reduce-historical/psl-1983/nmode/virtual-screen.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Virtual-Screen.SL
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        18 August 1982
% Revised:     16 February 1983
%
% Inspired by Will Galway's EMODE Virtual Screen package.
%
% A virtual screen is an object that can be used as independent rectangular
% character display, but in fact shares a physical screen with other objects.  A
% virtual screen object maintains a stored representation of the image on the
% virtual screen, which is used to update the physical screen when new areas of
% the virtual screen become "exposed".  A virtual screen does not itself
% maintain any information about changes to its contents.  It sends all changes
% directly to the physical screen as they are made, and sends the entire screen
% contents to the physical screen upon its request.
%
% A virtual screen is a legitimate "owner" for a shared physical screen, in that
% it satisfies the required interface.
%
% 16-Feb-83 Alan Snyder
%  Declare -> Declare-Flavor.
% 28-Dec-82 Alan Snyder
%  Avoid writing to shared screen when virtual screen is not exposed.  Add
%  WRITE-STRING and WRITE-VECTOR methods.  Improve efficiency of CLEAR-TO-EOL
%  method.  Remove patch that avoided old compiler bug.  Reformat.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

(de create-virtual-screen (shared-physical-screen)
  (make-instance 'virtual-screen 'screen shared-physical-screen))

(defflavor virtual-screen
  ((height (=> screen height))	% number of rows (0 indexed)
   maxrow			% highest numbered row
   (width (=> screen width))	% number of columns (0 indexed)
   maxcol			% highest numbered column
   (row-origin 0)		% position of upper left on the shared screen
   (column-origin 0)		% position of upper left on the shared screen
   (default-enhancement (=> screen normal-enhancement))
   (cursor-row 0)		% the virtual cursor position
   (cursor-column 0)		% the virtual cursor position
   (exposed? NIL)
   image			% the virtual image
   screen        	        % the shared-physical-screen
   )
  ()
  (gettable-instance-variables height width row-origin column-origin screen
			       exposed?)
  (settable-instance-variables default-enhancement)
  (initable-instance-variables height width row-origin column-origin screen
			       default-enhancement)
  )

(declare-flavor shared-physical-screen screen)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Private Macros:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmacro image-fetch (image row col)
  `(vector-fetch (vector-fetch ,image ,row) ,col))
(defmacro image-store (image row col value)
  `(vector-store (vector-fetch ,image ,row) ,col ,value))

(dm for-all-positions (form)
  % Executes the body repeatedly with the following variables
  % bound: ROW, COL, SCREEN-ROW, SCREEN-COL.
  `(for (from row 0 maxrow)
        (with screen-row)
        (do (setf screen-row (+ row-origin row))
	    (for (from col 0 maxcol)
		 (with screen-col ch)
	         (do (setf screen-col (+ column-origin col))
		     ,@(cdr form)
		     )))))

(dm for-all-columns (form)
  % Executes the body repeatedly with the following variables
  % bound: COL, SCREEN-COL.
  `(for (from col 0 maxcol)
        (with screen-col ch)
        (do (setf screen-col (+ column-origin col))
	    ,@(cdr form)
	    )))

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

(defmethod (virtual-screen set-size) (new-height new-width)
  % Change the size of the screen.  The screen is first DeExposed.  The contents
  % are cleared.  You must Expose the screen yourself if you want it to be
  % displayed.

  (=> self deexpose)
  (setf height new-height)
  (setf width new-width)
  (=> self &new-size)
  )

(defmethod (virtual-screen set-origin) (new-row new-column)
  % Change the location of the screen.  The screen is first DeExposed.  You must
  % Expose the screen yourself if you want it to be displayed.

  (=> self deexpose)
  (setf row-origin new-row)
  (setf column-origin new-column)
  )

(defmethod (virtual-screen set-cursor-position) (row column)
  (cond ((< row 0) (setf row 0))
	((> row maxrow) (setf row maxrow)))
  (cond ((< column 0) (setf column 0))
	((> column maxcol) (setf column maxcol)))
  (setf cursor-row row)
  (setf cursor-column column)
  )

(defmethod (virtual-screen write) (ch row column)
  % Write one character using the default enhancement.
  (if (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol))
    (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF)))
	  (screen-row (+ row row-origin))
          )
      (setq dc (=> screen convert-character dc))
      (image-store image row column dc)
      (if exposed?
	(=> screen write dc screen-row (+ column column-origin) self))
      )))

(defmethod (virtual-screen write-range) (ch row left-column right-column)
  % Write repeatedly.
  (when (and (>= row 0)
	     (<= row maxrow)
	     (<= left-column maxcol)
	     (>= right-column 0)
	     )
    (if (< left-column 0) (setf left-column 0))
    (if (> right-column maxcol) (setf right-column maxcol))
    (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF)))
	  (screen-row (+ row row-origin))
          )
      (setq dc (=> screen convert-character dc))
      (for (from col left-column right-column)
	   (do (image-store image row col dc)
	       (if exposed?
		 (=> screen write dc screen-row (+ col column-origin) self))
	       )))))

(defmethod (virtual-screen write-display-character) (dc row column)
  % Write one character (explicit enhancement)
  (when (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol))
    (setq dc (=> screen convert-character dc))
    (image-store image row column dc)
    (if exposed?
      (=> screen write dc (+ row row-origin) (+ column column-origin) self))
    ))

