[MLton-commit] r6225
Vesa Karvonen
vesak at mlton.org
Thu Nov 29 04:32:52 PST 2007
Added some more mouse support and tweaked signature.
----------------------------------------------------------------------
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl-key-sym.sig
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 10:33:23 UTC (rev 6224)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/detail/sdl.sml 2007-11-29 12:32:51 UTC (rev 6225)
@@ -6,12 +6,14 @@
structure SDL :> SDL = struct
structure Word32Flags = MkWordFlags (Word32)
+ structure Word8Flags = MkWordFlags (Word8)
val op >>& = With.Monad.>>&
fun withNew size = With.around (fn () => C.new' size) C.discard'
fun withAlloc alloc = With.around alloc C.free'
fun withZs mlStr = withAlloc (fn () => ZString.dupML' mlStr)
- fun withBuf length = withAlloc (fn () => C.alloc' C.S.uchar length)
+ fun withArray size length = withAlloc (fn () => C.alloc' size length)
+ fun withBuf length = withArray C.S.uchar length
val one = With.one
fun raiseError () = raise Fail (ZString.toML' (F_SDL_GetError.f' ()))
@@ -149,37 +151,68 @@
checkInt (F_SDL_SetGamma.f' (toFloat r, toFloat g, toFloat b))
end
-
structure Key = struct
structure Code = Word8
- structure Sym = SDLKeySym
+ structure Sym = struct
+ fun toString sym = ZString.toML' (checkPtr (F_SDL_GetKeyName.f' sym))
+ open SDLKeySym
+ end
+ structure Mod = struct
+ open Word32Flags
+ local
+ open E_'SDLMod
+ in
+ val toML = Word32.fromInt o E_'SDLMod.m2i
+ val LSHIFT = toML e_KMOD_LSHIFT
+ val RSHIFT = toML e_KMOD_RSHIFT
+ val LCTRL = toML e_KMOD_LCTRL
+ val RCTRL = toML e_KMOD_RCTRL
+ val LALT = toML e_KMOD_LALT
+ val RALT = toML e_KMOD_RALT
+ val LMETA = toML e_KMOD_LMETA
+ val RMETA = toML e_KMOD_RMETA
+ val NUM = toML e_KMOD_NUM
+ val CAPS = toML e_KMOD_CAPS
+ val MODE = toML e_KMOD_MODE
+ end
+ end
val setRepeat =
fn NONE => checkInt (F_SDL_EnableKeyRepeat.f' (0, 0))
| SOME {delay, interval} =>
checkInt (F_SDL_EnableKeyRepeat.f'
(Int.fromLarge (Time.toMilliseconds delay),
Int.fromLarge (Time.toMilliseconds interval)))
+ val keys = checkPtr (F_SDL_GetKeyState.f' C.Ptr.null')
+ fun isPressed sym =
+ C.Get.uchar' (C.Ptr.sub' C.S.uchar (keys, E_'SDLKey.m2i sym)) <> 0w0
end
- structure Alt = struct
- open Word32Flags
+ 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)
+ end
+
local
- open E_'SDLMod
+ fun getMouse f =
+ one (withArray C.S.sint 0w2)
+ (fn xy =>
+ (ignore (f (xy, C.Ptr.|+! C.S.sint (xy, 1)))
+ ; {x = C.Get.sint' (C.Ptr.|*! xy),
+ y = C.Get.sint' (C.Ptr.sub' C.S.sint (xy, 1))}))
in
- val toML = Word32.fromInt o E_'SDLMod.m2i
-
- val LSHIFT = toML e_KMOD_LSHIFT
- val RSHIFT = toML e_KMOD_RSHIFT
- val LCTRL = toML e_KMOD_LCTRL
- val RCTRL = toML e_KMOD_RCTRL
- val LALT = toML e_KMOD_LALT
- val RALT = toML e_KMOD_RALT
- val LMETA = toML e_KMOD_LMETA
- val RMETA = toML e_KMOD_RMETA
- val NUM = toML e_KMOD_NUM
- val CAPS = toML e_KMOD_CAPS
- val MODE = toML e_KMOD_MODE
+ fun getPos () = getMouse F_SDL_GetMouseState.f'
+ fun getDelta () = getMouse F_SDL_GetRelativeMouseState.f'
end
+ fun getButtons () = F_SDL_GetMouseState.f' (C.Ptr.null', C.Ptr.null')
+ fun showCursor b =
+ ignore (F_SDL_ShowCursor.f' (if b
+ then Int.fromLarge SDL_ENABLE
+ else Int.fromLarge SDL_DISABLE))
end
structure Event = struct
@@ -188,7 +221,7 @@
pressed : Bool.t,
code : Key.Code.t,
sym : Key.Sym.t,
- alt : Alt.flags}
+ mods : Key.Mod.flags}
fun toML event = let
val t = C.Get.uchar' (U_SDL_Event.f_type' event)
@@ -199,13 +232,15 @@
then let
val ke = U_SDL_Event.f_key' event
val ks = S_SDL_KeyboardEvent.f_keysym' ke
+ open S_SDL_keysym
in
SOME (KEY {down = is e_SDL_KEYDOWN,
pressed = Word8.fromLargeInt SDL_PRESSED =
- C.Get.uchar' (S_SDL_KeyboardEvent.f_state' ke),
- code = C.Get.uchar' (S_SDL_keysym.f_scancode' ks),
- sym = C.Get.enum' (S_SDL_keysym.f_sym' ks),
- alt = Alt.toML (C.Get.enum' (S_SDL_keysym.f_mod' ks))})
+ C.Get.uchar'
+ (S_SDL_KeyboardEvent.f_state' ke),
+ code = C.Get.uchar' (f_scancode' ks),
+ sym = C.Get.enum' (f_sym' ks),
+ mods = Key.Mod.toML (C.Get.enum' (f_mod' ks))})
end
else NONE (* We just ignore other events for now *)
end
@@ -226,6 +261,8 @@
of NONE => wait ()
| SOME e => e)
| _ => raiseError ())
+
+ val pump = F_SDL_PumpEvents.f'
end
structure Image = 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 10:33:23 UTC (rev 6224)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml 2007-11-29 12:32:51 UTC (rev 6225)
@@ -4,8 +4,6 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-open SDL
-
val printlns = println o concat
structure Opt = struct
@@ -29,17 +27,19 @@
fun demo () = let
val surface =
- Video.setMode
- let open Prop in
+ SDL.Video.setMode
+ let open SDL.Prop in
flags ([DOUBLEBUF] @
(if !Opt.fs then [HWSURFACE, FULLSCREEN] else [])) end
{bpp = !Opt.bpp}
{w = !Opt.w, h = !Opt.h}
- val format = Surface.pixelFormat surface
+ val format = SDL.Surface.pixelFormat surface
- val black = Pixel.fromRGB format {r=0w0, g=0w0, b=0w0}
- val white = Pixel.fromRGB format {r=0w255, g=0w255, b=0w255}
+ 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 xMax = real (!Opt.w - !Opt.size)
val yMax = real (!Opt.h - !Opt.size)
@@ -54,16 +54,29 @@
val obDim = {w = !Opt.size, h = !Opt.size}
- fun render () =
- (Surface.fill surface black
- ; Vector.app (fn {x, y, ...} =>
- Surface.fillRect
- surface
- white
- {dim = obDim,
- pos = {x = trunc (!x), y = trunc (!y)}})
- obs
- ; Surface.flip surface)
+ fun render () = let
+ val color = if SDL.Key.isPressed SDL.Key.Sym.SPACE then red else green
+ in
+ SDL.Surface.fill surface black
+ ; Vector.app (fn {x, y, ...} =>
+ SDL.Surface.fillRect
+ surface
+ color
+ {dim = obDim,
+ pos = {x = trunc (!x), y = trunc (!y)}}) obs
+ ; SDL.Surface.fillRect
+ surface
+ let
+ open SDL.Mouse.Button
+ val buttons = SDL.Mouse.getButtons ()
+ in
+ if anySet (LEFT, buttons) then red
+ else if anySet (RIGHT, buttons) then green
+ else blue
+ end
+ {dim = obDim, pos = SDL.Mouse.getPos ()}
+ ; SDL.Surface.flip surface
+ end
fun animate () =
Vector.app (fn {x, y, dx, dy} => let
@@ -91,19 +104,25 @@
end
fun lp () =
- case Event.poll ()
- of SOME (Event.KEY {sym, pressed = true, down = true, ...}) =>
- if sym = Key.Sym.Q orelse sym = Key.Sym.ESCAPE then () else lp ()
+ case SDL.Event.poll ()
+ of SOME (SDL.Event.KEY {sym, pressed, ...}) =>
+ if sym = SDL.Key.Sym.Q orelse
+ sym = SDL.Key.Sym.ESCAPE
+ then ()
+ else (printlns ["Key ", SDL.Key.Sym.toString sym, " ",
+ if pressed then "pressed" else "released"]
+ ; lp ())
| _ => (render () ; animate () ; sleep () ; lp ())
in
- lp ()
+ SDL.Mouse.showCursor false
+ ; lp ()
end
fun main () =
- (printlns ["Driver name: ", Video.getDriverName ()]
+ (printlns ["Driver name: ", SDL.Video.getDriverName ()]
; print "Available full screen modes: "
- ; case Video.listModes
- let open Prop in flags [DOUBLEBUF, HWSURFACE, FULLSCREEN] end
+ ; case SDL.Video.listModes
+ let open SDL.Prop in flags [DOUBLEBUF, HWSURFACE, FULLSCREEN] end
of NONE => println "Any resolution is OK?"
| SOME [] => println "None"
| SOME rs =>
@@ -113,12 +132,13 @@
val () =
recur (CommandLine.arguments ()) (fn lp =>
- fn [] => (init Init.VIDEO ; after (main, quit))
- | "-bpp" :: v :: xs => (Opt.bpp := valOf (Int.fromString v) ; lp xs)
+ fn "-bpp" :: v :: xs => (Opt.bpp := valOf (Int.fromString v) ; lp xs)
| "-w" :: v :: xs => (Opt.w := valOf (Int.fromString v) ; lp xs)
| "-h" :: v :: xs => (Opt.h := valOf (Int.fromString v) ; lp xs)
| "-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]))
+ | x :: _ => (printlns ["Invalid option: ", x])
+ | [] => (SDL.init SDL.Init.VIDEO
+ ; after (main, SDL.quit)))
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl-key-sym.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl-key-sym.sig 2007-11-29 10:33:23 UTC (rev 6224)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl-key-sym.sig 2007-11-29 12:32:51 UTC (rev 6225)
@@ -6,6 +6,7 @@
signature SDL_KEY_SYM = sig
eqtype t
+ val toString : t -> String.t
val BACKSPACE : t
val TAB : t
val CLEAR : t
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-29 10:33:23 UTC (rev 6224)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/public/sdl.sig 2007-11-29 12:32:51 UTC (rev 6225)
@@ -53,9 +53,7 @@
structure Pixel : sig
eqtype t
-
structure Format : sig eqtype t end
-
val fromRGB : Format.t -> Word8.t RGB.t -> t
val fromRGBA : Format.t -> Word8.t RGBA.t -> t
end
@@ -74,7 +72,8 @@
end
structure Video : sig
- val setMode : Prop.flags -> {bpp : Int.t} -> Int.t Dim.t -> {video : yes} Surface.t
+ val setMode : Prop.flags -> {bpp : Int.t} -> Int.t Dim.t
+ -> {video : yes} Surface.t
val getSurface : {video : yes} Surface.t Thunk.t
val getDriverName : String.t Thunk.t
val listModes : Prop.flags -> Int.t Dim.t List.t Option.t
@@ -82,26 +81,39 @@
end
structure Key : sig
- structure Code : sig
- eqtype t
+ structure Code : sig eqtype t end
+ structure Sym : SDL_KEY_SYM
+ structure Mod : sig
+ include FLAGS where type flags_word = Word32.t
+ val LSHIFT : flags
+ val RSHIFT : flags
+ val LCTRL : flags
+ val RCTRL : flags
+ val LALT : flags
+ val RALT : flags
+ val LMETA : flags
+ val RMETA : flags
+ val NUM : flags
+ val CAPS : flags
+ val MODE : flags
end
- structure Sym : SDL_KEY_SYM
val setRepeat : {delay : Time.t, interval : Time.t} Option.t Effect.t
+ val isPressed : Sym.t UnPr.t
end
- structure Alt : sig
- include FLAGS where type flags_word = Word32.t
- val LSHIFT : flags
- val RSHIFT : flags
- val LCTRL : flags
- val RCTRL : flags
- val LALT : flags
- val RALT : flags
- val LMETA : flags
- val RMETA : flags
- val NUM : flags
- val CAPS : flags
- val MODE : flags
+ structure Mouse : sig
+ structure Button : sig
+ include FLAGS where type flags_word = Word8.t
+ val LEFT : flags
+ val MIDDLE : flags
+ val RIGHT : flags
+ val WHEELDOWN : flags
+ val WHEELUP : flags
+ end
+ val getPos : Int.t Pos.t Thunk.t
+ val getDelta : Int.t Pos.t Thunk.t
+ val getButtons : Button.flags Thunk.t
+ val showCursor : Bool.t Effect.t
end
structure Event : sig
@@ -110,9 +122,10 @@
pressed : Bool.t,
code : Key.Code.t,
sym : Key.Sym.t,
- alt : Alt.flags}
+ mods : Key.Mod.flags}
val poll : t Option.t Thunk.t
val wait : t Thunk.t
+ val pump : Unit.t Effect.t
end
structure Image : sig
More information about the MLton-commit
mailing list