Artifact 588d56dbf7bdc3ccd09749c0e974299daf9285714fc01eb87777cedb3f228f68:


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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)


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]