Updated EDITFONT for FONT compatibility and robustness (#2257)
Updated for FONT compatibility and robustness
This commit is contained in:
rmkaplan
GitHub
parent
4fef217c45
commit
8fa61304a3
@ -1,56 +1,54 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 1-Feb-2025 12:28:41" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;2 28339
|
||||
(FILECREATED " 4-Aug-2025 13:34:06" {WMEDLEY}<lispusers>EDITFONT.;26 23614
|
||||
|
||||
:EDIT-BY "mth"
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS EDITFONTCOMS)
|
||||
:CHANGES-TO (FNS READSTRIKEFONTFILE BLANKCHARSETCREATE EF.INIT EF.DELETE BLANKFONTCREATE
|
||||
EF.DELETECHAR EF.SAVE EDITFONT EF.CHARITEMS EF.EDITBM EF.BLANK COPYFONT
|
||||
EF.CHANGESIZE EF.ENTER EF.REPLACE)
|
||||
(VARS EDITFONTCOMS)
|
||||
(RECORDS CHARITEM)
|
||||
|
||||
:PREVIOUS-DATE "12-Jul-2022 14:18:56" {DSK}<home>matt>Interlisp>medley>lispusers>EDITFONT.;1)
|
||||
:PREVIOUS-DATE " 2-Aug-2025 10:11:50" {WMEDLEY}<lispusers>EDITFONT.;14)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EDITFONTCOMS)
|
||||
|
||||
(RPAQQ EDITFONTCOMS
|
||||
((* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
|
||||
(
|
||||
(* ;; "EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file.")
|
||||
|
||||
(INITVARS (EF.MENU NIL)
|
||||
(EF.TITLEMENU NIL))
|
||||
(RECORDS CHARITEM)
|
||||
(FNS EF.INIT EF.PROMPT EF.MESSAGE EF.CLOSEFN EF.CHARITEMS EF.BUTTONEVENTFN EF.WHENSELECTEDFN
|
||||
EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE EF.BLANK
|
||||
COPYFONT READSTRIKEFONTFILE)
|
||||
(FNS BLANKFONTCREATE EDITFONT)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2))
|
||||
EF.EDITBM EF.MIDDLEBUTTONFN EF.CHANGESIZE EF.DELETE EF.ENTER EF.REPLACE EF.SAVE COPYFONT
|
||||
READSTRIKEFONTFILE)
|
||||
(FNS BLANKCHARSETCREATE EDITFONT)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARITEM)
|
||||
(FILES (LOADCOMP)
|
||||
FONT))
|
||||
(P (EF.INIT))))
|
||||
|
||||
|
||||
|
||||
(* EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file. *)
|
||||
(* ;; "EDITFONT -- By Kelly Roach. Need to LOAD EXPORTS.ALL in order to compile this file.")
|
||||
|
||||
|
||||
(RPAQ? EF.MENU NIL)
|
||||
|
||||
(RPAQ? EF.TITLEMENU NIL)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD CHARITEM (BITMAP (CHARCODE DUMMYFLG)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(EF.INIT
|
||||
[LAMBDA NIL (* kbr%: "21-Oct-85 15:50")
|
||||
(PROG NIL
|
||||
[SETQ EF.MENU (create MENU
|
||||
ITEMS _ '((CHANGESIZE 'EF.CHANGESIZE "Change size of character.")
|
||||
(DELETE ''EF.DELETE "Delete character.")
|
||||
(EDITBM ''EF.EDITBM "Edit character.")
|
||||
(REPLACE ''EF.REPLACE
|
||||
"Prompt for bitmap to replace character."]
|
||||
(SETQ EF.TITLEMENU (create MENU
|
||||
ITEMS _ '((SAVE 'EF.SAVE "Save EDITFONT's work back into font."])
|
||||
[LAMBDA NIL (* ; "Edited 4-Aug-2025 13:16 by rmk")
|
||||
[SETQ EF.MENU (create MENU
|
||||
ITEMS _ '((CHANGESIZE 'EF.CHANGESIZE "Change size of character.")
|
||||
(DELETE 'EF.DELETE "Delete character.")
|
||||
(EDITBM 'EF.EDITBM "Edit character.")
|
||||
(REPLACE 'EF.REPLACE "Prompt for bitmap to replace character."]
|
||||
(SETQ EF.TITLEMENU (create MENU
|
||||
ITEMS _ '((SAVE 'EF.SAVE "Save EDITFONT's work back into font."])
|
||||
|
||||
(EF.PROMPT
|
||||
[LAMBDA (STRING WINDOW) (* kbr%: "16-Oct-85 22:48")
|
||||
@ -86,43 +84,17 @@
|
||||
(WINDOWPROP WINDOW 'MENU NIL])
|
||||
|
||||
(EF.CHARITEMS
|
||||
[LAMBDA (FONT FROMCHAR8CODE TOCHAR8CODE CHARSET) (* kbr%: "16-Oct-85 23:11")
|
||||
(* Get CHARITEMS for FONT.
|
||||
*)
|
||||
(PROG (FROMCHARCODE TOCHARCODE OFFSETS DUMMYOFFSET DUMMYBITMAP OFFSET BITMAP CHARITEM CHARITEMS)
|
||||
(* Get DUMMY CHARITEM *)
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 4-Aug-2025 00:14 by rmk")
|
||||
(* ; "Edited 25-Jul-2025 10:06 by rmk")
|
||||
(* kbr%: "16-Oct-85 23:11")
|
||||
|
||||
(* Interlisp assuming 256 is dummy is dumb now because of NS chars.
|
||||
Maybe Kaplan and Nuyens will fix. *)
|
||||
(* ;; "Get CHARITEMS for CHARSET in FONT. ")
|
||||
|
||||
(SETQ DUMMYBITMAP (GETCHARBITMAP 256 FONT))
|
||||
(SETQ CHARITEM (create CHARITEM
|
||||
BITMAP _ DUMMYBITMAP
|
||||
CHARCODE _ DUMMYINDEX
|
||||
DUMMYFLG _ T))
|
||||
(push CHARITEMS CHARITEM) (* Get ordinairy CHARITEMs.
|
||||
*)
|
||||
(SETQ FROMCHARCODE (IPLUS (ITIMES 256 CHARSET)
|
||||
FROMCHAR8CODE))
|
||||
(SETQ TOCHARCODE (IPLUS (ITIMES 256 CHARSET)
|
||||
TOCHAR8CODE))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of (\GETCHARSETINFO CHARSET FONT)))
|
||||
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX))
|
||||
(for I from TOCHARCODE to FROMCHARCODE by -1
|
||||
do (SETQ OFFSET (\FGETOFFSET OFFSETS I))
|
||||
[COND
|
||||
((EQ OFFSET DUMMYOFFSET)
|
||||
(SETQ CHARITEM (create CHARITEM
|
||||
BITMAP _ DUMMYBITMAP
|
||||
CHARCODE _ I
|
||||
DUMMYFLG _ T)))
|
||||
(T (SETQ BITMAP (GETCHARBITMAP I FONT))
|
||||
(SETQ CHARITEM (create CHARITEM
|
||||
BITMAP _ BITMAP
|
||||
CHARCODE _ I
|
||||
DUMMYFLG _ NIL]
|
||||
(push CHARITEMS CHARITEM)) (* OKEY DOKEY *)
|
||||
(RETURN CHARITEMS])
|
||||
(for C8 from 0 to \MAXTHINCHAR as C from (LLSH CHARSET 8)
|
||||
collect (create CHARITEM
|
||||
BITMAP _ (GETCHARBITMAP C FONT)
|
||||
CHARCODE _ C8
|
||||
SLUGCHARP _ (SLUGCHARP.DISPLAY C FONT])
|
||||
|
||||
(EF.BUTTONEVENTFN
|
||||
[LAMBDA (WINDOW) (* kbr%: "16-Oct-85 22:19")
|
||||
@ -145,32 +117,26 @@
|
||||
(* Do nothing. *)])
|
||||
|
||||
(EF.EDITBM
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
|
||||
(PROG (BITMAP CHARCODE DUMMYFLG)
|
||||
(RESETLST
|
||||
[RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE)
|
||||
`(SHADEITEM ,CHARITEM ,MENU ,WHITESHADE]
|
||||
(SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
|
||||
[COND
|
||||
((AND (NOT (IEQP (fetch (CHARITEM CHARCODE) of CHARITEM)
|
||||
DUMMYINDEX))
|
||||
(fetch (CHARITEM DUMMYFLG) of CHARITEM))
|
||||
(* Undummify this CHARITEM.
|
||||
*)
|
||||
(SETQ BITMAP (COPYALL BITMAP))
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with BITMAP)
|
||||
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))]
|
||||
(EDITBM BITMAP))
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 4-Aug-2025 09:11 by rmk")
|
||||
(* kbr%: "15-Dec-84 15:20")
|
||||
(LET ((SLUGCHARP (fetch (CHARITEM BITMAP) of CHARITEM))
|
||||
BITMAP)
|
||||
(RESETLST
|
||||
[RESETSAVE (SHADEITEM CHARITEM MENU BLACKSHADE)
|
||||
`(SHADEITEM ,CHARITEM ,MENU ,WHITESHADE]
|
||||
(SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
|
||||
(CL:WHEN SLUGCHARP (* ; "Unslug this CHARITEM ")
|
||||
(SETQ BITMAP (BITMAPCOPY BITMAP))
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with BITMAP)
|
||||
(replace (CHARITEM SLUGCHARP) of CHARITEM with NIL)))
|
||||
(EDITBM BITMAP))
|
||||
|
||||
(* Update MENU image. SHADEITEM's side effects above suffice if we only changed
|
||||
one menu item. (I.e. we edited an ordinairy CHARITEM.) *)
|
||||
(* ;; "Update MENU image. SHADEITEM's side effects above suffice if we only changed one menu item. (I.e. we edited an ordinary CHARITEM.) ")
|
||||
|
||||
(COND
|
||||
((IEQP (fetch (CHARITEM CHARCODE) of CHARITEM)
|
||||
DUMMYINDEX)
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU])
|
||||
(CL:WHEN SLUGCHARP
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU)))])
|
||||
|
||||
(EF.MIDDLEBUTTONFN
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
|
||||
@ -180,7 +146,8 @@
|
||||
(COMMAND (APPLY* COMMAND CHARITEM MENU])
|
||||
|
||||
(EF.CHANGESIZE
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "16-Oct-85 23:03")
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 3-Aug-2025 17:44 by rmk")
|
||||
(* kbr%: "16-Oct-85 23:03")
|
||||
(* Change height & width of CHARITEM's
|
||||
BITMAP *)
|
||||
(PROG (HEIGHT WIDTH NEWBITMAP WINDOW)
|
||||
@ -202,26 +169,30 @@
|
||||
NIL NIL NEWBITMAP)
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP)
|
||||
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
|
||||
(replace (CHARITEM SLUGCHARP) of CHARITEM with NIL))
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU])
|
||||
|
||||
(EF.DELETE
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
|
||||
(* Turn CHARITEM into dummy charitem.
|
||||
*)
|
||||
(PROG (WINDOW CHARITEMS DUMMYBITMAP)
|
||||
(SETQ WINDOW (WFROMMENU MENU))
|
||||
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
|
||||
[SETQ DUMMYBITMAP (fetch (CHARITEM BITMAP) of (CAR (LAST CHARITEMS]
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with DUMMYBITMAP)
|
||||
(replace (CHARITEM DUMMYFLG) of CHARITEM with T))
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU])
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 4-Aug-2025 13:14 by rmk")
|
||||
(* kbr%: "15-Dec-84 15:20")
|
||||
(* ;
|
||||
"Turn CHARITEM into a slug charitem.")
|
||||
(LET ((WINDOW (WFROMMENU MENU))
|
||||
SLUGBITMAP)
|
||||
[SETQ SLUGBITMAP (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\XGETCHARSETINFO (WINDOWPROP
|
||||
WINDOW
|
||||
'FONT)
|
||||
(WINDOWPROP WINDOW 'CHARSET]
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with SLUGBITMAP)
|
||||
(replace (CHARITEM SLUGCHARP) of CHARITEM with T))
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU])
|
||||
|
||||
(EF.ENTER
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "15-Dec-84 15:20")
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 3-Aug-2025 17:44 by rmk")
|
||||
(* kbr%: "15-Dec-84 15:20")
|
||||
(* Enter BITMAP of CHARITEM.
|
||||
*)
|
||||
(PROG (NEWBITMAP)
|
||||
@ -232,13 +203,14 @@
|
||||
((type? BITMAP NEWBITMAP)
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with NEWBITMAP)
|
||||
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
|
||||
(replace (CHARITEM SLUGCHARP) of CHARITEM with NIL))
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU)))
|
||||
(T (LISPERROR "ILLEGAL ARG" NEWBITMAP])
|
||||
|
||||
(EF.REPLACE
|
||||
[LAMBDA (CHARITEM MENU) (* kbr%: "16-Oct-85 23:04")
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 3-Aug-2025 17:44 by rmk")
|
||||
(* kbr%: "16-Oct-85 23:04")
|
||||
(* Replace BITMAP of CHARITEM.
|
||||
*)
|
||||
(PROG (BITMAP WINDOW)
|
||||
@ -250,279 +222,238 @@
|
||||
((type? BITMAP BITMAP)
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with BITMAP)
|
||||
(replace (CHARITEM DUMMYFLG) of CHARITEM with NIL))
|
||||
(replace (CHARITEM SLUGCHARP) of CHARITEM with NIL))
|
||||
(UPDATE/MENU/IMAGE MENU)
|
||||
(REDISPLAYW (WFROMMENU MENU)))
|
||||
(T (LISPERROR "ILLEGAL ARG" BITMAP])
|
||||
|
||||
(EF.SAVE
|
||||
[LAMBDA (WINDOW) (* kbr%: "21-Oct-85 15:39")
|
||||
(* Save EDITFONT changes to FONT.
|
||||
*)
|
||||
(PROG (CHARITEMS FONT CB CBWIDTH CBHEIGHT WIDTHS OFFSETS HEIGHT WIDTH DUMMYOFFSET OFFSET BITMAP
|
||||
FIRSTCHAR LASTCHAR CHARSET CSINFO)
|
||||
(SETQ CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
|
||||
(SETQ FONT (WINDOWPROP WINDOW 'FONT)) (* New allocations. *)
|
||||
(SETQ CBWIDTH 0)
|
||||
(SETQ CBHEIGHT 0)
|
||||
[for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS
|
||||
when (OR (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM))
|
||||
(IEQP I DUMMYINDEX)) do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
|
||||
(SETQ CBWIDTH (IPLUS CBWIDTH (fetch (BITMAP BITMAPWIDTH
|
||||
)
|
||||
of BITMAP)))
|
||||
(SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP
|
||||
BITMAPHEIGHT
|
||||
)
|
||||
of BITMAP]
|
||||
(SETQ CSINFO (create CHARSETINFO
|
||||
CHARSETASCENT _ (fetch (FONTDESCRIPTOR \SFAscent) of FONT)
|
||||
CHARSETDESCENT _ (fetch (FONTDESCRIPTOR \SFDescent) of FONT)))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(* Store new info in allocations.
|
||||
*)
|
||||
(SETQ OFFSET 0)
|
||||
[SETQ DUMMYOFFSET (IDIFFERENCE CBWIDTH (fetch (BITMAP BITMAPWIDTH)
|
||||
of (fetch (CHARITEM BITMAP)
|
||||
of (CAR (LAST CHARITEMS]
|
||||
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
|
||||
[for I from 0 to DUMMYINDEX as CHARITEM in CHARITEMS
|
||||
do (SETQ BITMAP (fetch (CHARITEM BITMAP) of CHARITEM))
|
||||
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
|
||||
(SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
|
||||
(\FSETWIDTH WIDTHS I WIDTH)
|
||||
(COND
|
||||
((AND (fetch (CHARITEM DUMMYFLG) of CHARITEM)
|
||||
(NOT (IEQP I DUMMYINDEX)))
|
||||
(\FSETOFFSET OFFSETS I DUMMYOFFSET))
|
||||
(T (\FSETOFFSET OFFSETS I OFFSET)
|
||||
(BITBLT BITMAP 0 0 CB OFFSET 0 WIDTH HEIGHT 'INPUT 'REPLACE)
|
||||
(SETQ OFFSET (IPLUS OFFSET WIDTH] (* FIRSTCHAR & LASTCHAR.
|
||||
(I wonder what you're suppose to do if
|
||||
there aren't any chars?) *)
|
||||
[SETQ FIRSTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE)
|
||||
of (for CHARITEM in CHARITEMS
|
||||
thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM]
|
||||
[SETQ LASTCHAR (\CHAR8CODE (fetch (CHARITEM CHARCODE)
|
||||
of (for CHARITEM in (REVERSE CHARITEMS)
|
||||
thereis (NOT (fetch (CHARITEM DUMMYFLG) of CHARITEM]
|
||||
[SETQ CHARSET (\CHARSET (fetch (CHARITEM CHARCODE) of (CAR CHARITEMS]
|
||||
(* Store new info. *)
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
|
||||
(replace (CHARSETINFO WIDTHS) of CSINFO with WIDTHS)
|
||||
(replace (CHARSETINFO OFFSETS) of CSINFO with OFFSETS)
|
||||
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with WIDTHS))
|
||||
(* OKEY DOKEY. *)
|
||||
])
|
||||
[LAMBDA (WINDOW) (* ; "Edited 4-Aug-2025 09:22 by rmk")
|
||||
(* ; "Edited 2-Aug-2025 08:47 by rmk")
|
||||
(* kbr%: "21-Oct-85 15:39")
|
||||
(* ; "Save EDITFONT changes to FONT. *")
|
||||
(LET ((FONT (WINDOWPROP WINDOW 'FONT))
|
||||
(CHARITEMS (WINDOWPROP WINDOW 'CHARITEMS))
|
||||
(CHARSET (WINDOWPROP WINDOW 'CHARSET))
|
||||
(CBWIDTH 0)
|
||||
(CBHEIGHT 0)
|
||||
CB WIDTHS OFFSETS HEIGHT WIDTH OFFSET CSINFO SLUGBM SLUGOFFSET SLUGWIDTH)
|
||||
(* ; "New allocations")
|
||||
|
||||
(EF.BLANK
|
||||
[LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
|
||||
(* kbr%: "21-Oct-85 15:25")
|
||||
(PROG (FONT CSINFO WIDTHS DUMMYWIDTH OFFSETS DUMMYOFFSET CB CBWIDTH CBHEIGHT)
|
||||
(SETQ FAMILY (U-CASE FAMILY))
|
||||
(COND
|
||||
((NOT (FIXP SIZE))
|
||||
(LISPERROR "ILLEGAL ARG" SIZE)))
|
||||
(SETQ FACE (\FONTFACE FACE))
|
||||
(COND
|
||||
((NOT (SMALLP FIRSTCHAR))
|
||||
(LISPERROR "ILLEGAL ARG" FIRSTCHAR)))
|
||||
(COND
|
||||
((NOT (SMALLP LASTCHAR))
|
||||
(LISPERROR "ILLEGAL ARG" LASTCHAR)))
|
||||
(COND
|
||||
((NOT (SMALLP ASCENT))
|
||||
(LISPERROR "ILLEGAL ARG" ASCENT)))
|
||||
(COND
|
||||
((NOT (SMALLP DESCENT))
|
||||
(LISPERROR "ILLEGAL ARG" DESCENT)))
|
||||
(COND
|
||||
([NOT (OR (FIXP WIDTH)
|
||||
(AND (LISTP WIDTH)
|
||||
[NOT (for W in WIDTH thereis (NOT (FIXP W]
|
||||
(IEQP (LENGTH WIDTH)
|
||||
(IPLUS LASTCHAR (IMINUS FIRSTCHAR)
|
||||
1 1]
|
||||
(LISPERROR "ILLEGAL ARG" WIDTH))) (* WIDTHS. *)
|
||||
(SETQ CSINFO (create CHARSETINFO
|
||||
CHARSETASCENT _ ASCENT
|
||||
CHARSETDESCENT _ DESCENT))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
[COND
|
||||
((LISTP WIDTH)
|
||||
(SETQ DUMMYWIDTH (CAR (LAST WIDTH)))
|
||||
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH))
|
||||
(for I from FIRSTCHAR to LASTCHAR as W in WIDTH do (\FSETWIDTH WIDTHS I W))
|
||||
(for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETWIDTH WIDTHS I DUMMYWIDTH)))
|
||||
(T (for I from 0 to DUMMYINDEX do (\FSETWIDTH WIDTHS I WIDTH]
|
||||
(* OFFSETS. *)
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
[for I from FIRSTCHAR to (ADD1 LASTCHAR) do (\FSETOFFSET OFFSETS (ADD1 I)
|
||||
(IPLUS (\FGETOFFSET OFFSETS I)
|
||||
(\FGETWIDTH WIDTHS I]
|
||||
(SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS (ADD1 LASTCHAR)))
|
||||
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETOFFSET OFFSETS I DUMMYOFFSET))
|
||||
(for I from (ADD1 LASTCHAR) to DUMMYINDEX do (\FSETOFFSET OFFSETS I DUMMYOFFSET))
|
||||
(* Characterbitmap CB.
|
||||
*)
|
||||
(SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
|
||||
(SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS DUMMYINDEX)
|
||||
(\FGETWIDTH WIDTHS DUMMYINDEX)))
|
||||
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
|
||||
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
|
||||
(* FONT. *)
|
||||
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
[SETQ FONT
|
||||
(create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'DISPLAY
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
ROTATION _ 0
|
||||
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
|
||||
(replace (FONTDESCRIPTOR \SFAscent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFAscent)
|
||||
of FONT)
|
||||
(fetch (CHARSETINFO CHARSETASCENT)
|
||||
of CSINFO)))
|
||||
(replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent)
|
||||
of FONT)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT)
|
||||
of CSINFO)))
|
||||
[replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFHeight)
|
||||
of FONT)
|
||||
(IPLUS (fetch (CHARSETINFO
|
||||
CHARSETASCENT)
|
||||
of CSINFO)
|
||||
(fetch (CHARSETINFO
|
||||
CHARSETDESCENT)
|
||||
of CSINFO]
|
||||
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
|
||||
0 CSINFO)
|
||||
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
|
||||
(RETURN FONT])
|
||||
(* ;; "Get the width of the new bitmap, including the slug")
|
||||
|
||||
[for CI BM in CHARITEMS unless (fetch (CHARITEM SLUGCHARP) of CI)
|
||||
do (SETQ BM (fetch (CHARITEM BITMAP) of CI))
|
||||
(SETQ CBWIDTH (IPLUS CBWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)))
|
||||
(SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM]
|
||||
|
||||
(* ;; "We'll install the slugbm at the end, include its dimensions")
|
||||
|
||||
(SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\XGETCHARSETINFO FONT CHARSET)))
|
||||
(SETQ SLUGWIDTH (fetch (BITMAP BITMAPWIDTH) of SLUGBM))
|
||||
(add CBWIDTH SLUGWIDTH)
|
||||
(SETQ CBHEIGHT (IMAX CBHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SLUGBM)))
|
||||
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
|
||||
(SETQ CSINFO (create CHARSETINFO copying (\XGETCHARSETINFO FONT CHARSET)
|
||||
CHARSETBITMAP _ CB))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))(* ; "Store new info in allocations")
|
||||
(SETQ OFFSET 0)
|
||||
|
||||
(* ;; "Copy all the character bitmaps into CB, setting their offsets and widths.")
|
||||
|
||||
(for CI BM C8 in CHARITEMS unless (fetch (CHARITEM SLUGCHARP) of CI)
|
||||
do (SETQ BM (fetch (CHARITEM BITMAP) of CI))
|
||||
(SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BM))
|
||||
(BITBLT BM 0 0 CB OFFSET 0 WIDTH (fetch (BITMAP BITMAPHEIGHT) of BM)
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(SETQ C8 (fetch (CHARITEM CHARCODE) of CI))
|
||||
(\FSETOFFSET OFFSETS C8 OFFSET)
|
||||
(\FSETWIDTH WIDTHS C8 WIDTH)
|
||||
(add OFFSET WIDTH))
|
||||
|
||||
(* ;; "OFFSET is now the SLUG offset")
|
||||
|
||||
(SETQ SLUGOFFSET OFFSET)
|
||||
(\FSETOFFSET OFFSETS SLUGCHARINDEX SLUGOFFSET)
|
||||
(\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
|
||||
(IPLUS SLUGOFFSET SLUGWIDTH))
|
||||
(BITBLT SLUGBM 0 0 CB SLUGOFFSET 0 SLUGWIDTH (fetch (BITMAP BITMAPHEIGHT) of SLUGBM)
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(for CI in CHARITEMS when (fetch (CHARITEM SLUGCHARP) of CI)
|
||||
do (\FSETOFFSET OFFSETS (fetch (CHARITEM CHARCODE) of CI)
|
||||
SLUGOFFSET)
|
||||
(\FSETOFFSET WIDTHS (fetch (CHARITEM CHARCODE) of CI)
|
||||
SLUGWIDTH)) (* ; "Store new info")
|
||||
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
|
||||
(replace (CHARSETINFO WIDTHS) of CSINFO with WIDTHS)
|
||||
(replace (CHARSETINFO OFFSETS) of CSINFO with OFFSETS)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with WIDTHS)
|
||||
|
||||
(* ;; "Can this editing change the descent or ascent?")
|
||||
|
||||
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
|
||||
CHARSET CSINFO])
|
||||
|
||||
(COPYFONT
|
||||
[LAMBDA (FONT) (* jds "26-Aug-86 16:01")
|
||||
(PROG (NEWFONT NEWCHARSETVECTOR OLDCHARSETVECTOR NEWCSINFO OLDCSINFO)
|
||||
(SETQ NEWFONT (create FONTDESCRIPTOR using FONT))
|
||||
(SETQ NEWCHARSETVECTOR (\ALLOCBLOCK (ADD1 \MAXCHARSET)
|
||||
T))
|
||||
(SETQ OLDCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT))
|
||||
[for CHARSET from 0 to \MAXCHARSET
|
||||
do (SETQ OLDCSINFO (\GETBASEPTR OLDCHARSETVECTOR (UNFOLD CHARSET 2)))
|
||||
(COND
|
||||
(OLDCSINFO [SETQ NEWCSINFO (create CHARSETINFO
|
||||
CHARSETASCENT _ (fetch (CHARSETINFO
|
||||
CHARSETASCENT)
|
||||
of OLDCSINFO)
|
||||
CHARSETDESCENT _ (fetch (CHARSETINFO
|
||||
CHARSETDESCENT)
|
||||
of OLDCSINFO)
|
||||
CHARSETBITMAP _ (COPYALL (fetch (CHARSETINFO
|
||||
CHARSETBITMAP)
|
||||
of OLDCSINFO]
|
||||
(\BLT (fetch (CHARSETINFO WIDTHS) of NEWCSINFO)
|
||||
(fetch (CHARSETINFO WIDTHS) of OLDCSINFO)
|
||||
(ADD1 DUMMYINDEX))
|
||||
(\BLT (fetch (CHARSETINFO OFFSETS) of NEWCSINFO)
|
||||
(fetch (CHARSETINFO OFFSETS) of OLDCSINFO)
|
||||
(ADD1 DUMMYINDEX))
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of NEWCSINFO with (fetch (CHARSETINFO
|
||||
WIDTHS)
|
||||
of NEWCSINFO))
|
||||
(\RPLPTR NEWCHARSETVECTOR (UNFOLD CHARSET 2)
|
||||
NEWCSINFO]
|
||||
(RETURN NEWFONT])
|
||||
[LAMBDA (FONT) (* ; "Edited 3-Aug-2025 17:37 by rmk")
|
||||
(* jds "26-Aug-86 16:01")
|
||||
(create FONTDESCRIPTOR copying (FONTCREATE FONT])
|
||||
|
||||
(READSTRIKEFONTFILE
|
||||
[LAMBDA (FAMILY SIZE FACE FILE FONT CHARSET)
|
||||
|
||||
(* ;; "Edited 12-Jul-2022 14:16 by rmk: Removed slightlly different implementations of \READSTRIKEFONTFILE and charset installation in favor of common code in FONT.")
|
||||
(* ;; "Edited 4-Aug-2025 13:33 by rmk")
|
||||
|
||||
(* ;; "Edited 12-Jul-2022 13:33 by rmk")
|
||||
(* kbr%: "14-Oct-85 11:16")
|
||||
(CL:UNLESS CHARSET (SETQ CHARSET 0)) (* ; "Returns fontdescriptor FONT. *")
|
||||
(LET (STRM CSINFO)
|
||||
(SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD))
|
||||
(\WIN STRM)
|
||||
(SETQ CSINFO (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE))
|
||||
(CLOSEF STRM) (* ;
|
||||
"This part imitates \CREATEDISPLAYFONT *")
|
||||
(CL:UNLESS FONT
|
||||
[SETQ FONT
|
||||
(create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'DISPLAY
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
ROTATION _ 0
|
||||
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY])
|
||||
(\INSTALLCHARSETINFO FONT CSINFO CHARSET)
|
||||
FONT])
|
||||
(HELP "USE MEDLEYFONT.READ.FONT")
|
||||
|
||||
(* ;; "Why specialize to strike fonts? This is a throwaway.")
|
||||
|
||||
(FONTCREATE FAMILY SIZE FACE FILE FONT CHARSET])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(BLANKFONTCREATE
|
||||
[LAMBDA (FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
|
||||
(BLANKCHARSETCREATE
|
||||
[LAMBDA (FAMILY SIZE FACE CHARSET FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
|
||||
(* ; "Edited 4-Aug-2025 13:29 by rmk")
|
||||
(* mjs "27-Mar-85 14:48")
|
||||
(EF.BLANK FAMILY SIZE FACE FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH])
|
||||
(* ; "Edited 3-Aug-2025 17:53 by rmk")
|
||||
|
||||
(* ;; "Adds CHARSET to an existing or created font, if not already there")
|
||||
|
||||
(CL:UNLESS CHARSET (SETQ CHARSET 0))
|
||||
(CL:UNLESS FIRSTCHAR (SETQ FIRSTCHAR 0))
|
||||
(CL:UNLESS LASTCHAR (SETQ LASTCHAR \MAXTHINCHAR))
|
||||
(CL:UNLESS (<= 0 FIRSTCHAR LASTCHAR \MAXTHINCHAR)
|
||||
(ERROR "ILLEGAL ARGS" (LIST FIRSTCHAR LASTCHAR)))
|
||||
(CL:UNLESS (SMALLP ASCENT)
|
||||
(LISPERROR "ILLEGAL ARG" ASCENT))
|
||||
(CL:UNLESS (SMALLP DESCENT)
|
||||
(LISPERROR "ILLEGAL ARG" DESCENT))
|
||||
(PROG (ROTATION DEVICE FONT CSINFO SLUGWIDTH OFFSETS WIDTHS SLUGOFFSET CB CBWIDTH CBHEIGHT)
|
||||
(SETQ FONT (\FONT.CHECKARGS FAMILY SIZE FACE 0 'DISPLAY CHARSET))
|
||||
[if (type? FONTDESCRIPTOR FONT)
|
||||
then (CL:WHEN (SETQ CSINFO (\XGETCHARSETINFO FONT CHARSET))
|
||||
(RETURN FONT))
|
||||
else (SPREADFONTSPEC FONT)
|
||||
(SETQ FONT
|
||||
(create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'DISPLAY
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
\SFHeight _ 0
|
||||
ROTATION _ 0
|
||||
FONTDEVICESPEC _ (LIST FAMILY SIZE FACE 0 'DISPLAY]
|
||||
(if (NULL WIDTH)
|
||||
then (SETQ WIDTH (FIXR (FTIMES SIZE 0.6)))
|
||||
elseif [AND (for W inside WIDTH always (FIXP W))
|
||||
(EQ (LENGTH WIDTH)
|
||||
(ADD1 (IDIFFERENCE (ADD1 LASTCHAR)
|
||||
FIRSTCHAR]
|
||||
else
|
||||
(* ;; "The outer ADD1 is for the slug width")
|
||||
|
||||
(LISPERROR "ILLEGAL ARG" WIDTH)) (* ; "WIDTHS")
|
||||
(SETQ CSINFO (create CHARSETINFO
|
||||
CHARSETASCENT _ ASCENT
|
||||
CHARSETDESCENT _ DESCENT))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(if (LISTP WIDTH)
|
||||
then (SETQ SLUGWIDTH (CAR (LAST WIDTH))) (* ; "Last is slugchar width")
|
||||
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETWIDTH WIDTHS I SLUGWIDTH))
|
||||
(for I from FIRSTCHAR to LASTCHAR as W in WIDTH do (\FSETWIDTH WIDTHS I W))
|
||||
(for I from (ADD1 LASTCHAR) to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I SLUGWIDTH))
|
||||
else (SETQ SLUGWIDTH WIDTH)
|
||||
(for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)))
|
||||
(* ; "OFFSETS")
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
[for I from FIRSTCHAR to (ADD1 LASTCHAR) do (\FSETOFFSET OFFSETS (ADD1 I)
|
||||
(IPLUS (\FGETOFFSET OFFSETS I)
|
||||
(\FGETWIDTH WIDTHS I]
|
||||
(\FSETWIDTH WIDTHS SLUGCHARINDEX SLUGWIDTH)
|
||||
(SETQ SLUGOFFSET (IPLUS (\FGETOFFSET OFFSETS LASTCHAR)
|
||||
(\FGETWIDTH WIDTHS LASTCHAR)))
|
||||
(\FSETOFFSET OFFSETS SLUGCHARINDEX SLUGOFFSET)
|
||||
(\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
|
||||
(IPLUS SLUGOFFSET SLUGWIDTH))
|
||||
(for I from 0 to (SUB1 FIRSTCHAR) do (\FSETOFFSET OFFSETS I SLUGOFFSET))
|
||||
(for I from (ADD1 LASTCHAR) to SLUGCHARINDEX do (\FSETOFFSET OFFSETS I SLUGOFFSET))
|
||||
(SETQ ASCENT (IMAX (OR (fetch (FONTDESCRIPTOR \SFDescent) of FONT)
|
||||
0)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
|
||||
(SETQ DESCENT (IMAX (OR (fetch (FONTDESCRIPTOR \SFDescent) of FONT)
|
||||
0)
|
||||
(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)))
|
||||
(* ; "Characterbitmap CB")
|
||||
(SETQ CBHEIGHT (IPLUS ASCENT DESCENT))
|
||||
(SETQ CBWIDTH (IPLUS (\FGETOFFSET OFFSETS SLUGCHARINDEX)
|
||||
(\FGETWIDTH WIDTHS SLUGCHARINDEX)))
|
||||
(SETQ CB (BITMAPCREATE CBWIDTH CBHEIGHT))
|
||||
(BLTSHADE BLACKSHADE CB SLUGOFFSET 0 SLUGWIDTH (fetch (BITMAP BITMAPHEIGHT) of CB)
|
||||
'REPLACE)
|
||||
(replace (CHARSETINFO CHARSETBITMAP) of CSINFO with CB)
|
||||
(* ; "FONT")
|
||||
(\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR)
|
||||
(replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))
|
||||
(replace (FONTDESCRIPTOR \SFAscent) of FONT with ASCENT)
|
||||
(replace (FONTDESCRIPTOR \SFDescent) of FONT with DESCENT)
|
||||
(replace (FONTDESCRIPTOR \SFHeight) of FONT with (IMAX (OR (fetch (FONTDESCRIPTOR \SFHeight
|
||||
) of FONT)
|
||||
0)
|
||||
CBHEIGHT))
|
||||
(\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)
|
||||
CHARSET CSINFO)
|
||||
(replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))
|
||||
(RETURN FONT])
|
||||
|
||||
(EDITFONT
|
||||
[LAMBDA (FONT FROMCHARCODE TOCHARCODE CHARSET) (* ; "Edited 27-Jun-2022 10:47 by rmk")
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 3-Aug-2025 23:25 by rmk")
|
||||
(* ; "Edited 2-Aug-2025 10:11 by rmk")
|
||||
(* mjs "27-Mar-85 14:48")
|
||||
(* kbr%: "21-Oct-85 15:35")
|
||||
(* kbr%: "21-Oct-85 15:35")
|
||||
(SETQ FONT (FONTCREATE FONT))
|
||||
(CL:UNLESS FROMCHARCODE (SETQ FROMCHARCODE 0))
|
||||
(CL:UNLESS TOCHARCODE (SETQ TOCHARCODE 255))
|
||||
(CL:UNLESS CHARSET (SETQ CHARSET 0))
|
||||
(PROG (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
|
||||
(SETQ CHARITEMS (EF.CHARITEMS FONT FROMCHARCODE TOCHARCODE CHARSET))
|
||||
(SETQ MENU
|
||||
(create MENU
|
||||
MENUFONT _ FONT
|
||||
CENTERFLG _ T
|
||||
MENUCOLUMNS _ 16
|
||||
ITEMS _ CHARITEMS
|
||||
WHENSELECTEDFN _ (FUNCTION EF.WHENSELECTEDFN)))
|
||||
[SETQ TITLE (PACK* (FONTPROP FONT 'FAMILY)
|
||||
(FONTPROP FONT 'SIZE)
|
||||
(PACKC (for ATOM in (FONTPROP FONT 'FACE) collect (CHCON1 ATOM]
|
||||
(SETQ HEIGHT (HEIGHTIFWINDOW (fetch (MENU IMAGEHEIGHT) of MENU)
|
||||
T))
|
||||
(SETQ WIDTH (WIDTHIFWINDOW (fetch (MENU IMAGEWIDTH) of MENU)))
|
||||
(SETQ POS (GETBOXPOSITION WIDTH HEIGHT))
|
||||
(SETQ REGION (create REGION
|
||||
LEFT _ (fetch (POSITION XCOORD) of POS)
|
||||
BOTTOM _ (fetch (POSITION YCOORD) of POS)
|
||||
WIDTH _ WIDTH
|
||||
HEIGHT _ HEIGHT))
|
||||
(SETQ WINDOW (CREATEW REGION TITLE))
|
||||
(WINDOWPROP WINDOW 'CHARITEMS CHARITEMS)
|
||||
(ADDMENU MENU WINDOW (create POSITION
|
||||
XCOORD _ 0
|
||||
YCOORD _ 0))
|
||||
(WINDOWPROP WINDOW 'BUTTONEVENTFN 'EF.BUTTONEVENTFN])
|
||||
(LET (CHARITEMS MENU TITLE HEIGHT WIDTH REGION POS WINDOW)
|
||||
(SETQ CHARITEMS (EF.CHARITEMS FONT CHARSET))
|
||||
(SETQ MENU (create MENU
|
||||
MENUFONT _ FONT
|
||||
CENTERFLG _ T
|
||||
MENUCOLUMNS _ 16
|
||||
ITEMS _ CHARITEMS
|
||||
WHENSELECTEDFN _ (FUNCTION EF.WHENSELECTEDFN)))
|
||||
[SETQ TITLE (PACK* (FONTPROP FONT 'FAMILY)
|
||||
(FONTPROP FONT 'SIZE)
|
||||
(PACKC (for ATOM in (FONTPROP FONT 'FACE) collect (CHCON1 ATOM]
|
||||
(SETQ HEIGHT (HEIGHTIFWINDOW (fetch (MENU IMAGEHEIGHT) of MENU)
|
||||
T))
|
||||
(SETQ WIDTH (WIDTHIFWINDOW (fetch (MENU IMAGEWIDTH) of MENU)))
|
||||
(SETQ POS (GETBOXPOSITION WIDTH HEIGHT))
|
||||
(SETQ REGION (create REGION
|
||||
LEFT _ (fetch (POSITION XCOORD) of POS)
|
||||
BOTTOM _ (fetch (POSITION YCOORD) of POS)
|
||||
WIDTH _ WIDTH
|
||||
HEIGHT _ HEIGHT))
|
||||
(SETQ WINDOW (CREATEW REGION TITLE))
|
||||
(WINDOWPROP WINDOW 'CHARITEMS CHARITEMS)
|
||||
(WINDOWPROP WINDOW 'FONT FONT)
|
||||
(WINDOWPROP WINDOW 'CHARSET CHARSET)
|
||||
(ADDMENU MENU WINDOW (create POSITION
|
||||
XCOORD _ 0
|
||||
YCOORD _ 0))
|
||||
(WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION EF.BUTTONEVENTFN))
|
||||
(MODERNWINDOW WINDOW)
|
||||
WINDOW])
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ BITSPERWORD 16)
|
||||
|
||||
(RPAQQ BYTESPERWORD 2)
|
||||
|
||||
|
||||
(CONSTANTS (BITSPERWORD 16)
|
||||
(BYTESPERWORD 2))
|
||||
(RECORD CHARITEM (BITMAP CHARCODE SLUGCHARP))
|
||||
)
|
||||
|
||||
|
||||
@ -532,10 +463,10 @@
|
||||
|
||||
(EF.INIT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1325 25875 (EF.INIT 1335 . 2061) (EF.PROMPT 2063 . 2645) (EF.MESSAGE 2647 . 2859) (
|
||||
EF.CLOSEFN 2861 . 3388) (EF.CHARITEMS 3390 . 5611) (EF.BUTTONEVENTFN 5613 . 6025) (EF.WHENSELECTEDFN
|
||||
6027 . 6431) (EF.EDITBM 6433 . 7831) (EF.MIDDLEBUTTONFN 7833 . 8078) (EF.CHANGESIZE 8080 . 9299) (
|
||||
EF.DELETE 9301 . 10066) (EF.ENTER 10068 . 10899) (EF.REPLACE 10901 . 11764) (EF.SAVE 11766 . 16439) (
|
||||
EF.BLANK 16441 . 22066) (COPYFONT 22068 . 24508) (READSTRIKEFONTFILE 24510 . 25873)) (25876 28090 (
|
||||
BLANKFONTCREATE 25886 . 26143) (EDITFONT 26145 . 28088)))))
|
||||
(FILEMAP (NIL (1402 15256 (EF.INIT 1412 . 2046) (EF.PROMPT 2048 . 2630) (EF.MESSAGE 2632 . 2844) (
|
||||
EF.CLOSEFN 2846 . 3373) (EF.CHARITEMS 3375 . 4033) (EF.BUTTONEVENTFN 4035 . 4447) (EF.WHENSELECTEDFN
|
||||
4449 . 4853) (EF.EDITBM 4855 . 6024) (EF.MIDDLEBUTTONFN 6026 . 6271) (EF.CHANGESIZE 6273 . 7602) (
|
||||
EF.DELETE 7604 . 8679) (EF.ENTER 8681 . 9622) (EF.REPLACE 9624 . 10597) (EF.SAVE 10599 . 14548) (
|
||||
COPYFONT 14550 . 14825) (READSTRIKEFONTFILE 14827 . 15254)) (15257 23426 (BLANKCHARSETCREATE 15267 .
|
||||
21244) (EDITFONT 21246 . 23424)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user