steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

units: Add exponentiation operator and a d-cube.

freebsd-work
Doug Coleman 2019-01-05 14:27:42 -06:00
parent 2cfa457258
commit e4579d02e7
2 changed files with 20 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/units/units-tests.factor
View File

@ -15,6 +15,12 @@ IN: units.tests
{ t } [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test { t } [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
{ t } [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test { t } [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
{ t } [ 2 m 3 d^ 2 m d-cube = ] unit-test
{ t } [ 2 m 3 d^ 8 { m m m } { } <dimensioned> = ] unit-test
{ t } [ 2 m -3 d^ 1/8 { } { m m m } <dimensioned> = ] unit-test
{ t } [ 2 m 0 d^ 1 scalar = ] unit-test
: km/L ( n -- d ) km 1 L d/ ; : km/L ( n -- d ) km 1 L d/ ;
: mpg ( n -- d ) miles 1 gallons d/ ; : mpg ( n -- d ) miles 1 gallons d/ ;

17
extra/units/units.factor
View File

@ -1,6 +1,5 @@
USING: accessors arrays io kernel math namespaces splitting USING: accessors arrays combinators fry inverse kernel math
prettyprint sequences sorting vectors words inverse summary math.functions sequences sets shuffle sorting splitting summary ;
shuffle math.functions sets ;
IN: units IN: units
TUPLE: dimensioned value top bot ; TUPLE: dimensioned value top bot ;
@ -61,11 +60,23 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d-sq ( d -- d ) dup d* ; : d-sq ( d -- d ) dup d* ;
: d-cube ( d -- d ) dup dup d* d* ;
: d-recip ( d -- d' ) : d-recip ( d -- d' )
>dimensioned< recip dimension-op> ; >dimensioned< recip dimension-op> ;
: d/ ( d d -- d ) d-recip d* ; : d/ ( d d -- d ) d-recip d* ;
ERROR: dimensioned-power-op-expects-integer d n ;
: d^ ( d n -- d^n )
dup integer? [ dimensioned-power-op-expects-integer ] unless
{
{ [ dup 0 > ] [ 1 - over '[ _ d* ] times ] }
{ [ dup 0 < ] [ 1 - abs over '[ _ d/ ] times ] }
{ [ dup 0 = ] [ 2drop 1 scalar ] }
} cond ;
: comparison-op ( d d -- n n ) 2dup check-dimensions 2values ; : comparison-op ( d d -- n n ) 2dup check-dimensions 2values ;
: d< ( d d -- ? ) comparison-op < ; : d< ( d d -- ? ) comparison-op < ;