core/math/parser/parser.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math.private namespaces sequences sequences.private
   4 strings arrays combinators splitting math assocs byte-arrays make ;
   5 IN: math.parser
   6
   7 : digit> ( ch -- n )
   8     H{
   9         { CHAR: 0 0 }
  10         { CHAR: 1 1 }
  11         { CHAR: 2 2 }
  12         { CHAR: 3 3 }
  13         { CHAR: 4 4 }
  14         { CHAR: 5 5 }
  15         { CHAR: 6 6 }
  16         { CHAR: 7 7 }
  17         { CHAR: 8 8 }
  18         { CHAR: 9 9 }
  19         { CHAR: A 10 }
  20         { CHAR: B 11 }
  21         { CHAR: C 12 }
  22         { CHAR: D 13 }
  23         { CHAR: E 14 }
  24         { CHAR: F 15 }
  25         { CHAR: a 10 }
  26         { CHAR: b 11 }
  27         { CHAR: c 12 }
  28         { CHAR: d 13 }
  29         { CHAR: e 14 }
  30         { CHAR: f 15 }
  31     } at 255 or ; inline
  32
  33 : string>digits ( str -- digits )
  34     [ digit> ] B{ } map-as ; inline
  35
  36 : (digits>integer) ( valid? accum digit radix -- valid? accum )
  37     2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
  38
  39 : each-digit ( seq radix quot -- n/f )
  40     [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
  41
  42 : digits>integer ( seq radix -- n/f )
  43     [ (digits>integer) ] each-digit ; inline
  44
  45 DEFER: base>
  46
  47 <PRIVATE
  48
  49 SYMBOL: radix
  50 SYMBOL: negative?
  51
  52 : string>natural ( seq radix -- n/f )
  53     over empty? [ 2drop f ] [
  54         [ [ digit> ] dip (digits>integer) ] each-digit
  55     ] if ; inline
  56
  57 : sign ( -- str ) negative? get "-" "+" ? ;
  58
  59 : with-radix ( radix quot -- )
  60     radix swap with-variable ; inline
  61
  62 : (base>) ( str -- n ) radix get base> ;
  63
  64 : whole-part ( str -- m n )
  65     sign split1 [ (base>) ] dip
  66     dup [ (base>) ] [ drop 0 swap ] if ;
  67
  68 : string>ratio ( str radix -- a/b )
  69     [
  70         "-" ?head dup negative? set swap
  71         "/" split1 (base>) [ whole-part ] dip
  72         3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
  73     ] with-radix ;
  74
  75 : string>integer ( str radix -- n/f )
  76     over first-unsafe CHAR: - = [
  77         [ rest-slice ] dip string>natural dup [ neg ] when
  78     ] [
  79         string>natural
  80     ] if ; inline
  81
  82 : string>float ( str -- n/f )
  83     >byte-array 0 suffix (string>float) ;
  84
  85 PRIVATE>
  86
  87 : base> ( str radix -- n/f )
  88     over empty? [ 2drop f ] [
  89         over [ "/." member? ] find nip {
  90             { CHAR: / [ string>ratio ] }
  91             { CHAR: . [ drop string>float ] }
  92             [ drop string>integer ]
  93         } case
  94     ] if ;
  95
  96 : string>number ( str -- n/f ) 10 base> ;
  97 : bin> ( str -- n/f ) 2 base> ;
  98 : oct> ( str -- n/f ) 8 base> ;
  99 : hex> ( str -- n/f ) 16 base> ;
 100
 101 : >digit ( n -- ch )
 102     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
 103
 104 : positive>base ( num radix -- str )
 105     dup 1 <= [ "Invalid radix" throw ] when
 106     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 107     dup reverse-here ; inline
 108
 109 PRIVATE>
 110
 111 GENERIC# >base 1 ( n radix -- str )
 112
 113 <PRIVATE
 114
 115 : (>base) ( n -- str ) radix get positive>base ;
 116
 117 PRIVATE>
 118
 119 M: integer >base
 120     over 0 = [
 121         2drop "0"
 122     ] [
 123         over 0 > [
 124             positive>base
 125         ] [
 126             [ neg ] dip positive>base CHAR: - prefix
 127         ] if
 128     ] if ;
 129
 130 M: ratio >base
 131     [
 132         dup 0 < negative? set
 133         abs 1 /mod
 134         [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
 135         [
 136             [ numerator (>base) ]
 137             [ denominator (>base) ] bi
 138             "/" glue
 139         ] bi* append
 140         negative? get [ CHAR: - prefix ] when
 141     ] with-radix ;
 142
 143 : fix-float ( str -- newstr )
 144     {
 145         {
 146             [ CHAR: e over member? ]
 147             [ "e" split1 [ fix-float "e" ] dip 3append ]
 148         } {
 149             [ CHAR: . over member? ]
 150             [ ]
 151         }
 152         [ ".0" append ]
 153     } cond ;
 154
 155 : float>string ( n -- str )
 156     (float>string)
 157     [ 0 = ] trim-tail >string
 158     fix-float ;
 159
 160 M: float >base
 161     drop {
 162         { [ dup fp-nan? ] [ drop "0/0." ] }
 163         { [ dup 1/0. = ] [ drop "1/0." ] }
 164         { [ dup -1/0. = ] [ drop "-1/0." ] }
 165         { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
 166         [ float>string ]
 167     } cond ;
 168
 169 : number>string ( n -- str ) 10 >base ;
 170 : >bin ( n -- str ) 2 >base ;
 171 : >oct ( n -- str ) 8 >base ;
 172 : >hex ( n -- str ) 16 >base ;
 173
 174 : # ( n -- ) number>string % ;