(defmethod (virtual-screen write-string) (row left-column s count)
  % S is a string of characters. Write S[0..COUNT-1] using the default
  % enhancement to the specified row, starting at the specified column.

  (when (and (> count 0)
	     (>= row 0)
	     (<= row maxrow)
	     (<= left-column maxcol)
	     (> (+ left-column count) 0)
	     )
    (let ((smax (- count 1))
	  (image-row (vector-fetch image row))
	  (screen-row (+ row row-origin))
	  )
      (if (< left-column 0) (setf left-column 0))
      (if (> (+ left-column smax) maxcol)
	(setf smax (- maxcol left-column)))
      (for (from i 0 smax)
	   (for col left-column (+ col 1))
	   (for screen-col (+ left-column column-origin) (+ screen-col 1))
	   (do
	    (let ((ch (string-fetch s i)))
	      (setf ch (display-character-cons default-enhancement 0 ch))
	      (setf ch (=> screen convert-character ch))
	      (vector-store image-row col ch)
	      (if exposed?
		(=> screen write ch screen-row screen-col self))
	      ))))))

(defmethod (virtual-screen write-vector) (row left-column v count)
  % V is a vector of display-characters. Write V[0..COUNT-1] to the specified
  % row, starting at the specified column.

  (when (and (> count 0)
	     (>= row 0)
	     (<= row maxrow)
	     (<= left-column maxcol)
	     (> (+ left-column count) 0)
	     )
    (let ((vmax (- count 1))
	  (image-row (vector-fetch image row))
	  (screen-row (+ row row-origin))
	  )
      (if (< left-column 0) (setf left-column 0))
      (if (> (+ left-column vmax) maxcol)
	(setf vmax (- maxcol left-column)))
      (for (from i 0 vmax)
	   (for col left-column (+ col 1))
	   (for screen-col (+ left-column column-origin) (+ screen-col 1))
	   (do
	    (let ((ch (vector-fetch v i)))
	      (vector-store image-row col ch)
	      (if exposed?
		(=> screen write ch screen-row screen-col self))
	      ))))))

(defmethod (virtual-screen clear) ()
  (let ((dc (display-character-cons default-enhancement 0 #\space)))
    (setq dc (=> screen convert-character dc))
    (for-all-positions
     (image-store image row col dc)
     )
    (if exposed?
      (for-all-positions
       (=> screen write dc screen-row screen-col self)
       ))
    ))

(defmethod (virtual-screen clear-to-end) (first-row)
  (if (< first-row 0) (setf first-row 0))
  (let ((dc (display-character-cons default-enhancement 0 #\space)))
    (setq dc (=> screen convert-character dc))
    (for (from row first-row maxrow)
         (with screen-row)
         (do (setf screen-row (+ row-origin row))
             (for-all-columns
	      (image-store image row col dc)
	      )
	     (if exposed?
	       (for-all-columns
		(=> screen write dc screen-row screen-col self)
		))
	     ))))

(defmethod (virtual-screen clear-to-eol) (row first-column)
  (when (and (>= row 0) (<= row maxrow))
    (if (< first-column 0) (setf first-column 0))
    (let ((dc (display-character-cons default-enhancement 0 #\space))
	  (image-row (vector-fetch image row))
	  )
      (setq dc (=> screen convert-character dc))
      (for (from col first-column maxcol)
	   (do (vector-store image-row col dc)))
      (if exposed?
	(let ((screen-row (+ row row-origin)))
	  (for
	   (from col (+ first-column column-origin) (+ maxcol column-origin))
	   (do (=> screen write dc screen-row col self)))))
      )))

(defmethod (virtual-screen expose) ()
  % Expose the screen.  Make it overlap all other screens.
  (=> screen select-primary-owner self)
  (setf exposed? T)
  )

(defmethod (virtual-screen deexpose) ()
  % Remove the screen from the display.
  (when exposed?
    (=> screen remove-owner self)
    (setf exposed? NIL)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Semi-Private methods:
% The following methods are for use ONLY by the shared physical screen.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(defmethod (virtual-screen send-changes) (breakout-allowed)
  % This method is invoked by the shared physical screen to obtain any buffered
  % changes to the virtual screen image.  Since the virtual screen does not
  % buffer any changes, this method does nothing.
  )

(defmethod (virtual-screen send-contents) (breakout-allowed)
  % This method is invoked by the shared physical screen to obtain the entire
  % virtual screen image.
  (for-all-positions
   (let ((ch (image-fetch image row col)))
     (=> screen write ch screen-row screen-col self)
     )))

(defmethod (virtual-screen assert-ownership) ()
  % This method is invoked by the shared physical screen to obtain the desired
  % area for the virtual screen.
  (=> screen set-owner-region row-origin column-origin height width self)
  )

(defmethod (virtual-screen screen-cursor-position) ()
  % This method is invoked by the shared physical screen to obtain the desired
  % cursor position for the virtual screen.
  (cons
   (+ cursor-row row-origin)
   (+ cursor-column column-origin)
   ))

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

(defmethod (virtual-screen init) (init-plist)
  (=> self &new-size)
  )

(defmethod (virtual-screen &new-size) ()
  (if (< height 0) (setf height 0))
  (if (< width 0) (setf width 0))
  (setf maxrow (- height 1))
  (setf maxcol (- width 1))
  (setf image (make-vector maxrow NIL))
  (let ((line (make-vector maxcol #\space)))
    (for (from row 0 maxrow)
	 (do (vector-store image row (copyvector line))))
    )
  )

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

(undeclare-flavor screen)