[MLton-commit] r6210
Vesa Karvonen
vesak at mlton.org
Mon Nov 26 13:11:18 PST 2007
Theoretically enough functionality to render some rectangles on screen.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
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-26 21:09:47 UTC (rev 6209)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-26 21:11:17 UTC (rev 6210)
@@ -7,10 +7,9 @@
structure Word32Flags = MkWordFlags (Word32)
structure SDL :> SDL = struct
- fun check code =
- if 0 = code
- then ()
- else raise Fail (ZString.toML' (F_SDL_GetError.f' ()))
+ fun raiseError () = raise Fail (ZString.toML' (F_SDL_GetError.f' ()))
+ fun checkInt code = if 0 = code then () else raiseError ()
+ fun checkPtr ptr = if C.Ptr.isNull' ptr then ptr else raiseError ()
structure Init = struct
open Word32Flags
@@ -24,9 +23,63 @@
val EVENTTHREAD = `SDL_INIT_EVENTTHREAD
val EVERYTHING = `SDL_INIT_EVERYTHING
end
- val init = check o F_SDL_Init.f'
- val initSubSystem = check o F_SDL_InitSubSystem.f'
+ val init = checkInt o F_SDL_Init.f'
+ val initSubSystem = checkInt o F_SDL_InitSubSystem.f'
val quitSubSystem = F_SDL_QuitSubSystem.f'
val wasInit = F_SDL_WasInit.f'
val quit = F_SDL_Quit.f'
+
+ structure Prop = struct
+ open Word32Flags
+ val ` = Word32.fromLargeInt
+ val SWSURFACE = `SDL_SWSURFACE
+ val HWSURFACE = `SDL_HWSURFACE
+ val ASYNCBLIT = `SDL_ASYNCBLIT
+ val ANYFORMAT = `SDL_ANYFORMAT
+ val HWPALETTE = `SDL_HWPALETTE
+ val DOUBLEBUF = `SDL_DOUBLEBUF
+ val FULLSCREEN = `SDL_FULLSCREEN
+ val OPENGL = `SDL_OPENGL
+ val OPENGLBLIT = `SDL_OPENGLBLIT
+ val RESIZABLE = `SDL_RESIZABLE
+ val NOFRAME = `SDL_NOFRAME
+ end
+
+ structure Rect = struct
+ type t = {x : Int.t, y : Int.t, w : Int.t, h : Int.t}
+ end
+
+ structure Surface = struct
+ type 'a t = (T_SDL_Surface.t, C.rw) C.obj C.ptr'
+ val free = F_SDL_FreeSurface.f'
+ fun updateRect surface =
+ F_SDL_UpdateRect.f' o
+ (fn NONE => (surface, 0, 0, 0w0, 0w0)
+ | SOME {x, y, w, h} => (surface, x, y, Word.fromInt w, Word.fromInt h))
+ val flip = checkInt o F_SDL_Flip.f'
+ fun getPixelFormat surface =
+ C.Get.ptr' (S_SDL_Surface.f_format' (C.Ptr.|*! surface))
+ end
+
+ structure Color = struct
+ type rgb = {r : Word8.t, g : Word8.t, b : Word8.t}
+ type rgba = {r : Word8.t, g : Word8.t, b : Word8.t, a : Word8.t}
+ type t = Word32.t
+ fun fromRGB surface {r, g, b} =
+ F_SDL_MapRGB.f' (Surface.getPixelFormat surface, r, g, b)
+ fun fromRGBA surface {r, g, b, a} =
+ F_SDL_MapRGBA.f' (Surface.getPixelFormat surface, r, g, b, a)
+ end
+
+ structure Video = struct
+ fun setMode {w, h, bpp, props} =
+ checkPtr (F_SDL_SetVideoMode.f' (w, h, bpp, props))
+ val getSurface = checkPtr o F_SDL_GetVideoSurface.f'
+ end
+
+ fun fillRect surface color =
+ fn NONE => checkInt (F_SDL_FillRect.f' (surface, C.Ptr.null', color))
+ | SOME {x, y, w, h} =>
+ checkInt (F_SML_SDL_FillRect.f'
+ (surface, x, y, Word.fromInt w, Word.fromInt h, color))
end
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-26 21:09:47 UTC (rev 6209)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-26 21:11:17 UTC (rev 6210)
@@ -5,11 +5,12 @@
*)
(**
- * This is a thin wrapper on top of the SDL API. It should be easy to see
- * the correspondence between these specifications and the SDL API. The
- * most visible difference is that instead of returning errors, we raise
- * exceptions. See, for example, [http://www.libsdl.org/cgi/docwiki.cgi/
- * SDL Documentation Wiki] for documentation on the SDL.
+ * This is a fairly thin wrapper on top of the SDL API. It should be
+ * relatively easy to see the correspondence between these specifications
+ * and the SDL API.
+ *
+ * For documentation on the SDL, see, for example, the
+ * [http://www.libsdl.org/cgi/docwiki.cgi/ SDL Documentation Wiki].
*)
signature SDL = sig
structure Init : sig
@@ -28,4 +29,46 @@
val quitSubSystem : Init.flags Effect.t
val wasInit : Init.flags -> Init.flags
val quit : Unit.t Effect.t
+
+ structure Prop : sig
+ include FLAGS where type flags_word = Word32.t
+ val SWSURFACE : flags
+ val HWSURFACE : flags
+ val ASYNCBLIT : flags
+ val ANYFORMAT : flags
+ val HWPALETTE : flags
+ val DOUBLEBUF : flags
+ val FULLSCREEN : flags
+ val OPENGL : flags
+ val OPENGLBLIT : flags
+ val RESIZABLE : flags
+ val NOFRAME : flags
+ end
+
+ structure Rect : sig
+ type t = {x : Int.t, y : Int.t, w : Int.t, h : Int.t}
+ end
+
+ structure Surface : sig
+ type 'a t
+ val free : {video : no} t Effect.t
+ val updateRect : 'any t -> Rect.t Option.t Effect.t
+ val flip : 'any t Effect.t
+ end
+
+ structure Color : sig
+ type rgb = {r : Word8.t, g : Word8.t, b : Word8.t}
+ type rgba = {r : Word8.t, g : Word8.t, b : Word8.t, a : Word8.t}
+ type t
+ val fromRGB : 'any Surface.t -> rgb -> t
+ val fromRGBA : 'any Surface.t -> rgba -> t
+ end
+
+ structure Video : sig
+ val setMode : {w : Int.t, h : Int.t, bpp : Int.t, props : Prop.flags}
+ -> {video : yes} Surface.t
+ val getSurface : {video : yes} Surface.t Thunk.t
+ end
+
+ val fillRect : 'any Surface.t -> Color.t -> Rect.t Option.t Effect.t
end
More information about the MLton-commit
mailing list