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

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

;1;; Variables, etc.*

(declare (special
	   bit-array-dimensions			;from CONSTRUCT-TIGER-BIT-ARRAY
	   queue-object tiger-type tiger-host	;from TIGER-FILE-INTERNAL and
						;     TIGER-PROCESS-IMMEDIATE
	   printer file copies			;from HARDCOPY-FILE-USING-WINDOW
	   ))

(defconst tiger-file-options
	  '((printer si:*default-printer*)
	    (ncopies 1)
	    (font 0)
	    (characters-per-inch 10.)
	    (lines-per-inch 6.)
	    (page-headings t)
	    (file-heading t)
	    title-page
	    &allow-other-keys))

(defconst tiger-file-arglist
	   `(file &optional &key
	      delete-after-printing
	      . ,tiger-file-options))

(defconst tiger-stream-arglist
	  `(stream &optional &key
	      (delete-after-printing t)
	      . ,tiger-file-options))

(defconst tiger-array-arglist
	  '(array &optional &key
	     (printer si:*default-bit-array-printer*)
	     left
	     top
	     right
	     bottom
	     (copies 1)
	     rotation
	     x-scale
	     y-scale
	     spool-file
	     (delete-after t)
	     return-array))

(defstruct (tiger-bit-array :named-array-leader
			    (:make-array (:dimensions bit-array-dimensions :type 'art-1b))
			    (:print "#<TIGER-BIT-ARRAY ~D>" (array-dimensions tiger-bit-array))))

(defun construct-tiger-bit-array (width height)
  (let* ((dim1 (if array-index-order height width))
	 (dim2 (if array-index-order width height))
	 (bit-array-dimensions (list dim1 dim2)))
    (make-tiger-bit-array)))
	
(defresource tiger-bit-array (width height)
  :constructor (construct-tiger-bit-array width height))

(defvar handshake-type :default)		;1What sort of handshaking to use*
(defvar serial-stream nil)			;1Stream used for serial output.*
						;1Only one will be used per machine.*
(defvar tiger-queue nil)			;1Backed-up printer requests.*
(defvar tiger-process)				;1The process used by the printer software.*
(defvar owner-of-serial-port nil)		;1Lock on serial port for Phonenet.*
(defvar tiger-debug nil)			;T1 to send output to *standard-output1.*
(defvar tiger-array-free t)			;T1 if the temporary bit array is available.*
(defvar tiger-temporary-bit-array (tv:make-pixel-array 0 0 :type 'art-1b))
						;1An array used for restoring dumped array files.*
						;ARRAY-GROW1 will be used to make its size reasonable.*

(defun wait-for-tiger-array ()
  (process-wait "Wait for Array"
		#'(lambda () tiger-array-free))
  (%store-conditional (locf tiger-array-free) t nil))

(defun adjust-tiger-array-size (array width height)
  (let ((old-width (pixel-array-width array))
	(old-height (pixel-array-height array)))
    (cond ((and (eq height old-height) (eq width old-width)) array)
	  (t (make-pixel-array (max width old-width) (max height old-height) :type 'art-1b)))))

(defun free-queue-entry-array (entry)
  (let ((array (tq-object entry)))
    (when (typep array 'tiger-bit-array)
      (deallocate-resource 'tiger-bit-array array))))

;1; An element in the Tiger queue is a list:*
;;
;;  (TIGER:TIGER-QUEUE-ENTRY <version> {:FILE :ARRAY :RAW-FILE :ARAY-FILE}
;1;*			1       *<sender> <user> <options>)
;;  (TIGER:TIGER-QUEUE-ENTRY :NOTIFICATION <version> <message>)
;;
;1; A *FILE1 is a text file which is processed with character translations, etc.*
;1; A *RAW-FILE1 is a file which is to be sent literally to the printer, with no translations.*
;1;*	1They are usually arrays which have been preprocessed for later printing.*
;1; An *ARRAY-FILE1 (note different spelling from below!) is an obsolete name for *RAW-FILE1.  It is still*
;1;*	1accepted, but will not be generated by current software versions.*
;1; An *ARAY-FILE1 is a file which contains the dumped contents of a pixel array, in a format intended*
;1;*	1for easy restoring.*
;1; An *ARRAY1 represents an actual array on the local machine.  An *ARRAY1 entry will never be sent over*
;1; *	1the net; it is valid only on the machine which originated it.  An *ARRAY1 will be processed into*
;1;*	1either a *RAW-FILE1 or an *ARAY-FILE1, and then that file will be queued (or dumped to tape).*
;1; A *NOTIFICATION1 is used for internal purposes to notify the sending machine when a requested printout*
;1;*	1is happening.  It will never appear in the queue.  When received, a notification is immediately*
;1;*	1printed (using *TV:NOTIFY1).*
;;
;1; The permitted options for a file include*
;; :copies :delete-after :font :characters-per-inch :lines-per-inch :page-headings
;; :title-page :file-heading
;1;*
;1; The permitted options for an array include*
;; :left :top :right :bottom :copies :rotation :spool-file :delete-after :return-array
;; :x-scale :y-scale

(defstruct (tiger-queue-entry :named-list (:conc-name tq-))
;; note: if you change this structure you will probably have to change
;; PRINT-QUEUE-ENTRY in SERVER.LISP
  (:version 4)
  :type
  :object
  (:sender (send si:local-host :string-for-printing))
  (:user user-id)
  :options
  :job-number)

(defstruct (toshiba-font :conc-name
			 (:type :named-array-leader) 
			 (:make-array (:leader-length 3 :dimensions 128.)))
  :name)

;1;; Graphics scaling stuff*

(defun perform-y-scaling (char scale n-bits)
  (loop with transformed-char = 0
	for y from 0 below n-bits
	for scaled-y from 0 by scale
	for pixel = (load-byte char y 1)
	do (loop for new-y from scaled-y
		 for foo from 1 to scale
		 do ;1Note that the anti-bignum hack is no longer needed now that we have 25 bit fixnums*
		    (setq transformed-char (deposit-byte transformed-char new-y 1 pixel)))
	finally (return transformed-char)))

(defun fill-scale-array (array scale)
  (loop with n-bits = (ceiling 24. scale)
	for char from 0 below (^ 2 n-bits)
	do (aset (perform-y-scaling char scale n-bits) array char))
  array)

(defvar scale-2-array)
(defvar scale-3-array)
(defvar scale-4-array)

(defun fast-perform-y-scaling (char scale n-bits)
  (selectq scale
    (1 char)
    (2 (aref scale-2-array char))
    (3 (aref scale-3-array char))
    (4 (aref scale-4-array char))
    (:otherwise (perform-y-scaling char scale n-bits))))

(defmacro def-tiger-props (printer-type-keyword &rest props)
  "Use this to define a new printer, giving printer-type-keyword the default
tiger properties, and keeping track of it on *tiger-printer-types*"
  `(*def-tiger-props ',printer-type-keyword ',props))

(defvar *tiger-printer-types* () "A list of printers supported by this software")

(defun *def-tiger-props (key l)
  (when (record-source-file-name key 'def-tiger-props)
    (pushnew key *tiger-printer-types*)
    (setf (get key 'si:print-file) 'tiger-file-interface)
    (setf (get key 'si:print-bit-array) 'tiger-array-interface)
    (setf (get key 'si:print-stream) 'tiger-stream-interface)
    (setf (get key 'si:print-status) 'tiger-status-interface)
    (do ((l l (cddr l)))
	((null l))
      (setf (get key (car l)) (cadr l)))))
  

(define-site-variable *default-printer-host-alist*
		      :default-printer-host-alist
  "Tells what kind of printers are located where. e.g.
/(:default-printer-host-alist '((:ti855 /"LAMA/")
                               (:toshiba /"LAMC/")))
This information is used if explicit host specifications are
not given to hardcopy-file etc.")

(defun figure-out-printer-type-and-host (printer &aux temp)
  (cond ((not (atom printer))
	 (values (first printer) (si:parse-host (second printer))))
	((setq temp (assq printer *default-printer-host-alist*))
	 (values printer (si:parse-host (cadr temp))))
	((setq temp (get printer 'default-tiger-host-eval))
	 (values printer (si:parse-host (eval temp))))
	('else
	 (ferror nil "Cannot find a host for printer: ~S" printer))))

(defun host-string (host)
  (cond ((stringp host) host)
	((typep host 'si:host) (send host :string-for-printing))
	(t (ferror nil "Cannot coerce host ~A into a string." host))))

(defun host-equal (host-1 host-2)
  (let ((parsed-1 (si:parse-host (host-string host-1) t))
	(parsed-2 (si:parse-host (host-string host-2) t)))
    (and parsed-1 parsed-2 (eq parsed-1 parsed-2))))

(defsubst notify-local-tiger-error (message)
  (tv:notify () message))

(defvar *tiger-queue-job-number* 0)

(defmacro with-tiger-queue-lock (&rest body)
  `(with-lock ((get 'tiger-queue 'lock))
     ,@body))

(defun push-tiger-queue-entry (entry)
;; Here is the old losing definition, just for kicks, and to show how-not-to-do-it.
;; Typical paranoid lossage here. Even the evaluation of ENTRY is inside
;; a without-interrupts. (Which in some actual usages in this code was
;; some moby consing). Lesson: Never use a macro when a function will do.
;; never use without-interrupts when a simple lock will do.
  #|
  (defmacro push-tiger-queue-entry (entry)
    `(without-interrupts
       (setq tiger-queue (nconc tiger-queue (ncons ,entry)))))
|#
  ;; you know, this system could use some primitives for maintaining
  ;; QUEUE's. Atomic push and pop operations.
  (with-tiger-queue-lock
    (incf *tiger-queue-job-number*)
    (setf (tq-job-number entry)
	  *tiger-queue-job-number*)
    (setq tiger-queue (nconc tiger-queue (ncons entry)))))

(defun pop-tiger-queue ()
  "Use this instead of (pop tiger-queue)"
  (with-tiger-queue-lock
    (pop tiger-queue)))


;;; Here is an example of the options in DefSite to declare the printers for explorer.
;;;  (:PRINTER-NAMES '((("PRINTER-1" "P1") (:TI855 "EXPLORER-1" :parallel))
;;;		    (("PRINTER-2" "P2") (:TI855 "EXPLORER-1" :serial))
;;;		    ))

(defun serial-flavor-requirements (&optional options)
  (select si:processor-type-code
    (si:cadr-type-code
     ;; in fact, this has no hope of running on the CADR until
     ;; somebody defines a "SERIAL-PORT" host.
     (values "SERIAL-PORT:"
	     (list (selectq handshake-type
		     ((:software :default) 'si:serial-xon-xoff-stream)
		     (:hardware 'si:serial-stream)
		     (:otherwise (ferror nil "~A is not a valid handshake type."
					 handshake-type)))
		   :baud 9600.
		   :number-of-stop-bits 1
		   :parity nil
		   :number-of-data-bits 8.
		   :xon-xoff-protocol t)))
    (si:lambda-type-code
     ;; on the LAMBDA we can use our winning new device allocation technology.
     (cond ((not (atom handshake-type))
	    ;; in this case it is ("DEVICE-FOO:" flavor-bar &rest init-options)
	    ;; what a kludge, what a generalization! -gjc
	    (values (car handshake-type)
		    (cdr handshake-type)))
	   ('else
	    (values "SDU-SERIAL-B:"
		    (list (selectq handshake-type
			    ((:hardware :default) 'si:sdu-serial-stream)
			    (:software 'si:sdu-serial-xon-xoff-stream)
			    (:otherwise (ferror nil "~A is not a valid handshake type."
						handshake-type)))
			  :baud-rate 9600.)))))
    (si:explorer-type-code
     (Let ((printer-info (cadr (memq :printer options))))
       (selectq (third printer-info)
	 (:parallel (Values "Exp-Printer:" '(si:exp-parallel-stream)))
	 (:serial (Values "Exp-Printer:" '(si:exp-serial-xon-xoff-stream)))
	 (otherwise (Values "Exp-Printer:" '(si:exp-parallel-stream))))))
    ))

(defun check-font-object-type (font-spec font-type printer)
  (when (and (symbolp font-spec) (boundp font-spec))
    (setq font-spec (symeval font-spec)))
  ;1; *(check-arg-type font-spec font-type)
  ;1; Note that the code below is the macroexpansion of *CHECK-ARG-TYPE1,*
  ;1; except that the type-name and the type-name string is evaluated.*
  ;1; Also note that *T1 is used as the proceed type rather than *:ARGUMENT-VALUE1,*
  ;1; because the latter doesn't work in Lambda System 1.*
  (DO NIL
      ((TYPEP FONT-SPEC FONT-TYPE) font-spec)
    (SETQ FONT-SPEC (CERROR t
			    NIL
			    'SYS:WRONG-TYPE-ARGUMENT
			    "The argument ~2G~A was ~1G~S, which is not ~3G~A."
			    FONT-TYPE
			    FONT-SPEC
			    'FONT-SPEC
			    (FORMAT NIL "a ~A" FONT-TYPE)))
    (setq font-spec (load-font-if-necessary font-spec printer))))

(defun load-font-if-necessary (font-spec printer)
  (let ((font-type (get printer 'tiger-font-type)))
    (cond ((fixnump font-spec) font-spec)
	  ((or (symbolp font-spec) (stringp font-spec))
	   (setq font-spec (intern (string font-spec) "TIGER"))
	   (cond ((boundp font-spec)
		  (check-font-object-type font-spec font-type printer))
		 (t (load (send (fs:merge-pathname-defaults (get printer 'font-directory))
				:new-pathname :name (string font-spec))
			  "TIGER" t t)
		    (check-font-object-type font-spec font-type printer))))
	  (t (check-font-object-type font-spec font-type printer)))))

(defun verify-font (font-spec printer)
  (cond ((fixnump font-spec) font-spec)
	(t (toshiba-font-name (load-font-if-necessary font-spec printer)))))

(defun lookup-font (fon lis typ)
  (cond ((typep fon typ) fon)
	((symbolp fon) (if (boundp fon) (symeval fon) fon))
	(t (when ( fon (ascii-code #/0)) (decf fon (ascii-code #/0)))
	   (cond (lis (cond ((nth fon lis))
			    (t fon)))
		 (t fon)))))

(defun short-number (number stream)
  (let ((rounded-number (round number)))
    (cond (( 0 rounded-number 125.)
	   (send stream :tyo (+ rounded-number (ascii-code :SOH))))
	  (t (ferror nil "Invalid Toshiba short number ~D." number)))))

(defun long-number (number stream)
  (let ((rounded-number (round number)))
    (cond (( 0 rounded-number 159.)
	   (multiple-value-bind (quo rem)
	       (truncate rounded-number 10.)
	     (send stream :tyo (aref (format nil "~16R" quo) 0))
	     (send stream :tyo (+ rem (ascii-code #/0)))))
	  (t (ferror nil "Invalid Toshiba long number ~D." number)))))

(defun very-long-number (number stream)
  (let* ((rounded-number (round number))
	 (negative-flag (minusp rounded-number))
	 (number-magnitude (abs rounded-number)))
    (cond (( 1 number-magnitude 1791.)
	   (multiple-value-bind (temp d1)
	       (floor number-magnitude 16.)
	     (multiple-value-bind (d256 d16)
		 (floor temp 16.)
	       (send stream :tyo (+ d256 (if negative-flag (ascii-code #/P) (ascii-code #/@))))
	       (send stream :tyo (+ d16 (ascii-code #/@)))
	       (send stream :tyo (+ d1 (ascii-code #/@))))))
	  (t (ferror nil "Invalid Toshiba relative motion number ~D." number)))))

(defmacro push-graphic-blanks (number &optional (array 'temporary-bit-graphics-array))
  `(dotimes (foo ,number)
    (array-push ,array 0)))