core/math/math.factor

   1 ! Copyright (C) 2003, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math.private ;
   4 IN: math
   5
   6 GENERIC: >fixnum ( x -- y ) foldable
   7 GENERIC: >bignum ( x -- y ) foldable
   8 GENERIC: >float ( x -- y ) foldable
   9
  10 MATH: number= ( x y -- ? ) foldable
  11 M: object number= 2drop f ;
  12
  13 MATH: <  ( x y -- ? ) foldable
  14 MATH: <= ( x y -- ? ) foldable
  15 MATH: >  ( x y -- ? ) foldable
  16 MATH: >= ( x y -- ? ) foldable
  17
  18 MATH: +   ( x y -- z ) foldable
  19 MATH: -   ( x y -- z ) foldable
  20 MATH: *   ( x y -- z ) foldable
  21 MATH: /   ( x y -- z ) foldable
  22 MATH: /i  ( x y -- z ) foldable
  23 MATH: mod ( x y -- z ) foldable
  24
  25 MATH: /mod ( x y -- z w ) foldable
  26
  27 MATH: bitand ( x y -- z ) foldable
  28 MATH: bitor  ( x y -- z ) foldable
  29 MATH: bitxor ( x y -- z ) foldable
  30 GENERIC# shift 1 ( x n -- y ) foldable
  31 GENERIC: bitnot ( x -- y ) foldable
  32 GENERIC# bit? 1 ( x n -- ? ) foldable
  33
  34 <PRIVATE
  35
  36 GENERIC: (log2) ( x -- n ) foldable
  37
  38 PRIVATE>
  39
  40 : log2 ( x -- n )
  41     dup 0 <= [
  42         "log2 expects positive inputs" throw
  43     ] [
  44         (log2)
  45     ] if ; foldable
  46
  47 GENERIC: zero? ( x -- ? ) foldable
  48
  49 M: object zero? drop f ;
  50
  51 GENERIC: sqrt ( x -- y ) foldable
  52
  53 : 1+ ( x -- y ) 1 + ; foldable
  54 : 1- ( x -- y ) 1 - ; foldable
  55 : 2/ ( x -- y ) -1 shift ; foldable
  56 : sq ( x -- y ) dup * ; foldable
  57 : neg ( x -- -x ) 0 swap - ; foldable
  58 : recip ( x -- y ) 1 swap / ; foldable
  59
  60 : /f  ( x y -- z ) >r >float r> >float float/f ; inline
  61
  62 : max ( x y -- z ) [ > ] most ; foldable
  63 : min ( x y -- z ) [ < ] most ; foldable
  64
  65 : between? ( x y z -- ? )
  66     pick >= [ >= ] [ 2drop f ] if ; inline
  67
  68 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
  69 : sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
  70 : truncate ( x -- y ) dup 1 mod - ; inline
  71 : round ( x -- y ) dup sgn 2 / + truncate ; inline
  72
  73 : floor ( x -- y )
  74     dup 1 mod dup zero?
  75     [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
  76
  77 : ceiling ( x -- y ) neg floor neg ; foldable
  78
  79 : [-] ( x y -- z ) - 0 max ; inline
  80
  81 : 2^ ( n -- 2^n ) 1 swap shift ; inline
  82
  83 : even? ( n -- ? ) 1 bitand zero? ;
  84
  85 : odd? ( n -- ? ) 1 bitand 1 number= ;
  86
  87 : >fraction ( a/b -- a b )
  88     dup numerator swap denominator ; inline
  89
  90 UNION: integer fixnum bignum ;
  91
  92 UNION: rational integer ratio ;
  93
  94 UNION: real rational float ;
  95
  96 UNION: number real complex ;
  97
  98 GENERIC: fp-nan? ( x -- ? )
  99
 100 M: object fp-nan?
 101     drop f ;
 102
 103 M: float fp-nan?
 104     double>bits -51 shift BIN: 111111111111 [ bitand ] keep
 105     number= ;
 106
 107 <PRIVATE
 108
 109 : (rect>) ( x y -- z )
 110     dup zero? [ drop ] [ <complex> ] if ; inline
 111
 112 PRIVATE>
 113
 114 : rect> ( x y -- z )
 115     over real? over real? and [
 116         (rect>)
 117     ] [
 118         "Complex number must have real components" throw
 119     ] if ; inline
 120
 121 : >rect ( z -- x y ) dup real swap imaginary ; inline
 122
 123 : >float-rect ( z -- x y )
 124     >rect swap >float swap >float ; inline
 125
 126 : (next-power-of-2) ( i n -- n )
 127     2dup >= [
 128         drop
 129     ] [
 130         >r 1 shift r> (next-power-of-2)
 131     ] if ;
 132
 133 : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
 134
 135 <PRIVATE
 136
 137 : iterate-prep 0 -rot ; inline
 138
 139 : if-iterate? >r >r pick pick < r> r> if ; inline
 140
 141 : iterate-step ( i n quot -- i n quot )
 142     #! Apply quot to i, keep i and quot, hide n.
 143     swap >r 2dup 2slip r> swap ; inline
 144
 145 : iterate-next >r >r 1+ r> r> ; inline
 146
 147 PRIVATE>
 148
 149 : (each-integer) ( i n quot -- )
 150     [ iterate-step iterate-next (each-integer) ]
 151     [ 3drop ] if-iterate? ; inline
 152
 153 : (find-integer) ( i n quot -- i )
 154     [
 155         iterate-step roll
 156         [ 2drop ] [ iterate-next (find-integer) ] if
 157     ] [ 3drop f ] if-iterate? ; inline
 158
 159 : (all-integers?) ( i n quot -- ? )
 160     [
 161         iterate-step roll
 162         [ iterate-next (all-integers?) ] [ 3drop f ] if
 163     ] [ 3drop t ] if-iterate? ; inline
 164
 165 : each-integer ( n quot -- )
 166     iterate-prep (each-integer) ; inline
 167
 168 : times ( n quot -- )
 169     [ drop ] swap compose each-integer ; inline
 170
 171 : find-integer ( n quot -- i )
 172     iterate-prep (find-integer) ; inline
 173
 174 : all-integers? ( n quot -- ? )
 175     iterate-prep (all-integers?) ; inline
 176
 177 : find-last-integer ( n quot -- i )
 178     over 0 < [
 179         2drop f
 180     ] [
 181         2dup 2slip rot [
 182             drop
 183         ] [
 184             >r 1- r> find-last-integer
 185         ] if
 186     ] if ; inline