(FILECREATED "25-Jun-84 09:34:24" {ROSEBOWL}<FEUERMAN>LISP>FONTMENU.;5 8070
changes to: (VARS FONTLST)
(FNS FONTMENU.CREATE FONTMENU.MAKE.FAMILY.ITEM FONTMENU.MAKE.SIZE.ITEM)
previous date: "18-Jun-84 09:17:15" {ROSEBOWL}<FEUERMAN>LISP>FONTMENU.;3)
(PRETTYCOMPRINT FONTMENUCOMS)
(RPAQQ FONTMENUCOMS ((VARS FONTLST)
(FNS FONTMENU.CREATE FONTMENU.MAKE.FACE.BITMAP FONTMENU.MAKE.FACE.ITEM
FONTMENU.MAKE.FAMILY.BITMAP FONTMENU.MAKE.FAMILY.ITEM
FONTMENU.MAKE.SIZE.BITMAP FONTMENU.MAKE.SIZE.ITEM)))
(RPAQQ FONTLST ((CLASSIC (8 STANDARD ITALIC BOLD)
(10 STANDARD ITALIC BOLD)
(12 STANDARD ITALIC BOLD)
(14 STANDARD ITALIC BOLD))
(CREAM (10 STANDARD ITALIC BOLD BOLDITALIC)
(12 STANDARD ITALIC BOLD BOLDITALIC))
(GACHA (8 STANDARD ITALIC BOLD BOLDITALIC)
(10 STANDARD ITALIC BOLD BOLDITALIC)
(12 STANDARD ITALIC BOLD BOLDITALIC))
(HELVETICA (5 STANDARD ITALIC BOLD BOLDITALIC)
(7 STANDARD ITALIC BOLD BOLDITALIC)
(8 STANDARD ITALIC BOLD BOLDITALIC)
(9 STANDARD ITALIC BOLD BOLDITALIC)
(10 STANDARD ITALIC BOLD BOLDITALIC)
(11 STANDARD ITALIC BOLD BOLDITALIC)
(12 STANDARD ITALIC BOLD BOLDITALIC)
(13 STANDARD ITALIC BOLD BOLDITALIC)
(14 STANDARD ITALIC BOLD BOLDITALIC)
(16 STANDARD ITALIC BOLD BOLDITALIC)
(18 STANDARD ITALIC BOLD BOLDITALIC)
(36 STANDARD ITALIC BOLD BOLDITALIC))
(HELVETICAD (DEFAULTSIZE . 24)
(DEFAULTFACE . STANDARD)
(24 STANDARD ITALIC BOLD BOLDITALIC))
(OLDENGLISH (10 STANDARD ITALIC BOLD BOLDITALIC)
(18 STANDARD ITALIC BOLD BOLDITALIC))
(TIMESROMAN (4 STANDARD ITALIC BOLD BOLDITALIC)
(6 STANDARD ITALIC BOLD BOLDITALIC)
(8 STANDARD ITALIC BOLD BOLDITALIC)
(9 STANDARD ITALIC BOLD BOLDITALIC)
(10 STANDARD ITALIC BOLD BOLDITALIC)
(11 STANDARD ITALIC BOLD BOLDITALIC)
(12 STANDARD ITALIC BOLD BOLDITALIC)
(13 STANDARD ITALIC BOLD BOLDITALIC)
(14 STANDARD ITALIC BOLD BOLDITALIC)
(16 STANDARD ITALIC BOLD BOLDITALIC)
(18 STANDARD ITALIC BOLD BOLDITALIC)
(36 STANDARD ITALIC BOLD BOLDITALIC))
(TIMESROMAND (DEFAULTSIZE . 24)
(24 (DEFAULTFACE . STANDARD)
STANDARD ITALIC BOLD BOLDITALIC)
(30 (DEFAULTFACE . ITALIC)
STANDARD ITALIC BOLD BOLDITALIC)
(36 (DEFAULTFACE . BOLD)
STANDARD ITALIC BOLD BOLDITALIC))))
(DEFINEQ
(FONTMENU.CREATE
[LAMBDA (FONTLIST DEFAULTSIZE DEFAULTFACE) (* Feuerman "25-Jun-84 08:15")
(* Returns a menu suitable for displaying and selecting fonts in a tree menu form. Fonts are categorized in the
tree menu first by family, then size, then face)
(create MENU
ITEMS ←(for Family in FONTLIST collect (FONTMENU.MAKE.FAMILY.ITEM Family DEFAULTSIZE
DEFAULTFACE))
CENTERFLG ← T
TITLE ← "Fonts"])
(FONTMENU.MAKE.FACE.BITMAP
[LAMBDA (FAMILY SIZE FACE) (* Feuerman "15-Jun-84 15:54")
(* This returns the bitmap image that will appear in the second tier of trees. It is the word, FAMILY, followed by
the number, SIZE, and then whatever FACE is, printed in the font specified by FAMILY SIZE FACE)
(PROG ((FONT (FONTCREATE FAMILY SIZE FACE))
BITMAP STREAM)
[SETQ BITMAP (BITMAPCREATE (STRINGWIDTH (L-CASE (CONCAT FAMILY " " SIZE " " FACE)
T)
FONT)
(FONTPROP FONT (QUOTE SIZE]
(SETQ STREAM (DSPCREATE BITMAP))
(DSPFONT FONT STREAM)
(MOVETO 0 (SUB1 (FONTPROP FONT (QUOTE DESCENT)))
STREAM)
(PRIN1 (L-CASE (CONCAT FAMILY " " SIZE " " FACE)
T)
STREAM)
(RETURN BITMAP])
(FONTMENU.MAKE.FACE.ITEM
[LAMBDA (FAMILY SIZE FACE) (* Feuerman "15-Jun-84 14:19")
(* This function finally returns the individual menu
item with all three FAMILY SIZE FACE all specified.
It is the third tier of trees)
(LIST (FONTMENU.MAKE.FACE.BITMAP FAMILY SIZE FACE)
(LIST (QUOTE FONTCREATE)
(KWOTE FAMILY)
SIZE
(KWOTE FACE])
(FONTMENU.MAKE.FAMILY.BITMAP
[LAMBDA (FAMILY DEFAULTSIZE DEFAULTFACE) (* Feuerman "15-Jun-84 15:52")
(* This returns the bitmap image that will appear in the first tier of trees. It is the word, FAMILY, printed in
the font specified by FAMILY DEFAULTSIZE DEFAULTFACE)
(PROG ((FONT (FONTCREATE FAMILY (OR DEFAULTSIZE 10)
DEFAULTFACE))
BITMAP STREAM)
[SETQ BITMAP (BITMAPCREATE (STRINGWIDTH (L-CASE FAMILY T)
FONT)
(FONTPROP FONT (QUOTE SIZE]
(SETQ STREAM (DSPCREATE BITMAP))
(DSPFONT FONT STREAM)
(MOVETO 0 (SUB1 (FONTPROP FONT (QUOTE DESCENT)))
STREAM)
(PRIN1 (L-CASE FAMILY T)
STREAM)
(RETURN BITMAP])
(FONTMENU.MAKE.FAMILY.ITEM
[LAMBDA (FAMILY DEFAULTSIZE DEFAULTFACE) (* Feuerman "25-Jun-84 08:32")
(* Returns a single menu item for MENUFONT.CREATE
consisting of all of the subitems for FAMILY)
(PROG ((FAMILYDEFAULTSIZESPEC (ASSOC (QUOTE DEFAULTSIZE)
(CDR FAMILY)))
(FAMILYDEFAULTFACESPEC (ASSOC (QUOTE DEFAULTFACE)
(CDR FAMILY)))
FAMILYDEFAULTSIZE FAMILYDEFAULTFACE)
(SETQ FAMILYDEFAULTSIZE (COND
(FAMILYDEFAULTSIZESPEC (CDR FAMILYDEFAULTSIZESPEC))
(DEFAULTSIZE)))
(SETQ FAMILYDEFAULTFACE (COND
(FAMILYDEFAULTFACESPEC (CDR FAMILYDEFAULTFACESPEC))
(DEFAULTFACE)))
(RETURN (LIST (FONTMENU.MAKE.FAMILY.BITMAP (CAR FAMILY)
FAMILYDEFAULTSIZE FAMILYDEFAULTFACE)
(LIST (QUOTE FONTCREATE)
(KWOTE (CAR FAMILY))
(OR FAMILYDEFAULTSIZE 10)
(KWOTE FAMILYDEFAULTFACE))
NIL
(CONS (QUOTE SUBITEMS)
(for Size in (LDIFFERENCE (LDIFFERENCE (CDR FAMILY)
(LIST FAMILYDEFAULTSIZESPEC))
(LIST FAMILYDEFAULTFACESPEC))
collect (FONTMENU.MAKE.SIZE.ITEM (CAR FAMILY)
Size FAMILYDEFAULTFACE])
(FONTMENU.MAKE.SIZE.BITMAP
[LAMBDA (FAMILY SIZE DEFAULTFACE) (* Feuerman "15-Jun-84 15:53")
(* This returns the bitmap image that will appear in the second tier of trees. It is the word, FAMILY, followed by
the number, SIZE, printed in the font specified by FAMILY SIZE DEFAULTFACE)
(PROG ((FONT (FONTCREATE FAMILY SIZE DEFAULTFACE))
BITMAP STREAM)
[SETQ BITMAP (BITMAPCREATE (STRINGWIDTH (L-CASE (CONCAT FAMILY " " SIZE)
T)
FONT)
(FONTPROP FONT (QUOTE SIZE]
(SETQ STREAM (DSPCREATE BITMAP))
(DSPFONT FONT STREAM)
(MOVETO 0 (SUB1 (FONTPROP FONT (QUOTE DESCENT)))
STREAM)
(PRIN1 (L-CASE (CONCAT FAMILY " " SIZE)
T)
STREAM)
(RETURN BITMAP])
(FONTMENU.MAKE.SIZE.ITEM
[LAMBDA (FAMILY SIZE DEFAULTFACE) (* Feuerman "25-Jun-84 09:26")
(* Returns a subitem for MENUFONT.MAKE.FAMILY.ITEM which refers to the font in FAMILY and SIZE.
DEFAULTFACE is used in case the user does not go on to the face menu)
(PROG ((SIZEDEFAULTFACESPEC (ASSOC (QUOTE DEFAULTFACE)
(CDR SIZE)))
SIZEDEFAULTFACE)
(SETQ SIZEDEFAULTFACE (COND
(SIZEDEFAULTFACESPEC (CDR SIZEDEFAULTFACESPEC))
(DEFAULTFACE)))
(RETURN (LIST (FONTMENU.MAKE.SIZE.BITMAP FAMILY (CAR SIZE)
SIZEDEFAULTFACE)
(LIST (QUOTE FONTCREATE)
(KWOTE FAMILY)
(CAR SIZE)
(KWOTE SIZEDEFAULTFACE))
NIL
(CONS (QUOTE SUBITEMS)
(for Face in (LDIFFERENCE (CDR SIZE)
(LIST SIZEDEFAULTFACESPEC))
collect (FONTMENU.MAKE.FACE.ITEM FAMILY (CAR SIZE)
Face])
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2437 8048 (FONTMENU.CREATE 2447 . 2948) (FONTMENU.MAKE.FACE.BITMAP 2950 . 3783) (
FONTMENU.MAKE.FACE.ITEM 3785 . 4270) (FONTMENU.MAKE.FAMILY.BITMAP 4272 . 5027) (
FONTMENU.MAKE.FAMILY.ITEM 5029 . 6298) (FONTMENU.MAKE.SIZE.BITMAP 6300 . 7102) (
FONTMENU.MAKE.SIZE.ITEM 7104 . 8046)))))
STOP