Compare commits
9 Commits
lmm-hcfile
...
mth63--Mis
| Author | SHA1 | Date | |
|---|---|---|---|
|
3f8e935216 | ||
|
|
cfcf91a150 | ||
|
|
7b2b6ef1f5 | ||
|
|
e78620c09b | ||
|
|
5bc81b8159 | ||
|
|
8474e63bc5 | ||
|
|
76be925e0a | ||
|
|
bb53e497ce | ||
|
|
a8a0313bd9 |
@@ -1,15 +1,16 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED " 8-May-2026 10:41:23" {DSK}<Users>larry>il>MEDLEY>INTERNAL>MEDLEY-UTILS.;2 30963
|
||||
(FILECREATED "16-Apr-2026 22:42:51" {DSK}<home>matt>Interlisp>medley>internal>MEDLEY-UTILS.;2 30564
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (ADVICE TEDIT.PROMPTPRINT)
|
||||
(FNS GATHER-INFO MAKE-FULLER-DB MEDLEY-FIX-LINKS MEDLEY-FIX-DATES MAKE-EXPORTS-ALL
|
||||
MAKE-WHEREIS-HASH MAKE-WHEREIS-LOOPS HCFILES MAKE-INDEX-HTMLS RECOMPILE-ONE
|
||||
RECMPL COMPILE-SETUP REMAKEFILES)
|
||||
:CHANGES-TO (FNS HCFILES MAKE-EXPORTS-ALL MAKE-INDEX-HTMLS)
|
||||
(FUNCTIONS REPORT-AND-GO)
|
||||
(VARS MEDLEY-UTILSCOMS HC-SKIP-EXTENSIONS)
|
||||
(ADVICE TEDIT.PROMPTPRINT)
|
||||
|
||||
:PREVIOUS-DATE " 4-May-2026 19:19:00" {DSK}<Users>larry>il>MEDLEY>INTERNAL>MEDLEY-UTILS.;1)
|
||||
:PREVIOUS-DATE "16-Apr-2026 22:27:40" {DSK}<home>matt>Interlisp>medley>internal>MEDLEY-UTILS.;1
|
||||
)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
@@ -214,9 +215,7 @@
|
||||
(DEFINEQ
|
||||
|
||||
(HCFILES
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 8-May-2026 10:39 by lmm")
|
||||
(* ; "Edited 4-May-2026 19:18 by lmm")
|
||||
(* ; "Edited 16-Apr-2026 22:42 by mth")
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 16-Apr-2026 22:42 by mth")
|
||||
(* ; "Edited 30-Jun-2024 08:27 by lmm")
|
||||
(* ; "Edited 23-Apr-2024 23:15 by lmm")
|
||||
(* ; "Edited 22-Apr-2024 13:22 by lmm")
|
||||
@@ -294,14 +293,12 @@
|
||||
(if (EQ REDO 'TEST)
|
||||
then (CL:FORMAT T "Testing open ~a..." SRCPATH)
|
||||
(CLOSEF? (OPENTEXTSTREAM SRCPATH))
|
||||
else
|
||||
(* ;; "ADDED HERE")
|
||||
|
||||
(SETQ NLSETQGAG NIL)
|
||||
(SETQ \TEDIT.THELPFLG T)
|
||||
(REPORT-AND-GO (TEDIT.TO.IMAGEFILE SRCPATH DEST 'PDF)
|
||||
else (REPORT-AND-GO (CL:WITH-OPEN-STREAM (S (OPENTEXTSTREAM
|
||||
SRCPATH))
|
||||
(TEDIT.FORMAT.HARDCOPY S DEST T NIL NIL
|
||||
NIL 'PDF))
|
||||
(CL:FORMAT NIL
|
||||
"~~%%~S TEDIT.TO.IMAGEFILE of ~A -- Condition: ~~A"
|
||||
"~~%%~S TEDIT.FORMAT.HARDCOPY of ~A -- Condition: ~~A"
|
||||
'FAIL SRCPATH)))
|
||||
(PRIN3 " DONE" T)
|
||||
(TERPRI T)
|
||||
@@ -522,14 +519,12 @@
|
||||
(TERPRI])
|
||||
)
|
||||
|
||||
(DEFMACRO REPORT-AND-GO (FORM REPORT-FORMAT) (* ; "Edited 4-May-2026 19:02 by lmm")
|
||||
(* ; "Edited 16-Apr-2026 16:02 by mth")
|
||||
(DEFMACRO REPORT-AND-GO (FORM REPORT-FORMAT) (* ; "Edited 16-Apr-2026 16:02 by mth")
|
||||
`[CL:MULTIPLE-VALUE-BIND (FORM-RESULT ERROR-CONDITION)
|
||||
(IGNORE-ERRORS (CL:VALUES ,FORM)) (* ; "Only the first value")
|
||||
(COND
|
||||
(ERROR-CONDITION (BAKTRACE 'BAKTRACE NIL NIL 1 T)
|
||||
(PRIN3 (CL:FORMAT NIL ,REPORT-FORMAT ERROR-CONDITION)
|
||||
T)
|
||||
(ERROR-CONDITION (PRIN3 (CL:FORMAT NIL ,REPORT-FORMAT ERROR-CONDITION)
|
||||
T)
|
||||
NIL)
|
||||
(T (LIST FORM-RESULT])
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
@@ -541,10 +536,10 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1365 8299 (GATHER-INFO 1375 . 6757) (MAKE-FULLER-DB 6759 . 7668) (MEDLEY-FIX-LINKS 7670
|
||||
. 8063) (MEDLEY-FIX-DATES 8065 . 8297)) (9871 12447 (MAKE-EXPORTS-ALL 9881 . 10728) (
|
||||
MAKE-WHEREIS-HASH 10730 . 11919) (MAKE-WHEREIS-LOOPS 11921 . 12445)) (12448 25236 (HCFILES 12458 .
|
||||
19760) (MAKE-INDEX-HTMLS 19762 . 25234)) (25570 30182 (RECOMPILE-ONE 25580 . 27477) (RECMPL 27479 .
|
||||
28082) (COMPILE-SETUP 28084 . 28708) (REMAKEFILES 28710 . 30180)) (30184 30807 (REPORT-AND-GO 30184 .
|
||||
30807)))))
|
||||
(FILEMAP (NIL (1289 8223 (GATHER-INFO 1299 . 6681) (MAKE-FULLER-DB 6683 . 7592) (MEDLEY-FIX-LINKS 7594
|
||||
. 7987) (MEDLEY-FIX-DATES 7989 . 8221)) (9795 12371 (MAKE-EXPORTS-ALL 9805 . 10652) (
|
||||
MAKE-WHEREIS-HASH 10654 . 11843) (MAKE-WHEREIS-LOOPS 11845 . 12369)) (12372 24990 (HCFILES 12382 .
|
||||
19514) (MAKE-INDEX-HTMLS 19516 . 24988)) (25324 29936 (RECOMPILE-ONE 25334 . 27231) (RECMPL 27233 .
|
||||
27836) (COMPILE-SETUP 27838 . 28462) (REMAKEFILES 28464 . 29934)) (29938 30408 (REPORT-AND-GO 29938 .
|
||||
30408)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,43 +1,18 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10)
|
||||
(FILECREATED "19-May-89 17:52:44" {ERINYES}<LISPUSERS>MEDLEY>DATEFORMAT-EDITOR.;1 13443
|
||||
|
||||
(FILECREATED " 3-May-2026 10:44:14" {MEDLEY}<lispusers>DATEFORMAT-EDITOR.;2 14047
|
||||
changes to%: (VARS DATEFORMAT-EDITORCOMS)
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
previous date%: "16-Sep-88 12:50:52" {PHYLUM}<LISP>MEDLEY>LISPUSERS>DATEFORMAT-EDITOR.;1)
|
||||
|
||||
:CHANGES-TO (VARS DATEFORMAT-EDITORCOMS)
|
||||
|
||||
:PREVIOUS-DATE "19-May-89 17:52:44" {MEDLEY}<lispusers>DATEFORMAT-EDITOR.;1)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1987, 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DATEFORMAT-EDITORCOMS)
|
||||
|
||||
(RPAQQ DATEFORMAT-EDITORCOMS
|
||||
(
|
||||
|
||||
(* ;;; "This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function.")
|
||||
|
||||
|
||||
|
||||
(* ;;; "Interface")
|
||||
|
||||
(FNS EDIT-DATEFORMAT GET-DATEFORMAT-EDITOR)
|
||||
(INITVARS (EDIT-DATEFORMAT-DEFAULT (DATEFORMAT)))
|
||||
|
||||
|
||||
(* ;;; "Support")
|
||||
|
||||
(FILES FREEMENU)
|
||||
(FNS DATEFORMAT-EDITOR-STATUS DATEFORMAT-EDITOR-GET-STATE DATEFORMAT-EDITOR-PUT-STATE
|
||||
DATEFORMAT-EDITOR-SHOW-STATE DATEFORMAT-EDITOR-ABORTFN DATEFORMAT-EDITOR-CLOSEFN
|
||||
DATEFORMAT-EDITOR-GETDFLTFN DATEFORMAT-EDITOR-PUTDFLTFN DATEFORMAT-EDITOR-QUITFN
|
||||
DATEFORMAT-EDITOR-SHOWFN)
|
||||
(VARS $$DATEFORMAT-EDITOR-ITEMS)
|
||||
(INITVARS (DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS)))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS ($$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR))
|
||||
($$DATEFORMAT-EDITOR-IDATE (IDATE
|
||||
" 1-Jan-1988 23:56:41"
|
||||
]
|
||||
(PROP MAKEFILE-ENVIRONMENT DATEFORMAT-EDITOR)))
|
||||
(RPAQQ DATEFORMAT-EDITORCOMS ((* ;;; "This system provides a facility for editing date formats as described in section 12.5 of the Interlisp-D manual, Koto version. User entry point is the function EDIT-DATEFORMAT. Editing is accomplished using a FREEMENU. Items displayed in this menu are stored on DATEFORMAT-EDITOR-ITEMS. Call (GET-DATEFORMAT-EDITOR T) after changing this variable. Input to EDIT-DATEFORMAT is either NIL or a value returned by the DATEFORMAT function. Output is either NIL -- in case editing was aborted -- or another value as returned from the DATEFORMAT function.") (* ;;; "Interface") (FNS EDIT-DATEFORMAT GET-DATEFORMAT-EDITOR) (INITVARS (EDIT-DATEFORMAT-DEFAULT (DATEFORMAT))) (* ;;; "Support") (FILES (SYSLOAD) FREEMENU) (FNS DATEFORMAT-EDITOR-STATUS DATEFORMAT-EDITOR-GET-STATE DATEFORMAT-EDITOR-PUT-STATE DATEFORMAT-EDITOR-SHOW-STATE DATEFORMAT-EDITOR-ABORTFN DATEFORMAT-EDITOR-CLOSEFN DATEFORMAT-EDITOR-GETDFLTFN DATEFORMAT-EDITOR-PUTDFLTFN DATEFORMAT-EDITOR-QUITFN DATEFORMAT-EDITOR-SHOWFN) (VARS $$DATEFORMAT-EDITOR-ITEMS) (INITVARS (DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS ($$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR)) ($$DATEFORMAT-EDITOR-IDATE (IDATE " 1-Jan-88 23:56:41"))) (P (COND ((NOT (GETD (QUOTE \OUTDATE-STRING))) (* ; "Get DATE extensions") (FILESLOAD (SYSLOAD) DATEPATCH))))) (PROP MAKEFILE-ENVIRONMENT DATEFORMAT-EDITOR)))
|
||||
|
||||
|
||||
|
||||
@@ -61,14 +36,14 @@
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQ? EDIT-DATEFORMAT-DEFAULT (DATEFORMAT))
|
||||
(RPAQ? EDIT-DATEFORMAT-DEFAULT (DATEFORMAT))
|
||||
|
||||
|
||||
|
||||
(* ;;; "Support")
|
||||
|
||||
|
||||
(FILESLOAD FREEMENU)
|
||||
(FILESLOAD (SYSLOAD) FREEMENU)
|
||||
(DEFINEQ
|
||||
|
||||
(DATEFORMAT-EDITOR-STATUS
|
||||
@@ -112,76 +87,26 @@
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQQ $$DATEFORMAT-EDITOR-ITEMS
|
||||
(((TYPE MOMENTARY LABEL "Quit" FONT (GACHA 10 BOLD)
|
||||
SELECTEDFN DATEFORMAT-EDITOR-QUITFN MESSAGE "Stop editing, return current settings")
|
||||
(TYPE DISPLAY LABEL "")
|
||||
(TYPE MOMENTARY LABEL "Abort" FONT (GACHA 10 BOLD)
|
||||
SELECTEDFN DATEFORMAT-EDITOR-ABORTFN MESSAGE
|
||||
"Stop editing, ignore changes, return NIL")
|
||||
(TYPE DISPLAY LABEL " Default:")
|
||||
(TYPE MOMENTARY LABEL "Get" FONT (GACHA 10 BOLD)
|
||||
SELECTEDFN DATEFORMAT-EDITOR-GETDFLTFN MESSAGE "Use default settings")
|
||||
(TYPE MOMENTARY LABEL "Put" FONT (GACHA 10 BOLD)
|
||||
SELECTEDFN DATEFORMAT-EDITOR-PUTDFLTFN MESSAGE "Save settings as default")
|
||||
(TYPE DISPLAY LABEL ""))
|
||||
((TYPE DISPLAY LABEL ""))
|
||||
((TYPE DISPLAY LABEL "DATE: " FONT (GACHA 10 BOLD)))
|
||||
((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION DATE ID DATE-NORMAL LABEL "dd-mon-yyyy" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION DATE ID DATE-SLASHES LABEL "dd/mon/yyyy" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION DATE ID DATE-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " ")
|
||||
(TYPE NWAY COLLECTION DATE ID DATE-SPACES LABEL "dd mon yyyy" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION DATE ID DATE-LEADING LABEL "mon dd, yyyy??" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " Year: " FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION YEAR ID YEAR-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION YEAR ID YEAR-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " Month: " FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION MONTH ID MONTH-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION MONTH ID MONTH-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN
|
||||
)
|
||||
(TYPE NWAY COLLECTION MONTH ID MONTH-NUMERIC LABEL "numeric" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " Weekday:" FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION DAY ID DAY-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION DAY ID DAY-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION DAY ID DAY-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " Spaces: " FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION LEADER ID LEADER-YES LABEL "yes" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION LEADER ID LEADER-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL ""))
|
||||
((TYPE DISPLAY LABEL "TIME:" FONT (GACHA 10 BOLD)))
|
||||
((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION TIME ID TIME-SECS LABEL "hh:mm:ss" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN
|
||||
)
|
||||
(TYPE NWAY COLLECTION TIME ID TIME-MINS LABEL "hh:mm" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION TIME ID TIME-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))
|
||||
((TYPE DISPLAY LABEL " Time Zone:" FONT (GACHA 10 BOLD))
|
||||
(TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-YES LABEL "yes" SELECTEDFN
|
||||
DATEFORMAT-EDITOR-SHOWFN)
|
||||
(TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN
|
||||
))))
|
||||
(RPAQQ $$DATEFORMAT-EDITOR-ITEMS (((TYPE MOMENTARY LABEL "Quit" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-QUITFN MESSAGE "Stop editing, return current settings") (TYPE DISPLAY LABEL "") (TYPE MOMENTARY LABEL "Abort" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-ABORTFN MESSAGE "Stop editing, ignore changes, return NIL") (TYPE DISPLAY LABEL " Default:") (TYPE MOMENTARY LABEL "Get" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-GETDFLTFN MESSAGE "Use default settings") (TYPE MOMENTARY LABEL "Put" FONT (GACHA 10 BOLD) SELECTEDFN DATEFORMAT-EDITOR-PUTDFLTFN MESSAGE "Save settings as default") (TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "DATE: " FONT (GACHA 10 BOLD))) ((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION DATE ID DATE-NORMAL LABEL "dd-mon-yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-SLASHES LABEL "dd/mon/yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " ") (TYPE NWAY COLLECTION DATE ID DATE-SPACES LABEL "dd mon yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DATE ID DATE-LEADING LABEL "mon dd, yy" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Year: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION YEAR ID YEAR-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION YEAR ID YEAR-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Month: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION MONTH ID MONTH-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION MONTH ID MONTH-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION MONTH ID MONTH-NUMERIC LABEL "numeric" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Weekday:" FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION DAY ID DAY-LONG LABEL "long" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DAY ID DAY-SHORT LABEL "short" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION DAY ID DAY-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Spaces: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION LEADER ID LEADER-YES LABEL "yes" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION LEADER ID LEADER-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL "")) ((TYPE DISPLAY LABEL "TIME:" FONT (GACHA 10 BOLD))) ((TYPE DISPLAY LABEL " Format: " FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION TIME ID TIME-SECS LABEL "hh:mm:ss" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIME ID TIME-MINS LABEL "hh:mm" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIME ID TIME-NONE LABEL "none" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN)) ((TYPE DISPLAY LABEL " Time Zone:" FONT (GACHA 10 BOLD)) (TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-YES LABEL "yes" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN) (TYPE NWAY COLLECTION TIMEZONE ID TIMEZONE-NO LABEL "no" SELECTEDFN DATEFORMAT-EDITOR-SHOWFN))))
|
||||
|
||||
(RPAQ? DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS))
|
||||
(RPAQ? DATEFORMAT-EDITOR-ITEMS (COPY $$DATEFORMAT-EDITOR-ITEMS))
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(RPAQ $$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR))
|
||||
(RPAQ $$DATEFORMAT-EDITOR (GET-DATEFORMAT-EDITOR))
|
||||
|
||||
(RPAQ $$DATEFORMAT-EDITOR-IDATE (IDATE " 1-Jan-1988 23:56:41"))
|
||||
(RPAQ $$DATEFORMAT-EDITOR-IDATE (IDATE " 1-Jan-88 23:56:41"))
|
||||
|
||||
|
||||
(COND ((NOT (GETD (QUOTE \OUTDATE-STRING))) (* ; "Get DATE extensions") (FILESLOAD (SYSLOAD) DATEPATCH)))
|
||||
)
|
||||
|
||||
(PUTPROPS DATEFORMAT-EDITOR MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE
|
||||
10))
|
||||
(PUTPROPS DATEFORMAT-EDITOR MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10))
|
||||
(PUTPROPS DATEFORMAT-EDITOR COPYRIGHT ("Johannes A. G. M. Koomen" 1987 1988 1989))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2634 4559 (EDIT-DATEFORMAT 2644 . 3671) (GET-DATEFORMAT-EDITOR 3673 . 4557)) (4658 9948
|
||||
(DATEFORMAT-EDITOR-STATUS 4668 . 4888) (DATEFORMAT-EDITOR-GET-STATE 4890 . 6696) (
|
||||
DATEFORMAT-EDITOR-PUT-STATE 6698 . 8508) (DATEFORMAT-EDITOR-SHOW-STATE 8510 . 8761) (
|
||||
DATEFORMAT-EDITOR-ABORTFN 8763 . 8903) (DATEFORMAT-EDITOR-CLOSEFN 8905 . 9094) (
|
||||
DATEFORMAT-EDITOR-GETDFLTFN 9096 . 9363) (DATEFORMAT-EDITOR-PUTDFLTFN 9365 . 9601) (
|
||||
DATEFORMAT-EDITOR-QUITFN 9603 . 9741) (DATEFORMAT-EDITOR-SHOWFN 9743 . 9946)))))
|
||||
(FILEMAP (NIL (2483 4408 (EDIT-DATEFORMAT 2493 . 3520) (GET-DATEFORMAT-EDITOR 3522 . 4406)) (4513 9803
|
||||
(DATEFORMAT-EDITOR-STATUS 4523 . 4743) (DATEFORMAT-EDITOR-GET-STATE 4745 . 6551) (
|
||||
DATEFORMAT-EDITOR-PUT-STATE 6553 . 8363) (DATEFORMAT-EDITOR-SHOW-STATE 8365 . 8616) (
|
||||
DATEFORMAT-EDITOR-ABORTFN 8618 . 8758) (DATEFORMAT-EDITOR-CLOSEFN 8760 . 8949) (
|
||||
DATEFORMAT-EDITOR-GETDFLTFN 8951 . 9218) (DATEFORMAT-EDITOR-PUTDFLTFN 9220 . 9456) (
|
||||
DATEFORMAT-EDITOR-QUITFN 9458 . 9596) (DATEFORMAT-EDITOR-SHOWFN 9598 . 9801)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,31 +1,12 @@
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 3-May-2026 10:44:14" {MEDLEY}<lispusers>DOC-OBJECTS.;2 53774
|
||||
(FILECREATED " 9-Dec-2024 21:07:13" {WMEDLEY}<lispusers>DOC-OBJECTS.;58 52672
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS DOC-OBJECTSCOMS)
|
||||
(FNS DOCOBJ-ACQUIRE-OBJECT DOCOBJ-INIT DOCOBJ-TEDIT-MENU-ENTRY DOCOBJ-GET-LOOKS
|
||||
DOCOBJ-REGISTER-OBJECT DOCOBJ-STRING-IMAGEBOX DOCOBJ-WAIT-MOUSE
|
||||
DOCOBJ-BEFOREHARDCOPYFN DOCOBJ-AFTERHARDCOPYFN DOCOBJ-ACQUIRE-EVALED-OBJECT
|
||||
DOCOBJ-ACQUIRE-SNAPPED-OBJECT DOCOBJ-EDIT-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP
|
||||
DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS DOCOBJ-TIMESTAMP-BUTTONEVENTINFN
|
||||
DOCOBJ-TIMESTAMP-COPYFN DOCOBJ-TIMESTAMP-DISPLAYFN DOCOBJ-TIMESTAMP-GETFN
|
||||
DOCOBJ-TIMESTAMP-IMAGEBOXFN DOCOBJ-TIMESTAMP-PREPRINTFN DOCOBJ-TIMESTAMP-PUTFN
|
||||
DOCOBJ-TIMESTAMP-TO-STRING DOCOBJ-MAKE-FILESTAMP
|
||||
DOCOBJ-MAKE-FILESTAMP-IMAGEFNS DOCOBJ-FILESTAMP-COPYFN
|
||||
DOCOBJ-FILESTAMP-DISPLAYFN DOCOBJ-FILESTAMP-GETFN DOCOBJ-FILESTAMP-IMAGEBOXFN
|
||||
DOCOBJ-FILESTAMP-GET-FULLNAME DOCOBJ-FILESTAMP-NEW-FULLNAME
|
||||
DOCOBJ-FILESTAMP-PREPRINTFN DOCOBJ-FILESTAMP-PUTFN DOCOBJ-MAKE-HRULE
|
||||
DOCOBJ-EDIT-HRULE DOCOBJ-HRULE-INIT DOCOBJ-HRULE-GET-WIDTH
|
||||
DOCOBJ-HRULE-BUTTONEVENTINFN DOCOBJ-MAKE-INCLUDE DOCOBJ-MAKE-INCLUDE-IMAGEFNS
|
||||
DOCOBJ-INCLUDE-CREATE-OBJ DOCOBJ-INCLUDE-EDIT DOCOBJ-INCLUDE-EDIT-WINDOWP
|
||||
DOCOBJ-INCLUDE-RESET-OBJ DOCOBJ-INCLUDE-BEFOREHARDCOPYFN
|
||||
DOCOBJ-INCLUDE-CLEANUPFN DOCOBJ-INCLUDE-BUTTONEVENTINFN DOCOBJ-INCLUDE-COPYFN
|
||||
DOCOBJ-INCLUDE-DISPLAYFN DOCOBJ-INCLUDE-GETFN DOCOBJ-INCLUDE-IMAGEBOXFN
|
||||
DOCOBJ-INCLUDE-PREPRINTFN DOCOBJ-INCLUDE-PUTFN)
|
||||
:CHANGES-TO (FNS DOCOBJ-STRING-IMAGEBOX)
|
||||
|
||||
:PREVIOUS-DATE " 9-Dec-2024 21:07:13" {MEDLEY}<lispusers>DOC-OBJECTS.;1)
|
||||
:PREVIOUS-DATE " 8-Dec-2024 15:49:01" {WMEDLEY}<lispusers>DOC-OBJECTS.;57)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT DOC-OBJECTSCOMS)
|
||||
@@ -35,7 +16,8 @@
|
||||
|
||||
(* ;;; "This TEdit subsystem implements an extensible facility originally intended to provide bibliography and citation capabilities. The TEdit function GET.OBJ.FROM.USER, the one triggered by typing ^O, calls the function PROMPTFOREVALED which is redefined by this subsystem to be equivalent to the function DocObj-Acquire-Object. This function inserts IMAGEOBJects into the current TEdit, and is driven by the variables DocObjectsMenu and DocObjectsMenuCommands (analogous to BackgroundMenu and BackgroundMenuCommands). Each menu entry contains a form that, when EVAL'd, creates and returns a particular kind of IMAGEOBJ. Note that this form is EVAL'd under the function DocObj-Acquire-Object, which runs under the function GET.OBJ.FROM.USER, which gets TEXTSTREAM and TEXTOBJ as arguments. They can be (and are) used freely to record state or other desired info. The image objects supplied by this subsystem are 'Eval`d Form' (i.e., the original behavior of ^O), 'Screen Snap' (equivalent to right-buttoning in the background while holding the SHIFT key down), etc.")
|
||||
|
||||
(FILES TEDIT IMAGEOBJ)
|
||||
(FILES (SYSLOAD)
|
||||
TEDIT IMAGEOBJ)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL))
|
||||
(VARS (DocObjectsMenu NIL)
|
||||
(DocObjectsConfirmEditMenu NIL))
|
||||
@@ -63,7 +45,8 @@
|
||||
(* ;; "Time Stamp")
|
||||
|
||||
(DECLARE%: DONTCOPY (RECORDS DOCOBJ-TIMESTAMP))
|
||||
(FILES DATEFORMAT-EDITOR)
|
||||
(FILES (SYSLOAD)
|
||||
DATEFORMAT-EDITOR)
|
||||
(FNS DOCOBJ-EDIT-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS
|
||||
DOCOBJ-TIMESTAMP-BUTTONEVENTINFN DOCOBJ-TIMESTAMP-COPYFN
|
||||
DOCOBJ-TIMESTAMP-DISPLAYFN DOCOBJ-TIMESTAMP-GETFN DOCOBJ-TIMESTAMP-IMAGEBOXFN
|
||||
@@ -87,7 +70,8 @@
|
||||
(COMS
|
||||
(* ;; "Horizontal Rule")
|
||||
|
||||
(FILES HRULE READNUMBER)
|
||||
(FILES (SYSLOAD)
|
||||
HRULE READNUMBER)
|
||||
(FNS DOCOBJ-MAKE-HRULE DOCOBJ-EDIT-HRULE DOCOBJ-HRULE-INIT DOCOBJ-HRULE-GET-WIDTH
|
||||
DOCOBJ-HRULE-BUTTONEVENTINFN)
|
||||
(VARS (DOCOBJ-HRULE-RULE-PAD)
|
||||
@@ -123,7 +107,8 @@
|
||||
)
|
||||
|
||||
|
||||
(FILESLOAD TEDIT IMAGEOBJ)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
TEDIT IMAGEOBJ)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD TEDIT-EXPORTS.ALL)
|
||||
@@ -161,17 +146,21 @@
|
||||
(MENU DocObjectsMenu])
|
||||
|
||||
(DOCOBJ-INIT
|
||||
[LAMBDA NIL (* ; "Edited 8-Oct-87 21:32 by Koomen")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 8-Oct-87 21:32 by Koomen")
|
||||
|
||||
(* ;;; "This function changes the behavior of standard TEdit such that ^O will invoke the DocObjects system; an entry to invoke the DocObjects system is also added to TEdit's middle button menu.")
|
||||
|
||||
(DECLARE (GLOBALVARS TEDIT.DEFAULT.MENU))
|
||||
(CHANGENAME 'GET.OBJ.FROM.USER 'PROMPTFOREVALED 'DOCOBJ-ACQUIRE-OBJECT)
|
||||
(TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU '(Object (FUNCTION DOCOBJ-TEDIT-MENU-ENTRY)
|
||||
"Insert a Document Object"])
|
||||
(CHANGENAME 'GET.OBJ.FROM.USER 'PROMPTFOREVALED '
|
||||
DOCOBJ-ACQUIRE-OBJECT)
|
||||
(TEDIT.ADD.MENUITEM TEDIT.DEFAULT.MENU
|
||||
'(Object (FUNCTION DOCOBJ-TEDIT-MENU-ENTRY)
|
||||
"Insert a Document Object"])
|
||||
|
||||
(DOCOBJ-TEDIT-MENU-ENTRY
|
||||
[LAMBDA (TEXTSTREAM) (* ; "Edited 8-Oct-87 21:31 by Koomen")
|
||||
[LAMBDA (TEXTSTREAM) (* ;
|
||||
"Edited 8-Oct-87 21:31 by Koomen")
|
||||
|
||||
(* ;;; "This is the entry point into the DocObjects system from TEdit's middle button menu. GET.OBJ.FROM.USER used to call PROMPTFOREVALED but DocObjects changes this into a call to DOCOBJ-ACQUIRE-OBJECT.")
|
||||
|
||||
@@ -212,8 +201,8 @@
|
||||
|
||||
(DOCOBJ-REGISTER-OBJECT
|
||||
[LAMBDA (OBJECT) (* ; "Edited 23-Oct-87 14:48 by Koomen")
|
||||
|
||||
(* ;; "The following ensures that all DocObjects get a chance to do whatever they want to before and after hardcopying. Each DocObject can associate a BEFOREHARDCOPYFN and/or an AFTERHARDCOPYFN with the ImageObj representing the DocObject")
|
||||
|
||||
(* ;; "The following ensures that all DocObjects get a chance to do whatever they want to before and after hardcopying. Each DocObject can associate a BEFOREHARDCOPYFN and/or an AFTERHARDCOPYFN with the ImageObj representing the DocObject")
|
||||
|
||||
(DECLARE (SPECVARS TEXTOBJ))
|
||||
(if OBJECT
|
||||
@@ -241,8 +230,11 @@
|
||||
XKERN _ 0])
|
||||
|
||||
(DOCOBJ-WAIT-MOUSE
|
||||
[LAMBDA (STREAM) (* ; "Edited 8-Oct-87 23:46 by Koomen")
|
||||
(while (NOT (MOUSESTATE UP)) bind (REGION _ (DSPCLIPPINGREGION NIL STREAM))
|
||||
[LAMBDA (STREAM) (* ;
|
||||
"Edited 8-Oct-87 23:46 by Koomen")
|
||||
|
||||
(while (NOT (MOUSESTATE UP)) bind (REGION _ (DSPCLIPPINGREGION
|
||||
NIL STREAM))
|
||||
do (if (NOT (INSIDEP REGION (LASTMOUSEX STREAM)
|
||||
(LASTMOUSEY STREAM)))
|
||||
then (RETURN NIL)) finally (RETURN T])
|
||||
@@ -354,9 +346,10 @@
|
||||
(DEFINEQ
|
||||
|
||||
(DOCOBJ-ACQUIRE-EVALED-OBJECT
|
||||
[LAMBDA NIL (* Koomen "30-Sep-86 02:08")
|
||||
|
||||
(* * This is the original function called under GET.OBJ.FROM.USER * *)
|
||||
[LAMBDA NIL (* Koomen "30-Sep-86 02:08")
|
||||
|
||||
(* * This is the original function called under
|
||||
GET.OBJ.FROM.USER * *)
|
||||
|
||||
(PROMPTFOREVALED "Form to eval: "])
|
||||
)
|
||||
@@ -371,7 +364,7 @@
|
||||
(DEFINEQ
|
||||
|
||||
(DOCOBJ-ACQUIRE-SNAPPED-OBJECT
|
||||
[LAMBDA NIL (* Koomen "26-Sep-86 16:55")
|
||||
[LAMBDA NIL (* Koomen "26-Sep-86 16:55")
|
||||
(GETREGION])
|
||||
)
|
||||
|
||||
@@ -389,27 +382,34 @@
|
||||
)
|
||||
)
|
||||
|
||||
(FILESLOAD DATEFORMAT-EDITOR)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
DATEFORMAT-EDITOR)
|
||||
(DEFINEQ
|
||||
|
||||
(DOCOBJ-EDIT-TIMESTAMP
|
||||
[LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:08")
|
||||
(PROG [(FORMAT (EDIT-DATEFORMAT (fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP]
|
||||
[LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:08")
|
||||
(PROG [(FORMAT (EDIT-DATEFORMAT (fetch (DOCOBJ-TIMESTAMP FORMAT)
|
||||
of TIMESTAMP]
|
||||
(if FORMAT
|
||||
then (replace (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP with FORMAT)
|
||||
(replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL)
|
||||
then (replace (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP
|
||||
with FORMAT)
|
||||
(replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP
|
||||
with NIL)
|
||||
(RETURN TIMESTAMP])
|
||||
|
||||
(DOCOBJ-MAKE-TIMESTAMP
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 13:54")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS DocObjectsTimeStampFormat))
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 13:54")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS
|
||||
DocObjectsTimeStampFormat))
|
||||
(IMAGEOBJCREATE (create DOCOBJ-TIMESTAMP
|
||||
IDATE _ (IDATE)
|
||||
FORMAT _ DocObjectsTimeStampFormat)
|
||||
IDATE _ (IDATE)
|
||||
FORMAT _ DocObjectsTimeStampFormat)
|
||||
DOCOBJ-TIMESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS
|
||||
[LAMBDA NIL (* ; "Edited 8-Oct-87 22:53 by Koomen")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 8-Oct-87 22:53 by Koomen")
|
||||
|
||||
(LET ((DISPLAYFN (FUNCTION DOCOBJ-TIMESTAMP-DISPLAYFN))
|
||||
(IMAGEBOXFN (FUNCTION DOCOBJ-TIMESTAMP-IMAGEBOXFN))
|
||||
(PUTFN (FUNCTION DOCOBJ-TIMESTAMP-PUTFN))
|
||||
@@ -423,58 +423,68 @@
|
||||
(WHENCOPIEDFN (FUNCTION NILL))
|
||||
(WHENOPERATEDONFN (FUNCTION NILL))
|
||||
(PREPRINTFN (FUNCTION DOCOBJ-TIMESTAMP-PREPRINTFN)))
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN
|
||||
WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN])
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN
|
||||
BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN
|
||||
WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN
|
||||
WHENOPERATEDONFN PREPRINTFN])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-BUTTONEVENTINFN
|
||||
[LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON)
|
||||
(* ; "Edited 8-Oct-87 23:43 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM
|
||||
BUTTON) (* ;
|
||||
"Edited 8-Oct-87 23:43 by Koomen")
|
||||
|
||||
(if (AND (EQ BUTTON 'MIDDLE)
|
||||
(DOCOBJ-WAIT-MOUSE WINDOWSTREAM))
|
||||
then (ALLOW.BUTTON.EVENTS)
|
||||
(if (DOCOBJ-EDIT-TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
|
||||
(if (DOCOBJ-EDIT-TIMESTAMP (IMAGEOBJPROP IMAGEOBJ
|
||||
'OBJECTDATUM))
|
||||
then 'CHANGED])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-COPYFN
|
||||
[LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 00:30")
|
||||
[LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM)
|
||||
(* Koomen "31-Jan-87 00:30")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS))
|
||||
(IMAGEOBJCREATE (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
|
||||
DOCOBJ-TIMESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-DISPLAYFN
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* Koomen " 4-Feb-87 14:11")
|
||||
(PRINTOUT IMAGESTREAM (DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM])
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM)
|
||||
(* Koomen " 4-Feb-87 14:11")
|
||||
(PRINTOUT IMAGESTREAM (DOCOBJ-TIMESTAMP-TO-STRING
|
||||
(IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-GETFN
|
||||
[LAMBDA (FILESTREAM) (* Koomen "31-Jan-87 00:19")
|
||||
[LAMBDA (FILESTREAM) (* Koomen "31-Jan-87 00:19")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-TIMESTAMP-IMAGEFNS))
|
||||
(IMAGEOBJCREATE (READ FILESTREAM)
|
||||
DOCOBJ-TIMESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-IMAGEBOXFN
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* Koomen " 9-Feb-87 17:13")
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN)
|
||||
(* Koomen " 9-Feb-87 17:13")
|
||||
(LET* ((TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
|
||||
(TIMESTRING (DOCOBJ-TIMESTAMP-TO-STRING TIMESTAMP)))
|
||||
(DOCOBJ-STRING-IMAGEBOX TIMESTRING IMAGESTREAM])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-PREPRINTFN
|
||||
[LAMBDA (IMAGEOBJ) (* ; "Edited 8-Oct-87 22:29 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ) (* ;
|
||||
"Edited 8-Oct-87 22:29 by Koomen")
|
||||
|
||||
(DOCOBJ-TIMESTAMP-TO-STRING (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-PUTFN
|
||||
[LAMBDA (IMAGEOBJ FILESTREAM) (* Koomen " 4-Feb-87 14:08")
|
||||
[LAMBDA (IMAGEOBJ FILESTREAM) (* Koomen " 4-Feb-87 14:08")
|
||||
(PROG [(TIMESTAMP (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
|
||||
(replace (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP with (IDATE))
|
||||
(replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with NIL)
|
||||
(PRINT TIMESTAMP FILESTREAM])
|
||||
|
||||
(DOCOBJ-TIMESTAMP-TO-STRING
|
||||
[LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:12")
|
||||
[LAMBDA (TIMESTAMP) (* Koomen " 4-Feb-87 14:12")
|
||||
(OR (STRINGP (fetch (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP))
|
||||
(replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP with (GDATE (fetch (DOCOBJ-TIMESTAMP IDATE)
|
||||
of TIMESTAMP)
|
||||
(fetch (DOCOBJ-TIMESTAMP FORMAT)
|
||||
of TIMESTAMP])
|
||||
(replace (DOCOBJ-TIMESTAMP DATESTR) of TIMESTAMP
|
||||
with (GDATE (fetch (DOCOBJ-TIMESTAMP IDATE) of TIMESTAMP)
|
||||
(fetch (DOCOBJ-TIMESTAMP FORMAT) of TIMESTAMP])
|
||||
)
|
||||
|
||||
(RPAQ? DocObjectsTimeStampFormat )
|
||||
@@ -491,14 +501,18 @@
|
||||
(DEFINEQ
|
||||
|
||||
(DOCOBJ-MAKE-FILESTAMP
|
||||
[LAMBDA NIL (* ; "Edited 8-Oct-87 22:55 by Koomen")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 8-Oct-87 22:55 by Koomen")
|
||||
|
||||
(DECLARE (SPECVARS TEXTOBJ)
|
||||
(GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS))
|
||||
(IMAGEOBJCREATE (DOCOBJ-FILESTAMP-NEW-FULLNAME TEXTOBJ)
|
||||
DOCOBJ-FILESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-MAKE-FILESTAMP-IMAGEFNS
|
||||
[LAMBDA NIL (* ; "Edited 8-Oct-87 22:54 by Koomen")
|
||||
[LAMBDA NIL (* ;
|
||||
"Edited 8-Oct-87 22:54 by Koomen")
|
||||
|
||||
(LET ((DISPLAYFN (FUNCTION DOCOBJ-FILESTAMP-DISPLAYFN))
|
||||
(IMAGEBOXFN (FUNCTION DOCOBJ-FILESTAMP-IMAGEBOXFN))
|
||||
(PUTFN (FUNCTION DOCOBJ-FILESTAMP-PUTFN))
|
||||
@@ -512,33 +526,46 @@
|
||||
(WHENCOPIEDFN (FUNCTION NILL))
|
||||
(WHENOPERATEDONFN (FUNCTION NILL))
|
||||
(PREPRINTFN (FUNCTION DOCOBJ-FILESTAMP-PREPRINTFN)))
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN
|
||||
WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN])
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN
|
||||
BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN
|
||||
WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN
|
||||
WHENOPERATEDONFN PREPRINTFN])
|
||||
|
||||
(DOCOBJ-FILESTAMP-COPYFN
|
||||
[LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* Koomen "31-Jan-87 04:10")
|
||||
[LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM)
|
||||
(* Koomen "31-Jan-87 04:10")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS))
|
||||
(IMAGEOBJCREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)
|
||||
DOCOBJ-FILESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-FILESTAMP-DISPLAYFN
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM) (* ; "Edited 8-Oct-87 22:56 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM IMAGESTREAMTYPE HOSTSTREAM)
|
||||
(* ;
|
||||
"Edited 8-Oct-87 22:56 by Koomen")
|
||||
|
||||
(PRINTOUT IMAGESTREAM (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ])
|
||||
|
||||
(DOCOBJ-FILESTAMP-GETFN
|
||||
[LAMBDA (FILESTREAM) (* ; "Edited 8-Oct-87 22:58 by Koomen")
|
||||
[LAMBDA (FILESTREAM) (* ;
|
||||
"Edited 8-Oct-87 22:58 by Koomen")
|
||||
|
||||
(DECLARE (GLOBALVARS DOCOBJ-FILESTAMP-IMAGEFNS))
|
||||
(LET ((FULLNAME (READ FILESTREAM)))
|
||||
(IMAGEOBJCREATE (AND FULLNAME (MKSTRING FULLNAME))
|
||||
DOCOBJ-FILESTAMP-IMAGEFNS])
|
||||
|
||||
(DOCOBJ-FILESTAMP-IMAGEBOXFN
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 8-Oct-87 22:59 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN)
|
||||
(* ;
|
||||
"Edited 8-Oct-87 22:59 by Koomen")
|
||||
|
||||
(LET ((FULLNAME (DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ)))
|
||||
(DOCOBJ-STRING-IMAGEBOX FULLNAME IMAGESTREAM])
|
||||
|
||||
(DOCOBJ-FILESTAMP-GET-FULLNAME
|
||||
[LAMBDA (IMAGEOBJ NODEFAULTFLG) (* ; "Edited 8-Oct-87 22:59 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ NODEFAULTFLG) (* ;
|
||||
"Edited 8-Oct-87 22:59 by Koomen")
|
||||
|
||||
(PROG [(FULLNAME (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
|
||||
(RETURN (OR (if FULLNAME
|
||||
then (if (LITATOM FULLNAME)
|
||||
@@ -549,7 +576,9 @@
|
||||
then "-- not yet filed --"])
|
||||
|
||||
(DOCOBJ-FILESTAMP-NEW-FULLNAME
|
||||
[LAMBDA (TEXTOBJ) (* ; "Edited 8-Oct-87 22:52 by Koomen")
|
||||
[LAMBDA (TEXTOBJ) (* ;
|
||||
"Edited 8-Oct-87 22:52 by Koomen")
|
||||
|
||||
(PROG ((FULLNAME (FULLNAME TEXTOBJ)))
|
||||
(RETURN (if FULLNAME
|
||||
then (if (LITATOM FULLNAME)
|
||||
@@ -558,11 +587,15 @@
|
||||
then (COPYALL FULLNAME])
|
||||
|
||||
(DOCOBJ-FILESTAMP-PREPRINTFN
|
||||
[LAMBDA (IMAGEOBJ) (* ; "Edited 8-Oct-87 22:56 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ) (* ;
|
||||
"Edited 8-Oct-87 22:56 by Koomen")
|
||||
|
||||
(DOCOBJ-FILESTAMP-GET-FULLNAME IMAGEOBJ T])
|
||||
|
||||
(DOCOBJ-FILESTAMP-PUTFN
|
||||
[LAMBDA (IMAGEOBJ FILESTREAM) (* ; "Edited 8-Oct-87 22:39 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ FILESTREAM) (* ;
|
||||
"Edited 8-Oct-87 22:39 by Koomen")
|
||||
|
||||
(PROG [(FULLNAME (MKSTRING (FULLNAME FILESTREAM]
|
||||
(IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM FULLNAME)
|
||||
(PRINT FULLNAME FILESTREAM])
|
||||
@@ -578,19 +611,22 @@
|
||||
(* ;; "Horizontal Rule")
|
||||
|
||||
|
||||
(FILESLOAD HRULE READNUMBER)
|
||||
(FILESLOAD (SYSLOAD)
|
||||
HRULE READNUMBER)
|
||||
(DEFINEQ
|
||||
|
||||
(DOCOBJ-MAKE-HRULE
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 16:12")
|
||||
(HRULE.CREATE (bind WIDTH for I from 1 while (AND (SETQ WIDTH (DOCOBJ-HRULE-GET-WIDTH
|
||||
(ODDP I)
|
||||
(EQ I 1)))
|
||||
(GREATERP WIDTH 0)) collect WIDTH])
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 16:12")
|
||||
(HRULE.CREATE (bind WIDTH for I from 1
|
||||
while (AND (SETQ WIDTH (DOCOBJ-HRULE-GET-WIDTH
|
||||
(ODDP I)
|
||||
(EQ I 1)))
|
||||
(GREATERP WIDTH 0)) collect WIDTH])
|
||||
|
||||
(DOCOBJ-EDIT-HRULE
|
||||
[LAMBDA (IMAGEOBJ) (* Koomen " 4-Feb-87 15:45")
|
||||
(PROG [NEWWIDTH (OLDWIDTH (MKLIST (IMAGEOBJPROP IMAGEOBJ 'RULE.WIDTH]
|
||||
[LAMBDA (IMAGEOBJ) (* Koomen " 4-Feb-87 15:45")
|
||||
(PROG [NEWWIDTH (OLDWIDTH (MKLIST (IMAGEOBJPROP IMAGEOBJ
|
||||
'RULE.WIDTH]
|
||||
(SETQ NEWWIDTH (COPYALL OLDWIDTH))
|
||||
(if (AND (NLSETQ (EDITE NEWWIDTH))
|
||||
(NOT (EQUAL NEWWIDTH OLDWIDTH)))
|
||||
@@ -598,18 +634,18 @@
|
||||
(RETURN IMAGEOBJ])
|
||||
|
||||
(DOCOBJ-HRULE-INIT
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 16:13")
|
||||
|
||||
(* * provide HRULE editing * *)
|
||||
[LAMBDA NIL (* Koomen " 4-Feb-87 16:13")
|
||||
|
||||
(* * provide HRULE editing * *)
|
||||
|
||||
(DECLARE (GLOBALVARS HRULE.IMAGEFNS))
|
||||
(replace (IMAGEFNS BUTTONEVENTINFN) of HRULE.IMAGEFNS with (FUNCTION DOCOBJ-HRULE-BUTTONEVENTINFN
|
||||
))
|
||||
(replace (IMAGEFNS BUTTONEVENTINFN) of HRULE.IMAGEFNS
|
||||
with (FUNCTION DOCOBJ-HRULE-BUTTONEVENTINFN))
|
||||
NIL])
|
||||
|
||||
(DOCOBJ-HRULE-GET-WIDTH
|
||||
[LAMBDA (RULE? FIRST?) (* ;
|
||||
"Edited 24-May-93 23:35 by sybalsky:mv:envos")
|
||||
[LAMBDA (RULE? FIRST?) (* ;
|
||||
"Edited 24-May-93 23:35 by sybalsky:mv:envos")
|
||||
(DECLARE (GLOBALVARS DOCOBJ-HRULE-BLANK-PAD DOCOBJ-HRULE-RULE-PAD LASTMOUSEX LASTMOUSEY))
|
||||
[COND
|
||||
((NULL DOCOBJ-HRULE-RULE-PAD)
|
||||
@@ -624,8 +660,10 @@
|
||||
T])
|
||||
|
||||
(DOCOBJ-HRULE-BUTTONEVENTINFN
|
||||
[LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON)
|
||||
(* ; "Edited 8-Oct-87 23:43 by Koomen")
|
||||
[LAMBDA (IMAGEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM
|
||||
BUTTON) (* ;
|
||||
"Edited 8-Oct-87 23:43 by Koomen")
|
||||
|
||||
(if (AND (EQ BUTTON 'MIDDLE)
|
||||
(DOCOBJ-WAIT-MOUSE WINDOWSTREAM))
|
||||
then (ALLOW.BUTTON.EVENTS)
|
||||
@@ -658,6 +696,7 @@
|
||||
|
||||
(DOCOBJ-MAKE-INCLUDE
|
||||
[LAMBDA NIL (* ; "Edited 15-Oct-87 14:54 by Koomen")
|
||||
|
||||
(DECLARE (SPECVARS TEXTOBJ))
|
||||
(PROG ((SUBFILE (TEDIT.GETINPUT TEXTOBJ "Enter file name: ")))
|
||||
(if SUBFILE
|
||||
@@ -666,6 +705,7 @@
|
||||
|
||||
(DOCOBJ-MAKE-INCLUDE-IMAGEFNS
|
||||
[LAMBDA NIL (* ; "Edited 23-Oct-87 00:20 by Koomen")
|
||||
|
||||
(LET ((DISPLAYFN (FUNCTION DOCOBJ-INCLUDE-DISPLAYFN))
|
||||
(IMAGEBOXFN (FUNCTION DOCOBJ-INCLUDE-IMAGEBOXFN))
|
||||
(PUTFN (FUNCTION DOCOBJ-INCLUDE-PUTFN))
|
||||
@@ -679,7 +719,7 @@
|
||||
(WHENCOPIEDFN (FUNCTION NILL))
|
||||
(WHENOPERATEDONFN (FUNCTION NILL))
|
||||
(PREPRINTFN (FUNCTION DOCOBJ-INCLUDE-PREPRINTFN)))
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN
|
||||
(IMAGEFNSCREATE DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN
|
||||
WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN])
|
||||
|
||||
(DOCOBJ-INCLUDE-CREATE-OBJ
|
||||
@@ -872,6 +912,7 @@
|
||||
|
||||
(DOCOBJ-INCLUDE-COPYFN
|
||||
[LAMBDA (IMAGEOBJ SOURCEHOSTSTREAM TARGETHOSTSTREAM) (* ; "Edited 23-Oct-87 00:13 by Koomen")
|
||||
|
||||
(DOCOBJ-INCLUDE-CREATE-OBJ (COPYALL (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM])
|
||||
|
||||
(DOCOBJ-INCLUDE-DISPLAYFN
|
||||
@@ -886,24 +927,28 @@
|
||||
|
||||
(DOCOBJ-INCLUDE-GETFN
|
||||
[LAMBDA (FILESTREAM) (* ; "Edited 26-Oct-87 22:00 by Koomen")
|
||||
|
||||
(LET ((INCLOBJ (READ FILESTREAM)))
|
||||
(if (NLISTP INCLOBJ)
|
||||
then
|
||||
(* ;; "Version 1: Just filename as string")
|
||||
|
||||
(* ;; "Version 2: List whose CAR is filename")
|
||||
|
||||
(* ;; "Version 1: Just filename as string")
|
||||
|
||||
(* ;; "Version 2: List whose CAR is filename")
|
||||
|
||||
(SETQ INCLOBJ (create INCLOBJ
|
||||
FILENAME _ INCLOBJ)))
|
||||
FILENAME _ INCLOBJ)))
|
||||
(if (NLISTP (CDR INCLOBJ))
|
||||
then
|
||||
(* ;; "Version 3: List whose CADR is ENABLEDP flag")
|
||||
|
||||
(* ;; "Version 3: List whose CADR is ENABLEDP flag")
|
||||
|
||||
(NCONC1 INCLOBJ T))
|
||||
(DOCOBJ-INCLUDE-CREATE-OBJ INCLOBJ])
|
||||
|
||||
(DOCOBJ-INCLUDE-IMAGEBOXFN
|
||||
[LAMBDA (IMAGEOBJ IMAGESTREAM CURRENTX RIGHTMARGIN) (* ; "Edited 23-Oct-87 14:41 by Koomen")
|
||||
|
||||
(OR (LET [(INCLOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
|
||||
(if [AND INCLOBJ (OR (EQ (IMAGESTREAMTYPE IMAGESTREAM)
|
||||
'DISPLAY)
|
||||
@@ -914,17 +959,19 @@
|
||||
else 'DONTINCLDISPLAYSTRING))
|
||||
IMAGESTREAM)))
|
||||
(create IMAGEBOX
|
||||
XSIZE _ 0
|
||||
YSIZE _ 0
|
||||
YDESC _ 0
|
||||
XKERN _ 0])
|
||||
XSIZE _ 0
|
||||
YSIZE _ 0
|
||||
YDESC _ 0
|
||||
XKERN _ 0])
|
||||
|
||||
(DOCOBJ-INCLUDE-PREPRINTFN
|
||||
[LAMBDA (IMAGEOBJ) (* ; "Edited 23-Oct-87 14:19 by Koomen")
|
||||
|
||||
(fetch (INCLOBJ FILENAME) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM])
|
||||
|
||||
(DOCOBJ-INCLUDE-PUTFN
|
||||
[LAMBDA (IMAGEOBJ FILESTREAM) (* ; "Edited 15-Oct-87 17:17 by Koomen")
|
||||
|
||||
(PRINT (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)
|
||||
FILESTREAM])
|
||||
)
|
||||
@@ -946,29 +993,29 @@
|
||||
(PUTPROPS DOC-OBJECTS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (9262 22844 (DOCOBJ-ACQUIRE-OBJECT 9272 . 10273) (DOCOBJ-INIT 10275 . 10897) (
|
||||
DOCOBJ-TEDIT-MENU-ENTRY 10899 . 11306) (DOCOBJ-GET-LOOKS 11308 . 13768) (DOCOBJ-REGISTER-OBJECT 13770
|
||||
. 14408) (DOCOBJ-STRING-IMAGEBOX 14410 . 15466) (DOCOBJ-WAIT-MOUSE 15468 . 15859) (
|
||||
DOCOBJ-BEFOREHARDCOPYFN 15861 . 21331) (DOCOBJ-AFTERHARDCOPYFN 21333 . 22842)) (22874 23139 (
|
||||
DOCOBJ-ACQUIRE-EVALED-OBJECT 22884 . 23137)) (23339 23496 (DOCOBJ-ACQUIRE-SNAPPED-OBJECT 23349 . 23494
|
||||
)) (23818 28482 (DOCOBJ-EDIT-TIMESTAMP 23828 . 24289) (DOCOBJ-MAKE-TIMESTAMP 24291 . 24688) (
|
||||
DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS 24690 . 25709) (DOCOBJ-TIMESTAMP-BUTTONEVENTINFN 25711 . 26186) (
|
||||
DOCOBJ-TIMESTAMP-COPYFN 26188 . 26473) (DOCOBJ-TIMESTAMP-DISPLAYFN 26475 . 26696) (
|
||||
DOCOBJ-TIMESTAMP-GETFN 26698 . 26953) (DOCOBJ-TIMESTAMP-IMAGEBOXFN 26955 . 27272) (
|
||||
DOCOBJ-TIMESTAMP-PREPRINTFN 27274 . 27489) (DOCOBJ-TIMESTAMP-PUTFN 27491 . 27875) (
|
||||
DOCOBJ-TIMESTAMP-TO-STRING 27877 . 28480)) (28776 32750 (DOCOBJ-MAKE-FILESTAMP 28786 . 29111) (
|
||||
DOCOBJ-MAKE-FILESTAMP-IMAGEFNS 29113 . 30104) (DOCOBJ-FILESTAMP-COPYFN 30106 . 30381) (
|
||||
DOCOBJ-FILESTAMP-DISPLAYFN 30383 . 30595) (DOCOBJ-FILESTAMP-GETFN 30597 . 30934) (
|
||||
DOCOBJ-FILESTAMP-IMAGEBOXFN 30936 . 31204) (DOCOBJ-FILESTAMP-GET-FULLNAME 31206 . 31808) (
|
||||
DOCOBJ-FILESTAMP-NEW-FULLNAME 31810 . 32267) (DOCOBJ-FILESTAMP-PREPRINTFN 32269 . 32462) (
|
||||
DOCOBJ-FILESTAMP-PUTFN 32464 . 32748)) (33056 35661 (DOCOBJ-MAKE-HRULE 33066 . 33540) (
|
||||
DOCOBJ-EDIT-HRULE 33542 . 33984) (DOCOBJ-HRULE-INIT 33986 . 34386) (DOCOBJ-HRULE-GET-WIDTH 34388 .
|
||||
35218) (DOCOBJ-HRULE-BUTTONEVENTINFN 35220 . 35659)) (36080 44419 (DOCOBJ-MAKE-INCLUDE 36090 . 36490)
|
||||
(DOCOBJ-MAKE-INCLUDE-IMAGEFNS 36492 . 37495) (DOCOBJ-INCLUDE-CREATE-OBJ 37497 . 38265) (
|
||||
DOCOBJ-INCLUDE-EDIT 38267 . 42536) (DOCOBJ-INCLUDE-EDIT-WINDOWP 42538 . 43394) (
|
||||
DOCOBJ-INCLUDE-RESET-OBJ 43396 . 44417)) (44420 53233 (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN 44430 . 47924)
|
||||
(DOCOBJ-INCLUDE-CLEANUPFN 47926 . 49445) (DOCOBJ-INCLUDE-BUTTONEVENTINFN 49447 . 50124) (
|
||||
DOCOBJ-INCLUDE-COPYFN 50126 . 50343) (DOCOBJ-INCLUDE-DISPLAYFN 50345 . 51097) (DOCOBJ-INCLUDE-GETFN
|
||||
51099 . 51809) (DOCOBJ-INCLUDE-IMAGEBOXFN 51811 . 52803) (DOCOBJ-INCLUDE-PREPRINTFN 52805 . 53023) (
|
||||
DOCOBJ-INCLUDE-PUTFN 53025 . 53231)))))
|
||||
(FILEMAP (NIL (7640 21328 (DOCOBJ-ACQUIRE-OBJECT 7650 . 8651) (DOCOBJ-INIT 8653 . 9281) (
|
||||
DOCOBJ-TEDIT-MENU-ENTRY 9283 . 9705) (DOCOBJ-GET-LOOKS 9707 . 12167) (DOCOBJ-REGISTER-OBJECT 12169 .
|
||||
12823) (DOCOBJ-STRING-IMAGEBOX 12825 . 13881) (DOCOBJ-WAIT-MOUSE 13883 . 14343) (
|
||||
DOCOBJ-BEFOREHARDCOPYFN 14345 . 19815) (DOCOBJ-AFTERHARDCOPYFN 19817 . 21326)) (21358 21625 (
|
||||
DOCOBJ-ACQUIRE-EVALED-OBJECT 21368 . 21623)) (21825 21967 (DOCOBJ-ACQUIRE-SNAPPED-OBJECT 21835 . 21965
|
||||
)) (22306 27102 (DOCOBJ-EDIT-TIMESTAMP 22316 . 22845) (DOCOBJ-MAKE-TIMESTAMP 22847 . 23258) (
|
||||
DOCOBJ-MAKE-TIMESTAMP-IMAGEFNS 23260 . 24330) (DOCOBJ-TIMESTAMP-BUTTONEVENTINFN 24332 . 24863) (
|
||||
DOCOBJ-TIMESTAMP-COPYFN 24865 . 25190) (DOCOBJ-TIMESTAMP-DISPLAYFN 25192 . 25485) (
|
||||
DOCOBJ-TIMESTAMP-GETFN 25487 . 25727) (DOCOBJ-TIMESTAMP-IMAGEBOXFN 25729 . 26085) (
|
||||
DOCOBJ-TIMESTAMP-PREPRINTFN 26087 . 26318) (DOCOBJ-TIMESTAMP-PUTFN 26320 . 26689) (
|
||||
DOCOBJ-TIMESTAMP-TO-STRING 26691 . 27100)) (27396 31703 (DOCOBJ-MAKE-FILESTAMP 27406 . 27747) (
|
||||
DOCOBJ-MAKE-FILESTAMP-IMAGEFNS 27749 . 28791) (DOCOBJ-FILESTAMP-COPYFN 28793 . 29108) (
|
||||
DOCOBJ-FILESTAMP-DISPLAYFN 29110 . 29398) (DOCOBJ-FILESTAMP-GETFN 29400 . 29753) (
|
||||
DOCOBJ-FILESTAMP-IMAGEBOXFN 29755 . 30093) (DOCOBJ-FILESTAMP-GET-FULLNAME 30095 . 30713) (
|
||||
DOCOBJ-FILESTAMP-NEW-FULLNAME 30715 . 31188) (DOCOBJ-FILESTAMP-PREPRINTFN 31190 . 31399) (
|
||||
DOCOBJ-FILESTAMP-PUTFN 31401 . 31701)) (32026 34523 (DOCOBJ-MAKE-HRULE 32036 . 32450) (
|
||||
DOCOBJ-EDIT-HRULE 32452 . 32924) (DOCOBJ-HRULE-INIT 32926 . 33258) (DOCOBJ-HRULE-GET-WIDTH 33260 .
|
||||
34071) (DOCOBJ-HRULE-BUTTONEVENTINFN 34073 . 34521)) (34942 43284 (DOCOBJ-MAKE-INCLUDE 34952 . 35353)
|
||||
(DOCOBJ-MAKE-INCLUDE-IMAGEFNS 35355 . 36360) (DOCOBJ-INCLUDE-CREATE-OBJ 36362 . 37130) (
|
||||
DOCOBJ-INCLUDE-EDIT 37132 . 41401) (DOCOBJ-INCLUDE-EDIT-WINDOWP 41403 . 42259) (
|
||||
DOCOBJ-INCLUDE-RESET-OBJ 42261 . 43282)) (43285 52131 (DOCOBJ-INCLUDE-BEFOREHARDCOPYFN 43295 . 46789)
|
||||
(DOCOBJ-INCLUDE-CLEANUPFN 46791 . 48310) (DOCOBJ-INCLUDE-BUTTONEVENTINFN 48312 . 48989) (
|
||||
DOCOBJ-INCLUDE-COPYFN 48991 . 49209) (DOCOBJ-INCLUDE-DISPLAYFN 49211 . 49963) (DOCOBJ-INCLUDE-GETFN
|
||||
49965 . 50688) (DOCOBJ-INCLUDE-IMAGEBOXFN 50690 . 51699) (DOCOBJ-INCLUDE-PREPRINTFN 51701 . 51920) (
|
||||
DOCOBJ-INCLUDE-PUTFN 51922 . 52129)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,18 +1,17 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF" "BUILD-COMPOSITE"
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE") ( IMPORT-FROM "IL" "BITBLT" "BITMAPBIT" "BITMAPCREATE"
|
||||
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "CHARSETPROP"
|
||||
"DISPLAY" "FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM"
|
||||
"REGULAR" "TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE
|
||||
10)
|
||||
"BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "DISPLAY"
|
||||
"FONTDESCRIPTOR" "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR" "TCONC"
|
||||
"UTOMCODE?" "MEDLEYFONT.FILENAME" "MEDLEYFONT.WRITE.FONT")) READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED " 8-Dec-2025 12:13:40" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9| 51309
|
||||
(IL:FILECREATED "16-Mar-2026 16:37:31" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;22| 58094
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")
|
||||
:CHANGES-TO (IL:FUNCTIONS READ-GLYPH READ-BDF BDF-TO-FONTDESCRIPTOR GLYPHS-BY-CHARSET
|
||||
WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE BDF-TO-CHARSETINFO)
|
||||
|
||||
:PREVIOUS-DATE " 8-Dec-2025 12:12:47" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;8|
|
||||
:PREVIOUS-DATE "23-Feb-2026 20:11:48" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;21|
|
||||
)
|
||||
|
||||
|
||||
@@ -20,7 +19,7 @@
|
||||
|
||||
(IL:RPAQQ IL:READ-BDFCOMS
|
||||
((IL:STRUCTURES BDF-FONT GLYPH XLFD)
|
||||
(IL:VARIABLES MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET)
|
||||
(IL:VARIABLES GLYPH-PROCESSING-HOOK MAXCHARSET MAXTHINCHAR NOMAPPINGCHARSET)
|
||||
(IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR BUILD-COMPOSITE CHAR-PRESENT-BIT
|
||||
COUNT-MCHARS GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF
|
||||
READ-DELIMITED-LIST-FROM-STRING READ-GLYPH WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE
|
||||
@@ -71,13 +70,17 @@
|
||||
(CHARSET昱EGISTRY NIL :TYPE STRING)
|
||||
(CHARSET挂NCODING NIL :TYPE STRING))
|
||||
|
||||
(DEFVAR GLYPH-PROCESSING-HOOK NIL)
|
||||
|
||||
(DEFCONSTANT MAXCHARSET 255)
|
||||
|
||||
(DEFCONSTANT MAXTHINCHAR 255)
|
||||
|
||||
(DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET))
|
||||
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUGWIDTH) (IL:* IL:\; "Edited 8-Dec-2025 12:13 by mth")
|
||||
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUGWIDTH &KEY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:35 by mth")
|
||||
(IL:* IL:\; "Edited 8-Dec-2025 12:13 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 00:12 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 16:37 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 21:18 by mth")
|
||||
@@ -107,7 +110,7 @@
|
||||
(IL:* IL:|;;| "If passed a BDF-FONT, look only at glyphs in the mapped charsets")
|
||||
|
||||
(DESTRUCTURING-SETQ (GBCS SW)
|
||||
(GLYPHS-BY-CHARSET FONT)))
|
||||
(GLYPHS-BY-CHARSET FONT :AS-UNICODE AS-UNICODE)))
|
||||
(T (ERROR "Invalid FONT: ~S" FONT)))
|
||||
(UNLESS (AND (INTEGERP SLUGWIDTH)
|
||||
(PLUSP SLUGWIDTH))
|
||||
@@ -126,7 +129,9 @@
|
||||
(IMAGEWIDTHS (IL:\\CREATECSINFOELEMENT))
|
||||
(DLEFT 0)
|
||||
GLYPHS-LIMITS BMAP OFFSETS HEIGHT WIDTHS)
|
||||
(CHARSETPROP CSINFO 'IL:CSCHARENCODING 'MCCS)
|
||||
(IL:CHARSETPROP CSINFO 'IL:CSCHARENCODING (IF AS-UNICODE
|
||||
'IL:UNICODE
|
||||
'MCCS))
|
||||
(LOOP :FOR XGL :IN CSGLYPHS :DO (LET* ((MCODE (CAR XGL))
|
||||
(GL (CDR XGL))
|
||||
(GWIDTH (GLYPH-WIDTH GL))
|
||||
@@ -201,7 +206,8 @@
|
||||
'IL:REPLACE)
|
||||
CSINFO))))
|
||||
|
||||
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE)
|
||||
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &KEY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:16 by mth")
|
||||
(IL:* IL:\; "Edited 8-Dec-2025 12:11 by mth")
|
||||
(IL:* IL:\; "Edited 2-Dec-2025 16:10 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 15:59 by mth")
|
||||
@@ -220,7 +226,8 @@
|
||||
(OR SIZE (FONTPROP FAMILY 'IL:SIZE))
|
||||
(OR FACE (FONTPROP FAMILY 'IL:FACE))
|
||||
(OR ROTATION (FONTPROP FAMILY 'IL:ROTATION))
|
||||
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)))))
|
||||
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE))
|
||||
:AS-UNICODE AS-UNICODE)))
|
||||
(WHEN (CONSP FAMILY) (IL:* IL:\;
|
||||
"Because (LISTP NIL) == T !!!")
|
||||
|
||||
@@ -240,7 +247,8 @@
|
||||
0)
|
||||
(OR DEVICE (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE)
|
||||
IL:|of| FAMILY)
|
||||
'DISPLAY))))
|
||||
'DISPLAY)
|
||||
:AS-UNICODE AS-UNICODE)))
|
||||
(LET ((XLFD (BF-XLFD BDFONT))
|
||||
FONTDESC GBCSL CHARSETS SLUGWIDTH)
|
||||
(SETQ FAMILY (IL:\\FONTSYMBOL (OR FAMILY (XLFD-FAMILY XLFD))))
|
||||
@@ -280,7 +288,7 @@
|
||||
'IL:MRR)
|
||||
NIL DEVICE))
|
||||
(DESTRUCTURING-SETQ (GBCSL SLUGWIDTH)
|
||||
(GLYPHS-BY-CHARSET BDFONT))
|
||||
(GLYPHS-BY-CHARSET BDFONT :AS-UNICODE AS-UNICODE))
|
||||
(UNLESS SLUGWIDTH
|
||||
|
||||
(IL:* IL:|;;|
|
||||
@@ -300,16 +308,21 @@
|
||||
IL:ROTATION IL:_ ROTATION
|
||||
IL:FONTDEVICESPEC IL:_ (LIST FAMILY SIZE FACE ROTATION DEVICE)
|
||||
IL:FONTSLUGWIDTH IL:_ SLUGWIDTH
|
||||
IL:FONTCHARENCODING IL:_ 'MCCS))
|
||||
IL:FONTCHARENCODING IL:_ (IF AS-UNICODE
|
||||
'IL:UNICODE
|
||||
'MCCS)))
|
||||
(SETQ CHARSETS (LOOP :FOR CS :IN GBCSL :WITH CSET :WITH CSINFO :NCONC
|
||||
(WHEN (<= 0 (SETQ CSET (FIRST CS))
|
||||
MAXCHARSET)
|
||||
(SETQ CSINFO (BDF-TO-CHARSETINFO GBCSL CSET (1+ SLUGWIDTH)))
|
||||
(SETQ CSINFO (BDF-TO-CHARSETINFO GBCSL CSET (1+ SLUGWIDTH)
|
||||
:AS-UNICODE AS-UNICODE))
|
||||
(IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET)
|
||||
(LIST CSET)))))
|
||||
(LIST FONTDESC CHARSETS))))
|
||||
|
||||
(DEFUN BUILD-COMPOSITE (FONTS &KEY VERBOSE) (IL:* IL:\; "Edited 1-Dec-2025 23:07 by mth")
|
||||
(DEFUN BUILD-COMPOSITE (FONTS &KEY VERBOSE (BLOCKING T))
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 21:45 by mth")
|
||||
(IL:* IL:\; "Edited 1-Dec-2025 23:07 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 12:32 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 21:23 by mth")
|
||||
(IL:* IL:\; "Edited 18-Nov-2025 21:22 by mth")
|
||||
@@ -327,53 +340,61 @@
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Loading initial font file: ~A~%" (NAMESTRING BASE-FONT)
|
||||
))
|
||||
(SETQ BASE-FONT (READ-BDF BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
|
||||
(SETQ BASE-FONT (READ-BDF BASE-FONT :MCCS-ONLY T :VERBOSE VERBOSE))
|
||||
(WHEN BLOCKING (IL:BLOCK)))
|
||||
((NOT (BDF-FONT-P BASE-FONT))
|
||||
(ERROR "Initial font (~S) is not a BDF-FONT, nor string, nor pathname." BASE-FONT)))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Initial font contains ~D MCCS characters.~%"
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))))
|
||||
(SETQ MCHAR-PRESENT (BF-MCHAR-PRESENT BASE-FONT))
|
||||
(LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WHEN FILL-FONT :DO
|
||||
(COND
|
||||
((OR (STRINGP FILL-FONT)
|
||||
(PATHNAMEP FILL-FONT))
|
||||
(UNLESS (IL:INFILEP FILL-FONT)
|
||||
(ERROR "Subsequent font ~S doesn't exist or is unreadable." (NAMESTRING
|
||||
FILL-FONT)))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Loading subsequent font file: ~A~%" (NAMESTRING
|
||||
FILL-FONT)))
|
||||
(SETQ FILL-FONT (READ-BDF FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)))
|
||||
((NOT (BDF-FONT-P FILL-FONT))
|
||||
(ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname."
|
||||
FILL-FONT)))
|
||||
(SETQ PREV-CC CHAR-COUNT)
|
||||
(LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT)
|
||||
:WITH V :DO (SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
(LOOP :FOR FILL-FONT :IN FILL-FROM :WITH PREV-CC :WITH FF-NAME :WHEN FILL-FONT :DO
|
||||
(FLET ((MERGE-GLYPH (GL &AUX V)
|
||||
(SETQ V (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP V)
|
||||
(EQ (FIRST V)
|
||||
-1))
|
||||
(SETQ V (OR (SECOND V)
|
||||
-1)))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
(IL:* IL:|;;|
|
||||
"Need to change this use of UTOMCODE? based on the CHARSET昱EGISTRY of the XLFD of FILL-FONT")
|
||||
|
||||
(WHEN (AND (UTOMCODE? V)
|
||||
(ZEROP (CHAR-PRESENT-BIT MCHAR-PRESENT V)))
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT V 1)
|
||||
(WHEN (AND (UTOMCODE? V)
|
||||
(ZEROP (CHAR-PRESENT-BIT MCHAR-PRESENT V)))
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT V 1)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
(IL:* IL:|;;|
|
||||
"What other bookkeping of BASE-FONT needs to be done when adding a glyph? Any?")
|
||||
|
||||
(PUSH GL (BF-GLYPHS BASE-FONT))))
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT* "~&Font ~A supplied ~D additional MCCS characters.~%"
|
||||
(NAMESTRING FILL-FONT)
|
||||
(- (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
PREV-CC))))
|
||||
(PUSH GL (BF-GLYPHS BASE-FONT)))
|
||||
NIL))
|
||||
(COND
|
||||
((OR (STRINGP FILL-FONT)
|
||||
(PATHNAMEP FILL-FONT))
|
||||
(SETQ FF-NAME (NAMESTRING FILL-FONT))
|
||||
(UNLESS (IL:INFILEP FILL-FONT)
|
||||
(ERROR "Subsequent font ~S doesn't exist or is unreadable." FF-NAME))
|
||||
(WHEN VERBOSE (FORMAT *STANDARD-OUTPUT*
|
||||
"~&Loading subsequent font file: ~A~%" FF-NAME))
|
||||
(LET ((GLYPH-PROCESSING-HOOK #'MERGE-GLYPH))
|
||||
(READ-BDF FILL-FONT :MCCS-ONLY T :VERBOSE VERBOSE)
|
||||
(SETQ FILL-FONT NIL))
|
||||
(WHEN BLOCKING (IL:BLOCK)))
|
||||
((NOT (BDF-FONT-P FILL-FONT))
|
||||
(ERROR "Subsequent font (~S) is not a BDF-FONT, nor string, nor pathname."
|
||||
FF-NAME)))
|
||||
(SETQ PREV-CC CHAR-COUNT)
|
||||
(WHEN FILL-FONT
|
||||
(LOOP :FOR GL :IN (BF-GLYPHS FILL-FONT)
|
||||
:DO
|
||||
(MERGE-GLYPH GL)))
|
||||
(SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
(WHEN VERBOSE
|
||||
(FORMAT *STANDARD-OUTPUT*
|
||||
"~&Font ~A supplied ~D additional MCCS characters.~%" FF-NAME
|
||||
(- (SETQ CHAR-COUNT (COUNT-MCHARS BASE-FONT))
|
||||
PREV-CC)))))
|
||||
BASE-FONT))
|
||||
|
||||
(DEFUN CHAR-PRESENT-BIT (BM MCODE &OPTIONAL (NEWBIT -1 SBIT)
|
||||
@@ -401,7 +422,8 @@
|
||||
(LET ((MCPBM (BF-MCHAR-PRESENT BDFONT)))
|
||||
(LOOP :FOR MC :FROM 0 :TO 65535 :COUNT (PLUSP (CHAR-PRESENT-BIT MCPBM MC))))))
|
||||
|
||||
(DEFUN GLYPHS-BY-CHARSET (FONT) (IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth")
|
||||
(DEFUN GLYPHS-BY-CHARSET (FONT &KEY AS-UNICODE) (IL:* IL:\; "Edited 16-Mar-2026 16:06 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 17:36 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:24 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 20:50 by mth")
|
||||
(IL:* IL:\; "Edited 20-Nov-2025 12:01 by mth")
|
||||
@@ -471,7 +493,9 @@
|
||||
X))
|
||||
Y))))
|
||||
|
||||
(DEFUN READ-BDF (PATH &KEY VERBOSE MCCS-ONLY (EXTERNAL-FORMAT :ISO8859/1))
|
||||
(DEFUN READ-BDF (PATH &KEY VERBOSE MCCS-ONLY AS-UNICODE (EXTERNAL-FORMAT :ISO8859/1))
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:11 by mth")
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 21:42 by mth")
|
||||
(IL:* IL:\; "Edited 1-Dec-2025 22:40 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 11:59 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:39 by mth")
|
||||
@@ -586,16 +610,43 @@
|
||||
(PLUSP NGLYPHS))
|
||||
(ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing."
|
||||
NGLYPHS))
|
||||
(LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO (SETQ GL (READ-GLYPH
|
||||
FILE-STREAM
|
||||
FONT))
|
||||
(LOOP :REPEAT NGLYPHS :WITH ENC :WITH MC :DO
|
||||
(SETQ GL (READ-GLYPH FILE-STREAM FONT :MCCS-ONLY MCCS-ONLY :AS-UNICODE
|
||||
AS-UNICODE))
|
||||
(SETQ ENC (GLYPH-ENCODING GL))
|
||||
(WHEN (AND (LISTP ENC)
|
||||
(EQ (FIRST ENC)
|
||||
-1))
|
||||
(EQL (FIRST ENC)
|
||||
-1))
|
||||
(SETQ ENC (OR (SECOND ENC)
|
||||
-1)))
|
||||
(COND
|
||||
(AS-UNICODE
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"IS THIS TRUE IF REMAINING IN UNICODE ENCODING?")
|
||||
|
||||
(IL:* IL:|;;| "This glyph must have either a non-zero-width \"image\" or a non-zero-width \"escapement\", otherwise it cannot be mapped, no matter the UTOMCODE? value.")
|
||||
|
||||
(IL:* IL:|;;| "For now, assuming NOT TRUE")
|
||||
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP
|
||||
GLYPH-PROCESSING-HOOK
|
||||
))
|
||||
(SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
|
||||
(WHEN GL
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Everything is mappable if in 0000-FFFF range")
|
||||
|
||||
(IF (<= 0 ENC 65535)
|
||||
(PROGN (SETF (GLYPH-MCODE GL)
|
||||
ENC)
|
||||
(TCONC MAPPED-GLYPHS GL))
|
||||
(TCONC UNMAPPED-GLYPHS GL)))
|
||||
|
||||
(IL:* IL:|;;| "Don't bother with MCHAR-PRESENT bits")
|
||||
|
||||
)
|
||||
((AND (OR (PLUSP (GLYPH-BBW GL))
|
||||
(PLUSP (FIRST (GLYPH-DWIDTH GL))))
|
||||
(SETQ MC (UTOMCODE? ENC)))
|
||||
@@ -615,143 +666,200 @@
|
||||
|
||||
(IL:* IL:|;;| "It ought to be safe to share the bitmap")
|
||||
|
||||
(TCONC MAPPED-GLYPHS CGL)
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP
|
||||
GLYPH-PROCESSING-HOOK
|
||||
))
|
||||
(SETQ CGL (FUNCALL GLYPH-PROCESSING-HOOK CGL)))
|
||||
(WHEN CGL (TCONC MAPPED-GLYPHS CGL))
|
||||
(CHAR-PRESENT-BIT MCHAR-PRESENT CC 1)))
|
||||
(T (TCONC UNMAPPED-GLYPHS GL))))
|
||||
((NOT MCCS-ONLY)
|
||||
(WHEN (AND GLYPH-PROCESSING-HOOK (FUNCTIONP GLYPH-PROCESSING-HOOK)
|
||||
)
|
||||
(SETQ GL (FUNCALL GLYPH-PROCESSING-HOOK GL)))
|
||||
(WHEN GL (TCONC UNMAPPED-GLYPHS GL)))))
|
||||
(SETF (BF-GLYPHS FONT)
|
||||
(CAR MAPPED-GLYPHS))
|
||||
(SETF (BF-UNMAPPED故LYPHS FONT)
|
||||
(CAR UNMAPPED-GLYPHS)))
|
||||
(ENDFONT (SETQ FONT-COMPLETE T))))))))
|
||||
(WHEN VERBOSE
|
||||
(ENDFONT (SETQ FONT-COMPLETE T)))))))))
|
||||
(WHEN VERBOSE
|
||||
|
||||
(IL:* IL:|;;| "The SIZE reported needs clarification:")
|
||||
(IL:* IL:|;;| "The SIZE reported needs clarification:")
|
||||
|
||||
(FORMAT *STANDARD-OUTPUT* "Name: ~A~%Family: ~A~%Sizes: Font: ~A Pixel: ~A Point: ~A (decipoints)~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%"
|
||||
(BF-NAME FONT)
|
||||
(XLFD-FAMILY XLFD)
|
||||
(FIRST (BF-SIZE FONT))
|
||||
(XLFD-PIXEL昤IZE XLFD)
|
||||
(XLFD-POINT昤IZE XLFD)
|
||||
(XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-SETWIDTH昧AME XLFD)))
|
||||
FONT)))
|
||||
(FORMAT *STANDARD-OUTPUT* "Name: ~A~%Family: ~A~%Sizes: Font: ~A Pixel: ~A Point: ~A (decipoints)~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%Glyphs: ~D~%Unmapped glyphs: ~D~%"
|
||||
(BF-NAME FONT)
|
||||
(XLFD-FAMILY XLFD)
|
||||
(FIRST (BF-SIZE FONT))
|
||||
(XLFD-PIXEL昤IZE XLFD)
|
||||
(XLFD-POINT昤IZE XLFD)
|
||||
(XLFD-WEIGHT XLFD)
|
||||
(XLFD-SLANT XLFD)
|
||||
(XLFD-SETWIDTH昧AME XLFD)
|
||||
(LENGTH (BF-GLYPHS FONT))
|
||||
(LENGTH (BF-UNMAPPED故LYPHS FONT))))
|
||||
FONT))
|
||||
|
||||
(DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\]))
|
||||
(IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth")
|
||||
(WITH-INPUT-FROM-STRING (SI (CONCATENATE 'STRING INPUT-STRING " " (STRING DELIMIT)))
|
||||
(READ-DELIMITED-LIST DELIMIT SI)))
|
||||
|
||||
(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 26-Nov-2025 23:32 by mth")
|
||||
(DEFUN READ-GLYPH (FILE-STREAM FONT &KEY MCCS-ONLY AS-UNICODE)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 15:32 by mth")
|
||||
(IL:* IL:\; "Edited 23-Feb-2026 20:11 by mth")
|
||||
(IL:* IL:\; "Edited 19-Feb-2026 15:46 by mth")
|
||||
(IL:* IL:\; "Edited 26-Nov-2025 23:32 by mth")
|
||||
(IL:* IL:\; "Edited 17-Nov-2025 20:03 by mth")
|
||||
(IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth")
|
||||
(IL:* IL:\; "Edited 21-Apr-2025 13:37 by mth")
|
||||
(IL:* IL:\; "Edited 19-Apr-2025 09:32 by mth")
|
||||
(IL:* IL:\; "Edited 17-Apr-2025 18:14 by mth")
|
||||
(IL:* IL:\; "Edited 21-Aug-2024 01:10 by mth")
|
||||
(LET ((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP :UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(COND
|
||||
((EQ KEY 'COMMENT) (IL:* IL:\; "Ignore COMMENT lines")
|
||||
(LET
|
||||
((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE ENC LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP
|
||||
:UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(COND
|
||||
((EQ KEY 'COMMENT) (IL:* IL:\; "Ignore COMMENT lines")
|
||||
(IL:* IL:\;
|
||||
"Probably aren't \"legal\" here, anyway.")
|
||||
)
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T (UNLESS STARTED (ERROR
|
||||
)
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T
|
||||
(UNLESS STARTED (ERROR
|
||||
"Invalid BDF file - glyph has not been started. STARTCHAR missing."
|
||||
))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(IF (EQL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP (UNLESS (ZEROP (* BBW BBH))
|
||||
))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(SETQ ENC (IF (EQL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS)))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP
|
||||
(UNLESS (ZEROP (* BBW BBH)) (IL:* IL:\;
|
||||
"Don't bother creating a BITMAP with no area")
|
||||
(IF (AND (NOT AS-UNICODE)
|
||||
MCCS-ONLY
|
||||
(NOT (UTOMCODE? ENC)))
|
||||
(PROGN
|
||||
(IL:* IL:|;;|
|
||||
"This is the case of skipping over non-MCCS encoded glyph when MCCS-ONLY")
|
||||
|
||||
(IL:* IL:|;;| "Don't bother creating a BITMAP with no area")
|
||||
(LOOP :REPEAT BBH :DO (READ-LINE FILE-STREAM)))
|
||||
(LET*
|
||||
((BM (BITMAPCREATE BBW BBH 1))
|
||||
(BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM))
|
||||
(BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH IL:|of| BM))
|
||||
(NBYTES (CEILING BBW 8))
|
||||
(NCHARS (* 2 NBYTES))
|
||||
(NWORDS (CEILING BBW 16))
|
||||
BITS WORDINDEX)
|
||||
(LABELS ((CHAR-HEX-VALUE (C)
|
||||
(IF (CHARACTERP C)
|
||||
(COND
|
||||
((CHAR<= #\0 C #\9)
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (CHAR-CODE #\0))))
|
||||
((CHAR<= #\A C #\F)
|
||||
|
||||
(LET* ((BM (BITMAPCREATE BBW BBH 1))
|
||||
(BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM))
|
||||
(BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH
|
||||
IL:|of| BM))
|
||||
(NBYTES (CEILING BBW 8))
|
||||
(NCHARS (* 2 NBYTES))
|
||||
(NWORDS (CEILING BBW 16))
|
||||
BITS BYTEPOS WORDINDEX)
|
||||
(LOOP :WITH BITROW = 0 :REPEAT BBH :DO
|
||||
(SETQ LINE (STRING-TRIM '(#\Space #\Tab)
|
||||
(READ-LINE FILE-STREAM)))
|
||||
(UNLESS (AND (EQUAL NCHARS (LENGTH LINE))
|
||||
(SETQ BITS
|
||||
(PARSE-INTEGER LINE :RADIX 16
|
||||
:JUNK-ALLOWED T)))
|
||||
(ERROR
|
||||
"Invalid BDF file - bad line in BITMAP: ~A"
|
||||
LINE))
|
||||
(WHEN (ODDP NBYTES)
|
||||
(SETQ BITS (ASH BITS 8)))
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(SETQ BYTEPOS (* 16 (1- NWORDS)))
|
||||
(LOOP :REPEAT NWORDS :DO
|
||||
(IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(LDB (BYTE 16 BYTEPOS)
|
||||
BITS))
|
||||
(INCF WORDINDEX)
|
||||
(DECF BYTEPOS 16))
|
||||
(INCF BITROW))
|
||||
(SETF (GLYPH-BITMAP GLYPH)
|
||||
BM))))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
(SETF (GLYPH-ASCENT GLYPH)
|
||||
(+ (GLYPH-BBH GLYPH)
|
||||
(GLYPH-BBYOFF0 GLYPH)))
|
||||
(SETF (GLYPH-DESCENT GLYPH)
|
||||
(ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH))))
|
||||
(SETF (GLYPH-WIDTH GLYPH)
|
||||
(MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH))
|
||||
(GLYPH-BBW GLYPH))
|
||||
(FIRST (GLYPH-DWIDTH GLYPH))))
|
||||
GLYPH))
|
||||
(IL:* IL:|;;|
|
||||
"The (- (CHAR-CODE #\\A) 10) accomplishes adding 10 after the outer subtraction")
|
||||
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (- (CHAR-CODE #\A)
|
||||
10))))
|
||||
((CHAR<= #\a C #\f)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"The (- (CHAR-CODE #\\a) 10) accomplishes adding 10 after the outer subtraction")
|
||||
|
||||
(- (CHAR-CODE C)
|
||||
(IL:CONSTANT (- (CHAR-CODE #\a)
|
||||
10))))
|
||||
(T 0))
|
||||
0))
|
||||
(PARSE-WORDS
|
||||
NIL
|
||||
(LOOP :FOR I :FROM 0 :TO (1- NCHARS)
|
||||
:BY 4 :WITH C3LIMIT = (- NCHARS 3)
|
||||
:WITH C4LIMIT = (- NCHARS 4)
|
||||
:COLLECT
|
||||
(+ (ASH (CHAR-HEX-VALUE (CHAR LINE I))
|
||||
12)
|
||||
(ASH (CHAR-HEX-VALUE (CHAR LINE (+ 1 I)))
|
||||
8)
|
||||
(ASH (CHAR-HEX-VALUE (AND (<= I C3LIMIT)
|
||||
(CHAR LINE (+ 2 I))))
|
||||
4)
|
||||
(CHAR-HEX-VALUE (AND (<= I C4LIMIT)
|
||||
(CHAR LINE (+ 3 I))))))))
|
||||
(LOOP :WITH BITROW = 0 :REPEAT BBH :DO
|
||||
(SETQ LINE (STRING-TRIM '(#\Space #\Tab)
|
||||
(READ-LINE FILE-STREAM)))
|
||||
(UNLESS (EQUAL NCHARS (LENGTH LINE))
|
||||
(ERROR "Invalid BDF file - bad line in BITMAP: ~A"
|
||||
LINE))
|
||||
(SETQ BITS (PARSE-WORDS))
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(LOOP :REPEAT NWORDS :DO (IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(POP BITS))
|
||||
(INCF WORDINDEX))
|
||||
(INCF BITROW)))
|
||||
(SETF (GLYPH-BITMAP GLYPH)
|
||||
BM)))))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
(SETF (GLYPH-ASCENT GLYPH)
|
||||
(+ (GLYPH-BBH GLYPH)
|
||||
(GLYPH-BBYOFF0 GLYPH)))
|
||||
(SETF (GLYPH-DESCENT GLYPH)
|
||||
(ABS (MIN 0 (GLYPH-BBYOFF0 GLYPH))))
|
||||
(SETF (GLYPH-WIDTH GLYPH)
|
||||
(MAX (+ (MAX 0 (GLYPH-BBXOFF0 GLYPH))
|
||||
(GLYPH-BBW GLYPH))
|
||||
(FIRST (GLYPH-DWIDTH GLYPH))))
|
||||
GLYPH))
|
||||
|
||||
(DEFUN WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE (BDFONT DEST-DIR &KEY FAMILY SIZE FACE ROTATION DEVICE
|
||||
&AUX FULLFILENAME)
|
||||
AS-UNICODE TEST &AUX FULLFILENAME)
|
||||
(IL:* IL:\; "Edited 16-Mar-2026 16:12 by mth")
|
||||
(IL:* IL:\; "Edited 23-Feb-2026 15:57 by mth")
|
||||
(IL:* IL:\; "Edited 17-Feb-2026 14:17 by mth")
|
||||
(IL:* IL:\; "Edited 2-Dec-2025 14:47 by mth")
|
||||
(IL:* IL:\; "Edited 30-Nov-2025 16:03 by mth")
|
||||
(IL:* IL:\; "Edited 28-Nov-2025 17:56 by mth")
|
||||
@@ -760,7 +868,7 @@
|
||||
(UNLESS (BDF-FONT-P BDFONT)
|
||||
(ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
|
||||
(DESTRUCTURING-BIND (FONTDESC CSETS)
|
||||
(BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE)
|
||||
(BDF-TO-FONTDESCRIPTOR BDFONT FAMILY SIZE FACE ROTATION DEVICE :AS-UNICODE AS-UNICODE)
|
||||
(UNLESS FONTDESC
|
||||
|
||||
(IL:* IL:|;;| "Creation of the FONTDESCRIPTOR failed!")
|
||||
@@ -769,8 +877,10 @@
|
||||
|
||||
(IL:* IL:|;;| "CSETS correspond to the charsets actually present in the FONTDESC.")
|
||||
|
||||
(SETQ FULLFILENAME (MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME FONTDESC NIL NIL
|
||||
DEST-DIR)))
|
||||
(SETQ FULLFILENAME (IF TEST
|
||||
"WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE TEST"
|
||||
(MEDLEYFONT.WRITE.FONT FONTDESC (MEDLEYFONT.FILENAME NIL FONTDESC
|
||||
NIL NIL DEST-DIR))))
|
||||
(LIST FULLFILENAME FONTDESC CSETS)))
|
||||
|
||||
(DEFUN XLFD-SPLIT-FONT-NAME (NAME) (IL:* IL:\; "Edited 26-Nov-2025 09:43 by mth")
|
||||
@@ -880,21 +990,21 @@
|
||||
"BITMAPCREATE" "BITMAPHEIGHT"
|
||||
"BITMAPWIDTH" "BLACKSHADE" "BLTSHADE"
|
||||
"BOLD" "COMPRESSED" "CHARSETINFO"
|
||||
"CHARSETPROP" "DISPLAY" "FONTDESCRIPTOR"
|
||||
"FONTP" "FONTPROP" "INPUT" "ITALIC"
|
||||
"LIGHT" "LRSH" "MCCS" "MEDIUM" "REGULAR"
|
||||
"TCONC" "UTOMCODE?" "MEDLEYFONT.FILENAME"
|
||||
"DISPLAY" "FONTDESCRIPTOR" "FONTP"
|
||||
"FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH"
|
||||
"MCCS" "MEDIUM" "REGULAR" "TCONC"
|
||||
"UTOMCODE?" "MEDLEYFONT.FILENAME"
|
||||
"MEDLEYFONT.WRITE.FONT"))
|
||||
:READTABLE "XCL"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO)
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (3116 10226 (BDF-TO-CHARSETINFO 3116 . 10226)) (10228 16847 (BDF-TO-FONTDESCRIPTOR
|
||||
10228 . 16847)) (16849 20782 (BUILD-COMPOSITE 16849 . 20782)) (20784 21533 (CHAR-PRESENT-BIT 20784 .
|
||||
21533)) (21535 21819 (COUNT-MCHARS 21535 . 21819)) (21821 24856 (GLYPHS-BY-CHARSET 21821 . 24856)) (
|
||||
24858 26283 (PACKFILENAME.STRING 24858 . 26283)) (26285 35760 (READ-BDF 26285 . 35760)) (35762 36085 (
|
||||
READ-DELIMITED-LIST-FROM-STRING 35762 . 36085)) (36087 43085 (READ-GLYPH 36087 . 43085)) (43087 44472
|
||||
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 43087 . 44472)) (44474 46891 (XLFD-SPLIT-FONT-NAME 44474 . 46891)
|
||||
) (46893 49905 (XLFD-TO-FACE 46893 . 49905)))))
|
||||
(IL:FILEMAP (NIL (3216 10679 (BDF-TO-CHARSETINFO 3216 . 10679)) (10681 17828 (BDF-TO-FONTDESCRIPTOR
|
||||
10681 . 17828)) (17830 22409 (BUILD-COMPOSITE 17830 . 22409)) (22411 23160 (CHAR-PRESENT-BIT 22411 .
|
||||
23160)) (23162 23446 (COUNT-MCHARS 23162 . 23446)) (23448 26592 (GLYPHS-BY-CHARSET 23448 . 26592)) (
|
||||
26594 28019 (PACKFILENAME.STRING 26594 . 28019)) (28021 40051 (READ-BDF 28021 . 40051)) (40053 40376 (
|
||||
READ-DELIMITED-LIST-FROM-STRING 40053 . 40376)) (40378 49390 (READ-GLYPH 40378 . 49390)) (49392 51271
|
||||
(WRITE-BDF-TO-MEDLEYDISPLAYFONT-FILE 49392 . 51271)) (51273 53690 (XLFD-SPLIT-FONT-NAME 51273 . 53690)
|
||||
) (53692 56704 (XLFD-TO-FACE 53692 . 56704)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Reference in New Issue
Block a user