LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032933. :SYSTEM-TYPE :LOGICAL :VERSION 1. :TYPE "LISP" :NAME "VERSA" :DIRECTORY ("REL3-PUBLIC" "PUBLIC") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2753216099. :AUTHOR "REL3" :LENGTH-IN-BYTES 13242. :LENGTH-IN-BLOCKS 13. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                  ;;; -*- Mode: common-LISP; Package: PRINTER; Base: 8 -*-;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;;;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.;;; Copyright (C) 1984 by Texas Instruments Incorporated.;;; All rights reserved.;;; This file defines print device, VERSA.(FS:DEFINE-CANONICAL-TYPE :VERSA "VERSA" (:LISPM "plot"); use to be "versa"   (:UNIX "plot") (:VMS "plt"))    ; use to be "vsa"(DEFPROP VERSA (454) DOTS-PER-INCH) (DEFFLAVOR VERSA   ((VERSA-CHAR-ARRAY (MAKE-ARRAY 2000 ':TYPE 'ART-STRING ':LEADER-LIST '(0)))    (VERSA-CHARCNT 0)    (VERSA-CNT-SINCE-CRLF 0))   (BASIC-PRINTER)) (DEFMETHOD (VERSA :PRINT-BITMAP) (BITMAP-ARRAY &OPTIONAL WIDTH HEIGHT (START-X 0) (START-Y 0) ORIENTATION DOTS-PER-INCH &AUX  LANDSCAPEP)  "Copy the bitmap array to a print stream;printer-stream can only be a file stream, since VERSA is currently only on a VAX"  (UNLESS WIDTH    (SETQ WIDTH (array-dimension BITMAP-ARRAY 1)))  (UNLESS HEIGHT    (SETQ HEIGHT (array-dimension BITMAP-ARRAY 0)))  (SETQ LANDSCAPEP (SEND SELF :COMPUTE-ORIENTATION ORIENTATION DOTS-PER-INCH WIDTH HEIGHT))  (IF LANDSCAPEP    (PSETQ WIDTH HEIGHT HEIGHT WIDTH START-X START-Y START-Y START-X))  (SEND SELF :WRITE-BITMAP BITMAP-ARRAY WIDTH HEIGHT START-X START-Y LANDSCAPEP)  (IF (NOT (ZEROP (ARRAY-ACTIVE-LENGTH VERSA-CHAR-ARRAY)))    (SEND SELF :VERSA-FLUSH-STRING-OUT))  T) (DEFMETHOD (VERSA :COMPUTE-ORIENTATION) (ORIENTATION IGNORE WIDTH HEIGHT)  "Returns whether or not landscape orientation is desired"  (CASE ORIENTATION    (:LANDSCAPE T)    (:PORTRAIT NIL)    (:BEST (> WIDTH HEIGHT)))) (DEFMETHOD (VERSA :WRITE-BITMAP) (BITMAP-ARRAY WIDTH HEIGHT START-X START-Y LANDSCAPEP)  "Write out bitmap"  (LET ((ZERO-COUNT 0)(ONE-COUNT 0))    (SEND SELF :VERSA-STORE "H" HEIGHT "W" WIDTH)    (LOOP FOR Y FROM START-Y BELOW HEIGHT DO       (LOOP FOR X FROM START-X BELOW WIDTH DO  (COND    ((=      (IF LANDSCAPEP(ARRAY-2-REF BITMAP-ARRAY Y (- WIDTH X 1))(ARRAY-2-REF BITMAP-ARRAY X Y))      0)     (INCF ZERO-COUNT)     (COND       ((NOT (ZEROP ONE-COUNT)) (SEND SELF :VERSA-STORE-COUNT #\O ONE-COUNT)(SETQ ONE-COUNT 0))))    (T (INCF ONE-COUNT)     (COND       ((NOT (ZEROP ZERO-COUNT)) (SEND SELF :VERSA-STORE-COUNT #\Z ZERO-COUNT)(SETQ ZERO-COUNT 0)))))  FINALLY  (PROGN;do at end of scanline   (COND     ((ZEROP ONE-COUNT)      (IF (= ZERO-COUNT WIDTH)(SEND SELF :VERSA-PUSH #\B)(SEND SELF :VERSA-STORE-COUNT #\Z ZERO-COUNT))      (SETQ ZERO-COUNT 0))     (T;one-count is non-zero      (IF (= ONE-COUNT WIDTH)(SEND SELF :VERSA-PUSH #\S)(SEND SELF :VERSA-STORE-COUNT #\O ONE-COUNT))      (SETQ ONE-COUNT 0))))  (SEND SELF :VERSA-PUSH #\L))))) (DEFMETHOD (VERSA :VERSA-STORE-COUNT) (COMPR-CHAR COUNT)  (PROGN    (SEND SELF :VERSA-PUSH COMPR-CHAR)    (IF (> COUNT 1);output the count, if needed      (SEND SELF :VERSA-STUFFN COUNT)))) (DEFMETHOD (VERSA :VERSA-PUSH) (SOMETHING)  (PROGN    (VECTOR-PUSH SOMETHING VERSA-CHAR-ARRAY)    (COND      ((= (ARRAY-ACTIVE-LENGTH VERSA-CHAR-ARRAY) 2000) (SEND SELF :VERSA-FLUSH-STRING-OUT)))    (INCF VERSA-CHARCNT)    (INCF VERSA-CNT-SINCE-CRLF)    (COND      ((> VERSA-CNT-SINCE-CRLF 774) (SETQ VERSA-CNT-SINCE-CRLF 0)       (VECTOR-PUSH #\NEWLINE VERSA-CHAR-ARRAY) (INCF VERSA-CHARCNT)       (SETQ VERSA-CNT-SINCE-CRLF 0))))) (DEFMETHOD (VERSA :VERSA-FLUSH-STRING-OUT) ()  (PROGN    (SEND PRINTER-STREAM :STRING-OUT VERSA-CHAR-ARRAY)    (STORE-ARRAY-LEADER 0 VERSA-CHAR-ARRAY 0))) (DEFMETHOD (VERSA :VERSA-STORE) (&REST ITEMS)  (MAPCAR #'(LAMBDA (NUM)      (SEND SELF :VERSA-STUFF NUM))  ITEMS)) (DEFMETHOD (VERSA :VERSA-STUFFN) (NUM &AUX NSTR)  (COND    ((< NUM 12) (SEND SELF :VERSA-PUSH (AREF "XX23456789" NUM)))    (T (SETQ NSTR (FORMAT () "~D" NUM))     (LOOP FOR I FROM 0 BELOW (ARRAY-ACTIVE-LENGTH NSTR) DO(SEND SELF :VERSA-PUSH (AREF NSTR I)))))) (DEFMETHOD (VERSA :VERSA-STUFF) (ITEM)  (COND    ((STRINGP ITEM) (SEND SELF :VERSA-PUSH (CHARACTER ITEM)))    ((NUMBERP ITEM) (SEND SELF :VERSA-STUFFN ITEM)))) (DEFMETHOD (VERSA :SCREEN-IMAGE-FILE-P) (FILENAME)  (LET ((FILE-TYPE (SEND FILENAME :TYPE)))    (OR (EQUALP "versa" FILE-TYPE) (EQUALP "vsa" FILE-TYPE) (EQUALP "plot" FILE-TYPE)       (EQUALP "plt" FILE-TYPE)))) (COMPILE-FLAVOR-METHODS VERSA) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; The following versa code is from "eh:window;obsolete.lisp#7" and is obsolete code;; originally in the Window system.  Transferred to Printer system for release 3.0 by;; lco, per te.;; From BASSTR 2/18/86 - lgo;; Versa - Versatec output routine;;;; This routine outputs the specified screen contents to the;; specified file in compressed format for later printing on;; a hardcopy device. The default screen is the one the mouse is;; currently in, and the default file is ai:ps:<netuser>versa-file.lm.;; Format for the call is;;;; (versa-hardcopy  (&optional ;;                  (file versa-file-name)       file name to store on;;                  (output nil)                    want % output;;                  (inside-margins nil)            copy from inside margins;;                  (window tv:mouse-window)        window you want dumped;;   ));; The compressed format is;;;; W<integer> - width of screen;; H<integer> - height of screen;; B - blank line (of zeroes);; S - solid line (of ones);; L - end of a scan line;; O - one bit on;; Z - one bit off;; O<integer> - that many ones;; Z<integer> - that many zeroes;;;;;; Edit History;; 10/27/81 created (ECP);; 11/3/81  add INSIDE-MARGINS (ECP);; 11/16/81 add OUTPUT so that % display is off by default (ECP);; 6/2/82   enhance performance, declare local fixnum variables;;          use fixed size output buffer (SDK);; 7/26/82  added queuing feature;; 8/24/82  made priority of queue server process -1 to help response to keyboard;; 1/11/83  forced TERMINAL/Q to pop up a window asking for the file name (BEF);;;;(DEFVAR versa-default-file-name "ai:ps:<netuser>versa-file.lm")(DEFVAR versa-debug-out nil)(DEFVAR versa-queue nil)(DEFVAR versa-process)(DEFVAR versa-queue-by-default t)(DEFSTRUCT (VERSA-ARRAY-QUEUE-ENTRY (:CONC-NAME VQ-) (:CONSTRUCTOR NIL) (:ALTERANT NIL)  (:CALLABLE-CONSTRUCTORS NIL) (:PREDICATE NIL) (:COPIER NIL) (:TYPE :LIST))  FILE  ARRAY  WIDTH  HEIGHT) (DEFUN versa-hardcopy-in-background       (&OPTIONAL (file versa-default-file-name)  (debug nil)  (inside-margins nil)  (window tv:mouse-window))       (versa-hardcopy file debug inside-margins window t))(DEFUN versa-hardcopy-in-foreground       (&OPTIONAL (file versa-default-file-name)  (debug nil)  (inside-margins nil)  (window tv:mouse-window))       (versa-hardcopy file debug inside-margins window nil))(DEFUN VERSA-HARDCOPY (&OPTIONAL (FILE VERSA-DEFAULT-FILE-NAME) (DEBUG NIL) (INSIDE-MARGINS NIL)  (WINDOW MOUSE-WINDOW) (QUEUE VERSA-QUEUE-BY-DEFAULT))  (LET ((BITMAP-ARRAY (SHEET-SCREEN-ARRAY WINDOW))(BITMAP-COPY-ARRAY NIL)(VERSA-DEBUG-OUT DEBUG)(START-X 0)(START-Y 0)(WIDTH 0)(HEIGHT 0))    (COND      (INSIDE-MARGINS       (MULTIPLE-VALUE-SETQ (START-X START-Y NIL NIL) (SEND WINDOW :INSIDE-EDGES))       (MULTIPLE-VALUE-SETQ (WIDTH HEIGHT) (SEND WINDOW :INSIDE-SIZE)))      (T (MULTIPLE-VALUE-SETQ (WIDTH HEIGHT)   (SEND WINDOW :SIZE))))    (COND      ((NULL BITMAP-ARRAY) (FERROR () "Window ~S has no bits now" WINDOW))      ((NOT (EQ 'ART-1B (ARRAY-TYPE BITMAP-ARRAY)))       (FERROR () "~S is not a bit array" BITMAP-ARRAY))      (QUEUE (SETQ BITMAP-COPY-ARRAY (MAKE-SHEET-BIT-ARRAY WINDOW WIDTH HEIGHT))       (PREPARE-SHEET (WINDOW)      (BITBLT ALU-SETA WIDTH HEIGHT BITMAP-ARRAY START-X START-Y      BITMAP-COPY-ARRAY 0 0))       (WITHOUT-INTERRUPTS(SETQ VERSA-QUEUE      (NCONC VERSA-QUEUE (CONS (LIST FILE BITMAP-COPY-ARRAY WIDTH HEIGHT) ()))))       (COND ((NOT (BOUNDP 'VERSA-PROCESS)) (SETQ VERSA-PROCESS (MAKE-PROCESS "VERSA" :PRIORITY -1))));low priority              (COND ((NULL (SEND VERSA-PROCESS :RUN-REASONS))  (PROCESS-PRESET VERSA-PROCESS 'VERSA-QUEUE-SERVER) (PROCESS-ENABLE VERSA-PROCESS)))       (LENGTH VERSA-QUEUE))      (T (VERSA-WRITE-BIT-FILE FILE BITMAP-ARRAY START-X START-Y WIDTH HEIGHT) NIL)))) (DEFUN versa-queue-server (&aux req)  (do () (nil)    (catch-error-restart ((sys:abort error)  "Restart versa process loop")      (PROCESS-WAIT "Queue Empty" #'(LAMBDA () Versa-Queue))      (without-interrupts (setq req (pop Versa-Queue)))      (versa-write-bit-file (VQ-FILE req) (VQ-ARRAY req) 0 0    (VQ-WIDTH req) (VQ-HEIGHT req)))))(DEFUN versa-write-bit-file (file bitmap-array start-x start-y width height)    (IF (NOT (EQ 'art-1b (array-type bitmap-array)))(FERROR nil "~s is not a bit array." bitmap-array)            (LET ((versa-stream (open file :characters t :direction :output))    (versa-char-array (make-array 1024. :element-type 'string-char  :leader-list '(0) ))    (versa-charcnt 0) (versa-cnt-since-crlf 0))(DECLARE (SPECIAL versa-stream versa-char-array versa-charcnt  versa-cnt-since-crlf))(versa-write-bit-file-1 file bitmap-array start-x start-y width height)(COND ((NOT (ZEROP (array-active-length versa-char-array)))       (versa-flush-string-out)))(close versa-stream))))(DEFUN VERSA-WRITE-BIT-FILE-1 (FILE BITMAP-ARRAY START-X START-Y WIDTH HEIGHT)  (DECLARE (SPECIAL VERSA-CHARCNT))  (LET ((ZERO-COUNT 0)(ONE-COUNT 0))    (FORMAT VERSA-DEBUG-OUT "~%Copying selected window (~D,~D) to ~A - completed    " WIDTH    HEIGHT FILE)    (VERSA-STORE "H" HEIGHT "W" WIDTH)    (LOOP FOR Y FROM START-Y BELOW HEIGHT DO  (LOOP FOR X FROM START-X BELOW WIDTH DO(COND  ((= (AREF BITMAP-ARRAY Y X) 0)   (INCF ZERO-COUNT)   (COND     ((NOT (ZEROP ONE-COUNT))      (VERSA-STORE-COUNT (char-int #\O) ONE-COUNT)      (SETQ ONE-COUNT 0))))  (T (INCF ONE-COUNT)     (COND       ((NOT (ZEROP ZERO-COUNT))(VERSA-STORE-COUNT (char-int #\Z) ZERO-COUNT)(SETQ ZERO-COUNT 0)))))FINALLY(PROGN;do at end of scanline  (COND    ((ZEROP ONE-COUNT)     (IF (= ZERO-COUNT WIDTH) (VERSA-PUSH (char-int #\B)) (VERSA-STORE-COUNT (char-int #\Z) ZERO-COUNT))     (SETQ ZERO-COUNT 0))    (T;one-count is non-zero     (IF (= ONE-COUNT WIDTH) (VERSA-PUSH (char-int #\S)) (VERSA-STORE-COUNT (char-int #\O) ONE-COUNT))     (SETQ ONE-COUNT 0))))(VERSA-PUSH (char-int #\L))))    (FORMAT VERSA-DEBUG-OUT "~%Versa hardcopy done - compression ratio ~D:1"    (truncate (* (- HEIGHT START-Y) (- WIDTH START-X))      VERSA-CHARCNT))))(DEFUN versa-store-count (compr-char count)  (PROGN   (versa-push compr-char)   (IF (> count 1);output the count       (versa-stuffn count))));if needed(DEFUN VERSA-PUSH (SOMETHING)  (DECLARE (SPECIAL VERSA-CHAR-ARRAY VERSA-CHARCNT VERSA-CNT-SINCE-CRLF))  (PROGN    (VECTOR-PUSH SOMETHING VERSA-CHAR-ARRAY)    (COND      ((= (ARRAY-ACTIVE-LENGTH VERSA-CHAR-ARRAY) 1024) (VERSA-FLUSH-STRING-OUT)))    (INCF VERSA-CHARCNT)    (INCF VERSA-CNT-SINCE-CRLF)    (COND      ((> VERSA-CNT-SINCE-CRLF 508) (SETQ VERSA-CNT-SINCE-CRLF 0)       (VECTOR-PUSH (char-int #\NEWLINE) VERSA-CHAR-ARRAY) (INCF VERSA-CHARCNT)       (SETQ VERSA-CNT-SINCE-CRLF 0))))) (DEFUN versa-flush-string-out ()  (DECLARE (SPECIAL versa-stream versa-char-array))  (progn    (SEND versa-stream :string-out versa-char-array)    (STORE-ARRAY-LEADER 0 versa-char-array 0)))(DEFUN versa-store (&rest items)  (MAPCAR (FUNCTION versa-stuff) items))(DEFUN versa-stuffn (num &aux nstr)  (cond ((< num 10.) (versa-push (aref "XX23456789" num)))(T (setq nstr (format nil "~D" num))   (loop for i from 0 below (array-active-length nstr) do (versa-push (aref nstr i))))))(DEFUN versa-stuff (item)  (COND   ((STRINGP item)    (versa-push (character item)))   ((NUMBERP item)    (versa-stuffn item))))(DEFUN VERSA-GET-PATHNAME (&OPTIONAL (ALLOW-ANY T) (PROMPT "Enter pathname")  (DEFAULT (FS:MERGE-PATHNAME-DEFAULTS "a-window.plot")))  (LOOP FOR NEW-PATHNAME =(GET-LINE-FROM-KEYBOARD (FORMAT () "~A~%(Default=~A)" PROMPT DEFAULT)) FOR STATUS =(OR ALLOW-ANY (PROBE-FILE DEFAULT)) DO(SETQ DEFAULT (FS:MERGE-PATHNAME-DEFAULTS NEW-PATHNAME DEFAULT "plot"))(COND  ((NOT STATUS)   (MULTIPLE-VALUE-SETQ (NEW-PATHNAME STATUS)     (FS:COMPLETE-PATHNAME DEFAULT NEW-PATHNAME "plot" ()))   (COND     ((EQ STATUS :OLD) (RETURN (FS:PARSE-PATHNAME NEW-PATHNAME)))     (T (SETQ DEFAULT (FS:MERGE-PATHNAME-DEFAULTS NEW-PATHNAME DEFAULT "plot")))))  (T (RETURN DEFAULT)))(SEND SELECTED-WINDOW :BEEP)))   (UNLESS (AND (CONSP (CDR i)) (CONSP (CDR j)))    (RETURN (co