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 -- n ) foldable
   7 GENERIC: >bignum ( x -- n ) foldable
   8 GENERIC: >integer ( x -- n ) foldable
   9 GENERIC: >float ( x -- y ) foldable
  10
  11 MATH: number= ( x y -- ? ) foldable
  12
  13 M: object number= 2drop f ;
  14
  15 MATH: <  ( x y -- ? ) foldable
  16 MATH: <= ( x y -- ? ) foldable
  17 MATH: >  ( x y -- ? ) foldable
  18 MATH: >= ( x y -- ? ) foldable
  19
  20 MATH: +   ( x y -- z ) foldable
  21 MATH: -   ( x y -- z ) foldable
  22 MATH: *   ( x y -- z ) foldable
  23 MATH: /   ( x y -- z ) foldable
  24 MATH: /f  ( x y -- z ) foldable
  25 MATH: /i  ( x y -- z ) foldable
  26 MATH: mod ( x y -- z ) foldable
  27
  28 MATH: /mod ( x y -- z w ) foldable
  29
  30 MATH: bitand ( x y -- z ) foldable
  31 MATH: bitor  ( x y -- z ) foldable
  32 MATH: bitxor ( x y -- z ) foldable
  33 GENERIC# shift 1 ( x n -- y ) foldable
  34 GENERIC: bitnot ( x -- y ) foldable
  35 GENERIC# bit? 1 ( x n -- ? ) foldable
  36
  37 GENERIC: abs ( x -- y ) foldable
  38
  39 <PRIVATE
  40
  41 GENERIC: (log2) ( x -- n ) foldable
  42
  43 PRIVATE>
  44
  45 : log2 ( x -- n )
  46     dup 0 <= [
  47         "log2 expects positive inputs" throw
  48     ] [
  49         (log2)
  50     ] if ; foldable
  51
  52 : zero? ( x -- ? ) 0 number= ; inline
  53 : 1+ ( x -- y ) 1 + ; inline
  54 : 1- ( x -- y ) 1 - ; inline
  55 : 2/ ( x -- y ) -1 shift ; inline
  56 : sq ( x -- y ) dup * ; inline
  57 : neg ( x -- -x ) 0 swap - ; inline
  58 : recip ( x -- y ) 1 swap / ; inline
  59 : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
  60
  61 : ?1+ [ 1+ ] [ 0 ] if* ; inline
  62
  63 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
  64
  65 : 2^ ( n -- 2^n ) 1 swap shift ; inline
  66
  67 : even? ( n -- ? ) 1 bitand zero? ;
  68
  69 : odd? ( n -- ? ) 1 bitand 1 number= ;
  70
  71 UNION: integer fixnum bignum ;
  72
  73 UNION: rational integer ratio ;
  74
  75 UNION: real rational float ;
  76
  77 UNION: number real complex ;
  78
  79 M: number equal? number= ;
  80
  81 M: real hashcode* nip >fixnum ;
  82
  83 GENERIC: fp-nan? ( x -- ? )
  84
  85 M: object fp-nan?
  86     drop f ;
  87
  88 M: float fp-nan?
  89     double>bits -51 shift BIN: 111111111111 [ bitand ] keep
  90     number= ;
  91
  92 : (next-power-of-2) ( i n -- n )
  93     2dup >= [
  94         drop
  95     ] [
  96         >r 1 shift r> (next-power-of-2)
  97     ] if ;
  98
  99 : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
 100
 101 : power-of-2? ( n -- ? )
 102     dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
 103
 104 : align ( m w -- n )
 105     1- [ + ] keep bitnot bitand ; inline
 106
 107 <PRIVATE
 108
 109 : iterate-prep 0 -rot ; inline
 110
 111 : if-iterate? >r >r 2over < r> r> if ; inline
 112
 113 : iterate-step ( i n quot -- i n quot )
 114     #! Apply quot to i, keep i and quot, hide n.
 115     swap >r 2dup 2slip r> swap ; inline
 116
 117 : iterate-next >r >r 1+ r> r> ; inline
 118
 119 PRIVATE>
 120
 121 : (each-integer) ( i n quot -- )
 122     [ iterate-step iterate-next (each-integer) ]
 123     [ 3drop ] if-iterate? ; inline
 124
 125 : (find-integer) ( i n quot -- i )
 126     [
 127         iterate-step roll
 128         [ 2drop ] [ iterate-next (find-integer) ] if
 129     ] [ 3drop f ] if-iterate? ; inline
 130
 131 : (all-integers?) ( i n quot -- ? )
 132     [
 133         iterate-step roll
 134         [ iterate-next (all-integers?) ] [ 3drop f ] if
 135     ] [ 3drop t ] if-iterate? ; inline
 136
 137 : each-integer ( n quot -- )
 138     iterate-prep (each-integer) ; inline
 139
 140 : times ( n quot -- )
 141     [ drop ] prepose each-integer ; inline
 142
 143 : find-integer ( n quot -- i )
 144     iterate-prep (find-integer) ; inline
 145
 146 : all-integers? ( n quot -- ? )
 147     iterate-prep (all-integers?) ; inline
 148
 149 : find-last-integer ( n quot -- i )
 150     over 0 < [
 151         2drop f
 152     ] [
 153         2dup 2slip rot [
 154             drop
 155         ] [
 156             >r 1- r> find-last-integer
 157         ] if
 158     ] if ; inline