;1;;  -*-* Mode:LISP; Package:LASER2; Fonts:(CPTFONT HL12B); Base:8; Readtable:ZL 1-*-*
;1;; Copyright (c) 1985, LISP Machine, Inc.*

;1;; Description: Laser2 text dump routines*
;1;; Programmer: James M. Turner*
;1;; Last Modification: 26-Jan-1985*
;1;;*
;1;; Change History:*
;1;;*


;1;; With streams, you have to actually write a file when you're queuing to another machine.*

(defun laser2-print-stream (arg1 stream &rest ignore)
  (start-laser2-processes-if-needed)
  (push (list ':STREAM arg1 stream)
	(send *laser2-stream* ':printer-queue)))

;1;; Where as with files, you just pass the name.*

(defun laser2-print-file (arg1 file &rest args &aux orientation)
  (if (member ':orientation args)
      (setq orientation (cadr (member ':orientation args)))
    (setq orientation nil))
  (start-laser2-processes-if-needed)
  (push (list ':file arg1 file orientation) (send *laser2-stream* ':printer-queue)))

(defconst BGLY 199. "Font download Command")

(defconst charmag 3.)

;1;; Download a Lispm font to the Laser2.*

(defmethod (laser2-stream :download-font) (font-desc font-number char-number orientation
					   &aux byte count char-width char)
  (setq char (aref font-desc char-number))
  (if (not char) ()
    (if (equal orientation :LANDSCAPE)
	(progn (send tcp-stream :tyo BGLY)
	       (send self :send-n-bytes (+ (lsh 1 14.) (lsh font-number 7) char-number) 2)
	       (setq char-width (fed:cd-char-width char))
	       (send self :send-n-bytes (* char-width charmag) 2)
	       (send self :send-n-bytes (* (car (array-dimensions char)) charmag) 2)
	       (send self :send-n-bytes 0 2)
	       (send self :send-n-bytes (* (cadr (array-dimensions char)) charmag) 2)
	       (send self :send-n-bytes (* (fed:fd-baseline font-desc) charmag) 2)
	       (dotimes (r (cadr (array-dimensions char)))
		 (dotimes (k charmag)
		   (setq byte 0)
		   (setq count 7)
		   (do ((c (1- (car (array-dimensions char))) (1- c)))
		       ((= c -1))
		     (dotimes (j charmag)
		       (setq byte (logior byte
					  (lsh
					    (if (zerop
						  (aref char c r))
						0 1) count)))
		       (setq count (1- count))
		       (if (not (minusp count)) ()
			 (setq count 7)
			 (send tcp-stream :tyo byte)
			 (setq byte 0))))
		   (if ( count 7)
		       (send tcp-stream :tyo byte)))))
      (send tcp-stream :tyo BGLY)
      (send self :send-n-bytes (+ (lsh font-number 7) char-number) 2)
      (setq char-width (fed:cd-char-width char))
      (send self :send-n-bytes (* char-width charmag) 2)
      (send self :send-n-bytes (* (cadr (array-dimensions char)) charmag) 2)
      (send self :send-n-bytes 0 2)
      (send self :send-n-bytes (* (car (array-dimensions char)) charmag) 2)
      (send self :send-n-bytes (* (fed:fd-baseline font-desc) charmag) 2)
      (dotimes (r (car (array-dimensions char)))
	(dotimes (k charmag)
	  (setq byte 0)
	  (setq count 7)
	  (dotimes (c (cadr (array-dimensions char)))
	    (dotimes (j charmag)
	      (setq byte (logior byte
				 (lsh
				   (if (zerop
					 (aref char r c))
				       0 1) count)))
	      (setq count (1- count))
	      (if (not (minusp count)) ()
		(setq count 7)
		(send tcp-stream :tyo byte)
		(setq byte 0))))
	  (if ( count 7)
	      (send tcp-stream :tyo byte))))))
    t)

(defmethod (laser2-stream :send-n-bytes) (number n)
  (dotimes (b n)
    (send tcp-stream :tyo (load-byte number (* (- (1- n) b) 8.) 8.))))


(defmethod (laser2-stream :set-x-abs) (value)
  (send tcp-stream :tyo 135.)
  (send self :send-n-bytes value 2))

(defmethod (laser2-stream :set-y-abs) (value)
  (send tcp-stream :tyo 137.)
  (send self :send-n-bytes value 2))

(defmethod (laser2-stream :set-x-rel) (value)
  (send tcp-stream :tyo 136.)
  (send self :send-n-bytes value 2))

(defmethod (laser2-stream :set-y-rel) (value)
  (send tcp-stream :tyo 138.)
  (send self :send-n-bytes value 2))

(defmethod (laser2-stream :set-font) (value)
  (setq current-map (nth value font-maps))
  (send tcp-stream :tyo 207.)
  (send tcp-stream :tyo value)
  (setq current-font value)
  (setq current-descriptor (nth value font-descriptors))
  (send self :set-space-size (* (fed:fd-space-width current-descriptor) charmag)))

(defmethod (laser2-stream :push-font) (value)
  (push current-font font-stack)
  (send self :set-font value))

(defmethod (laser2-stream :pop-font) ()
  (if font-stack
      (send self :set-font (pop font-stack))
    (send self :set-font current-font)))

(defmethod (laser2-stream :new-page) ()
  (send tcp-stream :tyo 219.))

(defmethod (laser2-stream :set-space-size) (value)
  (send tcp-stream :tyo 210.)
  (send self :send-n-bytes value 2))

(defmethod (laser2-stream :space) ()
  (send tcp-stream :tyo 128.))

(defvar top-margin 240. "Top Margin in Micas")

(defvar left-margin 120. "Left Margin in Micas")

(defvar bottom-margin 240. "Bottom Margin in Micas")
						
(defvar page-size (* charmag 1100.) "Page Size in Micas")

(defvar page-width (* charmag 850.) "Page Width in Micas")

(defvar header-space 120.)

(defvar interline-spacing 10.)

(defvar default-font :cptfont)

(defvar header-font :cptfontb)

;1;; Another attempt to avoid consing.*

(defvar page-string (make-array 30. ':type art-string ':leader-list '(0)))

;1;; Pretty straight forward, except that we simulate some characters, and special case form*
;1;; feed to get the headers right.*

(defmethod (laser2-stream :print-stream) (in-stream &optional orientation)
  (if (equal *laser2-print-mode* :IMAGE)
      (send *laser2-stream* :print-stream-laser2 in-stream *default-orientation*)
    (send *laser2-stream* :text-print in-stream *default-orientation*)))

(defmethod (laser2-stream :font-tyo) (char orientation)
  (and (zerop (aref current-map char))
       (send self :download-font
	     current-descriptor
	     current-font
	     char
	     orientation)
       (setf (aref current-map char) 1))
  (send tcp-stream :tyo char))


(defmethod (laser2-stream :print-stream-laser2) (in-stream orientation &aux file pathname temp
						 paper-height)
  (setq fonts (cadr (member :fonts (fs:read-attribute-list temp in-stream))))
  (setq pathname (send in-stream ':send-if-handles ':pathname))
  (setq file (if pathname (send pathname ':string-for-printing)
	       "Stream Dump"))
  (make-header tcp-stream ':language "Impress" :filename file :pagereversal "off")
  (if (equal orientation :PORTRAIT) (setq paper-height page-size)
    (setq paper-height page-width)
    (send tcp-stream :tyo 205.)
    (send tcp-stream :tyo 65.))
  (if (not fonts)
      (setq fonts (list default-font)))
  (if (not (member header-font fonts))
      (setq fonts (append fonts (list header-font))))
  (setq font-count 0)
  (setq page-count 1)
  (setq char-count 0)
  (setq line-space 0)
  (setq font-stack nil)
  (setq font-maps nil)
  (setq font-descriptors nil)
  (dolist (font fonts)
    (push (make-array 128. :type art-1b) font-maps)
    (setq font-descriptors (append font-descriptors
				   (list (fed:font-get-fd (intern font 'fonts)))))
    (incf font-count))
  (setq header-font-number (find-position-in-list header-font fonts))
  (send self :set-font 0)
  (setq v-pos (* paper-height 2))
  (do ((char (tyi in-stream ':eof) (tyi in-stream ':eof)))
      ((equal char ':eof)
       (send self :new-page))
    (if ( v-pos paper-height)
	(progn
	  (send self :set-x-abs left-margin)
	  (send self :set-y-abs top-margin)
	  (send self :push-font header-font-number)
	  (dotimes (n (string-length file))
	    (if (= (aref file n) 32.)
		(send self :space)
	      (send self :font-tyo (aref file n) orientation)))
	  (setf (array-leader page-string 0) 0)
	  (format page-string "Page ~D" page-count)
	  (setq page-count (1+ page-count))
	  (send self :set-x-rel (* (fed:fd-space-width current-descriptor)
				   charmag
				   (- 70. (string-length file) (string-length page-string))))
	  (dotimes (n (string-length page-string))
	    (if (= (aref page-string n) 32.)
		(send self :space)
	      (send self :font-tyo (aref page-string n) orientation)))
	  (setq v-pos (+ top-margin bottom-margin))
	  (send self :crlf)
	  (send self :crlf)
	  (send self :pop-font)))
    (cond
      ((= char 6.)
       (setq temp (send in-stream :tyi))
       (if (= temp #/*)
	   (send self :pop-font)
	 (send self :push-font (- temp #/0))))
      ((= char #\return)
       (send self :crlf))
      ((= char #\tab)
       (send self :tab))
      ((= char #\line)
       (send self :lf))
      ((= char #\form)
       (setq line-space (* paper-height 2.)))
      ((equal (array-dimensions (aref current-descriptor char)) '(0 0))
       (send self :space))
      (t
       (incf char-count)
       (if (> (fed:fd-line-spacing current-descriptor) line-space)
	   (setq line-space (fed:fd-line-spacing current-descriptor)))
       (send self ':font-tyo char orientation)))
    (if ( v-pos paper-height)
	(send self :new-page))))

(defmethod (laser2-stream :crlf) ()
  (send self :set-x-abs left-margin)
  (setq char-count 0)
  (send self :lf))

(defmethod (laser2-stream :lf) ()
  (if (zerop line-space)
      (setq line-space (fed:fd-line-spacing current-descriptor)))
  (send self :set-y-rel (+ interline-spacing (* charmag line-space)))
  (setq v-pos (+ v-pos interline-spacing (* charmag line-space))
	line-space 0))

(defmethod (laser2-stream :tab) ()
  (send self :set-x-rel (* (- 8. (mod char-count 8.)) charmag
			   (fed:fd-space-width current-descriptor)))
  (setq char-count (+ char-count (- 8. (mod char-count 8.)))))


(defmethod (laser2-stream :print-file) (file orientation)
  (if (probef file)
      (with-open-file (stream file)
	(send self :print-stream stream orientation))
    (tv:background-notify "File ~a doesn't exist" file)))

(putprop ':LASER2 'LASER2:LASER2-PRINT-STREAM 'SI:PRINT-STREAM)
(putprop ':LASER2 'LASER2:LASER2-PRINT-FILE 'SI:PRINT-FILE)

;1;; Do we print landscape or portrait?*

;1;; Another attempt to avoid consing.*

(defvar page-string (make-array 30. ':type art-string ':leader-list '(0)))


;1;; Pretty straight forward, except that we simulate some characters, and special case form*
;1;; feed to get the headers right.*

(defmethod  (laser2-stream :text-print) (stream orientation
			     &aux file pathname (line-count 62.))
  (setq page-count 1)
  (setq pathname (send stream ':send-if-handles ':pathname))
  (setq file (if pathname (send pathname ':string-for-printing)
		   "Stream Dump"))
  (make-header tcp-stream ':language "Printer" ':filename file
	       ':formwidth (if (equal orientation ':portrait) 80. 132.)
	       ':pagereversal "off"
	       ':pagecollation "on")
  (do ((char (tyi stream ':eof) (tyi stream ':eof)))
      ((equal char ':eof)
       (send tcp-stream ':tyo 14.))
    (if ( line-count 60.)
	(progn
	  (send tcp-stream ':string-out file)
	  (setf (array-leader page-string 0) 0)
	  (format page-string "Page ~D" page-count)
	  (setq page-count (1+ page-count))
	  (dotimes (n (- 70. (string-length file)) (string-length page-string))
	    (send tcp-stream ':tyo 32.))
	  (send tcp-stream ':string-out page-string)
	  (send tcp-stream ':tyo 13.)
	  (send tcp-stream ':tyo 10.)
	  (send tcp-stream ':tyo 13.)
	  (send tcp-stream ':tyo 10.)
	  (setq line-count 2.)))      
    (cond
      ;1; Ignore font changes for now.*
      ((= char 6)
       (send stream ':tyi))
      ((= char #/)
       (send tcp-stream ':tyo #/<)
       (send tcp-stream ':tyo 8.)
       (send tcp-stream ':tyo #/_))
      ((= char #/)
       (send tcp-stream ':tyo #/>)
       (send tcp-stream ':tyo 8.)
       (send tcp-stream ':tyo #/_))
      ((= char #/)
       (send tcp-stream ':tyo #/=)
       (send tcp-stream ':tyo 8.)
       (send tcp-stream ':tyo #//))
      ((= char #\return)
       (send tcp-stream ':tyo 13.)
       (send tcp-stream ':tyo 10.)
       (setq line-count (1+ line-count)))
      ((= char #\line)
       (send tcp-stream ':tyo 10.))
      ((= char #\tab)
       (send tcp-stream ':tyo 9.))
      ((= char #\form)
       (send tcp-stream ':tyo 14.)
       (setq line-count 60.))
      ((and (> char 31.) (< char 127.))
       (send tcp-stream ':tyo char)))))