[MLton-commit] r6233
Vesa Karvonen
vesak at mlton.org
Sat Dec 1 06:06:32 PST 2007
A bit of refactoring.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-30 16:14:48 UTC (rev 6232)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-12-01 14:06:31 UTC (rev 6233)
@@ -59,13 +59,19 @@
structure Pos = struct type 'a t = {x : 'a, y : 'a} end
structure Dim = struct type 'a t = {w : 'a, h : 'a} end
structure Rect = struct type 'a t = {pos : 'a Pos.t, dim : 'a Dim.t} end
- structure RGB = struct type 'a t = {r : 'a, g : 'a, b : 'a} end
+ structure RGB = struct
+ type 'a t = {r : 'a, g : 'a, b : 'a}
+ fun fromRGBA {r, g, b, a = _} = {r = r, g = g, b = b}
+ end
structure RGBA = struct
type 'a t = {r : 'a, g : 'a, b : 'a, a : 'a}
- fun unOp f {r, g, b, a} = {r = f r, g = f g, b = f b, a = f a}
- fun binOp f (l : 'a t, r : 'b t) =
+ fun map f {r, g, b, a} = {r = f r, g = f g, b = f b, a = f a}
+ fun zipWith f (l : 'a t, r : 'b t) =
{r = f (#r l, #r r), g = f (#g l, #g r),
b = f (#b l, #b r), a = f (#a l, #a r)}
+ fun sum op + {r, g, b, a} = r + g + b + a
+ fun binApp e = ignore o zipWith e
+ fun fromRGB a {r, g, b} = {r=r, g=g, b=b, a=a}
end
structure Pixel = struct
@@ -82,23 +88,24 @@
fun bits (t : t) = Word8.toWord (#bits t)
fun bitsRGBA (t : t) =
- RGBA.unOp (fn x => 0w8 - Word8.toWord x) (#loss t)
- val bitsRGB = (fn {r, g, b, ...} => {r = r, g = g, b = b}) o bitsRGBA
+ RGBA.map (fn x => 0w8 - Word8.toWord x) (#loss t)
+ val bitsRGB = RGB.fromRGBA o bitsRGBA
fun fromRGBA (rgba as {r, g, b, a}) : t = let
- val bits = r+g+b+a
+ val bits = RGBA.sum op + rgba
val shift = {b = 0w0, g = b, r = g+b,
a = if 0w0 = a then 0w0 else r+g+b}
- val loss = RGBA.unOp (0w8 <\ op -) rgba
+ val loss = RGBA.map (0w8 <\ op -) rgba
in
{alpha = 0w255, key = 0w0, bits = bits,
bytes = (bits + 0w7) div 0w8,
- mask = RGBA.binOp (fn (s, l) => let
- open Word32
- in
- (0w255 >> Word8.toWord l) << Word8.toWord s
- end)
- (shift, loss),
+ mask = RGBA.zipWith
+ (fn (s, l) => let
+ open Word32
+ in
+ (0w255 >> Word8.toWord l) << Word8.toWord s
+ end)
+ (shift, loss),
shift = shift, loss = loss}
end
@@ -109,51 +116,55 @@
shift = #shift r8g8b8} : t
val r8g8b8a8 = fromRGBA {r=0w8, g=0w8, b=0w8, a=0w8}
+ local
+ open S_SDL_PixelFormat
+ in
+ val f_loss = {r=f_Rloss', g=f_Gloss', b=f_Bloss', a=f_Aloss'}
+ val f_mask = {r=f_Rmask', g=f_Gmask', b=f_Bmask', a=f_Amask'}
+ val f_shift = {r=f_Rshift', g=f_Gshift', b=f_Bshift', a=f_Ashift'}
+ end
+
fun fromSDL pf = let
+ open S_SDL_PixelFormat
fun w f = C.Get.uint' (f pf)
fun b f = C.Get.uchar' (f pf)
- open S_SDL_PixelFormat
- val mask = {r=w f_Rmask', g=w f_Gmask', b=w f_Bmask', a=w f_Amask'}
+ val mask = RGBA.map w f_mask
in
{alpha = b f_alpha', key = w f_colorkey', bits = b f_BitsPerPixel',
bytes = b f_BytesPerPixel', mask = mask,
- shift = {r=b f_Rshift', g=b f_Gshift', b=b f_Bshift', a=b f_Ashift'},
- loss = {r=b f_Rloss', g=b f_Gloss', b=b f_Bloss',
- a=if 0w0 = #a mask then 0w8 else b f_Aloss'}}
+ shift = RGBA.map b f_shift,
+ loss = RGBA.zipWith (fn (m, l) => if 0w0 = m then 0w8 else b l)
+ (mask, f_loss)}
end
fun withSDL ({alpha, key, bits, bytes, mask, shift, loss} : t) =
With.Monad.map
(fn pf => let
- fun w f v = C.Set.uint' (f pf, v)
- fun b f v = C.Set.uchar' (f pf, v)
+ fun w (f, v) = C.Set.uint' (f pf, v)
+ fun b (f, v) = C.Set.uchar' (f pf, v)
open S_SDL_PixelFormat
in
C.Set.ptr' (f_palette' pf, C.Ptr.null')
- ; b f_alpha' alpha
- ; w f_colorkey' key
- ; b f_BitsPerPixel' bits
- ; b f_BytesPerPixel' bytes
- ; b f_Rloss' (#r loss) ; b f_Gloss' (#g loss)
- ; b f_Bloss' (#b loss) ; b f_Aloss' (#a loss)
- ; w f_Rmask' (#r mask) ; w f_Gmask' (#g mask)
- ; w f_Bmask' (#b mask) ; w f_Amask' (#a mask)
- ; b f_Rshift' (#r shift) ; b f_Gshift' (#g shift)
- ; b f_Bshift' (#b shift) ; b f_Ashift' (#a shift)
+ ; b (f_alpha', alpha)
+ ; w (f_colorkey', key)
+ ; b (f_BitsPerPixel', bits)
+ ; b (f_BytesPerPixel', bytes)
+ ; RGBA.binApp b (f_loss, loss)
+ ; RGBA.binApp w (f_mask, mask)
+ ; RGBA.binApp b (f_shift, shift)
; pf
end)
(withNew S_SDL_PixelFormat.size)
end
- fun fromRGBA ({shift, loss, ...} : Format.t) {r, g, b, a} = let
- open Word32
- fun pack (v, s, l) =
- (Word32.fromWord8 v >> Word8.toWord l) << Word8.toWord s
+ fun fromRGBA ({shift, loss, ...} : Format.t) rgba = let
+ open Word32 RGBA
in
- pack (r, #r shift, #r loss) orb pack (g, #g shift, #g loss) orb
- pack (b, #b shift, #b loss) orb pack (a, #a shift, #a loss)
+ sum op orb (zipWith op << (zipWith op >> (map fromWord8 rgba,
+ map Word8.toWord loss),
+ map Word8.toWord shift))
end
- fun fromRGB format {r, g, b} = fromRGBA format {r=r, g=g, b=b, a=0w255}
+ fun fromRGB format = fromRGBA format o RGBA.fromRGB 0w255
end
structure Surface = struct
@@ -309,11 +320,12 @@
structure Mouse = struct
structure Button = struct
open Word8Flags
- val LEFT = Word8.fromLargeInt (SDL_BUTTON SDL_BUTTON_LEFT)
- val MIDDLE = Word8.fromLargeInt (SDL_BUTTON SDL_BUTTON_MIDDLE)
- val RIGHT = Word8.fromLargeInt (SDL_BUTTON SDL_BUTTON_RIGHT)
- val WHEELDOWN = Word8.fromLargeInt (SDL_BUTTON SDL_BUTTON_WHEELDOWN)
- val WHEELUP = Word8.fromLargeInt (SDL_BUTTON SDL_BUTTON_WHEELUP)
+ val ` = Word8.fromLargeInt o SDL_BUTTON
+ val LEFT = `SDL_BUTTON_LEFT
+ val MIDDLE = `SDL_BUTTON_MIDDLE
+ val RIGHT = `SDL_BUTTON_RIGHT
+ val WHEELDOWN = `SDL_BUTTON_WHEELDOWN
+ val WHEELUP = `SDL_BUTTON_WHEELUP
end
local
More information about the MLton-commit
mailing list