;;; -*- Mode: LISP; Package: TV; Base: 8 -*-
;;;	** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; A scroll window displays a section of a database.  The user can dynamically
;;; change what is displayed on the window.

;;; The datastructure consists of items.  Each item represents an integral number
;;; of lines.  Each item is:
;;;  A) An array consisting of scroll entries (described later)
;;;  B) A list of items

;;; The scroll window knows only about one item:  in general for this to be useful
;;; this item is of form B

(DEFVAR SCROLL-NEW-X)
(DEFVAR SCROLL-NEW-Y)

(DEFVAR SCROLL-DEFAULT-VALUE-ARRAY-SIZE 100.)
(DEFSUBST VALUE (N) (AREF VALUE-ARRAY N))

(DEFMACRO SCROLL-LINE () `(SHEET-LINE-NO))

(DEFMACRO SCROLL-ITEM-SIZE (ITEM) `(ARRAY-DIMENSION-N 1 ,ITEM))

;;; Things in item's leader
(DEFSTRUCT (SCROLL-ITEM-LEADER :ARRAY-LEADER (:CONSTRUCTOR NIL))
  SCROLL-ITEM-MOUSE-ITEMS
  SCROLL-ITEM-LINE-SENSITIVITY)
(DEFVAR SCROLL-ITEM-LEADER-OFFSET)
(SETQ SCROLL-ITEM-LEADER-OFFSET (GET 'SCROLL-ITEM-LEADER 'SI:DEFSTRUCT-SIZE))

(DEFMACRO SCROLL-FLAGS (ITEM) `(CAR ,ITEM))
(DEFMACRO SCROLL-ITEMS (ITEM) `(CDR ,ITEM))

(DEFSTRUCT (SCROLL-ENTRY :ARRAY)
  SCROLL-ENTRY-FUNCTION			;Function to call to hack entry
  SCROLL-ENTRY-RECOMPUTE-FUNCTION	;Function called to recompute item (sometimes unused)
  SCROLL-ENTRY-ARGS			;Args to above, also included is data
  SCROLL-ENTRY-LINES			;Number of lines entry spanned last time
  SCROLL-ENTRY-FINAL-X			;Final X position of cursor after this item
  SCROLL-ENTRY-FINAL-PRINTING-X		;Final X position after item was printed (may be
					; different from final-x if fixed width item)
  SCROLL-ENTRY-WIDTH			;Width of entry, or last width if variable width
  SCROLL-ENTRY-VARIABLE-WIDTH-P		;T if entry is variable width, else NIL
  SCROLL-ENTRY-DATA			;Data to be printed
  SCROLL-ENTRY-PRINTED-FORM		;The data stored in its printed form in case
					; the data isn't a string, and if the data is
					; variable width -- this makes outputting
					; a bit more efficient (Note: this is only used
					; when the item is variable width)
  SCROLL-ENTRY-PRINT-FORMAT		;Specification of how to print data
					; List of (prin1-or-princ base)
  SCROLL-ENTRY-MOUSE-INFO		;Mouse data if item is mouse sensitive
  )


(DEFFLAVOR BASIC-SCROLL-WINDOW ((DISPLAY-ITEM NIL) TOP-ITEM TARGET-TOP-ITEM BOTTOM-ITEM
				SCREEN-IMAGE SCREEN-LINES (TRUNCATION NIL)
				(VALUE-ARRAY NIL) (OUTPUT-LOCK NIL))
  ()
  (:INCLUDED-FLAVORS ESSENTIAL-WINDOW)
  (:GETTABLE-INSTANCE-VARIABLES DISPLAY-ITEM TRUNCATION)
  (:INITABLE-INSTANCE-VARIABLES DISPLAY-ITEM TRUNCATION))

(DEFFLAVOR SCROLL-WINDOW ()
  (FLASHY-SCROLLING-MIXIN BASIC-SCROLL-WINDOW BORDERS-MIXIN BASIC-SCROLL-BAR WINDOW)
  (:DOCUMENTATION :COMBINATION))

(DEFMETHOD (SCROLL-WINDOW :SCROLL-BAR-P) () T)

(DEFMETHOD (SCROLL-WINDOW :SCREEN-MANAGE) (&REST IGNORE) () )

