; -*- Mode:LISP; Package:PRESS; Lowercase:YES; Base:10 -*-

(eval-when (compile eval)
  (cond ((status feature lispm))
	((status macro /#))
	(t (load '|dsk:liblsp;sharpm|))))

#Q (declare (setq run-in-maclisp-switch t))

;Interesting functions:
; (LOAD-FONT-WIDTHS)
;	loads up the file.  Takes an optional argument of the filename
;	of the widths file (defaults to FONTS; FONTS WIDTHS).
;	If a second optional argument is supplied, it is a list of
;	lists (family-name face-name point-size) and only those
;	specific fonts are loaded, to avoid running out of pdp-10
;	address space.
;	Merges with pre-existing contents of FONT-WIDTH-DATA (set it
;	to NIL first if you want to flush the old data.)
; (GET-FONT-WIDTH-DATA family-name face-name point-size)
;	returns an array of widths in micas (-1 for non-existent chars)
; (GET-FONT-WIDTH-AND-HEIGHT family-name face-name point-size)
;	returns a list of width and height in micas
;	This is gotten from the bounding box since the fixed Y-width
;	seems to be garbage generally.

#M (declare (special font-width-data))
#Q
(defvar font-width-data nil
  "FONT-WIDTH-DATA is a list of elements:
    (family-name face-name size rotation bounding-box xwidths ywidths)
	family-name is a string.
	face-name is a string structured as {B|L} {I} {C|E}.
		For an /"ordinary/" font, it is the empty string.
	size is 0 for relative sizing, in which case the data are
		in thousands of the nominal point-size of the font,
		or else size is the point-size in micas and the data are
		in micas.  A mica is 10 microns = 1/2540 inch
	rotation is normally 0, it is minutes of arc countclockwise
	bounding-box is a list of 4 numbers x-offset y-offset width height
	xwidths is a single number or a zero-origin fixnum array
	ywidths is a single number or a zero-origin fixnum array
A width of -1 means a non-existent character
In the bounding-box, the x-offset is negative to go to the left, and
the y-offset is negative to go below the baseline.
A point is exactly 2540./72. = approximately 35.27777 micas.")

;On Maclisp, the family-name and face-name are interned symbols.

#M (eval-when (compile eval)
	(defmacro dotimes ((var val) &rest forms)
		  `(do ((,var ,val (1- ,var))) ((not (> ,var 0))) ,.forms)))

#M (eval-when (compile eval)
	(defmacro truncate (dividend divisor)
	  `(// ,dividend ,divisor)))

#M (eval-when (compile eval)
	(defmacro with-open-file ((var filename options) . body)
		  `(let ((,var (open ,filename ,options)))
		     ,@body
		     (close ,var))))
(if-for-maclisp
  (defun equalp (x y) (equal x y)))

(declare (special widths-file code-alist #M widths-file-next-word))

;Fixnum array (so no number cons) contains -1 or buffered word
#M (or (boundp 'widths-file-next-word)
       (setq widths-file-next-word (*array nil 'fixnum 1)))

#M (declare (fixnum (next-word) (widths-file-pos) i j k m n wd))

(eval-when (compile eval #q load)
(defmacro high-byte (word)
  `(lsh ,word -8))

(defmacro low-byte (word)
  `(boole 1 377 ,word))
);eval-when

;Get next 16-bit word from widths-file
(defun next-word ()
  #M (cond ((minusp (arraycall fixnum widths-file-next-word 0))
	    (let ((wd (in widths-file)))
	      (store (arraycall fixnum widths-file-next-word 0)
		     (boole 1 (lsh wd -4) 177777))
	      (lsh wd -24)))
	   (t (prog2 nil (arraycall fixnum widths-file-next-word 0)
		     (store (arraycall fixnum widths-file-next-word 0) -1))))
  #Q (funcall widths-file ':tyi "Unexpected EOF on widths file"))

(defun widths-file-pos ()
   #M (- (* 2 (filepos widths-file))
	 (cond ((minusp (arraycall fixnum widths-file-next-word 0)) 0)
	       (t 1)))
   #Q (funcall widths-file ':read-pointer))

;2's complement form of next-word
(defun next-word2 ()
  (let ((wd (next-word)))
    (and (> wd 77777) (setq wd (- wd 200000)))
    wd))

	     
(defun bcpl-string (n widths-file) ;n = max-length-including-header-byte and is even
  (let ((wd (next-word)))
      (do ((chlist (if-for-lispm (make-array (high-byte wd) ':type 'art-string)))
	   (m (high-byte wd) (1- m))	;Number of characters
	   (i 0 (1+ i))
	   (k (truncate (- n (high-byte wd) 1) 2)))	;k is number of extra words
	  ((zerop m)
	   (do () ((zerop k))
	     (next-word) (setq k (1- k)))
	#M (prog2 (setq chlist (nreverse chlist))
		  (implode chlist)
		  (reclaim chlist t))
	#Q chlist)
	(cond ((oddp i)
	       (setq wd (next-word))
	    #M (push (high-byte wd) chlist)
	    #Q (aset (high-byte wd) chlist i))
	      (t
	    #M (push (low-byte wd) chlist)
	    #Q (aset (low-byte wd) chlist i))))))

(defun code-to-name (code)
  (or (cdr (assoc code code-alist))
      (list 'code code)))

;Normal face codes are || for normal, I for italic, B for bold, etc.
;These are strings rather than symbols on the Lisp machine.
;Alternatively the face code can be a list of the normal code,
;the CMU character-set-convention code, and the TEX logical size code.
(defun decode-face (face-code2)
  (declare (fixnum face-code2))
  (let ((l nil)
	(res nil)
	(face-code (\ face-code2 18.))
	(cmu-bullshit (\ (truncate face-code2 18.) 3))
	(tex-bullshit (if (< face-code2 54.) -1 (- face-code2 54.))))
    (declare (fixnum face-code cmu-bullshit tex-bullshit))
    (cond ((> face-code 11.)
	   (setq face-code (- face-code 12.))
	   (push #/E l))
	  ((> face-code 5)
	   (setq face-code (- face-code 6))
	   (push #/C l)))
     (cond ((oddp face-code)
	   (setq face-code (1- face-code))
	   (push #/I l)))
    (cond ((> face-code 3)
	   (setq face-code (- face-code 4))
	   (push #/L l))
	  ((> face-code 1)
	   (setq face-code (- face-code 2))
	   (push #/B l)))
    (cond ((not (zerop face-code))
	   #+CADR
	   (error '|extra garbage in face-code| face-code)
	   #+3600
	   (ferror "Extra garbage in face code: ~A" face-code)))
    (setq res (if-for-maclisp-else-lispm
		(implode l)
		(fillarray (make-array (length l) ':type 'art-string) l)))
    (cond ((or (not (zerop cmu-bullshit)) (not (minusp tex-bullshit)))
	   (setq res (list res cmu-bullshit))
	   (or (minusp tex-bullshit)
	       (setq res (nconc res (list tex-bullshit))))))
    res))

;Load it up and make the data structure mentioned at front of file
(defun load-font-widths (&optional filename fonts-desired dont-merge)
  "Loads font width data from FILENAME for fonts FONTS-DESIRED.
FILENAME defaults to SYS: PRESS-FONTS; FONTS WIDTHS.
FONTS-DESIRED defaults to everything in the file;
if specified, it is a list of decoded font names
/(lists of the form (family-name face-name point-size))
of fonts to be loaded.
The data is merged with the existing contents of FONT-WIDTH-DATA
 unless DONT-MERGE is non-NIL."
  (with-open-file (widths-file (or filename
				   #Q "sys: press-fonts;fonts widths"
				   #M '((dsk fonts)fonts widths))
			       '(read fixnum))
    (let ((code-alist nil)
	  (segment-data nil)
       #M (noret t)	; don't play musical corblk while loading stuff
	  (wd 0))
      ; guestimate core needed:
   #M (let ((max-guess (* 3 (lengthf widths-file))))
	(declare (fixnum max-guess))
	(and fonts-desired (let ((new-guess (* 800 (length fonts-desired))))
			     (declare (fixnum new-guess))
			     (and (< new-guess max-guess)
				  (setq max-guess new-guess))))
	(getsp max-guess))
   #M (store (arraycall fixnum widths-file-next-word 0) -1)
      (setq wd (next-word))
      ;; Read IXN entries (type 1)
      (do () ((not (= (lsh wd -12.) 1)))
	(let ((code (next-word))
	      (name (bcpl-string 20. widths-file)))
	  (push (cons code name) code-alist))
	(setq wd (next-word)))
      ;; Read WidthIndexEntries (type 4)
      (do () ((not (= (lsh wd -12.) 4)))
	(setq wd (next-word))		;family,,face
	(push (list (code-to-name (high-byte wd))		;Family-name
		    (decode-face (low-byte wd))		;Face name
		    (progn (setq wd (next-word))		;bc,,ec
			   (high-byte wd))		;First code
		    (low-byte wd)				;Last code
		    (next-word)				;Size
		    (next-word)				;Rotation
		    (+ (lsh (next-word) 16.) (next-word))	;Segment SA
		    (+ (lsh (next-word) 16.) (next-word)));Segment Len
	      segment-data)
	(setq wd (next-word)))
      ;; Now should have type-0 entry (end of index)
      (or (zerop (lsh wd -12.))
	  #+CADR
	  (error '|Garbage in file where type 0 IX expected| wd)
	  #+3600
	  (ferror "Garbage in file where type 0 IX expected: ~a" wd))
      ;; Now read out the WidthSegments, which should follow
      ;; immediately with no gaps.  Sort segments by SA
      ;; Hmm, now it seems gaps are allowed, so we skip them.
      ;; Also skip entries for fonts not in fonts-desired if it is non-nil.
      (setq segment-data (sort segment-data
			       #'(lambda (x y)
				   (< (cadddr (cdddr x)) (cadddr (cdddr y))))))
      (or (and (boundp 'font-width-data)
	       (null dont-merge))
	  (setq font-width-data nil))
      (do ((segment-data segment-data (cdr segment-data))
	   (seg) (bb) (m 0) (xwidths) (ywidths))
	  ((null segment-data))
	(setq seg (car segment-data))
	(let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
	  #M (declare (fixnum gap))
	  (cond ((minusp gap) (break file-out-of-phase t)))
	  (dotimes (i gap) (next-word)))
	(setq bb (list (next-word2) (next-word2) (next-word2) (next-word2)))
	(setq m (next-word))				;Flags
	  ;Note that the documentation on this flags word is wrong!
	(cond ((or (null fonts-desired)
		   (loop for f in fonts-desired
			 thereis (and (#+CADR equalp #+3600 string-equal
				       (car f) (car seg))  ;family
				      (#+CADR equalp #+3600 string-equal
				       (cadr f) (cadr seg)) ;face
				      (or (zerop (car (cddddr seg))) ;general
					  (point-size-equal	;specific
					      (car (cddddr seg)) (caddr f)))
				      (zerop (cadr (cddddr seg))) ;no rotation
				      )))
	       ;; Process X-data
	       (cond ((not (zerop (boole 1 100000 m)))
		      (setq xwidths (next-word)))
		     (t (setq xwidths (*array nil 'fixnum 400))
			(fillarray xwidths '(-1))	;Chars not in bc..ec
			(do ((j (caddr seg) (1+ j))
			     (k 0))
			    ((> j (cadddr seg)))
			  (setq k (next-word))
			  (and (= k 100000) (setq k -1))
			  #+CADR
			  (store (arraycall fixnum xwidths j) k)
			  #+3600
			  (aset k (function funcall) xwidths j))))
	       ;; Process Y-data
	       (cond ((not (zerop (boole 1 40000 m)))
		      (setq ywidths (next-word)))
		     (t (setq ywidths (*array nil 'fixnum 400))
			(fillarray ywidths '(-1))	;Chars not in bc..ec
			(do ((j (caddr seg) (1+ j))
			     (k 0))
			    ((> j (cadddr seg)))
			  (setq k (next-word2))
			  #+CADR
			  (store (arraycall fixnum ywidths j) k)
			  #+3600
			  (aset k (function funcall) ywidths j))))
	       ;; Make the data
	       (push (list (car seg) (cadr seg) (car (cddddr seg))
			   (cadr (cddddr seg)) bb xwidths ywidths)
		     font-width-data))
	      (t	;Skip this font
	       ;; Skip X-data
	       (cond ((not (zerop (boole 1 100000 m)))
		      (next-word))
		     (t (do ((j (caddr seg) (1+ j)))
			    ((> j (cadddr seg)))
			  (next-word))))
	       ;; Skip Y-data
	       (cond ((not (zerop (boole 1 40000 m)))
		      (next-word))
		     (t (do ((j (caddr seg) (1+ j)))
			    ((> j (cadddr seg)))
			  (next-word))))))))
 #Q (si:set-file-loaded-id (funcall widths-file ':pathname) (funcall widths-file ':info)
			   package)
    ))

;This will return the entry for the particular size if it
;can find it, otherwise the entry for relative size.
;Errors out if no info found.
(defun find-font-data (family-name face-name point-size)
  "Return width data on specified Dover font or family.
FAMILY-NAME is something like /"Helvetica/",
face name a symbol such as 'BI, POINT-SIZE a number.
If there is no entry for the specific size, but there is an
a scalable size-independent entry, that is returned."
  (or (find-font-data-1 family-name face-name point-size)
      #+CADR
      (error '|No information for font|
	     (list family-name face-name point-size))
      #+3600
      (ferror "No information for font")))

;This will return the entry for the particular size if it
;can find it, otherwise the entry for relative size.
;Returns NIL if no info found.
(defun find-font-data-1 (family-name face-name point-size)
 #Q (setq family-name (string family-name) face-name (string face-name))
    (or (do l font-width-data (cdr l) (null l)
	  (and (#+CADR equalp #+3600 string-equal (caar l) family-name)
	       (#+CADR equalp #+3600 string-equal (cadar l) face-name)
	       (point-size-equal (caddar l) point-size)
	       (zerop (cadddr (car l)))			;No rotation
	       (return (car l))))
	(do l font-width-data (cdr l) (null l)
	  (and (#+CADR equalp #+3600 string-equal (caar l) family-name)
	       (#+CADR equalp #+3600 string-equal (cadar l) face-name)
	       (zerop (caddar l))
	       (zerop (cadddr (car l)))			;No rotation
	       (return (car l))))))

(defun point-size-equal (internal point-size)
  (and ;(= (truncate (* internal 72.) 2540.) point-size)
       ;The above does not work.  Apparently Xerox just plain is not consistent
       ;about how many points there are in an inch.  It doesn't help that their
       ;font documentation is riddled with errors.  So we'll do something
       ;extremely forgiving.
       (> internal (truncate (- (* point-size 2540.) 1270.) 72.))
       (< internal (truncate (+ (* point-size 2540.) 1270.) 72.))))

; (GET-FONT-WIDTH-DATA family-name face-name point-size)
;	returns an array of widths in micas (-1 for non-existent chars)
#+CADR
(defun get-font-width-data (family-name face-name point-size)
  "Return array of character widths for specified Dover font.
FAMILY-NAME is something like /"Helvetica/",
face name a symbol such as 'BI, POINT-SIZE a number.
The returned array is indexed by character code,
and gives the character width in micas,
or -1 meaning the character is missing."
  (let ((dat (find-font-data family-name face-name point-size))
	(xwidths)(tem))
    (setq xwidths (cadr (cddddr dat)))
    (cond ((not (zerop (caddr dat)))	;Already got data in micas
	   (cond ((numberp xwidths)	;Fixed-width font
		  (setq tem (*array nil 'fixnum 400))
		  (fillarray tem (list xwidths))
		  (setq xwidths tem)))
	   xwidths)
	  ((numberp xwidths)		;Fixed-width font
	   (setq tem (truncate (* xwidths 2540. point-size) 72000.))
	   (setq xwidths (*array nil 'fixnum 400))
	   (fillarray xwidths (list tem))
	   xwidths)		    
	  ((let ((arr (*array nil 'fixnum
			      (cadr (arraydims xwidths)))))
	     (do ((i 0 (1+ i))
		  (m 0)
		  (n (cadr (arraydims arr))))
		 ((= i n))
	      (setq m (arraycall fixnum xwidths i))
	      (store (arraycall fixnum arr i)
		     (cond ((minusp m) -1)
			   ((truncate (* m point-size 2540.) 72000.)))))
	     arr)))))

(defun get-font-width-and-height (family-name face-name point-size)
  "Return the bounding box width and height for specified Dover font.
FAMILY-NAME is something like /"Helvetica/",
face name a symbol such as 'BI, POINT-SIZE a number.
The value is a list of the width and the height, in micas.
The height obtained this way is the right height for a line
made of text in this font."
  (let ((dat (find-font-data family-name face-name point-size)))
    (let ((bb (car (cddddr dat))))	;Bounding box
      (cond ((not (zerop (caddr dat)))	;Already got data in micas
	     (list (caddr bb) (cadddr bb)))
	    ((list (truncate (* (caddr bb) point-size 2540.) 72000.)
		   (truncate (* (cadddr bb) point-size 2540.) 72000.)))))))