[MLton-commit] r6665
Vesa Karvonen
vesak at mlton.org
Tue Jul 1 15:20:23 PDT 2008
Changed to literally use a separate library providing 3D vectors. Also
changed to the CVT module.
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/toys/n-body/app/
A mltonlib/trunk/org/mlton/vesak/toys/n-body/app/generic.mlb
U mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb
U mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml
D mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml
----------------------------------------------------------------------
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/app/generic.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/app/generic.mlb 2008-07-01 22:15:50 UTC (rev 6664)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/app/generic.mlb 2008-07-01 22:20:02 UTC (rev 6665)
@@ -0,0 +1,16 @@
+(* Copyright (C) 2007-2008 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+in
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/generic.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/close.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/extra.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types.sml
+ $(MLTON_LIB)/com/ssh/generic/unstable/with/types-$(SML_COMPILER).sml
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body/app/generic.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb 2008-07-01 22:15:50 UTC (rev 6664)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb 2008-07-01 22:20:02 UTC (rev 6665)
@@ -1,16 +1,17 @@
-(* Copyright (C) 2007 Vesa Karvonen
+(* Copyright (C) 2007-2008 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.
*)
+$(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+$(MLTON_LIB)/org/mlton/vesak/math3d/unstable/lib.mlb
+
local
- $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
ann
"warnUnused true"
"sequenceNonUnit warn"
in
- v3r.sml
n-body.sml
end
in
Modified: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml 2008-07-01 22:15:50 UTC (rev 6664)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml 2008-07-01 22:20:02 UTC (rev 6665)
@@ -9,14 +9,14 @@
* ``Computer Language Benchmarks Game'' (TheGame).
*
* In this version, 3D vector arithmetic used in the simulation is
- * implemented using essentially a separate reusable library rather than
- * manually inlined and specialized code. The representation of the
- * system has also been simplified to use a list of records instead of
- * multiple arrays. These changes significantly reduce the amount of code
- * required to write the simulation code and make it significantly more
- * readable. Nevertheless, the run-time performance of this version is
- * essentially the same as (actually slightly better than) in the SML
- * version used in TheGame at the time of writing.
+ * implemented using a reusable library rather than manually inlined and
+ * specialized code. The representation of the system has also been
+ * simplified to use a list of records instead of multiple arrays. These
+ * changes significantly reduce the amount of code required to write the
+ * simulation code and make it significantly more readable. Nevertheless,
+ * the run-time performance of this version is essentially the same as
+ * (actually slightly better than) in the SML version used in TheGame at
+ * the time of writing.
*
* Note that the version currently used in TheGame was originally
* translated to SML by Matthias Blume who probably tweaked the code for
@@ -25,12 +25,12 @@
* vectors used in the simulation.
*)
-open V3R
+open Cvt Vec3D
val solarMass = 4.0 * Math.pi * Math.pi
val daysPerYear = 365.24
-type body = {pos : v Ref.t, vel : v Ref.t, mass : Real.t}
+type body = {pos : Vec3D.t Ref.t, vel : Vec3D.t Ref.t, mass : Real.t}
fun pos (b : body) = ! (#pos b)
fun vel (b : body) = ! (#vel b)
@@ -38,7 +38,7 @@
val system =
map (fn {pos, vel, mass} =>
{pos = ref pos,
- vel = ref (vel :* daysPerYear),
+ vel = ref (vel |* daysPerYear),
mass = mass * solarMass})
[{pos = {x = 0.0, y = 0.0, z = 0.0},
vel = {x = 0.0, y = 0.0, z = 0.0},
@@ -76,38 +76,35 @@
fn [] => ()
| a::bs =>
(app (fn b => let
- val d = pos a :-: pos b
+ val d = pos a |-| pos b
val l = mag d
val m = dt / (l * l * l)
in
- #vel a := vel a :-: d :* #mass b * m
- ; #vel b := vel b :+: d :* #mass a * m
+ #vel a := vel a |-| d |* #mass b * m
+ ; #vel b := vel b |+| d |* #mass a * m
end)
bs
- ; #pos a := pos a :+: dt *: vel a
+ ; #pos a := pos a |+| vel a |* dt
; advance dt bs)
val offsetMomentum =
fn [] => fail "Empty system"
| sun::planets =>
- #vel sun := foldl (fn (b, v) => v :-: vel b :* #mass b)
+ #vel sun := foldl (fn (b, v) => v |-| vel b |* #mass b)
{x = 0.0, y = 0.0, z = 0.0}
- planets :/ solarMass
+ planets |/ solarMass
fun energy e =
fn [] => e
| a::bs =>
- energy (foldl (fn (b, e) => e - #mass a * #mass b / mag (pos a :-: pos b))
+ energy (foldl (fn (b, e) => e - #mass a * #mass b / mag (pos a |-| pos b))
(e + 0.5 * #mass a * norm (vel a))
bs)
bs
-val pr = println o String.map (fn #"~" => #"-" | c => c) o
- Real.fmt (StringCvt.FIX (SOME 9))
-
val n = valOf (Int.fromString (hd (CommandLine.arguments ()))) handle _ => 1000
val () = (offsetMomentum system
- ; pr (energy 0.0 system)
+ ; println (R'#F 9 (energy 0.0 system))
; repeat (fn () => advance 0.01 system) n ()
- ; pr (energy 0.0 system))
+ ; println (R'#F 9 (energy 0.0 system)))
Deleted: mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml 2008-07-01 22:15:50 UTC (rev 6664)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml 2008-07-01 22:20:02 UTC (rev 6665)
@@ -1,126 +0,0 @@
-(* 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.
- *)
-
-infix 7 :*: :* *: :/: :/ /:
-infix 6 :+: :+ +: :-: :- -:
-
-signature SCALAR = sig
- type t
- val ~ : t UnOp.t
- val + : t BinOp.t
- val - : t BinOp.t
- val * : t BinOp.t
- val / : t BinOp.t
- structure Math : sig
- val sqrt : t UnOp.t
- end
- val fromInt : Int.t -> t
-end
-
-signature SEQ_CORE = sig
- type 'a t
- val map : ('a -> 'b) -> 'a t -> 'b t
- val selector : ('a t -> 'a) t
- val foldr : ('a * 'b -> 'b) -> 'b -> 'a t -> 'b
-end
-
-signature SEQ = sig
- include SEQ_CORE
- val app : 'a Effect.t -> 'a t Effect.t
- val toList : 'a t -> 'a List.t
- val dup : 'a -> 'a t
- val zipWith : ('a * 'b -> 'c) -> 'a t * 'b t -> 'c t
- type 'a r
- val sub : ('a r t -> 'a r) -> 'a t -> 'a
- val update : ('a r t -> 'a r) -> 'a t * 'a -> 'a t
- val sumWith : ('a * 'a -> 'a) -> 'a t -> 'a
-end
-
-functor MkSeq (Core : SEQ_CORE) :> SEQ where type 'a t = 'a Core.t = struct
- open Core
- fun zipWith f (l, r) = let
- val l = map INL l
- val r = map INR r
- in
- map (fn s => f (Sum.outL (s l), Sum.outR (s r))) selector
- end
- fun app e = ignore o map e
- fun dup v = map (const v) selector
- fun toList v = foldr op :: [] v
- type 'a r = 'a ref
- fun sub f v = case map ref v of r => ! (f r)
- fun update f (v, s) = case map ref v of r => (f r := s ; map ! r)
- fun sumWith f =
- Sum.outR o foldr (fn (v, INL ()) => INR v
- | (v, INR s) => INR (f (s, v))) (INL ())
-end
-
-signature VEC = sig
- structure Scalar : SCALAR and Seq : SEQ
-
- type s = Scalar.t and v = Scalar.t Seq.t
-
- val diag : s -> v -> v Seq.t
-
- val e : v Seq.t
-
- val ~: : v UnOp.t
-
- val :+: : v BinOp.t val :+ : v * s -> v val +: : s * v -> v
- val :-: : v BinOp.t val :- : v * s -> v val -: : s * v -> v
- val :*: : v BinOp.t val :* : v * s -> v val *: : s * v -> v
- val :/: : v BinOp.t val :/ : v * s -> v val /: : s * v -> v
-
- val dot : v Sq.t -> s
- val norm : v -> s
- val mag : v -> s
-
- val lerp : v Sq.t -> s -> v
-
- val normalize : v UnOp.t
-end
-
-functor Vec (structure Scalar : SCALAR and Seq : SEQ_CORE) : VEC = struct
- structure Scalar = Scalar and Seq = MkSeq (Seq)
-
- open Scalar Seq
-
- type s = Scalar.t and v = Scalar.t Seq.t
-
- fun diag s v = map (fn f => update f (dup s, sub f v)) selector
-
- val e = diag (fromInt 0) (dup (fromInt 1))
-
- val ~: = map Scalar.~
-
- local
- fun mk f =
- case zipWith f
- of vv => vv & vv o Pair.map (id, dup) & vv o Pair.map (dup, id)
- in
- val op :+: & op :+ & op +: = mk op +
- val op :-: & op :- & op -: = mk op -
- val op :*: & op :* & op *: = mk op *
- val op :/: & op :/ & op /: = mk op /
- end
-
- val dot = sumWith op + o op :*:
- val norm = dot o Sq.mk
- val mag = Math.sqrt o norm
-
- fun lerp (l, r) s = l :* (fromInt 1 - s) :+: r :* s
-
- fun normalize v = v :* (fromInt 1 / mag v)
-end
-
-structure XYZ : SEQ_CORE = struct
- type 'a t = {x : 'a, y : 'a, z : 'a}
- val selector : ('a t -> 'a) t = {x = #x, y = #y, z = #z}
- fun map f {x, y, z} = {x = f x, y = f y, z = f z}
- fun foldr f s {x, y, z} = f (x, f (y, f (z, s)))
-end
-
-structure V3R = Vec (structure Scalar = Real and Seq = XYZ)
More information about the MLton-commit
mailing list