(FILECREATED "26-Feb-85 10:13:25" {ERIS}<LISPCORE>LIBRARY>NSTOASCIIDISPLAYFONT.;7 8948
changes to: (FNS ASCIIDISPLAYFONT NSTOASCIIDISPLAYFONT)
(VARS NSTOASCIIDISPLAYFONTCOMS ASCIITOACCENTARRAY)
previous date: "28-Nov-84 22:57:10" {ERIS}<LISPCORE>LIBRARY>NSTOASCIIDISPLAYFONT.;2)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NSTOASCIIDISPLAYFONTCOMS)
(RPAQQ NSTOASCIIDISPLAYFONTCOMS ((FNS ASCIIDISPLAYFONT NSTOASCIIDISPLAYFONT READNSDISPLAYFONTFILE)
(FILES (FROM VALUEOF LISPUSERSDIRECTORIES)
EDITFONT)
(ALISTS (ASCIITONSTRANSLATIONS CLASSICACCENTS MODERNACCENTS))
(VARS ASCIITOACCENTARRAY)))
(DEFINEQ
(ASCIIDISPLAYFONT
[LAMBDA (FAMILY SIZE FACE ROTATION) (* rmk: "26-Feb-85 10:13")
(PROG [TEMP (TRANSL (CDR (ASSOC (SETQ FAMILY (U-CASE FAMILY))
ASCIITONSTRANSLATIONS]
(OR TRANSL (ERROR "No translation information for " FAMILY))
(RETURN (NSTOASCIIDISPLAYFONT (COND
((NULL (SETQ TEMP (CAR TRANSL)))
\ASCIITONS)
((LITATOM TEMP)
(EVAL TEMP))
(T TEMP))
(COND
((NULL (SETQ TEMP (CADDR TRANSL)))
\ASCIITOSTAR)
((LITATOM TEMP)
(EVAL TEMP))
(T TEMP))
FAMILY
(OR (CADR TRANSL)
(QUOTE MODERN))
SIZE
(\FONTFACE FACE)
(OR ROTATION 0])
(NSTOASCIIDISPLAYFONT
[LAMBDA (ASCIITONSMAPARRAY ASCIITONSFIXARRAY ASCIIFAMILY NSFAMILY SIZE FONTFACE ROTATION DEVICE)
(* rmk: "26-Feb-85 09:50")
(* Produces an ASCII displayfont by getting bitmaps and
widths from NS character sets, as determined by the
translation table)
(* ASCIITONSFIXARRAY is for temporary problems with
font compatibility between printer and widths/screen.
in OS5.0 fonts)
(PROG [CHARSETDIR FD (ASCIITONSMAP (fetch (ARRAYP BASE) of (\DTEST (OR ASCIITONSFIXARRAY
ASCIITONSMAPARRAY)
(QUOTE ARRAYP]
[for I NSCODE CS from 0 to 255 unless (OR (EQ 0 (SETQ NSCODE (\GETBASE ASCIITONSMAP I)))
(ASSOC (SETQ CS (NSCHARSET NSCODE))
CHARSETDIR))
do (* Run thru the translate table looking for non-0
charsets. Add their width info to the directory)
(push CHARSETDIR (CONS CS
(COND
((READNSDISPLAYFONTFILE NSFAMILY SIZE FONTFACE CS))
(T (* There isn't any info for that character.
Warn the guy, but continue.)
(FRESHLINE PROMPTWINDOW)
(printout PROMPTWINDOW
"Warning: Information about character set "
.I3.8 CS " missing from font " ASCIIFAMILY ,
SIZE ".")
NIL] (* Return if one of the fonts couldn't be found)
[SETQ FD (for C in CHARSETDIR largest (FONTPROP (CDR C)
(QUOTE HEIGHT]
(* Choose FD with maximum height to modify and return)
(SETQ CHARSETDIR (DREMOVE FD CHARSETDIR))
(SETQ FD (CDR FD))
(for C CFD OLDBM NEWBM (FDH ←(FONTPROP FD (QUOTE HEIGHT)))
(FDD ←(FONTPROP FD (QUOTE DESCENT))) in CHARSETDIR unless (EQ FDH (FONTPROP
(CDR C)
(QUOTE HEIGHT)))
do (SETQ CFD (CDR C))
(if (EQ FDD (FONTPROP CFD (QUOTE DESCENT)))
then (SETQ OLDBM (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of CFD))
(* If Descents agree, then just coerce the height
upwards.)
(SETQ NEWBM (BITMAPCREATE (BITMAPWIDTH OLDBM)
FDH))
(BITBLT OLDBM 0 0 NEWBM)
(replace (FONTDESCRIPTOR CHARACTERBITMAP) of CFD with NEWBM)
(replace (FONTDESCRIPTOR \SFHeight) of CFD with FDH)
else (* If descents disagree, then not sure how to align
them)
(HELP "Mismatch of font heights and descents")))
(bind CHARSETINFO for I NSCODE from 0 to 255 unless (EQ 0 (SETQ NSCODE (\GETBASE
ASCIITONSMAP I)))
when (SETQ CHARSETINFO (CDR (ASSOC (NSCHARSET NSCODE)
CHARSETDIR)))
do (* For each non-ASCII character, look for width info in
the right NS place. If none, use zero width.)
(PUTCHARBITMAP I FD (GETCHARBITMAP (NSCHAR NSCODE)
CHARSETINFO)))
(RETURN FD])
(READNSDISPLAYFONTFILE
[LAMBDA (FAMILY SIZE FACE CHARSET) (* rmk: "28-Nov-84 22:25")
(DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
(SELECTQ (SYSTEMTYPE)
(J (PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE))
FONTDESC STRM)
(COND
((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES)))
(SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
(SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM))
(CLOSEF STRM)))
(replace FONTSCALE of FONTDESC with 1)
(RETURN FONTDESC)))
[D (for E FONTFILE FONTDESC STRM inside DISPLAYFONTEXTENSIONS
when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE E CHARSET)
T DISPLAYFONTDIRECTORIES))
do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
[RESETLST (SETQ FONTDESC (SELECTQ (FONTFILEFORMAT STRM T)
(STRIKE (RESETSAVE
NIL
(LIST (FUNCTION CLOSEF)
STRM))
(\READSTRIKEFONTFILE STRM FAMILY SIZE
FACE))
(AC
(* CLOSEF is guaranteed inside \READACFONTFILE, against
the possibility that we have to copy to make
randaccessp)
(\READACFONTFILE STRM FAMILY SIZE FACE))
(PROG1 (CLOSEF STRM)
(* This would get done by RESETSAVE if AC's were read
sequentially and we could factor the RESETSAVE)
]
(* If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also
be nice to tell the user that he has a bogus file.)
(COND
(FONTDESC (replace FONTSCALE of FONTDESC with 1)
(RETURN FONTDESC]
(SHOULDNT])
)
(FILESLOAD (FROM VALUEOF LISPUSERSDIRECTORIES)
EDITFONT)
(ADDTOVAR ASCIITONSTRANSLATIONS (CLASSICACCENTS ASCIITOACCENTARRAY CLASSIC ASCIITOACCENTARRAY)
(MODERNACCENTS ASCIITOACCENTARRAY MODERN ASCIITOACCENTARRAY))
(RPAQ ASCIITOACCENTARRAY (READARRAY 256 (QUOTE SMALLPOSP) 0))
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 61729 61730
61731 61732 61733 61734 61735 61736 61737 61738 61739 61740 61741 61742 61743 61744 61745 61746 61747
61748 61749 61750 61751 61752 61753 61754 61755 61756 61757 61758 61759 61760 61761 61762 61763 61764
61765 61766 61767 61768 61769 61770 61771 61772 61773 61774 61775 61776 61777 61778 61779 61780 61781
61782 61783 61784 61785 61786 61787 61788 61789 61790 61791 61792 61793 61794 61795 61796 61797 61798
61799 61800 61801 61802 61803 61804 61805 61806 61807 61808 113 114 115 116 117 118 119 120 121 122
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
148 149 150 151 152 153 154 155 156 157 158 159 160 61857 61858 61859 61860 61861 61862 61863 61864
61865 61866 61867 61868 61869 61870 61871 61872 61873 61874 61875 61876 61877 61878 61879 61880 61881
61882 61883 61884 61885 61886 61887 61888 61889 61890 61891 61892 61893 61894 61895 61896 61897 61898
61899 61900 61901 61902 61903 61904 61905 61906 61907 61908 61909 61910 61911 61912 61913 61914 61915
61916 61917 61918 61919 61920 61921 61922 61923 61924 61925 61926 61927 61928 61929 61930 61931 61932
61933 61934 61935 61936 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 NIL
)
(PUTPROPS NSTOASCIIDISPLAYFONT COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (692 7242 (ASCIIDISPLAYFONT 702 . 1508) (NSTOASCIIDISPLAYFONT 1510 . 5183) (
READNSDISPLAYFONTFILE 5185 . 7240)))))
STOP