FONT, EDITFONT: Cleanup strike font reading and writing (#845)
EDITFONThad its own slightly different version. Now centralized in FONT with slight adjustments to internal interfaces. Note that we don't have a way of writing AC font files, as near as I can tell
This commit is contained in:
rmkaplan
GitHub
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Jun-2022 10:59:12"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITFONT.;5 38667
|
||||
(FILECREATED "12-Jul-2022 14:18:56"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>lispusers>EDITFONT.;10 28741
|
||||
|
||||
:CHANGES-TO (FNS EDITFONT EF.EDIT)
|
||||
:CHANGES-TO (FNS READSTRIKEFONTFILE)
|
||||
(VARS EDITFONTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "26-Aug-86 16:23:09"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITFONT.;1)
|
||||
:PREVIOUS-DATE "27-Jun-2022 10:59:12"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>lispusers>EDITFONT.;5)
|
||||
|
||||
|
||||
(* ; "
|
||||
@@ -16,44 +17,26 @@ Copyright (c) 1985-1986 by Xerox Corporation.
|
||||
(PRETTYCOMPRINT EDITFONTCOMS)
|
||||
|
||||
(RPAQQ EDITFONTCOMS
|
||||
((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in order to compile
|
||||
this file. *)
|
||||
(CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2)
|
||||
(MAXCODE 255)
|
||||
(DUMMYINDEX 256))
|
||||
((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
|
||||
(INITVARS (EF.MENU NIL)
|
||||
(EF.TITLEMENU NIL))
|
||||
(RECORDS CHARITEM)
|
||||
(FNS EF.INIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.BUTTONEVENTFN EF.WHENSELECTEDFN
|
||||
EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE EF.BLANK
|
||||
COPYFONT READSTRIKEFONTFILE WRITESTRIKEFONTFILE)
|
||||
COPYFONT READSTRIKEFONTFILE)
|
||||
(FNS BLANKFONTCREATE EDITFONT)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
FONT))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2)
|
||||
(MAXCODE 255)
|
||||
(DUMMYINDEX 256))
|
||||
(FILES (LOADCOMP)
|
||||
FONT))
|
||||
(P (EF.INIT))))
|
||||
|
||||
|
||||
|
||||
(* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL and LOADFROM FONT in order to compile this
|
||||
file. *)
|
||||
(* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ BITSPERWORD 16)
|
||||
|
||||
(RPAQQ BYTESPERWORD 2)
|
||||
|
||||
(RPAQQ MAXCODE 255)
|
||||
|
||||
(RPAQQ DUMMYINDEX 256)
|
||||
|
||||
|
||||
(CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2)
|
||||
(MAXCODE 255)
|
||||
(DUMMYINDEX 256))
|
||||
)
|
||||
|
||||
(RPAQ? EF.MENU NIL)
|
||||
|
||||
@@ -466,166 +449,33 @@ file. *)
|
||||
(RETURN NEWFONT])
|
||||
|
||||
(READSTRIKEFONTFILE
|
||||
[LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET) (* kbr%: "14-Oct-85 11:16")
|
||||
(* Very similar to \READSTRIKEFONTFILE
|
||||
of <LISPCORE>SOURCES>FONT.
|
||||
Returns fontdescriptor FONT.
|
||||
*)
|
||||
(PROG (STRM CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
|
||||
(* This part imitates
|
||||
\READSTRIKEFONTFILE *)
|
||||
(SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD))
|
||||
(SETQ CSINFO (create CHARSETINFO))
|
||||
(\WIN STRM)
|
||||
(SETQ FIRSTCHAR (\WIN STRM)) (* minimum ascii code)
|
||||
(SETQ LASTCHAR (\WIN STRM)) (* maximum ascii code)
|
||||
(\WIN STRM) (* MaxWidth which isn't used by
|
||||
anyone.)
|
||||
(\WIN STRM) (* number of words in this StrikeBody)
|
||||
(replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM))
|
||||
(* ascent in scan lines
|
||||
(=FBBdy+FBBoy))
|
||||
(replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM))
|
||||
(* descent in scan-lines
|
||||
(=FBBoy))
|
||||
(\WIN STRM) (* offset in bits (<0 for kerning,
|
||||
else 0, =FBBox))
|
||||
(SETQ RW (\WIN STRM)) (* raster width of bitmap)
|
||||
(* height of bitmap)
|
||||
(SETQ HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
|
||||
(SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
|
||||
HEIGHT))
|
||||
(\BINS STRM (fetch (BITMAP BITMAPBASE) of BITMAP)
|
||||
0
|
||||
(UNFOLD (ITIMES RW HEIGHT)
|
||||
BYTESPERWORD)) (* read bits into bitmap)
|
||||
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)
|
||||
(SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR)
|
||||
3)) (* SETQ OFFSETS (ARRAY
|
||||
(IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0
|
||||
0))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
(* initialise the offsets to 0)
|
||||
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0))
|
||||
(* AIN OFFSETS FIRSTCHAR NUMBCODES
|
||||
STRM)
|
||||
(for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM)))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0))
|
||||
(* replace WIDTHS of CSINFO with
|
||||
(ARRAY (IPLUS \MAXCHAR 3)
|
||||
(QUOTE SMALLPOSP) 0 0))
|
||||
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(CLOSEF STRM) (* This part imitates
|
||||
\CREATEDISPLAYFONT *)
|
||||
(COND
|
||||
((NULL CHARSET)
|
||||
(SETQ CHARSET 0)))
|
||||
[COND
|
||||
((NULL FONT)
|
||||
(SETQ FONT
|
||||
(create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'DISPLAY
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
ROTATION _ 0
|
||||
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
|
||||
(* This part imitates \CREATECHARSET.
|
||||
*)
|
||||
(replace (FONTDESCRIPTOR \SFAscent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFAscent)
|
||||
of FONT)
|
||||
(fetch (CHARSETINFO CHARSETASCENT)
|
||||
of CSINFO)))
|
||||
(replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent)
|
||||
of FONT)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT)
|
||||
of CSINFO)))
|
||||
[replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFHeight)
|
||||
of FONT)
|
||||
(IPLUS (fetch (CHARSETINFO
|
||||
CHARSETASCENT)
|
||||
of CSINFO)
|
||||
(fetch (CHARSETINFO
|
||||
CHARSETDESCENT)
|
||||
of CSINFO]
|
||||
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
|
||||
CHARSET CSINFO)
|
||||
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
|
||||
(RETURN FONT])
|
||||
[LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)
|
||||
|
||||
(WRITESTRIKEFONTFILE
|
||||
[LAMBDA (FONT CHARSET FILE) (* kbr%: "21-Oct-85 15:08")
|
||||
(* Write strike FILE using info in
|
||||
FONT. *)
|
||||
(PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTH MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET
|
||||
OFFSET PREVIOUSOFFSET WIDTH CODE)
|
||||
(COND
|
||||
((NOT (FONTP FONT))
|
||||
(LISPERROR "ILLEGAL ARG" FONT)))
|
||||
(COND
|
||||
((NULL CHARSET)
|
||||
(SETQ CHARSET 0))
|
||||
((NOT (AND (IGEQ CHARSET 0)
|
||||
(ILESSP CHARSET \MAXCHARSET)))
|
||||
(LISPERROR "ILLEGAL ARG" CHARSET)))
|
||||
(SETQ CSINFO (\GETCHARSETINFO CHARSET FONT T))
|
||||
(COND
|
||||
((NULL CSINFO)
|
||||
(ERROR "Couldn't find charset " CHARSET)))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
|
||||
[SETQ FIRSTCHAR (for I from 0 to MAXCODE thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
|
||||
DUMMYOFFSET]
|
||||
[SETQ LASTCHAR (for I from MAXCODE to 0 by -1 thereis (NOT (EQ (\FGETOFFSET OFFSETS I)
|
||||
DUMMYOFFSET]
|
||||
(SETQ DUMMYCHAR (ADD1 LASTCHAR))
|
||||
[SETQ STREAM (OPENSTREAM FILE 'OUTPUT 'NEW '((TYPE BINARY]
|
||||
(* STRIKE HEADER. *)
|
||||
(\WOUT STREAM 32768)
|
||||
(\WOUT STREAM FIRSTCHAR)
|
||||
(\WOUT STREAM LASTCHAR)
|
||||
(SETQ MAXWIDTH 0)
|
||||
[for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I]
|
||||
(\WOUT STREAM MAXWIDTH) (* STRIKE BODY. *)
|
||||
(* Length. *)
|
||||
(SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP)
|
||||
of CSINFO)))
|
||||
(SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
|
||||
(ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT)
|
||||
RASTERWIDTH)))
|
||||
(\WOUT STREAM LENGTH) (* Ascent, Descent, Xoffset
|
||||
(no longer used) and Rasterwidth.
|
||||
*)
|
||||
(\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO))
|
||||
(\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
|
||||
(\WOUT STREAM 0)
|
||||
(\WOUT STREAM RASTERWIDTH) (* Bitmap. *)
|
||||
[\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP)
|
||||
of CSINFO))
|
||||
0
|
||||
(ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]
|
||||
(* Offsets. *)
|
||||
(SETQ CODE 0)
|
||||
(\WOUT STREAM CODE)
|
||||
(for I from FIRSTCHAR to DUMMYCHAR do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
|
||||
(SETQ WIDTH (\FGETWIDTH WIDTHS I))
|
||||
[COND
|
||||
((AND (IEQP OFFSET DUMMYOFFSET)
|
||||
(NOT (IEQP I DUMMYCHAR)))
|
||||
(* CODE stays the same.
|
||||
*)
|
||||
)
|
||||
(T (SETQ CODE (IPLUS CODE WIDTH]
|
||||
(\WOUT STREAM CODE))
|
||||
(CLOSEF STREAM])
|
||||
(* ;; "Edited 12-Jul-2022 14:16 by rmk: Removed slightlly different implementations of \READSTRIKEFONTFILE and charset installation in favor of common code in FONT.")
|
||||
|
||||
(* ;; "Edited 12-Jul-2022 13:33 by rmk")
|
||||
(* kbr%: "14-Oct-85 11:16")
|
||||
(CL:UNLESS CHARSET (SETQ CHARSET 0)) (* ; "Returns fontdescriptor FONT. *")
|
||||
(LET (STRM CSINFO)
|
||||
(SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD))
|
||||
(\WIN STRM)
|
||||
(SETQ CSINFO (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
|
||||
(CLOSEF STRM) (* ;
|
||||
"This part imitates \CREATEDISPLAYFONT *")
|
||||
(CL:UNLESS FONT
|
||||
[SETQ FONT
|
||||
(create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'DISPLAY
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
ROTATION _ 0
|
||||
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY])
|
||||
(\INSTALLCHARSETINFO FONT CSINFO CHARSET)
|
||||
FONT])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -671,6 +521,23 @@ file. *)
|
||||
(WINDOWPROP WINDOW 'BUTTONEVENTFN 'EF.BUTTONEVENTFN])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ BITSPERWORD 16)
|
||||
|
||||
(RPAQQ BYTESPERWORD 2)
|
||||
|
||||
(RPAQQ MAXCODE 255)
|
||||
|
||||
(RPAQQ DUMMYINDEX 256)
|
||||
|
||||
|
||||
(CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2)
|
||||
(MAXCODE 255)
|
||||
(DUMMYINDEX 256))
|
||||
)
|
||||
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
FONT)
|
||||
@@ -679,11 +546,10 @@ file. *)
|
||||
(EF.INIT)
|
||||
(PUTPROPS EDITFONT COPYRIGHT ("Xerox Corporation" 1985 1986))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1748 36280 (EF.INIT 1758 . 2484) (EF.PROMPT 2486 . 3068) (EF.MESSAGE 3070 . 3282) (
|
||||
EF.CLOSEFN 3284 . 3811) (EF.CHARITEMS 3813 . 6034) (EF.BUTTONEVENTFN 6036 . 6448) (EF.WHENSELECTEDFN
|
||||
6450 . 6854) (EF.EDITBM 6856 . 8254) (EF.MIDDLEBUTTONFN 8256 . 8501) (EF.CHANGESIZE 8503 . 9722) (
|
||||
EF.DELETE 9724 . 10489) (EF.ENTER 10491 . 11322) (EF.REPLACE 11324 . 12187) (EF.SAVE 12189 . 16862) (
|
||||
EF.BLANK 16864 . 22489) (COPYFONT 22491 . 24931) (READSTRIKEFONTFILE 24933 . 31905) (
|
||||
WRITESTRIKEFONTFILE 31907 . 36278)) (36281 38495 (BLANKFONTCREATE 36291 . 36548) (EDITFONT 36550 .
|
||||
38493)))))
|
||||
(FILEMAP (NIL (1567 26117 (EF.INIT 1577 . 2303) (EF.PROMPT 2305 . 2887) (EF.MESSAGE 2889 . 3101) (
|
||||
EF.CLOSEFN 3103 . 3630) (EF.CHARITEMS 3632 . 5853) (EF.BUTTONEVENTFN 5855 . 6267) (EF.WHENSELECTEDFN
|
||||
6269 . 6673) (EF.EDITBM 6675 . 8073) (EF.MIDDLEBUTTONFN 8075 . 8320) (EF.CHANGESIZE 8322 . 9541) (
|
||||
EF.DELETE 9543 . 10308) (EF.ENTER 10310 . 11141) (EF.REPLACE 11143 . 12006) (EF.SAVE 12008 . 16681) (
|
||||
EF.BLANK 16683 . 22308) (COPYFONT 22310 . 24750) (READSTRIKEFONTFILE 24752 . 26115)) (26118 28332 (
|
||||
BLANKFONTCREATE 26128 . 26385) (EDITFONT 26387 . 28330)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user