[MLton-commit] r6218
Vesa Karvonen
vesak at mlton.org
Wed Nov 28 05:04:46 PST 2007
Added getDriverName and listModes.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.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-27 22:10:14 UTC (rev 6217)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-28 13:04:46 UTC (rev 6218)
@@ -8,12 +8,16 @@
structure Word32Flags = MkWordFlags (Word32)
fun withNew size = With.around (fn () => C.new' size) C.discard'
+ fun withAlloc alloc = With.around alloc C.free'
+ fun withBuf length = withAlloc (fn () => C.alloc' C.S.uchar length)
val one = With.one
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 raiseError () else ptr
+ val minus1ptr : C.voidptr = C.U.i2p (C.Cvt.c_ulong (~ 0w1))
+
structure Init = struct
open Word32Flags
val ` = Word32.fromLargeInt
@@ -78,6 +82,31 @@
fun setMode props {bpp} {w, h} =
checkPtr (F_SDL_SetVideoMode.f' (w, h, bpp, props))
val getSurface = checkPtr o F_SDL_GetVideoSurface.f'
+ val maxDriverNameSz = 256 (* XXX is this large enough? *)
+ fun getDriverName () =
+ one (withBuf (Word.fromInt maxDriverNameSz))
+ (fn buf =>
+ if C.Ptr.isNull' (F_SDL_VideoDriverName.f'
+ (buf, maxDriverNameSz))
+ then fail "Cannot get driver name. Is SDL video initialized?"
+ else ZString.toML' buf)
+ fun listModes props =
+ case F_SDL_ListModes.f' (C.Ptr.null', props)
+ of modes =>
+ if C.Ptr.isNull' modes then SOME []
+ else if minus1ptr = C.Ptr.inject' modes then NONE
+ else recur (modes, []) (fn lp =>
+ fn (modes, ms) =>
+ if C.Ptr.isNull' (C.Get.ptr' (C.Ptr.|*! modes))
+ then SOME ms
+ else let
+ val r = C.Ptr.|*! (C.Get.ptr' (C.Ptr.|*! modes))
+ fun `f = Word16.toInt (C.Get.ushort' (f r))
+ in
+ lp (C.Ptr.|+! C.S.ptr (modes, 1),
+ {w = `S_SDL_Rect.f_w',
+ h = `S_SDL_Rect.f_h'}::ms)
+ end)
end
fun fillRect surface color =
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb 2007-11-27 22:10:14 UTC (rev 6217)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb 2007-11-28 13:04:46 UTC (rev 6218)
@@ -11,6 +11,7 @@
ann
"sequenceNonUnit warn"
+ "warnUnused true"
in
bounce.sml
end
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-27 22:10:14 UTC (rev 6217)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml 2007-11-28 13:04:46 UTC (rev 6218)
@@ -11,6 +11,7 @@
structure Opt = struct
val w = ref 640
val h = ref 480
+ val fs = ref false
val bpp = ref 16
val size = ref 4
val num = ref 100
@@ -26,9 +27,13 @@
end
end
-fun main () = let
+fun demo () = let
val surface =
- Video.setMode Prop.HWSURFACE {bpp = !Opt.bpp} {w = !Opt.w, h = !Opt.h}
+ Video.setMode
+ let open Prop in
+ flags ([HWSURFACE] @ (if !Opt.fs then [FULLSCREEN] else [])) end
+ {bpp = !Opt.bpp}
+ {w = !Opt.w, h = !Opt.h}
val black = Color.fromRGB surface {r=0w0, g=0w0, b=0w0}
val white = Color.fromRGB surface {r=0w255, g=0w255, b=0w255}
@@ -88,6 +93,17 @@
lp ()
end
+fun main () =
+ (printlns ["Driver name: ", Video.getDriverName ()]
+ ; print "Available full screen modes: "
+ ; case Video.listModes let open Prop in flags [HWSURFACE, FULLSCREEN] end
+ of NONE => println "Any resolution is OK?"
+ | SOME [] => println "None"
+ | SOME rs =>
+ println o String.concatWith ", " |< map
+ (fn {w, h} => concat [Int.toString w, "x", Int.toString h]) rs
+ ; demo ())
+
val () =
recur (CommandLine.arguments ()) (fn lp =>
fn [] => (init Init.VIDEO ; after (main, quit))
@@ -97,4 +113,5 @@
| "-size" :: v :: xs => (Opt.size := valOf (Int.fromString v) ; lp xs)
| "-num" :: v :: xs => (Opt.num := valOf (Int.fromString v) ; lp xs)
| "-fps" :: v :: xs => (Opt.fps := valOf (Int.fromString v) ; lp xs)
+ | "-fs" :: xs => (Opt.fs := true ; lp xs)
| x :: _ => (printlns ["Invalid option: ", x]))
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-27 22:10:14 UTC (rev 6217)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-28 13:04:46 UTC (rev 6218)
@@ -67,6 +67,8 @@
structure Video : sig
val setMode : Prop.flags -> {bpp : Int.t} -> wh -> {video : yes} Surface.t
val getSurface : {video : yes} Surface.t Thunk.t
+ val getDriverName : String.t Thunk.t
+ val listModes : Prop.flags -> wh List.t Option.t
end
val fillRect : 'any Surface.t -> Color.t -> xywh Option.t Effect.t
More information about the MLton-commit
mailing list