;;; -*- Mode:LISP; Package:USER; Fonts:(MEDFNT); Readtable:CL; Base:10 -*-

;;;HARDCOPY-OPTIONS
;;;
;;;Menu interface for setting hardcopy (printer) parameters, e.g. selecting
;;;a default printer, setting printer-specific options, etc.
;;;

;;;Defines a structure to represent printers, and a means to
;;;collect them.  The printer(s) is(are) gathered from site
;;;file and TIGER information.

;;;KNOWN-PRINTER structure definition:

(defstruct known-printer
  (host si:local-host)		;Associated host
  (name "<UNNAMED>")		;Printer name, if any
  (driver :vanilla)		;Printer driver specification
  (names nil)			;Other printer names
  (known-by nil)		;How printer definition was obtained
				;See *PRINTERS-ARE-KNOWN-BY-PRIORITY*
  (known-as nil)		;How to reconstruct printer spec
				; suitable for SETQ'ing SI:*DEFAULT-PRINTER*
  (currently-selected nil)	;Is this the selected/default printer?
  )

;;;Always coerce printer name(s) to upper-case string; anything else, NIL

(defun fix-printer-names(names)
  (typecase names
    (null nil)
    ((or string symbol) (ncons (string-upcase names)))
    (cons (mapcan #'fix-printer-names names))
    (t nil)))

;;;Smart constructor for known-printer structures

(defun create-known-printer(host driver
			    &optional
			    name names (known-by :default) known-as)
  (setq host (si:parse-host host))
  (make-known-printer
    :host host
    :name (car(fix-printer-names (or name "<UNNAMED>")))
    :driver (intern-soft (string-upcase driver) 'keyword)
    :names (fix-printer-names names)
    :known-by known-by
    :known-as (or known-as (list driver (send host :name)))))

;;;;;;Utility functions for KNOWN-PRINTER structures
;;;

;;;Values for KNOWN-PRINTER-ENTRY-KNOWN-BY; these are ranked in decreasing
;;;order of "authority", i.e., printer entries known by :NAME are a better
;;;source of knowledge about the printer than an equivalent definition by
;;;:DEFAULT.  Used for retaining what to SETQ SI:*DEFAULT-PRINTER* to.

(defvar *printers-are-known-by-priority*
	'(:ASKED :LIST :NAME :DRIVER :DEFAULT))

;;;Rank priority

(defun known-printer-knowledge-priority(printer)
  (length (member (known-printer-known-by printer)
		  *printers-are-known-by-priority*)))

;;;How to compare equality of printer entries; considered equal if they have
;;;same host and driver.  (As usual in CommonLISP, apply the TEST to the
;;;results of applying the KEY.)

(defun known-printers-equal-test(key-1 key-2)
  (equal key-1 key-2))

(defun known-printers-equal-key(printer)
  (cons (known-printer-host printer)
	(known-printer-driver printer)))

;;;Decode any type of printer spec; returns 2 values, driver and host.  If
;;;host is NIL, we blew up in system's decoding of printer spec.

(defun printer-type-and-host(spec)
  (declare(values driver host))
  ;;SPEC must be either
  ;;  1. a full printer spec cons (<driver> <host>)
  ;;  2. a string indexed in SI:*PRINTER-NAMES*
  ;;  3. a symbol indexed in TIGER:*DEFAULT-PRINTER-HOST-ALIST*
  (catch-error
    (tiger:figure-out-printer-type-and-host
      (if (stringp spec)
	  (si:expand-printer-name spec)
	spec))
    nil))

;;;Make a printer structure from a site file printer specification

(defun make-printer-from-spec(printer)
  (when printer
    (multiple-value-bind(driver host)
	(printer-type-and-host printer)
      (and driver host
	   (create-known-printer
	     host driver
	     nil nil		       ;name,names
	     (typecase
	       printer		       ;known-by
	       (list :list)
	       (symbol :driver)
	       (string :name)
	       (t :default))
	     printer		       ;known-as
	     )))))

;;;;;;Global printer gathering / remembering
;;;

;;;Current known-printer object corresponding to SI:*DEFAULT-PRINTER*

(defvar *currently-selected-text-printer*)

;;;Current known-printer object corresponding to SI:*DEFAULT-BIT-ARRAY-PRINTER*

(defvar *currently-selected-graphics-printer*)

;;;We can remember "manually defined" printer objects by saving them here.

(defvar *previously-mentioned-printers* nil)

;;;This controls whether we use *PREVIOUSLY-MENTIONED-PRINTERS*.

(defvar *remembering-previously-mentioned-printers* t)

;;;List of all currently known printers.

(defvar *currently-gathered-printers* nil)

;;;;;;Utility functions for lists of printers
;;;

;;;SORT-PRINTERS sorts a list of printers, removing duplicates by host/driver

(defun sort-printers(printers)
  (remove-duplicates
    ;;Sorting...
    (sort
      ;;Remove null entries (e.g., no/invalid default printer)
      (remove-if
	#'null
	printers)
      ;;Sort predicate: comparing two printers,
      #'(lambda(a b)
	  (or
	    ;;Sort first by host name
	    (string-lessp (known-printer-host a)
			  (known-printer-host b))
	    ;;Within host...
	    (and (string-equal (known-printer-host a)
			       (known-printer-host b))
		 ;;By driver...
		 (or (string-lessp (known-printer-driver a)
				   (known-printer-driver b))
		     ;;Within driver...
		     (and (string-equal (known-printer-driver a)
					(known-printer-driver b))
			  ;;Then by knowledge-priority order
			  (> (known-printer-knowledge-priority a)
			     (known-printer-knowledge-priority b))))))))
    :from-end t
    :test #'known-printers-equal-test
    :key #'known-printers-equal-key))

;;;Locate a printer, EQUAL by host and driver, from a list

(defun find-equivalent-printer(printer &optional
			       (printers *currently-gathered-printers*))
  (when printer
    (car (member (known-printers-equal-key printer) printers
		 :test #'known-printers-equal-test
		 :key  #'known-printers-equal-key))))

;;;Are there any duplicate printers by host only?

(defun duplicate-host-printers
       (&optional (printers *currently-gathered-printers*))
  (set-difference printers
		  (remove-duplicates printers
			  :key #'known-printer-host)))

;;;GATHER-PRINTERS assembles all the printer objects we can find

(defun gather-printers(&optional
		       (previously-mentioned-printers
			 (copy-list *previously-mentioned-printers*)))
  "Gather everything known about printers.  Printers are
defined in the site configuration information (site files),
but they are retained in global variables.  These variables are:
  1. SI:*DEFAULT-PRINTER*
  2. TIGER:*DEFAULT-PRINTER-HOST-ALIST* 
  3. SI:*PRINTER-NAMES*
PREVIOUSLY-MENTIONED-PRINTERS is used to keep/pass on printers
that have been manually defined (e.g., not in site files.)"
  ;;First create entry for default printer:
  (let*((default-text-printer-entry
	  (make-printer-from-spec si:*default-printer*))
	(default-graphics-printer-entry
	  (make-printer-from-spec si:*default-bit-array-printer*))
	(driver-printer-entries
	  (loop for entry in tiger:*default-printer-host-alist*
		with names = nil
		with name = nil
		as driver = (car entry)
		as host = (cadr entry)
		collect
		(create-known-printer
		  host driver name names
		  :driver
		  driver		   ;known-as
		  )))
	(named-printer-entries
	  (loop for spec in si:*printer-names*
		as names = (car spec)
		as info = (cadr spec)
		as name = (car names)
		as driver = (car info)
		as host = (cadr info)
		collect
		(create-known-printer
		  host driver
		  name (cdr names)
		  :name
		  name			   ;known-as
		  )))
	(printers
	  (append
	    (list default-text-printer-entry default-graphics-printer-entry)
	    driver-printer-entries
	    named-printer-entries
	    (and *remembering-previously-mentioned-printers*
		 previously-mentioned-printers))))
    ;;Now process this combined list of printers
    (setq *currently-gathered-printers*
	  (setq printers (sort-printers printers)))
    ;;Define globally-known, selected printers
    (setq *currently-selected-text-printer*
	  (and default-text-printer-entry
	       (find-equivalent-printer default-text-printer-entry)))
    (setq *currently-selected-graphics-printer*
	  (and default-graphics-printer-entry
	       (find-equivalent-printer default-graphics-printer-entry)))
    (cond
      ((and (null *currently-selected-text-printer*)
	    (null *currently-selected-graphics-printer*)))
      ((eq *currently-selected-text-printer*
	   *currently-selected-graphics-printer*)
       (setf (known-printer-currently-selected
	       *currently-selected-text-printer*)
	     :both))
      (t
       (when *currently-selected-text-printer*
	 (setf (known-printer-currently-selected
		 *currently-selected-text-printer*)
	     :text))
       (when *currently-selected-graphics-printer*
	 (setf (known-printer-currently-selected
		 *currently-selected-graphics-printer*)
	       :graphics))))
    ;;Return flag -- printers defined?
    (not(null printers))))

;;;;;;HARDCOPY-OPTIONS interface
;;;

;;;Global window - only need one!

(defvar *hardcopy-options-window* nil "Hardcopy Options Window")
(defvar *w)				   ;shorthand/debug

;;;;;;Scroll items for window

(defvar *display-printer-host-width* 15.)
(defvar *display-printer-name-width* 15.)
(defvar *display-printer-driver-width* 15.)
(defvar *display-printer-selected-width* 8.)

(defstruct printer-format
  known-printer
  name
  host
  driver
  (host-w *display-printer-host-width*)
  (name-w *display-printer-name-width*)
  (driver-w *display-printer-driver-width*)
  stuff)

(defun create-printer-format(known-printer)
  (flet((exactly(string size)
		(substring (format nil "~va" size string)
			   0 size)))
    (let((format (make-printer-format
		   :known-printer known-printer)))
      (setf (printer-format-name format)
	    (exactly (known-printer-name known-printer)
		     (printer-format-name-w format)))
      (setf (printer-format-host format)
	    (exactly (known-printer-host known-printer)
		     (printer-format-host-w format)))
      (setf (printer-format-driver format)
	    (exactly (known-printer-driver known-printer)
		     (printer-format-driver-w format)))
      format)))

(defun printer-supports(printer)
  (let*((driver (known-printer-driver printer))
	(text (getf (plist driver) 'si:print-file))
	(graphics (getf (plist driver ) 'si:print-bit-array)))
    (cond((and text graphics) :both)
	 ((and (null text) graphics) :graphics)
	 ((and (null graphics) text) :text)
	 (t nil))))

(defun hardcopy-options-hard-error(fmt &rest args)
  (error "Internal HARDCOPY-OPTIONS error -- report this to Customer Support.~%~a"
	 (apply #'format nil fmt args)))

(defun show-selections()
  "Show how/what printers are currently selected"
  (dolist(prt *currently-gathered-printers*)
    (format t "~&~va ~va ~@[~va~]"
	    *display-printer-host-width*
	    (known-printer-host prt)
	    *display-printer-driver-width*
	    (known-printer-driver prt)
	    *display-printer-selected-width*
	    (known-printer-currently-selected prt))))

;;;;;;Actual option routines
;;;

(defun select-printer(printer &optional select-as)
  "Mark printer as currently selected"
  (let((realprinter (find-equivalent-printer printer)))
    (if realprinter
	(setq printer realprinter)
      (hardcopy-options-hard-error
	"Attempt to select an unknown printer:~2%~s~%" printer)))
  (unless select-as
    (setq select-as
	  (let((supports (printer-supports printer))
	       (driver (known-printer-driver printer)))
	    (cond
	      ((null supports)
	       (tv:menu-choose
		 '(("Select it anyway?" :both))
		 (format nil "Printer ~a doesn't support text or graphics!" driver)
		 '(:MOUSE)))
	      ((neq supports :both)
	       (tv:menu-choose
		 (ncons(list (format nil "~a only" supports) supports))
		 (format nil "Printer ~a has limited support" driver)))
	      (t (tv:menu-choose
		   '(("Graphics" :graphics)
		     ("Text Files" :text)
		     ("Both Text and Graphics" :both))
		   (format nil "Select printer ~a for:" driver)))))))
  ;;Now, might have NIL select-as...
  (when select-as
    ;;Clear out all selections, just to be sure
  (loop for prnt in *currently-gathered-printers*
	do (setf (known-printer-currently-selected prnt) nil))
  ;;Set selections
  (case select-as
    (:text
     (setq *currently-selected-text-printer* printer)
     (setf (known-printer-currently-selected printer) :text)
     (setf (known-printer-currently-selected
	     *currently-selected-graphics-printer*)
	   (if (neq printer *currently-selected-graphics-printer*)
	       :graphics :both)))
    (:graphics
     (setq *currently-selected-graphics-printer* printer)
     (setf (known-printer-currently-selected printer) :graphics)
     (setf (known-printer-currently-selected
	     *currently-selected-text-printer*)
	   (if (neq printer *currently-selected-text-printer*)
	       :text :both)))
    (:both
     (setq *currently-selected-text-printer* printer)
     (setq *currently-selected-graphics-printer* printer)
     (setf (known-printer-currently-selected printer) :both)))
  ;;Set global/special values of default printers
  (setq si:*default-printer*
	(known-printer-known-as *currently-selected-text-printer*))
  (setq-globally si:*default-printer*
		 (known-printer-known-as *currently-selected-text-printer*))
  (setq si:*default-bit-array-printer*
	(known-printer-known-as *currently-selected-graphics-printer*))
  (setq-globally si:*default-bit-array-printer*
		 (known-printer-known-as *currently-selected-graphics-printer*))))

;;;???bad bug - can't change a default printer
(defun change-printer-driver(printer &optional new-driver)
  "Change printer driver to NEW-DRIVER, or prompt with menu"
  (let((realprinter (find-equivalent-printer printer)))
    (if realprinter
	(setq printer realprinter)
      (hardcopy-options-hard-error
	"Attempt to modify an unknown printer:~2%~s~%" printer)))
  (if new-driver
      (setf (known-printer-driver printer) new-driver)
    (let*((current-driver (known-printer-driver printer))
	  (new-driver (tv:menu-choose
			(copy-list tiger:*tiger-printer-types*)
			(format nil "Choose printer driver for host ~a"
				(known-printer-host printer))
			'(:mouse)
			current-driver)))
      (when new-driver
	(setf (known-printer-driver printer) new-driver)
	(when (known-printer-currently-selected printer)
	  (setf (known-printer-known-as printer)
		(list (known-printer-driver printer)
		      (known-printer-host printer)))
	  (setf (known-printer-known-by printer) :list))))))
	  

(defun add-printer()
  (let ((new-host (send si:local-host :string-for-printing))
	(new-driver :ti855)
	(select-text t)
	(select-graphics t))
    (declare(special new-host new-driver select-text select-graphics))
    (tv:choose-variable-values
      `((new-host "Host NAME" :sexp)
	(new-driver "Printer TYPE" :choose ,tiger:*tiger-printer-types*)
	(select-text "Select for TEXT" :boolean (yes no))
	(select-graphics "Select for GRAPHICS" :boolean (yes no)))
      :label "Specify host NAME and printer TYPE to add new printer")
    (let((printer (make-printer-from-spec (list new-driver new-host))))
      (if (null printer)
	  (tv:menu-choose
	    (ncons "Click to continue")
	    (format nil "Invalid specification: ~a on ~a"
		    new-driver new-host))
	(let((old-printer (find-equivalent-printer printer)))
	  (if old-printer
	      (if
		(tv:menu-choose
		  (ncons
		    (if (or select-text select-graphics)
			"Click to select as default printer"
		      "Click to continue"))
		  (format nil "Printer ~a on ~a already defined"
			  new-driver new-host))
		(setq printer old-printer)
		(return-from add-printer))
	    (progn
	      (setq *currently-gathered-printers*
		    (sort-printers
		      (cons printer *currently-gathered-printers*)))
	      (setq printer (find-equivalent-printer printer))))
	  (when printer
	    (if select-text (select-printer printer :text))
	    (if select-graphics (select-printer printer :graphics))))))))

;;;;;;Driver routines that can be run within a pop-up window
;;;

(defmacro within-nested-pop-up((name window) &body body)
  "Wrap this around a BODY that has to call a menu within
a POP-UP-SCROLL-WINDOW -- otherwise, hysteretical control of
the pop-up will cause the invoked menu to lose, putting you out
of commission (mouse won't work)."
  `(process-run-function
    "Choose menu within pop-up-scroll-window"
    #'(lambda()
	(let((,name ,window))
	  (send ,name :pop-up-within-menu)
	  (unwind-protect
	      (progn ,@body)
	    (progn
	      (send ,name :pop-up-done-with-menu)
	      (send-if-handles ,name :redisplay)))))))

(defun select-printer-in-window
       (printer &optional select-as window)
  (declare(special *hardcopy-options-window*))
  (setq window (or window *hardcopy-options-window*))
  (within-nested-pop-up (w window)
    (select-printer printer select-as)))

(defun change-printer-driver-in-window
       (printer &optional driver window)
  (declare(special *hardcopy-options-window*))
  (setq window (or window *hardcopy-options-window*))
  (within-nested-pop-up (w window)
    (change-printer-driver printer driver)))

(defun add-printer-in-window (&optional window)
  (declare(special *hardcopy-options-window*))
  (setq window (or window *hardcopy-options-window*))
  (within-nested-pop-up (w window)
    (add-printer)))

;;;;;;Scroll window items
;;;

(defvar *hardcopy-options-window-display-items*
	"Generated :DISPLAY-ITEMS for *HARDCOPY-OPTIONS-SCROLL-WINDOW*")

(defun known-printer-scroll-items()
  (tv:scroll-maintain-list
    #'(lambda() *currently-gathered-printers*)
    #'(lambda(printer)
	(list ()
	      (tv:scroll-parse-item
		`(:mouse
		   (nil
		     :eval (select-printer-in-window ',printer)
		     :documentation "Select printer")
		   :string
		   ,(send (known-printer-host printer) :string-for-printing)
		   ,*display-printer-host-width*)
		" "
		`(:string
		   ,(known-printer-name printer)
		   ,*display-printer-name-width*)
		" "
		`(:mouse
		   (nil
		     :eval (change-printer-driver-in-window ',printer)
		     :documentation "Change printer driver type")
		   :function
		   ,#'known-printer-driver
		   ,(ncons printer)
		   ,*display-printer-driver-width*)

		" "
		`(:function
		   ,#'known-printer-currently-selected
		   ,(ncons printer)
		   ,*display-printer-selected-width*
		   ("~@[~a~]"))
		)))))

(defun create-scroll-items(&rest items)
  (cons nil
	(mapcar #'tv:scroll-parse-item items)))

(defun display-printer-banner-item()
  (create-scroll-items
    ""
    "Click on the printer HOST name to select a printer."
    "Click on the printer TYPE to redefine the driver type."
    ""
    (format nil "~va ~va ~va ~a"
	    *display-printer-host-width* "HOST"
	    *display-printer-name-width* "NAME"
	    *display-printer-driver-width* "TYPE"
	    "SELECTED")
    ""))

(defun kill-hardcopy-options()
  (process-run-function "Kill HARDCOPY-OPTIONS"
			#'(lambda()
			    (send *hardcopy-options-window* :deactivate))))

(defun other-options-items()
  (list
    ()
    (tv:scroll-parse-item "")
    (tv:scroll-parse-item
      "Click "
      `(:mouse
	 (nil :eval (add-printer-in-window)
	      :documentation "Click to define another printer")
	 :string ">HERE<")
      " to define another printer.")
    (tv:scroll-parse-item
      "Click "
      `(:mouse
	 (nil :eval (kill-hardcopy-options)
	      :documentation "Click to exit HARDCOPY-OPTIONS")
	 :string ">HERE<")
      " to exit.")))

;;;;;;Put together all the scroll items
;;;;;;Also (re)initializing the window

(defun forget-hardcopy-options-window()
  (setq *hardcopy-options-window* nil))

(defun prepare-hardcopy-options-window()
  (setq *hardcopy-options-window-display-items*
	(list ()
	      (display-printer-banner-item)
	      (known-printer-scroll-items)
	      (other-options-items)))
  (setq *hardcopy-options-window* nil))

(add-initialization "Prepare Hardcopy-Options window"
		   '(prepare-hardcopy-options-window)
		   '(once))


;;;;;; Window flavor definition
;;;

(defflavor pop-up-scroll-window
	 ((pop-up-using-menu-stack nil))
	 (
	  tv:scroll-mouse-mixin
	  tv:borders-mixin
	  tv:top-box-label-mixin
	  tv:scroll-window-with-typeout
	  tv:hysteretic-window-mixin
	  )
  :inittable-instance-variables
  :gettable-instance-variables)

(defmethod (pop-up-scroll-window :pop-up-within-menu) ()
  (push t pop-up-using-menu-stack))

(defmethod (pop-up-scroll-window :pop-up-done-with-menu) ()
  (pop pop-up-using-menu-stack))

;;; The following liberally "borrowed" from flavor TV:BASIC-MOMENTARY-MENU
;;;
;;; When no selection, but mouse moved out of range, deexpose menu.

(DEFMETHOD (pop-up-scroll-window :AFTER :HANDLE-MOUSE) ()
  (OR
    ;; DON'T FLUSH IF MOUSE BEING USURPED
    TV:WINDOW-OWNING-MOUSE
    ;; ONLY FLUSH US IF EITHER NOT EXPLICITLY FLUSHING OR WE DON'T OWN MOUSE
    (AND TV:MOUSE-RECONSIDER (EQ SELF (TV:WINDOW-OWNING-MOUSE)))
    ;; Don't flush if flag set, e.g. when pop-up has called a different menu
    pop-up-using-menu-stack
    ;; THIS IS CALLED IN THE MOUSE PROCESS.  WE DON'T WANT TO TAKE THE
    ;; CHANCE THAT WE MIGHT GO BLOCKED, SO RUN IN ANOTHER PROCESS.
    (PROCESS-RUN-FUNCTION '(:NAME "MENU DEACTIVATE" :PRIORITY 20.) SELF ':DEACTIVATE)))

(DEFMETHOD (pop-up-scroll-window :BEFORE :INIT) (plist)
  ;; Default the height according to the number of variables, unless
  ;; it was specified explicitly.
  (OR (tv:HEIGHT-SPECIFIED-IN-INIT-PLIST PLIST)
      (PUTPROP PLIST
	       (max (min (+ (length *currently-gathered-printers*) 12.) 30.) 1)
	       ':CHARACTER-HEIGHT)))

(compile-flavor-methods pop-up-scroll-window)

(defvar *hardcopy-options-text-font* fonts:cptfont)

(defun window-width()
  (*
    (+ *display-printer-host-width* 1
       *display-printer-name-width* 1
       *display-printer-driver-width* 1
       8
       3)
    (font-char-width *hardcopy-options-text-font*)))

(defun make-hardcopy-options-window()
  (let((w (make-instance 'pop-up-scroll-window
			 :font-map (ncons *hardcopy-options-text-font*)
			 :label (list :string "Hardcopy Options"
				      :font 'tr12b)
			 :width (window-width)
			 :hysteresis 50.
			 :borders 4
			 :display-item
			 *hardcopy-options-window-display-items*)))
    (setq *hardcopy-options-window* w)))

(defun recheck-printers-in-case-redefined()
  (let((text (find-equivalent-printer
	       (make-printer-from-spec si:*default-printer*)))
       (graphics (find-equivalent-printer
		   (make-printer-from-spec si:*default-bit-array-printer*))))
    (or
      (and
	text
	(eq text *currently-selected-text-printer*)
	graphics
	(eq graphics *currently-selected-graphics-printer*))
      (gather-printers))))

(defun run-hardcopy-options(&optional window)
  (recheck-printers-in-case-redefined)
  (setq window
	(or window			   ;Might pass one in,
	    *hardcopy-options-window*	   ;Might have made one,
	    (make-hardcopy-options-window  ;Might have to make one.
	      )))
  (send window :activate)
  (send window :expose-near '(:mouse))
  (send window :redisplay))

;;; ;;; Good housekeeping (site option initializations)
;;;

;;; Run initializations, set globals, safely; suitable for
;;; use in system/site initialization list!

(defun initialize-hardcopy-options()
  (catch-error
    (progn
      (gather-printers)
      (prepare-hardcopy-options-window))))

;;; Make sure to gather printers if (UPDATE-SITE-CONFIGURATION-INFO)

(add-initialization "Initialize Hardcopy-Options"
		    '(initialize-hardcopy-options)
		    '(once site-option))