1(* 2 Copyright (c) 2001, 2015 3 David C.J. Matthews 4 5 This library is free software; you can redistribute it and/or 6 modify it under the terms of the GNU Lesser General Public 7 License version 2.1 as published by the Free Software Foundation. 8 9 This library is distributed in the hope that it will be useful, 10 but WITHOUT ANY WARRANTY; without even the implied warranty of 11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12 Lesser General Public License for more details. 13 14 You should have received a copy of the GNU Lesser General Public 15 License along with this library; if not, write to the Free Software 16 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 17*) 18 19structure FontBase = 20struct 21 local 22 open Foreign Base 23 in 24 datatype OutputQuality = 25 DEFAULT_QUALITY | DRAFT_QUALITY | PROOF_QUALITY | ANTIALIASED_QUALITY | CLEARTYPE_QUALITY | NONANTIALIASED_QUALITY 26 local 27 val tab = [ 28 (DEFAULT_QUALITY, 0w0: Word8.word), 29 (DRAFT_QUALITY, 0w1), 30 (PROOF_QUALITY, 0w2), 31 (NONANTIALIASED_QUALITY, 0w3), 32 (ANTIALIASED_QUALITY, 0w4), 33 (CLEARTYPE_QUALITY, 0w5) 34 ] 35 in 36 val (outQualToW8, outQualFromW8) = tableLookup(tab, NONE) 37 end 38 39 datatype CharacterSet = ANSI_CHARSET | DEFAULT_CHARSET | SYMBOL_CHARSET | MAC_CHARSET | 40 SHIFTJIS_CHARSET | HANGEUL_CHARSET | JOHAB_CHARSET | GB2312_CHARSET | 41 CHINESEBIG5_CHARSET | GREEK_CHARSET | TURKISH_CHARSET | VIETNAMESE_CHARSET | 42 HEBREW_CHARSET | ARABIC_CHARSET | BALTIC_CHARSET | RUSSIAN_CHARSET | 43 THAI_CHARSET | EASTEUROPE_CHARSET | OEM_CHARSET 44 45 local 46 val tab = [ 47 (ANSI_CHARSET, 0wx00: Word8.word), 48 (DEFAULT_CHARSET, 0wx01), 49 (SYMBOL_CHARSET, 0wx02), 50 (MAC_CHARSET, 0wx4D), 51 (SHIFTJIS_CHARSET, 0wx80), 52 (HANGEUL_CHARSET, 0wx81), 53 (JOHAB_CHARSET, 0wx82), 54 (GB2312_CHARSET, 0wx86), 55 (CHINESEBIG5_CHARSET, 0wx88), 56 (GREEK_CHARSET, 0wxA1), 57 (TURKISH_CHARSET, 0wxA2), 58 (VIETNAMESE_CHARSET, 0wxA3), 59 (HEBREW_CHARSET, 0wxB1), 60 (ARABIC_CHARSET, 0wxB2), 61 (BALTIC_CHARSET, 0wxBA), 62 (RUSSIAN_CHARSET, 0wxCC), 63 (THAI_CHARSET, 0wxDE), 64 (EASTEUROPE_CHARSET, 0wxEE), 65 (OEM_CHARSET, 0wxff) 66 ] 67 in 68 val (charsetToW8, charsetFromW8) = tableLookup(tab, NONE) 69 end 70 71 (* In the underlying CreateFont call the pitch and family are ORed together. *) 72 (*TYPE: FontFamily *) 73 datatype FontFamily = FF_DONTCARE | FF_ROMAN | FF_SWISS | FF_MODERN | 74 FF_SCRIPT| FF_DECORATIVE 75 76 and FontPitch = DEFAULT_PITCH | FIXED_PITCH | VARIABLE_PITCH 77 78 local 79 open Word8 80 val tab1 = [ 81 (DEFAULT_PITCH, 0w0), 82 (FIXED_PITCH, 0w1), 83 (VARIABLE_PITCH, 0w2)] 84 and tab2 = [ 85 (FF_DONTCARE, 0wx00 (* (0<<4) Don't care or don't know. *)), 86 (FF_ROMAN, 0wx10 (* (1<<4) Variable stroke width, serifed. *)), 87 (FF_SWISS, 0wx20 (* (2<<4) Variable stroke width, sans~serifed. *)), 88 (FF_MODERN, 0wx30 (* (3<<4) Constant stroke width, serifed or sans~serifed. *)), 89 (FF_SCRIPT, 0wx40 (* (4<<4) Cursive, etc. *)), 90 (FF_DECORATIVE, 0wx50 (* (5<<4) Old English, etc. *))] 91 val (fromPitch, toPitch) = tableLookup(tab1, NONE) 92 and (fromFamily, toFamily) = tableLookup(tab2, NONE) 93 in 94 val toFamily = toFamily (* This is used in GetTextMetrics. *) 95 fun pitchAndFamilyToW8 (pitch, family) = orb(fromPitch pitch, fromFamily family) 96 fun pitchAndFamilyFromW8 i = (toPitch(andb(i, 0w3)), toFamily(andb(i, 0wxf0))) 97 end 98 99 (*TYPE: FontWeight - This type is really int, not an abstract type. *) 100 type FontWeight = int 101 (* Values between 0 and 1000 *) 102 (*val FONTWEIGHT = cLong*) (* It's int for CreateFont but LONG for LONGFONT. *) 103 104 val FW_DONTCARE = 0 105 val FW_THIN = 100 106 val FW_EXTRALIGHT = 200 107 val FW_LIGHT = 300 108 val FW_NORMAL = 400 109 val FW_MEDIUM = 500 110 val FW_SEMIBOLD = 600 111 val FW_BOLD = 700 112 val FW_EXTRABOLD = 800 113 val FW_HEAVY = 900 114 val FW_ULTRALIGHT = FW_EXTRALIGHT 115 val FW_REGULAR = FW_NORMAL 116 val FW_DEMIBOLD = FW_SEMIBOLD 117 val FW_ULTRABOLD = FW_EXTRABOLD 118 val FW_BLACK = FW_HEAVY 119 120 datatype OutputPrecision = OUT_DEFAULT_PRECIS | OUT_STRING_PRECIS | 121 OUT_CHARACTER_PRECIS | OUT_STROKE_PRECIS | OUT_TT_PRECIS | OUT_DEVICE_PRECIS | 122 OUT_RASTER_PRECIS | OUT_TT_ONLY_PRECIS | OUT_OUTLINE_PRECIS | 123 OUT_SCREEN_OUTLINE_PRECIS 124 125 local 126 val tab = [ 127 (OUT_DEFAULT_PRECIS, 0w0: Word8.word), 128 (OUT_STRING_PRECIS, 0w1), 129 (OUT_CHARACTER_PRECIS, 0w2), 130 (OUT_STROKE_PRECIS, 0w3), 131 (OUT_TT_PRECIS, 0w4), 132 (OUT_DEVICE_PRECIS, 0w5), 133 (OUT_RASTER_PRECIS, 0w6), 134 (OUT_TT_ONLY_PRECIS, 0w7), 135 (OUT_OUTLINE_PRECIS, 0w8), 136 (OUT_SCREEN_OUTLINE_PRECIS, 0w9) 137 ] 138 in 139 val (outPrecToW8, outPrecFromW8) = tableLookup(tab, NONE) 140 end 141 142 (* TODO: This is a bit set. *) 143 datatype ClippingPrecision = 144 CLIP_DEFAULT_PRECIS | CLIP_STROKE_PRECIS | CLIP_LH_ANGLES | CLIP_DFA_DISABLE | CLIP_EMBEDDED 145 (* CLIP_CHARACTER_PRECIS and CLIP_TT_ALWAYS "should not be used" 146 [CLIP_DEFAULT_PRECIS] is the same as [] i.e. zero. *) 147 local 148 val tab = [ 149 (CLIP_DEFAULT_PRECIS, 0wx0), 150 (CLIP_STROKE_PRECIS, 0wx2), 151 (CLIP_LH_ANGLES, 0wx10), 152 (CLIP_DFA_DISABLE, 0w40), 153 (CLIP_EMBEDDED, 0w80) 154 ] 155 in 156 val (clipPrecSetToW32, clipPrecSetFromW32) = tableSetLookup(tab, NONE) 157 end 158 159 type LOGFONT = 160 { 161 height : int, 162 width : int, 163 escapement : int, 164 orientation : int, 165 weight : FontWeight, 166 italic : bool, 167 underline : bool, 168 strikeOut : bool, 169 charSet : CharacterSet, 170 outputPrecision: OutputPrecision, 171 clipPrecision : ClippingPrecision list, 172 quality : OutputQuality, 173 pitch: FontPitch, 174 family: FontFamily, 175 faceName : string 176 } 177 178 local 179 val cLogFont = 180 cStruct14(cLong, cLong, cLong, cLong, cLong, cUint8w, cUint8w, cUint8w, cUint8w, 181 cUint8w, cUint8w, cUint8w, cUint8w, cCHARARRAY 32) 182 fun chToB 0w0 = false | chToB _ = true 183 fun bToch false = 0w0 | bToch true = 0w1 184 185 fun toLF(height, width, escapement, orientation, weight, italic, underline, 186 strikeOut, charSet, outputPrecision, clipPrecision, quality, 187 pitchFamily, faceName) : LOGFONT = 188 let 189 val (pitch, family) = pitchAndFamilyFromW8 pitchFamily 190 in 191 {height = height, width = width, escapement = escapement, 192 orientation = orientation, weight = weight, italic = chToB italic, 193 underline = chToB underline, strikeOut = chToB strikeOut, 194 charSet = charsetFromW8 charSet, 195 outputPrecision = outPrecFromW8 outputPrecision, 196 clipPrecision = clipPrecSetFromW32(Word32.fromLargeWord(Word8.toLargeWord clipPrecision)), 197 quality = outQualFromW8 quality, pitch = pitch, family = family, 198 faceName = faceName} 199 end 200 201 fun fromLF ({height, width, escapement, orientation, weight, italic, underline, 202 strikeOut, charSet, outputPrecision, clipPrecision, quality, 203 pitch, family, faceName}: LOGFONT) = 204 let 205 val pitchFamily = pitchAndFamilyToW8(pitch, family) 206 in 207 (height, width, escapement, orientation, weight, bToch italic, 208 bToch underline, bToch strikeOut, charsetToW8 charSet, 209 outPrecToW8 outputPrecision, 210 Word8.fromLargeWord(Word32.toLargeWord (clipPrecSetToW32 clipPrecision)), 211 outQualToW8 quality, pitchFamily, faceName) 212 end 213 in 214 val cLOGFONT = absConversion{abs=toLF, rep=fromLF} cLogFont 215 end 216 end 217end; 218