/core/math/parser/parser.factor

http://github.com/abeaumont/factor · Factor · 431 lines · 334 code · 96 blank · 1 comment · 83 complexity · b4dc9265248659c11ff9edfe3ac4a060 MD5 · raw file

  1. ! (c)2009 Joe Groff bsd license
  2. USING: accessors byte-arrays combinators kernel kernel.private
  3. make math namespaces sequences sequences.private splitting
  4. strings ;
  5. IN: math.parser
  6. : digit> ( ch -- n )
  7. {
  8. { [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
  9. { [ dup CHAR: a < ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
  10. [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
  11. } cond ; inline
  12. ERROR: invalid-radix radix ;
  13. <PRIVATE
  14. TUPLE: number-parse
  15. { str read-only }
  16. { length fixnum read-only }
  17. { radix fixnum read-only } ;
  18. : <number-parse> ( str radix -- i number-parse n )
  19. [ 0 ] 2dip
  20. [ dup length ] dip
  21. number-parse boa
  22. 0 ; inline
  23. : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
  24. [ 2over length>> < ] 2dip
  25. [ [ 2over str>> nth-unsafe >fixnum [ 1 + >fixnum ] 3dip ] prepose ] dip if ; inline
  26. : require-next-digit ( i number-parse n quot -- n/f )
  27. [ 3drop f ] (next-digit) ; inline
  28. : next-digit ( i number-parse n quot -- n/f )
  29. [ 2nip ] (next-digit) ; inline
  30. : add-digit ( i number-parse n digit quot -- n/f )
  31. [ [ dup radix>> ] [ * ] [ + ] tri* ] dip next-digit ; inline
  32. : digit-in-radix ( number-parse n char -- number-parse n digit ? )
  33. digit> pick radix>> over > ; inline
  34. : ?make-ratio ( num denom/f -- ratio/f )
  35. [ / ] [ drop f ] if* ; inline
  36. TUPLE: float-parse
  37. { radix read-only }
  38. { point read-only }
  39. { exponent read-only } ;
  40. : inc-point ( float-parse -- float-parse' )
  41. [ radix>> ] [ point>> 1 + ] [ exponent>> ] tri float-parse boa ; inline
  42. : store-exponent ( float-parse n expt -- float-parse' n )
  43. swap [ [ drop radix>> ] [ drop point>> ] [ nip ] 2tri float-parse boa ] dip ; inline
  44. : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  45. [ store-exponent ] [ drop f ] if* ; inline
  46. : ((pow)) ( base x -- base^x )
  47. iota 1 rot [ nip * ] curry reduce ; inline
  48. : (pow) ( base x -- base^x )
  49. dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
  50. : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
  51. [ [ inc-point ] 4dip ] dip add-digit ; inline
  52. : make-float-dec-exponent ( float-parse n/f -- float/f )
  53. [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ] [ swap /f ] bi* ; inline
  54. : make-float-bin-exponent ( float-parse n/f -- float/f )
  55. [ drop [ radix>> ] [ point>> ] bi (pow) ]
  56. [ nip swap /f ]
  57. [ drop 2.0 swap exponent>> (pow) * ] 2tri ; inline
  58. : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
  59. over exponent>> [
  60. over radix>> 10 =
  61. [ [ [ radix>> ] [ point>> ] bi 0 float-parse boa ] dip ]
  62. [ drop f ] if
  63. ] unless ; inline
  64. : ?make-float ( float-parse n/f -- float/f )
  65. { float-parse object } declare
  66. ?default-exponent
  67. {
  68. { [ dup not ] [ 2drop f ] }
  69. { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
  70. [ make-float-bin-exponent ]
  71. } cond ;
  72. : ?neg ( n/f -- -n/f )
  73. [ neg ] [ f ] if* ; inline
  74. : ?add-ratio ( m n/f -- m+n/f )
  75. dup ratio? [ + ] [ 2drop f ] if ; inline
  76. : @abort ( i number-parse n x -- f )
  77. 4drop f ; inline
  78. : @split ( i number-parse n -- n i number-parse n' )
  79. -rot 0 ; inline
  80. : @split-exponent ( i number-parse n -- n i number-parse' n' )
  81. -rot [ str>> ] [ length>> ] bi 10 number-parse boa 0 ; inline
  82. : <float-parse> ( i number-parse n -- float-parse i number-parse n )
  83. [ drop nip radix>> 0 f float-parse boa ] 3keep ; inline
  84. DEFER: @exponent-digit
  85. DEFER: @mantissa-digit
  86. DEFER: @denom-digit
  87. DEFER: @num-digit
  88. DEFER: @pos-digit
  89. DEFER: @neg-digit
  90. : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
  91. {
  92. { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
  93. [ @exponent-digit ]
  94. } case ; inline
  95. : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
  96. { float-parse fixnum number-parse integer fixnum } declare
  97. digit-in-radix [ [ @exponent-digit-or-punc ] add-digit ] [ @abort ] if ;
  98. : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
  99. {
  100. { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
  101. { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
  102. [ @exponent-digit ]
  103. } case ; inline
  104. : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
  105. @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
  106. : exponent-char? ( number-parse n char -- number-parse n char ? )
  107. 3dup nip swap radix>> {
  108. { 10 [ [ CHAR: e CHAR: E ] dip [ = ] curry either? ] }
  109. [ drop [ CHAR: p CHAR: P ] dip [ = ] curry either? ]
  110. } case ; inline
  111. : or-exponent ( i number-parse n char quot -- n/f )
  112. [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
  113. : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
  114. [ exponent-char? [ drop ->exponent ] ] dip if ; inline
  115. : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
  116. {
  117. { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
  118. [ @mantissa-digit ]
  119. } case ; inline
  120. : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
  121. { float-parse fixnum number-parse integer fixnum } declare
  122. [
  123. digit-in-radix
  124. [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
  125. [ @abort ] if
  126. ] or-mantissa->exponent ;
  127. : ->mantissa ( i number-parse n -- n/f )
  128. <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
  129. : ->required-mantissa ( i number-parse n -- n/f )
  130. <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
  131. : @denom-digit-or-punc ( i number-parse n char -- n/f )
  132. {
  133. { CHAR: , [ [ @denom-digit ] require-next-digit ] }
  134. { CHAR: . [ ->mantissa ] }
  135. [ [ @denom-digit ] or-exponent ]
  136. } case ; inline
  137. : @denom-digit ( i number-parse n char -- n/f )
  138. { fixnum number-parse integer fixnum } declare
  139. digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
  140. : @denom-first-digit ( i number-parse n char -- n/f )
  141. {
  142. { CHAR: . [ ->mantissa ] }
  143. [ @denom-digit ]
  144. } case ; inline
  145. : ->denominator ( i number-parse n -- n/f )
  146. { fixnum number-parse integer } declare
  147. @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
  148. : @num-digit-or-punc ( i number-parse n char -- n/f )
  149. {
  150. { CHAR: , [ [ @num-digit ] require-next-digit ] }
  151. { CHAR: / [ ->denominator ] }
  152. [ @num-digit ]
  153. } case ; inline
  154. : @num-digit ( i number-parse n char -- n/f )
  155. { fixnum number-parse integer fixnum } declare
  156. digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
  157. : ->numerator ( i number-parse n -- n/f )
  158. { fixnum number-parse integer } declare
  159. @split [ @num-digit ] require-next-digit ?add-ratio ;
  160. : @pos-digit-or-punc ( i number-parse n char -- n/f )
  161. {
  162. { CHAR: , [ [ @pos-digit ] require-next-digit ] }
  163. { CHAR: + [ ->numerator ] }
  164. { CHAR: / [ ->denominator ] }
  165. { CHAR: . [ ->mantissa ] }
  166. [ [ @pos-digit ] or-exponent ]
  167. } case ; inline
  168. : @pos-digit ( i number-parse n char -- n/f )
  169. { fixnum number-parse integer fixnum } declare
  170. digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
  171. : (->radix) ( number-parse radix -- number-parse' )
  172. [ [ str>> ] [ length>> ] bi ] dip number-parse boa ; inline
  173. : ->radix ( i number-parse n quot radix -- i number-parse n quot )
  174. [ (->radix) ] curry 2dip ; inline
  175. : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
  176. [
  177. rot {
  178. { CHAR: b [ drop 2 ->radix require-next-digit ] }
  179. { CHAR: o [ drop 8 ->radix require-next-digit ] }
  180. { CHAR: x [ drop 16 ->radix require-next-digit ] }
  181. { f [ 3drop 2drop 0 ] }
  182. [ [ drop ] 2dip swap call ]
  183. } case
  184. ] 2curry next-digit ; inline
  185. : @pos-first-digit ( i number-parse n char -- n/f )
  186. {
  187. { CHAR: . [ ->required-mantissa ] }
  188. { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
  189. [ @pos-digit ]
  190. } case ; inline
  191. : @neg-digit-or-punc ( i number-parse n char -- n/f )
  192. {
  193. { CHAR: , [ [ @neg-digit ] require-next-digit ] }
  194. { CHAR: - [ ->numerator ] }
  195. { CHAR: / [ ->denominator ] }
  196. { CHAR: . [ ->mantissa ] }
  197. [ [ @neg-digit ] or-exponent ]
  198. } case ; inline
  199. : @neg-digit ( i number-parse n char -- n/f )
  200. { fixnum number-parse integer fixnum } declare
  201. digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
  202. : @neg-first-digit ( i number-parse n char -- n/f )
  203. {
  204. { CHAR: . [ ->required-mantissa ] }
  205. { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
  206. [ @neg-digit ]
  207. } case ; inline
  208. : @first-char ( i number-parse n char -- n/f )
  209. {
  210. { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
  211. { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
  212. [ @pos-first-digit ]
  213. } case ; inline
  214. : @first-char-no-radix ( i number-parse n char -- n/f )
  215. {
  216. { CHAR: - [ [ @neg-digit ] require-next-digit ?neg ] }
  217. { CHAR: + [ [ @pos-digit ] require-next-digit ] }
  218. [ @pos-digit ]
  219. } case ; inline
  220. PRIVATE>
  221. : string>number ( str -- n/f )
  222. 10 <number-parse> [ @first-char ] require-next-digit ;
  223. : base> ( str radix -- n/f )
  224. <number-parse> [ @first-char-no-radix ] require-next-digit ;
  225. : bin> ( str -- n/f ) 2 base> ; inline
  226. : oct> ( str -- n/f ) 8 base> ; inline
  227. : dec> ( str -- n/f ) 10 base> ; inline
  228. : hex> ( str -- n/f ) 16 base> ; inline
  229. : string>digits ( str -- digits )
  230. [ digit> ] B{ } map-as ; inline
  231. <PRIVATE
  232. : (digits>integer) ( valid? accum digit radix -- valid? accum )
  233. 2dup < [ swapd * + ] [ 4drop f 0 ] if ; inline
  234. : each-digit ( seq radix quot -- n/f )
  235. [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
  236. PRIVATE>
  237. : digits>integer ( seq radix -- n/f )
  238. [ (digits>integer) ] each-digit ; inline
  239. : >digit ( n -- ch )
  240. dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
  241. <PRIVATE
  242. : positive>base ( num radix -- str )
  243. dup 1 <= [ invalid-radix ] when
  244. [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
  245. reverse! ; inline
  246. PRIVATE>
  247. GENERIC# >base 1 ( n radix -- str )
  248. : number>string ( n -- str ) 10 >base ; inline
  249. : >bin ( n -- str ) 2 >base ; inline
  250. : >oct ( n -- str ) 8 >base ; inline
  251. : >hex ( n -- str ) 16 >base ; inline
  252. <PRIVATE
  253. SYMBOL: radix
  254. SYMBOL: negative?
  255. : sign ( -- str ) negative? get "-" "+" ? ;
  256. : with-radix ( radix quot -- )
  257. radix swap with-variable ; inline
  258. : (>base) ( n -- str ) radix get positive>base ;
  259. PRIVATE>
  260. M: integer >base
  261. over 0 = [
  262. 2drop "0"
  263. ] [
  264. over 0 > [
  265. positive>base
  266. ] [
  267. [ neg ] dip positive>base CHAR: - prefix
  268. ] if
  269. ] if ;
  270. M: ratio >base
  271. [
  272. dup 0 < negative? set
  273. abs 1 /mod
  274. [ [ "" ] [ (>base) sign append ] if-zero ]
  275. [
  276. [ numerator (>base) ]
  277. [ denominator (>base) ] bi
  278. "/" glue
  279. ] bi* append
  280. negative? get [ CHAR: - prefix ] when
  281. ] with-radix ;
  282. : fix-float ( str -- newstr )
  283. {
  284. {
  285. [ CHAR: e over member? ]
  286. [ "e" split1 [ fix-float "e" ] dip 3append ]
  287. } {
  288. [ CHAR: . over member? ]
  289. [ ]
  290. }
  291. [ ".0" append ]
  292. } cond ;
  293. <PRIVATE
  294. : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
  295. [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
  296. [ 1023 - ] if-zero ;
  297. : mantissa-expt ( float -- mantissa expt )
  298. [ 52 2^ 1 - bitand ]
  299. [ -0.0 double>bits bitnot bitand -52 shift ] bi
  300. mantissa-expt-normalize ;
  301. : float>hex-sign ( bits -- str )
  302. -0.0 double>bits bitand zero? "" "-" ? ;
  303. : float>hex-value ( mantissa -- str )
  304. >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
  305. [ "0" ] when-empty "1." prepend ;
  306. : float>hex-expt ( mantissa -- str )
  307. 10 >base "p" prepend ;
  308. : float>hex ( n -- str )
  309. double>bits
  310. [ float>hex-sign ] [
  311. mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
  312. ] bi 3append ;
  313. : format-float ( n format -- string )
  314. 0 suffix >byte-array (format-float)
  315. dup [ 0 = ] find drop head >string
  316. fix-float ;
  317. : float>base ( n radix -- str )
  318. {
  319. { 16 [ float>hex ] }
  320. { 10 [ "%.16g" format-float ] }
  321. [ invalid-radix ]
  322. } case ; inline
  323. PRIVATE>
  324. : float>string ( n -- str )
  325. 10 float>base ; inline
  326. M: float >base
  327. {
  328. { [ over fp-nan? ] [ 2drop "0/0." ] }
  329. { [ over 1/0. = ] [ 2drop "1/0." ] }
  330. { [ over -1/0. = ] [ 2drop "-1/0." ] }
  331. { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
  332. { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
  333. [ float>base ]
  334. } cond ;
  335. : # ( n -- ) number>string % ; inline