Initial commit

Basic dimensional analysis

contrib/math/constants.factor

@@ -0,0 +1,9 @@
+USING: kernel math dimensional-analysis units ;
+! From: http://physics.nist.gov/constants
+
+IN: physical-constants
+! speed of light in vacuum
+: c 299792458 m/s ;
+! : c0 299792458:m/s ; ! same as c
+! : c-vacuum 299792458:m/s ; ! same as c
+

contrib/math/dimensional-analysis.factor

@@ -0,0 +1,83 @@
+USING: physical-constants conversions ;
+USING: kernel prettyprint io sequences words lists vectors inspector math errors ;
+IN: dimensional-analysis
+
+
+IN: sequences
+: seq-diff ( seq1 seq2 -- seq2-seq1 )
+    [ swap member? not ] subset-with ; flushable
+
+: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
+    [ swap member? ] subset-with ; flushable
+
+IN: dimensional-analysis
+
+TUPLE: dimensioned val top bot ;
+C: dimensioned 
+    [ set-dimensioned-bot ] keep
+    [ set-dimensioned-top ] keep
+    over number? [ "dimensioned must be a number" throw ] unless
+    [ set-dimensioned-val ] keep ;
+
+: remove-one ( obj seq -- seq )
+    [ index ] keep over -1 = [
+        2drop
+    ] [
+        [ 0 -rot <slice> ] 2keep
+        >r 1+ r> [ length ] keep <slice> append 
+    ] if ;
+
+
+: dimensions ( dimensioned -- top bot )
+    dup >r dimensioned-top r> dimensioned-bot ;
+
+: 2remove-one ( obj seq seq -- seq seq )
+    pick swap remove-one >r remove-one r> ;
+
+: symbolic-reduce ( seq seq -- seq seq )
+    [ seq-intersect ] 2keep rot dup empty? [
+            drop
+        ] [
+            first -rot 2remove-one symbolic-reduce
+    ] if ;
+
+: reduce-units ( dimensioned -- )
+    dup dimensions symbolic-reduce pick set-dimensioned-bot swap set-dimensioned-top ;
+
+: 2reduce-units ( d d -- )
+    >r dup reduce-units r> dup reduce-units ;
+
+: 2val ( d d -- )
+    >r dimensioned-val r> dimensioned-val ;
+
+: =units?
+    >r dimensions 2list r> dimensions 2list = ;
+    
+
+: d+ ( d d -- )
+    2dup =units? [
+        "d+: dimensions must be the same" throw
+    ] unless
+    dup dimensions
+    >r >r 2val + r> r> <dimensioned> ;
+
+: d- ( d d -- )
+    2dup =units? [
+        "d-: dimensions must be the same" throw
+    ] unless
+    dup dimensions
+    >r >r 2val - r> r> <dimensioned> ;
+
+: add-dimensions ( d d -- d )
+    >r dimensions r> dimensions >r swap >r append r> r> append 0 -rot <dimensioned> ;
+
+: (d*)
+    >r add-dimensions r> over set-dimensioned-val dup reduce-units ;
+
+: d* ( d d -- )
+    2dup 2val * (d*) ;
+
+: d/ ( d d -- )
+    2dup 2val / (d*) ;
+
+

contrib/math/load.factor

@@ -8,9 +8,9 @@ USING: parser sequences words compiler ;
     "contrib/math/quaternions.factor"
     "contrib/math/matrices.factor"
 
-    ! "contrib/math/dimensions.factor"
-    ! "contrib/math/constants.factor"
     ! "contrib/math/dimensional-analysis.factor"
+    ! "contrib/math/units.factor"
+    ! "contrib/math/constants.factor"
 ] [ run-file ] each
 
 

contrib/math/units.factor

@@ -0,0 +1,47 @@
+USING: math dimensional-analysis ;
+IN: units
+
+SYMBOL: mm
+SYMBOL: cm
+SYMBOL: dm
+SYMBOL: m
+SYMBOL: km
+
+: mm>m 1000 / ;
+: m>mm 1000 * ;
+
+: cm>m 100 / ;
+: m>cm 100 * ;
+
+: dm>m 10 / ;
+: m>dm 10 * ;
+
+: km>m 1000 * ;
+: m>km 1000 / ;
+
+SYMBOL: ms
+SYMBOL: s
+
+: ms>s 1000 / ;
+: s>ms 1000 * ;
+
+
+: m { m } { } <dimensioned> ;
+: km { km } { } <dimensioned> ;
+
+: ms { ms } { } <dimensioned> ;
+: s { s } { } <dimensioned> ;
+
+: m/s { m } { s } <dimensioned> ;
+: m/s^2 { m } { s s } <dimensioned> ;
+
+SYMBOL: kg
+: kg { kg } { } <dimensioned> ;
+
+! SYMBOL: N  ! newtons
+! : N { N } { } <dimensioned> ;
+
+
+! Autogenerated plz
+
+: mm>km mm>m m>km ;  ! : mm>km 1000 / 1000 / ;