IMPORTFONTS: New file for organizing offline font construction (import, MCCS, complete)
This commit is contained in:
rmkaplan
906
library/IMPORTFONTS
Normal file
906
library/IMPORTFONTS
Normal file
@@ -0,0 +1,906 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
|
||||
|
||||
(FILECREATED " 5-Apr-2026 14:27:30" {WMEDLEY}<library>IMPORTFONTS.;94 59200
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS IMPORTFONTS IMPORTFONTS.DIRECTORY FAKEFACE)
|
||||
|
||||
:PREVIOUS-DATE " 5-Apr-2026 11:51:28" {WMEDLEY}<library>IMPORTFONTS.;92)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IMPORTFONTSCOMS)
|
||||
|
||||
(RPAQQ IMPORTFONTSCOMS
|
||||
((FNS IMPORTFONTS FONT.TO.MCCS IMPORTFONTS.FONTSPECS IMPORTFONTS.CONTEXT IMPORTFONTS.NOCACHE
|
||||
IMPORTFONTS.DIRECTORY IMPORTFONTS.CLEAR IMPORTFONTS.SUBDIR IMPORTFONTS.DIRSIZE)
|
||||
(FNS IMPORTFONTS.AVAILABLE IMPORTFONTS.EXISTS? IMPORTFONTS.DEPLOY)
|
||||
(FNS FAKEFACE FAKEFACE.FROMFILE FAKEFACE.FROMFONT)
|
||||
(FNS IMPORTFONTS.PHASES MISSINGFACE)
|
||||
(COMS (* ; "For legacy display imports")
|
||||
(FNS IMPORT.DISPLAY LEGACYDISPLAYFONT)
|
||||
(FILES ACFONT))
|
||||
(COMS (* ; "For testing")
|
||||
(FNS IPF IPFSIZES)
|
||||
(FNS PEF AEF IEF MEF CEF FEF EFCLOSE)
|
||||
(FNS SHOWCHARS CSSOURCE FONTDEFFONTS)
|
||||
(FILES EDITFONT))))
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORTFONTS
|
||||
[LAMBDA (PHASE FONTSPECS DEVICE FROMDIRECTORY TODIRECTORY IMPORTFN NODRIBBLE)
|
||||
(* ; "Edited 5-Apr-2026 14:22 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 08:15 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 08:25 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 16:41 by rmk")
|
||||
(* ; "Edited 29-Mar-2026 11:33 by rmk")
|
||||
(* ; "Edited 26-Mar-2026 12:47 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 15:00 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 11:16 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 09:44 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 15:56 by rmk")
|
||||
|
||||
(* ;; "Device-dependent IMPORTFN must be provided if PHASE is IMPORT, the other phases (MCCS, COMPLETE, FAKE) operate on Medleyfont files.")
|
||||
|
||||
(* ;; "If PHASE is MCCS, recodes source FONTSPECS to MCCS without completion, otherwise coerces/completes the specified MCCS fonts.")
|
||||
|
||||
(* ;; "Unless TODIRECTORY=DONT, writes the resultiing fonts Medley fontfiles, otherwise collects and returns them in a list (which will eat up storage). ")
|
||||
|
||||
(CL:UNLESS (MEMB (SETQ PHASE (U-CASE PHASE))
|
||||
'(IMPORT MCCS COMPLETE FAKE))
|
||||
(\ILLEGAL.ARG PHASE))
|
||||
(CL:UNLESS DEVICE
|
||||
(SETQ DEVICE 'DISPLAY))
|
||||
(CL:WHEN (AND (EQ PHASE 'IMPORT)
|
||||
(NOT (GETD IMPORTFN)))
|
||||
(ERROR "Importing from source requires an IMPORTFN"))
|
||||
(PROG1
|
||||
(RESETLST (* ;
|
||||
"Close dribble outside of this context")
|
||||
(CL:MULTIPLE-VALUE-SETQ (FROMDIRECTORY TODIRECTORY)
|
||||
(IMPORTFONTS.CONTEXT PHASE FROMDIRECTORY TODIRECTORY DEVICE))
|
||||
(IMPORTFONTS.CLEAR PHASE FONTSPECS TODIRECTORY DEVICE)
|
||||
(SETQ FONTSPECS (IMPORTFONTS.FONTSPECS PHASE FONTSPECS FROMDIRECTORY DEVICE))
|
||||
(CL:WHEN (AND (CDR FONTSPECS)
|
||||
(NOT NODRIBBLE)) (* ;
|
||||
"Put all the dribbles together one up")
|
||||
[DRIBBLE (PSEUDOFILENAME (PACKFILENAME 'BODY
|
||||
(OR (SUBSTRING TODIRECTORY 1
|
||||
(STRPOS ">" TODIRECTORY -2 NIL NIL NIL NIL
|
||||
T))
|
||||
LOGINHOST/DIR)
|
||||
'NAME PHASE 'EXTENSION 'DRIBBLE]
|
||||
(PRINTOUT T "Dribbling to " (FULLNAME (DRIBBLEFILE))
|
||||
T))
|
||||
(PRINTOUT T (SELECTQ PHASE
|
||||
(IMPORT "Importing ")
|
||||
(MCCS "MCCS recoding ")
|
||||
(COMPLETE "Completing ")
|
||||
(FAKE "Faking ")
|
||||
NIL)
|
||||
(LENGTH FONTSPECS)
|
||||
" " DEVICE " font" (CL:IF (IGEQ (LENGTH FONTSPECS)
|
||||
2)
|
||||
"s"
|
||||
""))
|
||||
(if TODIRECTORY
|
||||
then (PRINTOUT T 3 "from " FROMDIRECTORY 3 "to " TODIRECTORY T)
|
||||
else (PRINTOUT T " from " FROMDIRECTORY T 3 "(but not writing)" T))
|
||||
(BKSYSBUF " ")
|
||||
(IMPORTFONTS.CLEAR PHASE FONTSPECS TODIRECTORY DEVICE)
|
||||
(for FS FONT FONT FONTSTART TOFILE FROMFILE CAPTIONS THISTIME FROMSIZE TOSIZE CHANGED
|
||||
NOTINSTANTIATED TOTALTIME TODIRSIZE (FROMDIRSIZE ← (CL:IF (EQ PHASE 'IMPORT)
|
||||
0
|
||||
(IMPORTFONTS.DIRSIZE PHASE
|
||||
DEVICE FROMDIRECTORY))
|
||||
)
|
||||
(NNOCHARSETS ← 0) in FONTSPECS as I from 1 first (SETQ TOTALTIME (CLOCK 0))
|
||||
eachtime (PRINTOUT T .I3 I ". " (fetch (FONTSPEC FSFAMILY) of FS)
|
||||
" " .I2 (fetch (FONTSPEC FSSIZE) of FS)
|
||||
" "
|
||||
(FONTFACETOATOM (fetch (FONTSPEC FSFACE) of FS)))
|
||||
(SETQ THISTIME (CLOCK 0))
|
||||
collect (SELECTQ PHASE
|
||||
(IMPORT (SETQ FONT (APPLY* IMPORTFN FS FROMDIRECTORY))
|
||||
(SETQ CHANGED T))
|
||||
((MCCS COMPLETE)
|
||||
(SETQ FROMFILE (INFILEP (MEDLEYFONT.FILENAME FS FROMDIRECTORY)))
|
||||
(if FROMFILE
|
||||
then (SETQ FONT (MEDLEYFONT.READ.FONT FROMFILE 'ALL))
|
||||
(SETQ FROMSIZE (GETFILEINFO FROMFILE 'LENGTH))
|
||||
else (SETQ FONT (FONTCREATE.SLUGFD FS))
|
||||
(SETQ FROMSIZE 0))
|
||||
(SETQ CHANGED (SELECTQ PHASE
|
||||
(MCCS (FONT.TO.MCCS FONT))
|
||||
(COMPLETE (COMPLETE.FONT FONT T))
|
||||
NIL)))
|
||||
(FAKE (CL:MULTIPLE-VALUE-SETQ (FONT FROMFILE)
|
||||
(FAKEFACE.FROMFONT FS FROMDIRECTORY))
|
||||
(SETQ FROMSIZE (GETFILEINFO FROMFILE 'LENGTH))
|
||||
(SETQ CHANGED (FAKEFACE FONT)))
|
||||
NIL)
|
||||
(CL:WHEN [SETQ NOTINSTANTIATED (EQ 0 (FONTPROP FONT 'NINSTANTIATEDCHARSETS]
|
||||
(add NNOCHARSETS 1))
|
||||
(CL:WHEN TODIRECTORY
|
||||
(SETQ TOFILE (MEDLEYFONT.FILENAME FS TODIRECTORY))
|
||||
(SETQ TOFILE (CL:IF CHANGED
|
||||
(MEDLEYFONT.WRITE.FONT FONT TOFILE)
|
||||
(COPYFILE FROMFILE TOFILE))))
|
||||
(SETQ THISTIME (FQUOTIENT (IDIFFERENCE (CLOCK 0)
|
||||
THISTIME)
|
||||
1000))
|
||||
(if NOTINSTANTIATED
|
||||
then (PRINTOUT T 26 "No instantiated charsets" 41 .F7.2 THISTIME)
|
||||
elseif TOFILE
|
||||
then (SETQ TOSIZE (GETFILEINFO TOFILE 'LENGTH))
|
||||
(SELECTQ PHASE
|
||||
(IMPORT (PRINTOUT T 25 .I6 TOSIZE " " .F7.2 THISTIME))
|
||||
((MCCS COMPLETE FAKE)
|
||||
(if CHANGED
|
||||
then (PRINTOUT T 25 .I6 FROMSIZE " -> " .I6 TOSIZE " "
|
||||
.F6.2 THISTIME 50 .I5 (IDIFFERENCE TOSIZE
|
||||
FROMSIZE))
|
||||
else (PRINTOUT T 28 "Copied " .I6 TOSIZE " " .F6.2 THISTIME)
|
||||
))
|
||||
NIL))
|
||||
(TERPRI T)
|
||||
(CL:IF TODIRECTORY
|
||||
TOFILE
|
||||
FONT) finally (SETQ TOTALTIME (FIXR (FQUOTIENT (IDIFFERENCE (CLOCK 0)
|
||||
TOTALTIME)
|
||||
1000)))
|
||||
(PRINTOUT T 4 (IDIFFERENCE (LENGTH $$VAL)
|
||||
NNOCHARSETS)
|
||||
" font"
|
||||
(CL:IF (IGEQ (LENGTH $$VAL)
|
||||
2)
|
||||
"s "
|
||||
" ")
|
||||
(SELECTQ PHASE
|
||||
(IMPORT "imported")
|
||||
(MCCS "recoded to MCCS")
|
||||
(COMPLETE "completed")
|
||||
(FAKE "faked")
|
||||
NIL))
|
||||
(if TODIRECTORY
|
||||
then (SETQ TODIRSIZE (IMPORTFONTS.DIRSIZE PHASE DEVICE
|
||||
TODIRECTORY))
|
||||
(PRINTOUT T " and written in " TOTALTIME " seconds" 4
|
||||
"Total size is " (FIXR (FQUOTIENT TODIRSIZE 1024
|
||||
))
|
||||
" KB, grew by "
|
||||
(FIXR (FQUOTIENT (IDIFFERENCE TODIRSIZE
|
||||
FROMDIRSIZE)
|
||||
1024))
|
||||
" KB" T)
|
||||
(CL:UNLESS (EQ 0 NNOCHARSETS)
|
||||
(PRINTOUT T 4 NNOCHARSETS
|
||||
" fonts had no character sets" T))
|
||||
(CL:WHEN (AND TODIRECTORY (IGEQ (LENGTH $$VAL)
|
||||
5))
|
||||
(SETQ $$VAL TODIRECTORY))
|
||||
else (PRINTOUT T " (but not written) in " TOTALTIME " seconds"
|
||||
T))))
|
||||
(CL:WHEN (DRIBBLEFILE)
|
||||
(PRINTOUT T "Dribbled to " (FULLNAME (DRIBBLEFILE))
|
||||
T)
|
||||
[TEDIT (DRIBBLE)
|
||||
'Dribble NIL `(TITLE ,(CONCAT PHASE " font dribble" " " (DATE))
|
||||
LEAVETTY T READONLY QUIET PARABREAKCHARS NIL FONT DEFAULTFONT
|
||||
OPENWIDTH ,(fetch (REGION WIDTH) of (WINDOWPROP (WFROMDS
|
||||
T)
|
||||
'REGION))
|
||||
OPENHEIGHT
|
||||
,(fetch (REGION HEIGHT) of (WINDOWPROP (WFROMDS T)
|
||||
'REGION]))])
|
||||
|
||||
(FONT.TO.MCCS
|
||||
[LAMBDA (FONT) (* ; "Edited 10-Mar-2026 00:23 by rmk")
|
||||
(* ; "Edited 7-Mar-2026 12:55 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 13:43 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 17:13 by rmk")
|
||||
(* ; "Edited 6-Sep-2025 16:43 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 15:20 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 11:25 by rmk")
|
||||
(* ; "Edited 27-Aug-2025 17:36 by rmk")
|
||||
|
||||
(* ;;
|
||||
"Move character information in font to their MCCS positions, with coercions otherwise suppressed. ")
|
||||
|
||||
(* ;; "If there are no mappings, prints a message and returns INFONT.")
|
||||
|
||||
(LET [(PAIRS (MCCSMAPPAIRS (FONTPROP FONT 'CHARENCODING]
|
||||
(CL:WHEN PAIRS
|
||||
(MOVEFONTCHARS PAIRS FONT FONT)
|
||||
|
||||
(* ;; "Keep the map function even for coerced MCCS fonts--can still be used for code conversion (e.g. Tedit file updating) ")
|
||||
|
||||
[replace (FONTDESCRIPTOR FONTTOMCCSFN) of FONT with (MCCSMAPFN (FONTPROP FONT
|
||||
'CHARENCODING]
|
||||
(replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL)
|
||||
(CL:WHEN (MEMB (FONTPROP FONT 'CHARENCODING)
|
||||
'(GACHA XCCS$ ALTOTEXT PALATINO UNICODE))
|
||||
(replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with 'MCCS)
|
||||
(* ; "These fonts made it all the way")
|
||||
(CHARSETPROP (\GETCHARSETINFO FONT 0)
|
||||
'CSCHARENCODING
|
||||
'MCCS))
|
||||
T)])
|
||||
|
||||
(IMPORTFONTS.FONTSPECS
|
||||
[LAMBDA (PHASE FONTSPECS FROMDIRECTORY DEVICE) (* ; "Edited 4-Apr-2026 11:41 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 00:51 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 12:50 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 23:27 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 08:58 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:50 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:53 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 10:44 by rmk")
|
||||
|
||||
(* ;; "Crucially, the fontspecs for COMPLETE and FAKEFACE must be ordered so that coercions or faces come before the fontspecs that depend on them. E.g. the order of faces has to be MRR MIR/BRR BIR. That means that the TODIRECTORY can be the source for the completion/faking of later fonts.")
|
||||
|
||||
(CL:UNLESS DEVICE
|
||||
(SETQ DEVICE 'DISPLAY))
|
||||
(SETQ FROMDIRECTORY (IMPORTFONTS.DIRECTORY DEVICE FROMDIRECTORY (IMPORTFONTS.SUBDIR PHASE)))
|
||||
(RESETLST
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES FROMDIRECTORY)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(LET [(EXPANDED (CL:REMOVE-DUPLICATES
|
||||
(for F inside (CL:IF (type? FONTSPEC FONTSPECS)
|
||||
(CONS FONTSPECS)
|
||||
(OR FONTSPECS '*))
|
||||
join (if (type? FONTSPEC F)
|
||||
then (for FACE in (FONTFACE.STARS (fetch (FONTSPEC FSFACE)
|
||||
of (\FONT.CHECKARGS F)))
|
||||
collect (create FONTSPEC
|
||||
using F FSFACE ← FACE FSDEVICE ← DEVICE
|
||||
FSROTATION ← 0))
|
||||
elseif (LITATOM F)
|
||||
then
|
||||
(* ;; "Looks in FROMDIRECTORY")
|
||||
|
||||
(IMPORTFONTS.AVAILABLE PHASE (MAKEFONTSPEC
|
||||
(OR F '*)
|
||||
'*
|
||||
'* 0 DEVICE)
|
||||
FROMDIRECTORY)
|
||||
else (\ILLEGAL.ARG F)))
|
||||
:TEST
|
||||
(FUNCTION EQUAL]
|
||||
(SELECTQ PHASE
|
||||
(COMPLETE
|
||||
(* ;; "Fonts have to be ordered so that a coercion target is done before the font that needs it (e.g. CLASSIC before MODERN before TERMINAL before GACHA). This is essentially a topsort")
|
||||
|
||||
(for FONTSPEC NEWFONTS in EXPANDED
|
||||
do (for F in (DREVERSE (CONS FONTSPEC (COERCEFONTSPEC FONTSPEC
|
||||
'CHARCOERCIONS T)))
|
||||
unless (MEMBER F NEWFONTS) when (IMPORTFONTS.EXISTS? 'COMPLETE F
|
||||
FROMDIRECTORY)
|
||||
do (push NEWFONTS F)) finally
|
||||
|
||||
(* ;;
|
||||
"We may have requested a font that doesn't exist at all on its own: HELVETICA 10 MIR")
|
||||
|
||||
(for F in EXPANDED
|
||||
unless (MEMBER F NEWFONTS)
|
||||
do (push NEWFONTS F))
|
||||
(RETURN (DREVERSE NEWFONTS))))
|
||||
(FAKE
|
||||
(* ;;
|
||||
"If e.g. BIR is in the list, then so should be BMR, MIR, and if those are there, then so should MRR")
|
||||
|
||||
(for ETAIL FS FACE SOURCE NEWFONTS on EXPANDED
|
||||
do (SETQ FS (CAR ETAIL))
|
||||
(SETQ FACE (fetch (FONTSPEC FSFACE) of FS))
|
||||
(CL:WHEN (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(* ;
|
||||
"BRR -> MRR, BIR ->MIR which goes to MRR")
|
||||
(for FC SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE WEIGHT ←
|
||||
'MEDIUM))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← FC))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIRECTORY)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
(CL:WHEN (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(* ; "MIR -> MRR, BIR ->BMR")
|
||||
(for F SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE SLOPE ← 'REGULAR))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← F))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIRECTORY)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
(CL:WHEN (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(* ; "MRC -> MRR")
|
||||
(for F SOURCE in (FONTFACE.STARS (create FONTFACE
|
||||
using FACE EXPANSION ←
|
||||
'REGULAR))
|
||||
eachtime (SETQ SOURCE (create FONTSPEC using FS FSFACE ← F))
|
||||
when (IMPORTFONTS.EXISTS? 'FAKE SOURCE FROMDIRECTORY)
|
||||
do (push NEWFONTS SOURCE)))
|
||||
finally (for F in EXPANDED unless (MEMBER F NEWFONTS)
|
||||
do (push NEWFONTS F))
|
||||
(RETURN (DREVERSE NEWFONTS))))
|
||||
(SORTFONTSPECS EXPANDED))))])
|
||||
|
||||
(IMPORTFONTS.CONTEXT
|
||||
[LAMBDA (PHASE FROMDIRECTORY TODIRECTORY DEVICE) (* ; "Edited 4-Apr-2026 09:33 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 23:11 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:53 by rmk")
|
||||
(* ; "Edited 18-Mar-2026 22:36 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 09:01 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:56 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:52 by rmk")
|
||||
(* ; "Edited 3-Mar-2026 21:58 by rmk")
|
||||
|
||||
(* ;; "This sets up the FONTDEVICE props according to PHASE, using default values for the directories if they aren't specified. Returns the TODIRECTORY, or NIL if the TODIRECTORY was DONT=don't file.")
|
||||
|
||||
[SETQ FROMDIRECTORY (IMPORTFONTS.DIRECTORY DEVICE FROMDIRECTORY (IMPORTFONTS.SUBDIR
|
||||
(SELECTQ PHASE
|
||||
(IMPORT 'SOURCE)
|
||||
(MCCS 'IMPORT)
|
||||
(COMPLETE 'MCCS)
|
||||
(FAKE 'COMPLETE)
|
||||
NIL]
|
||||
(SETQ TODIRECTORY (IMPORTFONTS.DIRECTORY DEVICE TODIRECTORY (IMPORTFONTS.SUBDIR PHASE)))
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTCOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTCOERCIONS OLDVALUE]
|
||||
(SELECTQ PHASE
|
||||
((IMPORT MCCS)
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES FROMDIRECTORY)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE])
|
||||
(COMPLETE
|
||||
(* ;; "Make FONTCREATE1 in the COMPLETE phase draw from previously import-completed fonts, not from the currently active fonts")
|
||||
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES (LIST TODIRECTORY FROMDIRECTORY)
|
||||
)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(* ; "Suppress face faking")
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FACECOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FACECOERCIONS OLDVALUE])
|
||||
(FAKE
|
||||
(* ;; "Make FONTCREATE1 in the FAKE phase draw from previously import-completed fonts, not from the currently active fonts")
|
||||
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES (LIST TODIRECTORY FROMDIRECTORY))
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTDIRECTORIES OLDVALUE]
|
||||
(* ; "Completion has already been done")
|
||||
[RESETSAVE (FONTDEVICEPROP DEVICE 'FONTCOERCIONS NIL)
|
||||
`(PROGN (FONTDEVICEPROP ',DEVICE 'FONTCOERCIONS OLDVALUE])
|
||||
NIL)
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(CL:VALUES FROMDIRECTORY TODIRECTORY])
|
||||
|
||||
(IMPORTFONTS.NOCACHE
|
||||
[LAMBDA NIL (* ; "Edited 3-Mar-2026 11:54 by rmk")
|
||||
(RESETSAVE \FONTSINCORE NIL)
|
||||
(RESETSAVE \FONTEXISTS?-CACHE NIL)
|
||||
(RESETSAVE \FONTSAVAILABLEFILECACHE NIL])
|
||||
|
||||
(IMPORTFONTS.DIRECTORY
|
||||
[LAMBDA (DEVICE DIRECTORY SUBDIR) (* ; "Edited 5-Apr-2026 14:17 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 22:59 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 22:40 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 09:35 by rmk")
|
||||
(* ; "Edited 9-Mar-2026 09:14 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:46 by rmk")
|
||||
(CL:UNLESS (MEMB DIRECTORY '(DONT DON'T))
|
||||
[PSEUDOFILENAME (OR DIRECTORY (CONCAT MEDLEYDIR "internal>fonts>"
|
||||
(L-CASE (CONCAT (OR (if (type? FONTDESCRIPTOR DEVICE)
|
||||
then (FONTPROP DEVICE
|
||||
'DEVICE)
|
||||
elseif (type? FONTSPEC DEVICE)
|
||||
then (fetch (FONTSPEC FSDEVICE)
|
||||
of (\FONT.CHECKARGS
|
||||
DEVICE))
|
||||
elseif (NOT (LITATOM DEVICE))
|
||||
then (\ILLEGAL.ARG DEVICE)
|
||||
elseif DEVICE
|
||||
else 'DISPLAY))
|
||||
">"
|
||||
(CL:IF SUBDIR
|
||||
(CONCAT SUBDIR ">")
|
||||
"")])])
|
||||
|
||||
(IMPORTFONTS.CLEAR
|
||||
[LAMBDA (PHASE FONTSPECS TODIRECTORY DEVICE) (* ; "Edited 4-Apr-2026 10:03 by rmk")
|
||||
(* ; "Edited 3-Apr-2026 01:06 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 12:37 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 22:51 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 09:31 by rmk")
|
||||
(CL:WHEN [AND TODIRECTORY (MEMB PHASE '(COMPLETE FAKE] (* ;
|
||||
"Previous completions could serve as inputs for later ones, start fresh.")
|
||||
(LET (NDELETED)
|
||||
[SETQ NDELETED (if FONTSPECS
|
||||
then (for FS in (CL:IF (type? FONTSPEC FONTSPECS)
|
||||
(CONS FONTSPECS)
|
||||
FONTSPECS)
|
||||
sum (for FILE in (FILDIR (PACKFILENAME 'VERSION '*
|
||||
'BODY
|
||||
(MEDLEYFONT.FILENAME FS
|
||||
TODIRECTORY)))
|
||||
count (DELFILE FILE)))
|
||||
else (for FILE
|
||||
in [FILDIR (PACKFILENAME 'DIRECTORY TODIRECTORY 'NAME
|
||||
'*
|
||||
'VERSION
|
||||
'*
|
||||
'EXTENSION
|
||||
(CAR (MKLIST (FONTDEVICEPROP DEVICE
|
||||
'FONTEXTENSIONS]
|
||||
count (DELFILE FILE]
|
||||
(CL:UNLESS (EQ 0 NDELETED)
|
||||
(PRINTOUT T (SELECTQ NDELETED
|
||||
(1 "1 font")
|
||||
(CONCAT NDELETED " fonts"))
|
||||
" deleted from "
|
||||
(PSEUDOFILENAME TODIRECTORY)
|
||||
T))))])
|
||||
|
||||
(IMPORTFONTS.SUBDIR
|
||||
[LAMBDA (PHASE FROMFLAG) (* ; "Edited 30-Mar-2026 16:27 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:53 by rmk")
|
||||
(CL:IF FROMFLAG
|
||||
(SELECTQ PHASE
|
||||
(IMPORT "imported")
|
||||
(MCCS "imported")
|
||||
(COMPLETE "mccs")
|
||||
(FAKE "completed")
|
||||
(\ILLEGAL.ARG))
|
||||
(SELECTQ PHASE
|
||||
(SOURCE "source")
|
||||
(IMPORT "imported")
|
||||
(MCCS "mccs")
|
||||
(COMPLETE "completed")
|
||||
(FAKE "faked")
|
||||
(\ILLEGAL.ARG)))])
|
||||
|
||||
(IMPORTFONTS.DIRSIZE
|
||||
[LAMBDA (PHASE DEVICE DIRECTORY FROMFLAG) (* ; "Edited 30-Mar-2026 16:30 by rmk")
|
||||
(DIRECTORY (PACKFILENAME 'DIRECTORY (IMPORTFONTS.DIRECTORY DEVICE DIRECTORY (IMPORTFONTS.SUBDIR
|
||||
PHASE FROMFLAG))
|
||||
'NAME
|
||||
'*
|
||||
'EXTENSION
|
||||
[CAR (MKLIST (FONTDEVICEPROP (OR DEVICE 'DISPLAY)
|
||||
'FONTEXTENSIONS]
|
||||
'VERSION "")
|
||||
'COUNTLENGTH])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORTFONTS.AVAILABLE
|
||||
[LAMBDA (PHASE FONTSPEC FROMDIRECTORY) (* ; "Edited 22-Mar-2026 13:36 by rmk")
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP FONTSPEC 'FONTDIRECTORIES (IMPORTFONTS.DIRECTORY FONTSPEC
|
||||
FROMDIRECTORY (IMPORTFONTS.SUBDIR
|
||||
PHASE)))
|
||||
`(PROGN (FONTDEVICEPROP ',FONTSPEC 'FONTDIRECTORIES OLDVALUE]
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(FONTSAVAILABLE FONTSPEC NIL NIL NIL NIL 'ONLY))])
|
||||
|
||||
(IMPORTFONTS.EXISTS?
|
||||
[LAMBDA (PHASE FONTSPEC FROMDIRECTORY) (* ; "Edited 22-Mar-2026 14:55 by rmk")
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP FONTSPEC 'FONTDIRECTORIES (IMPORTFONTS.DIRECTORY FONTSPEC
|
||||
FROMDIRECTORY (IMPORTFONTS.SUBDIR
|
||||
PHASE)))
|
||||
`(PROGN (FONTDEVICEPROP ',FONTSPEC 'FONTDIRECTORIES OLDVALUE]
|
||||
(IMPORTFONTS.NOCACHE)
|
||||
(FONTEXISTS? FONTSPEC NIL NIL NIL NIL T))])
|
||||
|
||||
(IMPORTFONTS.DEPLOY
|
||||
[LAMBDA (PHASE FONTSPECS DEVICE FROMDIRECTORY TODIRECTORY) (* ; "Edited 30-Mar-2026 12:39 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
|
||||
(* ;; "Copies the FONTSPECS fonts from the FROMDIRECTOY to the TODIRECTORY, defaulting to the PHASE from directory and the (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES)), replacing what's there.")
|
||||
|
||||
(* ;;
|
||||
"Implicitly copies all of the indirect targets fonts of the fonts in FONTSPEC, recursively.")
|
||||
|
||||
(CL:UNLESS PHASE
|
||||
(SETQ PHASE 'FAKE))
|
||||
(CL:UNLESS DEVICE
|
||||
(SETQ DEVICE 'DISPLAY))
|
||||
(SETQ FROMDIRECTORY (IMPORTFONTS.DIRECTORY DEVICE FROMDIRECTORY (IMPORTFONTS.SUBDIR PHASE)))
|
||||
(CL:UNLESS TODIRECTORY
|
||||
[SETQ TODIRECTORY (PSEUDOFILENAME (CAR (MKLIST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES])
|
||||
(LET ((FONTSPECS (IMPORTFONTS.FONTSPECS PHASE FONTSPECS NIL DEVICE)))
|
||||
(SETQ FONTSPECS (CL:REMOVE-DUPLICATES (APPEND (for FS FONT in FONTSPECS
|
||||
join (MEDLEYFONT.GETFILEPROP (
|
||||
MEDLEYFONT.FILENAME
|
||||
FS
|
||||
FROMDIRECTORY
|
||||
)
|
||||
'INDIRECTS))
|
||||
FONTSPECS)
|
||||
:TEST
|
||||
(FUNCTION EQUAL)))
|
||||
(for FS (N ← 0) in FONTSPECS do (COPYFILE (MEDLEYFONT.FILENAME FS FROMDIRECTORY)
|
||||
(MEDLEYFONT.FILENAME FS TODIRECTORY))
|
||||
(FLUSHFONTCACHE NIL FS)
|
||||
(add N 1)
|
||||
finally (PRINTOUT T N " fonts copied from " FROMDIRECTORY " to " TODIRECTORY T])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(FAKEFACE
|
||||
[LAMBDA (FONT) (* ; "Edited 5-Apr-2026 14:10 by rmk")
|
||||
(* ; "Edited 4-Apr-2026 09:38 by rmk")
|
||||
(* ; "Edited 1-Apr-2026 09:00 by rmk")
|
||||
(* ; "Edited 24-Mar-2026 22:14 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 14:37 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 23:53 by rmk")
|
||||
|
||||
(* ;; "FONTSPEC describes a font that has already been completed in terms of its CHARCOERCIONS.")
|
||||
|
||||
(* ;; "Suppose FONTSPEC describes a (display) BRR font. If it has not been completed (i.e., it is still just MCCS), then all of the glyphs in all of its character sets are natively bold.")
|
||||
|
||||
(* ;; "If it has been completed without facefaking, then some of its characters may have been retrieved from other fonts, and those are mixed in with its native glyphs. But presumably, those characters are also drawn from a BRR font, on the assumption that CHARCOERCIONS tends to preserve faces.")
|
||||
|
||||
(* ;; "So: it is correct to run through all of the slugs, grab the corresponding glyphs from the already completed MRR, if it exists, and insert the bolded versions of those characters.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(LET* ((FONTSPEC (FONTPROP FONT 'DEVICESPEC))
|
||||
(FACE (fetch (FONTSPEC FSFACE) of FONTSPEC))
|
||||
SOURCEFONT CHANGED)
|
||||
(CL:UNLESS (EQ 'DISPLAY (FONTPROP FONT 'DEVICE))
|
||||
(ERROR "Only display fonts can be face-faked" FONT))
|
||||
(CL:UNLESS (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT)
|
||||
(ERROR "Fonts must be completed before face-faking" FONTSPEC))
|
||||
(CL:WHEN [AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSWEIGHT ←
|
||||
'MEDIUM]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MAKEBOLD.CHAR)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
(CL:WHEN [AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSSLOPE ←
|
||||
'REGULAR]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MAKEITALIC.CHAR)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
(CL:WHEN [AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(SETQ SOURCEFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSEXPANSION ←
|
||||
'REGULAR]
|
||||
(for CHARSET from 0 to (MAXCHARSET FONT) when (FAKEFACE.CHARSET FONT CHARSET
|
||||
(FUNCTION MOVEFONTCHARS)
|
||||
SOURCEFONT)
|
||||
do (SETQ CHANGED T)))
|
||||
CHANGED])
|
||||
|
||||
(FAKEFACE.FROMFILE
|
||||
[LAMBDA (FONTSPEC FROMDIRECTORY) (* ; "Edited 4-Apr-2026 09:42 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 23:17 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 09:03 by rmk")
|
||||
(* ; "Edited 19-Mar-2026 11:53 by rmk")
|
||||
(* ;
|
||||
"Start with MRR for a face that doesn't yet exist (HELVETICA MIR).")
|
||||
(OR (INFILEP (MEDLEYFONT.FILENAME FONTSPEC FROMDIRECTORY))
|
||||
(LET ((FACE (fetch (FONTSPEC FSFACE) of FONTSPEC)))
|
||||
(OR (AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(INFILEP (MEDLEYFONT.FILENAME (create FONTSPEC using FONTSPEC FSFACE ←
|
||||
(MAKEFONTFACE 'MEDIUM NIL
|
||||
NIL FACE))
|
||||
FROMDIRECTORY)))
|
||||
(AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE))
|
||||
(FAKEFACE.FROMFILE (create FONTSPEC using FONTSPEC FSFACE ← (MAKEFONTFACE
|
||||
NIL
|
||||
'REGULAR NIL FACE)
|
||||
)
|
||||
FROMDIRECTORY))
|
||||
(AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE))
|
||||
(FAKEFACE.FROMFILE (create FONTSPEC using FONTSPEC FSFACE ← (MAKEFONTFACE
|
||||
NIL NIL
|
||||
'REGULAR FACE))
|
||||
FROMDIRECTORY))
|
||||
(ERROR "No source for face-faking" FONTSPEC])
|
||||
|
||||
(FAKEFACE.FROMFONT
|
||||
[LAMBDA (FONTSPEC FROMDIRECTORY) (* ; "Edited 19-Mar-2026 20:42 by rmk")
|
||||
|
||||
(* ;; "If FONTSPEC doesn't identifyan existing font that needs to be coerced, we create an empty starting font full of slug charsets. ")
|
||||
|
||||
(LET (FROMFILE FONT)
|
||||
(SETQ FROMFILE (FAKEFACE.FROMFILE FONTSPEC FROMDIRECTORY))
|
||||
(SETQ FONT (MEDLEYFONT.READ.FONT FROMFILE 'ALL))
|
||||
(CL:UNLESS (EQUAL FONTSPEC (FONTPROP FONT 'SPEC))
|
||||
|
||||
(* ;; "We catch all the other properties of the backing font--encoding etc.")
|
||||
|
||||
(SETQ FONT (FONTCREATE.SLUGFD FONTSPEC FONT)))
|
||||
(CL:VALUES FONT FROMFILE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORTFONTS.PHASES
|
||||
[LAMBDA (PHASES DEVICE FONTSPECS FROMDIRECTORY TODIRECTORY)(* ; "Edited 24-Mar-2026 11:00 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 00:45 by rmk")
|
||||
(TDRIBBLE)
|
||||
(PROG1 (for P inside PHASES do (if (EQ P 'DEPLOY)
|
||||
then (IMPORTFONTS.DEPLOY 'FAKE FONTSPECS DEVICE FROMDIRECTORY
|
||||
TODIRECTORY)
|
||||
else (IMPORTFONTS P FONTSPECS DEVICE FROMDIRECTORY TODIRECTORY
|
||||
NIL T)
|
||||
(TERPRI T)))
|
||||
(DRIBBLE])
|
||||
|
||||
(MISSINGFACE
|
||||
[LAMBDA (DIRECTORY) (* ; "Edited 30-Mar-2026 23:06 by rmk")
|
||||
(* ; "Edited 26-Mar-2026 12:13 by rmk")
|
||||
(* ; "Edited 25-Mar-2026 00:59 by rmk")
|
||||
(LET [MRRS MIRS BRRS BIRS OTHERS (FAMILIESOFINTEREST
|
||||
(CL:REMOVE-DUPLICATES (APPEND ALTOFONTFAMILIES NSFONTFAMILIES
|
||||
(for C
|
||||
in (FONTDEVICEPROP 'DISPLAY
|
||||
'CHARCOERCIONS)
|
||||
when (LITATOM (CAR C))
|
||||
collect (CAR C]
|
||||
(for FS FACE in (for F FONTSPEC in (FILDIR (PACKFILENAME 'BODY DIRECTORY 'BODY
|
||||
'*-*.MEDLEYDISPLAYFONT))
|
||||
eachtime (SETQ FONTSPEC (FONTSPECFROMFILENAME F))
|
||||
when (MEMB (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
FAMILIESOFINTEREST) collect (FONTSPECFROMFILENAME F))
|
||||
do (SETQ FACE (fetch (FONTSPEC FSFACE) of FS))
|
||||
(replace (FONTSPEC FSFACE) of FS with 'FACE)
|
||||
(SELECTQ (FONTFACETOATOM FACE)
|
||||
(MRR (push MRRS FS))
|
||||
(MIR (push MIRS FS))
|
||||
(BRR (push BRRS FS))
|
||||
(BIR (push BIRS FS))
|
||||
(push OTHERS FS)))
|
||||
(for MRR NEEDED in MRRS do (CL:UNLESS (MEMBER MRR MIRS)
|
||||
(push NEEDED (SUBST '(MEDIUM ITALIC REGULAR)
|
||||
'FACE MRR)))
|
||||
(CL:UNLESS (MEMBER MRR BRRS)
|
||||
(push NEEDED (SUBST '(BOLD REGULAR REGULAR)
|
||||
'FACE MRR)))
|
||||
(CL:UNLESS (MEMBER MRR BIRS)
|
||||
(push NEEDED (SUBST '(BOLD ITALIC REGULAR)
|
||||
'FACE MRR)))
|
||||
finally (RETURN (SORTFONTSPECS NEEDED])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "For legacy display imports")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(IMPORT.DISPLAY
|
||||
[LAMBDA (FONTSPECS NODRIBBLE) (* ; "Edited 28-Mar-2026 23:08 by rmk")
|
||||
(* ; "Edited 18-Mar-2026 23:54 by rmk")
|
||||
(IMPORTFONTS 'IMPORT FONTSPECS 'DISPLAY NIL NIL (FUNCTION LEGACYDISPLAYFONT])
|
||||
|
||||
(LEGACYDISPLAYFONT
|
||||
[LAMBDA (FONTSPEC FROMDIRECTORY) (* ; "Edited 31-Mar-2026 15:01 by rmk")
|
||||
(* ; "Edited 28-Mar-2026 09:27 by rmk")
|
||||
|
||||
(* ;; "Loads legacy display fonts (ac or strike format, gacha, terminal, helevetica...) from FROMDIRECTORY. If NIL, the current directory")
|
||||
|
||||
(SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL 'DISPLAY T))
|
||||
(RESETLST
|
||||
[RESETSAVE (FONTDEVICEPROP 'DISPLAY 'FONTDIRECTORIES FROMDIRECTORY)
|
||||
`(PROGN (FONTDEVICEPROP 'DISPLAY 'FONTDIRECTORIES OLDVALUE]
|
||||
[RESETSAVE (FONTDEVICEPROP 'DISPLAY 'FONTEXTENSIONS '(DISPLAYFONT)
|
||||
FROMDIRECTORY)
|
||||
`(PROGN (FONTDEVICEPROP 'DISPLAY 'FONTEXTENSIONS OLDVALUE]
|
||||
(for CSNO CSINFO (FONT ← (FONTSPEC.TO.FONTDESCRIPTOR FONTSPEC 255)) from 0 to 255
|
||||
do [SETQ CSINFO (\READCHARSET FONTSPEC CSNO FONT '((AC ACFONT.FILEP ACFONT.GETCHARSET)
|
||||
(STRIKE STRIKEFONT.FILEP
|
||||
STRIKEFONT.GETCHARSET]
|
||||
|
||||
(* ;; "NIL means empty")
|
||||
|
||||
(CL:IF CSINFO
|
||||
(\INSTALLCHARSETINFO FONT CSINFO CSNO)
|
||||
(\SETCHARSETINFO FONT CSNO (SLUGCSINFO FONT))) finally (RETURN FONT)))])
|
||||
)
|
||||
|
||||
(FILESLOAD ACFONT)
|
||||
|
||||
|
||||
|
||||
(* ; "For testing")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(IPF
|
||||
[LAMBDA (PHASE FONTSPEC) (* ; "Edited 30-Mar-2026 12:44 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 22:46 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 00:54 by rmk")
|
||||
(MEDLEYFONT.READ.FONT (MEDLEYFONT.FILENAME FONTSPEC (IMPORTFONTS.DIRECTORY
|
||||
(OR (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
'DISPLAY)
|
||||
NIL
|
||||
(IMPORTFONTS.SUBDIR PHASE)))
|
||||
'ALL])
|
||||
|
||||
(IPFSIZES
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 30-Mar-2026 12:45 by rmk")
|
||||
(* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 00:59 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 08:43 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:33 by rmk")
|
||||
|
||||
(* ;; "Returns the file sizes for all the phases of FONTSPEC")
|
||||
|
||||
(if (type? FONTSPEC FONTSPEC)
|
||||
then (SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL NIL T))
|
||||
else (SETQ FONTSPEC (FONTSPECFROMFILENAME FONTSPEC)))
|
||||
(for PHASE DIR FONTFILE SIZE LASTSIZE in '(IMPORT MCCS COMPLETE FAKE)
|
||||
eachtime (SETQ DIR (IMPORTFONTS.DIRECTORY FONTSPEC NIL (IMPORTFONTS.SUBDIR PHASE)))
|
||||
when (SETQ FONTFILE (INFILEP (MEDLEYFONT.FILENAME FONTSPEC DIR)))
|
||||
collect (SETQ FONTFILE (INFILEP (MEDLEYFONT.FILENAME FONTSPEC DIR)))
|
||||
[SETQ SIZE (CL:IF FONTFILE
|
||||
(GETFILEINFO FONTFILE 'LENGTH))]
|
||||
(PROG1 [LIST* PHASE SIZE (CL:IF LASTSIZE
|
||||
(CONS (IDIFFERENCE SIZE LASTSIZE)))]
|
||||
(SETQ LASTSIZE SIZE])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(PEF
|
||||
[LAMBDA (PHASE FONTSPEC CHARSET DIRECTORY) (* ; "Edited 30-Mar-2026 09:14 by rmk")
|
||||
(* ; "Edited 25-Mar-2026 00:11 by rmk")
|
||||
(* ; "Edited 22-Mar-2026 00:19 by rmk")
|
||||
(* ; "Edited 16-Mar-2026 08:43 by rmk")
|
||||
(* ; "Edited 13-Mar-2026 10:33 by rmk")
|
||||
(CL:UNLESS CHARSET (SETQ CHARSET 0))
|
||||
(if (type? FONTSPEC FONTSPEC)
|
||||
then (SETQ FONTSPEC (\FONT.CHECKARGS FONTSPEC NIL NIL NIL NIL T))
|
||||
else (SETQ FONTSPEC (FONTSPECFROMFILENAME FONTSPEC)))
|
||||
(LET* ((DIR (IMPORTFONTS.DIRECTORY FONTSPEC DIRECTORY (IMPORTFONTS.SUBDIR PHASE)))
|
||||
(FONTFILE (MEDLEYFONT.FILENAME FONTSPEC DIR))
|
||||
TITLETAG CHARSETNAME)
|
||||
(if (NLSETQ (MEDLEYFONT.FILEP FONTFILE))
|
||||
then (SETQ CHARSET (OR (CHARSET.DECODE CHARSET)
|
||||
0))
|
||||
(SETQ TITLETAG (CL:IF (EQ PHASE 'MCCS)
|
||||
'MCCS
|
||||
(L-CASE PHASE T)))
|
||||
(SETQ CHARSETNAME (CHARSET.ENCODE CHARSET))
|
||||
(CL:UNLESS (OCTALNUM? CHARSETNAME)
|
||||
(SETQ TITLETAG (CONCAT CHARSETNAME " " TITLETAG)))
|
||||
(if [CAR (NLSETQ (RESETLST
|
||||
(IMPORTFONTS.CONTEXT PHASE DIR NIL (fetch (FONTSPEC FSDEVICE)
|
||||
of FONTSPEC))
|
||||
(EDITFONT FONTFILE CHARSET NIL NIL TITLETAG))]
|
||||
else (PRINTOUT T "Charset " (OCTALSTRING CHARSET)
|
||||
" of " FONTSPEC " not found in " DIR T)
|
||||
NIL)
|
||||
else (PRINTOUT T FONTSPEC " not found in " DIR T])
|
||||
|
||||
(AEF
|
||||
[LAMBDA (FONTSPEC CHARSET CLOSE) (* ; "Edited 5-Apr-2026 11:50 by rmk")
|
||||
(* ; "Edited 21-Mar-2026 15:09 by rmk")
|
||||
(* ; "Edited 14-Mar-2026 12:59 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 22:56 by rmk")
|
||||
|
||||
(* ;; "Shows CHARSET for all phases of FONTSPEC")
|
||||
|
||||
(CL:WHEN CLOSE (EFCLOSE))
|
||||
(LIST (IEF FONTSPEC CHARSET)
|
||||
(MEF FONTSPEC CHARSET)
|
||||
(CEF FONTSPEC CHARSET)
|
||||
(FEF FONTSPEC CHARSET)
|
||||
(EDITFONT FONTSPEC CHARSET NIL NIL "Deployed"])
|
||||
|
||||
(IEF
|
||||
[LAMBDA (FONTSPEC CHARSET DIRECTORY) (* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:02 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 23:56 by rmk")
|
||||
(* ; "Edited 27-Feb-2026 14:24 by rmk")
|
||||
(PEF 'IMPORT FONTSPEC CHARSET DIRECTORY])
|
||||
|
||||
(MEF
|
||||
[LAMBDA (FONTSPEC CHARSET DIRECTORY) (* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:01 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 1-Mar-2026 23:57 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 20:38 by rmk")
|
||||
(PEF 'MCCS FONTSPEC CHARSET DIRECTORY])
|
||||
|
||||
(CEF
|
||||
[LAMBDA (FONTSPEC CHARSET DIRECTORY) (* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:03 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 2-Mar-2026 00:00 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 22:58 by rmk")
|
||||
(PEF 'COMPLETE FONTSPEC CHARSET DIRECTORY])
|
||||
|
||||
(FEF
|
||||
[LAMBDA (FONTSPEC CHARSET DIRECTORY) (* ; "Edited 23-Mar-2026 13:18 by rmk")
|
||||
(* ; "Edited 19-Mar-2026 00:42 by rmk")
|
||||
(* ; "Edited 12-Mar-2026 11:38 by rmk")
|
||||
(* ; "Edited 10-Mar-2026 01:03 by rmk")
|
||||
(* ; "Edited 4-Mar-2026 00:31 by rmk")
|
||||
(* ; "Edited 2-Mar-2026 00:00 by rmk")
|
||||
(* ; "Edited 9-Oct-2025 22:58 by rmk")
|
||||
(PEF 'FAKE FONTSPEC CHARSET DIRECTORY])
|
||||
|
||||
(EFCLOSE
|
||||
[LAMBDA NIL (* ; "Edited 9-Oct-2025 19:48 by rmk")
|
||||
(for W in (OPENWINDOWS) when (AND (WINDOWPROP W 'FONT)
|
||||
(WINDOWPROP W 'CHARITEMS)) do (CLOSEW W])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWCHARS
|
||||
[LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 20:29 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 10:26 by rmk")
|
||||
(* ; "Edited 24-Jul-2025 11:30 by rmk")
|
||||
(* ; "Edited 8-Jun-2025 20:05 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:18 by mth")
|
||||
(* ; "Edited 1-Aug-2020 09:27 by rmk:")
|
||||
[SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12]
|
||||
(RESETLST
|
||||
[LET ((OLDFONT (DSPFONT NIL T))
|
||||
CHARS)
|
||||
(CL:UNLESS (CHARCODEP FROMCHAR)
|
||||
(SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T)
|
||||
FROMCHAR)))
|
||||
(SETQ CHARS (if (LISTP FROMCHAR)
|
||||
elseif (CHARCODEP FROMCHAR)
|
||||
then (CL:UNLESS (CHARCODEP TOCHAR)
|
||||
(SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR)
|
||||
FROMCHAR)))
|
||||
(for C from FROMCHAR to TOCHAR collect C)
|
||||
else (CHCON FROMCHAR)))
|
||||
[RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE]
|
||||
(TERPRI)
|
||||
(for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C))
|
||||
","
|
||||
(OCTALSTRING (\CHAR8CODE C)))
|
||||
10 .FONT FONT (CHARACTER C))
|
||||
(CL:UNLESS ONELINE (PRINTOUT T T])
|
||||
(TERPRI])
|
||||
|
||||
(CSSOURCE
|
||||
[LAMBDA (PHASE FONT INDIRECT) (* ; "Edited 22-Mar-2026 00:26 by rmk")
|
||||
|
||||
(* ;; "Shows the source properties of all the charsets")
|
||||
|
||||
(CL:UNLESS (FONTP FONT)
|
||||
(SETQ FONT (IPF PHASE FONT)))
|
||||
(LIST* PHASE (FONTPROP FONT 'SPEC)
|
||||
(for CS CSINFO SOURCE (FONTSPEC ← (FONTPROP FONT 'SPEC)) from 0 to (MAXCHARSET FONT)
|
||||
eachtime (SETQ CSINFO (\GETCHARSETINFO FONT CS)) when CSINFO
|
||||
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO)
|
||||
unless [AND INDIRECT (EQUAL FONTSPEC (CHARSETPROP CSINFO 'SOURCE]
|
||||
collect (LIST CS (CHARSETPROP CSINFO 'SOURCE])
|
||||
|
||||
(FONTDEFFONTS
|
||||
[LAMBDA (FACES) (* ; "Edited 22-Mar-2026 12:48 by rmk")
|
||||
(SETQ FACES (for F inside FACES collect (\FONTFACE F)))
|
||||
(for FD FONTLIST in FONTDEFS
|
||||
do (for FP in (CDR (ASSOC 'FONTPROFILE FD))
|
||||
do (for FONT in (CDDR FP) when FONT unless (MEMB (CAR FONT)
|
||||
'(PDF POSTSCRIPT))
|
||||
when (OR (NOT FACES)
|
||||
(MEMBER (\FONTFACE (fetch (FONTSPEC FSFACE) of FONT))
|
||||
FACES)) do (push FONTLIST FONT)))
|
||||
finally (RETURN (SORTFONTSPECS (CL:REMOVE-DUPLICATES FONTLIST :TEST (FUNCTION EQUAL])
|
||||
)
|
||||
|
||||
(FILESLOAD EDITFONT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1215 32446 (IMPORTFONTS 1225 . 12900) (FONT.TO.MCCS 12902 . 15025) (
|
||||
IMPORTFONTS.FONTSPECS 15027 . 22493) (IMPORTFONTS.CONTEXT 22495 . 26086) (IMPORTFONTS.NOCACHE 26088 .
|
||||
26339) (IMPORTFONTS.DIRECTORY 26341 . 28506) (IMPORTFONTS.CLEAR 28508 . 31075) (IMPORTFONTS.SUBDIR
|
||||
31077 . 31825) (IMPORTFONTS.DIRSIZE 31827 . 32444)) (32447 35871 (IMPORTFONTS.AVAILABLE 32457 . 33072)
|
||||
(IMPORTFONTS.EXISTS? 33074 . 33680) (IMPORTFONTS.DEPLOY 33682 . 35869)) (35872 42467 (FAKEFACE 35882
|
||||
. 39619) (FAKEFACE.FROMFILE 39621 . 41777) (FAKEFACE.FROMFONT 41779 . 42465)) (42468 45798 (
|
||||
IMPORTFONTS.PHASES 42478 . 43219) (MISSINGFACE 43221 . 45796)) (45842 47607 (IMPORT.DISPLAY 45852 .
|
||||
46175) (LEGACYDISPLAYFONT 46177 . 47605)) (47656 49870 (IPF 47666 . 48433) (IPFSIZES 48435 . 49868)) (
|
||||
49871 55607 (PEF 49881 . 51945) (AEF 51947 . 52691) (IEF 52693 . 53296) (MEF 53298 . 53899) (CEF 53901
|
||||
. 54506) (FEF 54508 . 55327) (EFCLOSE 55329 . 55605)) (55608 59155 (SHOWCHARS 55618 . 57648) (
|
||||
CSSOURCE 57650 . 58363) (FONTDEFFONTS 58365 . 59153)))))
|
||||
STOP
|
||||
BIN
library/IMPORTFONTS.LCOM
Normal file
BIN
library/IMPORTFONTS.LCOM
Normal file
Binary file not shown.
Reference in New Issue
Block a user