(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated "17-Dec-87 18:31:20" {erinyes}<lispusers>lyric>novafont.\;8 36636
|changes| |to:| (vars novafontcoms) (fns \\readdisplayfontfile \\createcharset.ip notice-novafont-file \\findfontfile)
(advice \\readdisplayfontfile \\createcharset.ip) (variables *novafont-info*)
|previous| |date:| " 9-Dec-87 01:12:54" {erinyes}<lispusers>lyric>novafont.\;5)
; Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
(prettycomprint novafontcoms)
(rpaqq novafontcoms ((* |;;;| "user callable functions (either load-on-demand or load them all") (fns notice-novafont-file load-novafont-file) (* |;;;| "the parts necessary for using with FONTCREATE") (fns \\readnovafontfile.display \\readnovafontfile.ip) (* |;;;| "modified versions of functions from the default font handling system") (* |;;| "advise doesn't work in released lyric, so do this with movds") (p (movd? (quote \\readdisplayfontfile) (quote \\no-nova-readdisplayfontfile)) (movd? (quote \\createcharset.ip) (quote \\no-nova-createcharset.ip))) (fns \\readdisplayfontfile \\createcharset.ip) (* |;;;| "the parts for general hacking of the NOVAFONT files") (fns describe-font select-font enumerate-fonts viewpoint-font-file-p) (vars (*warn-on-kerning* nil)) (* |;;;| "things for dealing with the structure of what we read") (macros readswappedfixp) (fns read-block-of-bytes read-novafont-characterset read-novafont-fileheader read-novafont-fontheader \\textblt) (* |;;;| "the datastructures that we use and their sizes") (declare\: eval@compile dontcopy (records fonttreenodeblock charsetblock fontdescription) (constants (fonttreenodeblockbytesize (constant (itimes bytesperword (indexf (fetch (fonttreenodeblock dummy-last-field-dont-reference-this) of t))))) (charsetblockbytesize (constant (itimes bytesperword (indexf (fetch (charsetblock dummy-last-field-dont-reference-this) of t))))) (fontdescriptionbytesize (constant (itimes bytesperword (indexf (fetch (fontdescription dummy-last-field-dont-reference-this) of t))))))) (declare\: eval@compile donteval@load docopy (initrecords fonttreenodeblock charsetblock fontdescription)) (* |;;;| "the mapping from font family number to font family name for those fonts which don't have the name embedded in the font file.") (constants \\novafontfamilynames) (* |;;;| "initialize the \"noticed\" fonts structure and set up the extensions so we can use the font files") (variables *novafont-info*) (* |;;;| "correct some omissions in the family aliases and printwheel fonts") (p (listput interpressfamilyaliases (quote xeroxlogo) (quote logotypes-xerox)) (|pushnew| interpressprintwheelfamilies (quote scientificthin) (quote ocrb) (quote ocra))) (* |;;;| "some things we need for compiling. Also need EXPORTS.ALL") (declare\: eval@compile dontcopy (files (loadcomp) interpress)) (* |;;;| "some hints for the compiler (system generated)") (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama) (nlaml) (lama read-novafont-fontheader read-novafont-fileheader))))
)
(* |;;;| "user callable functions (either load-on-demand or load them all")
(defineq
(notice-novafont-file
(lambda (novafont-filename notrace) (* \; "Edited 7-Dec-87 12:24 by Masinter") (cl:with-open-file (novafont-stream novafont-filename :input) (let (number-of-fonts font-offsets) (cl:multiple-value-setq (number-of-fonts font-offsets) (read-novafont-fileheader novafont-stream)) (|for| font-number |from| 1 |to| number-of-fonts |bind| font-name novafont-descriptor character-set-offsets font-face character-sets family-info size-info face-info |do| (cl:multiple-value-setq (font-name novafont-descriptor character-set-offsets) (read-novafont-fontheader novafont-stream (elt font-offsets font-number))) (setq font-face (+ (|fetch| (fontdescription emphasis) |of| novafont-descriptor) (cl:* 2 (|fetch| (fontdescription weight) |of| novafont-descriptor)))) (* |;;| "was (list (cl:ecase (|fetch| (fontdescription weight) |of| novafont-descriptor) (0 'light) (1 'medium) (2 'bold)) (cl:ecase (|fetch| (fontdescription emphasis) |of| novafont-descriptor) (0 'regular) (1 'italic)) 'regular) ") (cl:unless notrace (cl:format t "~A~D~A~S" font-name (|fetch| (fontdescription size) |of| novafont-descriptor) (list (cl:ecase (|fetch| (fontdescription weight) |of| novafont-descriptor) (0 (quote light)) (1 (quote medium)) (2 (quote bold))) (cl:ecase (|fetch| (fontdescription emphasis) |of| novafont-descriptor) (0 (quote regular)) (1 (quote italic)))) (|for| i |from| 0 |to| (- (arraysize character-set-offsets) 1) |when| (neq (elt character-set-offsets i) 0) |collect| i))) (|for| i |from| 0 |to| (- (arraysize character-set-offsets) 1) |when| (neq (elt character-set-offsets i) 0) |do| (cl:setf (cl:getf (cl:getf (cl:getf (cl:getf *novafont-info* (mkatom (u-case font-name))) (|fetch| (fontdescription size) |of| novafont-descriptor)) font-face) i) (list novafont-filename (+ (elt character-set-offsets i) (elt font-offsets font-number)))))) number-of-fonts)))
)
(load-novafont-file
(lambda (|filename|) (* \; "Edited 9-Jul-87 16:23 by mdd") (cl:with-open-file (|stream| |filename| :input) (cl:multiple-value-bind (|nfonts| |fontaddrs|) (read-novafont-fileheader |stream|) (* |;;| " loop through the font nodes. fontAddrs are relative to wd 0 of file and have been converted to byte offsets when read in.") (|for| |fontnumber| |from| 1 |to| |nfonts| |bind| |name| |fontdescriptor| |charsetaddrs| |fontpos| |font| |font-face| (|rasterinfos| ← (array 256 (quote word) 0 0)) (|fontprinterwidths| ← (array 256 (quote word) 0 0)) (|fontspacingwidths| ← (array 256 (quote byte) 0 0)) |do| (setq |fontpos| (elt |fontaddrs| |fontnumber|)) (* |;;| "read the second level FontTreeNode (known as a font header, since it collects the character sets of the font)") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (cl:multiple-value-setq (|name| |fontdescriptor| |charsetaddrs|) (read-novafont-fontheader |stream| |fontpos|)) (* |;;| "now read the third level char set nodes") (setq |font-face| (list (cl:ecase (|fetch| (fontdescription weight) |of| |fontdescriptor|) (0 (quote light)) (1 (quote medium)) (2 (quote bold))) (cl:ecase (|fetch| (fontdescription emphasis) |of| |fontdescriptor|) (0 (quote regular)) (1 (quote italic))) (quote regular))) (setq |name| (mkatom (u-case |name|))) (setq |font| (|create| fontdescriptor fontdevice ← (quote display) fontfamily ← |name| fontsize ← (|fetch| (fontdescription size) |of| |fontdescriptor|) fontface ← |font-face| |\\SFAscent| ← 0 |\\SFDescent| ← 0 |\\SFHeight| ← 0 rotation ← 0 fontdevicespec ← (list |name| (|fetch| (fontdescription size) |of| |fontdescriptor|) |font-face| 0 (quote display)))) (|for| \j |from| 0 |to| (- (arraysize |charsetaddrs|) 1) |bind| |csinfo| |charsetoffset| |do| (setq |charsetoffset| (elt |charsetaddrs| \j)) (|if| (neq |charsetoffset| 0) |then| (* |;;| "read in enough to get charSet # and bc,ec ") (setq |csinfo| (\\readnovafontfile.display |stream| (plus |fontpos| |charsetoffset|) nil nil nil \j |rasterinfos| |fontprinterwidths| |fontspacingwidths|)) (|replace| |\\SFAscent| |of| |font| |with| (imax (|fetch| |\\SFAscent| |of| |font|) (|fetch| charsetascent |of| |csinfo|))) (|replace| |\\SFDescent| |of| |font| |with| (imax (|fetch| |\\SFDescent| |of| |font|) (|ffetch| charsetdescent |of| |csinfo|))) (|replace| |\\SFHeight| |of| |font| |with| (iplus (|fetch| |\\SFAscent| |of| |font|) (|ffetch| |\\SFDescent| |of| |font|))) (\\setcharsetinfo (|ffetch| fontcharsetvector |of| |font|) \j |csinfo|))) (|replace| (fontdescriptor fontavgcharwidth) |of| |font| |with| (\\avgcharwidth |font|)) (setfontdescriptor |name| (|fetch| (fontdescription size) |of| |fontdescriptor|) |font-face| 0 (quote display) |font|)))))
)
)
(* |;;;| "the parts necessary for using with FONTCREATE")
(defineq
(\\readnovafontfile.display
(lambda (stream offset family size face charset rasterinfos fontprinterwidths fontspacingwidths) (* \; "Edited 9-Jul-87 16:23 by mdd") (declare (globalvars \\syspilotbbt)) (setfileptr stream offset) (let ((charsetinfo (|create| charsetinfo imagewidths ← (\\createcsinfoelement))) (charsetheader (read-block-of-bytes stream charsetblockbytesize)) rasteroffset rawrasters) (|replace| (charsetinfo charsetascent) |of| charsetinfo |with| (|fetch| (charsetblock ascent) |of| charsetheader)) (|replace| (charsetinfo charsetdescent) |of| charsetinfo |with| (|fetch| (charsetblock descent) |of| charsetheader)) (setfileptr stream (+ offset charsetblockbytesize)) (* |;;| "read the raster information, spacing for the printer (not used here) and spacing for the display as they are stored in the novafont file") (or (and rasterinfos (arrayp rasterinfos) (eq (arraysize rasterinfos) 256)) (setq rasterinfos (array 256 (quote word) 0 0))) (ain rasterinfos 0 (arraysize rasterinfos) stream) (or (and fontprinterwidths (arrayp fontprinterwidths) (eq (arraysize fontprinterwidths) 256)) (setq fontprinterwidths (array 256 (quote word) 0 0))) (ain fontprinterwidths 0 (arraysize fontprinterwidths) stream) (or (and fontspacingwidths (arrayp fontspacingwidths) (eq (arraysize fontspacingwidths) 256)) (setq fontspacingwidths (array 256 (quote byte) 0 0))) (ain fontspacingwidths 0 (arraysize fontspacingwidths) stream) (* |;;| "position to the start of the rasters, after the rasterinfo (256 words), printer width (256 words) and spacing width (256 bytes) arrays (this should be a noop if there's no padding)") (setfileptr stream (+ offset charsetblockbytesize (+ 256 (cl:* 256 bytesperword 2)))) (* |;;| "the rasters should be all the remaining storage in the character set block.") (setq rawrasters (read-block-of-bytes stream (- (cl:* bytesperword (|fetch| (charsetblock size) |of| charsetheader)) (+ (+ 256 (cl:* 256 bytesperword 2)) charsetblockbytesize)))) (* |;;| "process the novafont format information to that required for a regular font descriptor. We must compute the actual image width based on the kerning information (bits 15 and 16) passed in the raster infos. The \"slug\" is always the first character in a novafont. ") (|for| character |from| 1 |to| 255 |bind| (slugrasterinfo ← (elt rasterinfos 0)) |first| (* |;;| "we set up the slug first, then process all the other characters") (\\fsetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) 0 0) (\\fsetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) 0 (elt fontspacingwidths 0)) (\\fsetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) 0 (+ (elt fontspacingwidths 0) (logand (rsh (elt rasterinfos 0) 14) 1) (rsh (elt rasterinfos 0) 15))) (setq rasteroffset (\\fgetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) 0)) |do| (\\fsetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) character (elt fontspacingwidths character)) (\\fsetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) character (+ (elt fontspacingwidths character) (logand (rsh (elt rasterinfos character) 14) 1) (rsh (elt rasterinfos character) 15))) (|if| (not (equal (elt rasterinfos character) slugrasterinfo)) |then| (\\fsetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) character rasteroffset) (setq rasteroffset (+ rasteroffset (\\fgetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) character))))) (* |;;| "we used the rasteroffset calculated above to determine the width of the character bitmap that we must create -- otherwise this would be folded into the previous loop. We also allocate some extra bits in case we have to fake the space character") (|replace| (charsetinfo charsetbitmap) |of| charsetinfo |with| (bitmapcreate (+ rasteroffset (\\fgetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) 0)) (|fetch| (charsetblock height) |of| charsetheader))) (* |;;| "set up the slug first to speed up the check in the next loop") (\\textblt \\syspilotbbt (\\addbase rawrasters (logand (elt rasterinfos 0) 16383)) (\\fgetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) 0) (|fetch| (charsetblock height) |of| charsetheader) (|fetch| (charsetinfo charsetbitmap) |of| charsetinfo) (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) 0)) (* |;;| "extract the bitmaps for all the characters in the font.") (|for| character |from| 1 |to| 255 |bind| (height ← (|fetch| (charsetblock height) |of| charsetheader)) (slugoffset ← (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) 0)) |when| (not (eql slugoffset (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) character))) |do| (\\textblt \\syspilotbbt (\\addbase rawrasters (logand (elt rasterinfos character) 16383)) (\\fgetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) character) height (|fetch| (charsetinfo charsetbitmap) |of| charsetinfo) (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) character))) (* |;;| "if this is character set 0, and the space is a slug then we've got to fix up a space at the end of the bitmaps. For now we'll make it a 1 ex space.") (|if| (and (eq charset 0) (eql (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) 0) (\\fgetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) (charcode sp)))) |then| (\\fsetoffset (|fetch| (charsetinfo offsets) |of| charsetinfo) (charcode sp) rasteroffset) (\\fsetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) (charcode sp) (\\fgetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) (charcode \x))) (\\fsetimagewidth (|fetch| (charsetinfo imagewidths) |of| charsetinfo) (charcode sp) (\\fgetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) (charcode \x)))) (* |;;| "finally, return the newly created charsetinfo") charsetinfo))
)
(\\readnovafontfile.ip
(lambda (stream offset charset charsetinfo) (* \; "Edited 9-Apr-87 14:42 by Briggs") (setfileptr stream offset) (let ((charsetheader (read-block-of-bytes stream charsetblockbytesize)) fontprinterwidths minus-fbboy) (* |;;| "Descent from -FBBOY -- note that -FBBOY *could* be negative (lose!)") (|if| (ilessp (setq minus-fbboy (iminus (signed (|fetch| (charsetblock fbboy) |of| charsetheader) bitsperword))) 0) |then| (|replace| (charsetinfo charsetdescent) |of| charsetinfo |with| 0) (|replace| (charsetinfo charsetascent) |of| charsetinfo |with| (|fetch| (charsetblock fbbdy) |of| charsetheader)) |else| (|replace| (charsetinfo charsetdescent) |of| charsetinfo |with| minus-fbboy) (|replace| (charsetinfo charsetascent) |of| charsetinfo |with| (idifference (|fetch| (charsetblock fbbdy) |of| charsetheader) minus-fbboy))) (setfileptr stream (+ offset charsetblockbytesize)) (* |;;| "read the raster information, spacing for the printer (not used here) and spacing for the display as they are stored in the novafont file") (setq rasterinfos (array 256 (quote word) 0 0)) (ain rasterinfos 0 (arraysize rasterinfos) stream) (setq fontprinterwidths (array 256 (quote word) 0 0)) (ain fontprinterwidths 0 (arraysize fontprinterwidths) stream) (|for| character |from| 0 |to| 255 |do| (\\fsetwidth (|fetch| (charsetinfo widths) |of| charsetinfo) character (elt fontprinterwidths character))) charsetinfo))
)
)
(* |;;;| "modified versions of functions from the default font handling system")
(* |;;| "advise doesn't work in released lyric, so do this with movds")
(movd? (quote \\readdisplayfontfile) (quote \\no-nova-readdisplayfontfile))
(movd? (quote \\createcharset.ip) (quote \\no-nova-createcharset.ip))
(defineq
(\\readdisplayfontfile
(lambda (family size face rotation device charset) (* \; "Edited 17-Dec-87 18:17 by Masinter") (or (let ((cs (cl:getf (cl:getf (cl:getf (cl:getf *novafont-info* (u-case family)) size) (+ (cl:ecase (cadr face) (regular 0) (italic 1)) (cl:* 2 (cl:ecase (car face) (light 0) (medium 1) (bold 2))))) (or charset (setq charset 0))))) (cl:when cs (cl:with-open-file (stream (car cs) :direction :input) (\\readnovafontfile.display stream (cadr cs) family size face charset)))) (\\no-nova-readdisplayfontfile family size face rotation device charset)))
)
(\\createcharset.ip
(lambda (family psize face rotation device charset fontdesc noslug?) (* \; "Edited 17-Dec-87 18:16 by Masinter") (or (let ((cs (cl:getf (cl:getf (cl:getf (cl:getf *novafont-info* (u-case family)) psize) (+ (cl:ecase (cadr face) (regular 0) (italic 1)) (cl:* 2 (cl:ecase (car face) (light 0) (medium 1) (bold 2))))) (or charset (setq charset 0))))) (and cs (cl:with-open-file (stream (car cs) :direction :input) (\\readnovafontfile.ip stream (cadr cs) charset (|create| charsetinfo))))) (\\no-nova-createcharset.ip family psize face rotation device charset fontdesc noslug?)))
)
)
(* |;;;| "the parts for general hacking of the NOVAFONT files")
(defineq
(describe-font
(lambda (name fontdescriptor charsetheader fontspacingwidths fontprinterwidths fontraster) (* |briggs| "11-Nov-86 22:58") (|if| (and (boundp (quote lastfontdescriptor)) (neq fontdescriptor lastfontdescriptor)) |then| (setq lastfontdescriptor fontdescriptor) (printout t t name ":" \, (|fetch| (fontdescription size) |of| fontdescriptor) "pt. " (case (|fetch| (fontdescription weight) |of| fontdescriptor) (0 "light ") (1 "medium ") (2 "bold ") (otherwise "unknown ")) (case (|fetch| (fontdescription emphasis) |of| fontdescriptor) (0 "regular") (1 "italic") (otherwise "unknown")) " character sets: ")) (printout t (|fetch| (charsetblock charsetnum) |of| charsetheader) \,))
)
(select-font
(lambda (name fontdescriptor charsetheader fontspacingwidths fontprinterwidths fontraster) (* briggs " 6-Nov-86 23:14") (|if| (eql 12 (|fetch| (fontdescription size) |of| fontdescriptor)) |then| (cl:assert nil)))
)
(enumerate-fonts
(lambda (stream proc read-rasters-p) (* |briggs| "11-Nov-86 23:03") (* |;;| "\"assumes stream is open to a viewpoint font file with read access. Calls PROC for each font in the file. Used in listing the contents of a ViewPoint screenfont file. Returns error TRUE of an error of any kind occurs in working through the file (I/O errors, format errors, etc.)\"") (setfileptr stream 0) (or (viewpoint-font-file-p stream) (cl:error "not a font file")) (let (fontaddrs nfonts) (cl:multiple-value-setq (nfonts fontaddrs) (read-novafont-fileheader stream)) (* |;;| " loop through the font nodes. fontAddrs are relative to wd 0 of file and have been converted to byte offsets when read in.") (|for| fontnumber |from| 1 |to| nfonts |bind| name fontdescriptor charsetaddrs fontpos |do| (setq fontpos (elt fontaddrs fontnumber)) (* |;;| "read the second level FontTreeNode (known as a font header, since it collects the character sets of the font)") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (cl:multiple-value-setq (name fontdescriptor charsetaddrs) (read-novafont-fontheader stream fontpos)) (* |;;| "now read the third level char set nodes") (|for| j |from| 0 |to| (- (arraysize charsetaddrs) 1) |bind| charsetheader fontspacingwidths fontprinterwidths fontraster rasteroffsets charsetoffset |do| (setq charsetoffset (elt charsetaddrs j)) (|if| (neq charsetoffset 0) |then| (* |;;| "read in enough to get charSet # and bc,ec ") (cl:multiple-value-setq (charsetheader fontspacingwidths fontprinterwidths fontraster rasteroffsets) (read-novafont-characterset stream (+ fontpos charsetoffset) read-rasters-p)) (|if| proc |then| (apply* proc name fontdescriptor charsetheader fontspacingwidths fontprinterwidths fontraster rasteroffsets)) (* |;;| "Get pointsize (? bits) pitch (either fixed or variable) weight (light medium heavy other) posture (roman italic) and character set - charsetheader includes height descent") (* |;;| "SETQ STARTOFRASTERS (+ CHARSTART 1280 (* 2 FONTSEGMENTHEADERSIZE)) (LET ((FONT (create FONTDESCRIPTOR FONTDEVICE ← (QUOTE DISPLAY) FONTFAMILY ← (MKATOM (U-CASE NAME)) FONTSIZE ← SIZE FONTFACE ← FACE \\SFAscent ← 0 \\SFDescent ← 0 \\SFHeight ← 0 ROTATION ← ROTATION)) (CSI (CREATE CHARSETINFO)))) (FILLINFONTOBJECT FONT FONTINFO CHARSETHEADER STARMODE) (FUNCALL PROC FONT BC EC FONTPOS CHARSETPOS)"))))))
)
(viewpoint-font-file-p
(lambda (stream) (* |briggs| "11-Nov-86 22:44") "assumes stream is open to a file with read access. returns TRUE iff the file is a ViewPoint screen font file" (let (fileheader firstfontaddr firstcharsetaddr) (* |;;| "read first 12 words of file & check for pattern in first 3 words") (setq fileheader (read-block-of-bytes stream fonttreenodeblockbytesize)) (|if| (|with| fonttreenodeblock fileheader (and (eq id 0) (eq type 65535) (eql (geteofptr stream) (+ fonttreenodeblockbytesize (cl:* bytesperword (+ (cl:* 2 nchildren) sizefiller1 sizechildren)))))) |then| (* |;;| "\"at this point, we could have either a ViewPoint or Star font. First follow offsets to the first char set of the first font\"") (setq firstfontaddr (progn (setfileptr stream fonttreenodeblockbytesize) (readswappedfixp stream))) (setq firstcharsetaddr (progn (setfileptr stream (+ firstfontaddr fonttreenodeblockbytesize)) (readswappedfixp stream))) (* |;;| "\"Viewpoint files contain (here) a 256 word array of kern + offset, then a 256 word array of printer widths. Offset words are zero if no character, otherwise are monotonically increasing, since bitmaps are inserted in character code order. Printer widths are initialized to a default constant value for characters with no bitmap. So if first 256 words (masked to low order 14 bits and not counting 0 values) are monotonically increasing, we have a ViewPoint file. Legal ViewPoint arrays have monotonically increasing non-zero elements, whereas star arrays will be mixed in with printer widths and will not be monotonically increasing.\"") (* |;;;| "Punt for now") t)))
)
)
(rpaqq *warn-on-kerning* nil)
(* |;;;| "things for dealing with the structure of what we read")
(declare\: eval@compile
(putprops readswappedfixp dmacro (openlambda (stream) (+ (logor (llsh (bin stream) 8) (bin stream)) (cl:ash (logor (llsh (bin stream) 8) (bin stream)) 16))))
)
(defineq
(read-block-of-bytes
(lambda (stream number-of-bytes) (* |briggs| " 9-Nov-86 23:16") (let ((result (\\allocblock (foldhi number-of-bytes bytespercell) unboxedblock.gct))) (\\bins stream result 0 number-of-bytes) (* |;;| "(|for| byteindex |from| 0 |to| (- number-of-bytes 1) |do| (\\\\putbasebyte result byteindex (bin stream)))") result))
)
(read-novafont-characterset
(lambda (stream offsettocharset read-rasters-p) (* |briggs| "11-Nov-86 23:18") (declare (globalvars *warn-on-kerning* \\syspilotbbt)) (setfileptr stream offsettocharset) (let ((charsetheader (read-block-of-bytes stream charsetblockbytesize)) rasterinfos fontprinterwidths fontspacingwidths fontraster rawraster offsetsblock) (* |;;| "The header portion of a CharacterSet contains information such as character set number, height (which is constant for all characters), max width, ascender & descender, and font bounding box.") (* |;;| "reads the raster infos array of the character set located at charsetPos and determines bc:ec") (setfileptr stream (+ offsettocharset charsetblockbytesize)) (* |;;| "The rasterinfos field is basically an array 14 bit word offsets in the fontrasters array of where each bitmap starts. The offsets are relative to the start of the fontRasters field. fontprinterwidths & fontspacingwidths are initialized to certain default values, and fontrasters starts out with a 'missing character' bitmap - a black rectangle with a one pixel white outline at each side, sitting on the baseline, and running up to the ascend of the font, such that the whole thing is exactly font height by max width in size. Bitmaps include sufficient white space so that they can be placed contiguously (or in the case of kerned ones, overlapping previous by one pixel) without additional adjustments for spacing. I.e. they are in the right format for TextBlt. Padding is added so that all FontTreeNodes and CharacterSets begin on four word boundries, for some reason that is lost in antiquity.") (setq rasterinfos (array 256 (quote word) 0 0)) (ain rasterinfos 0 (arraysize rasterinfos) stream) (setq fontprinterwidths (array 256 (quote word) 0 0)) (ain fontprinterwidths 0 (arraysize fontprinterwidths) stream) (setq fontspacingwidths (array 256 (quote byte) 0 0)) (ain fontspacingwidths 0 (arraysize fontspacingwidths) stream) (|if| *warn-on-kerning* |then| (let ((kerns (|for| i |from| 0 |to| 255 |when| (> (elt rasterinfos i) 16383) |collect| i))) (|if| kerns |then| (cl:warn "Kerning on characters~{ ~S~}." kerns)))) (|for| i |from| 0 |to| 255 |do| (|if| (>= (elt fontspacingwidths i) (|fetch| (charsetblock maxwidth) |of| charsetheader)) |then| (|replace| (charsetblock maxwidth) |of| charsetheader |with| (elt fontspacingwidths i)))) (|if| read-rasters-p |then| (setq fontraster (bitmapcreate (cl:* (|fetch| (charsetblock maxwidth) |of| charsetheader) 256) (|fetch| (charsetblock height) |of| charsetheader))) (setfileptr stream (+ offsettocharset 1280 charsetblockbytesize)) (setq rawraster (read-block-of-bytes stream (- (cl:* bytesperword (|fetch| (charsetblock size) |of| charsetheader)) (+ 1280 charsetblockbytesize)))) (setq offsetsblock (\\createcsinfoelement)) (|for| i |from| 0 |to| 254 |bind| (offset ← 0) spacingwidth |do| (|if| (or (eql i 0) (not (eql (logand (elt rasterinfos i) 16383) (logand (elt rasterinfos 0) 16383)))) |then| (setq spacingwidth (+ (elt fontspacingwidths i) (logand (rsh (elt rasterinfos i) 14) 1) (rsh (elt rasterinfos i) 15))) (cl:assert (< (+ offset spacingwidth) (bitmapwidth fontraster)) nil "Attempted to blt beyond end of bitmap") (\\textblt \\syspilotbbt (\\addbase rawraster (logand (elt rasterinfos i) 16383)) spacingwidth (|fetch| (charsetblock height) |of| charsetheader) fontraster offset) (\\fsetoffset offsetsblock i offset) (setq offset (+ offset (elt fontspacingwidths i))) |else| (\\fsetoffset offsetsblock i 0)))) (cl:values charsetheader fontspacingwidths fontprinterwidths (|if| read-rasters-p |then| fontraster |else| nil) (|if| read-rasters-p |then| offsetsblock |else| nil))))
)
(read-novafont-fileheader
(cl:lambda (stream) (* \; "Edited 24-Nov-86 22:41 by BRIGGS") (* |;;| "reads file header of an open viewpoint font file to determine number of fonts, allocates an array to hold their offsets from beginning of file, and reads in those font offsets. While reading it converts from WORD offsets to BYTE offsets. This function also verifies that what it is passed is a plausible NOVAFONT format file.") (let (nfonts fileheaderbuffer fontaddrs filesize) (setq filesize (geteofptr stream)) (* |;;| "verify that there are enough bytes to be a plausible font file") (cl:assert (>= filesize fonttreenodeblockbytesize) nil "~(~A~) is not a NOVAFONT format font file." (fullname stream)) (setfileptr stream 0) (setq fileheaderbuffer (read-block-of-bytes stream fonttreenodeblockbytesize)) (* |;;| "check that what we read is a plausible font file header") (cl:assert (|with| fonttreenodeblock fileheaderbuffer (and (eq id 0) (eq type 65535) (eql filesize (+ fonttreenodeblockbytesize (cl:* bytesperword (+ (cl:* 2 nchildren) sizefiller1 sizechildren)))))) nil "~(~A~) is not a NOVAFONT format font file." (fullname stream)) (setq nfonts (|fetch| (fonttreenodeblock nchildren) |of| fileheaderbuffer)) (setq fontaddrs (array nfonts (quote fixp) 0 1)) (|for| i |from| 1 |to| nfonts |do| (seta fontaddrs i (cl:* (readswappedfixp stream) bytesperword))) (cl:values nfonts fontaddrs)))
)
(read-novafont-fontheader
(cl:lambda (stream fontpos) (* \; "Edited 23-Nov-86 12:38 by MASINTER") (* |;;| "reads font header located at fontPos into fontHeaderBuffer. Returns number of character sets in ncharSets, allocates an array to hold their word offsets from beginning of font block, and reads in those offsets.") (* |;;| "reads font header located at fontBlockPos into fontHeaderBuffer. Also returns the name of the font") (declare (globalvars \\novafontfamilynames)) (let (fontheader maxcharsetnumber charsetaddrs fontdescriptor name) (setfileptr stream fontpos) (setq fontheader (read-block-of-bytes stream fonttreenodeblockbytesize)) (setq maxcharsetnumber (|fetch| (fonttreenodeblock nchildren) |of| fontheader)) (setq charsetaddrs (array maxcharsetnumber (quote fixp) 0 0)) (setfileptr stream (+ fontpos fonttreenodeblockbytesize)) (|for| i |from| 0 |to| (- maxcharsetnumber 1) |do| (* |;;| "contains swapped count of 16-bit words, turn into count of number of bytes") (seta charsetaddrs i (cl:* 2 (readswappedfixp stream)))) (* |;;| "skip to the nodeInfo field, which is of type FontInfo") (setfileptr stream (+ fontpos fonttreenodeblockbytesize (cl:* 2 (+ (cl:* 2 maxcharsetnumber) (|fetch| (fonttreenodeblock sizefiller1) |of| fontheader))))) (cl:assert (eql (bin16 stream) 3325)) (setq fontdescriptor (read-block-of-bytes stream fontdescriptionbytesize)) (bin stream) (* \; "a piece of junk") (setq name (let* ((size (bin stream)) (string (allocstring size))) (|for| i |from| 1 |to| size |do| (rplcharcode string i (bin stream))) string)) (|if| (zerop (nchars name)) |then| (* |;;| "ugh! no name, try to guess from the family number") (setq name (or (cdr (assoc (|fetch| (fontdescription family) |of| fontdescriptor) \\novafontfamilynames)) (concat "UnknownFont-" (|fetch| (fontdescription family) |of| fontdescriptor))))) (cl:values name fontdescriptor charsetaddrs)))
)
(\\textblt
(lambda (pilotbbt |SourceHunk| |SourceWidth| |SourceHeight| |DestinationBitMap| |DestinationLeft|) (* \; "Edited 12-Mar-87 18:00 by Briggs") (\\dtest pilotbbt (quote pilotbbt)) (\\dtest |DestinationBitMap| (quote bitmap)) (uninterruptably (|freplace| (pilotbbt pbtflags) |of| pilotbbt |with| 0) (|freplace| (pilotbbt pbtdestbpl) |of| pilotbbt |with| (unfold (|ffetch| (bitmap bitmaprasterwidth) |of| |DestinationBitMap|) bitsperword)) (|freplace| (pilotbbt pbtdestbit) |of| pilotbbt |with| |DestinationLeft|) (|freplace| (pilotbbt pbtusegray) |of| pilotbbt |with| nil) (* \; "the raster width of the source") (|freplace| (pilotbbt pbtsourcebpl) |of| pilotbbt |with| |SourceWidth|) (|freplace| (pilotbbt pbtwidth) |of| pilotbbt |with| |SourceWidth|) (|freplace| (pilotbbt pbtheight) |of| pilotbbt |with| |SourceHeight|) (|freplace| (pilotbbt pbtsourcebit) |of| pilotbbt |with| 0) (|freplace| (pilotbbt pbtdisjoint) |of| pilotbbt |with| t) (|freplace| (pilotbbt pbtsource) |of| pilotbbt |with| |SourceHunk|) (|freplace| (pilotbbt pbtdest) |of| pilotbbt |with| (|ffetch| (bitmap bitmapbase) |of| |DestinationBitMap|)) (\\setpbtfunction pilotbbt (quote input) (quote paint)) (\\pilotbitblt pilotbbt 0)))
)
)
(* |;;;| "the datastructures that we use and their sizes")
(declare\: eval@compile dontcopy
(declare\: eval@compile
(blockrecord fonttreenodeblock ((id fixp) (type word) (nchildren word) (sizefiller1 swappedfixp) (sizenodeinfo swappedfixp) (sizefiller2 swappedfixp) (sizechildren swappedfixp) (dummy-last-field-dont-reference-this word))
)
(blockrecord charsetblock ((size swappedfixp) (version word) (charsetnum word) (maxwidth word) (height word) (ascent word) (descent word) (fbbox word) (fbboy word) (fbbdx word) (fbbdy word) (dummy-last-field-dont-reference-this word))
)
(blockrecord fontdescription ((size bits 8) (weight bits 2) (emphasis bits 1) (underline bits 1) (strikeout bits 1) (placement bits 3) (mbz1 bits 1) (pitch bits 1) (ornateness bits 1) (family bits 12) (mbz2 bits 1) (mbz3 bits 1) (offset bits 14) (mbz4 bits 1) (mbz5 bits 1) (doubleunderline bits 1) (unused bits 14) (dummy-last-field-dont-reference-this word))
)
)
(declare\: eval@compile
(rpaq fonttreenodeblockbytesize (constant (itimes bytesperword (indexf (fetch (fonttreenodeblock dummy-last-field-dont-reference-this) of t))))
)
(rpaq charsetblockbytesize (constant (itimes bytesperword (indexf (fetch (charsetblock dummy-last-field-dont-reference-this) of t))))
)
(rpaq fontdescriptionbytesize (constant (itimes bytesperword (indexf (fetch (fontdescription dummy-last-field-dont-reference-this) of t))))
)
(constants (fonttreenodeblockbytesize (constant (itimes bytesperword (indexf (fetch (fonttreenodeblock dummy-last-field-dont-reference-this) of t))))) (charsetblockbytesize (constant (itimes bytesperword (indexf (fetch (charsetblock dummy-last-field-dont-reference-this) of t))))) (fontdescriptionbytesize (constant (itimes bytesperword (indexf (fetch (fontdescription dummy-last-field-dont-reference-this) of t))))))
)
)
(declare\: eval@compile donteval@load docopy
)
(* |;;;|
"the mapping from font family number to font family name for those fonts which don't have the name embedded in the font file."
)
(declare\: eval@compile
(rpaqq \\novafontfamilynames ((0 . |Classic|) (1 . |Modern|) (2 . |Titan|) (3 . |Pica|) (4 . |Trojan|) (5 . |Vintage|) (6 . |Elite|) (7 . |LetterGothic|) (8 . |Master|) (9 . |Cubic|) (10 . |Roman|) (11 . |Scientific|) (12 . |Gothic|) (13 . |Bold|) (14 . |OcrB|) (15 . |Spokesman|) (16 . |XeroxLogo|) (17 . |CenturyThin|) (18 . |ScientificThin|) (19 . |Helvetica|) (20 . |HelveticaCondensed|) (21 . |Optima|) (22 . |Times|) (23 . |Baskerville|) (24 . |Spartan|) (25 . |Bodoni|) (26 . |Palatino|) (27 . |Caledonia|) (28 . |Memphis|) (29 . |Excelsior|) (30 . |Olympian|) (31 . |Univers|) (32 . |UniversCondensed|) (33 . |Trend|) (34 . |BoxPS|) (35 . |Terminal|) (36 . |OcrA|) (37 . |Logo1|) (38 . |Logo2|) (39 . |Logo3|) (40 . |Geneva2|) (41 . |Times2|) (42 . |Square3|) (43 . |Courier|) (44 . |Futura|) (45 . |Prestige|) (46 . |ALLetterGothic|) (47 . |CenturySchoolBook|) (48 . |Spare1|) (49 . |Spare2|) (50 . |Spare3|) (51 . |Spare4|) (52 . |Spare5|) (53 . |Melior|) (54 . |PCTerminal|) (55 . |ITCAmericanTypewriter|) (56 . |ITCAvantGardeGothic|) (57 . |ITCAvantGardeGothicCondensed|) (58 . |ITCBauhaus|) (59 . |ITCBarcelona|) (60 . |ITCBenguiat|) (61 . |ITCBenguiatCondensed|) (62 . |ITCBenguiatGothic|) (63 . |ITCBerkeleyOldStyle|) (64 . |ITCBookman|) (65 . |ITCCaslonNo224|) (66 . |ITCCentury|) (67 . |ITCCheltenham|) (68 . |ITCClearface|) (69 . |ITCCushing|) (70 . |ITCEras|) (71 . |ITCFenice|) (72 . |ITCFranklinGothic|) (73 . |ITCFrizQuadrata|) (74 . |ITCGalliard|) (75 . |ITCGaramond|) (76 . |ITCIsbell|) (77 . |ITCItalia|) (78 . |ITCKabel|) (79 . |ITCKorinna|) (80 . |ITCLubalinGraph|) (81 . |ITCModernNo216|) (82 . |ITCNewBaskerville|) (83 . |ITCNewtext|) (84 . |ITCNovarese|) (85 . |ITCQuorum|) (86 . |ITCSerifGothic|) (87 . |ITCSouvenir|) (88 . |ITCSymbol|) (89 . |ITCTiffany|) (90 . |ITCUsherwood|) (91 . |ITCWeidemann|) (92 . |ITCVeljovic|) (93 . |ITCZapfBook|) (94 . |ITCZapfChancery|) (95 . |ITCZapfDingbats|) (96 . |ITCZapfInternational|) (97 . |Cipher|) (98 . |FlemishScriptII|) (99 . |Quartz|) (100 . |QuartzA|) (101 . |QuartzT|) (102 . |Souvenir|) (103 . |Shimmer|) (104 . apl) (105 . |Arrows|) (106 . |BravoX|) (107 . |ClassicPiOne|) (108 . |ClassicPiTwo|) (109 . |Cream|) (110 . |Cyrillic|) (111 . |Dots|) (112 . |Gacha|) (113 . |Gates|) (114 . |HelveticaD|) (115 . |Hippo|) (116 . |Keyhole|) (117 . |Laurel|) (118 . |LogoOutline|) (119 . |LSIGates|) (120 . |MarqHippo|) (121 . |MarqRoman|) (122 . |Math|) (123 . |Mathology|) (124 . |OldEnglish|) (125 . |RomanPS|) (126 . |Sigma|) (127 . |Splunk|) (128 . |Template|) (129 . |Testfont|) (130 . |TimesRoman|) (131 . |TimesRomanD|) (132 . |TitanLegal|) (133 . wssa) (134 . |XeroxBook|) (135 . |LucidaRoman|) (136 . |MonoSpace|) (137 . |Spare6|) (138 . |Spare7|) (139 . |Spare8|) (140 . |Spare9|) (141 . |Spare10|))
)
(constants \\novafontfamilynames)
)
(* |;;;|
"initialize the \"noticed\" fonts structure and set up the extensions so we can use the font files")
(defglobalvar *novafont-info* nil)
(* |;;;| "correct some omissions in the family aliases and printwheel fonts")
(listput interpressfamilyaliases (quote xeroxlogo) (quote logotypes-xerox))
(|pushnew| interpressprintwheelfamilies (quote scientificthin) (quote ocrb) (quote ocra))
(* |;;;| "some things we need for compiling. Also need EXPORTS.ALL")
(declare\: eval@compile dontcopy
(filesload (loadcomp) interpress)
)
(* |;;;| "some hints for the compiler (system generated)")
(declare\: donteval@load doeval@compile dontcopy compilervars
(addtovar nlama )
(addtovar nlaml )
(addtovar lama read-novafont-fontheader read-novafont-fileheader)
)
(putprops novafont copyright ("Xerox Corporation" 1986 1987))
(declare\: dontcopy
(filemap (nil (3189 7988 (notice-novafont-file 3199 . 5078) (load-novafont-file 5080 . 7986)) (8055
15313 (\\readnovafontfile.display 8065 . 13880) (\\readnovafontfile.ip 13882 . 15311)) (15629 16817 (
\\readdisplayfontfile 15639 . 16212) (\\createcharset.ip 16214 . 16815)) (16890 21995 (describe-font
16900 . 17595) (select-font 17597 . 17828) (enumerate-fonts 17830 . 20359) (viewpoint-font-file-p
20361 . 21993)) (22291 30848 (read-block-of-bytes 22301 . 22645) (read-novafont-characterset 22647 .
26330) (read-novafont-fileheader 26332 . 27735) (read-novafont-fontheader 27737 . 29628) (\\textblt
29630 . 30846)))))
stop