2#| -*- Mode:LISP; Package:USER; Readtable:ZL; Base:10;
       Fonts:(TR12 TR12I CPTFONTB); -*-

 Copyright GigaMOS Systems, Inc.* 21987
   See filename "Copyright" for
 licensing and release information.

*********************************************************
*********************************************************
*** NOTE: This is an EXAMPLE, not GSI supported code. ***
*** information contained in this example is subject  ***
*** to change without notice. The ways of doing       ***
*** the things contained in the example may change    ***
*** between system releases or updates.               ***
*********************************************************
*********************************************************

1 This example demonstrates 'General Scroll Windows' (see chapter 17 of the Window
 System Manual).  The example demonstrates two different kinds of item lists.  Note
 that this is a completely self-contained demo, and is (I hope) a lot easier to follow
 than the 'Peek' display example which is mentioned in the manual. --KmC

 VALUE-SCROLL-ITEMS returns an item list which uses the value array.**  1Until you
 press C-Abort, the window will display and update the* 1numbers maintained in the
 window's value array. In this example, the* 1values are just incremented forever; a
 real application would* 1presumably be monitoring the values maintained by an
 external* 1source.

 HOST-SCROLL-ITEMS returns a maintaining list of host names.  This* 1list,
 *MY-HOST-LIST*, is originally based on the variable* 1SI:HOST-ALIST, which the
 site file system maintains.  Clicking on a* 1displayed host name brings up a menu
 which offers to remove the host* 1from the display; this demonstrates maintaining a
 dynamic list of* 1items.  Note the use of the site initialization list to ensure that
 updating site information will update my host list here.  There is* 1one stupid kludge:
 having to use PROCESS-RUN-FUNCTION to run the* 1pop-up menu in the
 background, which prevents cold-load stream and* 1processor-wedging errors.

 Compile this and run (start-my-scroll) to see what happens. Press* 1C-Abort to end
 the demo. Answer 'Y' when prompted to clean up (kill* 1the window), or 'N' if you
 want to debug the window interactively.

2|#**

(defflavor my-scroll-window ()
	   (tv:scroll-mouse-mixin tv:scroll-window))

(defvar *my-scroll-window* nil "Current scroll window [for debugging]")

1;;; Stuff for the self-maintaining host list*

(defun nickname-of(host)
  (or (car-safe (send host :host-names))
      "<unnamed>"))

(defvar *my-host-list* nil)

(defun initialize-my-host-list ()
  (setq *my-host-list* (mapcar #'cadr si:host-alist)))

(add-initialization "Initialize host list for my scroll windows"
		    '(initialize-my-host-list)
		    '(once site))

(defun menu-my-host(host &aux choice)
  (setq host (si:parse-host host))
  (setq choice (tv:menu-choose
		 '(("Yes" :value t)
		   ("No" :value nil))
		 (format nil "Remove ~a from display?"
			 (nickname-of host))))
  (when choice
    (setq *my-host-list*
	  (remove host *my-host-list*))))

(defun run-host-menu(&rest args)
  (apply #'process-run-function
	 "Run example host menu"
	 #'menu-my-host args))

(defun host-scroll-items(&optional (host-name-size 25))
  (tv:scroll-maintain-list
    #'(lambda() *my-host-list*)
    #'(lambda(host)
	(list ()
	      (tv:scroll-parse-item
		`(:mouse
		   (nil :eval (run-host-menu ',host))
		   :string ,(substring
			      (format nil "~va"
				      host-name-size
				      (nickname-of host))
				    0 host-name-size))
		(format nil " [~10a/~10a] ~@[Chaos #x~o ~]~@[Internet ~s ~]"
			(send host :machine-type)
			(send host :system-type)
			(send host :chaos-address)
			(send host :internet-address)))))))

1;;; Stuff for the value array scroll items*

(defvar *my-scroll-size* 5 "Number of entries in the value array")

1;;; UPDATE-MY-SCROLL demonstrates how to insert new values into* 1the value array.
;;; INIT-MY-SCROLL provides the initial values.*

(defun init-my-scroll(window)
  (let((v (send window :value-array)))
    (dotimes(i *my-scroll-size*)
      (setf (aref v i) 100.0))))

(defun update-my-scroll(window)
  (let((v (send window :value-array)))
    (do-forever
	(dotimes(i *my-scroll-size*)
	  (setf (aref v i) (+ (aref v i) i)))
	;;Force window to redisplay values
	(send window :redisplay)
	;escape interval to allow mouse tracking and escape by C-Abort
	(sleep 1))))

(defun value-scroll-items (&rest ignore)
  (cons nil
	(cons (tv:scroll-parse-item '(:string "Value items"))
	      (loop for i from 0 to (1- *my-scroll-size*)
		    collect
		    (tv:scroll-parse-item
		      `(:value ,i nil (,(string-append
					  (format nil "  This is item ~s" i)
					  " = ~s"))))))))

(defun value-scroll-items (&rest ignore)
  (cons nil
        (mapcar #'(lambda(item)
		       (list nil (tv:scroll-parse-item item)))
		   (value-scroll-items2))))

(defmacro value-scroll-items2 (&rest ignore)
  `(list
	   '(:string "Value items")
	   . ,(loop for i from 0 to (1- *my-scroll-size*)
		    collect
		    `'(:value ,i nil ( ,(string-append
						       (format nil "~&  This is item ~s" i)
						       " = ~s"))))))

