;;; This file contains functions for hacking Font files
;;; in KST format.  
;;; Submitted by Henry G. Baker, Jr.  

(defun let macro (form) 
       (cons (cons 'lambda (cons (cadr form) (cdddr form)))
	     (caddr form)))

(defun ^ macro (a)
       ;;; define logical "and" function.  
       (append '(boole 1.) (cdr a)))

(declare (fixnum n i j))

(defun readfont (font)
       ;;; "font" is an atom filename used by newio.  
       ;;; For example, |fonts;30vr kst|.  
       ;;; Readfont also returns its argument as its value.  
       ;;; Readfont gives this atom the following properties:
       ;;; kstid;
       ;;; column-position-adjustment;
       ;;; base-line;
       ;;; height;
       ;;; width.  
       ;;; "width" property is fixnum array of 128. entries
       ;;; giving width of each character in the font.  
       ;;; For example, after doing (readfont '|fonts;30vr kst|),
       ;;; (arraycall fixnum (get '|fonts;30vr kst| 'width) 65.)
       ;;; returns the width of capital "A".  
       (let (fontfile width)
	    ((open font '(in fixnum))
	     (*array nil 'fixnum 128.))
	    (putprop font width 'width)
	    (putprop font (in fontfile) 'kstid)
	    (let (n)((in fontfile))
		 (putprop font (^ (lsh n -27.) 511.) 'column-position-adjustment)
		 (putprop font (^ (lsh n -18.) 511.) 'base-line)
		 (putprop font (^ n (1- (lsh 1. 18.))) 'height))
	    (do ((i (in fontfile) i))
		((= i -1.))
		(let (char)((^ (in fontfile) 127.))
		     (store (arraycall fixnum width char)
			    (^ (in fontfile) (1- (lsh 1. 18.))))
		     (do ((j (in fontfile) (in fontfile)))
			 ((oddp j) (setq i j)))))
            (close fontfile))
       font)

(declare (fixnum s l) (notype w))

(defun flatlength (arg font) 
       ;;; compute the length of arg in the font "font".  
       (let (s w l)
	    ((flatc arg) (get font 'width) 0.)
	    (do ((i 1. (1+ i)))
		((> i s) l)
		(setq l
		      (+ l (arraycall fixnum w (getcharn arg i)))))))