github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-26 12:18:05 +00:00
Code Issues Projects Releases Wiki Activity

remove 'obsolete' folder from repo -- move to separate repo (#2503)

Browse Source
This commit is contained in:
Larry Masinter
2026-03-02 11:49:31 -08:00
committed by GitHub
parent 1569a27209
commit b1bdd90338
893 changed files with 0 additions and 95587 deletions
Download Patch File Download Diff File Expand all files Collapse all files

391
obsolete/library/IPFONTSAMPLE
View File

@@ -1,391 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "11-Jun-90 15:51:10" {DSK}<usr>local>lde>lispcore>library>FONTSAMPLE.;2 16609
changes to%: (VARS FONTSAMPLECOMS)
previous date%: "10-Jan-87 15:47:00" {DSK}<usr>local>lde>lispcore>library>FONTSAMPLE.;1)
(* ; "
Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT FONTSAMPLECOMS)
(RPAQQ FONTSAMPLECOMS ((MACROS IDIVUP)
(VARS FNT.PANEL FNT.FNAME FNT.INFOFONT FNT.OUTFTEXT)
(FNS FNT.MAKEBOOK FNT.LESSP FNT.SORTP FNT.DISPLOOK FNT.DISPTBLE
FNT.DISPDSCR FNT.NARRDSCR FNT.DISPINIT FNT.FACEMAP FNT.SIZEMAP
FNT.MAKENAME FNT.MAKEWIND FNT.FILEMAP FNT.FINDALL FNT.FLST)))
(DECLARE%: EVAL@COMPILE
(PUTPROPS IDIVUP DMACRO ((INUMEXPR IDENEXPR)
(LET (INUM IDEN)
(SETQ INUM INUMEXPR)
(SETQ IDEN IDENEXPR)
(IQUOTIENT (IPLUS INUM IDEN -1)
IDEN))))
)
(RPAQQ FNT.PANEL
([PROG (SETQ FNT.WIND (FNT.MAKEWIND))
(SETQ FNT.FONTLIST '(GACHA 10 (MEDIUM REGULAR REGULAR)
0 INTERPRESS]
(PROG (CLEARW FNT.WIND)
(FNT.DISPTBLE FNT.WIND FNT.FONTLIST))
(PROG (SETQ FNT.FILENAME (FNT.MAKENAME FNT.FONTLIST))
(SETQ FNT.STRM (OPENIMAGESTREAM FNT.FILENAME 'INTERPRESS))
(TOTOPW FNT.WIND)
(BITBLT FNT.WIND 0 0 FNT.STRM 0 0 612 792 'INPUT 'REPLACE)
(CLOSEF FNT.STRM))))
(RPAQQ FNT.FNAME {DSK}FONTBOOK.IP)
(RPAQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
0))
(RPAQQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
(DEFINEQ
(FNT.MAKEBOOK
[LAMBDA (OUTFROOTNAME ListOfFonts PRNTFN PERPAGE) (* FS "30-Jun-86 11:45")
(* * takes a file name and font specification and iteratively invokes a given
 print function (fnt.dispfont by default) on each font in the sorted list)
(LET (FONTLIST OUTFTYPE OUTFDSCR OUTFOPTS ITER THISPAGE OUTFNAME)
(* * Handle input parm defaults * *)
(if (EQ PRNTFN NIL)
then (SETQQ PRNTFN FNT.DISPLOOK))
(if (EQ PERPAGE NIL)
then (SETQ PERPAGE (SELECTQ PRNTFN
(FNT.DISPTBLE 1)
(FNT.DISPLOOK 18)
1)))
(SETQQ OUTFTYPE INTERPRESS)
(SETQQ OUTFOPTS (REGION (2794 1905 25400 24765)))
(if (EQUAL ListOfFonts 'ALL)
then (SETQ FONTLIST (FNT.FINDALL OUTFTYPE))
else (SETQ FONTLIST ListOfFonts))
(* * Iterate over files increment file names, iterate over fonts * *)
(SETQ ITER 0)
(for PAGENO from 1 to (IDIVUP (LENGTH FONTLIST)
PERPAGE)
do (SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO))
(if OUTFNAME
then (SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE OUTFOPTS)))
(SETQ THISPAGE (IMIN PERPAGE (IDIFFERENCE (LENGTH FONTLIST)
ITER)))
[for I from 1 to THISPAGE do (SETQ ITER (ADD1 ITER))
(APPLY* PRNTFN OUTFDSCR (CAR (NTH FONTLIST ITER]
(CLOSEF OUTFDSCR)
(BLOCK])
(FNT.LESSP
[LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:11")
(* * Impose alpha order on font list)
(PROG NIL
(if (NOT (LISTP DSC1))
then (RETURN (ALPHORDER DSC1 DSC2)))
(* * Switch face & size for order * *)
[SETQ DSC1 (LIST (CAR DSC1)
(CADDR DSC1)
(CADR DSC1)
(CADDDR DSC1)
(CAR (CDDDR DSC1]
[SETQ DSC2 (LIST (CAR DSC2)
(CADDR DSC2)
(CADR DSC2)
(CADDDR DSC2)
(CAR (CDDDR DSC2]
(RETURN (FNT.SORTP DSC1 DSC2])
(FNT.SORTP
[LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:15")
(* * Impose alpha order on font list)
(PROG (KEY1 KEY2)
(if (NOT (LISTP DSC1))
then (RETURN (ALPHORDER DSC1 DSC2)))
(SETQ KEY1 (CAR DSC1))
(SETQ KEY2 (CAR DSC2))
(* * Reverse order of face * *)
[if (EQUAL KEY1 KEY2)
then (RETURN (FNT.SORTP (CDR DSC1)
(CDR DSC2]
[if (LISTP KEY1)
then (RETURN (NOT (FNT.SORTP KEY1 KEY2]
(if (NUMBERP KEY1)
then (RETURN (LESSP KEY1 KEY2)))
(RETURN (ALPHORDER KEY1 KEY2])
(FNT.DISPLOOK
[LAMBDA (FILEDSC FONTDSC) (* FS "24-Jan-86 18:19")
(* * uses "private" global vars fnt.infofont and fnt.outftext to generate
 sample string)
(LET NIL (DSPFONT FNT.INFOFONT FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(TERPRI FILEDSC)
(FNT.NARRDSCR FILEDSC (LIST FONTDSC))
(DSPFONT FONTDSC FILEDSC)
(printout FILEDSC FNT.OUTFTEXT])
(FNT.DISPTBLE
[LAMBDA (Stream FONTDSC) (* FS "17-Mar-86 17:37")
(* * generates a font table using prin1)
(LET* ((TitleFont (FONTCREATE FNT.INFOFONT))
(FontList (LIST FONTDSC))
(InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream)))
(DDev (IMAGESTREAMTYPE Stream)))
(for Font in FontList
do (DSPRIGHTMARGIN (TIMES 100.0 InchesToPrinterUnits)
Stream) (* Let clip on right *)
(MOVETO (FTIMES 0.75 InchesToPrinterUnits)
(FTIMES 10.0 InchesToPrinterUnits)
Stream)
(DSPFONT TitleFont Stream)
(FNT.NARRDSCR Stream FontList)
(DSPFONT FONTDSC Stream)
(printout Stream FNT.OUTFTEXT)
(DSPFONT Font Stream)
(for YPosition from (TIMES 9 InchesToPrinterUnits) to (TIMES 1.5 InchesToPrinterUnits
)
by (TIMES -0.5 InchesToPrinterUnits) bind (CharacterCode _ 0)
do (for XPosition from (TIMES 0.75 InchesToPrinterUnits)
to (TIMES 7.5 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits)
do (MOVETO XPosition YPosition Stream)
(if (NEQ CharacterCode (CHARCODE FF))
then (if (EQ DDev 'DISPLAY)
then (BLTCHAR CharacterCode Stream)
else (PRIN1 (CHARACTER CharacterCode)
Stream)))
(SETQ CharacterCode (ADD1 CharacterCode)))
(printout T "."))
(printout T " done." T])
(FNT.DISPDSCR
[LAMBDA (OUTF FONTLIST) (* FS " 2-Jul-85 13:00")
(* * Prints a list of fontlists with facelist formatting appropriate for 8 pt.
 terminal)
(PROG (NAME SIZE JUNK NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 T6 T7)
(if (EQ FONTLIST NIL)
then (RETURN NIL))
(SETQ TEMP (DSPSCALE NIL OUTF))
(SETQ UNITS (TIMES 4.25 TEMP))
(SETQ OFFX (TIMES 42.5 TEMP))
(SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
(SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
(SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
(SETQ T3 (PLUS OFFX (TIMES 30 UNITS)))
(SETQ T4 (PLUS OFFX (TIMES 40 UNITS)))
(SETQ T5 (PLUS OFFX (TIMES 50 UNITS)))
(SETQ T6 (PLUS OFFX (TIMES 55 UNITS)))
(SETQ T7 (PLUS OFFX (TIMES 70 UNITS)))
[MAPC FONTLIST '(LAMBDA (DESCR)
(SETQ NAME (CAR DESCR))
(SETQ SIZE (CADR DESCR))
(SETQ JUNK (CADDR DESCR))
(SETQ TEMP (CDDDR DESCR))
(SETQ NUMB (CAR TEMP))
(SETQ STRM (CADR TEMP))
(DSPXPOSITION T0 OUTF)
(printout OUTF NAME)
(DSPXPOSITION T1 OUTF)
(printout OUTF |.I3| SIZE)
(DSPXPOSITION T2 OUTF)
(printout OUTF "(" (CAR JUNK))
(DSPXPOSITION T3 OUTF)
(printout OUTF (CADR JUNK))
(DSPXPOSITION T4 OUTF)
(printout OUTF (CADDR JUNK)
")")
(DSPXPOSITION T5 OUTF)
(printout OUTF NUMB)
(DSPXPOSITION T6 OUTF)
(printout OUTF STRM)
(DSPXPOSITION T7 OUTF]
(RETURN NIL])
(FNT.NARRDSCR
[LAMBDA (OUTF FONTLIST) (* ; "Edited 9-Jan-87 18:57 by FS")
(* * Prints a list of fontlists with narrow formatting appropriate for 8 pt.
 terminal)
(PROG (NAME SIZE FACE NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 DESCR)
(if (EQ FONTLIST NIL)
then (RETURN NIL))
(if (TYPENAMEP FONTLIST 'FONTDESCRIPTOR)
then (SETQ FONTLIST (FNT.FLST FONTLIST)))
(SETQ TEMP (DSPSCALE NIL OUTF))
(SETQ UNITS (TIMES 4.25 TEMP))
(SETQ OFFX (TIMES 42.5 TEMP))
(SETQ T0 (PLUS OFFX (TIMES 0 UNITS)))
(SETQ T1 (PLUS OFFX (TIMES 14 UNITS)))
(SETQ T2 (PLUS OFFX (TIMES 20 UNITS)))
(SETQ T3 (PLUS OFFX (TIMES 28 UNITS)))
(SETQ T4 (PLUS OFFX (TIMES 33 UNITS)))
(SETQ T5 (PLUS OFFX (TIMES 48 UNITS)))
(* * (MAPC FONTLIST (QUOTE (LAMBDA (DESCR)
 (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR))
 (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP
 (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM
 (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME)
 (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE)
 (DSPXPOSITION T2 OUTF) (printout OUTF FACE)
 (DSPXPOSITION T3 OUTF) (printout OUTF NUMB)
 (DSPXPOSITION T4 OUTF) (printout OUTF STRM)
 (DSPXPOSITION T5 OUTF)))))
(for I in FONTLIST do (if (type? FONTDESCRIPTOR I)
then (SETQ DESCR (FNT.FLST I))
else (SETQ DESCR I))
(SETQ NAME (CAR DESCR))
(SETQ SIZE (CADR DESCR))
(SETQ FACE (FNT.FACEMAP (CADDR DESCR)))
(SETQ TEMP (CDDDR DESCR))
(SETQ NUMB (CAR TEMP))
(SETQ STRM (CADR TEMP))
(DSPXPOSITION T0 OUTF)
(printout OUTF NAME)
(DSPXPOSITION T1 OUTF)
(printout OUTF |.I3| SIZE)
(DSPXPOSITION T2 OUTF)
(printout OUTF FACE)
(DSPXPOSITION T3 OUTF)
(printout OUTF NUMB)
(DSPXPOSITION T4 OUTF)
(printout OUTF STRM)
(DSPXPOSITION T5 OUTF))
(RETURN NIL])
(FNT.DISPINIT
[LAMBDA (FILEDSC) (* FS " 2-Jul-85 14:14")
(* * initialization or optimization for fnt.dispfont)
(PROG (vars...)
(SETQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL")
(SETQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR)
0 INTERPRESS))
(RETURN NIL])
(FNT.FACEMAP
[LAMBDA (OLDFACE) (* FS " 5-Sep-85 19:04")
(* * make short face from facelist)
(SETQ OLDFACE (\FONTFACE OLDFACE)) (* make list form *)
(CONCAT (GNC (MKSTRING (CAR OLDFACE)))
(GNC (MKSTRING (CADR OLDFACE)))
(GNC (MKSTRING (CADDR OLDFACE])
(FNT.SIZEMAP
[LAMBDA (SIZE) (* FS " 2-Jul-85 14:13")
(* * make size into two character string)
(PROG (STR)
(if (ILESSP SIZE 10)
then (RETURN (CONCAT "0" (MKSTRING SIZE)))
else (RETURN (MKSTRING SIZE])
(FNT.MAKENAME
[LAMBDA (FONTLIST) (* FS " 3-Sep-85 16:07")
(* * make a unique interpress file name given a fontlist)
(PROG (STR TYPE SIZE FACE DDEV)
(SETQ TYPE (MKSTRING (CAR FONTLIST)))
(SETQ SIZE (FNT.SIZEMAP (CADR FONTLIST)))
[SETQ FACE (MKSTRING (FNT.FACEMAP (CADDR FONTLIST]
(SETQ DDEV (CAR (CDDDDR FONTLIST)))
(SETQ STR (CONCAT (MKSTRING TYPE)
(MKSTRING SIZE)
(MKSTRING FACE)
(GNC (MKSTRING DDEV))
".IP"))
(RETURN STR])
(FNT.MAKEWIND
[LAMBDA NIL (* FS "21-Mar-86 18:07")
(* * MAKE A WINDOW)
(PROG (PPI)
(SETQ PPI (TIMES 72 (DSPSCALE NIL T)))
[SETQ FNT.WINDOW (CREATEW (create REGION
LEFT _ 0
BOTTOM _ 0
WIDTH _ (FIX (TIMES 8.5 PPI))
HEIGHT _ (TIMES 11 PPI]
(RETURN FNT.WINDOW])
(FNT.FILEMAP
[LAMBDA (OUTFNAME NUMBER) (* FS " 5-Sep-85 16:56")
(* * Takes a file name and returns an Interpress file name with number at end *
 *)
(PROG (FNAME ROOTNAME DESTNAME)
(if (OR (EQ OUTFNAME T)
(EQ OUTFNAME NIL))
then (RETURN OUTFNAME))
(SETQ FNAME OUTFNAME)
(SETQ ROOTNAME (FILENAMEFIELD FNAME 'NAME))
(SETQ ROOTNAME (MKATOM (CONCAT ROOTNAME NUMBER)))
(SETQ DESTNAME (PACKFILENAME 'NAME ROOTNAME 'BODY FNAME))
(RETURN DESTNAME])
(FNT.FINDALL
[LAMBDA (DEVICE) (* FS " 5-Sep-85 19:18")
(* * Returns list of all fonts for device * *)
(LET (RESULT)
(SETQ RESULT (FONTSAVAILABLE '* '* '
(* * *)
'* DEVICE T))
(SETQ RESULT (SORT RESULT 'FNT.LESSP])
(FNT.FLST
[LAMBDA (FONTOBJ) (* ; "Edited 9-Jan-87 18:56 by FS")
(COND
[(TYPENAMEP FONTOBJ 'FONTDESCRIPTOR)
(LIST (FONTPROP FONTOBJ 'FAMILY)
(FONTPROP FONTOBJ 'SIZE)
(FONTPROP FONTOBJ 'FACE)
(FONTPROP FONTOBJ 'ROTATION)
(FONTPROP FONTOBJ 'DEVICE]
((LISTP FONTOBJ)
FONTOBJ])
)
(PUTPROPS FONTSAMPLE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1964 16504 (FNT.MAKEBOOK 1974 . 3779) (FNT.LESSP 3781 . 4575) (FNT.SORTP 4577 . 5343) (
FNT.DISPLOOK 5345 . 5862) (FNT.DISPTBLE 5864 . 7867) (FNT.DISPDSCR 7869 . 9976) (FNT.NARRDSCR 9978 .
12722) (FNT.DISPINIT 12724 . 13136) (FNT.FACEMAP 13138 . 13525) (FNT.SIZEMAP 13527 . 13863) (
FNT.MAKENAME 13865 . 14549) (FNT.MAKEWIND 14551 . 15105) (FNT.FILEMAP 15107 . 15737) (FNT.FINDALL
15739 . 16082) (FNT.FLST 16084 . 16502)))))
STOP