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 GdiBase = 20struct 21 local 22 open Foreign Base 23 in 24 local 25 datatype RasterOpCode = 26 W of int 27 and QuaternaryRop = Y of int 28 in 29 type RasterOpCode = RasterOpCode 30 type QuaternaryRop = QuaternaryRop 31 val cRASTEROPCODE = absConversion {abs = W, rep = fn W n => n} cDWORD 32 val cQUATERNARY = absConversion {abs = Y, rep = fn Y n => n} cDWORD 33 34 val SRCCOPY = W (0x00CC0020 (* dest = source *)) 35 val SRCPAINT = W (0x00EE0086 (* dest = source OR dest *)) 36 val SRCAND = W (0x008800C6 (* dest = source AND dest *)) 37 val SRCINVERT = W (0x00660046 (* dest = source XOR dest *)) 38 val SRCERASE = W (0x00440328 (* dest = source AND (NOT dest ) *)) 39 val NOTSRCCOPY = W (0x00330008 (* dest = (NOT source) *)) 40 val NOTSRCERASE = W (0x001100A6 (* dest = (NOT src) AND (NOT dest) *)) 41 val MERGECOPY = W (0x00C000CA (* dest = (source AND pattern) *)) 42 val MERGEPAINT = W (0x00BB0226 (* dest = (NOT source) OR dest *)) 43 val PATCOPY = W (0x00F00021 (* dest = pattern *)) 44 val PATPAINT = W (0x00FB0A09 (* dest = DPSnoo *)) 45 val PATINVERT = W (0x005A0049 (* dest = pattern XOR dest *)) 46 val DSTINVERT = W (0x00550009 (* dest = (NOT dest) *)) 47 val BLACKNESS = W (0x00000042 (* dest = BLACK *)) 48 val WHITENESS = W (0x00FF0062 (* dest = WHITE *)) 49 50 fun MAKEROP4{fore = (W fore): RasterOpCode, back = (W back): RasterOpCode} = 51 Y(IntInf.orb(fore, IntInf.andb(IntInf.<<(back, 0w8), 0xFF000000))) 52 end 53 54 55 (* BITMAPS *) 56 type BITMAP = 57 { width: int, height: int, widthBytes: int, planes: int, bitsPerPixel: int, 58 bits: Word8Vector.vector option } 59 local 60 val bitmapStruct = cStruct7(cLong, cLong, cLong, cLong, cWORD, cWORD, cPointer) 61 val {load = fromCStr, store = toCStr, ctype = lpStruct} = breakConversion bitmapStruct 62 open Memory 63 64 fun storeBmp(v: voidStar, {width, height, widthBytes, planes, bitsPerPixel, bits}: BITMAP) = 65 let 66 val m = case bits of NONE => Memory.null | SOME b => toCWord8vec b 67 in 68 toCStr(v, (0, width, height, widthBytes, planes, bitsPerPixel, m)); 69 fn () => Memory.free m 70 end 71 72 fun loadbmp(v: voidStar): BITMAP = 73 let 74 val (_, width, height, widthBytes, planes, bitsPerPixel, bits) = 75 fromCStr v 76 val bits = 77 if bits = Memory.null 78 then NONE 79 else SOME (fromCWord8vec (bits, height * widthBytes)) 80 in 81 {width = width, height = height, widthBytes = widthBytes, planes = planes, 82 bitsPerPixel = bitsPerPixel, bits = bits} 83 end 84 in 85 val cBITMAP = makeConversion{store=storeBmp, load=loadbmp, ctype = lpStruct} 86 end 87 88 (* Line and Path *) 89 datatype PointType = 90 PT_MOVETO | PT_LINETO | PT_BEZIERTO | PT_LINETOANDCLOSE | PT_BEZIERTOANDCLOSE 91 local 92 val tab = [ 93 (PT_LINETO, 2), 94 (PT_BEZIERTO, 4), 95 (PT_MOVETO, 6), 96 (PT_LINETOANDCLOSE, 3), 97 (PT_BEZIERTOANDCLOSE, 5) 98 ] 99 val (toInt, fromInt) = tableLookup(tab, NONE) 100 in 101 val cPOINTTYPE = 102 absConversion {abs = fromInt, rep = toInt} cUint8 (* Encoded as single bytes *) 103 end 104 105 (* COLORREF - this is an RGB encoded into a 32-bit word. *) 106 abstype COLORREF = C of Word32.word 107 with 108 local 109 open Word32 110 infix 7 andb 111 infix 6 orb 112 infix 4 << >> 113 in 114 fun RGB{red: int, green: int, blue: int} = 115 C(fromInt red andb 0wxff 116 orb (fromInt green andb 0wxff << 0w8) 117 orb (fromInt blue andb 0wxff << 0w16)) 118 119 fun PALETTERGB rgb = let val C r = RGB rgb in C(r orb 0wx02000000) end 120 121 fun toRGB(C p) = 122 { red = toInt(p andb 0wxff), 123 green = toInt((p >> 0w8) andb 0wxff), 124 blue = toInt((p >> 0w16) andb 0wxff) } 125 end 126 val cCOLORREF = absConversion {abs=C, rep = fn(C v) => v} cDWORDw 127 end 128 129 (* Brush *) 130 131 datatype BrushStyle = BS_SOLID | BS_HOLLOW | BS_HATCHED of HatchStyle | BS_PATTERN of HBITMAP 132 (* | BS_DIBPATTERN of PACKEDDIB *) 133 and HatchStyle = 134 HS_HORIZONTAL | HS_VERTICAL | HS_FDIAGONAL | HS_BDIAGONAL | HS_CROSS | HS_DIAGCROSS 135 136 type LOGBRUSH = BrushStyle * COLORREF 137 local 138 val cLBRUSH = cStruct3(cUint, cCOLORREF, cULONG_PTR) 139 val {load=loadStr, store=storeStr, ctype=lbStruct} = breakConversion cLBRUSH 140 val hbtab = [ 141 (HS_HORIZONTAL, 0 (* ~~~~~ *)), 142 (HS_VERTICAL, 1 (* ||||| *)), 143 (HS_FDIAGONAL, 2 (* \\\\\ *)), 144 (HS_BDIAGONAL, 3 (* (* /// *) *)), 145 (HS_CROSS, 4 (* +++++ *)), 146 (HS_DIAGCROSS, 5 (* xxxxx *)) 147 ] 148 val (fromHB, toHB) = tableLookup(hbtab, NONE) 149 val hgdiAsInt = SysWord.toInt o Memory.voidStar2Sysword o voidStarOfHandle 150 and intAsHgdi = handleOfVoidStar o Memory.sysWord2VoidStar o SysWord.fromInt 151 152 fun storeLB(m, (BS_SOLID, cr)) = storeStr(m, (0, cr, 0)) 153 | storeLB(m, (BS_HOLLOW, cr)) = storeStr(m, (1, cr (* actually ignored *), 0)) 154 | storeLB(m, (BS_HATCHED hs, cr)) = storeStr(m, (2, cr, fromHB hs)) 155 | storeLB(m, (BS_PATTERN hb, cr)) = 156 storeStr(m, (3, cr (* actually ignored *), hgdiAsInt hb)) 157 (* | toLB(BS_DIBPATTERN dp, cr) = toStr(5, cr (* treated specially *), ??? dp) *) 158 159 fun loadLB (v: Memory.voidStar): LOGBRUSH = 160 let 161 val (t, cr, i) = loadStr v 162 in 163 case t of 164 0 => (BS_SOLID, cr) 165 | 1 => (BS_HOLLOW, cr) 166 | 2 => (BS_HATCHED(toHB i), cr) 167 | 3 => (BS_PATTERN(intAsHgdi i), cr) 168 | _ => raise Fail "Unknown brush type" 169 end 170 in 171 val cHATCHSTYLE = absConversion {abs = toHB, rep = fromHB} cInt 172 val cLOGBRUSH = makeConversion{load=loadLB, store=storeLB, ctype = lbStruct} 173 end 174 175 (* Pen *) 176 177 (* This is confused. Many of these are only applicable for ExtCreatePen and most are 178 mutually exclusive. *) 179 datatype PenStyle = PS_SOLID | PS_DASH | PS_DOT | PS_DASHDOT | PS_DASHDOTDOT | PS_NULL | 180 PS_INSIDEFRAME | PS_USERSTYLE | PS_ALTERNATE | PS_ENDCAP_ROUND | PS_ENDCAP_SQUARE | 181 PS_ENDCAP_FLAT | PS_JOIN_ROUND | PS_JOIN_BEVEL | PS_JOIN_MITER | PS_COSMETIC | PS_GEOMETRIC 182 183 184 type LOGPEN = PenStyle * int option * COLORREF 185 186 local 187 val LPEN = cStruct3(cUintw, cPoint, cCOLORREF) 188 val {load=loadStr, store=storeStr, ctype=lpStruct} = breakConversion LPEN 189 val tab = [ 190 (PS_SOLID, 0w0), 191 (PS_DASH, 0w1 (* ~~~~~~~ *)), 192 (PS_DOT, 0w2 (* ....... *)), 193 (PS_DASHDOT, 0w3 (* _._._._ *)), 194 (PS_DASHDOTDOT, 0w4 (* _.._.._ *)), 195 (PS_NULL, 0w5), 196 (PS_INSIDEFRAME, 0w6), 197 (PS_USERSTYLE, 0w7), 198 (PS_ALTERNATE, 0w8), 199 (PS_ENDCAP_ROUND, 0wx00000000), 200 (PS_ENDCAP_SQUARE, 0wx00000100), 201 (PS_ENDCAP_FLAT, 0wx00000200), 202 (PS_JOIN_ROUND, 0wx00000000), 203 (PS_JOIN_BEVEL, 0wx00001000), 204 (PS_JOIN_MITER, 0wx00002000), 205 (PS_COSMETIC, 0wx00000000), 206 (PS_GEOMETRIC, 0wx00010000) 207 ] 208 val (fromPS, toPS) = tableLookup(tab, NONE) 209 210 fun storeLP(m, (ps, width, cr): LOGPEN) = 211 storeStr(m, (fromPS ps, {x=getOpt(width, 0), y=0}, cr)) 212 213 fun loadLP v: LOGPEN = 214 let 215 val (ps, {x=width, ...}, cr) = loadStr v 216 in 217 (toPS ps, case width of 0 => NONE | i => SOME i, cr) 218 end 219 in 220 val cPENSTYLE = tableSetConversion(tab, NONE) 221 val cLOGPEN = makeConversion{store=storeLP, load=loadLP, ctype=lpStruct} 222 end 223 224 (* Transform *) 225 datatype MapMode = MM_TEXT | MM_LOMETRIC | MM_HIMETRIC | MM_LOENGLISH | MM_HIENGLISH | 226 MM_TWIPS | MM_ISOTROPIC | MM_ANISOTROPIC 227 val MM_MIN = MM_TEXT 228 val MM_MAX = MM_ANISOTROPIC 229 val MM_MAX_FIXEDSCALE = MM_TWIPS 230 231 local 232 val tab = [ 233 (MM_TEXT, 1), 234 (MM_LOMETRIC, 2), 235 (MM_HIMETRIC, 3), 236 (MM_LOENGLISH, 4), 237 (MM_HIENGLISH, 5), 238 (MM_TWIPS, 6), 239 (MM_ISOTROPIC, 7), 240 (MM_ANISOTROPIC, 8) 241 ] 242 (* SetMapMode and GetMapMode return 0 in the event of an error. *) 243 fun toInt _ = raise Match 244 fun fromInt i = (checkResult(i <> 0); raise Match); 245 in 246 val cMAPMODE = tableConversion(tab, SOME(fromInt, toInt)) cInt (* int for Get/SetMapMode *) 247 end 248 249 (* REGIONS *) 250 local 251 datatype RegionOperation = 252 W of int 253 in 254 type RegionOperation = RegionOperation 255 val REGIONOPERATION = absConversion {abs = W, rep = fn W n => n} cInt 256 257 val RGN_ERROR = W (0) 258 val RGN_AND = W (1) 259 val RGN_OR = W (2) 260 val RGN_XOR = W (3) 261 val RGN_DIFF = W (4) 262 val RGN_COPY = W (5) 263 end 264 265 local 266 datatype ResultRegion = 267 W of int 268 in 269 type ResultRegion = ResultRegion 270 val RESULTREGION = absConversion {abs = W, rep = fn W n => n} cInt 271 272 val ERROR = W (0) 273 val NULLREGION = W (1) 274 val SIMPLEREGION = W (2) 275 val COMPLEXREGION = W (3) 276 end 277 278 279 type METAFILEPICT = {mm: MapMode, size: SIZE, hMF: HMETAFILE} 280 281 local 282 val metaFilePict = cStruct3(cMAPMODE, cSize, cHMETAFILE) 283 val {store=storeMfp, load=loadMfp, ctype=mfpStruct} = breakConversion metaFilePict 284 fun storeCMfp(m, ({mm, size, hMF}: METAFILEPICT)) = storeMfp(m, (mm, size, hMF)) 285 fun loadCMfp v : METAFILEPICT = 286 let val (mm, size, hMF) = loadMfp v in {mm=mm, size=size, hMF=hMF} end 287 in 288 (* This is needed in the Clipboard structure. *) 289 val cMETAFILEPICT = makeConversion{store=storeCMfp, load=loadCMfp, ctype=mfpStruct} 290 end 291 292 293 end 294end; 295