EDITFONT uses FONTFACE subfunction
This commit is contained in:
rmkaplan
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "29-Aug-2025 22:34:31" {WMEDLEY}<lispusers>EDITFONT.;33 24939
|
||||
(FILECREATED " 4-Sep-2025 10:30:31" {WMEDLEY}<lispusers>EDITFONT.;35 25299
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS EDITFONT EF.EDITBM EF.CHARITEMS EF.SAVE)
|
||||
:CHANGES-TO (FNS EDITFONT)
|
||||
|
||||
:PREVIOUS-DATE "27-Aug-2025 22:50:51" {WMEDLEY}<lispusers>EDITFONT.;30)
|
||||
:PREVIOUS-DATE " 2-Sep-2025 23:03:37" {WMEDLEY}<lispusers>EDITFONT.;34)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EDITFONTCOMS)
|
||||
@@ -179,15 +179,16 @@
|
||||
(REDISPLAYW (WFROMMENU MENU])
|
||||
|
||||
(EF.DELETE
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 4-Aug-2025 13:14 by rmk")
|
||||
[LAMBDA (CHARITEM MENU) (* ; "Edited 2-Sep-2025 23:03 by rmk")
|
||||
(* ; "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)
|
||||
[SETQ SLUGBITMAP (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO (WINDOWPROP
|
||||
WINDOW
|
||||
'FONT)
|
||||
(WINDOWPROP WINDOW 'CHARSET]
|
||||
(UNINTERRUPTABLY
|
||||
(replace (CHARITEM BITMAP) of CHARITEM with SLUGBITMAP)
|
||||
@@ -233,7 +234,8 @@
|
||||
(T (LISPERROR "ILLEGAL ARG" BITMAP])
|
||||
|
||||
(EF.SAVE
|
||||
[LAMBDA (WINDOW) (* ; "Edited 29-Aug-2025 11:35 by rmk")
|
||||
[LAMBDA (WINDOW) (* ; "Edited 2-Sep-2025 23:03 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 11:35 by rmk")
|
||||
(* ; "Edited 4-Aug-2025 09:22 by rmk")
|
||||
(* ; "Edited 2-Aug-2025 08:47 by rmk")
|
||||
(* kbr%: "21-Oct-85 15:39")
|
||||
@@ -255,12 +257,12 @@
|
||||
|
||||
(* ;; "We'll install the slugbm at the end, include its dimensions")
|
||||
|
||||
(SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\XGETCHARSETINFO FONT CHARSET)))
|
||||
(SETQ SLUGBM (\GETCHARBITMAP.CSINFO SLUGCHARINDEX (\GETCHARSETINFO 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)
|
||||
(SETQ CSINFO (create CHARSETINFO copying (\GETCHARSETINFO FONT CHARSET)
|
||||
CHARSETBITMAP _ CB))
|
||||
(SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO))
|
||||
(SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO))(* ; "Store new info in allocations")
|
||||
@@ -325,6 +327,7 @@
|
||||
|
||||
(BLANKCHARSETCREATE
|
||||
[LAMBDA (FAMILY SIZE FACE CHARSET FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTH)
|
||||
(* ; "Edited 2-Sep-2025 23:03 by rmk")
|
||||
(* ; "Edited 4-Aug-2025 13:29 by rmk")
|
||||
(* mjs "27-Mar-85 14:48")
|
||||
(* ; "Edited 3-Aug-2025 17:53 by rmk")
|
||||
@@ -343,7 +346,7 @@
|
||||
(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))
|
||||
then (CL:WHEN (SETQ CSINFO (\GETCHARSETINFO FONT CHARSET))
|
||||
(RETURN FONT))
|
||||
else (SPREADFONTSPEC FONT)
|
||||
(SETQ FONT
|
||||
@@ -418,7 +421,8 @@
|
||||
(RETURN FONT])
|
||||
|
||||
(EDITFONT
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 29-Aug-2025 22:34 by rmk")
|
||||
[LAMBDA (FONT CHARSET) (* ; "Edited 4-Sep-2025 09:27 by rmk")
|
||||
(* ; "Edited 29-Aug-2025 22:34 by rmk")
|
||||
(* ; "Edited 17-Aug-2025 12:03 by rmk")
|
||||
(* ; "Edited 3-Aug-2025 23:25 by rmk")
|
||||
(* ; "Edited 2-Aug-2025 10:11 by rmk")
|
||||
@@ -440,7 +444,7 @@
|
||||
" "
|
||||
(FONTPROP FONT 'SIZE)
|
||||
" "
|
||||
(PACKC (for ATOM in (FONTPROP FONT 'FACE) collect (CHCON1 ATOM)))
|
||||
(FONTFACETOATOM (FONTPROP FONT 'FACE))
|
||||
" "
|
||||
(OCTALSTRING CHARSET)))
|
||||
(PUTMENUPROP MENU 'EDITFONTTITLE TITLE)
|
||||
@@ -477,10 +481,10 @@
|
||||
|
||||
(EF.INIT)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1141 16132 (EF.INIT 1151 . 1785) (EF.PROMPT 1787 . 2369) (EF.MESSAGE 2371 . 2583) (
|
||||
EF.CLOSEFN 2585 . 3112) (EF.CHARITEMS 3114 . 4436) (EF.BUTTONEVENTFN 4438 . 4850) (EF.WHENSELECTEDFN
|
||||
4852 . 5256) (EF.EDITBM 5258 . 6752) (EF.MIDDLEBUTTONFN 6754 . 6999) (EF.CHANGESIZE 7001 . 8330) (
|
||||
EF.DELETE 8332 . 9407) (EF.ENTER 9409 . 10350) (EF.REPLACE 10352 . 11325) (EF.SAVE 11327 . 15424) (
|
||||
COPYFONT 15426 . 15701) (READSTRIKEFONTFILE 15703 . 16130)) (16133 24751 (BLANKCHARSETCREATE 16143 .
|
||||
22120) (EDITFONT 22122 . 24749)))))
|
||||
(FILEMAP (NIL (1110 16314 (EF.INIT 1120 . 1754) (EF.PROMPT 1756 . 2338) (EF.MESSAGE 2340 . 2552) (
|
||||
EF.CLOSEFN 2554 . 3081) (EF.CHARITEMS 3083 . 4405) (EF.BUTTONEVENTFN 4407 . 4819) (EF.WHENSELECTEDFN
|
||||
4821 . 5225) (EF.EDITBM 5227 . 6721) (EF.MIDDLEBUTTONFN 6723 . 6968) (EF.CHANGESIZE 6970 . 8299) (
|
||||
EF.DELETE 8301 . 9482) (EF.ENTER 9484 . 10425) (EF.REPLACE 10427 . 11400) (EF.SAVE 11402 . 15606) (
|
||||
COPYFONT 15608 . 15883) (READSTRIKEFONTFILE 15885 . 16312)) (16315 25111 (BLANKCHARSETCREATE 16325 .
|
||||
22410) (EDITFONT 22412 . 25109)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user