Basic font files--see documentation
For the most part as described in docs/internal/FONTCODECHANGES and docs/internal/MEDLEYFONTFORMAT
This commit is contained in:
rmkaplan
@@ -1,23 +1,25 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jul-2025 16:43:34" {WMEDLEY}<internal>FONT-DEBUG.;46 19345
|
||||
(FILECREATED " 2-Sep-2025 13:47:42" {WMEDLEY}<internal>FONT-DEBUG.;66 23502
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS CSBMSIZE FONTSIZE CSSIZE EQCHARBM)
|
||||
(VARS FONT-DEBUGCOMS)
|
||||
:CHANGES-TO (FNS TRUEFONTCREATE)
|
||||
|
||||
:PREVIOUS-DATE "19-Jul-2025 12:36:48" {WMEDLEY}<internal>FONT-DEBUG.;41)
|
||||
:PREVIOUS-DATE "29-Aug-2025 22:39:54" {WMEDLEY}<internal>FONT-DEBUG.;65)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FONT-DEBUGCOMS)
|
||||
|
||||
(RPAQQ FONT-DEBUGCOMS (
|
||||
(* ;; "Little tools to help in debugging display fonts")
|
||||
(RPAQQ FONT-DEBUGCOMS
|
||||
(
|
||||
(* ;; "Little tools to help in debugging display fonts")
|
||||
|
||||
(FNS DEBUGCHARSET IBM ICS SHOWCACHE SHOWCSBITMAP EQCSBM EQCHARBM CHARSETCHARS
|
||||
CHARBMDIFFS SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS)
|
||||
(FNS FONTSIZE CSSIZE CSBMSIZE)))
|
||||
(FNS DEBUGCHARSET IBM ICS SHOWCACHE SHOWCSBITMAP EQCSBM EQCHARBM CHARSETCHARS CHARBMDIFFS
|
||||
SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS TRUEFONTCREATE)
|
||||
(FNS FONTSIZE CSSIZE CSBMSIZE)
|
||||
(FNS FONTCOMPARE)
|
||||
(MACROS TRUEFONT)))
|
||||
|
||||
|
||||
|
||||
@@ -26,7 +28,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(DEBUGCHARSET
|
||||
[LAMBDA (FONTSPEC CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 9-Jul-2025 16:26 by rmk")
|
||||
[LAMBDA (FONTSPEC CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 27-Aug-2025 17:19 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 16:26 by rmk")
|
||||
(* ; "Edited 6-Jul-2025 22:33 by rmk")
|
||||
(* ; "Edited 2-Jul-2025 16:50 by rmk")
|
||||
(* ; "Edited 30-Jun-2025 09:27 by rmk")
|
||||
@@ -43,46 +46,41 @@
|
||||
(CL:UNLESS INCLUDEMEDLEYFONT
|
||||
(RESETSAVE DISPLAYFONTEXTENSIONS (REMOVE 'MEDLEYDISPLAYFONT DISPLAYFONTEXTENSIONS)
|
||||
))
|
||||
[if (OR (LITATOM FONTSPEC)
|
||||
(if (OR (LITATOM FONTSPEC)
|
||||
(STRINGP FONTSPEC))
|
||||
then (CL:UNLESS CHARSET (SETQ CHARSET 0))
|
||||
(LET (STRM)
|
||||
[RESETSAVE (SETQ STRM (OPENSTREAM FONTSPEC 'INPUT))
|
||||
`(PROGN (CLOSEF? OLDVALUE]
|
||||
(for FNS CSINFO (FI _ (\FONTINFOFROMFILENAME FONTSPEC 'DISPLAY))
|
||||
(for FNS CSINFO (FI _ (FONTSPECFROMFILENAME FONTSPEC 'DISPLAY))
|
||||
in DISPLAYCHARSETFNS
|
||||
do (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS)
|
||||
STRM)))
|
||||
(SETQ CSINFO (APPLY* (CADDR FNS)
|
||||
STRM
|
||||
(CAR FI)
|
||||
(CADR FI)
|
||||
(CADDR FI)
|
||||
(CADDDR FI)
|
||||
(CAR (CDDDDR FI))
|
||||
CHARSET))
|
||||
STRM CHARSET))
|
||||
(PUTMULTI (fetch (CHARSETINFO CSINFOPROPS) of CSINFO)
|
||||
'FILE
|
||||
(PSEUDOFILENAME FONTSPEC))
|
||||
(RETURN CSINFO))
|
||||
(CLOSEF? STRM)))
|
||||
else (LET ((CS CHARSET))
|
||||
(CL:MULTIPLE-VALUE-BIND (FAMILY SIZE FACE ROTATION DEVICE CHARSET)
|
||||
(\FONT.CHECKARGS FONTSPEC)
|
||||
(CL:WHEN CS (SETQ CHARSET CS))
|
||||
(\READCHARSET FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET])])
|
||||
else (\READCHARSET (\FONT.CHECKARGS FONTSPEC)
|
||||
CHARSET)))])
|
||||
|
||||
(IBM
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 29-Jun-2025 17:05 by rmk")
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 27-Aug-2025 17:29 by rmk")
|
||||
(* ; "Edited 25-Aug-2025 08:58 by rmk")
|
||||
(* ; "Edited 29-Jun-2025 17:05 by rmk")
|
||||
(* ; "Edited 20-Jun-2025 16:35 by rmk")
|
||||
(* ; "Edited 18-Jun-2025 14:09 by rmk")
|
||||
|
||||
(* ;; "Inspects the character set bitmap for CHARSET in FONT, which may also be a charset info. If necessary, builds the font (unlike ICS).")
|
||||
|
||||
(SETQ CHARSET (CHARSET.DECODE CHARSET))
|
||||
(SHOWCSBITMAP (if (type? CHARSETINFO FONT)
|
||||
then FONT
|
||||
else (\XGETCHARSETINFO (SETQ FONT (FONTCREATE FONT))
|
||||
(OR CHARSET 0])
|
||||
elseif FONT
|
||||
then (\XGETCHARSETINFO (FONTCREATE FONT)
|
||||
(OR CHARSET 0])
|
||||
|
||||
(ICS
|
||||
[LAMBDA (FONT CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 7-Jul-2025 23:12 by rmk")
|
||||
@@ -114,7 +112,8 @@
|
||||
(DV \FONTEXISTS?-CACHE])
|
||||
|
||||
(SHOWCSBITMAP
|
||||
[LAMBDA (CSINFO) (* ; "Edited 29-Jun-2025 17:07 by rmk")
|
||||
[LAMBDA (CSINFO) (* ; "Edited 17-Aug-2025 12:36 by rmk")
|
||||
(* ; "Edited 29-Jun-2025 17:07 by rmk")
|
||||
(* ; "Edited 20-Jun-2025 16:38 by rmk")
|
||||
|
||||
(* ;; "Given a charsetinfo, shows the whole bitmap using EDITBM. Unfortunately, that runs in a separate process, so we can't directly get the window to put something useful in the title. If EDITBM is called directly, it doen't return until you quit...in which case it's gone. We'd really like just the displayer.")
|
||||
@@ -129,7 +128,7 @@
|
||||
(IGREATERP (BITMAPHEIGHT BM)
|
||||
0))
|
||||
then (EVAL.AS.PROCESS (LIST 'EDITBM BM))
|
||||
else "EMPTY BITMAP")
|
||||
else (PRINTOUT T "EMPTY BITMAP" T))
|
||||
CSINFO])
|
||||
|
||||
(EQCSBM
|
||||
@@ -277,11 +276,27 @@
|
||||
(LET ((CINFOS (CSCOMPARE CS1 CS2 CHARSET INCLUDEMEDLEYFONT)))
|
||||
(SHOWCHARBITMAPS NIL CINFOS CHARSET INCLUDEMEDLEYFONT T)
|
||||
CINFOS])
|
||||
|
||||
(TRUEFONTCREATE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)
|
||||
(* ; "Edited 2-Sep-2025 13:46 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 22:38 by rmk")
|
||||
(* ; "Edited 17-Aug-2025 15:47 by rmk")
|
||||
(* ; "Edited 31-Jul-2025 10:10 by rmk")
|
||||
(* ; "Edited 25-Jul-2025 13:43 by rmk")
|
||||
|
||||
(* ;; "New font, no coercions, no MEDLEYFORMAT")
|
||||
|
||||
(LEGACYFONT (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(FONTSIZE
|
||||
[LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 19-Jul-2025 16:42 by rmk")
|
||||
[LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 16-Aug-2025 23:34 by rmk")
|
||||
(* ; "Edited 19-Jul-2025 16:42 by rmk")
|
||||
|
||||
(* ;; "Estimates the amount of storage occupied by FONT")
|
||||
|
||||
(SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY NOERROR))
|
||||
(CL:UNLESS CHARSETS
|
||||
(SETQ CHARSETS (for CS CSINFO BM from 0 to 255 when (SETQ CSINFO (\XGETCHARSETINFO FONT CS))
|
||||
@@ -343,10 +358,72 @@
|
||||
8) finally (PRINTOUT T T))
|
||||
else 0])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(FONTCOMPARE
|
||||
[LAMBDA (ARGS VIRGIN SHOWFONT) (* ; "Edited 5-Aug-2025 13:14 by rmk")
|
||||
|
||||
(* ;; "Prints a line of characters in different fonts, for shape/size comparison. Each argument is a list of the form (FONT CHAR1 CHAR2...) or (FONT CHAR1 - CHARN) (hyphen). Characters can be codes or names.")
|
||||
|
||||
(* ;; "If CHARS are not specfied, uses the chars from the previous arg.")
|
||||
|
||||
(RESETLST
|
||||
(RESETSAVE (DSPFONT NIL T))
|
||||
(CL:WHEN VIRGIN
|
||||
(RESETSAVE \FONTSINCORE NIL)
|
||||
(RESETSAVE \DISPLAYCHARSETCOERCIONS NIL)
|
||||
(RESETSAVE \DISPLAYFONTCOERCIONS NIL)
|
||||
(RESETSAVE \FONTEXISTS?-CACHE NIL)
|
||||
(RESETSAVE DISPLAYFONTEXTENSIONS '(DISPLAYFONT)))
|
||||
(TERPRI T)
|
||||
(for A CHARS FONT SIZEPOS in ARGS
|
||||
do (CL:WHEN (CADR A)
|
||||
(SETQ CHARS (CDR A))
|
||||
[SETQ CHARS (if (EQ '- (CADR CHARS))
|
||||
then (for C from (CL:IF (CHARCODEP (CAR CHARS))
|
||||
(CAR CHARS)
|
||||
(CHARCODE.DECODE (CAR CHARS)))
|
||||
to (CL:IF (CHARCODEP (CADDR CHARS))
|
||||
(CADDR CHARS)
|
||||
(CHARCODE.DECODE (CADDR CHARS))) collect C)
|
||||
else (for C in CHARS collect (CL:IF (CHARCODEP C)
|
||||
C
|
||||
(CHARCODE.DECODE C))])
|
||||
(SETQ FONT (FONTCREATE (CAR A)))
|
||||
(if SHOWFONT
|
||||
then (SETQ SIZEPOS (IDIFFERENCE (STRPOS "-" FONT)
|
||||
2))
|
||||
(PRINTOUT T .FONT '(GACHA 8)
|
||||
" ["
|
||||
(SUBSTRING FONT 2 3)
|
||||
(SUBSTRING FONT SIZEPOS (ADD1 SIZEPOS))
|
||||
"]")
|
||||
else (PRINTOUT T .FONT '(GACHA 8)
|
||||
"/"))
|
||||
(DSPFONT FONT T)
|
||||
(for C in CHARS do (PRIN1 (CHARACTER C)
|
||||
T)))
|
||||
(TERPRI T))])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS TRUEFONT MACRO ((FORM) (* ;
|
||||
"Execute FORM in a non-medleyfont displayfont environment")
|
||||
(RESETVARS (\FONTSINCORE \FONTEXISTS?-CACHE DISPLAYFONTCOERCIONS
|
||||
DISPLAYCHARCOERCIONS (DISPLAYFONTEXTENSIONS '(DISPLAYFONT
|
||||
))
|
||||
(DISPLAYFONTDIRECTORIES (MEDLEYDIR "fonts>displayfonts>")
|
||||
)
|
||||
(DISPLAYCHARSETFNS (REMOVE (ASSOC 'MEDLEYFONT
|
||||
DISPLAYCHARSETFNS)
|
||||
DISPLAYCHARSETFNS)))
|
||||
(RETURN FORM))))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (818 15839 (DEBUGCHARSET 828 . 4007) (IBM 4009 . 4717) (ICS 4719 . 6013) (SHOWCACHE 6015
|
||||
. 6362) (SHOWCSBITMAP 6364 . 7478) (EQCSBM 7480 . 8366) (EQCHARBM 8368 . 9129) (CHARSETCHARS 9131 .
|
||||
9797) (CHARBMDIFFS 9799 . 10675) (SHOWCSCHAR 10677 . 11112) (CSCOMPARE 11114 . 13706) (SHOWBMS 13708
|
||||
. 13886) (SHOWCHARBITMAPS 13888 . 15479) (CANDS 15481 . 15837)) (15840 19322 (FONTSIZE 15850 . 16535)
|
||||
(CSSIZE 16537 . 17946) (CSBMSIZE 17948 . 19320)))))
|
||||
(FILEMAP (NIL (774 16422 (DEBUGCHARSET 784 . 3405) (IBM 3407 . 4405) (ICS 4407 . 5701) (SHOWCACHE 5703
|
||||
. 6050) (SHOWCSBITMAP 6052 . 7290) (EQCSBM 7292 . 8178) (EQCHARBM 8180 . 8941) (CHARSETCHARS 8943 .
|
||||
9609) (CHARBMDIFFS 9611 . 10487) (SHOWCSCHAR 10489 . 10924) (CSCOMPARE 10926 . 13518) (SHOWBMS 13520
|
||||
. 13698) (SHOWCHARBITMAPS 13700 . 15291) (CANDS 15293 . 15649) (TRUEFONTCREATE 15651 . 16420)) (16423
|
||||
20082 (FONTSIZE 16433 . 17295) (CSSIZE 17297 . 18706) (CSBMSIZE 18708 . 20080)) (20083 22490 (
|
||||
FONTCOMPARE 20093 . 22488)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
236
sources/AFONT
236
sources/AFONT
@@ -1,33 +1,31 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jul-2025 19:53:00" {WMEDLEY}<sources>AFONT.;13 43176
|
||||
(FILECREATED "22-Jul-2025 23:20:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;15 27510
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS ACFONT.GETCHARSET \READACFONTFILE)
|
||||
:CHANGES-TO (VARS AFONTCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Jul-2025 22:09:41" {WMEDLEY}<sources>AFONT.;12)
|
||||
:PREVIOUS-DATE "21-Jul-2025 00:14:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;14)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT AFONTCOMS)
|
||||
|
||||
(RPAQQ AFONTCOMS
|
||||
(
|
||||
(* ;; "AC and Interpress font file support. ACFILEP is on FONT")
|
||||
[
|
||||
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
|
||||
|
||||
(XCL:FILE-ENVIRONMENTS "AFONT")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX)
|
||||
(CONSTANTS noInfoCode))
|
||||
(FNS ACFONT.FILEP ACFONT.GETCHARSET \CREATESTARFONT \READACFONTBOXES \READACFONTFILE
|
||||
\ACCHARIMAGELIST \ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE
|
||||
\FACECODE \FAMILYCODE \FINDFONT)
|
||||
(ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET)))
|
||||
(INITVARS (INTERPRESSFONTDIRECTORIES))
|
||||
(MACROS \POSITIONFONTFILE)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX))
|
||||
(FNS ACFONT.FILEP ACFONT.GETCHARSET \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST
|
||||
\ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \FACECODE \FAMILYCODE)
|
||||
(ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET])
|
||||
|
||||
|
||||
|
||||
(* ;; "AC and Interpress font file support. ACFILEP is on FONT")
|
||||
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
|
||||
|
||||
|
||||
(XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL"
|
||||
@@ -58,14 +56,6 @@
|
||||
|
||||
(RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ noInfoCode 32768)
|
||||
|
||||
|
||||
(CONSTANTS noInfoCode)
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -96,35 +86,6 @@
|
||||
|
||||
(\READACFONTFILE STRM])
|
||||
|
||||
(\CREATESTARFONT
|
||||
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 22-May-2025 09:59 by rmk")
|
||||
(* ; "Edited 18-May-2025 21:37 by rmk")
|
||||
(* gbn " 1-Oct-85 18:29")
|
||||
|
||||
(* ;; "the Build font descriptor for an Interpress NS font. If we can't find widths info for that font, return NIL")
|
||||
|
||||
(* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS")
|
||||
|
||||
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS))
|
||||
(RESETLST (* ;
|
||||
"RESETLST to make sure the fontfiles get closed")
|
||||
(LET [(FD (create FONTDESCRIPTOR
|
||||
FONTDEVICE _ DEVICE
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ PSIZE
|
||||
FONTFACE _ FACE
|
||||
\SFFACECODE _ (\FACECODE FACE)
|
||||
ROTATION _ ROTATION
|
||||
OTHERDEVICEFONTPROPS _ \ASCIITONS
|
||||
FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72]
|
||||
(CL:UNLESS (fetch (CHARSETINFO CSSLUGP) of (\INSURECHARSETINFO (OR CHARSET
|
||||
\DEFAULTCHARSET)
|
||||
FD))
|
||||
|
||||
(* ;; "return NIL for slug, let FONTCREATE decide whether or not to cause an error")
|
||||
|
||||
FD)))])
|
||||
|
||||
(\READACFONTBOXES
|
||||
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48")
|
||||
(* ;
|
||||
@@ -448,93 +409,6 @@
|
||||
|
||||
(ROTATE-BITMAP-LEFT BITMAP])
|
||||
|
||||
(\READFONTWDFILE
|
||||
[LAMBDA (FILE FD WIDTHS SCALE) (* jds " 2-Jan-86 12:34")
|
||||
|
||||
(* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS")
|
||||
|
||||
(DECLARE (GLOBALVARS FONTWIDTHSFILES)) (* (RESETLST (* ;
|
||||
"RESETLST to make sure the fontfiles get closed")
|
||||
(PROG (FIXEDFLAGS FIRSTCHAR LASTCHAR
|
||||
TEM WIDTHSY) (SETFILEPTR FILE
|
||||
(LLSH (\FIXPIN FILE) 1))
|
||||
(* ; "Locate the segment")
|
||||
(replace (FONTDESCRIPTOR FBBOX) of FD
|
||||
with (SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(replace \SFDescent of FD with
|
||||
(IMINUS (SIGNED (\WIN FILE)
|
||||
BITSPERWORD))) (* ; "Descent is -FBBOY")
|
||||
(replace (FONTDESCRIPTOR FBBDX) of FD
|
||||
with (SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(replace \SFHeight of FD with
|
||||
(SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(* ; "Height is FBBDY")
|
||||
(replace \SFWidths of FD with WIDTHS)
|
||||
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
|
||||
(* ;
|
||||
"First and last 'real' characters in the font")
|
||||
(SETQ LASTCHAR (fetch LASTCHAR of FD))
|
||||
(COND (SCALE (* ;
|
||||
"Dimensions are relative, must be scaled")
|
||||
(replace (FONTDESCRIPTOR FBBOX) of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch (FONTDESCRIPTOR FBBOX) of FD)
|
||||
SCALE) 1000)) (replace \SFDescent of
|
||||
FD with (IQUOTIENT (ITIMES
|
||||
(fetch \SFDescent of FD) SCALE) 1000))
|
||||
(replace (FONTDESCRIPTOR FBBDX) of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch (FONTDESCRIPTOR FBBDX) of FD)
|
||||
SCALE) 1000)) (replace \SFHeight of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch \SFHeight of FD) SCALE) 1000))))
|
||||
(replace \SFAscent of FD with
|
||||
(IDIFFERENCE (fetch \SFHeight of FD)
|
||||
(fetch \SFDescent of FD)))
|
||||
(SETQ FIXEDFLAGS (LRSH
|
||||
(\BIN FILE) 6)) (* ;
|
||||
"The fixed flags") (\BIN FILE)
|
||||
(* ; "Skip the spares")
|
||||
(COND ((EQ 2 (LOGAND FIXEDFLAGS 2))
|
||||
(SETQ TEM (\WIN FILE))
|
||||
(* ; "The fixed width for this font")
|
||||
(COND ((AND SCALE (NOT
|
||||
(ZEROP TEM))) (SETQ TEM
|
||||
(IQUOTIENT (ITIMES TEM SCALE) 1000))))
|
||||
(for I from FIRSTCHAR to LASTCHAR do
|
||||
(SETA WIDTHS I TEM)))
|
||||
(T (AIN WIDTHS FIRSTCHAR
|
||||
(ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
|
||||
FILE) (for I from FIRSTCHAR to
|
||||
LASTCHAR when (EQ noInfoCode
|
||||
(ELT WIDTHS I)) do (SETA WIDTHS I 0))
|
||||
(COND (SCALE (for I from FIRSTCHAR to
|
||||
LASTCHAR do (SETA WIDTHS I
|
||||
(IQUOTIENT (ITIMES (ELT WIDTHS I)
|
||||
SCALE) 1000))))))) (COND
|
||||
((EQ 1 (LOGAND FIXEDFLAGS 1))
|
||||
(SETQ WIDTHSY (\WIN FILE))
|
||||
(* ;
|
||||
"The fixed width-Y for this font; the width-Y field is a single integer in the FD")
|
||||
(replace \SFWidthsY of FD with
|
||||
(COND ((AND SCALE (NOT
|
||||
(ZEROP WIDTHSY))) (IQUOTIENT
|
||||
(ITIMES WIDTHSY SCALE) 1000))
|
||||
(T WIDTHSY)))) (T (replace \SFWidthsY
|
||||
of FD with (SETQ WIDTHSY
|
||||
(ARRAY (ADD1 \MAXCHAR)
|
||||
(QUOTE SMALLPOSP) 0 0)))
|
||||
(AIN WIDTHSY FIRSTCHAR
|
||||
(ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
|
||||
FILE) (for I from FIRSTCHAR to
|
||||
LASTCHAR when (EQ noInfoCode
|
||||
(ELT WIDTHSY I)) do (SETA WIDTHSY I 0))
|
||||
(COND (SCALE (for I from FIRSTCHAR to
|
||||
LASTCHAR do (SETA WIDTHSY I
|
||||
(IQUOTIENT (ITIMES (ELT WIDTHSY I)
|
||||
SCALE) 1000))))))))))
|
||||
(HELP])
|
||||
|
||||
(\FACECODE
|
||||
[LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16")
|
||||
(IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
@@ -578,90 +452,12 @@
|
||||
(RETURN CODE))))
|
||||
(0 (RETURN NIL))
|
||||
NIL])
|
||||
|
||||
(\FINDFONT
|
||||
[LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* ; "Edited 2-Apr-87 14:39 by bvm:")
|
||||
|
||||
(* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR of the font are filled in, since we have to read past those to check the size. If successful, returns the size found in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing just after the Rotation word of the font. --- If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking --- Returns NIL if the font is not found")
|
||||
(* (bind TYPE LENGTH SIZE FAMILYCODE
|
||||
(ROTATION _ (fetch ROTATION of FD))
|
||||
(FACECODE _ (\FACECODE
|
||||
(fetch FONTFACE of FD)))
|
||||
(NEXT _ 0) (FUZZ _ (PROG1 0.02
|
||||
(* ;
|
||||
"percentile difference acceptable as the same font size")))
|
||||
first (OR (SETQ FAMILYCODE
|
||||
(\FAMILYCODE (OR DONTCHECK
|
||||
(fetch FONTFAMILY of FD)) WSTRM))
|
||||
(RETURN NIL)) do (SETQ TYPE
|
||||
(\BIN WSTRM)) (SETQ LENGTH
|
||||
(\BIN WSTRM)) (add NEXT
|
||||
(LLSH (IPLUS LENGTH (LLSH
|
||||
(LOGAND TYPE 15) 8)) 1))
|
||||
(SELECTQ (LRSH TYPE 4)
|
||||
(4 (COND ((OR (AND (EQ FAMILYCODE
|
||||
(\BIN WSTRM)) (EQ FACECODE
|
||||
(\BIN WSTRM))) DONTCHECK)
|
||||
(* ;
|
||||
"This is the right family/face (DONTCHECK must come last, so the file reads get done.)")
|
||||
(replace FIRSTCHAR of FD with
|
||||
(\BIN WSTRM)) (replace LASTCHAR of FD
|
||||
with (\BIN WSTRM)) (COND
|
||||
((AND (OR (ZEROP (SETQ SIZE
|
||||
(\WIN WSTRM))) (LESSP
|
||||
(ABS (FQUOTIENT (IDIFFERENCE
|
||||
(OR PRESSMICASIZE NSMICASIZE) SIZE)
|
||||
PRESSMICASIZE)) FUZZ))
|
||||
(EQ ROTATION (\WIN WSTRM)))
|
||||
(replace \SFFACECODE of FD with
|
||||
FACECODE) (RETURN SIZE))))))
|
||||
(0 (RETURN NIL)) NIL)
|
||||
(SETFILEPTR WSTRM NEXT)))
|
||||
(HELP])
|
||||
)
|
||||
|
||||
(ADDTOVAR DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET))
|
||||
|
||||
(RPAQ? INTERPRESSFONTDIRECTORIES )
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \POSITIONFONTFILE MACRO
|
||||
((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE)
|
||||
(* gbn "25-Jul-85 02:15")
|
||||
(bind TYPE LENGTH SIZE FAMCODE FILEFAM FILEFACE (NEXT _ 0)
|
||||
first (OR (SETQ FAMCODE (\FAMILYCODE (OR FAMILY T)
|
||||
WSTRM))
|
||||
(RETURN NIL))
|
||||
do (SETQ TYPE (\BIN WSTRM))
|
||||
(SETQ LENGTH (\BIN WSTRM))
|
||||
(add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15)
|
||||
8))
|
||||
1))
|
||||
(SELECTQ (LRSH TYPE 4)
|
||||
(4 (SETQ FILEFAM (\BIN WSTRM))
|
||||
(SETQ FILEFACE (\BIN WSTRM))
|
||||
[COND
|
||||
((OR (EQ FAMILY T)
|
||||
(EQ FAMILY NIL)
|
||||
(AND (IEQP FILEFAM FAMCODE)
|
||||
(IEQP FILEFACE FACECODE)))
|
||||
(SETQ FIRSTCHAR (\BIN WSTRM))
|
||||
(SETQ LASTCHAR (\BIN WSTRM))
|
||||
(COND
|
||||
((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM)))
|
||||
(LESSP (ABS (FQUOTIENT (IDIFFERENCE NSMICASIZE SIZE)
|
||||
NSMICASIZE))
|
||||
0.02))
|
||||
(ZEROP (\WIN WSTRM)))
|
||||
(RETURN SIZE])
|
||||
(0 (RETURN NIL))
|
||||
NIL)
|
||||
(SETFILEPTR WSTRM NEXT))))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2849 41269 (ACFONT.FILEP 2859 . 3743) (ACFONT.GETCHARSET 3745 . 4137) (\CREATESTARFONT
|
||||
4139 . 5862) (\READACFONTBOXES 5864 . 8091) (\READACFONTFILE 8093 . 20934) (\ACCHARIMAGELIST 20936 .
|
||||
21293) (\ACCHARWIDTHLIST 21295 . 22561) (\GETFBB 22563 . 25843) (\ACCHARPOSLIST 25845 . 26895) (
|
||||
\ACROTATECHAR 26897 . 27461) (\READFONTWDFILE 27463 . 35496) (\FACECODE 35498 . 36092) (\FAMILYCODE
|
||||
36094 . 37398) (\FINDFONT 37400 . 41267)))))
|
||||
(FILEMAP (NIL (2626 27417 (ACFONT.FILEP 2636 . 3520) (ACFONT.GETCHARSET 3522 . 3914) (\READACFONTBOXES
|
||||
3916 . 6143) (\READACFONTFILE 6145 . 18986) (\ACCHARIMAGELIST 18988 . 19345) (\ACCHARWIDTHLIST 19347
|
||||
. 20613) (\GETFBB 20615 . 23895) (\ACCHARPOSLIST 23897 . 24947) (\ACROTATECHAR 24949 . 25513) (
|
||||
\FACECODE 25515 . 26109) (\FAMILYCODE 26111 . 27415)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
3839
sources/FONT
3839
sources/FONT
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Jul-2025 22:22:23" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;218 57699
|
||||
(FILECREATED " 4-Sep-2025 11:43:26" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;240 58467
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MEDLEYFONT.READ.ITEM)
|
||||
:CHANGES-TO (FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.READ.CHARSET MEDLEYFONT.FILENAME)
|
||||
|
||||
:PREVIOUS-DATE "24-Jul-2025 22:07:35" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;217)
|
||||
:PREVIOUS-DATE " 3-Sep-2025 11:32:20" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;235)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
|
||||
@@ -59,7 +59,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.FONT
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 15-Jul-2025 16:43 by rmk")
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 2-Sep-2025 23:01 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 16:43 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 09:32 by rmk")
|
||||
(* ; "Edited 19-Jun-2025 10:59 by rmk")
|
||||
(* ; "Edited 9-Jun-2025 12:17 by rmk")
|
||||
@@ -84,7 +85,7 @@
|
||||
(SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET
|
||||
when (OR (NULL CHARSETNOS)
|
||||
(MEMB CSNO CHARSETNOS))
|
||||
when (SETQ CSINFO (\XGETCHARSETINFO FONT CSNO))
|
||||
when (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
|
||||
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO))
|
||||
(CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT))
|
||||
|
||||
@@ -128,11 +129,12 @@
|
||||
(FULLNAME STREAM])
|
||||
|
||||
(MEDLEYFONT.GETCHARSET
|
||||
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk")
|
||||
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 3-Sep-2025 11:32 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 17:09 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 15:45 by rmk")
|
||||
(* ; "Edited 14-May-2025 17:46 by rmk")
|
||||
|
||||
(* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information")
|
||||
(* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information. FONT is provided so that properties of the fontdescriptor can be read through this interface--ottherwise the fontcreate function of each device might have to also have a list of functions to try.")
|
||||
|
||||
(CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
|
||||
(\ILLEGAL.ARG CHARSET))
|
||||
@@ -145,6 +147,12 @@
|
||||
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))))
|
||||
(LET ((CSVECTORLOC (\FIXPIN STREAM))
|
||||
CSLOC)
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT) (* ;
|
||||
"Maybe only for the first character set?")
|
||||
(replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL)
|
||||
|
||||
(* ;;
|
||||
"One charset doesn't %"complete%" a complete font--maybe that's only an incore property? ")
|
||||
|
||||
(* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
|
||||
|
||||
@@ -186,7 +194,8 @@
|
||||
CHARSET])
|
||||
|
||||
(MEDLEYFONT.GETFILEPROP
|
||||
[LAMBDA (FILE PROP) (* ; "Edited 15-Jul-2025 20:21 by rmk")
|
||||
[LAMBDA (FILE PROP) (* ; "Edited 27-Aug-2025 17:12 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 20:21 by rmk")
|
||||
(* ; "Edited 10-Jul-2025 17:50 by rmk")
|
||||
(* ; "Edited 25-May-2025 20:53 by rmk")
|
||||
(* ; "Edited 21-May-2025 11:36 by rmk")
|
||||
@@ -194,9 +203,8 @@
|
||||
(* ; "Edited 14-May-2025 17:46 by rmk")
|
||||
(CL:UNLESS (OR (LITATOM FILE)
|
||||
(STRINGP FILE))
|
||||
[SETQ FILE (CAR (APPLY (FUNCTION FONTFILES)
|
||||
(FONTPROP (FONTCREATE FILE)
|
||||
'SPEC])
|
||||
[SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE)
|
||||
'SPEC])
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
|
||||
(LET (HEADERPROPS CSVECTORLOC)
|
||||
(CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM))
|
||||
@@ -255,7 +263,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.READ.FONT
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 15-Jul-2025 20:20 by rmk")
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 31-Aug-2025 14:42 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 20:20 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 00:06 by rmk")
|
||||
(* ; "Edited 6-Jul-2025 11:45 by rmk")
|
||||
(CL:UNLESS FILE (SETQ FILE FONT))
|
||||
@@ -267,14 +276,13 @@
|
||||
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
|
||||
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))
|
||||
(LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))
|
||||
FONTCHARSETVECTOR CSVECTORLOC NOTFOUND SINGLECS)
|
||||
CSVECTORLOC NOTFOUND SINGLECSNO)
|
||||
(SETQ CSVECTORLOC (\FIXPIN STREAM)) (* ;
|
||||
"Byte location of the charset dispatch vector")
|
||||
|
||||
(* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")
|
||||
|
||||
(SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT))
|
||||
(SETQ FONTCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT))
|
||||
(CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty")
|
||||
[if (ILESSP CSVECTORLOC 0)
|
||||
then
|
||||
@@ -284,15 +292,15 @@
|
||||
(* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")
|
||||
|
||||
(SETFILEPTR STREAM (IMINUS CSVECTORLOC))
|
||||
(SETQ SINGLECS (BIN STREAM))
|
||||
(SETQ SINGLECSNO (BIN STREAM))
|
||||
(CL:WHEN CHARSETNOS
|
||||
(CL:UNLESS (AND (EQ SINGLECS (CAR CHARSETNOS))
|
||||
(CL:UNLESS (AND (EQ SINGLECSNO (CAR CHARSETNOS))
|
||||
(NULL (CDR CHARSETNOS)))
|
||||
(ERROR (CONCAT FILE
|
||||
" does not contain information for charsets ÿ4ÿ "
|
||||
(REMOVE SINGLECS CHARSETNOS)))))
|
||||
(\SETCHARSETINFO FONTCHARSETVECTOR SINGLECS (MEDLEYFONT.READ.CHARSET
|
||||
STREAM SINGLECS))
|
||||
" does not contain information for charsets "
|
||||
(REMOVE SINGLECSNO CHARSETNOS)))))
|
||||
(\SETCHARSETINFO FONT SINGLECSNO (MEDLEYFONT.READ.CHARSET STREAM
|
||||
SINGLECSNO))
|
||||
else
|
||||
(* ;;
|
||||
"Gather all of the CSLOCS before reading, so that we always move forward")
|
||||
@@ -311,13 +319,17 @@
|
||||
(DREVERSE NOTFOUND))))
|
||||
(for X CS in $$VAL do (SETQ CSNO (CAR X))
|
||||
(SETFILEPTR STREAM (CDR X))
|
||||
(\SETCHARSETINFO FONTCHARSETVECTOR CSNO
|
||||
(MEDLEYFONT.READ.CHARSET STREAM CSNO
|
||||
])
|
||||
(\SETCHARSETINFO FONT CSNO (
|
||||
MEDLEYFONT.READ.CHARSET
|
||||
STREAM CSNO])
|
||||
FONT])
|
||||
|
||||
(MEDLEYFONT.READ.CHARSET
|
||||
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 11:27 by rmk")
|
||||
[LAMBDA (STREAM CHARSET) (* ; "Edited 4-Sep-2025 10:39 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 15:27 by rmk")
|
||||
(* ; "Edited 26-Aug-2025 23:36 by rmk")
|
||||
(* ; "Edited 17-Aug-2025 13:01 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 11:27 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 19:33 by rmk")
|
||||
(* ; "Edited 6-Jul-2025 10:11 by rmk")
|
||||
(* ; "Edited 25-May-2025 20:54 by rmk")
|
||||
@@ -331,12 +343,12 @@
|
||||
(LET (CSNO INDIRECT)
|
||||
(CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM STREAM 'CHARSET]
|
||||
(ERROR "Charset mismatch" (LIST CHARSET CSNO)))
|
||||
(if [EQ 'INDIRECTCHARSET (CAR (SETQ INDIRECT (MEDLEYFONT.PEEK.ITEM STREAM]
|
||||
then (* ;
|
||||
"Read a complete charset from another file (e.g. shared Kanji)")
|
||||
(MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET)
|
||||
(APPLY (FUNCTION \READCHARSET)
|
||||
(CADR INDIRECT))
|
||||
(if (EQ 'INDIRECTCHARSET (CAR (MEDLEYFONT.PEEK.ITEM STREAM)))
|
||||
then
|
||||
(* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ")
|
||||
|
||||
(SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET))
|
||||
(\READCHARSET INDIRECT CHARSET)
|
||||
else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO
|
||||
WIDTHS _ NIL
|
||||
OFFSETS _ NIL)) eachtime (SETQ PAIR
|
||||
@@ -366,10 +378,11 @@
|
||||
of CSINFO with ITEM))
|
||||
(CSCOMPLETEP (replace (CHARSETINFO CSCOMPLETEP)
|
||||
of CSINFO with ITEM))
|
||||
(HELP "Unrecognized charsetinfo label'" LABEL))
|
||||
(HELP "Unrecognized charsetinfo label" LABEL))
|
||||
finally (CL:UNLESS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO
|
||||
with (fetch (CHARSETINFO WIDTHS) of CSINFO)))
|
||||
(replace (CHARSETINFO CHARSETNO) of CSINFO with CHARSET)
|
||||
(RETURN CSINFO])
|
||||
|
||||
(MEDLEYFONT.READ.ITEM
|
||||
@@ -481,64 +494,65 @@
|
||||
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
|
||||
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:57 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 2-Sep-2025 23:52 by rmk")
|
||||
(* ; "Edited 12-Aug-2025 17:57 by rmk")
|
||||
(* ; "Edited 10-Jun-2025 20:57 by rmk")
|
||||
(* ; "Edited 21-May-2025 22:55 by rmk")
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
(* ; "Edited 16-May-2025 10:28 by rmk")
|
||||
(CL:UNLESS FONT
|
||||
(SETQ FONT (create FONTDESCRIPTOR)))
|
||||
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)))
|
||||
[if FONT
|
||||
then (* ; "compare/verify")
|
||||
(for P in FONTPROPS unless (EQUAL (CADR P)
|
||||
(RECORDACCESS (CAR P)
|
||||
FONT NIL 'FETCH))
|
||||
do (ERROR "Mismatching font property" P))
|
||||
else (SETQ FONT (create FONTDESCRIPTOR)) (* ; "Construct")
|
||||
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
|
||||
(SELECTQ (CAR P)
|
||||
(FONTDEVICE (replace (FONTDESCRIPTOR FONTDEVICE)
|
||||
of FONT with VAL))
|
||||
(FONTCOMPLETEP (replace (FONTDESCRIPTOR FONTCOMPLETEP)
|
||||
of FONT with VAL))
|
||||
(FONTFAMILY (replace (FONTDESCRIPTOR FONTFAMILY)
|
||||
of FONT with VAL))
|
||||
(FONTSIZE (replace (FONTDESCRIPTOR FONTSIZE)
|
||||
of FONT with VAL))
|
||||
(FONTFACE (replace (FONTDESCRIPTOR FONTFACE)
|
||||
of FONT with VAL))
|
||||
(\SFAscent (replace (FONTDESCRIPTOR \SFAscent)
|
||||
of FONT with VAL))
|
||||
(\SFDescent (replace (FONTDESCRIPTOR \SFDescent)
|
||||
of FONT with VAL))
|
||||
(\SFHeight (replace (FONTDESCRIPTOR \SFHeight)
|
||||
of FONT with VAL))
|
||||
(ROTATION (replace (FONTDESCRIPTOR ROTATION)
|
||||
of FONT with VAL))
|
||||
(FONTDEVICESPEC
|
||||
(replace (FONTDESCRIPTOR FONTDEVICESPEC)
|
||||
of FONT with VAL))
|
||||
(OTHERDEVICEFONTPROPS
|
||||
(replace (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
|
||||
of FONT with VAL))
|
||||
(FONTSCALE (replace (FONTDESCRIPTOR FONTSCALE)
|
||||
of FONT with VAL))
|
||||
(\SFFACECODE (replace (FONTDESCRIPTOR \SFFACECODE)
|
||||
of FONT with VAL))
|
||||
(FONTAVGCHARWIDTH
|
||||
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH)
|
||||
of FONT with VAL))
|
||||
(FONTCHARENCODING
|
||||
(replace (FONTDESCRIPTOR FONTCHARENCODING)
|
||||
of FONT with VAL))
|
||||
(FONTCHARSETVECTOR
|
||||
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR)
|
||||
of FONT with VAL))
|
||||
(FONTHASLEFTKERNS
|
||||
(replace (FONTDESCRIPTOR FONTHASLEFTKERNS)
|
||||
of FONT with VAL))
|
||||
(FONTEXTRAFIELD2
|
||||
(replace (FONTDESCRIPTOR FONTEXTRAFIELD2)
|
||||
of FONT with VAL))
|
||||
(HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P"]
|
||||
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
|
||||
(SELECTQ (CAR P)
|
||||
(FONTDEVICE (replace (FONTDESCRIPTOR FONTDEVICE) of FONT
|
||||
with VAL))
|
||||
(FONTCOMPLETEP (replace (FONTDESCRIPTOR FONTCOMPLETEP)
|
||||
of FONT with VAL))
|
||||
(FONTFAMILY (replace (FONTDESCRIPTOR FONTFAMILY) of FONT
|
||||
with VAL))
|
||||
(FONTSIZE (replace (FONTDESCRIPTOR FONTSIZE) of FONT
|
||||
with VAL))
|
||||
(FONTFACE (replace (FONTDESCRIPTOR FONTFACE) of FONT
|
||||
with VAL))
|
||||
(\SFAscent (replace (FONTDESCRIPTOR \SFAscent) of FONT
|
||||
with VAL))
|
||||
(\SFDescent (replace (FONTDESCRIPTOR \SFDescent) of FONT
|
||||
with VAL))
|
||||
(\SFHeight (replace (FONTDESCRIPTOR \SFHeight) of FONT
|
||||
with VAL))
|
||||
(ROTATION (replace (FONTDESCRIPTOR ROTATION) of FONT
|
||||
with VAL))
|
||||
(FONTSLUGWIDTH (replace (FONTDESCRIPTOR FONTSLUGWIDTH)
|
||||
of FONT with VAL))
|
||||
(FONTTOMCCSFN (replace (FONTDESCRIPTOR FONTTOMCCSFN)
|
||||
of FONT with VAL))
|
||||
(FONTDEVICESPEC
|
||||
(replace (FONTDESCRIPTOR FONTDEVICESPEC) of FONT
|
||||
with VAL))
|
||||
(OTHERDEVICEFONTPROPS
|
||||
(replace (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
|
||||
of FONT with VAL))
|
||||
(FONTSCALE (replace (FONTDESCRIPTOR FONTSCALE) of FONT
|
||||
with VAL))
|
||||
(\SFFACECODE (replace (FONTDESCRIPTOR \SFFACECODE)
|
||||
of FONT with VAL))
|
||||
(FONTAVGCHARWIDTH
|
||||
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT
|
||||
with VAL))
|
||||
(FONTCHARENCODING
|
||||
(replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT
|
||||
with VAL))
|
||||
(FONTCHARSETVECTOR
|
||||
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT
|
||||
with VAL))
|
||||
(FONTHASLEFTKERNS
|
||||
(replace (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT
|
||||
with VAL))
|
||||
(FONTEXTRAFIELD2
|
||||
(replace (FONTDESCRIPTOR FONTEXTRAFIELD2) of FONT
|
||||
with VAL))
|
||||
(HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P")))
|
||||
FONT])
|
||||
)
|
||||
|
||||
@@ -549,15 +563,15 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.CHARSET
|
||||
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 9-Jul-2025 19:14 by rmk")
|
||||
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-Sep-2025 11:41 by rmk")
|
||||
(* ; "Edited 30-Aug-2025 23:44 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 21:00 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 19:14 by rmk")
|
||||
(* ; "Edited 25-May-2025 20:49 by rmk")
|
||||
(* ; "Edited 22-May-2025 09:58 by rmk")
|
||||
(* ; "Edited 16-May-2025 20:18 by rmk")
|
||||
(* ; "Edited 13-May-2025 23:26 by rmk")
|
||||
|
||||
(* ;; "This outputs the characterset info for CHARSET in FONT.")
|
||||
|
||||
(LET ((CSINFO (\INSURECHARSETINFO CHARSET FONT))
|
||||
(LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET))
|
||||
CSCHARENCODING)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET))
|
||||
(* ; "For human file-scan")
|
||||
@@ -569,15 +583,12 @@
|
||||
|
||||
(* ;; "Copy the fonts charencoding down to each charset info so that it is available when the charsetinfo is read. The fontdescriptor isn't available at that point and coercion could lead to fonts of different encodings. At least this would make it possible to fix things up.")
|
||||
|
||||
(if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT CHARSET))
|
||||
(if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT))
|
||||
then
|
||||
(* ;;
|
||||
"This charset is is taken entirely from on another file, no need to copy it to this file.")
|
||||
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (GETMULTI (fetch (CHARSETINFO
|
||||
CSINFOPROPS)
|
||||
of CSINFO)
|
||||
'SOURCE)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE)
|
||||
NIL
|
||||
'PRINT)
|
||||
else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS)
|
||||
@@ -742,7 +753,8 @@
|
||||
(TERPRI STREAM))])
|
||||
|
||||
(MEDLEYFONT.WRITE.FONTPROPS
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:50 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 12-Aug-2025 17:55 by rmk")
|
||||
(* ; "Edited 10-Jun-2025 20:50 by rmk")
|
||||
(* ; "Edited 25-May-2025 20:50 by rmk")
|
||||
(* ; "Edited 22-May-2025 10:31 by rmk")
|
||||
(* ; "Edited 19-May-2025 10:42 by rmk")
|
||||
@@ -774,6 +786,10 @@
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONT)
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTSLUGWIDTH (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT)
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTTOMCCSFN (fetch (FONTDESCRIPTOR FONTTOMCCSFN) of FONT)
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICESPEC (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT)
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'OTHERDEVICEFONTPROPS (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
|
||||
@@ -810,36 +826,18 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.FILENAME
|
||||
[LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 10-Jun-2025 11:02 by rmk")
|
||||
[LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 4-Sep-2025 08:48 by rmk")
|
||||
(* ; "Edited 10-Jun-2025 11:02 by rmk")
|
||||
(* ; "Edited 25-May-2025 21:25 by rmk")
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
(* ; "Edited 16-May-2025 14:09 by rmk")
|
||||
|
||||
(* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT. If CHARSET, goes in the CHARSET subdirectory.")
|
||||
|
||||
(CL:WHEN (AND (LISTP CHARSET)
|
||||
(NULL (CDR CHARSET)))
|
||||
(SETQ CHARSET (CAR CHARSET))) (* ; "Edited 14-May-2025 12:02 by rmk")
|
||||
(LET (FAMILY SIZE FACE DEVICE FILENAME)
|
||||
[if (LISTP FONT)
|
||||
then (SETQ FAMILY (CAR FONT))
|
||||
(SETQ SIZE (CADR FONT))
|
||||
(SETQ FACE (OR (CADDR FONT)
|
||||
'MRR))
|
||||
(SETQ DEVICE (OR (CADDDR FONT)
|
||||
'DISPLAY))
|
||||
elseif (type? FONTDESCRIPTOR FONT)
|
||||
then (SETQ FAMILY (FONTPROP FONT 'FAMILY))
|
||||
(SETQ SIZE (FONTPROP FONT 'SIZE))
|
||||
(SETQ FACE (FONTPROP FONT 'FACE))
|
||||
(SETQ DEVICE (FONTPROP FONT 'DEVICE]
|
||||
(CL:WHEN (LISTP FACE)
|
||||
(SETQ FACE (CONCAT (NTHCHAR (CAR FACE)
|
||||
1)
|
||||
(NTHCHAR (CADR FACE)
|
||||
1)
|
||||
(NTHCHAR (CADDR FACE)
|
||||
1))))
|
||||
(LET (FAMILY SIZE FACE DEVICE ROTATION FILENAME)
|
||||
(SPREADFONTSPEC (CL:IF (type? FONTDESCRIPTOR FONT)
|
||||
(FONTPROP FONT 'SPEC)
|
||||
(\FONT.CHECKARGS FONT)))
|
||||
(CL:UNLESS EXTENSION
|
||||
(SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE)
|
||||
"FONT"))
|
||||
@@ -849,9 +847,10 @@
|
||||
(SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9)
|
||||
"0"
|
||||
"")
|
||||
SIZE "-" FACE (CL:IF (SMALLP CHARSET)
|
||||
(CONCAT "-C" (OCTALSTRING CHARSET))
|
||||
"")
|
||||
SIZE "-" (FONTFACETOATOM FACE)
|
||||
(CL:IF (SMALLP CHARSET)
|
||||
(CONCAT "-C" (OCTALSTRING CHARSET))
|
||||
"")
|
||||
"." EXTENSION))
|
||||
(PACKFILENAME 'BODY FILE 'BODY FILENAME])
|
||||
)
|
||||
@@ -904,11 +903,11 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2127 14772 (MEDLEYFONT.WRITE.FONT 2137 . 6995) (MEDLEYFONT.GETCHARSET 6997 . 9296) (
|
||||
MEDLEYFONT.CHARSET? 9298 . 10767) (MEDLEYFONT.GETFILEPROP 10769 . 12804) (MEDLEYFONT.FILEP 12806 .
|
||||
14770)) (14798 36689 (MEDLEYFONT.READ.FONT 14808 . 19241) (MEDLEYFONT.READ.CHARSET 19243 . 24137) (
|
||||
MEDLEYFONT.READ.ITEM 24139 . 30288) (MEDLEYFONT.PEEK.ITEM 30290 . 31152) (MEDLEYFONT.READ.FONTPROPS
|
||||
31154 . 31619) (MEDLEYFONT.READ.VERIFIEDFONT 31621 . 36687)) (36715 54244 (MEDLEYFONT.WRITE.CHARSET
|
||||
36725 . 41330) (MEDLEYFONT.WRITE.ITEM 41332 . 50385) (MEDLEYFONT.WRITE.FONTPROPS 50387 . 53589) (
|
||||
MEDLEYFONT.WRITE.HEADER 53591 . 54242)) (54245 56814 (MEDLEYFONT.FILENAME 54255 . 56812)))))
|
||||
(FILEMAP (NIL (2175 15697 (MEDLEYFONT.WRITE.FONT 2185 . 7151) (MEDLEYFONT.GETCHARSET 7153 . 10156) (
|
||||
MEDLEYFONT.CHARSET? 10158 . 11627) (MEDLEYFONT.GETFILEPROP 11629 . 13729) (MEDLEYFONT.FILEP 13731 .
|
||||
15695)) (15723 37913 (MEDLEYFONT.READ.FONT 15733 . 20165) (MEDLEYFONT.READ.CHARSET 20167 . 25525) (
|
||||
MEDLEYFONT.READ.ITEM 25527 . 31676) (MEDLEYFONT.PEEK.ITEM 31678 . 32540) (MEDLEYFONT.READ.FONTPROPS
|
||||
32542 . 33007) (MEDLEYFONT.READ.VERIFIEDFONT 33009 . 37911)) (37939 55776 (MEDLEYFONT.WRITE.CHARSET
|
||||
37949 . 42511) (MEDLEYFONT.WRITE.ITEM 42513 . 51566) (MEDLEYFONT.WRITE.FONTPROPS 51568 . 55121) (
|
||||
MEDLEYFONT.WRITE.HEADER 55123 . 55774)) (55777 57582 (MEDLEYFONT.FILENAME 55787 . 57580)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user