#| -*- mode: lisp;
       base: 10;
       fonts: (fonts:hl12b fonts:hl12bi);
       package: user;
       readtable: common-lisp; -*- |#

(in-package 'user)

(defflavor drawing-window (plane) (tv:select-mixin tv:process-mixin tv:window)
  (:default-init-plist
    :plane (make-plane 2 :type 'art-1b :default-value 0 :extension 32.)
    :process 'drawing-window-top-level)
  :settable-instance-variables)



(defmethod (drawing-window :pan-left) ()
  (loop
    (beep)
    until (zerop (tv:mouse-buttons))))

(defmethod (drawing-window :pan-right) ()
  (loop
    (beep)
    until (zerop (tv:mouse-buttons))))

(defmethod (drawing-window :pan-up) ()
  (loop
    (beep)
    until (zerop (tv:mouse-buttons))))

(defmethod (drawing-window :pan-down) ()
  (loop
    (beep)
    until (zerop (tv:mouse-buttons))))

(defun drawing-window-top-level (w) (send w :run-top-level))

(defmethod (drawing-window :run-top-level) ()
  (do-forever
    (loop      
      (process-wait "Mouse" #'(lambda (w) (and (send w :exposed-p) (send w :listen))) self)
      as next-char = (send self :any-tyi-no-hang)
      while next-char
      (if (consp next-char)
	  (case (car next-char)
	    (:menu
	     (let ((operation (third (second next-char))))
	       (if (consp operation)
		   (lexpr-send self operation)
		 (funcall self operation)))))
        (beep)))))

(defflavor panning-window nil
	   (tv:alias-for-inferiors-mixin tv:bordered-constraint-frame-with-shared-io-buffer)
  (:default-init-plist
    :panes
    '((drawing-pane drawing-window
		     :blinker-p nil
		     :deexposed-typein-action :normal
		     :deexposed-typeout-action :permit
		     :label nil
		     :save-bits t)
      (command-pane tv:command-menu		       
		       :blinker-p t
		       :blinker-deselected-visibility :on
		       :blinker-flavor tv:rectangular-blinker
		       :deexposed-typein-action :normal
		       :deexposed-typeout-action :normal
		       :label nil
		       :save-bits t
		       :item-list
		       (("Pan Left" :value :pan-left :font fonts:tr12BI)
		        ("Pan Right" :value :pan-right :font fonts:tr12BI)
			("Pan Up" :value :pan-up :font fonts:tr12BI)			
			("Pan Down" :value :pan-down :font fonts:tr12BI))))
    :constraints
    '((main (command-pane drawing-pane)
	    ((command-pane 0.05))
	    ((drawing-pane :even)))))
  :settable-instance-variables)  

(defmethod (panning-window :after :init) (&rest ignore)
  (let ((drawing-pane (send self :get-pane 'drawing-pane))
        (command-pane (send self :get-pane 'command-pane)))
    (funcall-self :set-selection-substitute drawing-pane)
    (send drawing-pane :set-selection-substitute nil)
    (send command-pane :set-selection-substitute self)))

(tv:add-system-key #\0 'panning-window "Window that pans" t)