;;; -*- Mode:common-LISP; Package:Imagen-Fonts; Base:10; Fonts:(Courier Hl12b Hl12bi) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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-1989 Texas Instruments Incorporated. All rights reserved.

(DEFUN ZAP-ARRAY (&AUX (BIT-ARRAY (MAKE-ARRAY (LIST 64 64) :ELEMENT-TYPE 'BIT)))
  "2Build and return a small square array with every-other bit turned on.*"
  (DOTIMES (I 32)
    (DOTIMES (J 32)
      (SETF (AREF BIT-ARRAY (+ I I) (+ J J)) 1)))
  BIT-ARRAY) 


(DEFUN DRAW-DIAGONAL (&AUX (BIG-ARRAY (MAKE-ARRAY (LIST 808 1024) :ELEMENT-TYPE 'BIT)))
  "2Build and return a screen-sized array with a diagonal line with hash marks in it.*"
  (DOTIMES (I 808)
    (SETF (AREF BIG-ARRAY I I) 1))
  ;1; Put horizontal lines every 8 pixels.*
  (LOOP FOR I FROM 0 TO (1- 808) BY 8 DO (DOTIMES (J 1024)
					   (SETF (AREF BIG-ARRAY I J) 1)))
  ;1; Put vertical lines every 8 pixels...*
  (LOOP FOR J FROM 0 TO (1- 1024) BY 8 DO (DOTIMES (I 808)
					    (SETF (AREF BIG-ARRAY I J) 1)))
  BIG-ARRAY) 


(DEFPARAMETER BIG-ARRAY-HEIGHT 2560) 

(DEFPARAMETER BIG-ARRAY-WIDTH 3328) 

(DEFUN BUILD-TEST-PATTERN (&AUX
			    (PATTERN (MAKE-ARRAY '(2 32) :ELEMENT-TYPE 'BIT :initial-element ()))
  (BIG-ARRAY (MAKE-ARRAY (LIST BIG-ARRAY-HEIGHT BIG-ARRAY-WIDTH) :ELEMENT-TYPE 'BIT)))
 ;1; Put staggered alternate on/off pattern throughout...*
  (DOTIMES (I 16)
    (SETF (AREF PATTERN 0 (+ I I)) 1)
    (SETF (AREF PATTERN 1 (+ I I 1)) 1))
  (BITBLT TV:ALU-SETA BIG-ARRAY-WIDTH BIG-ARRAY-HEIGHT PATTERN 0 0 BIG-ARRAY 0 0)
  ;1; Put 1-pixel think lines down every 32th pixel...*
  (dotimes (i 32)                            ;(FILLARRAY PATTERN ())
	   (setf (aref pattern 0 i) ())
	   (setf (aref pattern 1 i) ()))
  (SETF (AREF PATTERN 0 0) 1)
  (SETF (AREF PATTERN 1 0) 1)
  (LOOP FOR I FROM 0 TO (1- BIG-ARRAY-WIDTH) BY 32 DO
     (BITBLT TV:ALU-IOR 2 BIG-ARRAY-HEIGHT PATTERN 0 0 BIG-ARRAY I 0))
  ;1; Put 2-pixel thick lines down every 256th pixel...*
  (LOOP FOR I FROM 1 TO (1- BIG-ARRAY-WIDTH) BY 256 DO
     (BITBLT TV:ALU-IOR 2 BIG-ARRAY-HEIGHT PATTERN 0 0 BIG-ARRAY I 0))
  ;1; Put 1-pixel thick lines across every 32th pixel...*
  (dotimes (i 32)                            ;(FILLARRAY PATTERN ())
	   (setf (aref pattern 0 i) ())
	   (setf (aref pattern 1 i) ()))
  (DOTIMES (I 32)
    (SETF (AREF PATTERN 0 I) 1))
  (LOOP FOR I FROM 0 TO (1- BIG-ARRAY-HEIGHT) BY 32 DO
     (BITBLT TV:ALU-IOR BIG-ARRAY-WIDTH 2 PATTERN 0 0 BIG-ARRAY 0 I))
  ;1; Put 2-pixel thick lines across every 256th pixel...*
  (LOOP FOR I FROM 1 TO (1- BIG-ARRAY-HEIGHT) BY 256 DO
     (BITBLT TV:ALU-IOR BIG-ARRAY-WIDTH 2 PATTERN 0 0 BIG-ARRAY 0 I))
  ;1; Put a real thick line 256 pixels in from top & bottom...*
  (dotimes (i 32)                            ;(FILLARRAY PATTERN (LIST 1))
	   (setf (aref pattern 0 i) (LIST 1))
	   (setf (aref pattern 1 i) (LIST 1)))
  (BITBLT TV:ALU-IOR BIG-ARRAY-WIDTH 10 PATTERN 0 0 BIG-ARRAY 0 256)
  (BITBLT TV:ALU-IOR BIG-ARRAY-WIDTH 10 PATTERN 0 0 BIG-ARRAY 0 (- BIG-ARRAY-HEIGHT 256 10))
  ;1; Put real thick lines 256 pixels in from the sides...*
  (dotimes (i 32)                            ;(FILLARRAY PATTERN ())
	   (setf (aref pattern 0 i) ())
	   (setf (aref pattern 1 i) ()))
  (DOTIMES (I 10)
    (SETF (AREF PATTERN 0 I) 1)
    (SETF (AREF PATTERN 1 I) 1))
  (BITBLT TV:ALU-IOR 10 BIG-ARRAY-HEIGHT PATTERN 0 0 BIG-ARRAY 256 0)
  (BITBLT TV:ALU-IOR 10 BIG-ARRAY-HEIGHT PATTERN 0 0 BIG-ARRAY (- BIG-ARRAY-WIDTH 256 10) 0)
  ;1; Put in a 3-pixel wide diagonal line starting at the middle of the left-hand edge...*
  (DOTIMES (I
    (-
      (QUOTIENT BIG-ARRAY-HEIGHT 2)
     3))
    (DOTIMES (WIDTH 3)
      (SETF
       (AREF BIG-ARRAY
	     (+
	       (QUOTIENT BIG-ARRAY-HEIGHT 2)
	      I)
	     (+ WIDTH I))
       1)))
  BIG-ARRAY) 

;;; ********************************************************************************* ;;;
;;;                               The Imagen Font Descriptor                          ;;;
;;; ********************************************************************************* ;;;

	;;; 		***   N * O * T * E   ***
	;;; These three constructs are duplicated from IMAGENP
	;;; in order to keep this font-creation software separate
	;;; from the production font directory.  In particular,
	;;; you should set *imagen-font-directory-host-name* and
	;;; *imagen-font-directory-name* to a playground directory,
	;;; then later copy the created Imagen font files into your
	;;; production directory pointed to by these variables as
	;;; defined in the package IMAGEN in the file IMAGENP.


(DEFSTRUCT (IMAGEN-FONT (:CONC-NAME NIL) (:CALLABLE-CONSTRUCTORS NIL) (:ALTERANT ALTER-IMAGEN-FONT)
  (:PREDICATE NIL) (:COPIER NIL) (:TYPE :NAMED-ARRAY-LEADER))
  IMAGEN-FONT-NAME;1 Name of loadable Imagen font file*
  ;1    or printer-resident Imagen font.*
  LISP-FONT-NAME;1 Name of corresponding Lisp font*
  ;1    (NIL if printer-resident).*
  IMAGEN-FAMILY;1 Font's Imagen family-number. *
  SPACE-SIZE;1 Pixel-width of a good looking space.*
  INTERLINE-SPACING;1 Pixels between baselines.*
  DESIGN-SIZE;1 Points to which the font was designed.*
  MAGNIFICATION;
  (SEND-GLYPH-TO-IMAGEN;1 T iff glyph must be downloaded to printer.*
   (MAKE-ARRAY 128 :ELEMENT-TYPE 'BIT));1    **
  (CHAR-WIDTH;1 Width of I-th character in pixels.*
   (MAKE-ARRAY 128 :ELEMENT-TYPE '(UNSIGNED-BYTE 8)));1    **
  (GLYPH-MAP (MAKE-ARRAY 128))) 	   ;1 Bit-map for each glyph in this font.*


(DEFPARAMETER *IMAGEN-FONT-DIRECTORY-HOST-NAME* "sys"
   "2The host on which loadable Imagen fonts are stored.*") 


(DEFPARAMETER *IMAGEN-FONT-DIRECTORY-NAME* (LIST "imagen-fonts")
   "2The directory where loadable Imagen fonts are stored.*") 
;;; ********************************************************************************* ;;;


(DEFUN FLIP-BITS (&AUX (FLIPPED-BITS (MAKE-ARRAY 256 :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :FILL-POINTER 0))
  (IN-BITS (MAKE-ARRAY 8 :ELEMENT-TYPE 'BIT))
  (IN-VALUE (MAKE-ARRAY 1 :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :DISPLACED-TO IN-BITS))
  (OUT-BITS (MAKE-ARRAY 8 :ELEMENT-TYPE 'BIT))
  (OUT-VALUE (MAKE-ARRAY 1 :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :DISPLACED-TO OUT-BITS)))
  "2Build and return an array of the binary representations of the values 0-255 with the bits
flipped.*"
  (DOTIMES (I 256)
    (SETF (AREF IN-VALUE 0) I)
    (DOTIMES (J 8)
       (SETF (AREF OUT-BITS (- 7 J)) (AREF IN-BITS J)))
     (VECTOR-PUSH (AREF OUT-VALUE 0) FLIPPED-BITS))
  FLIPPED-BITS) 

;;; ********************************************************************************* ;;;
  

(DEFPARAMETER ASCIIZED-RECORD-LENGTH 684) 


(DEFUN DE-ASCIIZE-A-FILE (INPUT-PATHNAME OUTPUT-PATHNAME &AUX
  (ASCIIZED-BYTE-BUFFER
   (MAKE-ARRAY (1+ ASCIIZED-RECORD-LENGTH) :ELEMENT-TYPE '(UNSIGNED-BYTE 8))))
  "2Assumes that the file specified by* input-pathname2 was created from a Unix TAR tape
with 512 byte records by the 990's 'asciize*'2 utility, then reverses the process, leaving
the result in the file specified by* output-pathname2.*"
  (DECLARE (SPECIAL ASCIIZED-RECORD-LENGTH))
  (WITH-OPEN-FILE (INPUT-FILE INPUT-PATHNAME)
    (WITH-OPEN-FILE (OUTPUT-FILE OUTPUT-PATHNAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
      (LOOP WHILE (SEND INPUT-FILE :TYIPEEK) DO;1 Loop until EOF.*
	 (SEND INPUT-FILE;1 Read in 288. bytes of data plus the LF*
	    :STRING-IN ();1     added by XNS file transfer from the 990.*
	    ASCIIZED-BYTE-BUFFER);    1**
	 (LOOP FOR I FROM 0 TO (- ASCIIZED-RECORD-LENGTH 4 1) BY 4 DO;1 From 4 bytes of asciized pixel data*
	    (LOOP FOR K FROM 0 TO 2 BY 1 DO;1    create 3 bytes of real pixel data.*
	       (SEND OUTPUT-FILE :TYO;1    **
		  (+ (LDB;1 Get right-most 6 bits of pixel byte.*
		      (BYTE 6 0) (AREF ASCIIZED-BYTE-BUFFER (+ I K)))
		     (LSH;1 Get left-most 2 bits of pixel byte.*
		      (LDB (BYTE 2 (- 4 K K)) (AREF ASCIIZED-BYTE-BUFFER (+ I 3))) 6)))))
	 (LOOP FOR K FROM 0 TO 1 BY 1 DO;1 Create the last 2 bytes of the 512-byte*
	    (SEND OUTPUT-FILE :TYO;1    un-asciized record (ignore 513th byte).*
	       (+
		(LDB;1 Get right-most 6 bits of pixel byte.*
		 (BYTE 6 0) (AREF ASCIIZED-BYTE-BUFFER (+ (- ASCIIZED-RECORD-LENGTH 4) K)))
		(LSH;1 Get left-most 2 bits of pixel byte.*
		 (LDB (BYTE 2 (- 4 K K))
		      (AREF ASCIIZED-BYTE-BUFFER (+ (- ASCIIZED-RECORD-LENGTH 4) 3)))
		 6)))))))) 

;;; ******************************************************************************** ;;;


(DEFUN SHOW-FILE-IN-HEX (INPUT-PATHNAME &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*) &AUX (BLOCK-NUM -1))
  "2Writes a hexadecimal dump of the file specified by *input-pathname2 to *output-stream
2(to standard-output by default).*"
  (WITH-OPEN-FILE (INPUT-FILE INPUT-PATHNAME)
    (LOOP WHILE (SEND INPUT-FILE :TYIPEEK) DO (SETQ BLOCK-NUM (1+ BLOCK-NUM))
       (SEND OUTPUT-STREAM :STRING-OUT (FORMAT () "~%~%BLOCK ~D:" BLOCK-NUM))
       (LOOP FOR I FROM 0 TO 511 BY 16 DO
	  (SEND OUTPUT-STREAM :STRING-OUT
	     (FORMAT () "~%   ~16,3,48R - ~{~16,2,48R~16,2,48R ~}" I
		     (LOOP FOR K FROM 0 TO 15 BY 1 COLLECT (SEND INPUT-FILE :TYI)))))))) 

;;; ******************************************************************************** ;;;


(DEFUN SHOW-FILE-IN-OCTAL (INPUT-PATHNAME &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*) &AUX (BLOCK-NUM -1))
  "2Writes an octal dump of the file specified by* input-pathname2 to *output-stream
2(to standard-output by default).*"
  (WITH-OPEN-FILE (INPUT-FILE INPUT-PATHNAME)
    (LOOP WHILE (SEND INPUT-FILE :TYIPEEK) DO (SETQ BLOCK-NUM (1+ BLOCK-NUM))
       (SEND OUTPUT-STREAM :STRING-OUT (FORMAT () "~%~%BLOCK ~D:" BLOCK-NUM))
       (LOOP FOR I FROM 0 TO 511 BY 16 DO
	  (SEND OUTPUT-STREAM :STRING-OUT
	     (FORMAT () "~%   ~4,48O - ~{~3,48O ~}" I
		     (LOOP FOR K FROM 0 TO 15 BY 1 COLLECT (SEND INPUT-FILE :TYI)))))))) 


;;; ******************************************************************************** ;;;
;
;;; ******************************************************************************** ;;;


(DEFUN CONVERT-FIXES-TO-PIXELS (ARRAY START)
  (CEILING (* 300 (4-BYTE-UNSIGNED-VALUE ARRAY START)) (* 72.27 (LSH 1 20)))) 


(DEFUN 2-BYTE-UNSIGNED-VALUE (ARRAY START)
  (IF (NULL ARRAY)
    0
    (+ (* 256 (AREF ARRAY START)) (AREF ARRAY (1+ START))))) 


(DEFUN 2-BYTE-SIGNED-VALUE (ARRAY START)
  (IF (NULL ARRAY)
    0
    (+ (AREF ARRAY (1+ START))
       (* 256 (IF (> (AREF ARRAY START) 127)
		(- (AREF ARRAY START) 256)
		(AREF ARRAY START)))))) 


(DEFUN 3-BYTE-UNSIGNED-VALUE (ARRAY START)
  (IF (NULL ARRAY)
    0
    (+ (* 256 (+ (* 256 (AREF ARRAY START)) (AREF ARRAY (1+ START)))) (AREF ARRAY (+ START 2))))) 


(DEFUN 4-BYTE-UNSIGNED-VALUE (ARRAY START)
  (IF (NULL ARRAY)
    0
    (+ (* 256 (3-BYTE-UNSIGNED-VALUE ARRAY START)) (AREF ARRAY (+ START 3))))) 


(DEFUN 4-BYTE-SIGNED-VALUE (ARRAY START)
  (IF (NULL ARRAY)
    0
    (+ (3-BYTE-UNSIGNED-VALUE ARRAY (1+ START))
       (* 256 256 256
	  (IF (> (AREF ARRAY START) 127)
	    (- (AREF ARRAY START) 256)
	    (AREF ARRAY START)))))) 


(DEFUN DUMP-DESCRIPTOR (D &AUX NUMBER-OF-BYTES INITIAL-TEXT)
  (FORMAT T "~%~%...Dump of Imagen font descriptor ~A..." (STRING-UPCASE (IMAGEN-FONT-NAME D)))
  (DOTIMES (I 128)
    (SETQ INITIAL-TEXT (FORMAT () "~%~%CHARACTER ~16,2,48R = " I))
    (IF (NULL (AREF (GLYPH-MAP D) I))
      (FORMAT T "~A" INITIAL-TEXT)
      (PROGN
	(SETQ NUMBER-OF-BYTES (FILL-POINTER (AREF (GLYPH-MAP D) I)))
	(DOTIMES (J (CEILING NUMBER-OF-BYTES 20))
	  (FORMAT T "~A" INITIAL-TEXT)
	  (DOTIMES (JJ (MIN 20 (- NUMBER-OF-BYTES (* J 20))))
	    (FORMAT T "~16,2,48R, " (AREF (AREF (GLYPH-MAP D) I) (+ (* J 20) JJ))))
	  (SETQ INITIAL-TEXT (FORMAT () "~%               "))))))) 

;;; ******************************************************************************** ;;;


(DEFUN CREATE-IMAGEN-FONT-FILE (IMAGEN-FONT &AUX FONT)
  "2Given the name of an Imagen font file *imagen-font2 (a string) in the1 *directory of imagen
font files, or the pathname of the Imagen font file, builds an in-memory image of the font's
descriptor, assigns it to the symbol IMAGEN-FONTS:<FONT-NAME> and writes out this
symbol's value as an X*LD2 file in the directory of loadable imagen font descriptors to be
LOADed later by the* 2Imagen print server software.*"
  ;1; Extract just the file name if a file pathname was given us (as DIRED Apply does)...*
  (SETQ IMAGEN-FONT
	(subseq IMAGEN-FONT
		   (OR
		    (POSITION #\SPACE (THE STRING (STRING IMAGEN-FONT)) :START
			      (1+
			       (POSITION #\; (THE STRING (STRING IMAGEN-FONT)) :TEST
					 #'CHAR-EQUAL))
			      :TEST-NOT #'CHAR-EQUAL)
		    0)
		   (OR
		    (POSITION #\. (THE STRING (STRING IMAGEN-FONT)) :FROM-END T :TEST
			      #'CHAR-EQUAL)
		    (LENGTH IMAGEN-FONT))))
  ;1; Create the symbol this Imagen font descriptor will be stored in...*
  (SETQ FONT (INTERN (STRING-UPCASE (STRING IMAGEN-FONT)) 'IMAGEN-FONTS))
  ;1; Create the Imagen font descriptor, store it in the symbol...*
  (SET FONT (BUILD-IMAGEN-FONT-DESCRIPTOR IMAGEN-FONT))
  ;1; Write out the symbol's value to a file...*
  (COMPILER:FASD-SYMBOL-VALUE
   (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY
		  *IMAGEN-FONT-DIRECTORY-NAME* :NAME IMAGEN-FONT)
   FONT)) 

;;; ********************************************************************************* ;;;


(DEFUN BUILD-IMAGEN-FONT-DESCRIPTOR (IMAGEN-FONT &AUX PREAMBLE GLYPH-DIRECTORY-START 1ST-CHARACTER-NUMBER LAST-CHARACTER-NUMBER
  FONT-DESCRIPTOR MAGNIFIER)
  "2Given the name of an imagen font file *imagen-font2 (a string) in the directory of imagen font
files, builds an in-memory image of the font's descriptor and returns it as the value of the function.*"
  (WITH-OPEN-FILE (STREAM
    (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY
		   *IMAGEN-FONT-DIRECTORY-NAME* :NAME IMAGEN-FONT :TYPE "bin"))
    (SEND STREAM :SET-POINTER 8);1 Skip over the file mark.*
    (SETQ PREAMBLE (READ-RST-FONT-FILE-PREAMBLE STREAM))
    (SETQ GLYPH-DIRECTORY-START (3-BYTE-UNSIGNED-VALUE PREAMBLE 1))
    (SETQ 1ST-CHARACTER-NUMBER (2-BYTE-UNSIGNED-VALUE PREAMBLE 4))
    (SETQ LAST-CHARACTER-NUMBER (2-BYTE-UNSIGNED-VALUE PREAMBLE 6))
    (SETQ MAGNIFIER (/ 1000.0 (4-BYTE-UNSIGNED-VALUE PREAMBLE 8)))
    (SETQ FONT-DESCRIPTOR
	  (MAKE-IMAGEN-FONT LISP-FONT-NAME NIL IMAGEN-FONT-NAME IMAGEN-FONT SPACE-SIZE
	   (CEILING (CONVERT-FIXES-TO-PIXELS PREAMBLE 20) MAGNIFIER) INTERLINE-SPACING
	   (CEILING (CONVERT-FIXES-TO-PIXELS PREAMBLE 16) MAGNIFIER) DESIGN-SIZE
	   (CONVERT-FIXES-TO-PIXELS PREAMBLE 12) MAGNIFICATION
	   (4-BYTE-UNSIGNED-VALUE PREAMBLE 8)))
    (LOOP FOR I FROM 1ST-CHARACTER-NUMBER TO LAST-CHARACTER-NUMBER DO
 	(SETF (AREF (GLYPH-MAP FONT-DESCRIPTOR) I)
	      (READ-NTH-GLYPH STREAM GLYPH-DIRECTORY-START (- I 1ST-CHARACTER-NUMBER)
	       FONT-DESCRIPTOR MAGNIFIER))))
  ;1; Mark all glyphs as not-yet-sent-to-Imagen...*
  (DOTIMES (I 128)
    (SETF (AREF (SEND-GLYPH-TO-IMAGEN FONT-DESCRIPTOR) I) 0))
  ;1; Make sure the size of a space character is consistent...*
  (SETF (AREF (CHAR-WIDTH FONT-DESCRIPTOR) #\SPACE) (SPACE-SIZE FONT-DESCRIPTOR))
  FONT-DESCRIPTOR) 

;;; ******************************************************************************** ;;;
	  

(DEFUN READ-RST-FONT-FILE-PREAMBLE (STREAM &AUX PREAMBLE PREAMBLE-LENGTH)
  "2Reads the preamble of an RST-format font file into an array, returning the array as the
value of the function.*"
  (SETQ PREAMBLE-LENGTH (+ (* 256 (SEND STREAM :TYI)) (SEND STREAM :TYI)))
  (SETQ PREAMBLE (MAKE-ARRAY PREAMBLE-LENGTH :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))
  (SEND STREAM :STRING-IN () PREAMBLE)
  PREAMBLE) 

;;; ******************************************************************************** ;;;


(DEFUN READ-NTH-GLYPH (STREAM GLYPH-DIR-START N FONT-DESCRIPTOR MAGNIFIER &AUX
	 (DIRECTORY-BUFFER (MAKE-ARRAY 15 :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))
	 (BGLY-STRING (MAKE-ARRAY 100 :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :FILL-POINTER 0)))
  "2Returns a BGLY string (minus the 1st byte) for the Nth glyph.in an RST-format font file.*"
  (SEND STREAM :SET-POINTER (+ GLYPH-DIR-START (* 15 N)))
  (SEND STREAM :STRING-IN () DIRECTORY-BUFFER)
  (SETQ BGLY-STRING
	(STRING-NCONC BGLY-STRING
		      (IMAGEN::IMPRESS-OUTPUT-16
		       (CEILING (CONVERT-FIXES-TO-PIXELS DIRECTORY-BUFFER 8) MAGNIFIER))
		      (AREF DIRECTORY-BUFFER 2); width
		      (AREF DIRECTORY-BUFFER 3);   *
		      (AREF DIRECTORY-BUFFER 6); left-offset
		      (AREF DIRECTORY-BUFFER 7);   *
		      (AREF DIRECTORY-BUFFER 0); height
		      (AREF DIRECTORY-BUFFER 1);   *
		      (AREF DIRECTORY-BUFFER 4); top-offset
		      (AREF DIRECTORY-BUFFER 5)));   *
  ;1;*
  ;1; Pick up font map...*
  ;;
  (SEND STREAM :SET-POINTER (3-BYTE-UNSIGNED-VALUE DIRECTORY-BUFFER 12)); Point to the font map.
  (DOTIMES (I
    (* (2-BYTE-UNSIGNED-VALUE DIRECTORY-BUFFER 0)
       (CEILING (2-BYTE-UNSIGNED-VALUE DIRECTORY-BUFFER 2) 8)))
     (VECTOR-PUSH-EXTEND (SEND STREAM :TYI) BGLY-STRING))
  (SETF (AREF (CHAR-WIDTH FONT-DESCRIPTOR) N);1 Put character's advance width*

	(CEILING (CONVERT-FIXES-TO-PIXELS DIRECTORY-BUFFER 8);1    into the descriptor.*
		 MAGNIFIER))
  BGLY-STRING) 



;;; ******************************************************************************** ;;;
;;;            Convert an Imagen Font Descriptor into a FED Font Descriptor          ;;;
;;; ******************************************************************************** ;;;


(DEFVAR *CURRENT-IMAGEN-FD* ()) 


(DEFUN IMAGEN-CD-ADVANCE-WIDTH (CHAR-CODE)
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (2-BYTE-UNSIGNED-VALUE (AREF (GLYPH-MAP *CURRENT-IMAGEN-FD*) CHAR-CODE) 0)) 


(DEFUN IMAGEN-CD-WIDTH (CHAR-CODE)
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (2-BYTE-UNSIGNED-VALUE (AREF (GLYPH-MAP *CURRENT-IMAGEN-FD*) CHAR-CODE) 2)) 


(DEFUN IMAGEN-CD-LEFT-OFFSET (CHAR-CODE)
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (2-BYTE-SIGNED-VALUE (AREF (GLYPH-MAP *CURRENT-IMAGEN-FD*) CHAR-CODE) 4)) 


(DEFUN IMAGEN-CD-HEIGHT (CHAR-CODE)
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (2-BYTE-UNSIGNED-VALUE (AREF (GLYPH-MAP *CURRENT-IMAGEN-FD*) CHAR-CODE) 6)) 


(DEFUN IMAGEN-CD-TOP-OFFSET (CHAR-CODE)
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (2-BYTE-SIGNED-VALUE (AREF (GLYPH-MAP *CURRENT-IMAGEN-FD*) CHAR-CODE) 8)) 



(DEFUN IMAGEN-FONT-INTO-FONT-DESCRIPTOR (IMAGEN-FD &AUX FED-FD TEMP RASTER-WIDTH RASTER-HEIGHT (IMAGEN-FD-LEFT-EXTRA 0))
  "2Create and return a font-descriptor containing the data from* IMAGEN-FD."
  (DECLARE (SPECIAL *CURRENT-IMAGEN-FD*))
  (IF (SYMBOLP IMAGEN-FD)
    (SETF IMAGEN-FD (SYMBOL-VALUE IMAGEN-FD)))
  (SETQ *CURRENT-IMAGEN-FD* IMAGEN-FD);1 Give everybody access to it.*
  (SETQ FED-FD (FED::MAKE-FONT-DESCRIPTOR :MAKE-ARRAY (:LENGTH 128) FD-FILL-POINTER 128))
  (SETF (FED::FD-NAME FED-FD)
	(IF (STRINGP (IMAGEN-FONT-NAME IMAGEN-FD))
	  (INTERN (STRING-UPCASE (STRING-APPEND "imagen-" (IMAGEN-FONT-NAME IMAGEN-FD))) 'FONTS)
	  (IMAGEN-FONT-NAME IMAGEN-FD)))
  (SETF (FED::FD-LINE-SPACING FED-FD) (INTERLINE-SPACING IMAGEN-FD))
  (SETF (FED::FD-BASELINE FED-FD)
	(LOOP FOR CHAR-CODE FROM 0 TO 127 MAXIMIZE (IMAGEN-CD-TOP-OFFSET CHAR-CODE)))
  (SETF (FED::FD-BLINKER-HEIGHT FED-FD)
	(+ (FED::FD-BASELINE FED-FD)
	   (LOOP FOR CHAR-CODE FROM 0 TO 127 MAXIMIZE
	      (IF (= CHAR-CODE 32)
		0
		(- (IMAGEN-CD-HEIGHT CHAR-CODE) (IMAGEN-CD-TOP-OFFSET CHAR-CODE))))))
  (SETF (FED::FD-BLINKER-WIDTH FED-FD) (SPACE-SIZE IMAGEN-FD))
  (SETF (FED::FD-SPACE-WIDTH FED-FD) (SPACE-SIZE IMAGEN-FD))
  (SETF (FED::FD-DOUBLE-WIDTH-P FED-FD) ())
  (SETQ IMAGEN-FD-LEFT-EXTRA
	(-
	 (LOOP FOR CHAR-CODE FROM 0 TO 127 MAXIMIZE
	    (IF (= CHAR-CODE 32)
	      0
	      (IMAGEN-CD-LEFT-OFFSET CHAR-CODE)))))
  (LOOP FOR CHAR-CODE FROM 0 TO 127 DO (SETQ RASTER-HEIGHT (FED::FD-BLINKER-HEIGHT FED-FD))
     (SETQ RASTER-WIDTH (IMAGEN-CD-WIDTH CHAR-CODE))
     (SETQ TEMP
	   (FED::MAKE-CHAR-DESCRIPTOR :MAKE-ARRAY
	      (:TYPE 'ART-4B :LENGTH (LIST RASTER-HEIGHT RASTER-WIDTH)) FED::CD-CHAR-WIDTH
	      (AREF (CHAR-WIDTH IMAGEN-FD) CHAR-CODE) FED::CD-CHAR-VERT-WIDTH 0
	      FED::CD-CHAR-LEFT-KERN 0))
     (SETF (AREF FED-FD CHAR-CODE) TEMP);1 Put this cd into the fed-fd.*
     ;1;*
     ;1; Now we gotta stuff the Imagen bitmap into the FED char-descriptor, remembering that*
     ;1;    the bytes sent to the Imagen contain big-endian bits...* 
     ;1;*
     (DOTIMES (I (IMAGEN-CD-HEIGHT CHAR-CODE))
       (DOTIMES (J (CEILING (IMAGEN-CD-WIDTH CHAR-CODE) 8))
	 (DOTIMES (K 8)
	   (IF (< (+ (* 8 J) K) (IMAGEN-CD-WIDTH CHAR-CODE))
	      (SETF
	       (AREF TEMP (+ (- (FED::FD-BASELINE FED-FD) (IMAGEN-CD-TOP-OFFSET CHAR-CODE)) I)
		     (+;(MAX 0 (- (imagen-cd-left-offset char-code)))  ;1 Supress any kerning.*
		      (* 8 J) K))
	       (LDB (BYTE 1 (- 7 K))
		    (AREF (AREF (GLYPH-MAP IMAGEN-FD) CHAR-CODE)
			  (+ 10 (* I (CEILING (IMAGEN-CD-WIDTH CHAR-CODE) 8)) J)))))))))
  FED-FD) 


(DEFUN FEDIZE-AN-IMAGEN-FONT (IMAGEN-FONT-NAME &AUX FED-FD)
  "2Given the name of an Imagen font in a file in the directory of loadable Imagen fonts, create
the FED font descriptor and the Lisp font named '*IMAGEN-{imagen-font-name}'2.*"
  ;1; Load the Imagen font-descriptor...*
  (LOAD
   (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY
		  *IMAGEN-FONT-DIRECTORY-NAME* :NAME IMAGEN-FONT-NAME))
  (SETQ FED-FD
	(IMAGEN-FONT-INTO-FONT-DESCRIPTOR
	 (find-symbol (STRING-UPCASE (STRING IMAGEN-FONT-NAME)) 'IMAGEN-FONTS)))
  (FED::FONT-NAME-SET-FONT-AND-DESCRIPTOR
   (INTERN (STRING-UPCASE (STRING-APPEND "imagen-" IMAGEN-FONT-NAME)) 'FONTS) FED-FD)) 


(DEFUN FONT-DESCRIPTOR-TO-IMAGEN-FONT-FILE (FONTNAME &OPTIONAL (IMAGEN-FONTNAME NIL) &AUX LISP-FONT)
  "2Write a loadable Imagen font file from a Lisp font descriptor FONTNAME.
Only works for IMAGEN- fed fonts.*"
  ;1; Get the print name of FONTNAME...*
  (SETQ FONTNAME (STRING-UPCASE FONTNAME))
  ;1; If no associated Lisp font was specified, extract its name X from the IMAGEN-X fontname...*
  (UNLESS IMAGEN-FONTNAME
    (IF (STRING-EQUAL "IMAGEN-" (SUBSeq FONTNAME 0 7))
      (SETQ IMAGEN-FONTNAME (SUBSeq FONTNAME 7))
      ;1; else...*
      (FERROR () "Unable to determine an associated Lisp font for ~A." FONTNAME)))
  (SETF LISP-FONT (INTERN FONTNAME 'FONTS))
  (SETF IMAGEN-FONTNAME (INTERN (STRING-UPCASE IMAGEN-FONTNAME) 'IMAGEN-FONTS))
  (SET IMAGEN-FONTNAME (IMAGEN::FONT-DESCRIPTOR-INTO-IMAGEN-FONT LISP-FONT))
  ;1; Write the Imagen font descriptor and friends into a file...*
  (COMPILER:FASD-SYMBOL-VALUE
   (MAKE-PATHNAME :HOST *IMAGEN-FONT-DIRECTORY-HOST-NAME* :DIRECTORY
		  *IMAGEN-FONT-DIRECTORY-NAME* :NAME (STRING IMAGEN-FONTNAME))
   IMAGEN-FONTNAME)) 


(DEFUN IMAGENIZE-A-FONT-DESCRIPTOR (FONTNAME)
  (FONT-DESCRIPTOR-TO-IMAGEN-FONT-FILE FONTNAME)) 


(DEFUN PRINT-FONT-SAMPLE (FONTNAMES)
  "2Given a list of FONTNAMES, prints a file showing all the glyphs for all 128 character
codes in* 2all the specified fonts, one character code per line.*"
  (UNLESS (CONSP FONTNAMES)
    (SETF FONTNAMES (LIST FONTNAMES)))
  (WITH-OPEN-FILE (STREAM "lm:printer;font-sample.text" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
   ;1; Output the mode line containing the names of the fonts to be displayed...*
    (SEND STREAM :STRING-OUT " ;;; -*- Mode:TEXT; Base:8; Fonts:(CMASC10")
    (DOLIST (FONT-NAME FONTNAMES)
      (SEND STREAM :STRING-OUT (FORMAT () " ~A" FONT-NAME)))
    (SEND STREAM :LINE-OUT ") -*-")
    ;1; Output a line per character code, showing all the specified fonts' glyphs for that code...*  
    (DOTIMES (CHARCODE 128)
      (SEND STREAM :STRING-OUT (FORMAT () "~%Character code ~3,48O = " CHARCODE))
      (DOTIMES (FONT-NUMBER (LENGTH FONTNAMES))
	(SEND STREAM :TYO #\TAB);1 Tab over one stop using that font.*
	(SEND STREAM :TYO 6);1 Switch to next displayable font.*
	(SEND STREAM :TYO (+ FONT-NUMBER (CHAR-CODE #\1)));1 ** 
	(SEND STREAM :TYO CHARCODE);1 Display this character in that font.*
	(SEND STREAM :TYO 6);1 Switch back to the first font (fixed-width).*
	(SEND STREAM :TYO #\0))));1    **
  ;1; Print the file just built, then delete it...*
  (printer:PRINT-FILE-AND-WAIT "lm:printer;font-sample.text" :DELETE-AFTER T :PAGE-HEADING
		       (FORMAT () "Sample print of: ~A" FONTNAMES)))