[MLton-commit] r6226
Vesa Karvonen
vesak at mlton.org
Thu Nov 29 06:02:59 PST 2007
Added support for converting surfaces from pixel format to another.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml
A mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/chest.bmp
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-29 12:32:51 UTC (rev 6225)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-29 14:02:58 UTC (rev 6226)
@@ -66,7 +66,11 @@
type t = Word32.t
structure Format = struct
- type t = {mask : t RGBA.t,
+ type t = {alpha : Word8.t,
+ key : t,
+ bits : Word8.t,
+ bytes : Word8.t,
+ mask : t RGBA.t,
shift : Word8.t RGBA.t,
loss : Word8.t RGBA.t}
end
@@ -89,15 +93,21 @@
type 'a t = (T_SDL_Surface.t, C.rw) C.obj C.ptr'
fun pixelFormat surface = let
val pf = C.Ptr.|*! (C.Get.ptr' (S_SDL_Surface.f_format' (C.Ptr.|*! surface)))
- fun m f = C.Get.uint' (f pf)
- fun s f = C.Get.uchar' (f pf)
- val l = s
+ fun w f = C.Get.uint' (f pf)
+ fun b f = C.Get.uchar' (f pf)
open S_SDL_PixelFormat
in
- {mask = {r = m f_Rmask', g = m f_Gmask', b = m f_Bmask', a = m f_Amask'},
- shift = {r = s f_Rshift', g = s f_Gshift', b = s f_Bshift', a = s f_Ashift'},
- loss = {r = l f_Rloss', g = l f_Gloss', b = l f_Bloss', a = l f_Aloss'}}
+ {alpha = b f_alpha',
+ key = w f_colorkey',
+ bits = b f_BitsPerPixel',
+ bytes = b f_BytesPerPixel',
+ mask = {r=w f_Rmask', g=w f_Gmask', b=w f_Bmask', a=w f_Amask'},
+ 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=b f_Aloss'}}
end
+ fun props s = C.Get.uint' (S_SDL_Surface.f_flags' (C.Ptr.|*! s))
+ fun dim s = {w = C.Get.sint' (S_SDL_Surface.f_w' (C.Ptr.|*! s)),
+ h = C.Get.sint' (S_SDL_Surface.f_h' (C.Ptr.|*! s))}
val free = F_SDL_FreeSurface.f'
val flip = checkInt o F_SDL_Flip.f'
fun update surface = F_SDL_UpdateRect.f' (surface, 0, 0, 0w0, 0w0)
@@ -115,6 +125,28 @@
checkInt (F_SML_SDL_BlitRect.f'
(src, sx, sy, Word.fromInt sw, Word.fromInt sh,
dst, dx, dy, Word.fromInt dw, Word.fromInt dh))
+ fun convert ({alpha, key, bits, bytes, mask, shift, loss} : Pixel.Format.t)
+ flags surface =
+ one (withNew S_SDL_PixelFormat.size)
+ (fn pf => let
+ 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)
+ ; checkPtr (F_SDL_ConvertSurface.f'
+ (surface, C.Ptr.|&! pf, flags))
+ end)
end
structure Video = struct
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml 2007-11-29 12:32:51 UTC (rev 6225)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml 2007-11-29 14:02:58 UTC (rev 6226)
@@ -26,7 +26,7 @@
end
fun demo () = let
- val surface =
+ val display =
SDL.Video.setMode
let open SDL.Prop in
flags ([DOUBLEBUF] @
@@ -34,16 +34,22 @@
{bpp = !Opt.bpp}
{w = !Opt.w, h = !Opt.h}
- val format = SDL.Surface.pixelFormat surface
+ val format = SDL.Surface.pixelFormat display
+ val props = SDL.Surface.props display
- val black = SDL.Pixel.fromRGB format {r=0w000, g=0w000, b=0w000}
- val green = SDL.Pixel.fromRGB format {r=0w000, g=0w255, b=0w000}
- val red = SDL.Pixel.fromRGB format {r=0w255, g=0w000, b=0w000}
- val blue = SDL.Pixel.fromRGB format {r=0w000, g=0w000, b=0w255}
+ val chest = SDL.Surface.convert format props (SDL.Image.loadBMP "chest.bmp")
+ val chestDim as {w = chestW, h = chestH} = SDL.Surface.dim chest
- val xMax = real (!Opt.w - !Opt.size)
- val yMax = real (!Opt.h - !Opt.size)
+ val green = SDL.Pixel.fromRGB format {r=0w000, g=0w128, b=0w000}
+ val red = SDL.Pixel.fromRGB format {r=0w128, g=0w000, b=0w000}
+ val blue = SDL.Pixel.fromRGB format {r=0w000, g=0w000, b=0w128}
+ val w = !Opt.w
+ val h = !Opt.h
+
+ val xMax = real (w - !Opt.size)
+ val yMax = real (h - !Opt.size)
+
val obs =
Vector.tabulate
(!Opt.num,
@@ -56,16 +62,27 @@
fun render () = let
val color = if SDL.Key.isPressed SDL.Key.Sym.SPACE then red else green
+ fun lpX x = let
+ fun lpY y =
+ if h <= y then ()
+ else (SDL.Surface.blitRect
+ chest {pos = {x=0, y=0}, dim = chestDim}
+ display {pos = {x=x, y=y}, dim = chestDim}
+ ; lpY (y + chestH))
+ in
+ if w <= x then ()
+ else (lpY 0 ; lpX (x + chestW))
+ end
in
- SDL.Surface.fill surface black
+ lpX 0
; Vector.app (fn {x, y, ...} =>
SDL.Surface.fillRect
- surface
+ display
color
{dim = obDim,
pos = {x = trunc (!x), y = trunc (!y)}}) obs
; SDL.Surface.fillRect
- surface
+ display
let
open SDL.Mouse.Button
val buttons = SDL.Mouse.getButtons ()
@@ -75,7 +92,7 @@
else blue
end
{dim = obDim, pos = SDL.Mouse.getPos ()}
- ; SDL.Surface.flip surface
+ ; SDL.Surface.flip display
end
fun animate () =
Added: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/chest.bmp
===================================================================
(Binary files differ)
Property changes on: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/chest.bmp
___________________________________________________________________
Name: svn:mime-type
+ image/bmp
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-29 12:32:51 UTC (rev 6225)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-29 14:02:58 UTC (rev 6226)
@@ -61,6 +61,8 @@
structure Surface : sig
type 'a t
val pixelFormat : 'any t -> Pixel.Format.t
+ val props : 'any t -> Prop.flags
+ val dim : 'any t -> Int.t Dim.t
val free : {video : no} t Effect.t
val flip : 'dst t Effect.t
val update : 'dst t Effect.t
@@ -69,6 +71,7 @@
val fillRect : 'dst t -> Pixel.t -> Int.t Rect.t Effect.t
val blit : 'src t -> 'dst t Effect.t
val blitRect : 'src t -> Int.t Rect.t -> 'dst t -> Int.t Rect.t Effect.t
+ val convert : Pixel.Format.t -> Prop.flags -> 'any t -> {video : no} t
end
structure Video : sig
More information about the MLton-commit
mailing list