extra/units/units.factor

   1 USING: accessors arrays combinators fry inverse kernel math
   2 math.functions sequences sets shuffle sorting splitting summary ;
   3 IN: units
   4
   5 TUPLE: dimensioned value top bot ;
   6
   7 ERROR: dimensions-not-equal ;
   8
   9 M: dimensions-not-equal summary drop "Dimensions do not match" ;
  10
  11 : remove-one ( seq obj -- seq )
  12     1array split1 append ;
  13
  14 : 2remove-one ( seq seq obj -- seq seq )
  15     [ remove-one ] curry bi@ ;
  16
  17 : symbolic-reduce ( seq seq -- seq seq )
  18     2dup intersect
  19     [ first 2remove-one symbolic-reduce ] unless-empty ;
  20
  21 : <dimensioned> ( n top bot -- obj )
  22     symbolic-reduce
  23     [ natural-sort ] bi@
  24     dimensioned boa ;
  25
  26 : >dimensioned< ( d -- n top bot )
  27     [ bot>> ] [ top>> ] [ value>> ] tri ;
  28
  29 \ <dimensioned> [ [ dimensioned boa ] undo ] define-inverse
  30
  31 : dimensions ( dimensioned -- top bot )
  32     [ top>> ] [ bot>> ] bi ;
  33
  34 : check-dimensions ( d d -- )
  35     [ dimensions 2array ] same?
  36     [ dimensions-not-equal ] unless ;
  37
  38 : 2values ( dim dim -- val val ) [ value>> ] bi@ ;
  39
  40 : <dimension-op ( dim dim -- top bot val val )
  41     2dup check-dimensions dup dimensions 2swap 2values ;
  42
  43 : dimension-op> ( top bot val -- dim )
  44     -rot <dimensioned> ;
  45
  46 : d+ ( d d -- d ) <dimension-op + dimension-op> ;
  47
  48 : d- ( d d -- d ) <dimension-op - dimension-op> ;
  49
  50 : scalar ( n -- d )
  51     { } { } <dimensioned> ;
  52
  53 : d* ( d d -- d )
  54     [ dup number? [ scalar ] when ] bi@
  55     [ [ top>> ] bi@ append ] 2keep
  56     [ [ bot>> ] bi@ append ] 2keep
  57     2values * dimension-op> ;
  58
  59 : d-neg ( d -- d ) -1 d* ;
  60
  61 : d-sq ( d -- d ) dup d* ;
  62
  63 : d-cube ( d -- d ) dup dup d* d* ;
  64
  65 : d-recip ( d -- d' )
  66     >dimensioned< recip dimension-op> ;
  67
  68 : d/ ( d d -- d ) d-recip d* ;
  69
  70 ERROR: dimensioned-power-op-expects-integer d n ;
  71
  72 : d^ ( d n -- d^n )
  73     dup integer? [ dimensioned-power-op-expects-integer ] unless
  74     {
  75         { [ dup 0 > ] [ 1 - over '[ _ d* ] times ] }
  76         { [ dup 0 < ] [ 1 - abs over '[ _ d/ ] times ] }
  77         { [ dup 0 = ] [ 2drop 1 scalar ] }
  78     } cond ;
  79
  80 : comparison-op ( d d -- n n ) 2dup check-dimensions 2values ;
  81
  82 : d< ( d d -- ? ) comparison-op < ;
  83
  84 : d<= ( d d -- ? ) comparison-op <= ;
  85
  86 : d> ( d d -- ? ) comparison-op > ;
  87
  88 : d>= ( d d -- ? ) comparison-op >= ;
  89
  90 : d= ( d d -- ? ) comparison-op number= ;
  91
  92 : d~ ( d d delta -- ? ) [ comparison-op ] dip ~ ;
  93
  94 : d-min ( d d -- d ) [ d< ] most ;
  95
  96 : d-max ( d d -- d ) [ d> ] most ;
  97
  98 : d-product ( v -- d ) 1 scalar [ d* ] reduce ;
  99
 100 : d-sum ( v -- d ) [ ] [ d+ ] map-reduce ;
 101
 102 : d-infimum ( v -- d ) [ ] [ d-min ] map-reduce ;
 103
 104 : d-supremum ( v -- d ) [ ] [ d-max ] map-reduce ;
 105
 106 \ d+ [ d- ] [ d- ] define-math-inverse
 107 \ d- [ d+ ] [ d- ] define-math-inverse
 108 \ d* [ d/ ] [ d/ ] define-math-inverse
 109 \ d/ [ d* ] [ d/ ] define-math-inverse
 110 \ d-recip [ d-recip ] define-inverse