#|;;; -*- Mode:LISP; Package:TCP-APPLICATION; Fonts:(CPTFONTB); Base :10; Patch-File:T -*- Copyright LISP Machine, Inc. 1985 See filename "Copyright.Text" for licensing and release information. This is some simple imagen support code, more extensive capabilities such as multiple fonts and other impress support are available as a seperate product from LMI. |# (defun make-printer-imagen (address) "Set the default printer to be an imagen at the given address" (check-type address string) (setq si:*default-printer* (list :imagen address)) (setq si:*default-bit-array-printer* (list :imagen address))) (defvar *imagen-status-ok-wait* nil "if not-null the number of seconds to pause before trying to get a go-ahead status from the imagen") (defvar *imagen-status-ok-wait-tries* 10) (defun imagen-status-ok-to-print (address &optional (verbose t)) (cond ((not *imagen-status-ok-wait*) (imagen-status-ok-to-print-1 address verbose)) ('else (do ((j 0 (1+ j))) ((imagen-status-ok-to-print-1 address verbose) t) (if (= (1- *imagen-status-ok-wait-tries*) (mod j *imagen-status-ok-wait-tries*)) (cerror "continue waiting for it" "Imagen printer at ~S may be wedged" address)) (process-sleep (fix (* *imagen-status-ok-wait* 60)) "imagen queue wait"))))) (defun imagen-status-ok-to-print-1 (address verbose) (let ((status (get-imagen-status address))) (cond ((null status) (format t "~&Imagen printer at ~S not responding~%" addres s) nil) ((zerop (getf status :protocols-accepted)) (format t "~&Printer busy, try again: ~A~%" (getf status :engine-status)) Page 2 IMAGEN.LISP#1 GJC; LAM6: nil) ('else (describe-imagen-status status standard-output verbose) t)))) (defun (:imagen si:print-file) (printer filename &rest options) (let ((address (cadr printer))) (cond ((not (imagen-status-ok-to-print address))) ((probe-file filename) (print-document-to-imagen filename address options)) ('else (format t "~&File not found: ~S~%" filename))))) (DEFVAR INCREDIBLE-KLUDGE) (DEFUN (:IMAGEN SI:PRINT-STREAM) (PRINTER STREAM &REST OPTIONS) (LET ((INCREDIBLE-KLUDGE STREAM)) (APPLY (GET :IMAGEN 'SI:PRINT-FILE) PRINTER "EVAL-HOST:TCP-APPLICATION:INCREDIBLE-KLUDGE" OPTIONS))) (defun (:imagen si:print-status) (printer &optional (stream standard- output)) (format stream "~&Status of: ~A~%" printer) (describe-imagen-status (get-imagen-status (cadr printer)) stream)) (defun describe-imagen-status (status stream &optional (verbose t)) (cond ((null status) (format stream "~&Imagen printer not responding~%")) (verbose (format stream "~&Imagen printer at ~S for ~D second~p.~%~A~ %" (getf status :address) (getf status :age) (getf stat us :age) (getf status :engine-status)) (format stream "Job requests will be ~A~%" (if (zerop (getf status :protocols-accepted)) "rejected" "accepted")) (let ((problems (set-difference (getf status :problems) '(:job-in-progress)))) (if problems (format t "Problem~p: ~{~A~^, ~}.~%" (length problems) problems)))) ('else (princ (getf status :engine-status) stream) Page 3 IMAGEN.LISP#1 GJC; LAM6: (let ((problems (set-difference (getf status :problems) '(:job-in-progress)))) (if problems (format t " Problem~p: ~{~A~^, ~}.~%" (length problems) problems)))))) (defun print-document-to-imagen (filename address options) (check-type address string) (with-open-file (file-stream filename) (with-open-file (imagen-stream (string-append "TCP-HOST:" address "#IMAGEN") :auto-force-output nil) (let ((stream (make-simple-lispm->ascii-stream imagen-stream))) (format stream "@document(language Printer,~ ~% jobheader on,~ ~% name ~S,~ ~% spooldate ~S,~ ~% owner ~S,~ ~% pageReversal)" (send (send file-stream :truename) :string-for-printi ng) (time:print-current-time nil) (string si:user-id)) (let ((heading (if (getf options :page-headings) (send (send file-stream :truename) :string -for-editor)))) (let ((lpr (make-lpr-stream stream :margin 1 :width 80 :length 58 :pageno (not (null heading)) :heading heading))) (when heading (stream-copy-until-eof file-stream ))))) (defun make-simple-lispm->ascii-stream (output) (progv '(ftp:*hash*) '(nil) (closure '(ftp:*hash*) (FTP:MAKE-ASCII-TRANSLATING-OUTPUT-STREAM output)))) #|| (DEFUN TEST-LPR-STREAM (&optional no-op &aux tm) Page 4 IMAGEN.LISP#1 GJC; LAM6: (WITH-OPEN-FILE (IN "lm:gjc;IMAGEN.LISP") (WITH-OPEN-FILE (OUT "lm:gjc;IMAGEN.LPR" :OUT) (format t "~&;Timing ...") (setq tm (time)) (STREAM-COPY-UNTIL-EOF IN (if no-op out (MAKE-LPR-STREAM OUT :HEADING (send (SEND IN :TR UENAME) :string-for- editor) :pageno t))) (setq tm (quotient (time-difference (time) tm) 60.0)) (format t "~&;~$ seconds" tm) tm))) ||# (DEFUN MAKE-LPR-STREAM (OUTPUT &OPTIONAL &KEY (MARGIN 10) (WIDTH 69) (LENGTH 50) (PAGENO T) (HEADING NIL)) &AUX STREAM (LINE-COUNT 0) (CHAR-COUNT 0) (PA GE-COUNT 1)) "Make a stream for creating files suitable for simple line-printers " (SETQ STREAM #'(LAMBDA (OP &OPTIONAL ARG1 &REST ARGS) (SI:SELECTQ-WITH-WHICH-OPERATIONS OP (:TYO (COND ((< ARG1 #o40)) ((= ARG1 #\RETURN) (COND ((= LINE-COUNT LENGTH) (SEND OUTPUT :TYO #\FORM) (INCF PAGE-COUNT) (SETQ LINE-COUNT 0) (SETQ CHAR-COUNT 0) (WHEN (OR PAGENO HEADING) (DOTIMES (J (FLOOR WIDTH 2)) (SEND OUTPUT :TYO #\SPACE)) (COND ((AND PAGENO HEADING) (FORMAT STREAM "Page ~D ~A~%~%" page-count heading )) (PAGENO (FORMAT STREAM "Page ~D ~%~%" Page 5 IMAGEN.LISP#1 GJC; LAM6: heading )) (HEADING (FORMAT STREAM "~A~%~%" HEADING))))) ('ELSE (INCF LINE-COUNT) (SETQ CHAR-COUNT 0) (SEND OUTPUT :TYO #\RETURN) (DOTIMES (J MARGIN) (SEND OUTPUT :TYO #\SPACE))))) ((= ARG1 #\TAB) (DOTIMES (J (- 8 (MOD CHAR-COUNT 8))) (SEND STREAM :TYO #\SPACE))) ((GRAPHIC-CHAR-P ARG1) (COND ((= CHAR-COUNT WIDTH) (SEND STREAM :TYO #\RETURN) (SEND STREAM :TYO ARG1)) ('ELSE (INCF CHAR-COUNT) (SEND OUTPUT :TYO ARG1)))))) ;; handling :STRING-OUT is somewhat of a pain, b ut ;; runtime efficient, and interesting from the p oint of ;; view of how one would define a language so as to ;; make this sort of case handling more natural. ;; Timing result: 7.6 seconds with :STRING-OUT ;; 14.2 without. Using TEST-LPR-ST REAM ;; on this source file. No-Op case is 0.82 secon ds. ;;#|| (:string-out ;; we can think of two ways of handling this, ;; the complete way, by taking the :TYO code ;; and optimizing it by keeping local (non enc losed) ;; variables and by delaying the :TYO to OUTPU T until ;; :STRING-OUT, or the EASY-CASES way, by reco gnising ;; an amount of characters which are an easy c ase. (do ((start (or (car args) 0) (let ((s (lpr-stream-string-out-ea sy-case Page 6 IMAGEN.LISP#1 GJC; LAM6: output arg1 start (min end (+ start (- width char-count)))))) (cond ((= s start) (send stream :tyo (aref a rg1 start)) (1+ start)) ('else (incf char-count (- s sta rt)) s)))) (end (or (cadr args) (length arg1)))) ((= start end)))) ;;||# (T (STREAM-DEFAULT-HANDLER STREAM OP ARG1 ARGS))) ))) (defun lpr-stream-string-out-easy-case (output string start end) (do ((j start (1+ j)) (c)) ((= j end) (send output :string-out string start end) j) (setq c (aref string j)) (cond ((graphic-char-p c)) ((= j start) (return j)) ('else (send output :string-out string start j) (return j))))) (defun get-imagen-status (address &key &optional (tries 10) (try-pause 0.01) (wait-pause 0.01)) "Returns a plist describing the status of the imagen at the interne t ADDRESS" (check-type address string) (check-type tries (fixnum 1)) (check-type try-pause number) (check-type wait-pause number) (let (result) (dotimes (j tries) (if (setq result (get-imagen-status-1 address (ROUND (* wait-pa use 60)))) Page 7 IMAGEN.LISP#1 GJC; LAM6: (return-from get-imagen-status result)) (process-sleep (ROUND (* try-pause 60)) "imagen status sleep")) )) (defconst imagen-udp-status-pkt-size 256) (defun get-imagen-status-1 (address pause) (with-open-file (stream (string-append "TCP-HOST:" address "#IMAGEN ") :for-udp t) (using-resource (array fs:simple-string-buffer imagen-udp-status- pkt-size) (fill array 0) (send stream :write-packet array 0 imagen-udp-status-pkt-size) (dotimes (j pause) ;; :listen cant be use inside a process-wait function because ;; it sends a message to the device driver which needs a proc ess ;; to run in order to get the reply. (if (send stream :listen) (return)) (process-sleep 1 "imagen status reply")) (WHEN (SEND STREAM :LISTEN) (SEND STREAM :READ-PACKET ARRAY) (let ((plist (PARSE-IMAGEN-STATUS-PACKET ARRAY))) (setf (getf plist :address) address) plist))))) (DEFUN BIG-ENDIAN-BYTES (ARRAY &REST BYTES) "Combine bytes into an integer, most significant come first" (DO ((NUMBER 0 (+ (* NUMBER 256) (AREF ARRAY (CAR L)))) (L BYTES (CDR L))) ((NULL L) NUMBER))) (DEFUN PARSE-IMAGEN-STATUS-PACKET (ARRAY) (DO ((PLIST (LIST :STATUS-BYTE (BIG-ENDIAN-BYTES ARRAY 2) :AGE (BIG-ENDIAN-BYTES ARRAY 4 5 6 7) :PROTOCOLS-SUPPORTED (BIG-ENDIAN-BYTES ARRAY 8 9 10 11) :PROTOCOLS-ACCEPTED (BIG-ENDIAN-BYTES ARRAY 12 1 3 14 15) :ENGINE-STATUS (SUBSTRING ARRAY (BIG-ENDIAN-BYTES ARRAY 16 1) (+ (BIG-ENDIAN-BYTES AR RAY 16 1) (BIG-ENDIAN-BYTES AR RAY 18 19))))) (PROBLEMS '((#x01 :OTHER) (#x02 :NO-PAPER) Page 8 IMAGEN.LISP#1 GJC; LAM6: (#x04 :PAPER-JAM) (#x08 :LACKING-CONSUMABLES) (#xF0 :JOB-IN-PROGRESS)) (CDR PROBLEMS))) ((NULL PROBLEMS) PLIST) (IF (BIT-TEST (CAAR PROBLEMS) (GETF PLIST :STATUS-BYTE)) (PUSH (CADAR PROBLEMS) (GETF PLIST :PROBLEMS))))) ;;; printing arrays is somewhat hairier ;; for simplicity and speed we convert the bit array directly into ;; impress, (even if inside the KBD-SYS process) and then queue it fo r ;; transmission. (defvar *imagen-data-bytes* nil) (defvar *imagen-data-size* nil "A list of (hsize vsize), of 32^2 chun ks") (defun (:imagen si:print-bit-array) (PRINTER ARRAY LEFT TOP RIGHT BOT TOM &rest ignore) (when (null *imagen-data-bytes*) (setq *imagen-data-bytes* (make-array (// (* 1024 1024) 8) :type 'art-string))) (let (okp mess) (cond ((> (setq okp (round (* (- right left) (- bottom top)) 8)) (length *imagen-data-bytes*)) (tv:notify nil "Array too big to process, need ~D bytes" o kp)) (*imagen-data-size* (tv:notify nil "Last array still processing, try again lat er")) ((progn (and *imagen-status-ok-wait* ;; if we are going to wait for the imagen to b e ready ;; then process the data now. (setup-imagen-data-bytes array left top (- rig ht left) (- bottom top))) (setq mess (with-output-to-string (standard-output) (setq okp (imagen-status-ok-to-print ( cadr printer) n il)))) okp) Page 9 IMAGEN.LISP#1 GJC; LAM6: (or *imagen-status-ok-wait* (setup-imagen-data-bytes array left top (- right left) (- bottom top))) (tv:notify nil "~A" mess) ;; actually should do waiting in background process. ;; Implement full queued situation... (process-run-function "imagen transmit" #'transmit-imagen-data-bytes (cadr printer)))))) (defvar *bitrev-byte-table* nil) (defun transmit-imagen-data-bytes (address) (condition-case (obj) (unwind-protect (transmit-imagen-data-bytes-1 address) (setq *imagen-data-size* nil)) (error (tv:notify nil "~A" (with-output-to-string (stream) (send obj :report stream)) nil)))) (defun impress (stream &rest data) (dolist (datum data) (cond ((symbolp datum) (impress stream (or (get datum 'impress) (ferror nil "Undefined impress symbol: ~S" datum)))) ((atom datum) (if (atom stream) (send stream :tyo datum) (setf (car stream) (nconc (car stream) (ncons datum))))) ((eq (car datum) :word) (impress stream (ldb (byte 8 8) (cadr datum)) (ldb (byte 8 0) (cadr datum)))) ((eq (car datum) :byte) (do ((x 0 (+ (car v) (* x 2))) (v (cdr datum) (cdr v))) ((null v) (impress stream x)))) ('else (ferror nil "unknown impress datum: ~S" datum))))) (DEFPROP SET_MAGNIFICATION 236 IMPRESS) (DEFPROP SET_ABS_H 135 IMPRESS) (DEFPROP SET_ABS_V 137 IMPRESS) Page 10 IMAGEN.LISP#1 GJC; LAM6: (DEFPROP BITMAP 235 IMPRESS) (DEFPROP OPAQUE 3 IMPRESS) (DEFPROP SET_HV_SYSTEM 205 IMPRESS) (DEFPROP ENDPAGE 219 IMPRESS) (DEFPROP EOF 255 IMPRESS) (defun inches-to-points (x) (list :word (fix (* x 300)))) (defun imagen-magnification (bits inches) (let ((exact (log (// (* (float inches) 300) bits) 2))) (values (fix exact) (// (* bits (expt 2 (fix exact))) 300.0)))) (defvar *imagen-landscapep* '(> (car *imagen-data-size*) (cadr *imagen-data-size*)) "An expression to evaluate. If T then use landscape mode on imagen" ) (defvar *imagen-max-magnification* 4) (defun transmit-imagen-data-bytes-1 (address) (with-open-file (imagen-stream (string-append "TCP-HOST:" address "#IMAGEN")) (let* ((landscapep (eval *imagen-landscapep*)) (magnification (cond (landscapep (max 0 (min (fix (log *imagen-max-ma gnification* 2)) (imagen-magnification (n th 2 *imagen-data-size*) 10 .5) (imagen-magnification (n th 3 *imagen-data-size*) 8) ))) ('else (max 0 (min (fix (log *imagen-max-ma gnification* 2)) (imagen-magnification (n th 2 *imagen-data-size*) 7) (imagen-magnification (n th 3 *imagen-data-size*) 10 )))))) (ascii-stream (make-simple-lispm->ascii-stream imagen-stre am))) Page 11 IMAGEN.LISP#1 GJC; LAM6: (format ascii-stream "@document(language imPress,~ ~% jobheader on,~ ~% name ~:[portrait~;landscape~]~D-~D-~D,~ ~% spooldate ~S,~ ~% owner ~S,~ ~% pageReversal)" landscapep (expt 2 magnification) (nth 2 *imagen-data-size*) (nth 3 *imagen-data-size*) (time:print-current-time nil :dd-mmm-yyyy) (string si:user-id)) (cond (landscapep (impress imagen-stream 'SET_MAGNIFICATION magnification ;; the measurements units must be off, but th is looks ok. 'SET_ABS_H (inches-to-points 0.15) 'SET_ABS_V (inches-to-points 10.9) 'SET_HV_SYSTEM (list :byte 0 ; pad 1 1 ; ORIGIN: physical 1 0 ; AXES: +90 deg (r egular) 1 1 1 ; Orientation: 270 from X. ))) ('else (impress imagen-stream 'SET_MAGNIFICATION magnification 'SET_ABS_H (inches-to-points 1) 'SET_ABS_V (inches-to-points 1)))) (impress imagen-stream 'BITMAP 'OPAQUE (nth 0 *imagen-data-size*) (nth 1 *i magen-data-size*)) (send imagen-stream :string-out *imagen-data-bytes* 0 (* 128 (nth 0 *imagen-data-size*) (nth 1 *imagen-data -size*))) (impress imagen-stream 'ENDPAGE 'EOF)))) (defvar *32^32-chunk* nil) (defvar *128-byte-chunk* nil) (defun setup-imagen-data-bytes (array x y dx dy) (when (null *bitrev-byte-table*) (setq *bitrev-byte-table* (make-array 256)) Page 12 IMAGEN.LISP#1 GJC; LAM6: (dotimes (j 256) (setf (aref *bitrev-byte-table* j) (do ((value 0 (dpb (ldb (byte 1 k) j) (byte 1 (- 7 k)) va lue)) (k 0 (1+ k))) ((= k 8) value))))) (when (or (null *32^32-chunk*) (null *128-byte-chunk*)) (setq *32^32-chunk* (make-array '(32 32) :type 'art-1b)) (setq *128-byte-chunk* (make-array 128 :type 'art-8b :displaced-to *32^32-chunk*))) (multiple-value-bind (easy-y remainder-y) (floor dy 32) (multiple-value-bind (easy-x remainder-x) (floor dx 32) (let ((hsize (+ easy-x (if (zerop remainder-x) 0 1))) (vsize (+ easy-y (if (zerop remainder-y) 0 1)))) (setq *imagen-data-size* (list hsize vsize dx dy)) (do ((ymap 0 (1+ ymap)) (data-bytes *imagen-data-bytes*) (inc 0) (bitrev *bitrev-byte-table*) (32^32-chunk *32^32-chunk*) (128-byte-chunk *128-byte-chunk*)) ((= ymap vsize)) (do ((xmap 0 (1+ xmap))) ((= xmap hsize)) (let ((xbase (ash xmap 5)) (ybase (ash ymap 5))) (let ((x-want (min (- dx xbase) 32)) (y-want (min (- dy ybase) 32))) (when (or (= x-want remainder-x) (= y-want remainder-y)) (fill 128-byte-chunk 0)) (bitblt tv:alu-seta x-want y-want array (+ xbase x) (+ ybase y) 32^32-chunk 0 0))) (copy-array-portion-translated 128-byte-chunk 0 128 data-bytes inc (incf inc 128) Page 13 IMAGEN.LISP#1 GJC; LAM6: bitrev))))))) (defun copy-array-portion-translated (from-array from-start from-end to-array to-start to-end translation-table) ;; a canditate for microcompilation. (copy-array-portion from-array from-start from-end to-array to-start to-end) ;; A typical screen array takes 4.2 seconds to process. ;; 1.0 seconds with the following code commented out, ;; and 0.33 seconds with this entire function a no-op. (do ((j to-start (1+ j))) ((= j to-end)) ;; by having only one real array reference here ;; we win in the array cache. (setf (aref to-array j) ;; 3.4 seconds without the %p-contents-offset. (%p-contents-offset translation-table (1+ (aref to-array j) )))))