;;; -*- Mode:Common-Lisp; Package:(GC :size 200); Base:10; Fonts:(CPTFONT TR12B TR12BI) -*-
;;;	This file contains the Gulf Coast window system source code.
;;;	Gulf Coast style of window mananagement on the Explorer Lisp machine uses UCL
;;; and is a West Coast Pane Style (or overlapping panes) rather than a East Coast style
;;; (or Constraint frame based). Gulf Coast is implemented on top of a East Coast Style
;;; window system but allows the user to move back and forth between these two styles.
;;; Any time a new window is created over a Gulf Coast background pane (usually greyed over),
;;; the edges are requested from the user. Each Pane can have it's own command table, but
;;; the bakcground screen also can have its own application specific command table
;;; from which, all others can inherit (see UCL inheritance code in GULF-COAST-PATCHES file).
;;; The Background screen can contain not only application specific instance variables,
;;; but also a user specified closure environment (similar to ZMACS).
;;; Since comands can be evoked from anywhere, a consistant execution envionment is supported
;;; by using GULF-COAST-EVAL, which executes/evals code inside the closure and instance
;;; enviroments defined by the background screen and user defined closure variables.
;;; 	The macro GULF-COAST-APPLICATION allows a new application to be defined in minutes
;;; by specifing all the command tables, user documentation, and user variables. A generic
;;; GULF-COAST application is already defined in this file (SYSTEM-space key), to allow
;;; interested parties to play with the functionallity. Most GULF-COAST pane commands are 
;;; assigned to the HYPER-<keys> for consistancy.
;;;
;;; Please feel free to read the end of this file looking for online documentation.
;1;;**********************************************************************************
;1;;                              UTILITY FUNCTIONS*
;1;;**********************************************************************************

(defun find-gulf-coast-background (pane)
  (and pane
       (or (send pane :send-if-handles :gulf-coast-p)
	   (find-gulf-coast-background (send pane :superior)))))

(defun find-gulf-coast-frame (pane)
  (and pane
       (let ((super (send pane :superior)))
	 (or (and super (send super :send-if-handles :gulf-coast-p) pane)
	     (find-gulf-coast-frame super)))))

(defun find-gulf-coast-background-from-screen (screen)
  (loop for each in (send screen :inferiors)
	when (send each :send-if-handles :gulf-coast-p)
	do (return each)))

(defun gulf-coast-refresh-all (pane &optional (refresh-p t))
  "Gulf Coast Refresh All Windows."
  (let ((background (find-gulf-coast-background pane)))
    (when background
      (dolist (foo (send background :inferiors))
	(send foo :deexpose))
      (send background :deexpose)
      (and refresh-p (send background :refresh))
      (send background :grey-background)
      (dolist (foo (send background :inferiors))
	(send foo :refresh :use-old-bits)))))

(defun gulf-coast-refresh-exposed (pane)
  "Gulf Coast Refresh Exposed Windows."
  (let* ((background (find-gulf-coast-background pane))
	 (display (and background (send background :selection-substitute))))
    (when background
      (dolist (foo (send background :inferiors))
	(if (and (send foo :exposed-p)
		 (not (eq foo display)))
	    (send foo :refresh))))))

(defun GC-BURY-WINDOW (window)
  "Gulf Coast Bury Window."
  (setq window (find-gulf-coast-frame window))
  (and window
       (progn (SEND window :bury)
	      (gulf-coast-refresh-all window))))

(defun GC-KILL-WINDOW (window)
  "Gulf Coast Kill Window."
  (let ((top (find-gulf-coast-background window))
	(frame (find-gulf-coast-frame window)))
    (and frame (SEND frame :kill))
    (gulf-coast-refresh-all top)))

(defun GC-MOVE-WINDOW (window)
  "Gulf Coast Move Window."
  (setq window (find-gulf-coast-frame window))
  (and window
       (progn (W:mouse-set-window-position window t)
	      (send window :besure-inside-superior)
	      (gulf-coast-refresh-all window))))

(defun GC-RESHAPE-WINDOW (window)
  "Gulf Coast Reshape Window."
  (setq window (find-gulf-coast-frame window))
  (and window
       (progn (W:mouse-set-window-size window t)
	      (send window :besure-inside-superior)
	      (gulf-coast-refresh-all window))))

(defun GC-REFRESH-WINDOW (window)
  "Gulf Coast Bury Window."
  (setq window (find-gulf-coast-frame window))
  (and window (SEND window :refresh)))

(defun NEW-DRAW-RECTANGLE-INSIDE-CLIPPED
       (width height x-bitpos y-bitpos alu-function sheet
	&optional (color w:100%-black))
  2"Draw rectangle in SHEET, coordinates relative to inside of SHEET,
clipping to inside.  Recall that the inside of SHEET is what is not part
of the margins."*
  (let* ((left   (+ x-bitpos (W:sheet-inside-left   sheet)))
         (top    (+ y-bitpos (W:sheet-inside-top    sheet)))
         (right  (+ left width))
         (bottom (+ top height))
	 (destination (W:sheet-screen-array sheet)))
       (si:%draw-shaded-triangle left top
                                 right top
                                 left bottom
                                 alu-function  nil  t  nil
                                 color
                                 destination)
       (si:%draw-shaded-triangle right top
                                 left bottom
                                 right bottom
                                 alu-function  nil  nil  nil
                                 color
                                 destination)))

