;;; -*-Package: (PBOX GLOBAL 1000); Base:8.; Mode:lisp-*- ;;; (C) Copyright 1983 Massachusetts Institute of Technology ;;; ;;; Permission to use, copy, modify, distribute, and sell this software ;;; and its documentation for any purpose is hereby granted without fee, ;;; provided that the above copyright notice appear in all copies and that ;;; both that copyright notice and this permission notice appear in ;;; supporting documentation, and that the name of M.I.T. not be used in ;;; advertising or publicity pertaining to distribution of the software ;;; without specific, written prior permission. M.I.T. makes no ;;; representations about the suitability of this software for any ;;; purpose. It is provided "as is" without express or implied warranty. ;;; ;;; serial character printer for boxes. ;;; this code is meant to run in both MacLisp and Zetalisp. ;;; The box printer is divided into several parts. The printer prints ;;; printable-box-objects, which are generated by the preprocessor. The ;;; preprocessor itself is divided into two parts, the reader (which reads box ;;; files and conses up a printable-box-object, assuming no constraints), and ;;; the fitter, sometimes referred to in what follows as Procrustes, which ;;; operates on the printable-box-object and outputs a list of ;;; printable-box-objects, each of which is guaranteed to fit within the width ;;; of a page and be self-consistent. The fitter has a list of tools, some of ;;; which are the exporter and the breaker (not implemented). The printer is ;;; called by the page generator, which outputs individual pages, does ;;; formfeeds, numbers the boxes and pages, etc. ;;; In order to make this run in MacLisp, I define a string datatype, which is a ;;; list whose second member is the symbol STRING, first member a tail-pointer ;;; (for STRING-NCONC) and the rest of which is a series of fixnums representing ;;; the characters in the string. STRING comes second, not first, because it ;;; becomes hard to print empty strings when the tail pointer contains the tail ;;; pointer. The normal MacLisp excuse for strings is not used, because it ;;; would involve a great deal of copying. #M (DEFMACRO STRINGP (STRING) ;;validate the tail pointer somewhat, but don't take too long. `(IF (AND (LISTP ,STRING) (CAR ,STRING) (LISTP (CAR ,STRING)) (CDR ,STRING) (EQ (CADR ,STRING) 'STRING)) T NIL)) #M (DEFUN STRING-LENGTH (STRING) (IF (STRINGP STRING) (LENGTH (CDDR STRING)) (FERROR NIL "The argument to STRING-LENGTH, ~S was not a string." STRING))) #M (DEFUN STRING (OBJECT) (COND ((STRINGP OBJECT) OBJECT) ((SYMBOLP OBJECT) (LEXPR-FUNCALL #'MAKE-STRING (EXPLODEN OBJECT))) ((FIXNUMP OBJECT) (MAKE-STRING OBJECT)) (T (FERROR NIL "The argument to STRING, ~S, cannot be coerced ~ to a string." OBJECT)))) ;;; to be called from code that's already done the type-check #M (DEFMACRO TAIL-POINTER (STRING) `(CAR ,STRING)) #Q (DEFMACRO TAIL-POINTER (STRING) `(STRING-LENGTH ,STRING)) #M (DEFMACRO SET-TAIL-POINTER (STRING LIST) `(SETF (TAIL-POINTER ,STRING) ,LIST)) ;;; return a pointer to the beginning of a string. #M (DEFUN START-POINTER (STRING) (IF (STRINGP STRING) (CDR STRING) (FERROR NIL "The argument to START-POINTER, ~S, was not a string." STRING))) #Q (DEFMACRO START-POINTER (IGNORE) 0) #M (DEFMACRO CHAR-AT-POINTER (POINTER IGNORE) `(CADR ,POINTER)) #Q (DEFMACRO CHAR-AT-POINTER (POINTER STRING) `(AREF ,STRING ,POINTER)) (DEFMACRO GET-CHAR-AND-ADVANCE-POINTER (POINTER STRING) `(PROG1 (CHAR-AT-POINTER ,POINTER ,STRING) (ADVANCE-POINTER ,POINTER))) (DEFUN POINTER-POINTS-TO-END? (POINTER STRING) (IF (STRINGP STRING) (EQ POINTER (TAIL-POINTER STRING)) (FERROR NIL "The second argument to POINTER-POINTS-TO-END?, ~S, was not a string." STRING))) #M (DEFMACRO ADVANCE-POINTER (POINTER) `(SETQ ,POINTER (CDR ,POINTER))) #Q (DEFMACRO ADVANCE-POINTER (POINTER) `(INCF ,POINTER)) #M (DEFUN MAKE-STRING (&REST ELEMENTS) ;; make sure all the elements are fixnums. (DO ((ELEMENTS ELEMENTS (CDR ELEMENTS))) ((NULL ELEMENTS)) (IF (NOT (FIXNUMP (CAR ELEMENTS))) (FERROR NIL "One of the arguments to MAKE-STRING, ~S, was ~ not a fixnum." (CAR ELEMENTS)))) ;; okay to return a REST list in MacLisp. (LET ((NEW-STRING (CONS NIL (CONS 'STRING ELEMENTS)))) ;; calling LAST on elements would break if no elements. (SET-TAIL-POINTER NEW-STRING (LAST NEW-STRING)) NEW-STRING)) #Q (DEFUN MAKE-STRING (&REST ELEMENTS) ;; make sure all the elements are characters (DO ((ELEMENTS ELEMENTS (CDR ELEMENTS))) ((NULL ELEMENTS)) (IF (NOT (FIXNUMP (CAR ELEMENTS))) (FERROR NIL "The object ~S is not a fixnum." (CAR ELEMENTS)))) (LET* ((LENGTH (LENGTH ELEMENTS)) (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING ':LEADER-LIST (LIST LENGTH)))) (FILLARRAY STRING ELEMENTS))) ;FILLARRAY returns STRING #M (DEFUN CHARACTER (STRING) (CHAR-AT-POINTER (START-POINTER STRING) STRING)) #M (DEFUN STRING-EQUAL (STRING1 STRING2) (EQUAL (STRING STRING1) (STRING STRING2))) #M (DEFUN STRING-NCONC (STRING1 STRING2) (COND ((FIXNUMP STRING2) (LET ((NEW-TAIL (NCONS STRING2))) (RPLACD (TAIL-POINTER STRING1) NEW-TAIL) (SET-TAIL-POINTER STRING1 NEW-TAIL))) ((STRINGP STRING2) (RPLACD (TAIL-POINTER STRING1) (CDDR STRING2)) (SET-TAIL-POINTER STRING1 (TAIL-POINTER STRING2))) (T (FERROR NIL "The second argument to STRING-NCONC, ~S, ~ was not a string or a fixnum.")))) ;;; copies top-level elements. #M (DEFUN SUBLIST (LIST START &OPTIONAL END) (DO ((LIST (NTHCDR START LIST) (CDR LIST)) (COUNT START (1+ COUNT)) (NEW-LIST)) ((NULL LIST) (NREVERSE NEW-LIST)) (AND END (IF (= COUNT END) (RETURN (NREVERSE NEW-LIST)))) (PUSH (CAR LIST) NEW-LIST))) #M (DEFUN SUBSTRING (STRING START &OPTIONAL END) (IF (NOT (STRINGP STRING)) (FERROR NIL "The first argument to SUBSTRING, ~S, was not a string.") (LEXPR-FUNCALL #'MAKE-STRING (SUBLIST (CDDR STRING) START END)))) #M (DEFUN TYO-STRING (STRING STREAM) (IF (NOT (STRINGP STRING)) (FERROR NIL "The first argument to TYO-STRING, ~S, was not a string." STRING)) (DO ((STRING (CDDR STRING) (CDR STRING))) ((NULL STRING)) (TYO (CAR STRING) STREAM))) #Q (DEFMACRO TYO-STRING (STRING STREAM) `(PRINC ,STRING ,STREAM)) ;;; The printer. This code prints individual printable-box-objects, which look ;;; like this: (width row-list type height ). ;;; The printer assumes that the parameters for each printable-box-object are ;;; consistent with the contents of the box. So, for example, it will break if ;;; you give it a printable-box-object that has inside it a printable-box-object ;;; that doesn't fit inside it. Height is unnecessary for the printer. (defvar *pbox-system-hacker* nil) ;controls error message printing. (DEFVAR *BOX-UNSELECTABLE-AREA-CHAR* #\SPACE) (DEFVAR *BOX-INPUTS-STRING* (STRING "->")) (DEFVAR *BOX-LEFT-SIDE-CHAR* #/|) (DEFVAR *BOX-RIGHT-SIDE-CHAR* #/|) (DEFVAR *BOX-LEFT-MARGIN-WIDTH* 1) (DEFVAR *BOX-RIGHT-MARGIN-WIDTH* 1) (DEFVAR *BOX-TOP-CHAR* #/-) (DEFVAR *BOX-BOTTOM-CHAR* #/-) (DEFVAR *BOX-LEFT-CORNER-CHAR* #/+) (DEFVAR *BOX-RIGHT-CORNER-CHAR* #/+) (DEFVAR *INTER-BOX-SPACING* 1) ;vertical spacing between boxes (DEFVAR *BOX-IDENTIFIER-WIDTH* 4) ;the number of a box on a page (DEFVAR *PAGE-WIDTH* 80.) ;default if printing to file (DEFVAR *PAGE-HEIGHT* 70.) (DEFVAR *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*)) ;;; the 1- is for the header (DEFVAR *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*))) (DEFVAR *BOX-MINIMUM-WIDTH* 4) ;includes sides (DEFVAR *BOX-MINIMUM-HEIGHT* 3) ;includes top and bottom ;;; these settings give this for +--+ ;;; an empty box: | | ;;; +--+ ;;; BOX-WIDTH returns the width of a box. (DEFMACRO BOX-WIDTH (BOX) `(IF (STRINGP ,BOX) (STRING-LENGTH ,BOX) (CAR ,BOX))) (DEFMACRO SET-BOX-WIDTH (BOX WIDTH) `(SETF (CAR ,BOX) ,WIDTH)) (DEFMACRO BOX-HEIGHT (BOX) `(IF (STRINGP ,BOX) 1 (CADDDR ,BOX))) (DEFMACRO SET-BOX-HEIGHT (BOX HEIGHT) `(SETF (CADDDR ,BOX) ,HEIGHT)) (DEFMACRO BOX-ROW-LIST (BOX) `(CADR ,BOX)) (DEFMACRO SET-BOX-ROW-LIST (BOX NEW-ROW-LIST) `(SETF (BOX-ROW-LIST ,BOX) ,NEW-ROW-LIST)) (DEFMACRO BOX-TYPE (BOX) `(CADDR ,BOX)) (DEFMACRO SET-BOX-TYPE (BOX TYPE) `(SETF (BOX-TYPE ,BOX) ,TYPE)) (DEFMACRO BOX-FIRST-ROW (BOX) `(CAR (BOX-ROW-LIST ,BOX))) (DEFMACRO REMOVE-FIRST-ROW (BOX) `(SET-BOX-ROW-LIST ,BOX (CDR (BOX-ROW-LIST ,BOX)))) (DEFMACRO BOX-HAS-TOP? (BOX) `(AND (NOT (NULL (BOX-ROW-LIST ,BOX))) (EQ (BOX-FIRST-ROW ,BOX) 'TOP))) (DEFMACRO SET-FIRST-BOX-ALREADY-PRINTED (BOXES) `(LET ((BOX (CAR ,BOXES))) (IF (NOT (STRINGP BOX)) (SETF (CDR BOX) NIL) (SETF (CAR ,BOXES) (LIST (BOX-WIDTH BOX)))))) (DEFMACRO ALREADY-PRINTED-BOX? (BOX) `(NULL (CDR ,BOX))) (DEFMACRO BOX-ONLY-BOTTOM-TO-BE-PRINTED? (BOX) `(AND (NULL (BOX-ROW-LIST ,BOX)) (= 1 (BOX-HEIGHT ,BOX)))) (DEFMACRO BOX-ONLY-VSPACE-TO-BE-PRINTED? (BOX) `(AND (NULL (BOX-ROW-LIST ,BOX)) (> (BOX-HEIGHT ,BOX) 1))) (DEFMACRO PRINT-EMPTY-LINE (BOX STREAM) `(PROGN (TYO *BOX-LEFT-SIDE-CHAR* ,STREAM) (TYO-N #\SPACE ,STREAM (- (BOX-WIDTH ,BOX) 2)) (TYO *BOX-RIGHT-SIDE-CHAR* ,STREAM))) (DEFMACRO PRINT-BOX-BOTTOM (BOX STREAM) `(PROGN (TYO *BOX-LEFT-CORNER-CHAR* ,STREAM) (TYO-N *BOX-BOTTOM-CHAR* ,STREAM (- (BOX-WIDTH ,BOX) 2)) (TYO *BOX-RIGHT-CORNER-CHAR* ,STREAM))) (DEFUN PRINT-BOX-TOP (BOX STREAM) (TYO *BOX-LEFT-CORNER-CHAR* STREAM) (TYO-STRING (BOX-TYPE BOX) STREAM) (TYO-N *BOX-TOP-CHAR* STREAM (- (BOX-WIDTH BOX) 2 (STRING-LENGTH (BOX-TYPE BOX)))) (TYO *BOX-RIGHT-CORNER-CHAR* STREAM)) ;;; TYO-N tyos N CHARs to STREAM. (DEFUN TYO-N (CHAR STREAM N) (IF (MINUSP N) (FERROR NIL "The function TYO-N received the negative argument ~S for N. The other arguments were ~S for CHAR and ~S for STREAM." N CHAR STREAM)) (DO ((I N (1- I))) ((ZEROP I)) (TYO CHAR STREAM))) ;;; Call this to print a box at top level. PRINT-BOX-LINE and ;;; PRINT-FIRST-ROW-LINE necessarily print one line at a time, whereas this ;;; function prints an entire box, vertically as well as horizontally. (DEFUN PRINT-TOP-LEVEL-BOX (BOX STREAM) (IF (STRINGP BOX) (PROGN (TYO-STRING BOX STREAM) (TERPRI STREAM)) (IF (OR (NULL BOX) ;can't be nil (NOT (NUMBERP (BOX-WIDTH BOX))) ;has to have a width (NULL (CDR BOX)) ;has to have a list of rows ;;there has to be something in that list (at least 'TOP) (NULL (BOX-ROW-LIST BOX))) (FERROR NIL "The first argument to PRINT-TOP-LEVEL-BOX, ~S, is not a recognizable printable-box-object." BOX)) (DO ((BOX-FINISHED? (PROG1 (PRINT-BOX-LINE BOX STREAM) (TERPRI STREAM)) (PROG1 (PRINT-BOX-LINE BOX STREAM) (TERPRI STREAM)))) (BOX-FINISHED?)))) ;;; PRINT-BOX-LINE returns NIL if it has not yet finished printing a box, else ;;; non-NIL. Prints the first line of a box, including the first lines of any ;;; boxes inside it. Causes inferior boxes to be suitably modified; i.e., ;;; the printed line is removed from each inferior box. (DEFUN PRINT-BOX-LINE (BOX STREAM) (COND ((STRINGP BOX) (TYO-STRING BOX STREAM) T) ((ALREADY-PRINTED-BOX? BOX) (TYO-N *BOX-UNSELECTABLE-AREA-CHAR* STREAM (BOX-WIDTH BOX)) T) ((BOX-ONLY-BOTTOM-TO-BE-PRINTED? BOX) (PRINT-BOX-BOTTOM BOX STREAM) T) (T (IF (BOX-ONLY-VSPACE-TO-BE-PRINTED? BOX) (PRINT-EMPTY-LINE BOX STREAM) (PRINT-FIRST-ROW-LINE BOX STREAM)) ;; after printing a line, take note that there's one less to print, ;; if the box will ever be seen again. (SET-BOX-HEIGHT BOX (1- (BOX-HEIGHT BOX))) NIL))) ;;; PRINT-FIRST-ROW-LINE prints the first line of the first row of a box, and ;;; then replaces all fully printed boxes in it with already-printed-boxes. ;;; Then, if it has fully printed every box in the row, it removes the row from ;;; the box. (DEFUN PRINT-FIRST-ROW-LINE (BOX STREAM) (IF (OR (NULL (CDR BOX)) (NULL (BOX-ROW-LIST BOX))) (FERROR NIL "The printable-box-object ~S, which was the first argument to the function PRINT-FIRST-ROW-LINE, has an unrecognizable first row." BOX)) (IF (BOX-HAS-TOP? BOX) (PROGN (PRINT-BOX-TOP BOX STREAM) (REMOVE-FIRST-ROW BOX)) ;; if we weren't printing a boxtop, print a row. Start with ;; *BOX-LEFT-CHAR* and *BOX-LEFT-MARGIN-WIDTH*. (LET ((CHARS-ALREADY-PRINTED (+ 1 *BOX-LEFT-MARGIN-WIDTH*))) (TYO *BOX-LEFT-SIDE-CHAR* STREAM) (TYO-N #\SPACE STREAM *BOX-LEFT-MARGIN-WIDTH*) (DO ((WIDTH-TO-PRINT (- (BOX-WIDTH BOX) CHARS-ALREADY-PRINTED)) (BOXES (BOX-FIRST-ROW BOX) (CDR BOXES)) (ROW-FINISHED? T) (BOX-FINISHED?) (CURRENT-BOX)) ((NULL BOXES) (TYO-N #\SPACE STREAM (- WIDTH-TO-PRINT *BOX-RIGHT-MARGIN-WIDTH* 1)) (TYO-N #\SPACE STREAM *BOX-RIGHT-MARGIN-WIDTH*) (TYO *BOX-RIGHT-SIDE-CHAR* STREAM) (IF ROW-FINISHED? (REMOVE-FIRST-ROW BOX))) (SETQ CURRENT-BOX (CAR BOXES) WIDTH-TO-PRINT (- WIDTH-TO-PRINT (BOX-WIDTH CURRENT-BOX)) BOX-FINISHED? (PRINT-BOX-LINE CURRENT-BOX STREAM) ROW-FINISHED? (AND ROW-FINISHED? BOX-FINISHED?)) (IF BOX-FINISHED? (SET-FIRST-BOX-ALREADY-PRINTED BOXES)))))) ;;; The preprocessor. The preprocessor is divided into two parts, the reader ;;; (which reads box files and conses up a printable-box-object, assuming no ;;; constraints), and the fitter, sometimes referred to in what follows as ;;; Procrustes, which operates on the printable-box-object and outputs a list ;;; of printable-box-objects, each of which is guaranteed to fit within the ;;; width of a page and be self-consistent. The fitter has a list of tools, ;;; some of which are the exporter and the breaker (not implemented). ;;; The reader. The principal useful function in the reader is READ-BOX-FILE, ;;; which returns a list of self-consistent printable-box-objects. ;;; No delimiter string can be a non-terminal subset of another delimiter ;;; string. This is to avoid reading further than the end of a delimiter, which ;;; we don't want to do so we can call READ on the file whenever we expect that ;;; there will be a READable object next. (DEFCONST *BOX-FILE-START-BOX-STRING* #Q(MAKE-STRING BOXER:*STRT-BOX-CODE*) #M(MAKE-STRING #/[)) (DEFCONST *BOX-FILE-END-BOX-STRING* #Q(MAKE-STRING BOXER:*STOP-BOX-CODE*) #M(MAKE-STRING #/])) (DEFCONST *BOX-FILE-START-ROW-STRING* #Q(MAKE-STRING BOXER:*STRT-ROW-CODE*) #M(MAKE-STRING #/{)) (DEFCONST *BOX-FILE-END-ROW-STRING* #Q(MAKE-STRING BOXER:*STOP-ROW-CODE*) #M(MAKE-STRING #/})) (DEFCONST *BOX-FILE-FONT-SPEC-STRING* #Q(MAKE-STRING #\ROMAN-IV) #M(MAKE-STRING #\RUBOUT #^X)) (DEFCONST *BOX-FILE-QUOTING-STRING* #Q(MAKE-STRING #\EQUIVALENCE) #M(MAKE-STRING #^^)) (DEFCONST *BOX-FILE-INPUTS-STRING* #Q(MAKE-STRING BOXER:*INPUTS-CODE*) #M(MAKE-STRING #^Y)) (DEFCONST *BOX-FILE-LABEL-STRING* #Q(MAKE-STRING BOXER:*LABELLING-CODE*) #M(MAKE-STRING #/:)) (DEFCONST *BOX-FILE-DELIMITERS* (LIST *BOX-FILE-START-BOX-STRING* *BOX-FILE-END-BOX-STRING* *BOX-FILE-START-ROW-STRING* *BOX-FILE-END-ROW-STRING* *BOX-FILE-QUOTING-STRING* *BOX-FILE-FONT-SPEC-STRING* *BOX-FILE-LABEL-STRING* *BOX-FILE-INPUTS-STRING*)) (DEFCONST *BOX-TYPE-PRETTY-NAMES* (LIST (CONS ':DOIT-BOX (STRING "")) ;the calls to STRING are for (CONS ':DATA-BOX (STRING "Data")))) ;the benefit of MacLisp (DEFCONST *THE-EMPTY-STRING* (STRING "")) (DEFMACRO GET-PRETTY-TYPE-NAME (TYPE) `(LET ((PRETTY-NAME (CDR (ASSQ ,TYPE *BOX-TYPE-PRETTY-NAMES*)))) (IF PRETTY-NAME PRETTY-NAME *THE-EMPTY-STRING*))) (DEFMACRO PRINTABLE-BOX-OBJECT-WITHOUT-SIZE (ROWS TYPE) `(LIST NIL ;width (CONS 'TOP ,ROWS) ;row-list (GET-PRETTY-TYPE-NAME ,TYPE) ;type NIL ;height NIL)) ;last-export-pointer ;;; get the thing after THING, jumping two at a time. NIL if not found. (DEFUN GET-NEXT (THING LIST) (COND ((NULL LIST) NIL) ((EQUAL THING (CAR LIST)) (IF (NOT (NULL (CDR LIST))) (CADR LIST) NIL)) (T (GET-NEXT THING (CDDR LIST))))) ;;; GREATEST returns the greatest result of the application of FUNCTION to each ;;; member of LIST. > is used for the comparison. 0 is returned for the empty ;;; list. (DEFUN GREATEST (FUNCTION LIST) (DO ((GREATEST-SO-FAR 0) (LIST LIST (CDR LIST)) (THIS)) ((NULL LIST) GREATEST-SO-FAR) (SETQ THIS (FUNCALL FUNCTION (CAR LIST))) ;no DO* in MacLisp. (IF (> THIS GREATEST-SO-FAR) (SETQ GREATEST-SO-FAR THIS)))) ;;; SUM returns the sum of the results of the application of FUNCTION to LIST. ;;; 0 is returned if the list is empty. PLUS is used for addition. (DEFUN SUM (FUNCTION LIST) (DO ((SUM-SO-FAR 0) (LIST LIST (CDR LIST))) ((NULL LIST) SUM-SO-FAR) (SETQ SUM-SO-FAR (+ SUM-SO-FAR (FUNCALL FUNCTION (CAR LIST)))))) ;;; I hate Maclisp. #M (DEFUN RCHAR (STREAM EOF-OPTION) (LET ((CHAR (TYI STREAM EOF-OPTION))) (IF (= CHAR -1) NIL CHAR))) #Q (DEFMACRO RCHAR (STREAM EOF-OPTION) `(TYI ,STREAM ,EOF-OPTION)) #Q (DEFMACRO RLINE (STREAM) `(READLINE ,STREAM)) #M (DEFMACRO RLINE (STREAM) `(PROG1 (READLINE ,STREAM) (IF (= (TYIPEEK NIL ,STREAM -1) #\LINEFEED) (TYI ,STREAM)))) ;;; Return the character in STRING pointed to by POINTER, or if POINTER points ;;; to the end of STRING, read in a char from STREAM and NCONC it to string, and ;;; return it. If EOF is encountered, simply returns NIL. Does not advance ;;; POINTER. (DEFUN GET-CHAR-STRING-OR-STREAM (STRING POINTER STREAM) ;; if at end of string read a char from stream (IF (POINTER-POINTS-TO-END? POINTER STRING) (LET ((CHAR (RCHAR STREAM NIL))) ;; if at EOF don't try to put at end of string. (IF (NOT (NULL CHAR)) (STRING-NCONC STRING CHAR)) CHAR) ;; otherwise just return the one we're at. (CHAR-AT-POINTER POINTER STRING))) (DEFMACRO GET-CHAR-STRING-OR-STREAM-AP (STRING POINTER STREAM) `(PROG1 (GET-CHAR-STRING-OR-STREAM ,STRING ,POINTER ,STREAM) (ADVANCE-POINTER ,POINTER))) ;;; WITH-OPEN-FILE doesn't exist in MacLisp. #M (DEFMACRO WITH-OPEN-FILE ((STREAM FILE OPTIONS) &BODY BODY) `(LET ((,STREAM NIL)) (UNWIND-PROTECT (PROGN (SETQ ,STREAM (OPEN ,FILE ,OPTIONS)) . ,BODY) (CLOSE ,STREAM)))) ;;; READ-BOX-FILE returns a list of printable box objects, assuming no ;;; constraints on width or height. (DEFUN READ-BOX-FILE (FILE) (WITH-OPEN-FILE (FILE-IN-STREAM FILE 'IN) (READ-BOX-STREAM FILE-IN-STREAM))) (DEFUN READ-BOX-STREAM (FILE-IN-STREAM) (MAPC #'CALCULATE-AND-SET-BOX-SIZE ;set the size parameters of (PARSE-ROW-FROM-STREAM FILE-IN-STREAM)));each box ;;; PARSE-ROW-FROM-STREAM returns a list of printable box objects with NIL in ;;; their size fields and those of all subboxes. Comment lines are ignored. ;;; Returns 'END if there are no more rows in the box. ;;; Note that some boxes returned may be strings. (DEFUN PARSE-ROW-FROM-STREAM (STREAM) (DO ((DELIMITER T) (STRING) (ROW)) ;; null delimiter means eof ((OR (NULL DELIMITER) (STRING-EQUAL DELIMITER *BOX-FILE-END-ROW-STRING*)) (NREVERSE ROW)) ;; returns two values (MULTIPLE-VALUE (DELIMITER STRING) (READ-STRING-UNTIL-DELIMITER-OR-EOF STREAM *BOX-FILE-DELIMITERS*)) (IF (STRING-EQUAL DELIMITER *BOX-FILE-END-BOX-STRING*) (IF (OR (NOT (NULL ROW)) (NOT (STRING-EQUAL STRING DELIMITER))) ;; if we got an end-box, and there was something before it, it's a ;; bug. (FERROR NIL "A box terminator was encountered in the middle ~ of the row ~S. The string being read was ~S." (NREVERSE ROW) STRING) (RETURN 'END))) (LET ((SUBSTRING (SUBSTRING STRING 0 (- (STRING-LENGTH STRING) (IF (NULL DELIMITER) 0 (STRING-LENGTH DELIMITER)))))) ;; if we immediately encountered a delimiter, don't keep the null string (IF (NOT (STRING-EQUAL SUBSTRING *THE-EMPTY-STRING*)) (PUSH SUBSTRING ROW))) (COND ((STRING-EQUAL DELIMITER *BOX-FILE-START-BOX-STRING*) (PUSH (PARSE-BOX-FROM-STREAM STREAM) ROW)) ((STRING-EQUAL DELIMITER *BOX-FILE-QUOTING-STRING*) (PUSH (STRING (TYI STREAM)) ROW)) ((STRING-EQUAL DELIMITER *BOX-FILE-FONT-SPEC-STRING*) (TYI STREAM)) ((string-equal delimiter *box-file-label-string*) (push *box-file-label-string* row)) ((STRING-EQUAL DELIMITER *BOX-FILE-INPUTS-STRING*) (PUSH *BOX-INPUTS-STRING* ROW))))) ;;; PARSE-BOX-FROM-STREAM returns a printable box object read from the stream ;;; STREAM. Call it AFTER consuming the begin-box string. (DEFUN PARSE-BOX-FROM-STREAM (STREAM) (LET ((BOX-DESCRIPTOR (READ STREAM))) (IF (NOT (LISTP BOX-DESCRIPTOR)) (FERROR NIL "The box descriptor ~S is not a list. While reading a box from the stream ~S." BOX-DESCRIPTOR STREAM)) (DO ((TYPE (GET-NEXT ':TYPE BOX-DESCRIPTOR)) (ROW (PARSE-ROW-FROM-STREAM STREAM) (PARSE-ROW-FROM-STREAM STREAM)) (ROW-LIST)) ((EQ ROW 'END) (PRINTABLE-BOX-OBJECT-WITHOUT-SIZE (NREVERSE ROW-LIST) TYPE)) (PUSH ROW ROW-LIST)))) ;;; Read a string until encountering a delimiter string, and MVR the delimiter ;;; string and the string. (DEFUN READ-STRING-UNTIL-DELIMITER-OR-EOF (STREAM DELIMITER-LIST) (LET* ((STRING (MAKE-STRING)) (POINTER (START-POINTER STRING))) (DO ((CHAR (GET-CHAR-STRING-OR-STREAM STRING POINTER STREAM) (GET-CHAR-STRING-OR-STREAM STRING POINTER STREAM))) ((NULL CHAR) (VALUES NIL STRING)) (LET ((MATCH? (MATCH-ANY STRING POINTER STREAM DELIMITER-LIST))) (IF MATCH? (RETURN (VALUES MATCH? STRING)) (ADVANCE-POINTER POINTER)))))) ;;; try to match one of the strings in DELIMITER-LIST with the string and stream ;;; starting at POINTER. Return NIL if lose, delimiter if won. (DEFUN MATCH-ANY (STRING POINTER STREAM DELIMITER-LIST) (IF (NULL DELIMITER-LIST) NIL (LET* ((SELF (CAR DELIMITER-LIST)) (SELF-POINTER (START-POINTER SELF)) (CHAR-POINTER POINTER)) (DO ((CHAR (GET-CHAR-STRING-OR-STREAM-AP STRING CHAR-POINTER STREAM) (GET-CHAR-STRING-OR-STREAM-AP STRING CHAR-POINTER STREAM))) (NIL) ;;this will catch eof as well. (IF (EQ (GET-CHAR-AND-ADVANCE-POINTER SELF-POINTER SELF) CHAR) (IF (POINTER-POINTS-TO-END? SELF-POINTER SELF) (RETURN SELF)) (RETURN (MATCH-ANY STRING POINTER STREAM (CDR DELIMITER-LIST)))))))) (DEFMACRO MAYBE-BOX? (BOX) `(OR (STRINGP ,BOX) ;a maybe-box is a string (AND (LISTP ,BOX) ;or, more likely, a list (>= (LENGTH ,BOX) 4) ;with at least 4 elements (LISTP (CADR ,BOX)) ;row-list has to be a list (STRINGP (CADDR ,BOX))))) ;type has to be a string ;;; CALCULATE-AND-SET-BOX-SIZE actually calculates and changes all the WIDTH ;;; and HEIGHT fields in the box and all its subboxes. (DEFUN CALCULATE-AND-SET-BOX-SIZE (BOX) ;; validate the type somewhat. (IF (NOT (MAYBE-BOX? BOX)) (FERROR NIL "The object ~S is not a recognizable box." BOX)) (CALCULATE-AND-SET-BOX-WIDTH BOX) (CALCULATE-AND-SET-BOX-HEIGHT BOX)) ;;; Sets and returns BOX-WIDTH for this box and all subboxes. Does no type ;;; check on BOX. (DEFUN CALCULATE-AND-SET-BOX-WIDTH (BOX) (IF (STRINGP BOX) (STRING-LENGTH BOX) ;don't set a string's width (LET ((BOX-WIDTH ;;the width of a box is the greatest of (MAX ;; the sum of the widths of its sides, margins, and widest row, (+ *BOX-RIGHT-MARGIN-WIDTH* *BOX-LEFT-MARGIN-WIDTH* 2 (IF (NOT (BOX-HAS-TOP? BOX)) (FERROR NIL "~ The printable-box-object ~S, which was the first argument to CALCULATE-AND-SET-BOX-WIDTH, has no top." BOX) (GREATEST #'SET-AND-GET-ROW-WIDTH ;; don't consider the boxtop. (CDR (BOX-ROW-LIST BOX))))) ;; the sum of the widths of its label and sides (+ (STRING-LENGTH (BOX-TYPE BOX)) 2) ;; and the minumum box width. *BOX-MINIMUM-WIDTH*))) (SET-BOX-WIDTH BOX BOX-WIDTH) BOX-WIDTH))) ;;; Set the width of each box in the row ROW (and all subboxes) and return the ;;; sum of their widths. (DEFUN SET-AND-GET-ROW-WIDTH (ROW) ;; width of empty row being 0 follows from definition of SUM (SUM #'CALCULATE-AND-SET-BOX-WIDTH ROW)) ;;; Sets and returns BOX-HEIGHT for this box and all subboxes. Does no type ;;; check on BOX. (DEFUN CALCULATE-AND-SET-BOX-HEIGHT (BOX) (IF (STRINGP BOX) 1 ;don't set a string's height (LET ((BOX-HEIGHT (MAX *BOX-MINIMUM-HEIGHT* (+ (IF (NOT (BOX-HAS-TOP? BOX)) (FERROR NIL "~ The printable-box-object ~S, which was the first argument to CALCULATE-AND-SET-BOX-HEIGHT, has no top." BOX) (SUM #'SET-AND-GET-ROW-HEIGHT ;; don't consider the boxtop. (CDR (BOX-ROW-LIST BOX)))) 2)))) (SET-BOX-HEIGHT BOX BOX-HEIGHT) BOX-HEIGHT))) ;;; Set the height of each box in ROW (and all subboxes) and return the ;;; greatest of their heights. (DEFUN SET-AND-GET-ROW-HEIGHT (ROW) (IF (EQ ROW NIL) 1 ;the empty row is 1 tall. (GREATEST #'CALCULATE-AND-SET-BOX-HEIGHT ROW))) ;;; The fitter, or Procrustes. ;;; The fitter has a list of functions to call on a box which is too large to ;;; be printed. It calls them sequentially until one works. Each fitting ;;; function is expected to accept a list whose first member is the ;;; printable-box-object to be fitted; the rest is the rest of the boxes to be ;;; printed. This is so the exporter can put the boxes it exports somewhere ;;; (like immediately after the box it exports them from). Each fitting ;;; function is also expected to accept as second and third arguments the ;;; maximum width and height of a box. If a fitting function decides that it ;;; cannot cure the problem, it returns NIL. All fitting functions work by ;;; mutating the list they have been handed. (DEFVAR *BOX-FITTING-FUNCTIONS* NIL) ;;; returns the box-list, suitably modified. (DEFUN FIT (BOX-LIST &OPTIONAL (FITTERS *BOX-FITTING-FUNCTIONS*)) (DO ((BOXES BOX-LIST (CDR BOXES)) (BOX)) ((NULL BOXES) BOX-LIST) (SETQ BOX (CAR BOXES)) (IF (OR (> (BOX-WIDTH BOX) *BOX-MAXIMUM-WIDTH*) (> (BOX-HEIGHT BOX) *BOX-MAXIMUM-HEIGHT*)) (DO ((FITTING-FUNCTIONS FITTERS (CDR FITTING-FUNCTIONS))) ((NULL FITTING-FUNCTIONS) (NOTIFY-USER-ABOUT-BOX-FITTING-LOSSAGE box)) (IF (FUNCALL (CAR FITTING-FUNCTIONS) BOXES *BOX-MAXIMUM-WIDTH* *BOX-MAXIMUM-HEIGHT*) (RETURN NIL)))))) (DEFUN NOTIFY-USER-ABOUT-BOX-FITTING-LOSSAGE (BOX) (IF (NULL *PBOX-SYSTEM-HACKER*) (FORMAT T "~%A box of width ~D and height ~D is too big to fit on the page." (BOX-WIDTH BOX) (box-height box)) (LET ((PRINLEVEL 3) (PRINLENGTH 3)) (FORMAT T "The printable-box-object ~S, with width ~D and height ~D, cannot be mutated to fit within the width (~D) and height (~D) of the page." BOX (BOX-WIDTH BOX) (BOX-HEIGHT BOX) *BOX-MAXIMUM-WIDTH* *BOX-MAXIMUM-HEIGHT*) (IF (NOT (Y-OR-N-P (FORMAT NIL "~%Continue anyway? "))) (BREAK "-- you lose"))))) ;;; The exporter is the only fitting function implemented so far. The exporter ;;; grovels over the first box in the box-list it is handed, first adjusting ;;; its width to fit, then adjusting its height. Because these are done ;;; sequentially, the resulting configuration may actually be less wide than it ;;; has to be; that is, if a box is exported because it is too tall, it may ;;; happen that it is also on the widest row, so it may make the box thinner ;;; than need be. A second pass should cure this. ;;; If this is a box, the exporter should only copy this object, never use it! (DEFVAR *EXPORT-BOX-MODEL* (STRING "|pg 00,#00|")) (DEFVAR *DO-EXPORTS-FOR-WIDTH* T) (DEFVAR *DO-EXPORTS-FOR-HEIGHT* T) (DEFVAR *BOX-MINIMUM-EXPORT-HEIGHT* 4) (DEFMACRO EXPORT-PART (BOX) `(NTHCDR 5 ,BOX)) ;;; Every printable-box-object has a part, the last-export-pointer, which ;;; comes after the height. Looks like: ;;; (WIDTH ROW-LIST TYPE HEIGHT LAST-EXPORT-POINTER . EXPORT-PART) ;;; While the export part is a backpointer from a box that has been exported to ;;; the place from which it was exported, the last-export-pointer is a pointer ;;; from a top-level box from which something has been exported to where the ;;; next thing should be exported to. It is meant to aid in the ordering of ;;; export boxes. If it is null, the next export should go immediately after ;;; this box; otherwise it's a pointer to the list that the last exported box ;;; started and the next export box should go after that box, and the ;;; last-export-pointer should be updated. Since exports all happen in one ;;; pass, the result will be okay, even though the last-export-pointer of a box ;;; will no longer be good after things have been exported from one of its ;;; exports. (DEFMACRO LAST-EXPORT-POINTER (BOX) `(CAR (CDDDDR ,BOX))) (DEFMACRO SET-LAST-EXPORT-POINTER (BOX THING) `(SETF (LAST-EXPORT-POINTER ,BOX) ,THING)) (DEFUN EXPORT-SUBBOXES-IF-NECESSARY (BOX-LIST MAX-WIDTH MAX-HEIGHT) (IF (NULL BOX-LIST) (FERROR NIL "The function EXPORT-SUBBOXES-IF-NECESSARY was given an empty box-list.")) (LET ((BOX (CAR BOX-LIST))) ;; if the maximum width is less than the box-top width, can't fix. (IF (< MAX-WIDTH (+ 2 (STRING-LENGTH (BOX-TYPE BOX)))) NIL (AND (IF (> (BOX-WIDTH BOX) MAX-WIDTH) ;; this'll return NIL if it tries and loses (IF (NOT *DO-EXPORTS-FOR-WIDTH*) T (EXPORT-FOR-WIDTH BOX-LIST MAX-WIDTH)) ;;T if there's no problem, because then it's solved. T) (IF (> (BOX-HEIGHT BOX) MAX-HEIGHT) ;; this'll return NIL if it tries and loses (IF (NOT *DO-EXPORTS-FOR-HEIGHT*) T (EXPORT-FOR-HEIGHT BOX-LIST MAX-HEIGHT)) T))))) (PUSH #'EXPORT-SUBBOXES-IF-NECESSARY *BOX-FITTING-FUNCTIONS*) (DEFMACRO EXPORTABLE? (BOX) `(AND (NOT (STRINGP ,BOX)) (>= (BOX-HEIGHT ,BOX) *BOX-MINIMUM-EXPORT-HEIGHT*))) ;;; EXPORT-FOR-WIDTH attempts to export from the widest row the smallest single ;;; box that will cure the problem. If no single box can be exported to cure ;;; the problem, the widest box on the row will be removed and the exporter ;;; will be called again. [Note: in the plural case, this won't really find ;;; the best combination; it's just simple. That is, there may be a pair of ;;; boxes that exactly cure the problem that don't include the largest box.] (DEFUN EXPORT-FOR-WIDTH (BOX-LIST MAX-WIDTH) (LET* ((BOX (CAR BOX-LIST)) (WIDTH-OVER-MAXIMUM (- (BOX-WIDTH BOX) MAX-WIDTH)) (EXPORTABLE-WIDTH (+ (BOX-WIDTH *EXPORT-BOX-MODEL*) WIDTH-OVER-MAXIMUM))) (IF (<= WIDTH-OVER-MAXIMUM 0) T (LET ((BEST-BOX-LIST (BOX-WITH-WIDTH-CLOSEST-TO EXPORTABLE-WIDTH (WIDEST-ROW-NOT-TOP BOX)))) (IF BEST-BOX-LIST (LET ((BEST-WIDTH (BOX-WIDTH (CAR BEST-BOX-LIST)))) (IF (>= BEST-WIDTH (BOX-WIDTH *EXPORT-BOX-MODEL*)) (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST) (CALCULATE-AND-SET-BOX-SIZE BOX) (EXPORT-FOR-WIDTH BOX-LIST MAX-WIDTH)) NIL))))))) ;;; recursively walk the subboxes of a box and find the box with width closest ;;; to, but greater than or equal to, the width given, or if there are none ;;; greater than or equal to, the widest. Strings are never considered. NIL ;;; if no subboxes. Returns the list that the box starts. (DEFUN BOX-WITH-WIDTH-CLOSEST-TO (WIDTH BOX-LIST) (DO ((BOX-LIST BOX-LIST (CDR BOX-LIST)) (CURRENT-WIDTH) (BEST-WIDTH 0) (BEST-BOX-LIST)) ((NULL BOX-LIST) BEST-BOX-LIST) (IF (EXPORTABLE? (CAR BOX-LIST)) (PROGN (SETQ CURRENT-WIDTH (BOX-WIDTH (CAR BOX-LIST))) ;; if the current box is better than the best so far (IF (SORT-OF-CLOSER? CURRENT-WIDTH BEST-WIDTH WIDTH) ;; make it the best box (SETQ BEST-WIDTH CURRENT-WIDTH BEST-BOX-LIST BOX-LIST)) (LET ((BEST-SUBBOX-LIST (BOX-WITH-WIDTH-CLOSEST-TO WIDTH (WIDEST-ROW-NOT-TOP (CAR BOX-LIST))))) ;; if there is a best subbox (AND BEST-SUBBOX-LIST ;;and it's better than the best so far (IF (SORT-OF-CLOSER? (BOX-WIDTH (CAR BEST-SUBBOX-LIST)) BEST-WIDTH WIDTH) ;; then it's the best box (SETQ BEST-BOX-LIST BEST-SUBBOX-LIST BEST-WIDTH (BOX-WIDTH (CAR BEST-SUBBOX-LIST)))))))))) ;;; if CURRENT-QUANTITY is closer to QUANTITY than BEST-QUANTITY is, return t, ;;; else nil; but use a strange definition for closer. If both ;;; CURRENT-QUANTITY and BEST-QUANTITY are smaller or greater than QUANTITY, ;;; then the one actually closer is correct; but if one is over and one under, ;;; the one over is preferred. (DEFUN SORT-OF-CLOSER? (CURRENT-QUANTITY BEST-QUANTITY QUANTITY) (IF (>= BEST-QUANTITY QUANTITY) ;; if best-quantity over the desired, then current-quantity ;; has to be between it and desired to be better. (>= BEST-QUANTITY CURRENT-QUANTITY QUANTITY) ;; if best-quantity less than desired, current-quantity need ;; only be bigger to be better. (> CURRENT-QUANTITY BEST-QUANTITY))) ;;; returns NIL if no rows beside top (DEFUN WIDEST-ROW-NOT-TOP (BOX) (LET ((ROW-LIST (IF (BOX-HAS-TOP? BOX) (CDR (BOX-ROW-LIST BOX)) (BOX-ROW-LIST BOX)))) (DO ((ROW-LIST ROW-LIST (CDR ROW-LIST)) (CURRENT-ROW) (CURRENT-WIDTH) (WIDEST-ROW) (WIDEST-WIDTH 0)) ((NULL ROW-LIST) WIDEST-ROW) (SETQ CURRENT-ROW (CAR ROW-LIST) CURRENT-WIDTH (ROW-WIDTH CURRENT-ROW)) (IF (> CURRENT-WIDTH WIDEST-WIDTH) (SETQ WIDEST-ROW CURRENT-ROW WIDEST-WIDTH CURRENT-WIDTH))))) (DEFUN ROW-WIDTH (ROW) (IF (NOT (OR (LISTP ROW) (NULL ROW))) (FERROR NIL "The function ROW-WIDTH was given the value ~S, which should have been a list, for ROW." ROW)) (DO ((WIDTH 0 (+ WIDTH (BOX-WIDTH (CAR BOX-LIST)))) (BOX-LIST ROW (CDR BOX-LIST))) ((NULL BOX-LIST) WIDTH))) #M (DEFUN COPYTREE (TREE) (IF (OR (STRINGP TREE) ;for MacLisp "strings" (NOT (LISTP TREE))) TREE (MAPCAR #'COPYTREE TREE))) ;;;; symbol conflict ;(EVAL-WHEN (LOAD COMPILE) ; (SHADOW 'EXPORT) ; ) ;; this didn't work, I'm just going to change the name of the ; ;; function ;;; actually replace the given box with an export box, add a pointer from the ;;; export box to the pointer, put the export box in the right place, and reset ;;; the last-export-pointer of the box. (DEFUN EXPORT-IT (LIST-THAT-BOX-STARTS BOX-LIST) (LET ((BOX (CAR LIST-THAT-BOX-STARTS))) ;; remember that before printing this PAGIFY-BOX-LIST must be run on the ;; list to replace the model with the real thing. (SETF (CAR LIST-THAT-BOX-STARTS) *EXPORT-BOX-MODEL*) ;;; if the box has no last-export-pointer yet, give it one. (IF (NULL (LAST-EXPORT-POINTER BOX)) (SET-LAST-EXPORT-POINTER BOX BOX-LIST)) ;; the exported box goes in the cdr of the last-export-pointer, i.e., after ;; the last box expoted from this box. (LET ((NEW-EXPORT-POINTER (CONS BOX (CDR (LAST-EXPORT-POINTER BOX))))) (SETF (CDR (LAST-EXPORT-POINTER BOX)) NEW-EXPORT-POINTER) ;; then the last-export-pointer gets reset to point to the new last box ;; exported. (SET-LAST-EXPORT-POINTER BOX NEW-EXPORT-POINTER)) ;; finally, set the back-pointer from the exported box to the export ;; pointer. (SETF (EXPORT-PART BOX) LIST-THAT-BOX-STARTS))) (DEFUN EXPORT-FOR-HEIGHT (BOX-LIST MAX-HEIGHT) (LET* ((BOX (CAR BOX-LIST)) (HEIGHT-OVER-MAXIMUM (- (BOX-HEIGHT BOX) MAX-HEIGHT))) (IF (<= HEIGHT-OVER-MAXIMUM 0) T (MULTIPLE-VALUE-BIND (BEST-BOX-LIST BEST-SAVING) (BOX-WITH-HEIGHT-SAVING-CLOSEST-TO HEIGHT-OVER-MAXIMUM (CDR (BOX-ROW-LIST BOX))) (IF BEST-BOX-LIST (IF (>= BEST-SAVING HEIGHT-OVER-MAXIMUM) (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST) (CALCULATE-AND-SET-BOX-SIZE BOX)) (IF (> (BOX-HEIGHT (CAR BEST-BOX-LIST)) (BOX-HEIGHT *EXPORT-BOX-MODEL*)) (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST) (CALCULATE-AND-SET-BOX-SIZE BOX) (EXPORT-FOR-HEIGHT BOX-LIST MAX-HEIGHT))))))))) ;;; recursively determine the box or subbox in this row-list whose exportation ;;; would result in a reduction in height (of the box) closest to the quantity ;;; HEIGHT. MVRs the list the box starts and amount saved or NIL if none. (DEFUN BOX-WITH-HEIGHT-SAVING-CLOSEST-TO (HEIGHT ROW-LIST) (DO ((ROW-LIST ROW-LIST (CDR ROW-LIST)) (CURRENT-SAVING) (CURRENT-SUBLIST) (BEST-SAVING 0) (BEST-SUBLIST)) ((NULL ROW-LIST) (VALUES BEST-SUBLIST BEST-SAVING)) (MULTIPLE-VALUE (CURRENT-SUBLIST CURRENT-SAVING) (HEIGHT-SAVING-BOX (CAR ROW-LIST))) (IF CURRENT-SUBLIST (PROGN (IF (SORT-OF-CLOSER? CURRENT-SAVING BEST-SAVING HEIGHT) (SETQ BEST-SAVING CURRENT-SAVING BEST-SUBLIST CURRENT-SUBLIST)) (MULTIPLE-VALUE-BIND (BEST-SUBBOX-SUBLIST BEST-SUBBOX-SAVING) (BOX-WITH-HEIGHT-SAVING-CLOSEST-TO HEIGHT (CDR (BOX-ROW-LIST (CAR CURRENT-SUBLIST)))) (AND BEST-SUBBOX-SUBLIST (IF (SORT-OF-CLOSER? BEST-SUBBOX-SAVING BEST-SAVING HEIGHT) (SETQ BEST-SAVING BEST-SUBBOX-SAVING BEST-SUBLIST BEST-SUBBOX-SUBLIST)))))))) ;;; find the box whose removal would decrease this row's height and return the ;;; list it starts and the amount that would be saved. (DEFUN HEIGHT-SAVING-BOX (ROW) (DO ((BOX-LIST ROW (CDR BOX-LIST)) (TALLEST-SUBLIST) (TALLEST-HEIGHT 0) (NEXT-TALLEST-SUBLIST) (NEXT-TALLEST-HEIGHT 0) (CURRENT-HEIGHT)) ((NULL BOX-LIST) ;; only one box ever decreases the height of a row, so check here. (IF (AND TALLEST-SUBLIST (EXPORTABLE? (CAR TALLEST-SUBLIST))) (VALUES TALLEST-SUBLIST (- TALLEST-HEIGHT NEXT-TALLEST-HEIGHT)) NIL)) (SETQ CURRENT-HEIGHT (BOX-HEIGHT (CAR BOX-LIST))) (IF (> CURRENT-HEIGHT TALLEST-HEIGHT) (PSETQ TALLEST-SUBLIST BOX-LIST TALLEST-HEIGHT CURRENT-HEIGHT NEXT-TALLEST-SUBLIST TALLEST-SUBLIST NEXT-TALLEST-HEIGHT TALLEST-HEIGHT) (IF (> CURRENT-HEIGHT NEXT-TALLEST-HEIGHT) (SETQ NEXT-TALLEST-SUBLIST BOX-LIST NEXT-TALLEST-HEIGHT CURRENT-HEIGHT))))) ;;; The page generator. #M (DEFVAR STANDARD-OUTPUT T) (DEFCONST *PAGE-END-STRING* (STRING #Q (FORMAT NIL "~|") #M #^L)) ;;; print a box list to a stream. If no stream, standard-output. (DEFUN PRINT-BOX-LIST (BOX-LIST WHERE) (DO ((BOX-LIST BOX-LIST (CDR BOX-LIST)) (BOX-NUMBER 1)) ((NULL BOX-LIST)) (IF (STRINGP (CAR BOX-LIST)) (PROGN (TYO-STRING (CAR BOX-LIST) WHERE) (TERPRI WHERE) (IF (STRING-EQUAL (CAR BOX-LIST) *PAGE-END-STRING*) (SETQ BOX-NUMBER 1))) (DO ((BOX-FINISHED? ;; print the box number, with a ". " after, enough padding ;; before to have a total of *BOX-INDENTIFIER-WIDTH* ;; characters. (PROG2 (TYO-STRING (STRING (FORMAT NIL "~VD. " (- *BOX-IDENTIFIER-WIDTH* 2) BOX-NUMBER)) WHERE) ;; and a line of the box (PRINT-BOX-LINE (CAR BOX-LIST) WHERE) ;; then a CR (TERPRI WHERE)) (PROG2 (TYO-N #\SPACE WHERE *BOX-IDENTIFIER-WIDTH*) (PRINT-BOX-LINE (CAR BOX-LIST) WHERE) (TERPRI WHERE)))) (BOX-FINISHED?)) (SETQ BOX-NUMBER (1+ BOX-NUMBER))))) ;;; keeps the first cons the same. (DEFUN PUSH+ (THING CONS) (IF (OR (NOT (LISTP CONS)) (NULL CONS)) (FERROR NIL "The function PUSH+ was given a second argument of ~S, which was of the wrong type. The function expected a cons." CONS)) (LET ((NEWCDR (NCONS (CAR CONS)))) (RPLACD NEWCDR (CDR CONS)) (RPLACA CONS THING) (RPLACD CONS NEWCDR))) ;;; Being for the benefit of Mr. Maclisp FORMAT. #M (DEFUN UNSTRINGIFY (STRING) (IF (NOT (STRINGP STRING)) (FERROR NIL "The argument to UNSTRINGIFY, ~S,~ was not a string." STRING) (IMPLODE (CDDR STRING)))) (DEFUN PAGIFY-BOX-LIST (BOX-LIST PAGE-WIDTH PAGE-HEIGHT LEFT-HEADER RIGHT-HEADER) ;; make sure both left and right headers are same length so FORMAT wins (COND ((> (STRING-LENGTH LEFT-HEADER) (STRING-LENGTH RIGHT-HEADER)) (SETQ RIGHT-HEADER (STRING (FORMAT NIL "~VX~A" (- (STRING-LENGTH LEFT-HEADER) (STRING-LENGTH RIGHT-HEADER)) #M (UNSTRINGIFY RIGHT-HEADER) #Q RIGHT-HEADER)))) ((> (STRING-LENGTH RIGHT-HEADER) (STRING-LENGTH LEFT-HEADER)) (SETQ LEFT-HEADER (STRING (FORMAT NIL "~A~VX" #M (UNSTRINGIFY LEFT-HEADER) #Q LEFT-HEADER (- (STRING-LENGTH RIGHT-HEADER) (STRING-LENGTH LEFT-HEADER))))))) (DO ((BOXES BOX-LIST) (PAGE 1 (1+ PAGE))) ((NULL BOXES) BOX-LIST) ;; insert the header and an empty line (PUSH+ (STRING (FORMAT NIL "~V<~A~;-~D-~;~A~>" PAGE-WIDTH #M (UNSTRINGIFY LEFT-HEADER) #Q LEFT-HEADER PAGE #M (UNSTRINGIFY RIGHT-HEADER) #Q RIGHT-HEADER)) BOXES) ;; now cdr down the list of boxes until no more will fit on the page, ;; inserting vertical spacing between them. (DO ((SPACING *THE-EMPTY-STRING*) (BOX) (LINES-LEFT (1- PAGE-HEIGHT) (- LINES-LEFT (+ *INTER-BOX-SPACING* (BOX-HEIGHT BOX)))) (BOX-NUMBER 1 (1+ BOX-NUMBER)) (BOXES-MAYBE-ON-THIS-PAGE (CDR BOXES) (CDR BOXES-MAYBE-ON-THIS-PAGE))) ((OR (NULL BOXES-MAYBE-ON-THIS-PAGE) (> (+ *INTER-BOX-SPACING* (BOX-HEIGHT (CAR BOXES-MAYBE-ON-THIS-PAGE))) LINES-LEFT)) (SETQ BOXES BOXES-MAYBE-ON-THIS-PAGE)) (SETQ BOX (CAR BOXES-MAYBE-ON-THIS-PAGE)) ;; insert the spacing (DO ((I *INTER-BOX-SPACING* (1- I))) ((ZEROP I)) (PUSH+ SPACING BOXES-MAYBE-ON-THIS-PAGE)) ;; jump over it (SETQ BOXES-MAYBE-ON-THIS-PAGE (NTHCDR *INTER-BOX-SPACING* BOXES-MAYBE-ON-THIS-PAGE)) ;; update the export pointer (if there) to point to this box's location. (IF (AND (NOT (STRINGP BOX)) (EXPORTED? BOX)) (MAKE-EXPORT-POINTER-POINT-TO-BOX BOX PAGE BOX-NUMBER))) ;; now insert a page-break unless at end of the list (and thus file) (IF BOXES (PROGN (PUSH+ *PAGE-END-STRING* BOXES) (SETQ BOXES (CDR BOXES)))))) (DEFUN USERNAME-STRING () (STRING #Q FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST #M (STATUS UNAME))) (DEFUN FILENAME-STRING (STRING) (STRING (WITH-OPEN-FILE (PATHNAME STRING) #M(NAMESTRING (TRUENAME PATHNAME)) #Q(FUNCALL (FUNCALL PATHNAME ':TRUENAME) ':STRING-FOR-PRINTING)))) (DEFUN PRINT-BOXES-FROM-FILE (FROM-FILE &OPTIONAL TO-FILE) (WITH-OPEN-FILE (FROM-STREAM FROM-FILE '(IN ASCII)) (READLINE FROM-STREAM) ;flush the comment (COND ((NOT (NULL TO-FILE)) (WITH-OPEN-FILE (TO-STREAM TO-FILE '(OUT ASCII)) (PRINT-BOXES-FROM-STREAM-TO-STREAM FROM-STREAM TO-STREAM *PAGE-WIDTH* *PAGE-HEIGHT* (USERNAME-STRING) (FILENAME-STRING FROM-FILE)))) (T (PRINT-BOXES-FROM-STREAM-TO-STREAM FROM-STREAM STANDARD-OUTPUT *PAGE-WIDTH* *PAGE-HEIGHT* (USERNAME-STRING) (FILENAME-STRING FROM-FILE)))))) (DEFUN PRINT-BOXES-FROM-STREAM-TO-STREAM (FROM-STREAM TO-STREAM PAGE-WIDTH PAGE-HEIGHT UNAME FILENAME) (PRINT-BOX-LIST (PAGIFY-BOX-LIST (FIT (READ-BOX-STREAM FROM-STREAM)) PAGE-WIDTH PAGE-HEIGHT UNAME FILENAME) TO-STREAM)) (DEFUN HARDCOPY-BOXER-FILE (PATHNAME) (WITH-OPEN-FILE (STREAM PATHNAME ':READ) (SI:HARDCOPY-FROM-STREAM STREAM SI:*DEFAULT-HARDCOPY-DEVICE* ':PAGE-HEADINGS NIL))) #Q (DEFUN HARDCOPY-BOX (BOX) (LET ((TEMP-PATHNAME-1 (SEND (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME "PBOX" ':TYPE "TEMP1")) (TEMP-PATHNAME-2 (SEND (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME "PBOX" ':TYPE "TEMP2"))) (BOXER:OLD-WRITE-BOX-INTO-FILE BOX TEMP-PATHNAME-1) (PRINT-BOXES-FROM-FILE TEMP-PATHNAME-1 TEMP-PATHNAME-2) (HARDCOPY-BOXER-FILE TEMP-PATHNAME-2) (FS:DELETEF TEMP-PATHNAME-1) (FS:DELETEF TEMP-PATHNAME-2) )) (DEFUN EXPORTED? (BOX) (IF (OR (STRINGP BOX) (NOT (MAYBE-BOX? BOX))) (FERROR NIL "The function EXPORTED? received as argument the object ~S, ~ which is~% not a box." BOX)) (EXPORT-PART BOX)) (DEFUN MAKE-EXPORT-POINTER-POINT-TO-BOX (BOX PAGE BOX-NUMBER) (SETF (CAR (EXPORT-PART BOX)) (STRING (FORMAT NIL "|pg ~2D,#~2D|" PAGE BOX-NUMBER)))) ;;; Call this to idiot-proofly set the dimensions of the page or boxes. (DEFUN SET-PRINTER-DIMENSIONS (PAGE-WIDTH &OPTIONAL PAGE-HEIGHT BOX-MAX-WIDTH BOX-MAX-HEIGHT) ;; first set the width idiot-proofly. (COND ((AND (NULL PAGE-WIDTH) (NULL BOX-MAX-WIDTH)) ;neither width given (SETQ *PAGE-WIDTH* 100.) (SETQ *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*))) ((NULL BOX-MAX-WIDTH) ;only page width given (SETQ *PAGE-WIDTH* PAGE-WIDTH) (SETQ *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*))) ((NULL PAGE-WIDTH) ;only box width given (SETQ *BOX-MAXIMUM-WIDTH* BOX-MAX-WIDTH) (SETQ *PAGE-WIDTH* (+ *BOX-IDENTIFIER-WIDTH* *BOX-MAXIMUM-WIDTH*))) (T (IF (> BOX-MAX-WIDTH ;both given - check consistency (- PAGE-WIDTH *BOX-IDENTIFIER-WIDTH*)) (FERROR NIL "~ The values you have given for page width, ~D, and maximum box width, ~D, are inconsistent with each other. The maximum box width must be at least ~D less than the page width." PAGE-WIDTH BOX-MAX-WIDTH *BOX-IDENTIFIER-WIDTH*) (SETQ *PAGE-WIDTH* PAGE-WIDTH *BOX-MAXIMUM-WIDTH* BOX-MAX-WIDTH)))) (COND ((AND (NULL PAGE-HEIGHT) (NULL BOX-MAX-HEIGHT)) ;neither height given (SETQ *PAGE-HEIGHT* 70.) (SETQ *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*)))) ((NULL BOX-MAX-HEIGHT) ;only page height given (SETQ *PAGE-HEIGHT* PAGE-HEIGHT) (SETQ *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*)))) ((NULL PAGE-HEIGHT) ;only box height given (SETQ *BOX-MAXIMUM-HEIGHT* BOX-MAX-HEIGHT) (SETQ *PAGE-HEIGHT* (+ 1 *INTER-BOX-SPACING* *BOX-MAXIMUM-HEIGHT*))) (T (IF (> BOX-MAX-HEIGHT ;both given - check consistency (1- (- PAGE-HEIGHT *INTER-BOX-SPACING*))) (FERROR NIL "~ The values you have given for page height, ~D, and maximum box height, ~D, are inconsistent with each other. The maximum box height must be at least ~D less than the page height." PAGE-HEIGHT BOX-MAX-HEIGHT (1+ *INTER-BOX-SPACING*)) (SETQ *PAGE-HEIGHT* PAGE-HEIGHT *BOX-MAXIMUM-HEIGHT* BOX-MAX-HEIGHT)))))