Initial checkin.

diff --git a/contrib/units/constants.factor b/contrib/units/constants.factor
new file mode 100644 (file)
index 0000000..d3768ea
--- /dev/null
+++ b/contrib/units/constants.factor
@@ -0,0 +1,11 @@
+USING: kernel math dimensioned si-units ;
+! From: http://physics.nist.gov/constants
+
+IN: si-units
+! speed of light in vacuum
+: c 299792458 m/s ;
+: c0 299792458 m/s ; ! same as c
+: c-vacuum 299792458 m/s ; ! same as c
+
+! more to come
+

diff --git a/contrib/units/dimensioned.factor b/contrib/units/dimensioned.factor
new file mode 100644 (file)
index 0000000..31687f0
--- /dev/null
+++ b/contrib/units/dimensioned.factor
@@ -0,0 +1,97 @@
+USING: physical-constants conversions ;
+USING: kernel prettyprint io sequences words lists vectors inspector math errors namespaces ;
+
+
+IN: units-internal
+: seq-diff ( seq1 seq2 -- seq2-seq1 )
+    [ swap member? not ] subset-with ; flushable
+
+: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
+    [ swap member? ] subset-with ; flushable
+
+IN: units
+
+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 -- )
+    [ dimensioned-val ] 2apply ;
+
+: =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*) ;
+
+: swap-dimensions ( d -- d )
+    dup dimensions rot [ set-dimensioned-top ] keep [ set-dimensioned-bot ] keep ;
+
+: d/ ( d d -- )
+    swap-dimensions 2dup 2val / (d*) ;
+
+: d-inv ( d -- d )
+    swap-dimensions dup dimensioned-val 1 swap / over set-dimensioned-val ;
+
+: d-product ( v -- d ) 1 { } { } <dimensioned> [ d* ] reduce ;
+
+! does not compile
+! Example: 4 m { km } { } convert
+: convert ( d top bot -- val )
+    >r [ [ 1 swap execute , ] each ] { } make d-product r>
+    [ [ 1 swap execute d-inv , ] each ] { } make d-product
+    d*
+    2dup =units? [ "cannot make that conversion" throw ] unless
+    2val / ;
+

diff --git a/contrib/units/load.factor b/contrib/units/load.factor
new file mode 100644 (file)
index 0000000..0b230dd
--- /dev/null
+++ b/contrib/units/load.factor
@@ -0,0 +1,10 @@
+USING: parser sequences words compiler ;
+
+[
+    "contrib/units/dimensioned.factor"
+    "contrib/units/si-units.factor"
+    "contrib/units/constants.factor"
+] [ run-file ] each
+
+! "" words [ try-compile ] each
+

