diff --git a/contrib/math/constants.factor b/contrib/math/constants.factor new file mode 100644 index 0000000000..e74be7b7f7 --- /dev/null +++ b/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 + diff --git a/contrib/math/dimensional-analysis.factor b/contrib/math/dimensional-analysis.factor new file mode 100644 index 0000000000..997fdc51ca --- /dev/null +++ b/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 ] 2keep + >r 1+ r> [ length ] keep 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> ; + +: d- ( d d -- ) + 2dup =units? [ + "d-: dimensions must be the same" throw + ] unless + dup dimensions + >r >r 2val - r> r> ; + +: add-dimensions ( d d -- d ) + >r dimensions r> dimensions >r swap >r append r> r> append 0 -rot ; + +: (d*) + >r add-dimensions r> over set-dimensioned-val dup reduce-units ; + +: d* ( d d -- ) + 2dup 2val * (d*) ; + +: d/ ( d d -- ) + 2dup 2val / (d*) ; + + diff --git a/contrib/math/load.factor b/contrib/math/load.factor index ca0a05e95a..70afb0f0f5 100644 --- a/contrib/math/load.factor +++ b/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 diff --git a/contrib/math/units.factor b/contrib/math/units.factor new file mode 100644 index 0000000000..b96bebd1b2 --- /dev/null +++ b/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 } { } ; +: km { km } { } ; + +: ms { ms } { } ; +: s { s } { } ; + +: m/s { m } { s } ; +: m/s^2 { m } { s s } ; + +SYMBOL: kg +: kg { kg } { } ; + +! SYMBOL: N ! newtons +! : N { N } { } ; + + +! Autogenerated plz + +: mm>km mm>m m>km ; ! : mm>km 1000 / 1000 / ;