extra/units/units.factor

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