core/math/parser/parser.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math.private namespaces sequences strings
   4 arrays combinators splitting math assocs 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 ;
  32
  33 : string>digits ( str -- digits )
  34     [ digit> ] { } map-as ;
  35
  36 : digits>integer ( seq radix -- n )
  37     0 swap [ swapd * + ] curry reduce ;
  38
  39 DEFER: base>
  40
  41 <PRIVATE
  42
  43 SYMBOL: radix
  44 SYMBOL: negative?
  45
  46 : sign ( -- str ) negative? get "-" "+" ? ;
  47
  48 : with-radix ( radix quot -- )
  49     radix swap with-variable ; inline
  50
  51 : (base>) ( str -- n ) radix get base> ;
  52
  53 : whole-part ( str -- m n )
  54     sign split1 [ (base>) ] dip
  55     dup [ (base>) ] [ drop 0 swap ] if ;
  56
  57 : string>ratio ( str -- a/b )
  58     "-" ?head dup negative? set swap
  59     "/" split1 (base>) [ whole-part ] dip
  60     3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
  61
  62 : valid-digits? ( seq -- ? )
  63     {
  64         { [ dup empty? ] [ drop f ] }
  65         { [ f over memq? ] [ drop f ] }
  66         [ radix get [ < ] curry all? ]
  67     } cond ;
  68
  69 : string>integer ( str -- n/f )
  70     "-" ?head swap
  71     string>digits dup valid-digits?
  72     [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
  73
  74 PRIVATE>
  75
  76 : base> ( str radix -- n/f )
  77     [
  78         CHAR: / over member? [
  79             string>ratio
  80         ] [
  81             CHAR: . over member? [
  82                 string>float
  83             ] [
  84                 string>integer
  85             ] if
  86         ] if
  87     ] with-radix ;
  88
  89 : string>number ( str -- n/f ) 10 base> ;
  90 : bin> ( str -- n/f ) 2 base> ;
  91 : oct> ( str -- n/f ) 8 base> ;
  92 : hex> ( str -- n/f ) 16 base> ;
  93
  94 : >digit ( n -- ch )
  95     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
  96
  97 : positive>base ( num radix -- str )
  98     dup 1 <= [ "Invalid radix" throw ] when
  99     [ dup 0 > ] swap [ /mod >digit ] curry [ ] "" produce-as nip
 100     dup reverse-here ; inline
 101
 102 PRIVATE>
 103
 104 GENERIC# >base 1 ( n radix -- str )
 105
 106 <PRIVATE
 107
 108 : (>base) ( n -- str ) radix get positive>base ;
 109
 110 PRIVATE>
 111
 112 M: integer >base
 113     over 0 = [
 114         2drop "0"
 115     ] [
 116         over 0 > [
 117             positive>base
 118         ] [
 119             [ neg ] dip positive>base CHAR: - prefix
 120         ] if
 121     ] if ;
 122
 123 M: ratio >base
 124     [
 125         dup 0 < negative? set
 126         abs 1 /mod
 127         [ dup zero? [ drop "" ] [ (>base) sign append ] if ]
 128         [
 129             [ numerator (>base) ]
 130             [ denominator (>base) ] bi
 131             "/" glue
 132         ] bi* append
 133         negative? get [ CHAR: - prefix ] when
 134     ] with-radix ;
 135
 136 : fix-float ( str -- newstr )
 137     {
 138         {
 139             [ CHAR: e over member? ]
 140             [ "e" split1 [ fix-float "e" ] dip 3append ]
 141         } {
 142             [ CHAR: . over member? ]
 143             [ ]
 144         }
 145         [ ".0" append ]
 146     } cond ;
 147
 148 M: float >base
 149     drop {
 150         { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
 151         { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
 152         { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
 153         { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
 154         [ float>string fix-float ]
 155     } cond ;
 156
 157 : number>string ( n -- str ) 10 >base ;
 158 : >bin ( n -- str ) 2 >base ;
 159 : >oct ( n -- str ) 8 >base ;
 160 : >hex ( n -- str ) 16 >base ;
 161
 162 : # ( n -- ) number>string % ;