#| -*- Mode:LISP; Base: 10;
       Package:(vista-library :use (lisp))
       Syntax: Common-lisp; Readtable: CL   -*- |#


;;; This file is only for Lisp Machines.
;;; It defines a demo frame, containing a
;;; Lisp interactor, a black&white display 
;;; device, and a demo menu.


(export '(VISTA-DEMO-FRAME))      ;demo frame


(zl:defflavor demo-menu
	 ()
   (tv:dynamic-item-list-mixin tv:command-menu)
  :initable-instance-variables
  :gettable-instance-variables
  :settable-instance-variables)


(zl:defflavor demo-lisp-interactor
	 ()
	 (tv:lisp-interactor))


(defun menu-blip-handler (blip stream)
  (declare (ignore stream))
  (ecase (car blip)
    (:mouse-button
     (if (member (cadr blip) '(#\mouse-r-1 #.(char-int #\mouse-r-1)))
	 (tv:mouse-call-system-menu)))
    (:menu
     (unless (catch 'exit-demo
	       (zl:send (fourth blip) :execute (second blip))
	       t)
       (tv:kbd-switch-windows 2)))))

(zl:defwrapper (demo-lisp-interactor :tyi) (ignore . body)
 `(let ((tv:rubout-handler-options (cons (list :blip-handler 'menu-blip-handler)
					 tv:rubout-handler-options)))
    . ,body))


(zl:DEFMETHOD (demo-lisp-interactor :ANY-TYI-NO-HANG) (&OPTIONAL IGNORE)
  (if (> (tv:RHB-FILL-POINTER) (tv:RHB-SCAN-POINTER))
      (zl:send zl:self :any-tyi)
    (tv:KBD-IO-BUFFER-GET tv:IO-BUFFER T)))
	  

;;; Oh, gack this should use the vista package
(defvar *vista-user-package*
	(or (find-package 'vista-user)
	    (make-package 'vista-user
			  :nicknames "VU"
			  :use '(vista-library lisp))))

(zl:defmethod (demo-lisp-interactor :after :init) (&rest ignore)
  (zl:send zl:self :set-package *vista-user-package*))

(defvar *vista-demo-frame* nil)

(zl:defflavor VISTA-DEMO-FRAME
	 (bw-device)
	 (tv:bordered-constraint-frame-with-shared-io-buffer)
  :gettable-instance-variables
  :settable-instance-variables
  (:default-init-plist
    :panes
    `((demo-menu demo-menu
		 :item-list-pointer *demo-list*
		 :rows 2
		 :columns 5) ;it used to lose items sometimes before these
      (bw vl:black&white-display-device-host-window)
      (lisp demo-lisp-interactor))
    :constraints
    `((main . ((demo-menu bw lisp)
	       ((demo-menu 2 :lines))
	       ((bw .75s0))
	       ((lisp :even)))))))

(zl:defmethod (vista-demo-frame :after :init) (&rest ignore)
  (zl:send zl:self :set-selection-substitute (zl:send zl:self :get-pane 'lisp))
  (set-display-device
    (setq bw-device
	  (make-black&white :host-window
			    (zl:send zl:self :get-pane 'bw))))
  (setq *vista-demo-frame* zl:self))

(zl:defmethod (vista-demo-frame :after :expose) ()
  (zl:send zl:self :send-pane 'demo-menu :update-item-list)
  ; yecch! -pecann (set-display-device bw-device)
  )


(defdemo "Use Black&White" 'use-black&white
  "Use the Black&White device" "vista:library;demo-frame")

(defun use-black&white ()
;  (if (eq (zl:send tv:selected-window :superior) *vista-demo-frame*)
;      (set-display-device (zl:send *vista-demo-frame* :bw-device))
;    (zl:send *vista-demo-frame* :select)))
  (set-display-device (zl:send *vista-demo-frame* :bw-device))	         ;pecann
  (unless (eq (zl:send tv:selected-window :superior) *vista-demo-frame*) ; "
    (zl:send *vista-demo-frame* :select)))                               ; "

(defun VISTA-DEMO-FRAME ()
  "Select a Vista demo frame, containing a Black&White display device,
a demo menu, and a Lisp Interactor.  This is good for demonstration,
introduction, and experimentation.  You can also use System-V"
  (unless (and (boundp '*vista-demo-frame*)
	       (typep *vista-demo-frame* 'vista-demo-frame))
    (tv:make-window 'vista-demo-frame))
  (zl:send *vista-demo-frame* :select))

(tv:add-system-key #\V 'vista-demo-frame "Vista Demo Frame")