diff --git a/contrib/units/si-units.factor b/contrib/units/si-units.factor
new file mode 100644 (file)
index 0000000..e0e5068
--- /dev/null
+++ b/contrib/units/si-units.factor
@@ -0,0 +1,136 @@
+USING: math units ;
+IN: si-units
+
+! SI Conversions
+! http://physics.nist.gov/cuu/Units/
+
+! Y Z E P T G M k h da 1 d c m mu n p f a z y
+: yotta>1 1000000000000000000000000 * ;
+: zetta>1 1000000000000000000000 * ;
+: exa>1   1000000000000000000 * ;
+: peta>1  1000000000000000 * ;
+: tera>1  1000000000000 * ;
+: giga>1  1000000000 * ;
+: mega>1  1000000 * ;
+: kilo>1  1000 * ;
+: hecto>1 100 * ;
+: deca>1  10 * ;
+: deci>1  10 / ;
+: centi>1 100 / ;
+: milli>1 1000 / ;
+: micro>1 1000000 / ;
+: nano>1  1000000000 / ;
+: pico>1  1000000000000 / ;
+: femto>1 1000000000000000 / ;
+: atto>1  1000000000000000000 / ;
+: zepto>1 1000000000000000000000 / ;
+: yocto>1 1000000000000000000000000 / ;
+
+
+! Length
+SYMBOL: m
+: (m) { m } { } <dimensioned> ;
+: m (m) ;
+: km kilo>1 (m) ;
+: cm centi>1 (m) ;
+: mm milli>1 (m) ;
+: nm nano>1 (m) ;
+
+! Mass
+SYMBOL: kg
+: (kg) { kg } { } <dimensioned> ;
+: kg (kg) ;
+: g milli>1 (kg) ;
+
+! Time
+SYMBOL: s
+: (s) { s } { } <dimensioned> ;
+: s (s) ;
+: ms milli>1 (s) ;
+
+! Electric current
+SYMBOL: A
+: (A) { A } { } <dimensioned> ;
+: A (A) ;
+
+! Temperature
+SYMBOL: K
+: (K) { K } { } <dimensioned> ;
+: K (K) ;
+
+! Amount of substance
+SYMBOL: mol
+: (mol) { mol } { } <dimensioned> ;
+: mol (mol) ;
+
+! Luminous intensity
+SYMBOL: cd
+: (cd) { cd } { } <dimensioned> ;
+: cd (cd) ;
+
+
+! SI derived units
+: m^2 { m m } { } <dimensioned> ;
+: m^3 { m m m } { } <dimensioned> ;
+: m/s { m } { s } <dimensioned> ;
+: m/s^2 { m } { s s } <dimensioned> ;
+: m^-1 { } { m } <dimensioned> ;
+: kg/m^3 { kg } { m m m } <dimensioned> ;
+: A/m^2 { A } { m m } <dimensioned> ;
+: A/m { A } { m } <dimensioned> ;
+: mol/m^3 { mol } { m m m } <dimensioned> ;
+: cd/m^2 { cd } { m m } <dimensioned> ;
+: kg/kg { kg } { kg } <dimensioned> ;
+
+: radian ( n -- radian ) { m } { m } <dimensioned> ;
+: sr ( n -- steradian ) { m m } { m m } <dimensioned> ;
+: Hz ( n -- hertz ) { } { s } <dimensioned> ;
+: N ( n -- newton ) { kg m } { s s } <dimensioned> ;
+: Pa ( n -- pascal ) { kg } { m s s } <dimensioned> ;
+: J ( n -- joule ) { m m kg } { s s } <dimensioned> ;
+: W ( n -- watt ) { m m kg } { s s s } <dimensioned> ;
+: C ( n -- coulomb ) { s A } { } <dimensioned> ;
+: V ( n -- volt ) { m m kg } { s s s A } <dimensioned> ;
+: F ( n -- farad ) { s s s s A A } { m m kg } <dimensioned> ;
+: ohm ( n -- ohm ) { m m kg } { s s s A A } <dimensioned> ;
+: S ( n -- siemens ) { s s s A A } { m m kg } <dimensioned> ;
+: Wb ( n - weber ) { m m kg } { s s A } <dimensioned> ;
+: T ( n -- tesla ) { kg } { s s A } <dimensioned> ;
+: H ( n -- henry ) { m m kg } { s s A A } <dimensioned> ;
+: deg-C ( n -- Celsius ) 273.15 + { K } { } <dimensioned> ;
+: lm ( n -- lumen ) { m m cd } { m m } <dimensioned> ;
+: lx ( n -- lux ) { m m cd } { m m m m  } <dimensioned> ;
+: Bq ( n -- becquerel ) { } { s } <dimensioned> ;
+: Gy ( n -- gray ) { m m } { s s } <dimensioned> ;
+: Sv ( n -- sievert ) { m m } { s s } <dimensioned> ;
+: kat ( n -- katal ) { mol } { s } <dimensioned> ;
+
+! Extensions to the SI
+: minutes ( n -- minute ) 60 * s ;
+: hours ( n -- hour ) 3600 * s ;
+: month 2629743.83 * s ;
+: day 86400 * s ;
+: year 31556926 * s ;
+: arc-deg pi 180 / * radian ;
+: arc-min pi 10800 / * radian ;
+: arc-sec pi 648000 / * radian ;
+: L ( n -- liter ) 1/1000 * m^3 ;
+: t ( n -- metric-ton ) 1000 * kg ;
+: Np ( n -- neper ) { } { } <dimensioned> ;
+: B ( n -- bel ) 1.151292546497023 * Np ;
+: eV ( n -- electronvolt ) 1.60218e-19 * J ;
+: u ( n -- unified-atomic-mass-unit ) 1.66054e-27 * kg ;
+: ua ( n -- astronomical-unit ) 149598000000 * m ;
+
+: nautical-mile 1852 * m ;
+: knot 1852/3600 * m/s ;
+: a ( n -- are )100 * m^2 ;
+: ha ( n -- hectare ) 10000 * m^2 ;
+: bar ( n -- bar ) 100000 * Pa ;
+: angstrom .1 * nm ;
+: b ( n -- barn ) 1/10000000000000000000000000000 * m^2 ;
+: Ci ( n -- curie ) 37000000000 * Bq ;
+: R 0.000258 { s A } { kg } <dimensioned> ;
+: rad .01 * Gy ;
+: rem .01 * Sv ;
+