(DEFMETHOD (BASIC-SCROLL-WINDOW :BEFORE :INIT) (PLIST)
  (SETQ TOP-ITEM NIL
	TARGET-TOP-ITEM 0)
  (OR VALUE-ARRAY (SETQ VALUE-ARRAY (MAKE-ARRAY NIL 'ART-Q SCROLL-DEFAULT-VALUE-ARRAY-SIZE)))
  (PUTPROP PLIST NIL ':BLINKER-P)
  (PUTPROP PLIST NIL ':MORE-P))

(DEFMETHOD (BASIC-SCROLL-WINDOW :AFTER :INIT) (IGNORE)
  (SCROLL-MAKE-SCREEN-IMAGE))

(DEFMETHOD (BASIC-SCROLL-WINDOW :SET-DISPLAY-ITEM) (NEW-DISPLAY-ITEM)
  (SETQ DISPLAY-ITEM NEW-DISPLAY-ITEM
	TOP-ITEM NIL
	TARGET-TOP-ITEM 0)
  (FUNCALL-SELF ':REDISPLAY T ':FORCE))

(DEFMETHOD (BASIC-SCROLL-WINDOW :SET-TRUNCATION) (NEW-VALUE)
  (SETQ TRUNCATION NEW-VALUE)
  (FUNCALL-SELF ':REDISPLAY T ':FORCE))

(DEFMETHOD (BASIC-SCROLL-WINDOW :SCROLL-POSITION) ()
  (PROG () (RETURN (OR TOP-ITEM 0)		;Item number at top
		   (SCROLL-TOTAL-ITEMS)		;Total number of items
		   LINE-HEIGHT			;Pixels per item
		   (IF TOP-ITEM			;Number currently displayed
		       (MAX 0 (- BOTTOM-ITEM TOP-ITEM))
		       1))))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SCROLL-WINDOW)
(DEFUN SCROLL-TOTAL-ITEMS ()
  (1- (SCROLL-REDISPLAY-ITEM-LOOP DISPLAY-ITEM 0 #'(LAMBDA (&REST IGNORE)) T 0)))
) ;End declare

(DEFMETHOD (BASIC-SCROLL-WINDOW :AFTER :REFRESH) (&OPTIONAL TYPE)
  (AND (OR (NOT RESTORED-BITS-P) (EQ TYPE ':SIZE-CHANGED))
       (SCROLL-REDISPLAY T)))

(DEFMETHOD (BASIC-SCROLL-WINDOW :REDISPLAY) (&OPTIONAL (FULL-P NIL) (FORCE-P NIL))
  (IF FORCE-P
      (SCROLL-REDISPLAY FULL-P)
      (DO () (())
	(LOCK-SHEET (SELF)
	  (OR (SHEET-OUTPUT-HELD-P SELF)
	      (RETURN (SCROLL-REDISPLAY FULL-P))))
	(FUNCALL-SELF ':OUTPUT-HOLD-EXCEPTION))))

(DEFMETHOD (BASIC-SCROLL-WINDOW :REDISPLAY-SELECTED-ITEMS) (ITEMS)
  (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
    (LET ((SCROLL-NEW-X) (SCROLL-NEW-Y)
	  (ITEM NIL))
      (SETQ TARGET-TOP-ITEM TOP-ITEM)
      (*CATCH 'END-OF-PAGE
	(DOTIMES (I SCREEN-LINES)
	  (COND ((AND (SETQ ITEM (CAR (MEMQ (AREF SCREEN-IMAGE I 0) ITEMS)))
		      (ZEROP (AREF SCREEN-IMAGE I 1)))
		 (SETQ SCROLL-NEW-Y (* I LINE-HEIGHT)
		       SCROLL-NEW-X 0)
		 (SCROLL-REDISPLAY-DISPLAY-ITEM ITEM (AREF SCREEN-IMAGE I 2)))))))))

(DEFMETHOD (BASIC-SCROLL-WINDOW :AFTER :REDISPLAY) (&REST IGNORE)
  (MOUSE-WAKEUP))

(DEFMETHOD (BASIC-SCROLL-WINDOW :AFTER :CHANGE-OF-SIZE-OR-MARGINS) (&REST IGNORE)
  (SCROLL-MAKE-SCREEN-IMAGE))

(DEFMETHOD (BASIC-SCROLL-WINDOW :BEFORE :CLEAR-SCREEN) ()
  (OR TARGET-TOP-ITEM (SETQ TARGET-TOP-ITEM TOP-ITEM))
  (SETQ TOP-ITEM NIL)
  (DOTIMES (I SCREEN-LINES)
    (ASET NIL SCREEN-IMAGE I 0)
    (ASET -1 SCREEN-IMAGE I 1)
    (ASET -1 SCREEN-IMAGE I 2)))

;;; At end of page simply throw
(DEFMETHOD (BASIC-SCROLL-WINDOW :END-OF-PAGE-EXCEPTION) (&REST IGNORE)
  (SETF (SHEET-END-PAGE-FLAG SELF) 0)
  (*THROW 'END-OF-PAGE T))

;;; If run over end of line, make sure room on next line
(DEFVAR *SCROLL-CURRENT-ITEM*)
(DEFVAR *SCROLL-CURRENT-ITEM-LINE*)
(DEFMETHOD (BASIC-SCROLL-WINDOW :BEFORE :END-OF-LINE-EXCEPTION) ()
  (COND (TRUNCATION
	 (*THROW 'END-OF-LINE T)))
  (COND (( (1+ (SCROLL-LINE)) SCREEN-LINES)
	 ;; We're really at the end of the page, nothing to do
	 )
	((NEQ *SCROLL-CURRENT-ITEM* (AREF SCREEN-IMAGE (1+ (SCROLL-LINE)) 0))
	 (SCROLL-FLUSH-ITEM-FROM-SCREEN-IMAGE *SCROLL-CURRENT-ITEM*)
	 (LET-GLOBALLY ((CURSOR-Y (+ CURSOR-Y LINE-HEIGHT)))
	   (FUNCALL-SELF ':INSERT-LINE)))
	(( (1+ *SCROLL-CURRENT-ITEM-LINE*) (AREF SCREEN-IMAGE (1+ (SCROLL-LINE)) 1))
	 (SCROLL-FLUSH-ITEM-FROM-SCREEN-IMAGE *SCROLL-CURRENT-ITEM*))))

(DEFMETHOD (BASIC-SCROLL-WINDOW :BEFORE :DELETE-LINE) (&OPTIONAL (N 1)
						       &AUX (CUR-LINE (SCROLL-LINE)))
  (DO ((L CUR-LINE (1+ L)))
      (( (+ L N) SCREEN-LINES))
    (ASET (AREF SCREEN-IMAGE (+ L N) 0) SCREEN-IMAGE L 0)
    (ASET (AREF SCREEN-IMAGE (+ L N) 1) SCREEN-IMAGE L 1)
    (ASET (AREF SCREEN-IMAGE (+ L N) 2) SCREEN-IMAGE L 2))
  (DOTIMES (I N)
    (ASET NIL SCREEN-IMAGE (- SCREEN-LINES (1+ I)) 0)
    (ASET -1 SCREEN-IMAGE (- SCREEN-LINES (1+ I)) 1)
    (ASET -1 SCREEN-IMAGE (- SCREEN-LINES (1+ I)) 2)))

(DEFMETHOD (BASIC-SCROLL-WINDOW :BEFORE :INSERT-LINE) (&OPTIONAL (N 1)
						       &AUX (CUR-LINE (SCROLL-LINE)))
  (DO ((L (- SCREEN-LINES N 1) (1- L))
       (I (1- SCREEN-LINES) (1- I)))
      ((< L CUR-LINE))
    (ASET (AREF SCREEN-IMAGE L 0) SCREEN-IMAGE I 0)
    (ASET (AREF SCREEN-IMAGE L 1) SCREEN-IMAGE I 1)
    (ASET (AREF SCREEN-IMAGE L 2) SCREEN-IMAGE I 2))
  (DO ((L CUR-LINE (1+ L)))
      (( L (+ CUR-LINE N)))
    (ASET NIL SCREEN-IMAGE L 0)
    (ASET -1 SCREEN-IMAGE L 1)
    (ASET -1 SCREEN-IMAGE L 2)))

;;; Scrolling from the mouse
(DEFMETHOD (BASIC-SCROLL-WINDOW :SCROLL-RELATIVE) (FROM TO)
  (OR TOP-ITEM
      ;; Redisplay if a redisplay hasn't been done recently
      (FUNCALL-SELF ':REDISPLAY))
  ;; Convert FROM into an item number, and TO into a target top item
  (SETQ FROM (COND ((EQ FROM ':TOP) TOP-ITEM)
		   ((EQ FROM ':BOTTOM) BOTTOM-ITEM)
		   ((NUMBERP FROM)
		    ;; Number of pixels down, convert into item number
		    (SCROLL-ITEM-NUMBER-AT-Y FROM))))
  (AND (EQ TO ':BOTTOM)
       (SETQ TO (1- (* SCREEN-LINES LINE-HEIGHT))))
  (SETQ TO (IF (EQ TO ':TOP)
	       FROM
	       ;; Find an item such that if we put it on the top, then the FROM item will be
	       ;; in the desired position.  This is an estimate only and not guaranteed to
	       ;; do exactly the right thing
	       (SCROLL-FIND-A-TOP-ITEM FROM (// TO LINE-HEIGHT))))
  (IF TO
      (FUNCALL-SELF ':SCROLL-TO TO)
      (BEEP)))

(DEFMETHOD (BASIC-SCROLL-WINDOW :SCROLL-TO) (TO &OPTIONAL (TYPE ':ABSOLUTE))
  (OR TOP-ITEM
      ;; Redisplay if a redisplay hasn't been done recently
      (FUNCALL-SELF ':REDISPLAY))
  (SETQ TARGET-TOP-ITEM (SELECTQ TYPE
			  (:ABSOLUTE TO)
			  (:RELATIVE (+ TO TOP-ITEM))
			  (OTHERWISE (FERROR NIL "~A is an unknown type of scrolling" TYPE))))
  (AND (< TARGET-TOP-ITEM 0) (SETQ TARGET-TOP-ITEM 0))
  (FUNCALL-SELF ':REDISPLAY))

(DEFMETHOD (BASIC-SCROLL-WINDOW :AFTER :NEW-SCROLL-POSITION) (&REST IGNORE)
  (MOUSE-WAKEUP))

(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SCROLL-WINDOW)
(DEFUN SCROLL-ITEM-NUMBER-AT-Y (Y &AUX IN)
  (SETQ Y (SHEET-LINE-NO NIL Y))
  (SETQ IN (AREF SCREEN-IMAGE Y 2))
  (IF (< IN 0)
      NIL
      IN))

(LOCAL-DECLARE ((SPECIAL SCROLL-ITEM-LIST SCROLL-ITEM-LONGEST-DISTANCE
			 SCROLL-ITEM-TARGET-DISTANCE SCROLL-ITEM-TARGET-ITEM))
(DEFUN SCROLL-FIND-A-TOP-ITEM (SCROLL-ITEM-TARGET-ITEM SCROLL-ITEM-TARGET-DISTANCE)
  (LET ((SCROLL-ITEM-LIST NIL)
	(SCROLL-ITEM-LONGEST-DISTANCE 0)
	(TARGET-TOP-ITEM 0))
    (*CATCH 'SCROLL-FIND-A-TOP-ITEM
	    (SCROLL-REDISPLAY-ITEM-LOOP DISPLAY-ITEM 0
					#'SCROLL-FIND-A-TOP-ITEM-INTERNAL NIL 0))))

(DEFUN SCROLL-FIND-A-TOP-ITEM-INTERNAL (ITEM ITEM-NUMBER)
  (COND ((= ITEM-NUMBER SCROLL-ITEM-TARGET-ITEM)
	 ;; Found the item of interest, put the last item on top.
	 (*THROW 'SCROLL-FIND-A-TOP-ITEM (CDAR (LAST SCROLL-ITEM-LIST))))
	(( SCROLL-ITEM-LONGEST-DISTANCE SCROLL-ITEM-TARGET-DISTANCE)
	 ;; We have enough items to make up the distance, throw away the last one and
	 ;; add in the new one
	 (LET ((LAST-ITEM (CAR (LAST SCROLL-ITEM-LIST))))
	   (SETQ SCROLL-ITEM-LONGEST-DISTANCE
		 (+ (- SCROLL-ITEM-LONGEST-DISTANCE
		       (SCROLL-ITEM-LINES (CAR LAST-ITEM)))
		    (SCROLL-ITEM-LINES ITEM)))
	   (SETQ SCROLL-ITEM-LIST (DELQ LAST-ITEM SCROLL-ITEM-LIST))
	   (PUSH (CONS ITEM ITEM-NUMBER) SCROLL-ITEM-LIST)))
	(T
	 ;; An item, we can use it
	 (PUSH (CONS ITEM ITEM-NUMBER) SCROLL-ITEM-LIST)
	 (SETQ SCROLL-ITEM-LONGEST-DISTANCE
	       (+ SCROLL-ITEM-LONGEST-DISTANCE (SCROLL-ITEM-LINES ITEM))))))

(DEFUN SCROLL-ITEM-LINES (ITEM &AUX (SUM 1))
  (DOTIMES (I (ARRAY-DIMENSION-N 1 ITEM))
    (SETQ SUM (+ SUM (OR (SCROLL-ENTRY-LINES (AREF ITEM I)) 1))))
  SUM)
) ;End local declare
) ;End declare

(DEFFLAVOR SCROLL-WINDOW-WITH-TYPEOUT ()
  (WINDOW-WITH-TYPEOUT-MIXIN SCROLL-WINDOW)
  (:DEFAULT-INIT-PLIST :TYPEOUT-WINDOW '(TYPEOUT-WINDOW 
					 :DEEXPOSED-TYPEOUT-ACTION (:EXPOSE-FOR-TYPEOUT)
					 :IO-BUFFER NIL))
  (:DOCUMENTATION :COMBINATION "A scroll window with a typeout window"))

(DEFMETHOD (SCROLL-WINDOW-WITH-TYPEOUT :AFTER :INIT) (IGNORE)
  (FUNCALL TYPEOUT-WINDOW ':SET-IO-BUFFER IO-BUFFER))

(DEFMETHOD (SCROLL-WINDOW-WITH-TYPEOUT :BEFORE :REDISPLAY) (&REST IGNORE)
  "If the typeout window is active, deexposed it, and make sure the redisplayer knows how many
lines were clobbered."
  (COND ((FUNCALL TYPEOUT-WINDOW ':ACTIVE-P)
	 (LET ((BR (MIN SCREEN-LINES
			(1+ (// (FUNCALL TYPEOUT-WINDOW ':BOTTOM-REACHED) LINE-HEIGHT)))))
	   (DOTIMES (L BR)
	     ;; Mark lines as clobbered
	     (ASET NIL SCREEN-IMAGE L 0)
	     (ASET -1 SCREEN-IMAGE L 1)
	     (ASET -1 SCREEN-IMAGE L 2))
	   (FUNCALL TYPEOUT-WINDOW ':DEACTIVATE)
	   (FUNCALL-SELF ':DRAW-RECTANGLE
			 (SHEET-INSIDE-WIDTH) (* BR LINE-HEIGHT)
			 0 0
			 ALU-ANDCA)))))

;;; All the work is done by the redisplayer
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SCROLL-WINDOW)
(DEFUN SCROLL-REDISPLAY (&OPTIONAL FULL-REDISPLAY &AUX (SCROLL-NEW-X 0) (SCROLL-NEW-Y 0))
  (SHEET-FORCE-ACCESS (SELF :NO-PREPARE)
   (LOCK-SHEET (SELF)
    (AND (OR FULL-REDISPLAY (NULL TOP-ITEM))
	 ;; If doing full redisplay then must clear whole screen
	 ;; :CLEAR-SCREEN will take care of forcing redisplay
	 (FUNCALL-SELF ':CLEAR-SCREEN))
    (WITHOUT-INTERRUPTS
      (COND ((NULL TOP-ITEM)
	     ;; Nothing on the screen now, will have to do whole thing
	     (AND (OR (NULL TARGET-TOP-ITEM)
		      (< TARGET-TOP-ITEM 0))
		  (SETQ TARGET-TOP-ITEM 0)))
	    ((OR (NULL TARGET-TOP-ITEM) (< TARGET-TOP-ITEM 0))
	     ;; No change in top line, just target for where we are
	     (SETQ TARGET-TOP-ITEM TOP-ITEM))))
    (*CATCH 'END-OF-PAGE
      (PROGN
	(SETQ BOTTOM-ITEM -1)
	(SCROLL-REDISPLAY-ITEM-LOOP DISPLAY-ITEM 0
				    #'SCROLL-REDISPLAY-DISPLAY-ITEM NIL 0)
	(SETQ BOTTOM-ITEM (1+ BOTTOM-ITEM))
	(AND SCROLL-NEW-X
	     (FUNCALL-SELF ':SET-CURSORPOS SCROLL-NEW-X SCROLL-NEW-Y))
	(FUNCALL-SELF ':CLEAR-EOL)
	(DO ((I (SCROLL-LINE) (1+ I)))
	    (( I SCREEN-LINES))
	  (*CATCH 'END-OF-PAGE (FUNCALL-SELF ':TYO #\CR))
	  (FUNCALL-SELF ':CLEAR-EOL)
	  (ASET NIL SCREEN-IMAGE I 0)
	  (ASET -1 SCREEN-IMAGE I 1)
	  (ASET -1 SCREEN-IMAGE I 2))))
    (SETQ TOP-ITEM TARGET-TOP-ITEM)
    (FUNCALL-SELF ':NEW-SCROLL-POSITION TOP-ITEM))))

(DEFUN SCROLL-REDISPLAY-ITEM-LOOP (ITEM CURRENT-COUNT FUNCTION NO-RECOMP &REST POSITION
				   &AUX FUN)
  "Loop over an item and it's inferiors until TARGET-TOP-ITEM has been reached,
then start doing the appropriate things to fix up the screen.  This may require
inserting and deleting lines, etc...  Returns what the number of the next item is."
  (COND ((NULL ITEM))
	((LISTP ITEM)
	 ;; A list of other items, recurse
	 (OR NO-RECOMP
	     (DO ((F (SCROLL-FLAGS ITEM) (CDDR F)))
		 ((NULL F))
	       (SELECTQ (CAR F)
		 (:FUNCTION (SETQ FUN (CADR F)))
		 (:PRE-PROCESS-FUNCTION (FUNCALL (CADR F) ITEM)))))
	 (DO ((ITEMS (SCROLL-ITEMS ITEM) (CDR ITEMS)))
	     ((NULL ITEMS))
	   (AND FUN
		(RPLACA ITEMS (FUNCALL FUN (CAR ITEMS) POSITION (LOCF (SCROLL-FLAGS ITEM)))))
	   (SETQ CURRENT-COUNT
		 (LEXPR-FUNCALL #'SCROLL-REDISPLAY-ITEM-LOOP
				(CAR ITEMS) CURRENT-COUNT FUNCTION NO-RECOMP 0 POSITION))
	   (FUNCALL-SELF ':HANDLE-EXCEPTIONS)
	   (SETF (FIRST POSITION) (1+ (FIRST POSITION)))))
	;; An item that really takes up space
	((> (SETQ CURRENT-COUNT (1+ CURRENT-COUNT)) TARGET-TOP-ITEM)
	 ;; This item is of interest
	 (FUNCALL FUNCTION ITEM (1- CURRENT-COUNT))))
  CURRENT-COUNT)

(DEFVAR SCROLL-SPACES (FORMAT NIL "~2000X"))

(DEFUN SCROLL-REDISPLAY-DISPLAY-ITEM (ITEM CURRENT-COUNT
					   &AUX CURRENT-LINE CURRENT-ITEM-LINE
				           FIRST-LINE FORCE-UPDATE OLD-LINE
					   ENTRY-NEEDS-UPDATING END-OF-ITEM)
  "Called with an item that might want to be on the screen.  CURSOR-Y set up correctly."
  (COND (( CURRENT-COUNT TARGET-TOP-ITEM)
	 ;; We wanna be on the screen
	 (SETQ FIRST-LINE (IF SCROLL-NEW-X
			      (// SCROLL-NEW-Y LINE-HEIGHT)
			      (SCROLL-LINE))
	       BOTTOM-ITEM CURRENT-COUNT)
	 (COND ((AND (SETQ OLD-LINE
			   (DO ((I FIRST-LINE (1+ I)))
			       (( I SCREEN-LINES) NIL)
			     (AND (EQ ITEM (AREF SCREEN-IMAGE I 0))
				  (ZEROP (AREF SCREEN-IMAGE I 1))
				  ;; If first line of this item on screen anywhere, then
				  ;; can move it to current line
				  (RETURN I))))
		     ( OLD-LINE FIRST-LINE))
		(AND SCROLL-NEW-X
		     (FUNCALL-SELF ':SET-CURSORPOS SCROLL-NEW-X SCROLL-NEW-Y))
		(SETQ SCROLL-NEW-X NIL
		      SCROLL-NEW-Y NIL)
		;; On screen but not in same position, move it up
		(FUNCALL-SELF ':DELETE-LINE (- OLD-LINE FIRST-LINE))))

	 ;; Now redisplay the item.
	 (SETQ CURRENT-LINE FIRST-LINE
	       CURRENT-ITEM-LINE 0)
	 (UNWIND-PROTECT
	   (PROGN
	     (DOTIMES (I (SCROLL-ITEM-SIZE ITEM))
	       (LET ((ENTRY (AREF ITEM I))
		     (WID) (CHANGED-P))
		 ;; Loop over all elements of the item
		 (SETQ ENTRY-NEEDS-UPDATING
		       (OR FORCE-UPDATE
			   (NEQ ITEM (AREF SCREEN-IMAGE CURRENT-LINE 0))
			   ( (AREF SCREEN-IMAGE CURRENT-LINE 1) CURRENT-ITEM-LINE)))
		 (COND ((NOT (OR (SETQ CHANGED-P (FUNCALL (SCROLL-ENTRY-FUNCTION ENTRY)
							  ':CHANGED-P ENTRY
							  (SCROLL-ENTRY-FUNCTION ENTRY)))
				 ENTRY-NEEDS-UPDATING))
			;; Entry didn't change, but take into account how many
			;; lines it takes up
			(LET ((SEL (SCROLL-ENTRY-LINES ENTRY)))
			  (IF (AND TRUNCATION (> SEL 0))
			      ;; Spans more than one line, and truncating -- punt
			      (SETQ END-OF-ITEM T)
			      (SETQ CURRENT-ITEM-LINE (+ SEL CURRENT-ITEM-LINE)
				    CURRENT-LINE (+ SEL CURRENT-LINE))
			      (SETQ SCROLL-NEW-X (- (SCROLL-ENTRY-FINAL-X ENTRY)
						    (SHEET-INSIDE-LEFT))
				    SCROLL-NEW-Y (+ (OR SCROLL-NEW-Y
							(- CURSOR-Y (SHEET-INSIDE-TOP)))
						    (* LINE-HEIGHT SEL))))))
		       ;; Set cursor to correct place, and continue with COND
		       ((PROG1 NIL
			       (AND SCROLL-NEW-X
				    (FUNCALL-SELF ':SET-CURSORPOS SCROLL-NEW-X SCROLL-NEW-Y))
			       (SETQ SCROLL-NEW-X NIL
				     SCROLL-NEW-Y NIL)))		       
		       ;; Entry needs updating, decide whether variable width or not
		       ((AND CHANGED-P
			     (SCROLL-ENTRY-VARIABLE-WIDTH-P ENTRY)
			     ( (SCROLL-ENTRY-WIDTH ENTRY)
				(SETQ WID (FUNCALL (SCROLL-ENTRY-FUNCTION ENTRY) ':WIDTH
						   ENTRY (SCROLL-ENTRY-FUNCTION ENTRY)))))
			;; Variable width entry, and the width changed, force
			;; complete update of rest of item
			(SETQ FORCE-UPDATE T)
			(SETF (SCROLL-ENTRY-WIDTH ENTRY) WID)
			(FUNCALL-SELF ':CLEAR-EOL)
			(SCROLL-FLUSH-ITEM-FROM-SCREEN-IMAGE ITEM)
			(LET ((*SCROLL-CURRENT-ITEM* ITEM)
			      (*SCROLL-CURRENT-ITEM-LINE* CURRENT-ITEM-LINE))
			  (SETQ END-OF-ITEM
				(*CATCH 'END-OF-LINE
				  (PROGN
				    (FUNCALL (SCROLL-ENTRY-FUNCTION ENTRY) ':PRINT ENTRY)
				    NIL))))			      
			(SETF (SCROLL-ENTRY-FINAL-X ENTRY) CURSOR-X)
			(SETF (SCROLL-ENTRY-FINAL-PRINTING-X ENTRY) CURSOR-X)
			(SETF (SCROLL-ENTRY-LINES ENTRY) (- (SCROLL-LINE) CURRENT-LINE))
			(SETQ CURRENT-LINE (SCROLL-LINE)
			      CURRENT-ITEM-LINE (+ (SCROLL-ENTRY-LINES ENTRY)
						   CURRENT-ITEM-LINE)))
		       (T
			;; Fixed width entry, or variable width entry and width hasn't changed
			;; Using the width, figure out the cursor motion and erase area
			(MULTIPLE-VALUE-BIND (FINAL-X FINAL-Y FINAL-COUNT)
			    (SHEET-COMPUTE-MOTION SELF NIL NIL SCROLL-SPACES
						  0 (SCROLL-ENTRY-WIDTH ENTRY)
						  NIL
						  (IF TRUNCATION
						      (- (SHEET-INSIDE-RIGHT) CHAR-WIDTH)
						      0)
						  (IF TRUNCATION
						      (- CURSOR-Y (SHEET-INSIDE-TOP))
						      NIL))
			  (SETQ FINAL-X (+ FINAL-X (SHEET-INSIDE-LEFT))
				FINAL-Y (+ FINAL-Y (SHEET-INSIDE-TOP))
				END-OF-ITEM (AND (NUMBERP FINAL-COUNT)
						 ( FINAL-COUNT (SCROLL-ENTRY-WIDTH ENTRY))))
			  (AND (> FINAL-Y (- (SHEET-INSIDE-BOTTOM) LINE-HEIGHT))
			       (SETQ FINAL-X (SHEET-INSIDE-RIGHT)
				     FINAL-Y (- (SHEET-INSIDE-BOTTOM) LINE-HEIGHT)))
			  (SETF (SCROLL-ENTRY-FINAL-X ENTRY) FINAL-X)
			  (SETF (SCROLL-ENTRY-LINES ENTRY)
				(- (SHEET-LINE-NO NIL FINAL-Y) CURRENT-LINE))
			  ;; Zero the area
			  (PREPARE-SHEET (SELF)
			    (DO ((Y CURSOR-Y (+ Y LINE-HEIGHT))
				 (LINE 0 (1+ LINE))
				 (X CURSOR-X (SHEET-INSIDE-LEFT))
				 (LE) (DELTA-ITEMS))
				((> Y FINAL-Y))
			      (SETQ LE (AREF SCREEN-IMAGE (+ CURRENT-LINE LINE) 0))
			      (COND ((OR (AND (EQ LE ITEM)
					      (= (AREF SCREEN-IMAGE (+ CURRENT-LINE LINE) 1)
						 (+ CURRENT-ITEM-LINE LINE)))
					 (NULL LE))
				     ;; We know about this line so just clear the area
				     (%DRAW-RECTANGLE (- (IF (= Y FINAL-Y)
							     FINAL-X
							     (SHEET-INSIDE-RIGHT))
							 X)
						      LINE-HEIGHT X Y ALU-ANDCA SELF))
				    ((EQ LE ITEM)
				     ;; We own line, but it is wrong number.  Clear the line
				     ;; and flush all knowledge
				     (%DRAW-RECTANGLE (- (SHEET-INSIDE-RIGHT) X) LINE-HEIGHT
						      X Y ALU-ANDCA SELF)
				     (SCROLL-FLUSH-ITEM-FROM-SCREEN-IMAGE ITEM))
				    (T
				     ;; Make room for remaining number of lines and return
				     (SETQ DELTA-ITEMS
					   (- (AREF SCREEN-IMAGE (+ CURRENT-LINE LINE) 2)
					      CURRENT-COUNT))
				     ;; DELTA-ITEMS is a guess as to the number of items
				     ;; in between this and the line it collided with.  
				     ;; Assuming one line per item, this is a good guess as
				     ;; to the number of additional lines to insert
				     (LET-GLOBALLY ((CURSOR-Y Y))
				       (FUNCALL-SELF ':INSERT-LINE
					 ;; If we are past the item that's on this line, it
					 ;; can't possibly appear on the screen -- insert 
					 ;; enough lines to make it go off the screen
					 (MAX 1 (MIN (+ (// (- FINAL-Y Y) LINE-HEIGHT)
							(ABS DELTA-ITEMS))
						     (- SCREEN-LINES (SCROLL-LINE))))))
				     (RETURN T)))))
			  (LET ((*SCROLL-CURRENT-ITEM* ITEM)
				(*SCROLL-CURRENT-ITEM-LINE* CURRENT-ITEM-LINE))
			    (COND ((*CATCH 'END-OF-LINE
				     (PROGN
				       (FUNCALL (SCROLL-ENTRY-FUNCTION ENTRY) ':PRINT ENTRY)
				       (SETQ CURRENT-ITEM-LINE (+ (SCROLL-ENTRY-LINES ENTRY)
								  CURRENT-ITEM-LINE)
					     CURRENT-LINE (+ (SCROLL-ENTRY-LINES ENTRY)
							     CURRENT-LINE))
				       (SETF (SCROLL-ENTRY-FINAL-PRINTING-X ENTRY) CURSOR-X)
				       (SETQ SCROLL-NEW-X (- FINAL-X (SHEET-INSIDE-LEFT))
					     SCROLL-NEW-Y (- FINAL-Y (SHEET-INSIDE-TOP)))
				       (FUNCALL-SELF ':HANDLE-EXCEPTIONS)
				       NIL))
				   (SETF (SCROLL-ENTRY-FINAL-PRINTING-X ENTRY) CURSOR-X)
				   (SETQ END-OF-ITEM T))))))))
	       (AND END-OF-ITEM (RETURN T)))
	     (SETQ SCROLL-NEW-X 0
		   SCROLL-NEW-Y (+ (OR SCROLL-NEW-Y (- CURSOR-Y (SHEET-INSIDE-TOP)))
				   LINE-HEIGHT))
	     (AND ( (1+ CURRENT-LINE) SCREEN-LINES)
		  (*THROW 'END-OF-PAGE T)))
	   (SETQ CURRENT-LINE (MIN CURRENT-LINE (1- SCREEN-LINES)))
	   (DO ((L FIRST-LINE (1+ L)))
	       ((> L CURRENT-LINE))
	     (ASET ITEM SCREEN-IMAGE L 0)
	     (ASET (- L FIRST-LINE) SCREEN-IMAGE L 1)
	     (ASET CURRENT-COUNT SCREEN-IMAGE L 2))))))

(DEFUN SCROLL-FLUSH-ITEM-FROM-SCREEN-IMAGE (ITEM)
  (DOTIMES (I SCREEN-LINES)
    (COND ((EQ (AREF SCREEN-IMAGE I 0) ITEM)
	   (ASET NIL SCREEN-IMAGE I 0)
	   (ASET -1 SCREEN-IMAGE I 1)
	   (ASET -1 SCREEN-IMAGE I 2)))))

(DEFUN SCROLL-MAKE-SCREEN-IMAGE ()
  (SETQ SCREEN-LINES (SHEET-NUMBER-OF-INSIDE-LINES))
  (SETQ SCREEN-IMAGE (MAKE-ARRAY NIL 'ART-Q `(,SCREEN-LINES 3)))
  (DOTIMES (I SCREEN-LINES)
    (ASET NIL SCREEN-IMAGE I 0)
    (ASET -1 SCREEN-IMAGE I 1)
    (ASET -1 SCREEN-IMAGE I 2)))

(DEFSELECT SCROLL-ENTRY-CONSTANT-STRING-FUNCTION
  (:PRINT (ENTRY)
    (FUNCALL-SELF ':STRING-OUT (SCROLL-ENTRY-DATA ENTRY)))
  (:RECOMPUTE (IGNORE) NIL)
  (:CHANGED-P (IGNORE IGNORE) NIL))

(DEFSELECT SCROLL-ENTRY-SYMBOL-VALUE-FUNCTION
  (:PRINT (ENTRY &AUX (DATA (SCROLL-ENTRY-PRINTED-FORM ENTRY))
		      (FORMAT (SCROLL-ENTRY-PRINT-FORMAT ENTRY)))
    (COND (DATA (FUNCALL-SELF ':STRING-OUT DATA))
	  (T
	   (LET ((BASE (OR (CADR FORMAT) BASE))
		 (*NOPOINT (OR (CADDR FORMAT) *NOPOINT)))
	     (SETQ DATA (SCROLL-ENTRY-DATA ENTRY))
	     (IF (CAR FORMAT)
		 (FORMAT SELF (CAR FORMAT) DATA)
		 (FORMAT SELF "~A" DATA))))))
  (:CHANGED-P (ENTRY US)
    (COND ((NOT (EQUAL (SCROLL-ENTRY-DATA ENTRY)
		       (FUNCALL US ':RECOMPUTE ENTRY)))
	   (SETF (SCROLL-ENTRY-PRINTED-FORM ENTRY) NIL)
	   T)
	  (T NIL)))    
  (:RECOMPUTE (ENTRY &AUX DATA)
    (SETQ DATA (SYMEVAL (SCROLL-ENTRY-RECOMPUTE-FUNCTION ENTRY)))
    (SETF (SCROLL-ENTRY-DATA ENTRY) DATA)
    DATA)
  (:WIDTH (ENTRY US &AUX DATA (FORMAT (SCROLL-ENTRY-PRINT-FORMAT ENTRY)))
    (SETQ DATA (FUNCALL US ':RECOMPUTE ENTRY))
    ;; Stream to return length
    (LET ((BASE (OR (CADR FORMAT) BASE))
	  (*NOPOINT (OR (CADDR FORMAT) *NOPOINT)))
;	 (SETF (SCROLL-ENTRY-PRINTED-FORM ENTRY)
;	       (SETQ DATA
;		     (IF (AND (STRINGP DATA) (NULL (CAR FORMAT)))
;			 DATA
;			 (IF (CAR FORMAT)
;			     (FORMAT NIL (CAR FORMAT) DATA)
;			     (FORMAT NIL "~A" DATA)))))
;	 (MULTIPLE-VALUE-BIND (IGNORE WIDTH)
;	     (SHEET-STRING-LENGTH SELF DATA)
;	   WIDTH))))
      (IF (AND (STRINGP DATA) (NULL (CAR FORMAT)))
	  (MULTIPLE-VALUE-BIND (IGNORE WIDTH)
	      (SHEET-STRING-LENGTH SELF DATA)
	    WIDTH)
	  (LET ((SI:*IOCH 0))
	    (IF (CAR FORMAT)
		(FORMAT 'SI:FLATSIZE-STREAM (CAR FORMAT) DATA)
		(FORMAT 'SI:FLATSIZE-STREAM "~A" DATA))
	    SI:*IOCH)))))

(DEFSELECT (SCROLL-ENTRY-CALL-FUNCTION-FUNCTION SCROLL-ENTRY-SYMBOL-VALUE-FUNCTION)
  (:RECOMPUTE (ENTRY &AUX DATA)
    (SETQ DATA (LEXPR-FUNCALL (SCROLL-ENTRY-RECOMPUTE-FUNCTION ENTRY)
			      (SCROLL-ENTRY-ARGS ENTRY)))
    (SETF (SCROLL-ENTRY-DATA ENTRY) DATA)
    DATA))
)  ;End of declare

;;; More sophisticated user interface functions
(DECLARE-FLAVOR-INSTANCE-VARIABLES (BASIC-SCROLL-WINDOW)
(DEFUN SCROLL-GET-ITEM-LOCATIVE (POSITION &AUX (ITEM (LOCATE-IN-INSTANCE SELF 'DISPLAY-ITEM)))
  (AND (NUMBERP POSITION) (SETQ POSITION (NCONS POSITION)))
  (DOLIST (C POSITION)
    (SETQ ITEM (LOCF (NTH (1+ C) (SCROLL-ITEMS (CAR ITEM))))))
  ITEM))

(DEFMETHOD (BASIC-SCROLL-WINDOW :GET-ITEM) (POSITION)
  "Given a position in the tree, returns the specified item."
  (CAR (SCROLL-GET-ITEM-LOCATIVE POSITION)))

(DEFMETHOD (BASIC-SCROLL-WINDOW :SET-ITEM) (POSITION NEW-ITEM)
  (RPLACA (SCROLL-GET-ITEM-LOCATIVE POSITION) NEW-ITEM)
  (FUNCALL-SELF ':REDISPLAY))

(DEFMETHOD (BASIC-SCROLL-WINDOW :INSERT-ITEM) (POSITION ITEM &AUX WHERE)
  "Inserts an item before the specified position."
  (AND (NUMBERP POSITION) (SETQ POSITION (NCONS POSITION)))
  (SETQ WHERE (LOCATE-IN-INSTANCE SELF 'DISPLAY-ITEM))
  (DOLIST (P POSITION)
    (DOTIMES (I P)
      (SETQ WHERE (LOCF (CDAR WHERE)))))
  (RPLACA WHERE (CONS ITEM (CAR WHERE)))
  (FUNCALL-SELF 'REDISPLAY))

(DEFMETHOD (BASIC-SCROLL-WINDOW :DELETE-ITEM) (POSITION &AUX WHERE)
  "Deletes the item at the specified position."
  (AND (NUMBERP POSITION) (SETQ POSITION (NCONS POSITION)))
  (SETQ WHERE (LOCATE-IN-INSTANCE SELF 'DISPLAY-ITEM))
  (DOLIST (P POSITION)
    (DOTIMES (I P)
      (SETQ WHERE (LOCF (CDAR WHERE)))))
  (RPLACA WHERE (CDAR WHERE))
  (FUNCALL-SELF ':REDISPLAY))

(DEFUN SCROLL-MAKE-ENTRY (&REST ELTS &AUX ENTRY)
  (SETQ ENTRY (MAKE-SCROLL-ENTRY))
  (FILLARRAY ENTRY ELTS)
  ENTRY)

(DEFUN SCROLL-INTERPRET-ENTRY (ENTRY ITEM &AUX MOUSE)
  "Given a descriptor (see documentation) returns an entry suitable for inclusion
in an array-type item."
  (COND-EVERY
   ((STRINGP ENTRY) (SETQ ENTRY (LIST ':STRING ENTRY)))
   ((SYMBOLP ENTRY) (SETQ ENTRY (LIST ':SYMEVAL ENTRY)))
   ((OR (= (%DATA-TYPE ENTRY) DTP-FEF-POINTER)
	(AND (LISTP ENTRY) (MEMQ (CAR ENTRY) '(LAMBDA NAMED-LAMBDA))))
    (SETQ ENTRY (LIST ':FUNCTION ENTRY)))
   ((LISTP ENTRY)
    (COND-EVERY ((EQ (FIRST ENTRY) ':MOUSE)
		 (SETQ MOUSE (SECOND ENTRY)
		       ENTRY (CDDR ENTRY)))
		((EQ (FIRST ENTRY) ':MOUSE-ITEM)
		 (SETQ MOUSE (SUBLIS `((ITEM . ,ITEM)) (CADR ENTRY))
		       ENTRY (CDDR ENTRY)))
		((EQ (FIRST ENTRY) ':VALUE)
		 (SETQ ENTRY `(:FUNCTION ,#'VALUE (,(SECOND ENTRY)) . ,(CDDR ENTRY)))))
    (SETQ ENTRY
	  (SELECTQ (FIRST ENTRY)
	    (:STRING (SCROLL-MAKE-ENTRY 'SCROLL-ENTRY-CONSTANT-STRING-FUNCTION NIL NIL 0 0 0
					(OR (THIRD ENTRY) (STRING-LENGTH (SECOND ENTRY)))
					NIL (SECOND ENTRY) NIL NIL NIL))
	    (:SYMEVAL (SCROLL-MAKE-ENTRY 'SCROLL-ENTRY-SYMBOL-VALUE-FUNCTION
					 (SECOND ENTRY) NIL
					 0 0 0 (OR (THIRD ENTRY) 0) (NULL (THIRD ENTRY))
					 (NCONS NIL) NIL (FOURTH ENTRY) NIL))
	    (:FUNCTION (SCROLL-MAKE-ENTRY 'SCROLL-ENTRY-CALL-FUNCTION-FUNCTION
					  (SECOND ENTRY) (THIRD ENTRY)
					  0 0 0 (OR (FOURTH ENTRY) 0) (NULL (FOURTH ENTRY))
					  (NCONS NIL) NIL (FIFTH ENTRY) NIL)))))
   (MOUSE
     (SETF (SCROLL-ENTRY-MOUSE-INFO ENTRY) MOUSE))
   (:OTHERWISE (FERROR NIL "Unknown kind of entry: ~S" ENTRY)))
  ENTRY)

(DEFUN SCROLL-PARSE-ITEM (&REST ITEM-SPEC &AUX ITEM (EXTRA-LEADER 0) LEADER-FILL
				               MOUSE MOUSE-SELF)
  "Given a list of entry descriptors, produce an array-type item."
  (SETQ ITEM-SPEC (DELQ NIL (COPYLIST ITEM-SPEC)))
  (DO ((L ITEM-SPEC (CDDR L)))
      ((NOT (SYMBOLP (CAR L)))
       (SETQ ITEM-SPEC L))
    (SELECTQ (CAR L)
      (:MOUSE (SETQ MOUSE (CADR L)))
      (:MOUSE-SELF (SETQ MOUSE-SELF T MOUSE (CADR L)))
      (:LEADER (SETQ EXTRA-LEADER
		     (IF (NUMBERP (CADR L))
			 (CADR L)
			 (SETQ LEADER-FILL (CADR L))
			 (LENGTH LEADER-FILL))))
      (OTHERWISE (FERROR NIL "~A is unknown keyword to SCROLL-PARSE-ITEM" (CAR L)))))
  (SETQ ITEM (MAKE-ARRAY NIL 'ART-Q (LENGTH ITEM-SPEC)
			 NIL (+ EXTRA-LEADER SCROLL-ITEM-LEADER-OFFSET)))
  (AND MOUSE-SELF (SETQ MOUSE (SUBLIS `((SELF . ,ITEM)) MOUSE)))
  (AND LEADER-FILL
       (DOTIMES (I EXTRA-LEADER)
	 (SETF (ARRAY-LEADER ITEM (+ SCROLL-ITEM-LEADER-OFFSET I)) (NTH I LEADER-FILL))))
  (SETF (SCROLL-ITEM-LINE-SENSITIVITY ITEM) MOUSE)
  (DOTIMES (I (LENGTH ITEM-SPEC))
    (ASET (SCROLL-INTERPRET-ENTRY (CAR ITEM-SPEC) ITEM) ITEM I)
    (SETQ ITEM-SPEC (CDR ITEM-SPEC)))
  ITEM)

(DEFUN SCROLL-STRING-ITEM-WITH-EMBEDDED-NEWLINES (STRING &AUX STRINGS ITEM)
  (DO ((NEXT (STRING-SEARCH-CHAR #\CR STRING)
	     (STRING-SEARCH-CHAR #\CR STRING (1+ NEXT)))
       (ONEXT 0 (1+ NEXT)))
      ((NULL NEXT)
       (AND (< ONEXT (STRING-LENGTH STRING))
	    (PUSH (NSUBSTRING STRING ONEXT) STRINGS)))
    (PUSH (NSUBSTRING STRING ONEXT NEXT) STRINGS))
  (DOLIST (STRING STRINGS)
    (PUSH (SCROLL-PARSE-ITEM STRING) ITEM))
  (LIST* () ITEM))

(DEFUN SCROLL-MAINTAIN-LIST-UNORDERED (INIT-FUN ITEM-FUN &OPTIONAL PER-ELT-FUN STEPPER)
  "Given a function that returns a list, and a function that returns an item spec
when given an element of that list, maintains one item for each element in the list.
This is not useful when recursion is necessary.  Returns an item that should be
inserted somewhere.  The LIST-FUN should return a private copy of the list."
  (LIST (LIST ':PRE-PROCESS-FUNCTION 'SCROLL-MAINTAIN-LIST-UNORDERED-UPDATE-FUNCTION
	      ':FUNCTION PER-ELT-FUN
	      ':INIT-FUNCTION INIT-FUN
	      ':ITEM-FUNCTION ITEM-FUN
	      ':OLD-STATE NIL
	      ':STEPPER-FUNCTION (OR STEPPER #'SCROLL-MAINTAIN-LIST-STEPPER))))


(DEFUNP SCROLL-MAINTAIN-LIST-STEPPER (STATE)
  (RETURN (CAR STATE) (CDR STATE) (NULL (CDR STATE))))

(DEFSTRUCT (STATE :LIST (:CONSTRUCTOR NIL))
  STATE-VALUE
  STATE-FLAG
  STATE-ITEM)

;;; **** The real PUTPROP ought'a work something like this
(DEFUN SCROLL-PUTPROP (PLIST NEW-VALUE &REST PROPERTY)
  (OR (NULL (CDR PROPERTY))
      (FERROR NIL "To many args to SCROLL-PUTPROP"))
  (LET ((OLD (GETL PLIST PROPERTY)))
    (IF (NULL OLD)
	(PUTPROP PLIST NEW-VALUE (CAR PROPERTY))
	(SETF (SECOND OLD) NEW-VALUE)
	NEW-VALUE)))

(DEFUN SCROLL-MAINTAIN-LIST-UNORDERED-UPDATE-FUNCTION (ITEM
						       &AUX (FLAGS-PLIST (LOCF (CAR ITEM))))
  (LET ((STEP-STATE (FUNCALL (GET FLAGS-PLIST ':INIT-FUNCTION)))
	(OLD-STATE (GET FLAGS-PLIST ':OLD-STATE))
	(ITEM-FUN (GET FLAGS-PLIST ':ITEM-FUNCTION))
	(STEPPER (GET FLAGS-PLIST ':STEPPER-FUNCTION)))
    ;; Clear out remembered state
    (DOLIST (E OLD-STATE)
      (SETF (STATE-FLAG E) NIL))
    ;; Loop over all items.  If one is found that doesn't exist, add it and
    ;; remember that.  Any that no longer exist need to be flushed.
    (DO ((CURRENT)
	 (LAST)
	 (STATE))
	((OR (NULL STEP-STATE) LAST))
      (MULTIPLE-VALUE (CURRENT STEP-STATE LAST) (FUNCALL STEPPER STEP-STATE))
      (IF (SETQ STATE (ASSQ CURRENT OLD-STATE))
	  (SETF (STATE-FLAG STATE) T)
	  ;; Doesn't exist.  Add it to the front of the list and add in the item
	  (LET ((NEW-ITEM (FUNCALL ITEM-FUN CURRENT)))
	    (PUSH (LIST CURRENT T NEW-ITEM) OLD-STATE)
	    (PUSH NEW-ITEM (SCROLL-ITEMS ITEM)))))
    (DOLIST (STATE OLD-STATE)
      ;; Delete all items that are no longer valid
      (COND ((NOT (STATE-FLAG STATE))
	     (SETF (SCROLL-ITEMS ITEM) (DELQ (STATE-ITEM STATE) (SCROLL-ITEMS ITEM)))
	     (SETQ OLD-STATE (DELQ STATE OLD-STATE)))))
    ;; ITEM and OLD-STATE have been updated.  Store back appropriate info.
    (SCROLL-PUTPROP FLAGS-PLIST OLD-STATE ':OLD-STATE)
    ITEM))

(DEFUN SCROLL-MAINTAIN-LIST (INIT-FUN ITEM-FUN
			     &OPTIONAL PER-ELT-FUN STEPPER COMPACT-P
				       (PRE-PROC-FUN 'SCROLL-MAINTAIN-LIST-UPDATE-FUNCTION))
									     
  "Given a function that returns a list, and a function that returns an item spec
when given an element of that list, maintains one item for each element in the list.
This is not useful when recursion is necessary.  Returns an item that should be
inserted somewhere.  The LIST-FUN should return a private copy of the list."
  (LIST (LIST ':PRE-PROCESS-FUNCTION PRE-PROC-FUN
	      ':FUNCTION PER-ELT-FUN
	      ':INIT-FUNCTION INIT-FUN
	      ':ITEM-FUNCTION ITEM-FUN
	      ':OLD-STATE NIL
	      ':COMPACT-P COMPACT-P
	      ':STEPPER-FUNCTION (OR STEPPER #'SCROLL-MAINTAIN-LIST-STEPPER))))

(DEFVAR SCROLL-LIST-AREA (MAKE-AREA ':NAME 'SCROLL-LIST-AREA))

(DEFUN SCROLL-MAINTAIN-LIST-UPDATE-FUNCTION (ITEM &AUX (FLAGS-PLIST (LOCF (CAR ITEM))))
  (LET* ((STEP-STATE (FUNCALL (GET FLAGS-PLIST ':INIT-FUNCTION)))
	 (OLD-STATE (LOCF (GET FLAGS-PLIST ':OLD-STATE)))
	 (ITEM-FUN (GET FLAGS-PLIST ':ITEM-FUNCTION))
	 (STEPPER (GET FLAGS-PLIST ':STEPPER-FUNCTION))
	 (COMPACT-P (GET FLAGS-PLIST ':COMPACT-P))
	 (ITEMS (LOCF (SCROLL-ITEMS ITEM))))
    ;; Loop over all items.  If one is found that doesn't exist, add it and
    ;; remember that.  Any that no longer exist need to be flushed.
    (DO ((CURRENT)
	 (NEEDS-COMPACTION NIL)
	 (LAST (NULL STEP-STATE))
	 (PREV-ITEM ITEMS)
	 (PREV-STATE OLD-STATE))
	(LAST
	  (RPLACD PREV-STATE NIL)
	  (RPLACD PREV-ITEM NIL)
	  (COND ((AND COMPACT-P NEEDS-COMPACTION)
		 (SETF (SCROLL-ITEMS ITEM) (COPYLIST (SCROLL-ITEMS ITEM) SCROLL-LIST-AREA))
		 (SETF (GET FLAGS-PLIST ':OLD-STATE)
		       (COPYLIST (GET FLAGS-PLIST ':OLD-STATE) SCROLL-LIST-AREA)))))
      (SETQ ITEMS (CDR ITEMS)
	    OLD-STATE (CDR OLD-STATE))
      (MULTIPLE-VALUE (CURRENT STEP-STATE LAST) (FUNCALL STEPPER STEP-STATE))
      (COND ((EQ (CAR OLD-STATE) CURRENT)
	     ;; No change, ok then
	     )
	    ((MEMQ CURRENT OLD-STATE)
	     ;; Is later on list, therefore must have deleted some things
	     (SETQ NEEDS-COMPACTION T)
	     (DO ()
		 ((EQ (CAR OLD-STATE) CURRENT))
	       (RPLACD PREV-STATE (SETQ OLD-STATE (CDR OLD-STATE)))
	       (RPLACD PREV-ITEM (SETQ ITEMS (CDR ITEMS)))))
	    (T
	     (SETQ NEEDS-COMPACTION T)
	     (RPLACD PREV-STATE (SETQ OLD-STATE (CONS-IN-AREA CURRENT (CDR PREV-STATE)
							      SCROLL-LIST-AREA)))
	     (RPLACD PREV-ITEM (SETQ ITEMS
				     (CONS-IN-AREA (FUNCALL ITEM-FUN CURRENT)
						   (CDR PREV-ITEM) SCROLL-LIST-AREA)))))
      
      (AND OLD-STATE (SETQ PREV-STATE OLD-STATE))
      (AND ITEMS (SETQ PREV-ITEM ITEMS)))
    ITEM))

(DEFUN SCROLL-MAINTAIN-LIST-UPDATE-STATES (STATES WINDOW
					   &OPTIONAL (DITEM (FUNCALL WINDOW ':DISPLAY-ITEM))
					   &AUX (FLAGS-PLIST (LOCF (CAR DITEM))))
  (LET ((OLD-STATE (LOCF (GET FLAGS-PLIST ':OLD-STATE)))
	(ITEMS (LOCF (SCROLL-ITEMS DITEM)))
	(ITEMS-TO-BE-REDISPLAYED NIL))
    (DOLIST (STATE OLD-STATE)
      (AND (MEMQ STATE STATES)
	   (PUSH (CAR ITEMS) ITEMS-TO-BE-REDISPLAYED))
      (SETQ ITEMS (CDR ITEMS)))
    (FUNCALL WINDOW ':REDISPLAY-SELECTED-ITEMS ITEMS-TO-BE-REDISPLAYED)))

;;; Mouse-menu stuff
(DEFFLAVOR ESSENTIAL-SCROLL-MOUSE-MIXIN ((ITEM-LIST NIL) (TYPE-ALIST) (ITEM-BLINKER NIL))
  ()
  (:INITABLE-INSTANCE-VARIABLES TYPE-ALIST ITEM-BLINKER)
  :GETTABLE-INSTANCE-VARIABLES
  :SETTABLE-INSTANCE-VARIABLES
  (:INCLUDED-FLAVORS BASIC-SCROLL-WINDOW SHEET))

(DEFFLAVOR SCROLL-MOUSE-MIXIN () (ESSENTIAL-SCROLL-MOUSE-MIXIN MENU-EXECUTE-MIXIN)
  (:DOCUMENTATION :MIXIN "Menu like scroll windows"))

(DEFMETHOD (ESSENTIAL-SCROLL-MOUSE-MIXIN :AFTER :INIT) (IGNORE)
  (SETQ ITEM-BLINKER (LEXPR-FUNCALL #'DEFINE-BLINKER SELF
				    (OR (CAR ITEM-BLINKER) 'HOLLOW-RECTANGULAR-BLINKER)
				    ':VISIBILITY NIL
				    (CDR ITEM-BLINKER))))

(DEFMETHOD (ESSENTIAL-SCROLL-MOUSE-MIXIN :AFTER :HANDLE-MOUSE) ()
  (BLINKER-SET-VISIBILITY ITEM-BLINKER NIL))

(DEFMETHOD (ESSENTIAL-SCROLL-MOUSE-MIXIN :MOUSE-SENSITIVE-ITEM) (X Y)
  (SCROLL-FIND-SENSITIVE-ITEM X Y))

(DEFMETHOD (ESSENTIAL-SCROLL-MOUSE-MIXIN :MOUSE-MOVES) (X Y)
  (MOUSE-SET-BLINKER-CURSORPOS)
  (MULTIPLE-VALUE-BIND (ITEM NIL LEFT TOP WID HEI)
      (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y)
    (AND TOP (SETQ TOP (1- TOP)))
    (COND (ITEM
	   (BLINKER-SET-CURSORPOS ITEM-BLINKER (- LEFT (SHEET-INSIDE-LEFT))
				  (- TOP (SHEET-INSIDE-TOP)))
	   (BLINKER-SET-SIZE ITEM-BLINKER WID HEI)
	   (BLINKER-SET-VISIBILITY ITEM-BLINKER T))
	  (T (BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)))))

(DEFVAR SCROLL-MOUSE-BUTTONS 0)
(DEFMETHOD (ESSENTIAL-SCROLL-MOUSE-MIXIN :MOUSE-BUTTONS) (BD X Y
						&AUX ITEM TYPE OP (SCROLL-MOUSE-BUTTONS BD))
  (COND ((= (SETQ BD (MOUSE-BUTTON-ENCODE BD)) #\MOUSE-3-2)
	 (MOUSE-CALL-SYSTEM-MENU))
	((AND (OR (= BD #\MOUSE-1-1) (= BD #\MOUSE-3-1))
	      (PROGN (MULTIPLE-VALUE (ITEM TYPE)
		       (FUNCALL-SELF ':MOUSE-SENSITIVE-ITEM X Y))
		     ITEM))
	 (COND ((NULL TYPE)
		(BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)
		(FUNCALL-SELF ':EXECUTE ITEM))
	       ((SETQ OP (FIRST (CDR (ASSQ TYPE TYPE-ALIST))))
		(BLINKER-SET-VISIBILITY ITEM-BLINKER NIL)
		(FUNCALL-SELF ':EXECUTE (LIST* NIL OP ITEM)))
	       (T
		(FUNCALL-SELF ':FORCE-KBD-INPUT (LIST TYPE ITEM SELF BD)))))
	(T
	 ;; Unknown button, just select ourselves
	 (AND (FUNCALL-SELF ':NAME-FOR-SELECTION)
	      (FUNCALL-SELF ':MOUSE-SELECT)))))

(DEFSTRUCT (SCROLL-MOUSE-ITEM :LIST (:CONSTRUCTOR NIL))
  SCROLL-MOUSE-ITEM-ITEM
  SCROLL-MOUSE-ITEM-TYPE
  SCROLL-MOUSE-ITEM-LEFT
  SCROLL-MOUSE-ITEM-REL-TOP
  SCROLL-MOUSE-ITEM-WIDTH
  SCROLL-MOUSE-ITEM-HEIGHT)

(DECLARE-FLAVOR-INSTANCE-VARIABLES (ESSENTIAL-SCROLL-MOUSE-MIXIN)
(DEFUN SCROLL-FIND-SENSITIVE-ITEM (X Y)
  ;; First check for the mouse pointing at something in the item list (things here
  ;; may override items as specified in the data structure itself)
  (PROG HAVE-ITEM ()
    (COND ((AND ( Y (SHEET-INSIDE-TOP))
		(< Y (+ (SHEET-INSIDE-TOP) (* SCREEN-LINES LINE-HEIGHT)))
		( X (SHEET-INSIDE-LEFT))
		(< X (SHEET-INSIDE-RIGHT)))
	   (LET ((LINE-OF-INTEREST (SHEET-LINE-NO NIL Y))
		 (MOUSE-INFO) (LINE-ITEM) (LINE) (ENTRY) (START-X (SHEET-INSIDE-LEFT))
		 (REL-Y) (FIRST-LINE))
	     (SETQ LINE-ITEM (AREF SCREEN-IMAGE LINE-OF-INTEREST 0))
	     (OR LINE-ITEM (RETURN-FROM HAVE-ITEM NIL))
	     (SETQ FIRST-LINE
		   (SETQ LINE (- LINE-OF-INTEREST (AREF SCREEN-IMAGE LINE-OF-INTEREST 1))))

	     ;; First check explicitly set up mouse items
	     (SETQ REL-Y (- Y (* LINE LINE-HEIGHT)))
	     (DOLIST (I (SCROLL-ITEM-MOUSE-ITEMS LINE-ITEM))
	       (AND ( REL-Y (SCROLL-MOUSE-ITEM-REL-TOP I))
		    (< REL-Y (+ (SCROLL-MOUSE-ITEM-REL-TOP I) (SCROLL-MOUSE-ITEM-HEIGHT I)))
		    ( X (SETQ START-X (SCROLL-MOUSE-ITEM-LEFT I)))
		    (< X (+ (SCROLL-MOUSE-ITEM-LEFT I) (SCROLL-MOUSE-ITEM-WIDTH I)))
		    (RETURN-FROM HAVE-ITEM
		      (SCROLL-MOUSE-ITEM-ITEM I) (SCROLL-MOUSE-ITEM-TYPE I)
		      START-X (+ (* LINE LINE-HEIGHT) (SCROLL-MOUSE-ITEM-REL-TOP I))
		      (SCROLL-MOUSE-ITEM-WIDTH I) (SCROLL-MOUSE-ITEM-HEIGHT I))))

	     ;; Didn't find an explicit item, check for one in the regular data structure
	     (DOTIMES (I (ARRAY-DIMENSION-N 1 LINE-ITEM))
	       (SETQ ENTRY (AREF LINE-ITEM I))
	       (COND ((> LINE LINE-OF-INTEREST)
		      (RETURN NIL))
		     ((< LINE LINE-OF-INTEREST)
		      (SETQ LINE (+ LINE (SCROLL-ENTRY-LINES ENTRY))))
		     ((OR (NULL (SCROLL-ENTRY-MOUSE-INFO ENTRY))
			  ( (IF (> (SCROLL-ENTRY-LINES ENTRY) 0)
				 (SHEET-INSIDE-RIGHT)
				 (SCROLL-ENTRY-FINAL-PRINTING-X ENTRY))
			     X))
		      (SETQ LINE (+ LINE (SCROLL-ENTRY-LINES ENTRY))
			    START-X (SCROLL-ENTRY-FINAL-X ENTRY)))
		     ((> START-X X)
		      (RETURN NIL))
		     (T
		      (RETURN-FROM HAVE-ITEM
			(SETQ MOUSE-INFO (SCROLL-ENTRY-MOUSE-INFO ENTRY)) (FIRST MOUSE-INFO)
			START-X (+ (SHEET-INSIDE-TOP) (* LINE-OF-INTEREST LINE-HEIGHT))
			(IF (> (SCROLL-ENTRY-LINES ENTRY) 0)
			    (- (SHEET-INSIDE-RIGHT) START-X)
			    (- (SCROLL-ENTRY-FINAL-PRINTING-X ENTRY) START-X))
			LINE-HEIGHT))))

	     ;; No item is sensitive, perhaps the whole item (line) is sensitive
	     (COND ((SETQ MOUSE-INFO (SCROLL-ITEM-LINE-SENSITIVITY LINE-ITEM))
		    (RETURN-FROM HAVE-ITEM
		      MOUSE-INFO (FIRST MOUSE-INFO)
		      (SHEET-INSIDE-LEFT) (+ (* FIRST-LINE LINE-HEIGHT) (SHEET-INSIDE-TOP))
		      (SHEET-INSIDE-WIDTH)
		      (DO ((I (1+ FIRST-LINE) (1+ I)))
			  ((OR ( I SCREEN-LINES) (NEQ LINE-ITEM (AREF SCREEN-IMAGE I 0)))
			   (* LINE-HEIGHT (- I FIRST-LINE)))))))))))))