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 Color (* Use American spelling for consistency. *): 20 sig 21 type HPALETTE and HDC 22 23 datatype 24 PaletteEntryFlag = PC_EXPLICIT | PC_NOCOLLAPSE | PC_NULL | PC_RESERVED 25 type PALETTEENTRY = {red: int, green: int, blue: int, flags: PaletteEntryFlag} 26 27 type COLORREF 28 val toRGB : 29 COLORREF -> {red: Int.int, blue: Int.int, green: Int.int} 30 val RGB : {red: int, blue: int, green: int} -> COLORREF 31 val PALETTERGB : {red: int, blue: int, green: int} -> COLORREF 32 33 type SystemPaletteUse 34 val SYSPAL_ERROR : SystemPaletteUse 35 val SYSPAL_NOSTATIC : SystemPaletteUse 36 val SYSPAL_STATIC : SystemPaletteUse 37 38 val AnimatePalette : HPALETTE * int * PALETTEENTRY list -> bool 39 val CreateHalftonePalette : HDC -> HPALETTE 40 val CreatePalette : PALETTEENTRY list -> HPALETTE 41 val GetNearestColor : HDC * COLORREF -> COLORREF 42 val GetNearestPaletteIndex : HPALETTE * COLORREF -> int 43 val GetPaletteEntries : HPALETTE * int * int -> PALETTEENTRY list 44 val GetSystemPaletteEntries : HDC * int * int -> PALETTEENTRY list 45 val GetSystemPaletteUse : HDC -> SystemPaletteUse 46 val RealizePalette : HDC -> int 47 val ResizePalette : HPALETTE * int -> unit 48 val SelectPalette : HDC * HPALETTE * bool -> HPALETTE 49 val SetPaletteEntries : HPALETTE * int * PALETTEENTRY list -> unit 50 val SetSystemPaletteUse : HDC * SystemPaletteUse -> SystemPaletteUse 51 val UnrealizeObject : HPALETTE -> unit 52 val UpdateColors : HDC -> unit 53 end = 54struct 55 local 56 open Foreign Base 57 in 58 type HDC = HDC and HPALETTE = HPALETTE 59 open GdiBase 60 61 62 local 63 datatype SystemPaletteUse = 64 W of int 65 in 66 type SystemPaletteUse = SystemPaletteUse 67 val SYSTEMPALETTEUSE = absConversion {abs = W, rep = fn W n => n} cUint 68 69 val SYSPAL_ERROR = W (0) 70 val SYSPAL_STATIC = W (1) 71 val SYSPAL_NOSTATIC = W (2) 72 end 73 74 datatype PaletteEntryFlag = PC_NULL | PC_RESERVED | PC_EXPLICIT | PC_NOCOLLAPSE 75 type PALETTEENTRY = {red: int, green: int, blue: int, flags: PaletteEntryFlag} 76 77 local 78 val cPaletteEnt = cStruct4(cUint8, cUint8, cUint8, cUint8) 79 val { load=loadPE, store=storePE, ctype={size=peSize, ...} } = breakConversion cPaletteEnt 80 81 fun toPE({red, green, blue, flags}: PALETTEENTRY) = 82 let 83 val f = 84 case flags of PC_NULL => 0 | PC_RESERVED => 1 85 | PC_EXPLICIT => 2 | PC_NOCOLLAPSE => 4 86 in 87 (red, green, blue, f) 88 end 89 fun fromPE (red, green, blue, f): PALETTEENTRY = 90 let 91 val flags = 92 case f of 93 0 => PC_NULL 94 | 1 => PC_RESERVED 95 | 2 => PC_EXPLICIT 96 | 4 => PC_NOCOLLAPSE 97 | _ => raise Match 98 in 99 {red=red, green=green, blue=blue, flags=flags} 100 end 101 102 open Memory 103 infix 6 ++ 104 val logPal = cStruct2(cWORD, cWORD) 105 val {store=storeLP, ctype={size=lpSize, ...}, ...} = breakConversion logPal 106 in 107 (* Unfortunately we can't make a simple conversion here. When we load 108 the entries we need to know how many we're loading. *) 109 fun allocPEVec n = malloc(Word.fromInt n * peSize) 110 val freePEVec = free 111 112 local 113 (* Copy the elements into the array. *) 114 fun doStore (pe: PALETTEENTRY, vec) = 115 ( 116 ignore(storePE(vec, toPE pe)); (* Ignore result - nothing to free *) 117 vec ++ peSize 118 ) 119 in 120 fun palListToC pl = 121 let 122 val count = List.length pl 123 val vec = allocPEVec count 124 val _ = List.foldl doStore vec pl 125 in 126 (vec, count) 127 end 128 129 fun logPaletteToC pl = 130 let 131 (* A logical palette has two additional words at the start. *) 132 val count = List.length pl 133 val vec = malloc(Word.fromInt count * peSize + lpSize) 134 val _ = storeLP(vec, (0x300, count)) 135 val _ = List.foldl doStore (vec ++ lpSize) pl 136 in 137 vec 138 end 139 end 140 141 fun palListFromC(vec, count) = 142 let 143 fun loadPalE n = fromPE(loadPE(vec ++ Word.fromInt n * peSize)) 144 in 145 List.tabulate(count, loadPalE) 146 end 147 end 148 149 val GetSystemPaletteUse = winCall1(gdi "GetSystemPaletteUse") (cHDC) SYSTEMPALETTEUSE 150 val RealizePalette = winCall1(gdi "RealizePalette") (cHDC) cUint 151 val ResizePalette = winCall2(gdi "ResizePalette") (cHPALETTE,cUint) (successState "ResizePalette") 152 val SelectPalette = winCall3(gdi "SelectPalette") (cHDC,cHPALETTE,cBool) cHPALETTE 153 val SetSystemPaletteUse = winCall2(gdi "SetSystemPaletteUse") (cHDC,SYSTEMPALETTEUSE) SYSTEMPALETTEUSE 154 val UpdateColors = winCall1(gdi "UpdateColors") (cHDC) (successState "UpdateColors") 155 val CreateHalftonePalette = winCall1(gdi "CreateHalftonePalette") (cHDC) cHPALETTE 156 val GetNearestColor = winCall2 (gdi "GetNearestColor") (cHDC,cCOLORREF) cCOLORREF 157 val GetNearestPaletteIndex = winCall2 (gdi "GetNearestPaletteIndex") (cHPALETTE,cCOLORREF) cUint 158 val UnrealizeObject = winCall1(gdi "UnrealizeObject") (cHPALETTE) (successState "UnrealizeObject") 159 160 local 161 val animatePalette = 162 winCall4 (gdi "AnimatePalette") (cHPALETTE, cUint, cUint, cPointer) (cBool) 163 in 164 fun AnimatePalette (h,start,pl) = 165 let 166 val (vec, count) = palListToC pl 167 val res = 168 animatePalette(h, start, count, vec) 169 handle ex => (freePEVec vec; raise ex) 170 val () = freePEVec vec 171 in 172 res 173 end 174 end 175 176 local 177 val createPalette = winCall1 (gdi "CreatePalette") (cPointer) (cHPALETTE) 178 in 179 fun CreatePalette pl = 180 let 181 val vec = logPaletteToC pl 182 val res = 183 createPalette vec handle ex => (freePEVec vec; raise ex) 184 val () = freePEVec vec 185 val () = checkResult(not(isHNull res)) 186 in 187 res 188 end 189 end 190 191 local 192 val getPaletteEntries = 193 winCall4 (gdi "GetPaletteEntries") (cHPALETTE, cUint, cUint, cPointer) cUint 194 in 195 fun GetPaletteEntries (h, start, no) = 196 let 197 val vec = allocPEVec no 198 val res = getPaletteEntries (h, start, no, vec) 199 (* The result is zero if error *) 200 val result = palListFromC(vec, res) 201 val () = freePEVec vec 202 val () = checkResult(res <> 0) 203 in 204 result 205 end 206 end 207 208 local 209 val getSystemPaletteEntries = 210 winCall4 (gdi "GetSystemPaletteEntries") (cHDC, cUint, cUint, cPointer) cUint 211 in 212 fun GetSystemPaletteEntries (h, start, no) = 213 let 214 val vec = allocPEVec no 215 val res = getSystemPaletteEntries (h, start, no, vec) 216 (* The result is zero if error *) 217 val result = palListFromC(vec, res) 218 val () = freePEVec vec 219 val () = checkResult(res <> 0) 220 in 221 result 222 end 223 end 224 225 local 226 val setPaletteEntries = 227 winCall4 (gdi "SetPaletteEntries") (cHPALETTE, cUint, cUint, cPointer) cUint 228 in 229 fun SetPaletteEntries (h, start,pl) = 230 let 231 val (vec, count) = palListToC pl 232 val res = 233 setPaletteEntries(h, start, count, vec) 234 handle ex => (freePEVec vec; raise ex) 235 val () = freePEVec vec 236 in 237 checkResult(res <> 0) 238 end 239 end 240 (* 241 Other Colour functions: 242 GetColorAdjustment 243 GetSystemPaletteUse 244 SetColorAdjustment 245 *) 246 247 end 248end; 249 250(* Install a pretty printer for COLORREF. *) 251local 252 open Color 253 fun printColorRef _ _ x = 254 let 255 val {red, green, blue} = toRGB x 256 in 257 PolyML.PrettyString 258 (concat["RGB{red=", Int.toString red, 259 ",green=", Int.toString green, 260 ",blue=", Int.toString blue, "}"]) 261 end 262in 263 val _ = PolyML.addPrettyPrinter printColorRef 264end; 265