;;; -*- 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;; Routines for *ASCII1 printers.*
;1;; User-callable functions are in the file *USER.LISP1.*
;1;; Functions used by the *TIGER1 process and the *TIGER-SERVER1 processes are in the file *SERVER.LISP1.*
;1;; Definitions of variables and structures are in the file *DEFS.LISP1.*
;1;; Methods of *BASIC-PRINTER-STREAM-MIXIN1 are in the file *STREAM.LISP1.*
;1;; Methods of *TOSHIBA-STREAM1 (for the Toshiba P1350 printer) are in the file *TOSHIBA.LISP1.*
;1;; Internal functions of the TIGER process.*
;1;; *TIGER-FILE-INTERNAL1 is the top-level function of that process.*

(defun tiger-file-internal ()
  (error-restart ((sys:abort error) "Return to printer specification command level.")
    (do-forever
      (process-wait "Queue Empty" #'(lambda () tiger-queue))
      ;; if remote machine then we must do the following
      ;; if it is a file, just send the file name to the tiger host
      ;; otherwise write the file somewhere, and then send this temporary
      ;; filename to the tiger host.
      (let* ((queue-object (first tiger-queue))
	     (user-id "Tiger"))			;1Fool* FORCE-USER-TO-LOGIN
	(multiple-value-bind (tiger-type tiger-host)
	    (figure-out-printer-type-and-host (figure-out-printer queue-object))
	  (cond ((host-equal tiger-host si:local-host)
		 (setq handshake-type
		       (or (get tiger-type 'tiger-serial-handshake-type)
			   :default))
		 (multiple-value-bind (device flavor-and-inits)
		     (serial-flavor-requirements)
		   (WITH-OPEN-FILE (x device :flavor-and-init-options flavor-and-inits)
		     (setq serial-stream x)
		     (let ((aborted-p t))
		       (unwind-protect
			   (progn (tiger-process-immediate)
				  (setq aborted-p nil))
			 (when aborted-p
			   (handle-aborted-tiger-process-immediate)))))))
		(t (selectq (tq-type queue-object)
		     ((:file :array-file :aray-file :raw-file)
		      (cond ((stringp (tq-object queue-object))
			     (tiger-notify-user (format nil "Spooling to ~A" tiger-host)
						(tq-sender queue-object))
			     (tiger-send-it tiger-host queue-object))
			    (t (tiger-notify-user
				 (format nil "~A is not a valid tiger file queue entry."
					 queue-object)
				 (tq-sender queue-object)))))
		     (:array (tiger-array-entry queue-object t))
		     (:otherwise (tiger-notify-user
				   (format nil "Error Printing ~A, ~A is not a known type"
					   (tq-object queue-object)
					   (tq-type queue-object))
				   (tq-sender queue-object))))
		   (pop-tiger-queue))))))))


(defun handle-aborted-tiger-process-immediate ()
  (send serial-stream :send-if-handles :clear-input)
  (send serial-stream :send-if-handles :clear-output)
  (send serial-stream :send-if-handles :tyo (ascii-code #\form)))
		       


(defun get-or-instantiate-printer-stream (printer)
  (let ((obj (or (get printer 'tiger-stream)
		 (putprop printer
			  (make-instance (get printer 'tiger-stream-flavor))
			  'tiger-stream))))
    (send obj :set-destination serial-stream)
    obj))

(defun figure-out-printer (entry)
  (cond ((cadr (memq :printer (tq-options entry))))
	((eq (tq-type entry) :file)
	 si:*default-printer*)
	((memq (tq-type entry) '(:array :array-file))
	 si:*default-bit-array-printer*)
	(t si:*default-printer*)))

(defun setup-tiger-normal (tiger-stream)
  (send tiger-stream :setup-normal)
  (send tiger-stream :send-if-handles :set-tab-stops 8.)
  (send tiger-stream :send-if-handles :set-elongated-printing nil)
  ;1; These should default per printer -- therefore should be handled in the *:SETUP-NORMAL1 message.*
; (send tiger-stream :send-if-handles :set-characters-per-inch 10.)
; (send tiger-stream :send-if-handles :set-lines-per-inch 6.)
; (send tiger-stream :send-if-handles :set-form-length 11.)
  (send tiger-stream :send-if-handles :set-font 0 t))

(defun array-file-p (filename stream)
  (or (equal "TIGER" (send (fs:merge-pathname-defaults filename) :type))
      (send stream :send-if-handles :get :tiger)))

(defun tiger-process-immediate ()
  (selectq (tq-version queue-object)
    ((3 4) (selectq (tq-type queue-object)
	     ((:file :array-file :raw-file) (tiger-file-entry queue-object))
	     (:aray-file (tiger-dumped-array queue-object))
	     (:array (tiger-array-entry queue-object nil))
	     (:otherwise (tiger-notify-user
			   (format nil "Error Printing ~A, ~A is not a known type"
				   (tq-object queue-object)
				   (tq-type queue-object))
			   (tq-sender queue-object)))))
    (:otherwise (tiger-notify-user
		  (format nil "Error Printing ~A, queue entry version ~D not supported."
			  queue-object
			  (tq-version queue-object))
		  (tq-sender queue-object))))
  (pop-tiger-queue))

(defun tiger-file-entry (queue-entry)
  (lexpr-funcall 'tiger-file-entry-1
		 (tq-object queue-entry)
		 (tq-sender queue-entry)
		 (tq-user queue-entry)
		 (tq-options queue-entry)))

(defun tiger-file-entry-1 (file sender user &rest options &optional &key
;			   (printer si:*default-printer*)
			   (delete-after nil)
			   (copies 1)
			   (font nil)
			   (font-list nil)
			   characters-per-inch
			   lines-per-inch
			   (page-headings t)
			   (title-page nil)
			   (file-heading t)
			   &allow-other-keys)
  (declare (special queue-object tiger-type tiger-host))
  sender
  (let ((tiger-stream (get-or-instantiate-printer-stream tiger-type)))
    (setup-tiger-normal tiger-stream)
    (with-open-file (in file :direction :input :error nil)
      (cond ((errorp in)
	     (tiger-notify-user (format nil "Error Printing ~A: ~A" file in) sender))
	    (t (tiger-notify-user (format nil "Now Printing ~A" file) sender)
	       (dotimes (i copies)
		 (when (plusp i) (send in :set-pointer 0))	;reset file stream
		 (cond ((or (memq (tq-type queue-object) '(:raw-file :array-file))
			    (array-file-p file in))
			;1; Binary Image file*
			(stream-copy-until-eof in (send tiger-stream :destination)))
		       (t 
			;1; otherwise regular text file.*
			(cond (font-list
			       (send tiger-stream :send-if-handles :set-font-list font-list)
			       (send tiger-stream :send-if-handles :set-font 0)
			       (send tiger-stream :set-process-font-changes t))
			      (font
			       (send tiger-stream :send-if-handles 
						  :set-font-list (circular-list font))
			       (send tiger-stream :set-font font)
			       (send tiger-stream :set-process-font-changes nil))
			      (t (send tiger-stream :send-if-handles :set-font-list nil)
				 (send tiger-stream :send-if-handles :set-font font)
				 (send tiger-stream :set-process-font-changes t)))
			(send tiger-stream :send-if-handles 
					   :set-characters-per-inch characters-per-inch)
			(send tiger-stream :send-if-handles
					   :set-lines-per-inch lines-per-inch)
			(send tiger-stream :set-page-headings page-headings)
			(send tiger-stream :set-heading-line
			      (format nil "~A  ~\time\"
				      (send in :truename)
				      (send in :creation-date)))
			(send tiger-stream :set-page-number 1)
			(when (or title-page page-headings file-heading)
			  (send tiger-stream :send-if-handles :set-elongated-printing t)
			  (format tiger-stream "  for ~A on ~A at ~\datime\~&" user sender)
			  (send tiger-stream :print-heading))
			(when title-page
			  (send tiger-stream :tyo #\form))
			(stream-copy-until-eof in tiger-stream)))
		 (send tiger-stream :set-page-headings nil)
		 (send tiger-stream :tyo #\form)))))
    (when delete-after
      (deletef file)
      (fs:expunge-directory (send (fs:parse-pathname file) :new-pathname
			       :name :wild
			       :type :wild
			       :version :wild)))))

(defunp tiger-array-entry (queue-entry &optional (always-spool-p t)
			  &aux array (q-obj (tq-object queue-entry)))
  (cond ((typep q-obj :array)
	 (setq array q-obj))
	((typep q-obj :instance)
	 (setq array (tv:sheet-screen-array q-obj)))
	(t (tiger-notify-user (format nil "~A not a valid array type." q-obj)
			      (tq-sender queue-entry))
	   (return nil)))
  (lexpr-funcall 'tiger-array-entry-1 array
				      (tq-sender queue-entry)
				      (tq-user queue-entry)
				      always-spool-p
				      (tq-options queue-entry))
  (free-queue-entry-array queue-entry))


;;; tiger-array-entry-1 doesn't free the queue-entry-array anymore.
;;; It must be done by the caller.

(defun tiger-array-entry-1 (array sender user always-spool-p &rest options &optional &key
			    (printer si:*default-bit-array-printer*)
			    (copies 1)
			    (left 0)
			    (top 0)
			    (bottom (pixel-array-height array))
			    (right (pixel-array-width array))
			    (rotation nil)
			    (delete-after t)
			    return-array x-scale y-scale
			    &allow-other-keys)
  (declare (special tiger-type tiger-host))
  user
  (let ((tiger-stream (get-or-instantiate-printer-stream tiger-type))
	(temp-file-p (or always-spool-p ( 1 copies)))
	(temp-file-stream nil)
	(user-id "Tiger")			;1Fool *FORCE-USER-TO-LOGIN
	old-destination truename)
    (unwind-protect
	(progn
	  (cond (temp-file-p
		 (setq old-destination (send tiger-stream :destination))
		 (send tiger-stream :set-destination
		       (setq temp-file-stream
			     (open (make-tiger-queue-directory-filename
				     tiger-host
				     "TEMPORARY-SCREEN-ARRAY"
				     "TIGER")
				   :direction :output :byte-size 8. :characters nil)))
		 (tiger-notify-user (format nil "Spooling temporary file to ~A" tiger-host)
				    sender)
		 (send temp-file-stream :putprop t :tiger)
		 (setq truename (send (send temp-file-stream :truename)
				      :string-for-printing)))
		(t (tiger-notify-user (format nil "Now printing array ~A" array)
				      sender)))
	  (setup-tiger-normal tiger-stream)
	  (send tiger-stream :set-x-scale (or x-scale (get tiger-type 'default-x-scale)))
	  (send tiger-stream :set-y-scale (or y-scale (get tiger-type 'default-y-scale)))
	  (tiger-bit-array-to-stream array tiger-stream rotation left top right bottom))
      (when temp-file-stream (send temp-file-stream :close)))
    (cond (temp-file-p (tiger-send-it tiger-host
				      (make-tiger-queue-entry
					:type :array-file
					:object truename
					:sender sender
					:options
					`(:printer ,printer
					  :copies ,copies
					  :delete-after ,delete-after)))
		       (send tiger-stream :set-destination old-destination))
	  (t (send tiger-stream :set-page-headings nil)
	     (send tiger-stream :tyo #\form)))
    (when return-array array)))

(defun tiger-dumped-array (queue-entry)
  (let ((file (tq-object queue-entry)))
    (wait-for-tiger-array)
    (multiple-value-bind (array left top right bottom)
	(restore-pixel-array-from-file file tiger-temporary-bit-array)
      (when (cadr (memq :delete-after (tq-options queue-entry)))
	(deletef file))
      (push-tiger-queue-entry
	(make-tiger-queue-entry
	  :type :array
	  :object array
	  :sender (tq-sender queue-entry)
	  :user (tq-user queue-entry)
	  :options (append (tq-options queue-entry)
			    `(:left ,left :top ,top :right ,right :bottom ,bottom)))))
    (setq tiger-array-free t)))

(defun tiger-bit-array-to-stream (array stream &optional
				  (rotation nil)
				  (left 0)
				  (top 0)
				  (right (pixel-array-width array))
				  (bottom (pixel-array-height array)))
  (send stream :set-up-for-graphics rotation)
  (let ((width (- right left))
	(height (- bottom top))
	(x left)
	(y top))
    ;; i'm trying to make this be as consistent with the tv:sheet :BITBLT
    ;; operation as possible. dropping some arguments that arent needed.
    ;; (tv:bitblt alu width height from-array from-x from-y to-array to-x to-y)
    (cond ((send stream :get-handler-for :bitblt)
	   (send stream :bitblt width height array x y))
	  ((and (= 1 (floor (send stream :dots-per-line) (send stream :y-scale)))
		(= 1 (send stream :x-scale)))
	   (bitblt-to-stream-simple-case width height array x y stream))
	  ('else
	   (bitblt-to-stream-hairy-case width height array x y stream)))))

(defun bitblt-to-stream-simple-case (width height array x y stream &aux left-bit right-bit)
  ;; This is for printers that just want to see a string of bits but
  ;; haven't implemented the :BITBLT message themselves. In this case we do
  ;; some whitespace optimization on a row-by-row basis and do a SEND
  ;; for each bit in the non-optimized-away region.
  ;; Since this is so primitive we print messages as we go along to aid in debugging.
  (format t "~&Simple array case is ~D by ~D" width height)
  (dotimes (j height)
    (format t " ~D" j)
    (cond ((null (setq left-bit (row-bit-search array (+ y j) x width)))
	   (format t "@"))
	  ('else
	   (send stream :position-horizontal (- left-bit x))
	   (setq right-bit (row-reverse-bit-search array (+ y j) x width))
	   (format t "[~D,~D]" left-bit right-bit)
	   (do ((k left-bit (1+ k)))
	       ((> k right-bit))
	     (send stream :print-bit-graphics (aref array (+ y j) k)))))
    (send stream :new-graphics-line)))

(defun row-bit-search (array y x count)
  (do ((j 0 (1+ j)))
      ((= j count)
       nil)
    (or (zerop (aref array y (+ x j)))
	(return (+ x j)))))

(defun row-reverse-bit-search (array y x count)
  (do ((position (+ x (1- count)) (1- position)))
      ((< position x)
       nil)
    (or (zerop (aref array y position))
	(return position))))


(defun bitblt-to-stream-hairy-case (width height array x y stream &aux left right top bottom)
  ;; this is for printers that take <BYTES> and stack them horizontally. They do things
  ;; a line-at-a-time. This is the original tiger code for arrays, the dots-per-line
  ;; figure is the actual number of solenoid driven wires in the IMPACT-PRINTER head,
  ;; modified by number of quality-passes perhaps. Or perhaps the number of thermally
  ;; active areas on a thermal printer head.
  (setq left x right (+ left width))
  (setq left 0) ;; this code doesnt work unless LEFT = 0
  (setq top y bottom (+ top height))
  ;1; This loop iterates by printer lines.  For each, we print some graphics, then move on to next line.*
  ;1; This loop iterates by printer lines.  For each, we print some graphics, then move on to next line.*
  (loop with dots-per-line = (send stream :dots-per-line)
       	with x-scale = (send stream :x-scale)
	with y-scale = (send stream :y-scale)
	with pixels-per-line = (floor dots-per-line y-scale)
	with start-bp = (dpb (1- pixels-per-line) si:%%byte-specifier-position 1)
	with height = (- bottom top)
;	with width = (- right left)
	with real-width = (pixel-array-width array)
	with init-positioned-p = (zerop left)
	for current-row from top below bottom by pixels-per-line
	for first-pixel = (* current-row real-width)
	for rows-remaining from height downto 0 by pixels-per-line
	do ;1; This loop iterates by columns.  For each, we gather up information and print it.*
	   (loop with positioned-p = init-positioned-p
		 for x from left below right
		 for char = ;1; This loop copies the current column, one row at a time.*
			    (loop with character = 0
				  for bp = start-bp then (- bp 100)
				  for count from 0 below (min pixels-per-line rows-remaining)
				  for i from (+ first-pixel x) by real-width
				  do (setq character (%logdpb (ar-1-force array i) bp character))
				  finally (return character))
		 do (cond ((zerop char) (setq positioned-p nil))
			  (t (unless positioned-p
			       (send stream :position-horizontal (* x x-scale))
			       (setq positioned-p t))
			     (let ((transformed-char
				     (fast-perform-y-scaling char y-scale pixels-per-line)))
			       (dotimes (foo x-scale)
				 (send stream :print-bit-graphics transformed-char))))))

	   ;1; Now we move on to the next line.*
	   (send stream :new-graphics-line)))


;1; The Tiger server is a Chaosnet server which accepts the printed representation of the lists which are*
;1; queue entries.  The lists are printed and read in the *TIGER1 package, in base 10.,  to make sure*
;1; the reading happens correctly.*
;1;*
;1; The serving machine assumes that the requested file already exists.  An error notification will be sent*
;1; if it is not found.*

(defvar tiger-server-connections nil)

(defun tiger-server-function (&aux conn)
  (setq conn (chaos:listen "TIGER"))
  (chaos:accept conn)
  (send tv:who-line-file-state-sheet :add-server conn "TIGER")
  (unwind-protect
      (let* ((base 10.) (ibase 10.) stream object)
	(unwind-protect
	    (progn
	      (setq stream (chaos:make-stream conn)
		    object (pkg-bind "TIGER"
			     (read stream)))
	      (selectq (tq-type object)
		(:notification
		 (notify-local-tiger-error (tq-object object))
		 (send stream :line-out "+Notification performed."))
		((:file :array :array-file :raw-file :aray-file)
		 (push-tiger-queue-entry object)
		 (send stream :line-out "+Request accepted."))
		(:otherwise (send stream :line-out "-Unknown queue entry type.")))
	      (send stream :force-output))
	  (when stream (send stream :finish))))
    (when conn
      (chaos:remove-conn conn)
      (send tv:who-line-file-state-sheet :delete-server conn)))
  (start-tiger)
  nil)

(add-initialization "TIGER"
		    '(process-run-function "TIGER Server" 'tiger-server-function)
		    nil
		    'chaos:server-alist)

(defun tiger-status-server-function ()
  (condition-case ()
      (with-open-stream (stream (chaos:open-stream nil "TIGER-STATUS"))
	(send stream :accept)
	(tiger-local-status-description stream))
    (SYS:REMOTE-NETWORK-ERROR NIL)))

(add-initialization "TIGER-STATUS"
		    '(process-run-function "TIGER Status Server"
					   'tiger-status-server-function)
		    nil
		    'chaos:server-alist)

(defun tiger-send-it (tiger-host queue-entry)
  ;1; queue-entry should be a file-type queue so send appropriate info*
  (fs:force-user-to-login)
  (condition-case (conn-error)
      (with-open-stream (stream (chaos:open-stream tiger-host "TIGER"))
	(let ((base 10.) (ibase 10.))
	  (pkg-bind "TIGER" (print-queue-entry queue-entry stream)))
	(send stream :force-output)
	(check-chaos-tiger-response stream queue-entry)
	(send stream :finish))
    (sys:network-error (tv:notify nil "Error ~A while trying to queue to host ~A."
				  conn-error tiger-host))))

(defun print-queue-entry (entry &optional (stream standard-output))
  (cond ((eq (car entry) 'tiger-queue-entry)
	 (format stream "(TIGER:TIGER-QUEUE-ENTRY ~D. :~A ~S ~S ~S "
		 (tq-version entry) (tq-type entry) (tq-object entry)
		 (tq-sender entry) (tq-user entry))
	 (print-option-list (tq-options entry) stream)
	 (format stream " NO-JOB-NUMBER-YET)"))
	(t (ferror nil "Illegal queue entry ~A encountered." entry))))

(defun print-option-list (list &optional (stream standard-output))
  (send stream :tyo #/()
  (do ((first-time-p t)
       (tail list))
      (())
    ;1; First read an option name.  It must be a symbol.*
    (unless tail (return))
    (cond (first-time-p (setq first-time-p nil))
	  (t (send stream :tyo #\Space)))
    (let ((option (pop tail)))
      (cond ((symbolp option)
	     (unless (keywordp option)
	       (cerror t nil nil
		       "The option name ~S in the option list ~S does not appear to be a keyword."
		       option tail))
	     (format stream ":~A" option))
	    (t (ferror nil "The option name ~S in the option list ~S is not a symbol."
		       option tail)))
      (unless tail
	(cerror t nil nil "The option name ~S in the option list ~S has no value."
		option tail))
      (send stream :tyo #\Space)
      (prin1 (pop tail) stream)))
  (send stream :tyo #/)))
  
(defun check-chaos-tiger-response (stream queue-entry)
  (let ((line (send stream :line-in)))
    (selectq (aref line 0)
      (#/+)					;AOK
      (#/-
       (tv:notify nil "Negative response from host for ~A: ~A" (tq-object queue-entry) line))
      (:otherwise
       (tv:notify nil "Unknown response from host for ~A: ~A"
		  (tq-object queue-entry) line)))))

(defun tiger-notify-user (message host)
  (cond ((null host) (tv:notify nil message))
	((or (typep host 'si:host) (stringp host))
	 (notify-tiger-error host message))
	(t (tv:notify nil "Error sending message ~A to incorrect host ~A." message host))))

(defun notify-tiger-error (host error-message)
  (if (host-equal host si:local-host) (notify-local-tiger-error error-message)
    (notify-chaos-tiger-error host error-message)))

(defun notify-chaos-tiger-error (host error-message &aux keyword-response)
  (condition-case (conn-error)
      (with-open-stream (stream (chaos:open-stream host "TIGER"))
	(pkg-bind "TIGER"
	  (print (make-tiger-queue-entry :type :notification :object error-message) stream))
	(send stream :force-output)
	(setq keyword-response (send stream :line-in))
	(when (neq #/+ (aref keyword-response 0))
	  (tv:notify nil "Error ~A sending notification ~A to host ~A." 
		     keyword-response error-message host))
	(send stream :finish))
    (sys:network-error (tv:notify nil "Error ~A while trying to send notification ~A to host ~A."
				  conn-error error-message host))))