[MLton-commit] r6238
Vesa Karvonen
vesak at mlton.org
Wed Dec 5 04:40:40 PST 2007
Another toy.
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/toys/n-body/
A mltonlib/trunk/org/mlton/vesak/toys/n-body/Build.bgb
A mltonlib/trunk/org/mlton/vesak/toys/n-body/Makefile
A mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb
A mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml
A mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml
----------------------------------------------------------------------
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body
___________________________________________________________________
Name: svn:ignore
+ generated
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/Build.bgb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/Build.bgb 2007-12-02 15:07:47 UTC (rev 6237)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/Build.bgb 2007-12-05 12:40:39 UTC (rev 6238)
@@ -0,0 +1,8 @@
+;; 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.
+
+(bg-build
+ :name "N-Body Simultation"
+ :shell "nice -n5 make run")
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/Makefile
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/Makefile 2007-12-02 15:07:47 UTC (rev 6237)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/Makefile 2007-12-05 12:40:39 UTC (rev 6238)
@@ -0,0 +1,11 @@
+# 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.
+
+name := n-body
+args := 20000000
+
+root := ../../../../..
+
+include ../common.mk
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body/Makefile
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb 2007-12-02 15:07:47 UTC (rev 6237)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb 2007-12-05 12:40:39 UTC (rev 6238)
@@ -0,0 +1,17 @@
+(* 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.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ ann
+ "warnUnused true"
+ "sequenceNonUnit warn"
+ in
+ v3r.sml
+ n-body.sml
+ end
+in
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml 2007-12-02 15:07:47 UTC (rev 6237)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml 2007-12-05 12:40:39 UTC (rev 6238)
@@ -0,0 +1,114 @@
+(* 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.
+ *)
+
+(*
+ * This is an implementation of the N-Body toy benchmark, from the
+ * ``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.
+ *
+ * Note that version currently used in TheGame was originally translated
+ * to SML by Matthias Blume who apparently tweaked the code for SML/NJ.
+ * In particular, I believe that the reason behind using multiple arrays
+ * is to be able to efficiently mutate the position and velocity vectors
+ * used in the simulation. This stems from the fact that SML/NJ is,
+ * AFAIK, unable to flatten ref cells, which usually require whole-program
+ * analysis.
+ *)
+
+open V3R
+
+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}
+
+fun pos (b : body) = ! (#pos b)
+fun vel (b : body) = ! (#vel b)
+
+val system =
+ map (fn {pos, vel, mass} =>
+ {pos = ref pos, 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},
+ mass = 1.0},
+ {pos = {x = 4.84143144246472090,
+ y = ~1.16032004402742839,
+ z = ~1.03622044471123109e~1},
+ vel = {x = 1.66007664274403694e~3,
+ y = 7.69901118419740425e~3,
+ z = ~6.90460016972063023e~5},
+ mass = 9.54791938424326609e~4},
+ {pos = {x = 8.34336671824457987,
+ y = 4.12479856412430479,
+ z = ~4.03523417114321381e~1},
+ vel = {x = ~2.76742510726862411e~3,
+ y = 4.99852801234917238e~3,
+ z = 2.30417297573763929e~5},
+ mass = 2.85885980666130812e~4},
+ {pos = {x = 1.28943695621391310e1,
+ y = ~1.51111514016986312e1,
+ z = ~2.23307578892655734e~1},
+ vel = {x = 2.96460137564761618e~3,
+ y = 2.37847173959480950e~3,
+ z = ~2.96589568540237556e~5},
+ mass = 4.36624404335156298e~5},
+ {pos = {x = 1.53796971148509165e1,
+ y = ~2.59193146099879641e1,
+ z = 1.79258772950371181e~1},
+ vel = {x = 2.68067772490389322e~3,
+ y = 1.62824170038242295e~3,
+ z = ~9.51592254519715870e~5},
+ mass = 5.15138902046611451e~5}]
+
+fun advance dt =
+ fn [] => ()
+ | a::bs =>
+ (app (fn b => let
+ 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
+ end)
+ bs
+ ; #pos a := pos a :+: dt *: vel a
+ ; advance dt bs)
+
+val offsetMomentum =
+ fn [] => fail "Empty system"
+ | sun::planets => #vel sun := foldl (fn (b, v) => v :-: vel b :* #mass b)
+ {x = 0.0, y = 0.0, z = 0.0}
+ planets :/ solarMass
+
+fun energy e =
+ fn [] => e
+ | a::bs =>
+ 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)
+ ; repeat (fn () => advance 0.01 system) n ()
+ ; pr (energy 0.0 system))
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body/n-body.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml 2007-12-02 15:07:47 UTC (rev 6237)
+++ mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml 2007-12-05 12:40:39 UTC (rev 6238)
@@ -0,0 +1,126 @@
+(* 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)
Property changes on: mltonlib/trunk/org/mlton/vesak/toys/n-body/v3r.sml
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list