mirror of
https://github.com/PDP-10/its.git
synced 2026-01-19 09:29:15 +00:00
60 lines
1.9 KiB
Plaintext
Executable File
60 lines
1.9 KiB
Plaintext
Executable File
;;; 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)))))))
|
||
|
||
|