(FILECREATED "25-Jul-84 02:16:59" {ERIS}<LISPCORE>LIBRARY>GETFONT.;1 10346
changes to: (FNS GETFONT GETFONT.WHENSELECTEDFN)
(VARS GETFONTCOMS)
previous date: "24-Jul-84 03:57:27" {ERIS}<NUYENS>GETFONT.;14)
(* Copyright (c) by NIL. All rights reserved.)
(PRETTYCOMPRINT GETFONTCOMS)
(RPAQQ GETFONTCOMS ([INITVARS \GETFONT.MENU (DEFAULTFACE (QUOTE (MEDIUM REGULAR REGULAR)))
(\GETFONT.SIZELIST (QUOTE (3 4 5 6 8 10 12 14 18 24 36)))
(GETFONT.FACE.SUBITEMS (QUOTE (SUBITEMS (Standard (LIST NESTEDITEMS
(QUOTE STANDARD)
)
"chooses a standard font face")
(Italic (LIST NESTEDITEMS
(QUOTE ITALIC))
"chooses an italic font face")
(Bold (LIST NESTEDITEMS
(QUOTE BOLD))
"chooses a bold font face")
(Bold% Italic
(LIST NESTEDITEMS
(QUOTE BOLDITALIC))
"chooses a bold and italic font face"]
(FNS GETFONT GETFONT.DESCFROMFACEENTRY GETFONT.FACE.ITEM GETFONT.FACENAME
GETFONT.ITEMBITMAP GETFONT.SIZESORTFN GETFONT.SIZESORTFNAUX
GETFONT.WHENSELECTEDFN GETFONT.FAMILY.ITEM GETFONT.DESCFROMSIZEENTRY
GETFONT.RATE.FACE GETFONT.SIZE.ITEM)))
(RPAQ? \GETFONT.MENU NIL)
(RPAQ? DEFAULTFACE (QUOTE (MEDIUM REGULAR REGULAR)))
(RPAQ? \GETFONT.SIZELIST (QUOTE (3 4 5 6 8 10 12 14 18 24 36)))
(RPAQ? GETFONT.FACE.SUBITEMS (QUOTE (SUBITEMS (Standard (LIST NESTEDITEMS (QUOTE STANDARD))
"chooses a standard font face")
(Italic (LIST NESTEDITEMS (QUOTE ITALIC))
"chooses an italic font face")
(Bold (LIST NESTEDITEMS (QUOTE BOLD))
"chooses a bold font face")
(Bold% Italic (LIST NESTEDITEMS (QUOTE BOLDITALIC))
"chooses a bold and italic font face"))))
(DEFINEQ
(GETFONT
[LAMBDA (DEFAULTSIZE) (* gbn "25-Jul-84 01:31")
(* if \GETFONT.MENU has a non-nil value, uses that menu
to return a font-descriptor. Otherwise, computes a new
menu and uses it)
(PROG [RESULT NESTEDITEMS (GETFONTMENU (if \GETFONT.MENU
then \GETFONT.MENU
else (SETQ \GETFONT.MENU
(create MENU
ITEMS ←(for FAMILY in \FONTSINCORE
collect (GETFONT.FAMILY.ITEM
FAMILY
(OR DEFAULTSIZE 10)))
CENTERFLG ← T
TITLE ← "Fonts"
WHENSELECTEDFN ←(QUOTE
GETFONT.WHENSELECTEDFN]
(SETQ RESULT (MENU GETFONTMENU))
(SETQ NESTEDITEMS (CAR RESULT))
(RETURN (APPEND (REVERSE (bind UNEVALEDVALUE for ITEM in NESTEDITEMS
when (SETQ UNEVALEDVALUE (CADDR (CADR ITEM)))
collect (CADR UNEVALEDVALUE)))
(CDR RESULT])
(GETFONT.DESCFROMFACEENTRY
[LAMBDA (FACEENTRY) (* gbn "17-Jul-84 23:38")
(* takes a faceentry {looks like
((MEDIUM REGULAR REGULAR) (0
(DISPLAY . desc))) } and returns the desc)
(CDR (ASSOC (QUOTE DISPLAY)
(CDR (ASSOC 0 (CDR FACEENTRY])
(GETFONT.FACE.ITEM
[LAMBDA (FACEENTRY FAMILY SIZE) (* gbn "24-Jul-84 02:29")
(* returns an item with Family+size+face)
(PROG ((DESC (GETFONT.DESCFROMFACEENTRY FACEENTRY)))
(RETURN (LIST (GETFONT.ITEMBITMAP T DESC FAMILY SIZE (GETFONT.FACENAME (CAR FACEENTRY)))
(BQUOTE (LIST NESTEDITEMS (QUOTE , (CAR FACEENTRY])
(GETFONT.FACENAME
[LAMBDA (FACETRIPLE) (* gbn "17-Jul-84 22:37")
(* given a triple like (BOLD ITALIC REGULAR) returns a
single atom ItalicBold)
(COND
[(EQ (CAR FACETRIPLE)
(QUOTE BOLD))
(COND
((EQ (CADR FACETRIPLE)
(QUOTE ITALIC))
(QUOTE Bold% Italic))
(T (QUOTE Bold]
(T (COND
((EQ (CADR FACETRIPLE)
(QUOTE ITALIC))
(QUOTE Italic))
(T (QUOTE Regular])
(GETFONT.ITEMBITMAP
[LAMBDA (EXACT? DESC FAMILY SIZE FACE) (* gbn "17-Jul-84 23:57")
(* produces the bitmap for the item, size and face
default to "")
(PROG (ITEM BITMAP STREAM (EXACT? EXACT?)
(DESC DESC))
(if (NOT DESC)
then (* there is no fontdesc for display or we would have
gotten it. Use menufont and de-exact it)
(SETQ EXACT? NIL)
(SETQ DESC MENUFONT))
(SETQ ITEM (L-CASE (CONCAT (if EXACT?
then " "
else "~ ")
(COND
((AND SIZE FACE)
(CONCAT FAMILY " " SIZE " " FACE))
(SIZE (CONCAT FAMILY " " SIZE))
(T FAMILY)))
T))
[SETQ BITMAP (BITMAPCREATE (STRINGWIDTH ITEM DESC)
(FONTPROP DESC (QUOTE SIZE]
(SETQ STREAM (DSPCREATE BITMAP))
(DSPFONT DESC STREAM)
(DSPYPOSITION (SUB1 (FONTPROP DESC (QUOTE DESCENT)))
STREAM)
(PRIN1 ITEM STREAM)
(RETURN BITMAP])
(GETFONT.SIZESORTFN
[LAMBDA (ITEM1 ITEM2) (* gbn "18-Jul-84 00:24")
(ILESSP (GETFONT.SIZESORTFNAUX ITEM1)
(GETFONT.SIZESORTFNAUX ITEM2])
(GETFONT.SIZESORTFNAUX
[LAMBDA (ITEM) (* gbn "18-Jul-84 00:20")
(PROG ((FONT? (CADR ITEM)))
(RETURN (if (TYPENAMEP FONT? (QUOTE FONTDESCRIPTOR))
then (FONTPROP FONT? (QUOTE SIZE))
else (CADR (CADDR (CADR ITEM])
(GETFONT.WHENSELECTEDFN
[LAMBDA (ITEM FROMMENU BUTTON NESTEDITEMS) (* gbn "25-Jul-84 01:29")
(* * comment)
(COND
((AND (LISTP ITEM)
(LISTP (CDR ITEM)))
(EVAL (CADR ITEM)))
(T ITEM])
(GETFONT.FAMILY.ITEM
[LAMBDA (FAMILYENTRY DEFAULTSIZE) (* gbn "24-Jul-84 03:50")
(* creates an item suitable for the item list in a menu create. Looks like FAMILY written in the incore size
closest to DEFAULTSIZE and the "simplest" incore face present in that size)
(PROG ((FAMILY (CAR FAMILYENTRY))
(FAMILYENTRY (CDR FAMILYENTRY))
SIZE FACE ENTRY DESC EXACT? VALUE SUBITEMS SIZESINCORE)
(SETQ ENTRY (ASSOC DEFAULTSIZE FAMILYENTRY))
(if (AND ENTRY (SETQ DESC (GETFONT.DESCFROMSIZEENTRY ENTRY)))
then (* the font is present in the default face, use it ,)
(SETQ EXACT? T)
else (* otherwise display the item in menufont,)
(SETQ DESC MENUFONT)) (* make the value the family)
[SETQ VALUE (BQUOTE (LIST NESTEDITEMS (QUOTE , FAMILY]
(SETQ SUBITEMS (SORT (for SIZEENTRY in FAMILYENTRY
collect (push SIZESINCORE (CAR SIZEENTRY))
(GETFONT.SIZE.ITEM SIZEENTRY FAMILY))
(QUOTE GETFONT.SIZESORTFN)))
[SETQ SUBITEMS (APPEND SUBITEMS
(LIST (LIST (QUOTE Other% Sizes)
(BQUOTE (LIST NESTEDITEMS NIL))
"Allows specification of font size"
(CONS (QUOTE SUBITEMS)
(for SIZE in (LDIFFERENCE \GETFONT.SIZELIST
SIZESINCORE)
collect (BQUOTE (, (GETFONT.ITEMBITMAP NIL DESC
FAMILY
SIZE)
(LIST NESTEDITEMS
(QUOTE , SIZE))
"picks this family and size with the default face"
, GETFONT.FACE.SUBITEMS]
(RETURN (LIST (GETFONT.ITEMBITMAP EXACT? DESC FAMILY)
VALUE "Chooses this font in the default size and face" (CONS (QUOTE SUBITEMS)
SUBITEMS])
(GETFONT.DESCFROMSIZEENTRY
[LAMBDA (SIZEENTRY) (* gbn "17-Jul-84 00:18")
(* takes a sizeentry from \FONTSINCORE and gets the desc
, returns NIL if no defaultface available)
(CDR (ASSOC (QUOTE DISPLAY)
(CDR (ASSOC 0 (SASSOC DEFAULTFACE (CDR SIZEENTRY])
(GETFONT.RATE.FACE
[LAMBDA (FACETRIPLE) (* gbn "16-Jul-84 16:08")
(* gives the smallest numerical rating to the "simplest" font (rate the simplest font as first, regular expansion
second, regular slope and lastly, by weight))
(IPLUS (if (EQ (CAR FACETRIPLE)
(QUOTE MEDIUM))
then 0
else 1)
(if (EQ (CADR FACETRIPLE)
(QUOTE REGULAR))
then 0
else 2)
(if (EQ (CADDR FACETRIPLE)
(QUOTE REGULAR))
then 0
else 3])
(GETFONT.SIZE.ITEM
[LAMBDA (SIZEENTRY FAMILY) (* gbn "24-Jul-84 03:56")
(* creates the family+size item
(together with the necessary subitems of course))
(PROG ((SIZE (CAR SIZEENTRY))
(SIZEENTRY (CDR SIZEENTRY))
FACE EXACT? VALUE DESC SUBITEMS ENTRY)
(SETQ ENTRY (SASSOC DEFAULTFACE SIZEENTRY))
(if (AND ENTRY (SETQ DESC (GETFONT.DESCFROMFACEENTRY ENTRY)))
then (* the default face was found,)
(SETQ EXACT? T)
else (* The default face is not in core, so display the item
in menufont)
(SETQ DESC MENUFONT))
[SETQ VALUE (BQUOTE (LIST NESTEDITEMS (QUOTE , SIZE]
(SETQ SUBITEMS (for FACEENTRY in SIZEENTRY collect (GETFONT.FACE.ITEM FACEENTRY FAMILY SIZE)
))
(RETURN (LIST (GETFONT.ITEMBITMAP EXACT? DESC FAMILY SIZE)
VALUE NIL (CONS (QUOTE SUBITEMS)
SUBITEMS])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1913 10324 (GETFONT 1923 . 2997) (GETFONT.DESCFROMFACEENTRY 2999 . 3389) (
GETFONT.FACE.ITEM 3391 . 3834) (GETFONT.FACENAME 3836 . 4374) (GETFONT.ITEMBITMAP 4376 . 5516) (
GETFONT.SIZESORTFN 5518 . 5718) (GETFONT.SIZESORTFNAUX 5720 . 6024) (GETFONT.WHENSELECTEDFN 6026 .
6272) (GETFONT.FAMILY.ITEM 6274 . 8218) (GETFONT.DESCFROMSIZEENTRY 8220 . 8607) (GETFONT.RATE.FACE
8609 . 9193) (GETFONT.SIZE.ITEM 9195 . 10322)))))
STOP