basis/math/functions/integer-logs/integer-logs.factor

   1 ! Copyright (C) 2017 Jon Harper.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel kernel.private math math.functions
   4 math.functions.private math.private sequences.private ;
   5 IN: math.functions.integer-logs
   6
   7 <PRIVATE
   8
   9 GENERIC: (integer-log10) ( x -- n ) foldable
  10
  11 ! For 32 bits systems, we could reduce
  12 ! this to the first 27 elements..
  13 CONSTANT: log10-guesses {
  14     0 0 0 0 1 1 1 2 2 2 3 3 3 3
  15     4 4 4 5 5 5 6 6 6 6 7 7 7 8
  16     8 8 9 9 9 9 10 10 10 11 11 11
  17     12 12 12 12 13 13 13 14 14 14
  18     15 15 15 15 16 16 16 17 17
  19 }
  20
  21 ! This table will hold a few unused bignums on 32 bits systems...
  22 ! It could be reduced to the first 8 elements
  23 ! Note that even though the 64 bits most-positive-fixnum
  24 ! is hardcoded here this table also works (by chance) for 32bit systems.
  25 ! This is because there is only one power of 2 greater than the
  26 ! greatest power of 10 for 27 bit unsigned integers so we don't
  27 ! need to hardcode the 32 bits most-positive-fixnum. See the
  28 ! table below for powers of 2 and powers of 10 around the
  29 ! most-positive-fixnum.
  30 !
  31 ! 67108864  2^26    | 72057594037927936   2^56
  32 ! 99999999  10^8    | 99999999999999999  10^17
  33 ! 134217727 2^27-1  | 144115188075855872  2^57
  34 !                   | 288230376151711744  2^58
  35 !                   | 576460752303423487  2^59-1
  36 CONSTANT: log10-thresholds {
  37     9 99 999 9999 99999 999999
  38     9999999 99999999 999999999
  39     9999999999 99999999999
  40     999999999999 9999999999999
  41     99999999999999 999999999999999
  42     9999999999999999 99999999999999999
  43     576460752303423487
  44 }
  45
  46 : fixnum-integer-log10 ( n -- x )
  47     dup (log2) { array-capacity } declare
  48     log10-guesses nth-unsafe { array-capacity } declare
  49     dup log10-thresholds nth-unsafe { fixnum } declare
  50     rot < [ 1 + ] when ; inline
  51
  52 ! bignum-integer-log10-find-down and bignum-integer-log10-find-up
  53 ! work with very bad guesses, but in practice they will never loop
  54 ! more than once.
  55 : bignum-integer-log10-find-down ( guess 10^guess n -- log10 )
  56     [ 2dup > ] [ [ [ 1 - ] [ 10 / ] bi* ] dip ] do while 2drop ;
  57
  58 : bignum-integer-log10-find-up ( guess 10^guess n -- log10 )
  59     [ 10 * ] dip
  60     [ 2dup <= ] [ [ [ 1 + ] [ 10 * ] bi* ] dip ] while 2drop ;
  61
  62 : bignum-integer-log10-guess ( n -- guess 10^guess )
  63     (log2) >integer log10-2 * >integer dup 10^ ;
  64
  65 : bignum-integer-log10 ( n -- x )
  66     [ bignum-integer-log10-guess ] keep 2dup >
  67     [ bignum-integer-log10-find-down ]
  68     [ bignum-integer-log10-find-up ] if ; inline
  69
  70 M: fixnum (integer-log10) fixnum-integer-log10 { fixnum } declare ; inline
  71
  72 M: bignum (integer-log10) bignum-integer-log10 ; inline
  73
  74 PRIVATE>
  75
  76 ERROR: log-expects-positive x ;
  77
  78 <PRIVATE
  79
  80 GENERIC: (integer-log2) ( x -- n ) foldable
  81
  82 M: integer (integer-log2) ( x -- n ) (log2) ; inline
  83
  84 : ((ratio-integer-log)) ( ratio quot -- log )
  85     [ >integer ] dip call ; inline
  86
  87 : (ratio-integer-log) ( ratio quot base -- log )
  88     pick 1 >=
  89     [ drop ((ratio-integer-log)) ] [
  90         [ recip ] 2dip
  91         [ drop ((ratio-integer-log)) ] [ nip pick ^ = ] 3bi
  92         [ 1 + ] unless neg
  93     ] if ; inline
  94
  95 M: ratio (integer-log2) ( r -- n ) [ (integer-log2) ] 2 (ratio-integer-log) ;
  96
  97 M: ratio (integer-log10) ( r -- n )  [ (integer-log10) ] 10 (ratio-integer-log) ;
  98
  99 : (integer-log) ( x quot -- n )
 100     [ dup 0 > ] dip [ log-expects-positive ] if ; inline
 101
 102 PRIVATE>
 103
 104 : integer-log10 ( x -- n )
 105     [ (integer-log10) ] (integer-log) ; inline
 106
 107 : integer-log2 ( x -- n )
 108     [ (integer-log2) ] (integer-log) ; inline