Artifact 588d56dbf7bdc3ccd09749c0e974299daf9285714fc01eb87777cedb3f228f68:

• File psl-1983/3-1/nmode/window-label.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 8540) [annotate] [blame] [check-ins using] [more...]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Window-Label.SL
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        31 January 1983
% Revised:     14 March 1983
%
% A Window-Label object maintains the "label" portion of a buffer-window.
% This always occupies the lowermost "n" lines of the virtual screen,
% where "n" is 1 by default in this implementation.
%
% 14-Mar-83 Alan Snyder
%  Extend to handle buffers with no name.  Extend to display label-string 
%  attribute of buffers.
% 16-Feb-83 Alan Snyder
%  Declare -> Declare-Flavor.
% 10-Feb-83 Alan Snyder
%  Fix bug: minor modes did not display.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(BothTimes (load objects))
(CompileTime (load fast-int fast-vectors fast-strings display-char))

(de create-window-label (w)
  % Create a window-label object that will maintain the label portion
  % of the specified buffer-window.
  (make-instance 'window-label 'window w))

(defflavor window-label
  (window			% the buffer-window object

   (height 1)			% number of screen rows occupied by the label
   minrow			% location of top row of the label
   maxrow			% location of the bottom row of the label
   width			% width of the screen
   maxcol			% highest numbered screen column

   pos				% current position while writing label
   screen			% output screen while writing label

   (label-enhancement (dc-make-enhancement-mask INVERSE-VIDEO))
   (prompt-enhancement (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY))

   % The following instance variables store the various information used
   % in the construction of the label as currently displayed.  This information
   % is saved so that it can be compared against the current information
   % to determine whether the displayed label needs to be recomputed.

   (buffer-name NIL)		% name of buffer (as displayed)
   (buffer-mode NIL)		% buffer's mode (as displayed)
   (minor-modes NIL)		% minor mode list (as displayed)
   (buffer-file NIL)		% buffer's filename (as displayed)
   (buffer-top NIL)		% buffer-top (as used in label)
   (buffer-left NIL)		% buffer-left (as used in label)
   (buffer-size NIL)		% current buffer size (as used in label)
   (buffer-modified NIL)	% buffer-modified flag (as used in label)
   (current-window NIL)		% current-window (at time label was written)
   (prompt-string NIL)		% PromptString* (at time label was written)
   (label-string NIL)		% label-string attribute of buffer
   (browser-filter-count NIL)	% filter count for browser buffer
   )
  ()
  (gettable-instance-variables
   height
   )
  (settable-instance-variables
   label-enhancement
   prompt-enhancement
   )
  (initable-instance-variables
   window
   height
   )
  )

