core/math/math.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: math
   4 USING: errors generic kernel math-internals ;
   5
   6 GENERIC: >fixnum ( x -- y ) foldable
   7 GENERIC: >bignum ( x -- y ) foldable
   8 GENERIC: >float ( x -- y ) foldable
   9
  10 G: number= ( x y -- ? ) math-combination ; foldable
  11 M: object number= 2drop f ;
  12
  13 G: <  ( x y -- ? ) math-combination ; foldable
  14 G: <= ( x y -- ? ) math-combination ; foldable
  15 G: >  ( x y -- ? ) math-combination ; foldable
  16 G: >= ( x y -- ? ) math-combination ; foldable
  17
  18 G: +   ( x y -- z ) math-combination ; foldable
  19 G: -   ( x y -- z ) math-combination ; foldable
  20 G: *   ( x y -- z ) math-combination ; foldable
  21 G: /   ( x y -- z ) math-combination ; foldable
  22 G: /i  ( x y -- z ) math-combination ; foldable
  23 G: mod ( x y -- z ) math-combination ; foldable
  24
  25 G: /mod ( x y -- z w ) math-combination ; foldable
  26
  27 G: bitand ( x y -- z ) math-combination ; foldable
  28 G: bitor  ( x y -- z ) math-combination ; foldable
  29 G: bitxor ( x y -- z ) math-combination ; foldable
  30 G: shift  ( x n -- y ) 1 standard-combination ; foldable
  31
  32 GENERIC: bitnot ( x -- y ) foldable
  33
  34 GENERIC: abs ( x -- y ) foldable
  35 GENERIC: absq ( x -- y ) foldable
  36
  37 GENERIC: zero? ( x -- ? ) foldable
  38 M: object zero? drop f ;
  39
  40 : 1+ ( x -- y ) 1 + ; foldable
  41 : 1- ( x -- y ) 1 - ; foldable
  42 : sq ( x -- y ) dup * ; foldable
  43 : neg ( x -- -x ) 0 swap - ; foldable
  44 : recip ( x -- y ) 1 swap / ; foldable
  45 : max ( x y -- z ) [ > ] 2keep ? ; foldable
  46 : min ( x y -- z ) [ < ] 2keep ? ; foldable
  47 : between? ( x y z -- ? ) pick >= >r >= r> and ; foldable
  48 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
  49 : sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
  50 : align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
  51 : truncate ( x -- y ) dup 1 mod - ; foldable
  52
  53 : floor ( x -- y )
  54     dup 1 mod dup zero?
  55     [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
  56
  57 : ceiling ( x -- y ) neg floor neg ; foldable
  58
  59 : [-] - 0 max ; inline
  60
  61 : (repeat) ( i n quot -- )
  62     pick pick >= [
  63         3drop
  64     ] [
  65         [ swap >r call 1+ r> ] keep (repeat)
  66     ] if ; inline
  67
  68 : repeat 0 -rot (repeat) ; inline
  69
  70 : times ( n quot -- )
  71     swap [ >r dup slip r> ] repeat drop ; inline