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

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


;1;; Constants for DPRESS commands.*
(defvar SET_MAGNIFICATION 236.)
(defvar BITMAP 235.)
(defvar ENDPAGE 219.)
(defvar eof 255.)
(defvar image-mag 2)
(defvar *x-offset* 44.)
(defvar *y-offset* 60.)

;1;; First check to make sure we're the machine with the printer. If not, queue it to a file,*
;1;; else go for it.*
(defun LASER2-PRINT-BIT-ARRAY (arg1 ARRAY LEFT TOP RIGHT BOTTOM &rest &key
			       &allow-other-keys (nocopy nil) 
			       &aux array1)
  (start-laser2-processes-if-needed)
  (if nocopy (setq array1 array)
    (setq array1 (allocate-resource 'tv:hardcopy-bit-array-resource))
    (bitblt tv:alu-seta (- right left) (- bottom top) array left top array1 0 0))
  (push (list :ARRAY arg1 array1 0 0 (- right left) (- bottom top) nocopy)
	(send *laser2-stream* :printer-queue)))
							     
(defvar bit-reversal-table (make-array 256. :element-type '(mod 256) :initial-value 0))

;1;; The function that creates screen dumps.*
(defmethod (laser2-stream :print-bit-array)
	   (ARRAY LEFT TOP RIGHT BOTTOM
	    &aux array-8 screen-output-array y-last
	    (last-dat (make-array 4))
	    index limit width power-of-2 dup-mag)
  (make-header tcp-stream :filename "Screen Dump")
  (if (zerop (mod image-mag 4.))
      (setq power-of-2 2.)
    (if (zerop (mod image-mag 2.))
	(setq power-of-2 1.)
      (setq power-of-2 0.)))
  (setq dup-mag (// image-mag (^ 2 power-of-2)))
  (send tcp-stream :tyo set_magnification)
  (send tcp-stream :tyo power-of-2)
  (if (> (- bottom top) (- right left)) ()
    (send tcp-stream :tyo 205.)
    (send tcp-stream :tyo 65.))
  ;1; X Offset (1/5 Inch)*
  (send tcp-stream :tyo 135.)
  (send tcp-stream :tyo 0)
  (send tcp-stream :tyo *x-offset*)
  ;1; Y Offset (1/5 Inch)*
  (send tcp-stream :tyo 137.)
  (send tcp-stream :tyo 0)
  (send tcp-stream :tyo *y-offset*)
  (send tcp-stream :tyo bitmap)
  (send tcp-stream :tyo 3.)
  (if (and (zerop (mod left 8.)) (zerop (mod (array-dimension array 1) 8.))
	   (= dup-mag 1))
      (progn
	(if (= (aref bit-reversal-table 255.) 255.) ()
	  (dotimes (n 256.)
	    (setf (aref bit-reversal-table n)
		  (+ (if (bit-test 128. n) 1. 0)
		     (if (bit-test 64. n) 2. 0)
		     (if (bit-test 32. n) 4. 0)
		     (if (bit-test 16. n) 8. 0)
		     (if (bit-test 8. n) 16. 0)
		     (if (bit-test 4. n) 32. 0)
		     (if (bit-test 2. n) 64. 0)
		     (if (bit-test 1. n) 128. 0)))))
	(send tcp-stream :tyo (// (- right left) 32.))
	(if (zerop (\ (- bottom top) 32.))
	    (send tcp-stream :tyo (// (- bottom top) 32.))
	  (send tcp-stream :tyo (1+ (// (- bottom top) 32.))))
	(setq width (// (array-dimension array 1) 8.))
	(setq array-8 (make-array (* (array-dimension array 0) width)
				   :type art-8b :displaced-to array))
	(send tcp-stream :send-current-output-buffer)
	(multiple-value (screen-output-array index limit)
	  (send tcp-stream :new-output-buffer))
	(do ((row top (+ row 32.)))
	     (( row bottom))
	  (do ((col (// left 8.) (+ col 4)))
	      (( col (// right 8.)))
	    (do* ((y row (1+ y))
		 (offset (+ (* y width) col)  (+ (* y width) col) ))
		 ((= y (+ row 32.)))
	      (if ( y bottom)
		  (dotimes (n 4)
		    (aset 0 screen-output-array index)
		    (incf index)
		    (if ( index limit) ()
			(send tcp-stream :send-output-buffer screen-output-array index)
			(multiple-value (screen-output-array index limit)
			  (send tcp-stream :new-output-buffer))))
		(dotimes (x 4)
		  (aset (aref bit-reversal-table (aref array-8 (+ offset x)))
			screen-output-array index)
		  (incf index)
		  (if ( index limit) ()
		    (send tcp-stream :send-output-buffer screen-output-array index)
		    (multiple-value (screen-output-array index limit)
		      (send tcp-stream :new-output-buffer))))))))
	(if (< (+ index 3) limit) ()
	  (send tcp-stream :send-output-buffer screen-output-array index)
	  (multiple-value (screen-output-array index limit)
	    (send tcp-stream :new-output-buffer)))
	(aset 219. screen-output-array index) ; >Magic number ?
	(incf index)
	(aset 255. screen-output-array index) ; > Magic number ?
	(incf index)
	(send tcp-stream :send-output-buffer screen-output-array index))

    ;1; Compute width to nearest 32 bit boundary.*
    (if (zerop (\ (* dup-mag (- right left)) 32.))
	(send tcp-stream :tyo (// (* dup-mag (- right left)) 32.))
      (send tcp-stream :tyo (1+ (// (* dup-mag (- right left)) 32.))))
    ;1; Same for height*
    (if (zerop (\ (* dup-mag (- bottom top)) 32.))
	(send tcp-stream :tyo (// (* dup-mag (- bottom top)) 32.))
      (send tcp-stream :tyo (1+ (// (* dup-mag (- bottom top)) 32.))))
    ;1; Go through sending 32x32 bit chunks, padding with 0.*
    (send tcp-stream :send-current-output-buffer)
    (multiple-value (screen-output-array index limit)
      (send tcp-stream :new-output-buffer))
    (do ((row (* dup-mag top) (+ row 32.))
	 (height (car (array-dimensions array)))
	 (width (cadr (array-dimensions array))))
	(( row (* dup-mag bottom)))
      (do ((col (* dup-mag left) (+ col 32.)))
	  (( col (* dup-mag right)))
	(setq y-last nil)
	(do* ((y row (1+ y))
	      (y1 (// y dup-mag) (// y dup-mag)))
	    ((= y (+ row 32.)))
	  (if (and y-last (= y1 y-last))
	      (dotimes (n 4)
		(aset (aref last-dat n) screen-output-array index)
		(incf index)
		(if ( index limit) ()
		  (send tcp-stream :send-output-buffer screen-output-array index)
		  (multiple-value (screen-output-array index limit)
		    (send tcp-stream :new-output-buffer))))
	    (do ((x col (+ 8. x))
		 (n 0 (1+ n))
		 (byte 0 0))
		((= x (+ col 32.)))
	      (setq y-last y1)
	      (if (and (< y (* dup-mag height)) (< x (* dup-mag width)))
		  (do* ((bit x (1+ bit))
			(b (- bit x) (- bit x)))
		       ((= b 8.))
		    (setq byte (logior byte (lsh (aref array y1 (// bit dup-mag))
						 (- 7. b))))))
	      (setf (aref last-dat n) byte)
	      (aset byte screen-output-array index)
	      (incf index)
	      (if ( index limit) ()
		(send tcp-stream :send-output-buffer screen-output-array index)
		(multiple-value (screen-output-array index limit)
		(send tcp-stream :new-output-buffer))))))))
    (if (< (+ index 3) limit) ()
      (send tcp-stream :send-output-buffer screen-output-array index)
      (multiple-value (screen-output-array index limit)
	(send tcp-stream :new-output-buffer)))
    (aset 219. screen-output-array index)
    (incf index)
    (aset 255. screen-output-array index)
    (incf index)
    (send tcp-stream :send-output-buffer screen-output-array index)))
  ;1; End page.*

;1;; Function to create a document header.*

(defun make-header (tcp-stream &optional &key (language "Impress")
		    (owner (or user-id "Free Machine"))
		    (filename "")
		    (directory "")
		    (copies 1)
		    (jamresistance "off")
		    (pagecollation "off")
		    (pagereversal "off")
		    (paper "Letter")
		    (jobheader "on")
		    (messagedetail "off")
		    (formwidth 80.)
		    (name (send (send fs:local-host-pathname :host) :name)))
  (format tcp-stream
	  "@document(name /"~A/", owner /"~A/", directory /"~A/")"
	  name owner directory)
  (format tcp-stream
	  "@document(filename /"~A/", printed /"~A/")"
	  filename (time:print-current-time nil))
  (format tcp-stream
	  "@document(Language ~A, Copies ~D, JamResistance ~A)"
		language copies jamresistance)
  (format tcp-stream
	  "@document(PageCollation ~A, PageReversal ~D, Paper ~A)"
	  pagecollation pagereversal paper)
  (format tcp-stream
	  "@document(JobHeader ~A, MessageDetail ~D)"
	  jobheader messagedetail)
  (if (string-equal language "Printer")
      (format tcp-stream "@document(Formwidth ~D)" formwidth)))

(setf (get :laser2 'si:print-bit-array) 'laser2:laser2-print-bit-array)