core/math/integers/integers.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! Copyright (C) 2008, Doug Coleman.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: kernel kernel.private sequences
   5 sequences.private math math.private combinators ;
   6 IN: math.integers.private
   7
   8 M: integer numerator ;
   9 M: integer denominator drop 1 ;
  10
  11 M: fixnum >fixnum ;
  12 M: fixnum >bignum fixnum>bignum ;
  13 M: fixnum >integer ;
  14
  15 M: fixnum hashcode* nip ;
  16 M: fixnum equal? over bignum? [ >bignum bignum= ] [ 2drop f ] if ;
  17 M: fixnum number= eq? ;
  18
  19 M: fixnum < fixnum< ;
  20 M: fixnum <= fixnum<= ;
  21 M: fixnum > fixnum> ;
  22 M: fixnum >= fixnum>= ;
  23
  24 M: fixnum + fixnum+ ;
  25 M: fixnum - fixnum- ;
  26 M: fixnum * fixnum* ;
  27 M: fixnum /i fixnum/i ;
  28 M: fixnum /f [ >float ] dip >float float/f ;
  29
  30 M: fixnum mod fixnum-mod ;
  31
  32 M: fixnum /mod fixnum/mod ;
  33
  34 M: fixnum bitand fixnum-bitand ;
  35 M: fixnum bitor fixnum-bitor ;
  36 M: fixnum bitxor fixnum-bitxor ;
  37 M: fixnum shift >fixnum fixnum-shift ;
  38
  39 M: fixnum bitnot fixnum-bitnot ;
  40
  41 M: fixnum bit? neg shift 1 bitand 0 > ;
  42
  43 : fixnum-log2 ( x -- n )
  44     0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ;
  45
  46 M: fixnum (log2) fixnum-log2 ;
  47
  48 M: integer next-power-of-2
  49     dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ;
  50
  51 M: bignum >fixnum bignum>fixnum ;
  52 M: bignum >bignum ;
  53
  54 M: bignum hashcode* nip >fixnum ;
  55
  56 M: bignum equal?
  57     over bignum? [ bignum= ] [
  58         swap dup fixnum? [ >bignum bignum= ] [ 2drop f ] if
  59     ] if ;
  60
  61 M: bignum number= bignum= ;
  62
  63 M: bignum < bignum< ;
  64 M: bignum <= bignum<= ;
  65 M: bignum > bignum> ;
  66 M: bignum >= bignum>= ;
  67
  68 M: bignum + bignum+ ;
  69 M: bignum - bignum- ;
  70 M: bignum * bignum* ;
  71 M: bignum /i bignum/i ;
  72 M: bignum mod bignum-mod ;
  73
  74 M: bignum /mod bignum/mod ;
  75
  76 M: bignum bitand bignum-bitand ;
  77 M: bignum bitor bignum-bitor ;
  78 M: bignum bitxor bignum-bitxor ;
  79 M: bignum shift bignum-shift ;
  80
  81 M: bignum bitnot bignum-bitnot ;
  82 M: bignum bit? bignum-bit? ;
  83 M: bignum (log2) bignum-log2 ;
  84
  85 ! Converting ratios to floats. Based on FLOAT-RATIO from
  86 ! sbcl/src/code/float.lisp, which has the following license:
  87
  88 ! "The software is in the public domain and is
  89 ! provided with absolutely no warranty."
  90
  91 ! First step: pre-scaling
  92 : twos ( x -- y ) dup 1- bitxor log2 ; inline
  93
  94 : scale-denonimator ( den -- scaled-den scale' )
  95     dup twos neg [ shift ] keep ; inline
  96
  97 : pre-scale ( num den -- scale shifted-num scaled-den )
  98     2dup [ log2 ] bi@ -
  99     tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi*
 100     -rot ; inline
 101
 102 ! Second step: loop
 103 : shift-mantissa ( scale mantissa -- scale' mantissa' )
 104     [ 1+ ] [ 2/ ] bi* ; inline
 105
 106 : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
 107     [ 2dup /i log2 53 > ]
 108     [ [ shift-mantissa ] dip ]
 109     [ ] while /mod ; inline
 110
 111 ! Third step: post-scaling
 112 : unscaled-float ( mantissa -- n )
 113     52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
 114
 115 : scale-float ( scale mantissa -- float' )
 116     [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
 117
 118 : post-scale ( scale mantissa -- n )
 119     2/ dup log2 52 > [ shift-mantissa ] when
 120     unscaled-float scale-float ; inline
 121
 122 ! Main word
 123 : /f-abs ( m n -- f )
 124     over zero? [
 125         2drop 0.0
 126     ] [
 127         dup zero? [
 128             2drop 1.0/0.0
 129         ] [
 130             pre-scale
 131             /f-loop over odd?
 132             [ zero? [ 1+ ] unless ] [ drop ] if
 133             post-scale
 134         ] if
 135     ] if ; inline
 136
 137 M: bignum /f ( m n -- f )
 138     [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;