;;; -*- Mode:LISP; Package: COMPOSER; Readtable:CL; Base:10 -*-
;;;
;;; Window system user interface for composer system
;;;
;;;

(defflavor composer-frame (music-pane)
	   (tv:process-mixin
	    tv:select-mixin
	    tv:inferiors-not-in-select-menu-mixin
	    tv:alias-for-inferiors-mixin
	    tv:essential-mouse
	    tv:bordered-constraint-frame-with-shared-io-buffer
	    tv:top-box-label-mixin)
  (:default-init-plist
    :save-bits :delayed
    :io-buffer (tv:make-io-buffer #o512 nil 'tv:kbd-default-output-function)
    :process '(composer-frame-process :regular-pdl-size 16000 :special-pdl-size 2000)
    :borders 1
    :label '(:string "Music Composer" :font fonts:metsi :centered)
    :configuration 'basic
    :panes `((music-pane music-pane)
	     (interaction-pane interaction-pane))
    :constraints
    `((basic
	(music-pane interaction-pane)
	((interaction-pane 30 :lines)
	 (music-pane :even)))))
  :gettable-instance-variables
  :settable-instance-variables)

(defmethod (composer-frame :after :init) (&rest ignore)
  (send self :set-selection-substitute
	(send self :get-pane 'interaction-pane))
  (setq music-pane
	(send self :get-pane 'music-pane)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Lisp listener pane
;;;
;;;

(defflavor interaction-pane ()
	   (tv:notification-mixin
	    tv:list-mouse-buttons-mixin
	    tv:window))

(defmethod (interaction-pane :package) ()
  (pkg-find-package 'composer))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Music graphics pane
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defflavor music-pane ((blinker-array (make-array 256 :type 'art-q))
		       (blinker-char 0)
		       (script-pointer))
	   (tv:graphics-mixin tv:window)
  (:default-init-plist
    :blinker-p nil)
  :gettable-instance-variables
  :settable-instance-variables)

(defmethod (music-pane :after :init) (&rest ignore)
  (setup-mouse-note-blinkers-for-window blinker-array self))

(defmethod (music-pane :mouse-standard-blinker) ()
  (tv:mouse-set-blinker (aref blinker-array blinker-char)))

(defmethod (music-pane :set-mouse-blinker) (number)
  (check-type number (integer 0 255))
  (setq blinker-char number)
  (send self :mouse-standard-blinker))

(tv:add-system-key #\Z 'composer-frame "Music Composition Frame")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Mouse note blinkers
;;;
;;;

(defflavor mouse-note-blinker ()
	   (tv:mouse-character-blinker))

(defun setup-mouse-note-blinkers-for-window (array window)
  (dotimes (c 256)
    (setf (aref array c)
	  (make-instance 'tv:mouse-character-blinker
			 :char c
			 :font fonts:music-font
			 :sheet window))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Process stuff
;;;
;;;

(defvar *composer-closure* :unbound)

(defvar *composer-closure-variables* nil)

(defvar *whole-frame* :unbound)

(defvar *default-menu-font* fonts:medfnb
  "This is the default font for the command menu")

(defmacro define-closed-variable (symbol &optional reset-form documentation)
  `(progn 'compile
	  (defvar ,symbol :unbound ,documentation)
	  (putprop ',symbol ',reset-form :reset-form)
	  (setq *composer-closure-variables*
		(nunion *composer-closure-variables* (ncons ',symbol)))))

(defun reset-closure-variables (closure)
  (dolist (c (closure-variables closure))
    (set-in-closure closure c (si:eval-special-ok (get c :reset-form)))))

(defun make-composer-closure (bindings &optional (init-p t))
  (let ((closure (closure (copylist bindings) #'funcall)))
    (when init-p
      (reset-closure-variables closure))
    closure))

(define-closed-variable *interaction* (send *whole-frame* :get-pane 'interaction-pane))
(define-closed-variable *music* (send *whole-frame* :get-pane 'music-pane))

(defun composer-frame-process (window)
  (let ((*package* (pkg-find-package 'tape)))
    (error-restart-loop (restart "Back to Toplevel COMPOSER loop")
      (let* ((*whole-frame* window)
	     (*composer-closure* (make-composer-closure *composer-closure-variables* nil)))
	(reset-closure-variables *composer-closure*)
	(funcall *composer-closure* #'composer-toplevel)))))

(defun composer-toplevel ()
  (let ((terminal-io (send *whole-frame* :get-pane 'interaction-pane)))
    (error-restart-loop (sys:abort "Back to Toplevel COMPOSER loop")
      (composer-toplevel-1-loop))))

(defun composer-toplevel-1-loop ()		;stolen from SI:LISP-TOP-LEVEL1
  si:(let (old-package w-pkg (top-level-p t))
       (FORMAT T "~&;Reading~:[~; at top level~]~@[ in ~A~]."
	       TOP-LEVEL-P (SEND-IF-HANDLES *TERMINAL-IO* :NAME))
       (PUSH NIL *VALUES*)
       (DO ((*READTABLE* si:common-lisp-readtable)
	    (LAST-TIME-READTABLE NIL)
	    THROW-FLAG)				;Gets non-NIL if throw to COMMAND-LEVEL (e.g. quitting from an error)
	   (NIL)				;Do forever
	 ;; If *PACKAGE* has changed, set OLD-PACKAGE and tell our window.
	 ;; Conversely, if the window's package has changed, change ours.
	 ;; The first iteration, we always copy from the window.
	 (COND
	   ;; User set the package during previous iteration of DO
	   ;; => tell the window about it.
	   ((AND OLD-PACKAGE (NEQ *PACKAGE* OLD-PACKAGE))
	    (SEND-IF-HANDLES *TERMINAL-IO* :SET-PACKAGE *PACKAGE*)
	    (SETQ OLD-PACKAGE *PACKAGE*))
	   ;; Window's package has been changed, or first iteration through DO,
	   ;; => set our package to the window's -- if the window has one.
	   ((SETQ W-PKG (SEND-IF-HANDLES *TERMINAL-IO* :PACKAGE))
	    (AND (NEQ W-PKG *PACKAGE*)
		 (SETQ *PACKAGE* W-PKG))
	    (SETQ OLD-PACKAGE *PACKAGE*))
	   ;; First time ever for this window => set window's package
	   ;; to the global value of *PACKAGE*.
	   ((NULL OLD-PACKAGE)
	    (SETQ OLD-PACKAGE *PACKAGE*)
	    (SEND-IF-HANDLES *TERMINAL-IO* :SET-PACKAGE *PACKAGE*)))
	 (CHECK-FOR-READTABLE-CHANGE LAST-TIME-READTABLE)
	 (SETQ LAST-TIME-READTABLE *READTABLE*)
	 (SETQ THROW-FLAG T)
	 (CATCH-ERROR-RESTART ((SYS:ABORT DBG:DEBUGGER-CONDITION) "Return to top level in ~A."
			       (OR (SEND-IF-HANDLES *TERMINAL-IO* :NAME) "current process."))
	   (FRESH-LINE)
	   (SETQ +++ ++ ++ + + -)		;Save last three input forms
	   (SETQ - (read-for-top-level nil nil '((:preemptable) (:activation char= #\end))))
	   (if (and (listp -) (eq (car -) :mouse-button))
	       (send-if-handles (third -) :process-mouse-blip -)
	     (LET ((LISP-TOP-LEVEL-INSIDE-EVAL T)
		   VALUES)
	       (UNWIND-PROTECT
		   (SETQ VALUES (MULTIPLE-VALUE-LIST (EVAL-ABORT-TRIVIAL-ERRORS -)))
		 ;; Always push SOMETHING -- NIL if evaluation is aborted.
		 (PUSH VALUES *VALUES*))
	       (SETQ /// // // / / VALUES)
	       (SETQ *** ** ** * * (CAR /)))
	     (DOLIST (VALUE / (terpri))
	       (FRESH-LINE)
	       (FUNCALL (OR PRIN1 #'PRIN1) VALUE)))
	   (SETQ THROW-FLAG NIL))
	 (WHEN THROW-FLAG
	   ;; Inform user of return to top level.
	   (FORMAT T "~&;Back to top level~@[ in ~A~]."
		   (SEND-IF-HANDLES *TERMINAL-IO* :NAME))))))