1;;; Main function (demo)*

(defun start-my-scroll()
  (initialize-my-host-list)
  (setq *my-scroll-window*
	(make-instance 'my-scroll-window
		       :value-array (make-array *my-scroll-size*)
		       :display-item
			 (list ()
			       (value-scroll-items)
			       (tv:scroll-parse-item "")
			       (host-scroll-items))))
  (unwind-protect
      (progn
	(init-my-scroll *my-scroll-window*)
	(send *my-scroll-window* :activate)
	(send *my-scroll-window* :expose)
	(send *my-scroll-window* :select)
	(update-my-scroll *my-scroll-window*))
    (progn
      (send terminal-io :select)
      (if (y-or-n-p "Kill scroll window (answer 'N' to debug it) ?")
	(send *my-scroll-window* :kill)))))


;;; Fix problems with system standard TV methods for scroll windows

tv:(DEFUN SCROLL-GET-ITEM-LOCATIVE (POSITION &AUX (ITEM (LOCATE-IN-INSTANCE SELF 'DISPLAY-ITEM)))
  (DECLARE (:SELF-FLAVOR BASIC-SCROLL-WINDOW))
  (AND (NUMBERP POSITION) (SETQ POSITION (NCONS POSITION)))
  (DOLIST (C POSITION)
    (SETQ ITEM (LOCF (NTH C (SCROLL-ITEMS (CAR ITEM))))))	;not (1+ C) !
  ITEM)

(defun putin(position newitem itemlist &optional (position-offset 0))

#|  "Inserts NEWITEM before the specified POSITION in ITEMLIST.

POSITION is either a (0-based) number indicating the position before which to
insert the NEWITEM, or a list of positions indicating a sub-tree position.  For
example, POSITION of (0 1) means insert NEWITEM before the item in the first
(zeroth) sublist occupying the position 1 in the sublist.  

Each position is offset by POSITION-OFFSET; so for example, with an offset of
1, the CAR of each list and sublist is not counted in positioning.

Note that PUTIN returns NIL if there is no item at POSITION already, but
otherwise returns the destructively altered ITEMLIST.

Examples with FOO == ((A B) (C D) (E F)) :
  (PUTIN '(0 1) 'Q FOO)    => ((A Q B) (C D) (E F))
  (PUTIN '(0 1) 'Q FOO 1)  => NIL
  (PUTIN '(0 0) 'Q FOO 1)  => ((A B) (C Q B) (E F))"
|#
  (declare(values itemlist))
  (AND (NUMBERP POSITION) (SETQ POSITION (NCONS POSITION)))
  (LET*((now (car position))
	  (later (cdr position)))
    (flet((rightpos(pos) (+ position-offset pos)))
      (cond
	((null now) nil)
	((null later)
	 (let((sublist (nthcdr (rightpos now) itemlist)))
	   (when sublist
	     (let((olditem (car sublist)))
	       (rplaca sublist newitem)
	       (rplacd sublist (cons olditem (cdr sublist))))
	     itemlist)))
	(t (let((sublist (nth (rightpos now) itemlist)))
	     (and (listp sublist)
		   (putin (cdr position) newitem sublist
			    position-offset)
		 itemlist)))))))

(defmethod (my-scroll-window :insert-item) (position item)
  (putin position item tv:display-item 1))

;;; Testing stuff

(defvar w)

(defun test1()
  (list '()
        (tv:scroll-parse-item '(:string "hi 0"))
	(tv:scroll-parse-item '(:string "hi 1"))
	(tv:scroll-parse-item '(:string "hi 2"))
	(tv:scroll-parse-item '(:string "hi 3"))))

(defun test1()
  (list '()
        (print(tv:scroll-parse-item '(:string "hi 0")))
	(print(tv:scroll-parse-item '(:string "hi 1")))
	(print(tv:scroll-parse-item '(:string "hi 2")))
	(print(tv:scroll-parse-item '(:string "hi 3")))))

(defun test1()
  (list '()
        (print (list '()
		      (tv:scroll-parse-item '(:string "hi 0"))
		      (tv:scroll-parse-item '(:string "hello 0"))))
        (print(list '() (tv:scroll-parse-item '(:string "hi 1"))))
        (print(list '() (tv:scroll-parse-item '(:string "hi 2"))))
        (print(list '() (tv:scroll-parse-item '(:string "hi 3"))))))

(defun test()
  (setq w (make-instance 'my-scroll-window
			       :display-item (test1)))
  (unwind-protect
      (progn
	(send w :activate)
	(send w :expose)
	(send w :select)
	(sleep 5)
	(send w :insert-item '(0) (tv:scroll-parse-item '(:string "this should be at the top")))
	(send w :insert-item '(1 1) (tv:scroll-parse-item '(:string "this should be above hello 0")))
	(send w :redisplay)
	(do-forever (sleep 1)))
    (send terminal-io :select)))