(defun CREATE-WINDOW-WITH-MOUSE
       (flavor-name &optional (edges-from 'mouse)
	&key (gulf-coast-background (find-gulf-coast-background-from-screen W:DEFAULT-SCREEN))
	&aux tem)
  (setq edges-from (intern edges-from 'gc))
  2"Create and return a window of FLAVOR-NAME, using mouse to get
edges.  EDGES is how to get the edges, and :MOUSE or :EXPAND will
use the mouse to get them."*
  (and flavor-name gulf-coast-background 
1       ;; Get the edges before creating the window so can abort.*
       (car
         (setq tem
               (case edges-from
                 ('mouse
                  (let*
                    ((init-plist (si:flavor-default-init-plist flavor-name))
                     (minimum-width  (or (get init-plist ':minimum-width ) 0))
                     (minimum-height (or (get init-plist ':minimum-height) 0)))
                    (multiple-value-list
                      (w:mouse-specify-rectangle nil nil nil nil W:mouse-sheet
                                               minimum-width minimum-height t))))
                 ('expand
                  (multiple-value-list
                    (tv:mouse-specify-expand W:mouse-sheet))))))
       (let ((window (W:make-window flavor-name
                                  ':superior gulf-coast-background ':edges tem)))
	 (SEND window :send-if-handles :set-current-application
	       (SEND gulf-coast-background :current-application))
	 (send window :besure-inside-superior)
	 (funcall window ':select)
	 window)))

(defun decode-mouse-method (button)
  (case (int-char button)
    (#\mouse-L-1 :mouse-L-1)
    (#\mouse-M-1 :mouse-M-1)
    (#\mouse-R-1 :mouse-R-1)
    (#\mouse-L-2 :mouse-L-2)
    (#\mouse-M-2 :mouse-M-2)
    (#\mouse-R-2 :mouse-R-2)
    (#\mouse-L-3 :mouse-L-3)
    (#\mouse-M-3 :mouse-M-3)
    (#\mouse-R-3 :mouse-R-3)
    (t nil)))

(defun expose-and-select (pane)
  (send pane :expose)
  (send pane :send-if-handles :select))

(defun choose-pane-and-expose (possible-panes-for-exposure background)
  "If a list of panes are passed in, then one is selected to be :exposed and :selected."
  (let* ((choices (mapcar #'(lambda (pane) (list (send pane :name) pane))
			  possible-panes-for-exposure))
	 (answer (w:menu-choose choices :label " Expose pane? "
				:superior background :item-alignment :center)))
    (and answer (expose-and-select answer))))

;1;;*********************************************************************************
;1;;                             WINDOW FLAVOR/METHOD DEFINITIONS*
;1;;*********************************************************************************
(defflavor who-line-documentation-mixin (Who-Line-Documentation-String
					 (Default-Who-Line-Documentation ""))
	   ()
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables)

(defmethod (who-line-documentation-mixin :after :init) (&rest ignore)
  (setq Who-Line-Documentation-String Default-Who-Line-Documentation))


(defflavor Application-mixin  ((current-application nil)) ()
  :settable-instance-variables)
  
(DEFMETHOD (Application-mixin  :set-module)  (new) (SETQ current-application  new))
(DEFMETHOD (Application-mixin  :module)      ()    (AND (VARIABLE-BOUNDP CURRENT-APPLICATION) CURRENT-APPLICATION))

;(defmacro rename-current-application (name)
;  "2Allows external renaming of current-application ot :NAME method and :SET-NAME method.*"
;  `(progn 
;	(DEFMETHOD (APPLICATION-MIXIN ,(intern name 'keyword)) ()
;	  (AND (VARIABLE-BOUNDP CURRENT-APPLICATION) CURRENT-APPLICATION))
;	(DEFMETHOD (APPLICATION-MIXIN  ,(intern (format nil "SET-~a" name) 'keyword)) (new-application)
;	  (SETQ CURRENT-APPLICATION new-application))))

;;(rename-current-application module)

1;;;window flavor for MAIN *GULF-COAST 1BACKGROUND SCREEN*
(defflavor GULF-COAST 
	   ((top-closure nil)
	    (hidden-inferiors nil)
	    (current-pane-group nil)
	    (current-pane-name nil)
	    (Default-Who-Line-Documentation "L: Expose pane  R2: System Menu"))
	   (UCL:COMMAND-LOOP-MIXIN	    
	    UCL:SELECTIVE-FEATURES-MIXIN
	    W:LIST-MOUSE-BUTTONS-MIXIN
	    who-line-documentation-mixin
	    Application-mixin 
	    W:notification-mixin
	    W:list-mouse-buttons-mixin
	    W:process-mixin 
	    W:select-mixin
   	    W:essential-window-with-typeout-mixin
	    W:window
	    W:stream-mixin
	    W:label-mixin)
  (:default-init-plist 
    :save-bits             t
    :typeout-window        '(W:typeout-window :deexposed-typeout-action (:expose-for-typeout))
    :process	           '(closure-command-loop :regular-pdl-size 5000. :special-pdl-size 5000.)	   
    :blinker-p             nil
    :label                 nil
    :ACTIVE-COMMAND-TABLES '(*generic-gulf-coast-commands*)
    :ALL-COMMAND-TABLES '(*generic-gulf-coast-commands*)
    :TYPEIN-HANDLER :HANDLE-TYPEIN-INPUT
    :PROMPT " "
    :BASIC-HELP '(VIEW-DOCUMENTATION *gulf-coast-basic-help*)
;    :TUTORIAL '(PROGN (BEEP)
;		      (FORMAT T "Sorry, no gulf-coast tutorial written yet.")
;		      (SEND UCL:THIS-APPLICATION :HANDLE-PROMPT))
    :REMOVE-FEATURES '(:LISP-TYPEIN)
    ;;This specifies a method to call (:clicked-on-obstruction, defined below) when we get a blip of 
    ;;type :TYPEOUT-EXECUTE (when the user clicks on an obstruction).  The other two entries are UCL defaults.
    :BLIP-ALIST '((:MENU :HANDLE-MENU-INPUT)
		  (:MOUSE-BUTTON :HANDLE-MOUSE-INPUT))
    :ALLOW-OTHER-KEYS t
    :MORE-P      NIL
    :BORDERS	 3.    )
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables
  )

(defun get-gc ()
  "Non global debug solution for getting handle for window."
  (W:find-window-of-flavor 'gc:gulf-coast))

(defmethod (GULF-COAST :after :init) (init-keywords)
  (let ((vars (get init-keywords :closure-variables)))
    (if vars (setq top-closure (make-closure vars))
	(setq top-closure init-keywords)))
  (send W:process :eval-inside-yourself
	`(setq si:initial-form (list ,self :closure-command-loop))))

(defmethod (GULF-COAST :closure-command-loop) ()
  (if (closurep top-closure)
      (funcall top-closure `(send ,self :command-loop))
      (send self :command-loop)))
  
(defmethod (GULF-COAST :eval-inside-closure) (&rest args)
  (if (closurep top-closure)
      (apply top-closure
		     (if (and (symbolp (car args))
			      (eq (pkg-find-package 'keyword)
				  (symbol-package (car args))))
			 (cons self args) ;;then assume method call 
			 args))
      (apply self args)))

(DEFMETHOD (GULF-COAST :designate-io-streams) ()  ;;originally from ucl:BASIC-COMMAND-LOOP 
  "1Sets IO stream variables to values which are fairly reasonable.  It sets *STANDARD-INPUT* and
*STANDARD-OUTPUT* to SELF.  The rest of the command loop uses these two for input and ouput.  If
you are using BASIC-COMMAND-LOOP, this means that *TERMINAL-IO* is still equal to its previous value; 
this often works out nicely.  If you are using COMMAND-LOOP-MIXIN, which gives you a process, it is 
set to a background stream which is brought up on errors.  You might want to redefine this method
for your flavor to SETQ *TERMINAL-IO* to your window (or a pane).  Or you might want to redirect
input or output by setting *STANDARD-INPUT* or *STANDARD-OUTPUT* to an appropriate pane.  Also
check out *DEBUG-IO* for handling errors.  (If you have a type-out pane, it is nice to set *DEBUG-IO*
to it.)*"
  (SETQ *standard-input* self 
	*standard-output* (or (send SELF :selection-substitute) self)))

(DEFMETHOD (GULF-COAST  :handle-prompt) ()   ;;originally from ucl:BASIC-COMMAND-LOOP
  "1Output the prompt for this application if the user needs a prompt.
This is set up so that a prompt is printed at the start of the loop and after each typed expression.*"
  ; NO prompt for the GULF-coast Background screen.
  nil
  )

(defmethod (GULF-COAST :gulf-coast-p) () self)

(defmethod (GULF-COAST :GREY-BACKGROUND) ()
  (new-draw-rectangle-inside-clipped 1023 807 0 0 W:alu-xor self W:12%-gray))

(defmethod (GULF-COAST :after :clear-screen)()
  (find-new-listener self)
  (gulf-coast-refresh-all self))


(defmethod (GULF-COAST :after :set-edges)(&rest new-edges)
  new-edges
  (send self :besure-inferiors-inside))

(defmethod (GULF-COAST :besure-inferiors-inside) ()
  (loop for each-window in W:inferiors
	do (send each-window :besure-inside-superior)))

(defun any-listener-p (background)
  (loop for each in (send background :inferiors)
	when (typep each 'w:lisp-listener)
	do (return each)))

(defun find-new-listener (background)
  (let ((lisper (or (any-listener-p background)
		    (let ((W:selected-window background))
		      (W:KBD-SYS-1 #\control-l)
		      nil)
		    (any-listener-p background))))
    (and LISper (progn (send background :set-selection-substitute lisper)
		       (send lisper :set-more-p nil)))
    LISper))

(defmethod (GULF-COAST :MOUSE-CLICK) (buttons x y)
  "This handles all mouse clicks. If handlers are available, then they handle it,
2    *Else click is assumed to be attempt to expose a pane."
  (let* ((method (decode-mouse-method buttons))
	 (handled-p (and method (send self :operation-handled-p method))))
    (if handled-p 
	(send self method)
	(let* ((possibles-for-exposure
		 (loop for each in W:inferiors
		       when (let ((x-offset (send each :send-if-handles :x-offset))
				  (y-offset (send each :send-if-handles :y-offset))
				  (width (send each :send-if-handles :width))
				  (height (send each :send-if-handles :height)))
			      (and x-offset (> x x-offset)
				   width    (< x (+ x-offset width))
				   y-offset (> y y-offset)
				   height   (< y (+ y-offset height))))
		       collect each))
	       (expose-this-pane (if (< (length possibles-for-exposure) 2)
				     (car possibles-for-exposure))))				      
	  (if expose-this-pane
	      (process-run-function "expose pane"2 *'expose-and-select expose-this-pane)
	      (if possibles-for-exposure
		  (process-run-function "Choose pane"2 *'choose-pane-and-expose possibles-for-exposure self)
		  )))))) ;;(beep)

(defmethod (GULF-COAST  :mouse-R-1)(&optional window)
  window
  (process-run-function "2window-operations" * 'gulf-coast  self))

(defmethod (GULF-COAST :mouse-R-2)(&optional window)
  (W:mouse-call-system-menu (or window self)))

;;;********************************************************************************
;;;********************************************************************************
;;;pane group management stuff

(defmethod (GULF-COAST :add-to-pane-group) (pane-group-name &rest new-panes-to-add)
  "Add the list of new-panes to set of panes specified by pane-group-name."
  (loop for each in hidden-inferiors
	for (pane-name . panes) = each
	for new-ones = (set-difference new-panes-to-add panes)
	when (string-equal pane-name pane-group-name)
	do (return (and new-ones (rplacd (last each) new-ones)))
	finally (push-end (cons pane-group-name new-panes-to-add) hidden-inferiors))
  (if (string-equal pane-group-name current-pane-name)
      (progn (setq current-pane-group (union current-pane-group new-panes-to-add))
	     (setq W:inferiors (union W:inferiors new-panes-to-add))
	     (gulf-coast-refresh-all self)))
  )

(defmethod (GULF-COAST :switch-to-pane-group) (&optional (new-pane-group-name :ASK-USER))
  "If NEW-PANE-GROUP-NAME is new, then that pane group is created.
If NEW-PANE-GROUP-NAME is :ASK-USER then all current ones are asked in a menu.
If NEW-PANE-GROUP-NAME is :NEXT-IN-ORDER then they are cycled through in order.
If NEW-PANE-GROUP-NAME is :LAST-IN-ORDER then they are cycled through in reverse order."
  (if (eq new-pane-group-name :ASK-USER)
      (setq new-pane-group-name
	    (if (not (cdr hidden-inferiors))
		(caar hidden-inferiors)
		(w:menu-choose (cons `(" CHOOSE A PANE GROUP NAME. "
					:no-select nil 
					:font fonts:HL12B)
				      (mapcar 'first hidden-inferiors))
			        :item-alignment :center)))
      (if (eq new-pane-group-name :NEXT-IN-ORDER)
	  (setq new-pane-group-name (if (cdr hidden-inferiors)
					(first (second hidden-inferiors))
					(first (first hidden-inferiors))))
	  (if (eq new-pane-group-name :LAST-IN-ORDER)
	      (setq new-pane-group-name (first (last hidden-inferiors))))))
  (if (null new-pane-group-name) (beep)
      (progn 
	(if (not (assoc new-pane-group-name hidden-inferiors :test #'string-equal))
	    (push-end (list new-pane-group-name) hidden-inferiors))
	(or (string-equal new-pane-group-name current-pane-name)
	    (send self :update-pane-group-display new-pane-group-name))))
  )

(defmethod (GULF-COAST :update-pane-group-display)(new-pane-group-name)
  (let ((new-group (assoc new-pane-group-name hidden-inferiors :test #'string-equal)))
    (and new-pane-group-name new-group
	 (progn 
	   (setq hidden-inferiors (cons new-group (remove new-group hidden-inferiors)))
	   (setq W:inferiors (union (cdr new-group) ;;new plus those not in any pane group
				     (set-difference W:inferiors current-pane-group)))
	   (mapcar #'(lambda (window)(send window  :deexpose)) current-pane-group)
	   (setq current-pane-name (car new-group))
	   (setq current-pane-group (cdr new-group))))
    (gulf-coast-refresh-all self)))

(defmethod (GULF-COAST :edit-pane-grouping) ()
  (let* ((all-panes (union (loop with answer = nil
				 for name-and-panes in hidden-inferiors
				 for panes = (cdr name-and-panes)
				 do (setq answer (union answer panes))
				 finally (return answer)) W:inferiors))
	 (all-groups (mapcar 'car  hidden-inferiors))
	 (all-keys (loop for each in all-groups
			 collect (firstn 6 (list each (string each)))))
	 (old-groupings (loop for each-window in all-panes  ;;build inverted data set for choose
			      for selections = (loop for (name . panes) in hidden-inferiors
						     collect (if (member each-window  panes)
								 (list name t)
								 name))			  
			      collect (list each-window (string (send each-window :name)) selections)))	 
	 (new-groupings (W:MULTIPLE-CHOOSE
			  (String-append "Edit Gulf Coast pane groups for "
					 (subseq (send self :name) 0 (zlc:string-search " " (send self :name))))
			  old-groupings
			  all-keys))
	 (new-inferiors (loop for name in all-groups ;;change choose information to hidden-inferiors format
			      collect (cons name
					    (loop for (pane . new-groups) in new-groupings
						  when (member name new-groups :test #'string-equal)
						  collect pane))))
	 (all-new-panes (loop with answer = nil
			      for name-and-panes in hidden-inferiors
			      for panes = (cdr name-and-panes)
			      do (setq answer (union answer panes))
			      finally (return answer)))
	 (no-group (set-difference all-panes all-new-panes))) ;;panes not in any other group (common)
    (when new-groupings 
      (grind-top-level new-inferiors)
      (format t "~&The following panes belong to no pane group. ~&~s" no-group)
      (if (yes-or-no-p "Use this edited Gulf Coast pane configuration? ")
	  (progn (mapcar '(lambda (window)(send window :deexpose)) current-pane-group)
	         (setq current-pane-group nil) ;;force UPDATE to not exclude no-group windows
		 (setq W:inferiors no-group)  ;;this is new common panes list
		 (setq hidden-inferiors new-inferiors)
		 (send self :update-pane-group-display current-pane-name)))))
  )

(compile-flavor-methods gulf-coast)

;;;********************************
W:
(defmethod (ESSENTIAL-SET-EDGES :set-gulf-coast-size) (width-percent height-percent &optional (x-percent 0) (y-percent 0))
  "This allows setting of size/position based on percentages of the superior window."
  (and superior 
       (multiple-value-bind (left top right bottom) (send superior :inside-edges)
	 (let* ((superior-width  (- right left))
		(superior-height (- bottom top))
		(new-left (max (1+ left) (floor (abs (quotient (* x-percent superior-width) 100.)))))
		(new-top  (max (1+ top) (floor (abs (quotient (* y-percent superior-height) 100.)))))
		(new-right  (min (1- right)
				 (+ new-left (floor (abs (quotient (* width-percent superior-width) 100.))))))
		(new-bottom (min (1- bottom)
				 (+ new-top (floor (abs (quotient (* height-percent superior-height) 100.)))))))
	   (send self :set-edges new-left new-top new-right new-bottom)))))

W:
(defmethod (ESSENTIAL-SET-EDGES :gulf-coast-size)()
  (and superior 
       (multiple-value-bind (sup-left sup-top sup-right sup-bottom) (send superior :inside-edges)
	 (multiple-value-bind (left top right bottom) (send self :edges)
	   (let ((sup-width  (- sup-right sup-left))
		 (sup-height (- sup-bottom sup-top))
		 (my-width   (* 100.0 width))
		 (my-height  (* 100.0 height))
		 (my-left    (* 100.0 left))
		 (my-top     (* 100.0 top)))
	     right bottom
	     (values (round my-width sup-width)(round my-height sup-height)
		     (round my-left sup-width) (round my-top sup-height)))))))
		   
W:
(defmethod (ESSENTIAL-SET-EDGES :besure-inside-superior)()
  (and superior 
       (multiple-value-bind (sup-left sup-top sup-right sup-bottom) (send superior :inside-edges)
	 (multiple-value-bind (my-left my-top my-right my-bottom) (send self :edges)
	 (if (or (<= my-left sup-left) (<= my-top sup-top)
		 (>= my-right sup-right) (>= my-bottom sup-bottom))
	     (let* ((new-left  (max (1+ sup-left) (min my-left (1- sup-right))))
		    (new-top   (max (1+ sup-top) (min my-top (1- sup-bottom))))
		    (new-right (min (1- sup-right) my-right))
		    (new-bottom (min (1- sup-bottom) my-bottom))
		    (new-width  (- new-right new-left))
		    (new-height (- new-bottom new-top)))
	       (if (< new-width 1) (setq new-left (1+ sup-left)))
	       (if (< new-height 1)(setq new-top  (1+ sup-top)))
	       (send self :set-edges new-left new-top new-right new-bottom)))))))

;;;********************************
(defflavor GENERIC-WINDOW ((Default-Who-Line-Documentation
			     "L: Expose pane  R2: System Menu R3: Gulf Coast commands ")
			   )
	   (UCL:COMMAND-LOOP-MIXIN UCL:SELECTIVE-FEATURES-MIXIN W:LIST-MOUSE-BUTTONS-MIXIN
	    application-mixin who-line-documentation-mixin W:select-mixin W:window)
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables
  (:default-init-plist
    :save-bits t
    :borders 2
    :deexposed-typeout-action :permit
   :BLIP-ALIST '((:MENU :HANDLE-MENU-INPUT)
		 (:MOUSE-BUTTON :HANDLE-MOUSE-INPUT))
   :REMOVE-FEATURES '(:LISP-TYPEIN)
   :TYPEIN-HANDLER :HANDLE-TYPEIN-INPUT
    ))

(defmethod (GENERIC-WINDOW :mouse-R-1)()
  (process-run-function "2window-operations" * 'gulf-coast self))

(DEFMETHOD (GENERIC-WINDOW :designate-io-streams) ()  ;;originally from ucl:BASIC-COMMAND-LOOP 
  "1Sets IO stream variables to values which are fairly reasonable.  It sets *STANDARD-INPUT* and
*STANDARD-OUTPUT* to SELF.  The rest of the command loop uses these two for input and ouput.  If
you are using BASIC-COMMAND-LOOP, this means that *TERMINAL-IO* is still equal to its previous value; 
this often works out nicely.  If you are using COMMAND-LOOP-MIXIN, which gives you a process, it is 
set to a background stream which is brought up on errors.  You might want to redefine this method
for your flavor to SETQ *TERMINAL-IO* to your window (or a pane).  Or you might want to redirect
input or output by setting *STANDARD-INPUT* or *STANDARD-OUTPUT* to an appropriate pane.  Also
check out *DEBUG-IO* for handling errors.  (If you have a type-out pane, it is nice to set *DEBUG-IO*
to it.)*"
  (SETQ *standard-input* self ;;redirect output to lisp listener
	*standard-output* (or (send W:superior :selection-substitute) self)))

(compile-flavor-methods GENERIC-WINDOW)

;;;********************************
(defflavor generic-mouse-sensitive-window ()
	   (GENERIC-WINDOW))

;;orignally from (:method MOUSE-SENSITIVE-TEXT-SCROLL-WINDOW :MOUSE-CLICK)
;(DEFMETHOD (generic-mouse-sensitive-window :MOUSE-CLICK) (BUTTON X Y &AUX ITEM TYPE)
;  (MULTIPLE-VALUE-setq (ITEM TYPE) (FUNCALL SELF :send-if-handles ':MOUSE-SENSITIVE-ITEM X Y))
;  (COND (TYPE
;	 (FUNCALL-SELF ':FORCE-KBD-INPUT (LIST TYPE ITEM SELF
;					       (W:MERGE-SHIFT-KEYS BUTTON)))
;	 T)
;	(t (decode-generic-mouse-click button self))))

(DEFMETHOD (generic-mouse-sensitive-window :MOUSE-CLICK) (BUTTON X Y &AUX ITEM TYPE)
  "This is the UCL version of old method above."
  (MULTIPLE-VALUE-setq (ITEM TYPE) (FUNCALL SELF :send-if-handles ':MOUSE-SENSITIVE-ITEM X Y))
  (IF  TYPE
       (SEND self :send-if-handles  type item (decode-mouse-method button) W:selected-window)
       (decode-generic-mouse-click  button self)))

(compile-flavor-methods generic-mouse-sensitive-window)

(defun decode-generic-mouse-click (buttons pane)
  (let ((method (decode-mouse-method buttons)))
    (if (and method (send pane :operation-handled-p method))
	(if (send pane :exposed-p)
	    (send pane method)
	    (expose-and-select pane))
	(send (send pane :superior) :send-if-handles method pane))))

;;;********************************
(defflavor GENERIC-WINDOW-NO-LABEL ()
	   (GENERIC-WINDOW)
  (:default-init-plist
    :label nil))

(compile-flavor-methods GENERIC-WINDOW-NO-LABEL)

;;;********************************
(defflavor GENERIC-WINDOW-NO-BLINKER ()
	   (GENERIC-WINDOW)
  (:default-init-plist
    :blinker-p nil))

(compile-flavor-methods GENERIC-WINDOW-NO-BLINKER)

;;;********************************
(defflavor GENERIC-WINDOW-NO-LABEL-NO-BLINKER ()
	   (GENERIC-WINDOW)
  (:default-init-plist
    :blinker-p nil
    :label nil))

(compile-flavor-methods GENERIC-WINDOW-NO-LABEL-NO-BLINKER)

;;;********************************
(zwei:defcom zwei:com-gulf-coast "Gulf Coast Window operations" (km)
  (gulf-coast zwei:*WINDOW*)
  zwei:DIS-NONE)

;;; The mouse tables in standard comtab will not accept greater than double clicks, 
;;; so I'm commenting this out. -- Ken Bice
;(zwei:set-comtab zwei:*standard-comtab* `(#\mouse-R-3 zwei:com-gulf-coast))

(zwei:set-comtab zwei:*standard-comtab* `(#\hyper-G zwei:com-gulf-coast))

;;;********************************
(W:add-terminal-key #\hyper-G
     '(gc:gulf-coast W:selected-window) "Gulf Coast Style Pane Operations.")

(W:add-terminal-key #\hyper-M
     '(gc:gc-move-window W:selected-window) "Move2 *Gulf Coast Window.")     

(W:add-terminal-key #\hyper-R
     '(gc:gc-reshape-window W:selected-window) "Reshape Gulf Coast Window.")

(W:add-terminal-key #\hyper-L
     '(gc:gulf-coast-refresh-all W:selected-window) "Refresh all Gulf Coast Windows.")


;;;****************************************************************
;;; Stuff for making dynamic closures. Ideas from ZMACS code.
;;;****************************************************************

(defun closure-eval (&rest args)
  "This is an evaluator for inside a closure."
  (let ((first (car args)))
    (if (and (not (symbolp first)) (or (functionp first) (instancep first)))
	(apply (car args) (cdr args))    ;;be fast or 
	(apply #'values (mapcar #'eval args))))) ;;be general

(defmacro eval-inside-closure (&rest args)
  `(funcall ,@args))

(defun make-closure (binding-alist)
  (setq binding-alist (cons `(celf nil)
			    (mapcar #'(lambda (thing) (if (consp thing) thing (list thing nil))) binding-alist)))
  (let ((closure  (progw binding-alist
		    (CLOSURE (MAPCAR #'car BINDING-alist) 'closure-eval))))
    (funcall closure `(setq celf ,closure))
    closure))

(DEFUN gulf-coast-eval (&rest args)
  "This forces the execution of args inside the closure and background flavor environment."
  (LET ((environment (gc:find-gulf-coast-background W:selected-window)))
    (IF environment (apply environment :eval-inside-closure args)
	(apply (first args) (cdr args)))))

;1;;*********************************************************************************
;1;;                                  *GULF COAST 1MENU ITEM LISTS*
;1;;*********************************************************************************
;; UCL based Pane/window operations
;
(DEFCOMMAND gc-switch-configuration ()
  '(:DESCRIPTION "Switch to a different named pane group for this Gulf coast application."
    :names "Switch Config" :KEYS (#\HYPER-S))
   (let ((background (find-gulf-coast-background *terminal-io*)))
     (if (null background) (beep)
	 (send background :switch-to-pane-group))
     (gulf-coast-eval #'handle-prompt)))

(DEFCOMMAND gc-edit-configuration ()
  '(:DESCRIPTION "Edit the pane groups for this Gulf coast application."
    :names "Edit Config" :KEYS (#\HYPER-E))
   (let ((background (find-gulf-coast-background *terminal-io*)))
     (if (null background) (beep)
	 (send background :edit-pane-grouping))
     (gulf-coast-eval #'handle-prompt)))

(DEFCOMMAND gc-add-configuration ()
  '(:DESCRIPTION "Add a new pane group name for this Gulf coast application."
    :names "Add new Config" :KEYS (#\HYPER-A))
   (let ((background (find-gulf-coast-background *terminal-io*)))
     (if (null background) (beep)
	 (let ((group-name (string-trim " " (zwei:typein-line-readline-near-window
			     W:selected-window "Enter a new pane group name: "))))
	   (and group-name (> (length group-name) 0)
		(send background :add-to-pane-group
		      (intern (string-upcase group-name) :keyword)))))
     (gulf-coast-eval #'handle-prompt)))
 
(DEFCOMMAND GC-MOVE-COM (&optional window)
  '(:names "Move" :DESCRIPTION "Move selected window."       :KEYS (#\HYPER-M))
  (gc-move-window (or window (W:window-under-mouse) *terminal-io*)))

(DEFCOMMAND GC-RESHAPE-COM (&optional window)
  '(:names "Reshape" :DESCRIPTION "Reshape selected window." :KEYS (#\HYPER-R))
  (gc-reshape-window  (or window (W:window-under-mouse) *TERMINAL-IO*)))

(DEFCOMMAND GC-CLEAR-COM (&optional window)
  '(:names "Clear" :DESCRIPTION "Clear selected window."     :KEYS (#\HYPER-C))
  (SEND (or window (W:window-under-mouse) *terminal-io*)  :clear-screen))

(DEFCOMMAND GC-KILL-COM (&optional window)
  '(:names "Kill" :DESCRIPTION "Kill selected window."       :KEYS (#\HYPER-K))
  (gc-kill-window  (or window (W:window-under-mouse) *TERMINAL-IO*)))

(DEFCOMMAND GC-REFRESH-COM (&optional window)
  '(:names "Refresh" :DESCRIPTION "Refresh selected window." :KEYS (#\HYPER-L))
  (GC-REFRESH-WINDOW  (or window (W:window-under-mouse) *TERMINAL-IO*)))

(DEFCOMMAND GC-BURY-COM (&optional window)
  '(:names "Bury" :DESCRIPTION "Bury selected window."       :KEYS (#\HYPER-B))
  (gc-bury-window (or window (W:window-under-mouse) *TERMINAL-IO*)))

(MAKE-COMMAND pop-up-Gulf-Coast-operations-menu
  '(:NAMES "Pop-up Gulf Coast Operations"
	   :KEYS (#\HYPER-G #\MOUSE-R-1 #\MOUSE-R-3)  ;;Causes clicking right 1 or 3 to execute this command.
	   :DEFINITION gulf-coast-ucl))

(BUILD-MENU '*pop-up-gulf-coast-operations-menu* 'gulf-coast
  :ITEM-LIST-ORDER
  '(GC-MOVE-COM
    GC-RESHAPE-com
    GC-CLEAR-com
    GC-KILL-com
    GC-REFRESH-com
    GC-BURY-com)
  :superior-menus '(W:com-list-menus))

(defun gulf-coast-ucl (&optional (pane (W:window-under-mouse)))
  "This is a UCL version of gulf-coast pop up operations menu."
  (let* ((frame (find-gulf-coast-frame pane)))
    (if (null frame)  (beep)
	;;the following code derived from UCL:POP-UP-COMMAND-MENU 
	(LET* ((menu-items (SYMBOL-VALUE '*pop-up-Gulf-Coast-operations-menu*))
	       (command (w:menu-choose menu-items :item-alignment :center)))
	  (WHEN (TYPEP command 'UCL:COMMAND)
	    (funcall (send command :definition) pane))))))

(defun gulf-coast (&optional (pane *terminal-io*))
  (gulf-coast-ucl pane))

(defun handle-prompt ()
  "This allows the gulf-coast UCL typeout window to be updated if messages are displayed."
  (DECLARE (SPECIAL Background))
  (if (variable-boundp Background)
      (let* ((typeout (send background :selection-substitute))
	     (*STANDARD-INPUT* typeout)) ;;where prompt goes to
	(SEND typeout :send-if-handles :handle-prompt))
      (gulf-coast-eval #'handle-prompt)))
  
;;several default commands for all gulf-coast applications
(DEFCOMMAND gulf-coast-command ()
  '(:DESCRIPTION "Gulf Coast Operations Menu."     :KEYS (#\HYPER-G))  (GC:gulf-coast))

(DEFCOMMAND gulf-coast-refresh ()
  '(:DESCRIPTION "Gulf Coast Operations Menu."     :KEYS (#\HYPER-CLEAR-SCREEN))
  (gc:gulf-coast-refresh-all *standard-input*))

(defparameter *gulf-coast-basic-help*
   "   This application is implemented in a window management system called Gulf Coast windows.
This style of window management is a non-constraint based style of pane management which
allows overlapping panes (West Coast Style), built on top of a traditional contraint based
lisp machine window system (East Coast Style). Gulf Coast Windows is really a set of conventions
established to allow switching back and forth between these two styles of pane management.

	The major component used by Gulf-Coast windows is a gray background screen which
contains the commands associated with a particular custom application.  The Universal Command
Loop (UCL) has been enhanced to add command inheritance for the purpose of supporting custom
application command tables even with standard product windows.  New Gulf Coast applications can
be quickly defined using the GULF-COAST-APPLICATION macro to bind command tables, custom
flavors, docuementation, and closure environment variables.  Once a GULF COAST application has
been defined and instantiated, new panes can be attached to that environment using regular
SYSTEM key conventions.  Whenever a new window is created (ie SYSTEM-control-<key>) and the
GULF-Coast background screen is its superior, then it follows the GULF Coast Conventions.  This
requires that the user specify the orignal position and size of the new pane by specifying its
corners with the mouse.  Creating new panes when not over a Gulf-Coast background works normally.

	All Gulf Coast applications should have the same Gulf Coast commands supported by
the generic Gulf-Coast application, which is attached to the SYSTEM-SPACE key. These Gulf Coast 
commands allow simple movement, reshaping, and reconfiguration of the set of overlapping panes.
Gulf-Coast commands can be evoked directly through the following keystrokes, or in most cases
the TERMINAL-keystroke sequence also works. These commands generally effect the window located 
under the mouse. The TERMINAL-keystroke sequences generally effect the selected window. 
As a rule, all GULF-COAST commands are bound to HYPER-<keystroke>. 

	Command		Description of Gulf-Coast Command.
	--------------  ----------------------------------------------
	HYPER-Help	UCL Help menu containing this help messages.
	HYPER-Clear-Screen   Refresh all the panes in this Gulf-Coast application
	HYPER-G		Gulf-Coast Pop-up menu containing the following six commands.
			This is attached to ZMACS command tables and generally to the
			mouse-right or mouse-3-right keystrokes in custom panes.

	HYPER-M		Move the pane to a new position
	HYPER-R		Reshape the pane by indicating it's new corners
	HYPER-C		Clear the pane
	HYPER-K		Kill the pane without asking for confirmation
	HYPER-L		Refresh only this pane
	HYPER-B		Bury this pane                <scroll for more documentation below>

	HYPER-A		Add a new pane group name to this application
	HYPER-S		Switch to another Pane group configuration
	HYPER-E		Edit the Current pane configurations

	Pane groups allow rapid switching of configurations, by hidding various sets of panes.
Any pane which is not contained in a single pane group is common to all panes groups and
is thus by default always exposed.
")

(DEFCOMMAND gulf-coast-help-menu ()
  '(:NAMES          ("gulf-coast-Help")
    :DESCRIPTION    "Pops up a menu of help-oriented commands for gulf-coast application."
    :KEYS           #\HYPER-HELP
    :DOCUMENTATION "1This command pops up a menu of help commands for the current *GULF COAST APPLICATION.
1The help commands include Basic-Help and Tutorial if this program is
equiped to handle them.  Other* 1help commands include the Command
Display and Command Editor for learning about the program's commands
and for customizing the command environment.*")
  (let ((ucl:help-menu (append `((" Gulf Coast Help Menu " :NO-SELECT T :FONT FONTS:HL12B)
				 ("Basic Gulf Coast Help" :EVAL (VIEW-DOCUMENTATION *gulf-coast-basic-help*)
				  :DOCUMENTATION
				 "Gives generic help information about Gulf Coast windows for new users."))
			       (cdr ucl:help-menu))))
    (GC:GULF-COAST-EVAL #'ucl:help-menu)))


(defmacro gulf-coast-application (application-name system-key command-tables &key
				  mixins basic-help tutorial who-line closure-vars
				  typeout-type typeout-size initialization)
  "This macro builds everything to define an application in the GULF COAST pane management style.

APPLICATION-NAME is used to create a flavor of type <application-name>-GULF-COAST-BACKGROUND.

SYSTEM-KEY allows creation or selection of this type of GULF-COAST application window.

COMMAND-TABLES can be one or more UCL command tables which contain commands. Each command will be
executed inside the environment built by MIXINS flavor variables and specials defined in CLOSURE-VARS. 

CLOSURE-VARS can be either a list of variable names or alist of variables and their values.

TYPEOUT-TYPE is defaulted to be a W:LISP-LISTENER and TYPEOUT-SIZE is a list containing the
GULF-COAST size information, (width-percent height-percent Xoffset-percent Yoffset-percent)
where percentages can range from 0 to 100. The default TYPEOUT-SIZE is `(80 35 0 65).

INITIALIZATION is any other initialization code which needs to be run when new
<application-name>-GULF-COAST-BACKGROUND instance is created. 

BASIC-HELP and TUTORIAL are lisp expressions which can be evoked by typing HYPER-HELP
when the GULF-COAST-HELP-MENU is included in command table.

All macro arguments need not be quoted." 
  (let ((flavor-name (intern (format nil "~a-GULF-COAST-BACKGROUND" application-name)))
	(select-name (intern (format nil "SELECT-GULF-COAST-~a" application-name))))
    (or (consp command-tables)(setq command-tables (list command-tables)))
  `(progn
     (defflavor ,flavor-name ()
		(gc:GULF-COAST ,@(if (consp mixins) mixins (and mixins (list mixins))))
       (:default-init-plist
	 :Default-Who-Line-Documentation ,(or who-line "L: Expose Pane   R2: System Menu")
	 :ACTIVE-COMMAND-TABLES ',command-tables 
	 :ALL-COMMAND-TABLES ',command-tables
	 :BASIC-HELP ',(or basic-help `(VIEW-DOCUMENTATION *gulf-coast-basic-help*))
	 :TUTORIAL ',(or tutorial 
		       `(PROGN (BEEP)
			       (FORMAT T "Sorry, no tutorial written yet for GULF-COAST application ~a." ',application-name)
			       (SEND UCL:THIS-APPLICATION :HANDLE-PROMPT)))))
     (compile-flavor-methods ,flavor-name)
     (defun ,select-name ()
       ,(format nil "A function to create a new instance of window ~a." flavor-name)
       (let* ((flavor-type ',flavor-name)
	      (gc-background-screen (make-instance flavor-type
						   :closure-variables '(background ,@closure-vars)))
	      (typeout (or (send gc-background-screen  :selection-substitute)
			    ,(and (null typeout-type) '(any-listener-p gc-background-screen))
			    (make-instance ',(or typeout-type 'W:lisp-listener)
					   :superior gc-background-screen :more-p nil))))
	 (send gc-background-screen :set-selection-substitute typeout)
	 (SEND gc-background-screen :eval-inside-closure #'SET 'background gc-background-screen)
	 (send gc-background-screen :grey-background)
	 (send typeout :set-gulf-coast-size ,@(or typeout-size `(80 35 0 65)))
	 ,@initialization
	 (expose-and-select typeout)
	 ))
     (W:add-system-key ,system-key ',flavor-name ,(format nil "~a Gulf Coast Application Window." application-name)
			'(,select-name)))))


;;;********************************************************************************
;;; This is a generic gulf-coast application so people can play with it.

(gulf-coast-application GENERIC #\space *GENERIC-gulf-coast-commands*)  

(BUILD-COMMAND-TABLE '*GENERIC-gulf-coast-commands*  'GENERIC-gulf-coast-background
  '(GULF-COAST-COMMAND
    GULF-COAST-REFRESH 
    GULF-COAST-HELP-MENU
    pop-up-Gulf-Coast-operations-menu
    GC-MOVE-COM
    GC-RESHAPE-com
    GC-CLEAR-com
    GC-KILL-com
    GC-REFRESH-com
    GC-BURY-com
    gc-switch-configuration
    gc-edit-configuration 
    gc-add-configuration
    )
  :INIT-OPTIONS
  '(:name "Gulf Coast Window application menu."
	  :documentation "Gulf Coast Window command documentation string"))