Artifact 477b2e96b7e9b5c9a378b6712f1c998bbff60f63bc650810949bc7ee56ebc0f4:

• File psl-1983/nmode/virtual-screen.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: 11808) [annotate] [blame] [check-ins using] [more...]

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