;;; -*- Mode:LISP; Package:TIGER; Base:8; Fonts:(CPTFONT TR12I); Readtable:T -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

;1;; Utilities used by functions in this file*

(defmacro defun-with-arglist (fun-name arglist-var args &body body)
  `(defun ,fun-name ,args
     (declare (:arglist ,(symeval arglist-var)))
     . ,body))

(defun dwimify-filename (file)
  (let ((path (fs:merge-pathname-defaults file)))
    (condition-case (dwimified-path)
	(send path :truename)
      (:no-error (send dwimified-path :string-for-printing))
      (fs:file-not-found
       (let* ((dir-list (fs:directory-list
			  (send path :new-pathname :type :wild :version :newest)))
	      (real-path
		(loop for dir-entry in dir-list
		      for new-path = (car dir-entry)
		      do (cond ((null new-path))
			       ((fquery nil "File ~A does not exist.~&  Did you mean ~A? "
				       path new-path)
				(return new-path)))
		      finally (format query-io 
				      "~&File ~A does not match any existing files." file)
			      (return nil))))
	 (cond (real-path (send (send real-path :truename)
				:string-for-printing))
	       (t nil))))
      (:otherwise nil))))

(defun extract-printer-from-options (options &optional array-p)
  (or (cadr (memq :printer options))
      (if array-p si:*default-bit-array-printer* si:*default-printer*)))


(defflavor tiger-operator-window
	   ((first-time t))
	   (tv:process-mixin tv:notification-mixin tv:window)
  (:settable-instance-variables)
  (:default-init-plist
    :more-p nil))

(defmethod (tiger-operator-window :after :kill) (&rest ignore)
  (setq *tiger-operator-window* nil))

(defvar *tiger-operator-window* nil)

(defun tiger-operator-process-toplevel (window)
  ;; Bind variables to make debugging easier
  (let ((terminal-io window)
	(*package* (find-package "TIGER"))
	(base 8)
	(ibase 8)
	(readtable (si:find-readtable-named "T")))
    (cond ((send terminal-io :first-time)
	   (format t "~&; Started at ")
	   (send terminal-io :set-first-time nil)
	   (time:print-current-date terminal-io))
	  ('else
	   (format t "~&; Reset at ")
	   (time:print-current-date terminal-io)))
    (tiger-file-internal)))

(defun set-local-printer (&optional (type :ti855))
  "Sets the default printer to be the one on the local device port"
  (setq si:*default-printer* (list type (send si:local-host :short-name)))
  (setq si:*default-bit-array-printer* (list type (send si:local-host :short-name))))


(defun make-tiger-operator-window (&aux w)
  (setq w (make-instance 'tiger-operator-window
			 :superior tv:main-screen
			 :save-bits t
			 :process '(tiger-operator-process-toplevel
				     :regular-pdl-size #o40000)
						;same size as a lisp listener
						;the default value was far too small
			 :edges (multiple-value-bind (x0 y0 x1 y1)
				    (send tv:main-screen :edges)
				  ;; no need to create anything huge...
				  (list x0
					y0
					x1
					(+ y0 (// (- y1 y0) 2))))))
  (send w :set-more-p nil)
  (send w :set-deexposed-typeout-action :permit)

  (send (send w ':process) ':run-reason w)	;use these, instead of :SELECTing
  (send w ':activate)	

  w)	



(defun start-tiger ()
  (cond ((null *tiger-operator-window*)
	 (setq *tiger-operator-window* (make-tiger-operator-window)))))

(defun kill-tiger-operator-window ()
  "to be use only when debugging"
  (when *tiger-operator-window*
    (send *tiger-operator-window* ':deactivate)
    (send *tiger-operator-window* :kill)
    (setq *tiger-operator-window* nil)))

#|
;; inside a comment.
(kill-tiger-operator-window)

|#
  
(defun reset-tiger ()
  (with-tiger-queue-lock
    (mapc 'free-queue-entry-array tiger-queue)
    (setq tiger-queue nil)
    (setq *tiger-queue-job-number* 0)
    (dolist (ptype *tiger-printer-types*)
      ;; clear the cache of streams, useful for debugging.
      (remprop ptype 'tiger-stream))
    (UNWEDGE-TIGER)))

(defun UNWEDGE-TIGER ()
  (when *tiger-operator-window*
    (send (send *tiger-operator-window* :process) :reset)))

(defun abort-file (&optional job-number bad-boy)
  "use this only on the locally running printer"
  (with-tiger-queue-lock
    (cond ((null tiger-queue)
	   "There is nothing in the local tiger queue")
	  ((setq bad-boy (if (null job-number)
			     (car tiger-queue)
			   (car (mem #'(lambda (n entry)
					 (equal (tq-job-number entry) n))
				     job-number
				     tiger-queue))))
	   (free-queue-entry-array bad-boy)
	   (let ((being-processed? (eq (car tiger-queue) bad-boy)))
	     (setq tiger-queue (delq bad-boy tiger-queue))
	     (cond (being-processed?
		    (unwedge-tiger)
		    "job being processed aborted")
		   ('else
		    "Job in queue deleted"))))
	  ('else
	   "job not found in queue"))))

(defun make-tiger-queue-directory-filename (host name type)
  (fs:make-pathname :host host
		    :directory "TIGER-QUEUE"
		    :name name
		    :type type
		    :version :newest))
		  

;1;; User-level routines*
;1;; These are the only functions here which should ever be called by users.*
;1;; Actually, an even better idea for users would be to use the functions *HARDCOPY-FILE1, *HARDCOPY-STREAM1,*
;1;; *HARDCOPY-BIT-ARRAY1, and *HARDCOPY-STATUS1.  Those functions will work whether the printer is handled*
;1;; by this software or by other stuff entirely.*
;1;; These functions continue to exist for users who are set in their ways, and as things for the functions*
;1;; mentioned above to call.*

;1;; *(TIGER:TIGER-FILE FILE &REST KEYWORD-OPTIONS)
;1;; This prints the specified file.*
;1;; The printout goes to the default printer *(SI:*DEFAULT-PRINTER*)1 unless *:PRINTER1 is one of the*
;1;; specified options, in which case it goes to that printer.*
(defun-with-arglist tiger-file tiger-file-arglist (file &rest options)
  (setq options (copylist options))
  "Print a file on the ASCII printer."
  (when (setq file (dwimify-filename file))
    (multiple-value-bind (tiger-type tiger-host)
	(figure-out-printer-type-and-host (extract-printer-from-options options))
      tiger-host
      (let ((font-list (memq :font-list options))
	    (font (memq :font options)))
	(cond (font-list
	       (rplaca (cdr font-list)
		       (mapcar 'verify-font (cadr font-list) (circular-list tiger-type))))
	      (font
	       (rplaca (cdr font) (verify-font (cadr font) tiger-type))))
	(push-tiger-queue-entry
	  (make-tiger-queue-entry :type :file
				  :object file
				  :options options))
	(start-tiger)
	(values file (length tiger-queue))))))

;1;; *(TIGER:TIGER-STREAM STREAM &REST KEYWORD-OPTIONS)
;1;; This causes input from the specified character stream to be printed.*
;1;; The characters will first be written to a temporary file, then that file is queued.*
;1;; (Printing directly from the stream is not a good idea because of the slowness of printers.)*
;1;; The printout goes to the default printer *(SI:*DEFAULT-PRINTER*)1 unless *:PRINTER1 is one of the*
;1;; specified options, in which case it goes to that printer.*
(defun-with-arglist tiger-stream tiger-stream-arglist (stream &rest options &aux file)
  (multiple-value-bind (tiger-type tiger-host)
      (figure-out-printer-type-and-host (extract-printer-from-options options))
    tiger-type
    (with-open-file (out-stream
		      (make-tiger-queue-directory-filename
			tiger-host
			"TEMPORARY-TEXT-FILE"
			:TEXT)
		      :direction :output)
      (stream-copy-until-eof stream out-stream)
      (setq file (send out-stream :truename))))
  (lexpr-funcall 'tiger-file file (append (copylist options) '(:delete-after t))))

;1;; This causes the specified array to have something done to it.  One of three things may happen:*
;1;; 1.  If the printer is not *:ARRAY-DISK1 or *:ARRAY-TAPE1, the printer is connected to your machine directly,*
;1;;     and you have asked for only one copy of it, the array is immediately printed.*
;1;; 2.  If the printer is not *:ARRAY-DISK1 or *:ARRAY-TAPE1, but the printer is connected to some other machine,*
;1;;     you have asked for more than one copy of your printout, or both, a file of characters to be sent to*
;1;;     the printer is created, and that is queued.*
;1;; 3.  If the printer is *:ARRAY-DISK1 or *:ARRAY-TAPE1, a dump file representing the array is written to the*
;1;;     appropriate device.  If the device was *:ARRAY-DISK1, that file is also queued; the machine with the*
;1;;     printer will convert it to characters and print it.*
;1;; In any case, the idea is to eventually get hardcopy of the array.*
;1;; The printout goes to the default bit-array printer *(SI:*DEFAULT-BIT-ARRAY-PRINTER*)1 unless *:PRINTER
;1;; is one of the specified options, in which case it goes to that printer.*
;1;; This version is hacked to work if the specified printer is *ARRAY-DISK1 or *ARRAY-TAPE1.*
(defun-with-arglist tiger-array tiger-array-arglist (entry &rest options &optional &key
							   (copy-array t) &allow-other-keys)
  (let (left top right bottom)
    (cond ((listp entry)
	   (push-tiger-queue-entry entry)
	   (start-tiger)
	   (values entry (length tiger-queue)))
	  (t (multiple-value-bind (tiger-type tiger-host)
		 (figure-out-printer-type-and-host (extract-printer-from-options options t))
	       (when copy-array
		 (let* ((old-array (cond ((typep entry 'tv:minimum-window)
					  (multiple-value (left top right bottom)
					    (send entry :inside-edges))
					  (send entry :screen-array))
					 (t entry)))
			(width (if left (- right left) (pixel-array-width old-array)))
			(height (if left (- bottom top) (pixel-array-height old-array)))
			(real-left (or left 0))
			(real-top (or top 0)))
		   (setq entry
			 (cond ((get tiger-type 'array-device-p)	;*
				      (wait-for-tiger-array)	;*
				      (adjust-tiger-array-size tiger-temporary-bit-array	;*
							       width height))	;*
				     (t		;*
				      (allocate-resource 'tiger-bit-array width height))
		   ))				;*
;;;   The modification above  <*> is to allow things like :array-tape as an output device
;;;   for NEWDRAW not to run out of either virtual memory or address space by allocating
;;;   lots and lots of arrays.  Unfortunately, it seems none of this code (Version 42)
;;;   ever worked - the installed version is 25, and things like wait-for-tiger-array
;;;   never seem to get reset anywhere. So, I am resetting tiger-array-free EVERYWHERE
;;;   after its used...                                                         -rdm
		   (array-initialize entry 0)
		   (bitblt tv:alu-seta width height
			   old-array real-left real-top
			   entry real-left real-top)))
	       (selectq (get tiger-type 'array-device-p)
		 ((t) (funcall (get tiger-type 'array-dump-function)
			       (send (make-tiger-queue-directory-filename
					     tiger-host
					     "TEMP"
					     "ARAY")
				     :string-for-printing)
			       entry)
		      (setq tiger-array-free t))
		 ((nil) (setq entry (make-tiger-queue-entry
				      :type :array
				      :object entry
				      :options (make-array-option-list options left top
								       right bottom)))
			(push-tiger-queue-entry entry)
			(start-tiger)
			(values entry (length tiger-queue)))))))))

(defun make-array-option-list (options left top right bottom)
  (cond (left (append options (list :left left :top top :right right :bottom bottom)))
	(t (copylist options))))

;1;; Interface functions between TIGER stuff and the "new hardcopy system".*
;1;; These are not meant to be called directly.  They get called when *HARDCOPY-FILE1, etc., are used.*
;1;; See the documentation of *HARDCOPY-FILE1, etc. in the Lisp Machine Manual for more info.*

;1;; *ARGLIST1 of *HARDCOPY-FILE
;1 *(FILE-NAME &KEY &OPTIONAL FORMAT (FONT "LPT8") FONT-LIST HEADING-FONT (PAGE-HEADINGS T)
;1                                    *VSP (COPIES 1) SPOOL)

(defun tiger-file-interface (printer file &rest options
			     &optional &key format &allow-other-keys)
  printer
  format
  (lexpr-funcall 'tiger-file file :printer printer options))

;1;; *ARGLIST1 of *HARDCOPY-BIT-ARRAY
;1 *(ARRAY LEFT TOP RIGHT BOTTOM &REST OPTIONS &KEY &OPTIONAL
;       1 *(PRINTER (OR SI:*DEFAULT-BIT-ARRAY-PRINTER* SI:*DEFAULT-PRINTER*)) &ALLOW-OTHER-KEYS)

(defun tiger-array-interface (printer array left top right bottom &rest options)
  (lexpr-funcall 'tiger-array array
			      :printer printer
			      :left left
			      :top top
			      :right right
			      :bottom bottom
			      :copy-array t
			      options))

;1;; *ARGLIST1 of *HARDCOPY-STREAM
;1 *(STREAM &KEY &OPTIONAL FILE-NAME (FONT "LPT8") FONT-LIST HEADING-FONT (PAGE-HEADINGS T)
;                        VSP (COPIES 1) SPOOL)

(defun tiger-stream-interface (printer stream &rest options)
  printer
  (lexpr-funcall 'tiger-stream stream :printer printer options))

;1;; *ARGLIST1 of *HARDCOPY-STATUS
;1 *(&OPTIONAL (PRINTER SI:*DEFAULT-PRINTER*) (STREAM STANDARD-OUTPUT))

(defun tiger-status-interface (printer &optional (stream standard-output))
  (multiple-value-bind (tiger-type tiger-host)
      (figure-out-printer-type-and-host printer)
    (cond ((eq tiger-host si:local-host)
	   (tiger-local-status-description stream))
	  ('else
	   (with-open-stream (s-stream (chaos:open-stream tiger-host "TIGER-STATUS"))
	     (stream-copy-until-eof s-stream stream))))))
    
(defun tiger-local-status-description (&optional (stream standard-output))
  (multiple-value-bind (s-maj s-min)
      (si:get-system-version 'system)
    (multiple-value-bind (t-maj t-min)
	(si:get-system-version 'tiger)
      (format stream "~&~A running System ~D.~D Tiger ~D.~D~%"
	      si:local-host-name
	      s-maj s-min
	      t-maj t-min)))
  (with-tiger-queue-lock
    (cond ((null tiger-queue)
	   (format stream "The printer queue is empty~%"))
	  ('else
	   (format stream "Job Type         Object                                 Who~%")
	   (dolist (e tiger-queue)
	     (format stream "~3D ~5A ~40A ~A@~A~%"
		     (tq-job-number e)
		     (tq-type e)
		     (tq-object e)
		     (tq-user e)
		     (tq-sender e)))))))

(compile-flavor-methods tiger-operator-window)