(fluid '(nmode-major-window nmode-output-buffer nmode-minor-modes))

(declare-flavor text-buffer buffer)
(declare-flavor buffer-window window)
(declare-flavor virtual-screen screen)
(declare-flavor browser browser)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Public methods:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (window-label refresh) ()

  % Update the label are to correspond to the
  % current state of the attached buffer window.
  % Conditionally rewrite the entire label, if any relevant
  % information has changed.

  (let* ((buffer (=> window buffer))
	 (browser (=> buffer get 'browser))
	 )
    (if (not (and (eq buffer-name (=> buffer name))
		  (eq buffer-mode (=> buffer mode))
		  (eq minor-modes nmode-minor-modes)
		  (eq buffer-file (=> buffer file-name))
		  (= buffer-top (=> window buffer-top))
		  (= buffer-left (=> window buffer-left))
		  (= buffer-size (=> buffer visible-size))
		  (eq buffer-modified (=> buffer modified?))
		  (eq current-window nmode-major-window)
		  (eq prompt-string PromptString*)
		  (eq label-string (=> buffer label-string))
		  (eq browser-filter-count
		      (when browser (=> browser filter-count)))
		  ))
      (=> self &rewrite)
      )))

(defmethod (window-label resize) ()
  % This method must be invoked whenever the window's size may have changed.
  (setf screen (=> window screen))
  (setf width (=> screen width))
  (setf maxrow (- (=> screen height) 1))
  (setf minrow (- maxrow (- height 1)))
  (setf maxcol (- width 1))
  (setf buffer-name T) % force complete rewrite
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Private methods:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (window-label init) (init-plist)
  (=> self resize)
  )

(defmethod (window-label &rewrite) ()
  % Unconditionally rewrite the entire label.
  (let* ((buffer (=> window buffer))
	 (browser (=> buffer get 'browser))
	 )
    (setf screen (=> window screen))
    (setf buffer-name (=> buffer name))
    (setf buffer-mode (=> buffer mode))
    (setf minor-modes nmode-minor-modes)
    (setf buffer-file (=> buffer file-name))
    (setf buffer-top (=> window buffer-top))
    (setf buffer-left (=> window buffer-left))
    (setf buffer-size (=> buffer visible-size))
    (setf buffer-modified (=> buffer modified?))
    (setf current-window nmode-major-window)
    (if PromptString* (setf prompt-string PromptString*))
    (setf label-string (=> buffer label-string))
    (setf browser-filter-count (when browser (=> browser filter-count)))
    (let ((old-enhancement (=> screen default-enhancement)))
      (=> screen set-default-enhancement label-enhancement)
      (setf pos 0)
      (if (eq window current-window)
	(=> self &write-string "NMODE ")
	(=> self &write-string "      "))
      (=> self &write-string (=> buffer-mode name))
      (if (and minor-modes (eq window current-window))
	(let ((leader-string " ("))
	  (for (in minor-mode minor-modes)
	       (do 
		(=> self &write-string leader-string)
		(setf leader-string " ")
		(=> self &write-string (=> minor-mode name))
		))
	  (=> self &write-string ")")
	  ))
      % Omit the buffer name if it is directly derived from the file name.
      (cond ((and buffer-name
		  (or (not buffer-file)
		      (not (string= buffer-name
				    (filename-to-buffername buffer-file)))
		      ))
	     (=> self &write-string " [")
	     (=> self &write-string buffer-name)
	     (=> self &write-string "]")
	     ))
      (when buffer-file
	(=> self &write-string " ")
	(=> self &write-string buffer-file)
	)
      (when (and label-string (not (string-empty? label-string)))
	(=> self &write-string " ")
	(=> self &write-string label-string)
	)
      (when (and browser-filter-count (> browser-filter-count 0))
	(=> self &write-string
	    (bldmsg " <%w %w>"
		    browser-filter-count
		    (if (~= browser-filter-count 1) "filters" "filter")
		    ))
	)
      (when (> buffer-left 0)
	(=> self &write-string (bldmsg " >%d" buffer-left))
	)
      (cond
       ((and (= buffer-top 0) (<= buffer-size (=> window height)))
	% The entire buffer is showing on the screen.
	% Do nothing.
	)
       ((= buffer-top 0)
	% The window is showing the top end of the buffer.
	(=> self &write-string " --TOP--")
	)
       ((>= buffer-top (- buffer-size (=> window height)))
	% The window is showing the bottom end of the buffer.
	(=> self &write-string " --BOT--")
	)
       (t % Otherwise...
	(let ((percentage (/ (* buffer-top 100) buffer-size)))
	  (=> self &write-string " --")
	  (=> self &write-char (+ #/0 (/ percentage 10)))
	  (=> self &write-char (+ #/0 (// percentage 10)))
	  (=> self &write-string "%--")
	  )))
      (if buffer-modified
	(=> self &write-string " *"))
      (when (and (StringP prompt-string) (eq buffer nmode-output-buffer))
	(=> self &write-string " ")
	(=> self &advance-pos (- width (string-length prompt-string)))
	(=> screen set-default-enhancement prompt-enhancement)
	(=> self &write-string prompt-string)
	)
      (=> screen clear-to-eol maxrow pos)
      (=> screen set-default-enhancement old-enhancement)
      )))

(defmethod (window-label &write-string) (string)
  (for (from i 0 (string-upper-bound string))
       (do (=> screen write (string-fetch string i) maxrow pos)
	   (setf pos (+ pos 1))
	   )))

(defmethod (window-label &write-char) (ch)
  (=> screen write ch maxrow pos)
  (setf pos (+ pos 1))
  )

(defmethod (window-label &advance-pos) (col)
  (while (< pos col) (=> self &write-char #\space))
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(undeclare-flavor buffer screen window browser)