[MLton-commit] r6214
Vesa Karvonen
vesak at mlton.org
Tue Nov 27 06:22:50 PST 2007
Silly example of bouncing rectangles and a set of ugly build files for it.
----------------------------------------------------------------------
_U mltonlib/trunk/org/mlton/vesak/sdl/unstable/
A mltonlib/trunk/org/mlton/vesak/sdl/unstable/Build.sh
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.bgb
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.sh
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb
U mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml
----------------------------------------------------------------------
Property changes on: mltonlib/trunk/org/mlton/vesak/sdl/unstable
___________________________________________________________________
Name: svn:ignore
- generated
+ generated
libsdl-*-*.a
Added: mltonlib/trunk/org/mlton/vesak/sdl/unstable/Build.sh
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/Build.sh 2007-11-27 14:01:10 UTC (rev 6213)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/Build.sh 2007-11-27 14:22:49 UTC (rev 6214)
@@ -0,0 +1,29 @@
+# Copyright (C) 2007 Vesa Karvonen
+#
+# This code is released under the MLton license, a BSD-style license.
+# See the LICENSE file or http://mlton.org/License for details.
+
+set -e
+set -x
+
+##########################################################################
+# MLton Platform
+
+arch="$(mlton -show path-map | awk '/^TARGET_ARCH/ {print $2}')"
+os="$(mlton -show path-map | awk '/^TARGET_OS/ {print $2}')"
+target="$arch-$os"
+
+##########################################################################
+# Build Library
+
+cd detail/lib
+
+mkdir -p .$target
+
+for src in *.c ; do
+ gcc -O3 -Wall -c -o .$target/$src.o $src
+done
+
+cd ../..
+
+ar cr libsdl-$target.a detail/lib/.$target/*.o
Property changes on: mltonlib/trunk/org/mlton/vesak/sdl/unstable/Build.sh
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.bgb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.bgb 2007-11-27 14:01:10 UTC (rev 6213)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.bgb 2007-11-27 14:22:49 UTC (rev 6214)
@@ -5,4 +5,4 @@
(bg-build
:name "Bounce SDL example"
- :shell "./Build.sh")
+ :shell "nice -n 10 ./Build.sh")
Modified: mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.sh
===================================================================
--- mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.sh 2007-11-27 14:01:10 UTC (rev 6213)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/Build.sh 2007-11-27 14:22:49 UTC (rev 6214)
@@ -6,6 +6,16 @@
set -e
set -x
+##########################################################################
+# MLton Platform
+
+arch="$(mlton -show path-map | awk '/^TARGET_ARCH/ {print $2}')"
+os="$(mlton -show path-map | awk '/^TARGET_OS/ {print $2}')"
+target="$arch-$os"
+
+##########################################################################
+# Build Program
+
export MLTON_LIB="$(cd ../../../../../../../ && pwd)"
mkdir -p generated
@@ -16,6 +26,8 @@
-prefer-abs-paths true \
-show-def-use generated/bounce.du \
-output generated/bounce \
- -link-opt '-ldl' \
- -link-opt '-lSDL' \
+ -link-opt "-ldl" \
+ -link-opt "-lSDL" \
+ -link-opt "-L../.." \
+ -link-opt "-lsdl-$target" \
bounce.mlb
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 14:01:10 UTC (rev 6213)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.mlb 2007-11-27 14:22:49 UTC (rev 6214)
@@ -6,8 +6,13 @@
local
$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/random/unstable/lib.mlb
../../lib.mlb
- bounce.sml
+ ann
+ "sequenceNonUnit warn"
+ in
+ bounce.sml
+ end
in
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 14:01:10 UTC (rev 6213)
+++ mltonlib/trunk/org/mlton/vesak/sdl/unstable/example/bounce/bounce.sml 2007-11-27 14:22:49 UTC (rev 6214)
@@ -4,12 +4,90 @@
* See the LICENSE file or http://mlton.org/License for details.
*)
-fun say ms = println (concat ms)
+open SDL
-fun main () =
- ()
+val printlns = println o concat
+structure Opt = struct
+ val w = ref 640
+ val h = ref 480
+ val bpp = ref 16
+ val size = ref 4
+ val num = ref 100
+end
+
+structure G = struct
+ open RanQD1Gen
+ local
+ val r = ref (RNG.make (RNG.Seed.fromWord (valOf (RandomDev.useed ()))))
+ in
+ fun gen g = generate 1 (!r before r := RNG.next (!r)) g
+ end
+end
+
+fun main () = let
+ val surface =
+ Video.setMode Prop.HWSURFACE {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}
+
+ val xMax = real (!Opt.w - !Opt.size)
+ val yMax = real (!Opt.h - !Opt.size)
+
+ val obs =
+ Vector.tabulate
+ (!Opt.num,
+ fn _ => let
+ open G
+ in
+ {x = ref (gen (realInRange (0.0, xMax))),
+ y = ref (gen (realInRange (0.0, yMax))),
+ dx = ref (gen (realInRange (~5.0, 5.0))),
+ dy = ref (gen (realInRange (~5.0, 5.0)))}
+ end)
+
+ fun render () =
+ (fillRect surface black NONE
+ ; Vector.app (fn {x, y, ...} =>
+ fillRect surface white (SOME {x = trunc (!x),
+ y = trunc (!y),
+ w = !Opt.size,
+ h = !Opt.size}))
+ obs
+ ; Surface.updateRect surface NONE)
+
+ fun animate () =
+ Vector.app (fn {x, y, dx, dy} =>
+ (if !x < 0.0 andalso !dx < 0.0 orelse
+ xMax < !x andalso 0.0 < !dx then
+ dx := ~ (!dx)
+ else ()
+ ; if !y < 0.0 andalso !dy < 0.0 orelse
+ yMax < !y andalso 0.0 < !dy then
+ dy := ~ (!dy)
+ else ()
+ ; x := !x + !dx
+ ; y := !y + !dy))
+ obs
+
+ fun sleep () = OS.Process.sleep (Time.fromMilliseconds 20)
+
+ fun lp () =
+ case Event.poll ()
+ of SOME (Event.KEY {key, pressed = true, down = true, ...}) =>
+ if key = Key.Q orelse key = Key.ESCAPE then () else lp ()
+ | _ => (render () ; animate () ; sleep () ; lp ())
+in
+ lp ()
+end
+
val () =
- (SDL.init SDL.Init.EVERYTHING
- ; say ["SDL initialized"]
- ; after (main, SDL.quit))
+ recur (CommandLine.arguments ()) (fn lp =>
+ fn [] => (init Init.VIDEO ; after (main, quit))
+ | "-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)
+ | x :: _ => (printlns ["Invalid option: ", x]))
More information about the MLton-commit
mailing list