1(* 2 Copyright (c) 2001-7, 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 Bitmap: 20 sig 21 type HBITMAP and HDC 22 type COLORREF = Color.COLORREF 23 type RECT = { top: int, left: int, bottom: int, right: int } 24 type SIZE = { cx: int, cy: int } 25 datatype BitmapCompression = BI_BITFIELDS | BI_RGB | BI_RLE4 | BI_RLE8 26 datatype FloodFillMode = FLOODFILLBORDER | FLOODFILLSURFACE 27 28 type BITMAP = 29 { width: int, height: int, widthBytes: int, planes: int, bitsPerPixel: int, 30 bits: Word8Vector.vector option } 31 32 type StretchMode 33 val BLACKONWHITE : StretchMode 34 val COLORONCOLOR : StretchMode 35 val HALFTONE : StretchMode 36 val MAXSTRETCHBLTMODE : StretchMode 37 val WHITEONBLACK : StretchMode 38 39 type RasterOpCode 40 val BLACKNESS : RasterOpCode 41 val DSTINVERT : RasterOpCode 42 val MERGECOPY : RasterOpCode 43 val MERGEPAINT : RasterOpCode 44 val NOTSRCCOPY : RasterOpCode 45 val NOTSRCERASE : RasterOpCode 46 val PATCOPY : RasterOpCode 47 val PATINVERT : RasterOpCode 48 val PATPAINT : RasterOpCode 49 val SRCAND : RasterOpCode 50 val SRCCOPY : RasterOpCode 51 val SRCERASE : RasterOpCode 52 val SRCINVERT : RasterOpCode 53 val SRCPAINT : RasterOpCode 54 val WHITENESS : RasterOpCode 55 56 val BitBlt : HDC * int * int * int * int * HDC * int * int * RasterOpCode -> unit 57 val CreateBitmap : 58 {bits: Word8Vector.vector option, width: int, height: int, 59 planes: int, bitsPerPixel: int} -> HBITMAP 60 val CreateBitmapIndirect : BITMAP -> HBITMAP 61 val CreateCompatibleBitmap : HDC * int * int -> HBITMAP 62 val ExtFloodFill : HDC * int * int * COLORREF * FloodFillMode -> unit 63 val GetBitmapBits : HBITMAP * int -> Word8Vector.vector 64 val GetBitmapDimensionEx : HBITMAP -> SIZE 65 val GetPixel : HDC * int * int -> COLORREF 66 val GetStretchBltMode : HDC -> StretchMode 67 68 type QuaternaryRop 69 val MAKEROP4 : {back: RasterOpCode, fore: RasterOpCode} -> QuaternaryRop 70 val MaskBlt : 71 HDC * int * int * int * int * HDC * int * int * 72 HBITMAP * int * int * QuaternaryRop -> unit 73 74 (*val PlgBlt : HDC * RECT * HDC * RECT * HBITMAP * int * int -> unit*) 75 val SetBitmapBits : HBITMAP * Word8Vector.vector -> unit 76 val SetBitmapDimensionEx : HBITMAP * int * int * SIZE -> SIZE 77 val SetPixel : HDC * int * int * COLORREF -> COLORREF 78 val SetStretchBltMode : HDC * StretchMode -> unit 79 val StretchBlt : 80 HDC * int * int * int * int * HDC * int * int * int * int * RasterOpCode -> unit 81 82 type BITMAPINFOHEADER = 83 { 84 width: int, height: int, planes: int, bitsPerPixel: int, 85 compression: BitmapCompression, sizeImage: int, xPelsPerM: int, 86 yPelsPerM: int, clrUsed: int, clrImportant: int 87 } 88 (* ML extension to extract the information from a DIB. *) 89 val getBitmapInfoHdr: Word8Vector.vector -> BITMAPINFOHEADER 90 val GetDIBits: HDC * HBITMAP * int * int * BITMAPINFOHEADER option -> Word8Vector.vector 91 val SetDIBits: HDC * HBITMAP * int * int * Word8Vector.vector -> unit 92 93 end = 94struct 95 local 96 open Foreign Base 97 98 fun checkBitmap c = (checkResult(not(isHgdiObjNull c)); c) 99 in 100 type HDC = HDC and HBITMAP = HBITMAP 101 type COLORREF = Color.COLORREF 102 type SIZE = SIZE and RECT = RECT 103 104 open GdiBase 105 106 local 107 datatype StretchMode = 108 W of int 109 in 110 type StretchMode = StretchMode 111 val STRETCHMODE = absConversion {abs = W, rep = fn W n => n} cInt 112 113 val BLACKONWHITE = W (1) 114 val WHITEONBLACK = W (2) 115 val COLORONCOLOR = W (3) 116 val HALFTONE = W (4) 117 val MAXSTRETCHBLTMODE = W (4) 118 end 119 120 (*TYPE: FloodFillMode *) 121 datatype FloodFillMode = FLOODFILLBORDER | FLOODFILLSURFACE 122 local 123 val tab = [ 124 (FLOODFILLBORDER, 0), 125 (FLOODFILLSURFACE, 1) 126 ] 127 128 in 129 val FLOODFILLMODE = tableConversion(tab, NONE) cUint 130 end 131 132 val ExtFloodFill = 133 winCall5 (gdi "ExtFloodFill") 134 (cHDC,cInt,cInt,cCOLORREF,FLOODFILLMODE) (successState "ExtFloodFill") 135 136 val GetPixel = winCall3 (gdi "GetPixel") (cHDC,cInt,cInt) cCOLORREF 137 val SetPixel = winCall4 (gdi "SetPixel") (cHDC,cInt,cInt, cCOLORREF) cCOLORREF 138 val BitBlt = winCall9 (gdi "BitBlt") (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cRASTEROPCODE) 139 (successState "BitBlt") 140 141 142 val CreateCompatibleBitmap = 143 checkBitmap o 144 winCall3 (gdi "CreateCompatibleBitmap") (cHDC,cInt,cInt) cHBITMAP 145 146 147 val GetStretchBltMode = winCall1 (gdi "GetStretchBltMode") (cHDC) STRETCHMODE 148 149 (* TODO: The raster op is supposed to be a combined operation for the foreground and 150 background. *) 151 val MaskBlt = winCall12(gdi "MaskBlt") (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cHBITMAP,cInt, 152 cInt,cQUATERNARY) (successState "MaskBlt") 153 154 val SetStretchBltMode = winCall2(gdi "SetStretchBltMode") (cHDC,STRETCHMODE) (successState "SetStretchBltMode") 155 156 val StretchBlt = 157 winCall11(gdi "StretchBlt") 158 (cHDC,cInt,cInt,cInt,cInt,cHDC,cInt,cInt,cInt,cInt,cRASTEROPCODE) (successState "StretchBlt") 159 160 (* This definitely has the wrong type. *) 161 (*val PlgBlt = winCall7 (gdi "PlgBlt")(cHDC,RECT,cHDC,RECT,HBITMAP,XCOORD,YCOORD) 162 (successState "PlgBlt")*) 163 164 165 local 166 val setBitmapDimensionEx = 167 winCall4 (gdi "SetBitmapDimensionEx") (cHBITMAP, cInt, cInt, cStar cSize) (successState "SetBitmapDimensionEx") 168 in 169 fun SetBitmapDimensionEx(hbm, width, height, s) = 170 let 171 val r = ref s 172 in 173 setBitmapDimensionEx(hbm, width, height, r); 174 !r 175 end 176 end 177 local 178 val getBitmapDimensionEx = 179 winCall2 (gdi "GetBitmapDimensionEx") (cHBITMAP, cStar cSize) (successState "SetBitmapDimensionEx") 180 in 181 fun GetBitmapDimensionEx hbm = 182 let 183 val r = ref {cx=0, cy=0} 184 in 185 getBitmapDimensionEx(hbm, r); 186 !r 187 end 188 end 189 190 val CreateBitmapIndirect = 191 checkBitmap o 192 winCall1 (gdi "CreateBitmapIndirect") (cConstStar cBITMAP) cHBITMAP 193 194 local 195 val cbm = checkBitmap o 196 winCall5 (gdi "CreateBitmap") (cInt, cInt, cInt, cInt, cPointer) cHBITMAP 197 in 198 fun CreateBitmap{width, height, planes, bitsPerPixel, bits} = 199 let 200 val vec = case bits of NONE => Memory.null | SOME v => toCWord8vec v 201 val res = 202 cbm(width, height, planes, bitsPerPixel, vec) 203 handle ex => (Memory.free vec; raise ex) 204 in 205 Memory.free vec; 206 checkBitmap res 207 end 208 end 209(* 210 local 211 (* RGBQUAD values are four bytes of blue, green, red and a reserved byte. *) 212 val RGBQUAD = cStruct4(cUint8, cUint8, cUint8, cUint8) 213 fun from v = 214 let val (b, g, r, _) = v in {red = r, blue = b, green = g} end 215 fun to {red, green, blue} = (blue, green, red, 0) 216 in 217 val RGBQUAD = absConversion {rep=to, abs=from} RGBQUAD 218 end*) 219 220 (*TYPE: BitmapCompression *) 221 datatype BitmapCompression = BI_RGB | BI_RLE8 | BI_RLE4 | BI_BITFIELDS 222 223 local 224 val tab = [ 225 (BI_RGB, 0), 226 (BI_RLE8, 1), 227 (BI_RLE4, 2), 228 (BI_BITFIELDS, 3) 229 ] 230 in 231 val (fromComp, toComp) = tableLookup(tab, NONE) 232 val BITCOMPRESSION = absConversion {abs = toComp, rep = fromComp} cDWORD 233 end 234 235 type BITMAPINFOHEADER = 236 { 237 width: int, height: int, planes: int, bitsPerPixel: int, 238 compression: BitmapCompression, sizeImage: int, xPelsPerM: int, 239 yPelsPerM: int, clrUsed: int, clrImportant: int 240 } 241 242 (* Device-independent bitmaps are intended to be used for storing and 243 transferring bitmaps. I've written this code to simplify the process 244 of packing and unpacking them. In particular it takes care of the 245 calculating the header size which is generally a bit of a pain. DCJM. *) 246 fun getBitmapInfoHdr(w: Word8Vector.vector): BITMAPINFOHEADER = 247 let 248 val size = LargeWord.toInt(PackWord32Little.subVec(w, 0)) 249 (* Check that the size of the structure given by the 250 first word is less than the overall size. There are 251 various extended versions of the BITMAPINFOHEADER structure 252 but we only look at the fields in the basic one. *) 253 val _ = 254 if size > Word8Vector.length w 255 then raise Fail "Bitmap length field is wrong" 256 else () 257 val width = LargeWord.toIntX(PackWord32Little.subVecX(w, 1)) 258 val height = LargeWord.toIntX(PackWord32Little.subVecX(w, 2)) 259 val planes = LargeWord.toIntX(PackWord16Little.subVecX(w, 6)) 260 val bitsPerPixel = LargeWord.toIntX(PackWord16Little.subVecX(w, 7)) 261 val compression = toComp(LargeWord.toIntX(PackWord32Little.subVecX(w, 4))) 262 val sizeImage = LargeWord.toIntX(PackWord32Little.subVecX(w, 5)) 263 val xPelsPerM = LargeWord.toIntX(PackWord32Little.subVecX(w, 6)) 264 val yPelsPerM = LargeWord.toIntX(PackWord32Little.subVecX(w, 7)) 265 val clrUsed = LargeWord.toIntX(PackWord32Little.subVecX(w, 8)) 266 val clrImportant = LargeWord.toIntX(PackWord32Little.subVecX(w, 9)) 267 in 268 { width = width, height = height, bitsPerPixel = bitsPerPixel, 269 planes = planes, compression = compression, sizeImage = sizeImage, 270 xPelsPerM = xPelsPerM, yPelsPerM = yPelsPerM, clrUsed = clrUsed, 271 clrImportant = clrImportant } 272 end 273 274 local 275 val DIB_RGB_COLORS = 0 276 (*val DIB_PAL_COLORS = 1*) 277 278 val BITMAPINFOHEADER = cStruct11(cDWORD, cLong, cLong, cWORD, cWORD, BITCOMPRESSION, 279 cDWORD, cLong, cLong, cDWORD, cDWORD) 280 val {load=fromR, store=toR, ctype={size=rtypeSize, ...}} = 281 breakConversion BITMAPINFOHEADER 282 283 val getDIBits = winCall7 (gdi "GetDIBits") 284 (cHDC, cHBITMAP, cUint, cUint, cPointer, cPointer, cUint) cInt 285 286 val setDIBits = winCall7 (gdi "SetDIBits") 287 (cHDC, cHBITMAP, cUint, cUint, cPointer, cPointer, cUint) cInt 288 289 val sizeColourEntry = #size LowLevel.cTypeInt (* Should this RGBQUAD? *) 290 291 in 292 (* This is all a bit messy. GetDIBits can be used in a number of ways 293 to get all or part of the information. Passing NULL for the "bits" 294 argument and setting bitsPerPixel to zero in the BITMAPINFO argument 295 simply fills in the BITMAPINFOHEADER. With bitsPerPixel non-zero it 296 builds a colour table on the end of the BITMAPINFO. With "bits" 297 non-NULL it builds the colour table and creates the bitmap. 298 299 If NONE is given as the header it returns a vector containing 300 only the header, allowing getBitmapInfoHdr to be used to unpack it. 301 Otherwise it uses the information in the supplied header to 302 get the bitmap. It ignores the passed in sizeImage because that 303 may be wrong. *) 304 fun GetDIBits(hdc: HDC, hb: HBITMAP, startScan, scanLines, NONE) = 305 let 306 (* Allocate a vector for the result and set the length field 307 and bitsPerPixel. The others don't matter. *) 308 open Memory 309 val v = malloc rtypeSize 310 val _ = toR(v, (Word.toInt rtypeSize, 0, 0, 0, 0, BI_RGB, 0, 0, 0, 0, 0)) 311 val res = 312 getDIBits(hdc, hb, startScan, scanLines, Memory.null, v, DIB_RGB_COLORS) 313 handle ex => (free v; raise ex) 314 in 315 checkResult(res <> 0) handle ex => (free v; raise ex); 316 fromCWord8vec(v, Word.toInt rtypeSize) before free v 317 end 318 319 | GetDIBits(hdc: HDC, hb: HBITMAP, startScan, scanLines, 320 SOME {width, height, planes, bitsPerPixel, compression, sizeImage, 321 xPelsPerM, yPelsPerM, clrUsed, clrImportant}) = 322 let 323 (* The passed in value for sizeImage may be wrong. Call 324 GetDIBits to find the correct value. *) 325 open Memory 326 infix 6 ++ 327 local 328 (* This call will build a colour map so we have to have enough 329 space for it. The biggest possible is with 8 bits. *) 330 val w = malloc (rtypeSize + 0w256 * sizeColourEntry) 331 val _ = toR(w, (Word.toInt rtypeSize, width, height, planes, bitsPerPixel, 332 compression, sizeImage, xPelsPerM, yPelsPerM, clrUsed, 333 clrImportant)) 334 val _ = 335 checkResult(getDIBits(hdc, hb, startScan, scanLines, null, w, DIB_RGB_COLORS) <> 0) 336 handle ex => (free w; raise ex) 337 in 338 val (_, _, _, _, _, _, sizeImage, _, _, _, _) = fromR w 339 val () = free w 340 end 341 342 (* Calculate the size of the palette. *) 343 val numColours = 344 if clrUsed <> 0 345 then clrUsed 346 else if bitsPerPixel < 16 347 then IntInf.<<(1, Word.fromInt bitsPerPixel) 348 else if compression = BI_BITFIELDS 349 then 3 (* These are DWORD colour masks not RGBQUADS. *) 350 else 0 (* No colour table. *) 351 val bitOffset = rtypeSize + Word.fromInt numColours * sizeColourEntry 352 val size = bitOffset + Word.fromInt sizeImage 353 val w = malloc size 354 val _ = toR(w, (Word.toInt rtypeSize, width, height, planes, bitsPerPixel, 355 compression, sizeImage, xPelsPerM, yPelsPerM, clrUsed, 356 clrImportant)) 357 val _ = 358 checkResult(getDIBits(hdc, hb, startScan, scanLines, w ++ bitOffset, w, DIB_RGB_COLORS) <> 0) 359 handle ex => (free w; raise ex) 360 in 361 fromCWord8vec (w, Word.toInt size) before free w 362 end 363 364 365 fun SetDIBits(hdc, hb, startScan, scanLines, w) = 366 let 367 open Memory 368 infix 6 ++ 369 val v = toCWord8vec w 370 (*val v = toCbytes w*) 371 (* We need to work out the offset of the bits. For this we need 372 the size of the header structure (which may not be a 373 BITMAPINFOHEADER but some other version of it), the number of 374 colours and the compression. *) 375 val hdrSize = #1 (fromR v) 376 val { clrUsed, compression, bitsPerPixel, ...} = getBitmapInfoHdr w 377 val numColours = 378 if clrUsed <> 0 379 then clrUsed 380 else if bitsPerPixel < 16 381 then IntInf.<<(1, Word.fromInt bitsPerPixel) 382 else if compression = BI_BITFIELDS 383 then 3 (* These are DWORD colour masks not RGBQUADS. *) 384 else 0 (* No colour table. *) 385 val bitOffset = Word.fromInt hdrSize +Word.fromInt numColours * sizeColourEntry 386 val res = setDIBits(hdc, hb, startScan, scanLines, 387 v ++ bitOffset, v, DIB_RGB_COLORS) 388 in 389 checkResult(res <> 0) 390 end 391 end 392 393 (* GetBitmapBits and SetBitmapBits are supposedly obsolete but they're useful 394 for copying device-dependent bitmaps. *) 395 fun GetBitmapBits(hbm, bytes): Word8Vector.vector = 396 let 397 val gbb = winCall3 (gdi "GetBitmapBits") (cHBITMAP, cDWORD, cPointer) cLong 398 open Memory 399 val buff = malloc (Word.fromInt bytes) 400 val () = 401 checkResult(gbb(hbm, bytes, buff) > 0) 402 handle ex => (free buff; raise ex) 403 in 404 fromCWord8vec (buff, bytes) before free buff 405 end 406 407 fun SetBitmapBits(hbm, w) = 408 let 409 val sbb = winCall3 (gdi "SetBitmapBits") (cHBITMAP, cDWORD, cPointer) cLong 410 val buff = toCWord8vec w 411 open Memory 412 val () = 413 checkResult(sbb(hbm, Word8Vector.length w, buff) > 0) 414 handle ex => (free buff; raise ex) 415 in 416 free buff 417 end 418 419 (* 420 Other Bitmap functions: 421 AlphaBlend 422 CreateDIBitmap 423 CreateDIBSection - This creates an area of memory to write to - won't work in ML. 424 GetDIBColorTable 425 GradientFill 426 SetDIBColorTable 427 SetDIBitsToDevice 428 SetPixelV 429 StretchDIBits 430 TransparentBlt 431 *) 432 433 end 434end; 435