conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixed reading of polar notation

This commit is contained in:
Abdulaziz Ghuloum 2009-08-02 12:23:07 +03:00
parent b2bca8a00a
commit 3e71a5aa5e
3 changed files with 75 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

177
scheme/ikarus.string-to-number.ss
View File

@ -24,6 +24,11 @@
(* sn (if (eq? ex 'i) (inexact ac) ac))) (* sn (if (eq? ex 'i) (inexact ac) ac)))
(define (do-dec-sn/ex sn ex ac) (define (do-dec-sn/ex sn ex ac)
(* sn (if (eq? ex 'e) ac (inexact ac)))) (* sn (if (eq? ex 'e) ac (inexact ac))))
(define (sign c)
(case c
[(#\+) +1]
[(#\-) -1]
[else #f]))
(define (digit c r) (define (digit c r)
(let ([n (fx- (char->integer c) (char->integer #\0))]) (let ([n (fx- (char->integer c) (char->integer #\0))])
(cond (cond
@ -120,8 +125,19 @@
orig* orig*
[name* (arg** ...) clause** ...] ...)])))])))) [name* (arg** ...) clause** ...] ...)])))]))))
(define (mkrec n0 n1) (define (mkrec0 n0 n1)
(if n0 (make-rectangular n0 n1) (make-rectangular 0 n1))) (cond
[(not n0) (make-rectangular 0 n1)]
[(and (pair? n0) (eq? (car n0) 'polar))
(make-polar (cdr n0) n1)]
[else (make-rectangular n0 n1)]))
(define (mkrec1 n0 n1)
(cond
[(not n0) n1]
[(and (pair? n0) (eq? (car n0) 'polar))
(make-polar (cdr n0) n1)]
[else (make-rectangular n0 n1)]))
(define-parser define-string->number-parser next fail (define-parser define-string->number-parser next fail
@ -132,25 +148,20 @@
(do-sn/ex sn ex (/ num ac)))] (do-sn/ex sn ex (/ num ac)))]
[(digit r) => d [(digit r) => d
(next u:ratio+ r n0 ex sn num (+ (* ac r) d))] (next u:ratio+ r n0 ex sn num (+ (* ac r) d))]
[(#\+) [(sign) => sn2
(if (or n0 (= ac 0)) (if (or n0 (= ac 0))
(fail) (fail)
(let ([real (do-sn/ex sn ex (/ num ac))]) (let ([real (do-sn/ex sn ex (/ num ac))])
(next u:sign r real ex +1)))] (next u:sign r real ex sn2)))]
[(#\-)
(if (or n0 (= ac 0))
(fail)
(let ([real (do-sn/ex sn ex (/ num ac))])
(next u:sign r real ex -1)))]
[(#\@) [(#\@)
(if (or n0 (= ac 0)) (if (or n0 (= ac 0))
(fail) (fail)
(let ([mag (do-sn/ex sn ex (/ num ac))]) (let ([mag (do-sn/ex sn ex (/ num ac))])
(next polar r mag ex)))] (next u:polar r mag ex)))]
[(#\i) [(#\i)
(if (= ac 0) (if (= ac 0)
(fail) (fail)
(next u:done (mkrec n0 (do-sn/ex sn ex (/ num ac)))))]) (next u:done (mkrec0 n0 (do-sn/ex sn ex (/ num ac)))))])
(u:ratio (r n0 ex sn num) (u:ratio (r n0 ex sn num)
[(digit r) => d [(digit r) => d
@ -159,88 +170,38 @@
(u:done (n) (u:done (n)
[(eof) n]) [(eof) n])
(polar (r mag ex) (u:polar (r mag ex)
[(digit r) => d [(digit r) => d
(next polar+digit r mag ex d 1)] (next u:digit+ r (cons 'polar mag) ex +1 d)]
[(#\.) [(#\.)
(if (= r 10) (if (= r 10)
(next polar+dot r mag ex +1) (next u:dot r (cons 'polar mag) ex +1)
(fail))] (fail))]
[(#\+) [(sign) => sn
(next polar+sign r mag ex +1)] (next u:sign r (cons 'polar mag) ex sn)])
[(#\-)
(next polar+sign r mag ex -1)])
(polar+sign (r mag ex sn)
[(digit r) => d
(next polar+digit r mag ex d sn)]
[(#\.)
(if (= r 10)
(next polar+dot r mag ex sn)
(fail))]
[(#\n)
(next pol:sign-n (make-polar mag +nan.0))]
[(#\i)
(next pol:sign-i (make-polar mag (* +inf.0 sn)))])
(pol:sign-n (n) [(#\a) (next pol:sign-na n)])
(pol:sign-na (n) [(#\n) (next pol:sign-nan n)])
(pol:sign-nan (n) [(#\.) (next pol:sign-nan. n)])
(pol:sign-nan. (n) [(#\0) (next u:done n)])
(pol:sign-i (n) [(#\n) (next pol:sign-in n)])
(pol:sign-in (n) [(#\f) (next pol:sign-inf n)])
(pol:sign-inf (n) [(#\.) (next pol:sign-inf. n)])
(pol:sign-inf. (n) [(#\0) (next u:done n)])
(polar+dot (r mag ex sn)
[(digit r) => d
(next polar+digit+dot r mag ex d sn -1)])
(polar+digit (r mag ex ang sn)
[(eof) (make-polar mag (* ang sn))]
[(digit r) => d
(next polar+digit r mag ex (+ (* r ang) d) sn)]
[(#\.)
(if (= r 10)
(next polar+digit+dot r mag ex ang sn 0)
(fail))])
(polar+digit+dot (r mag ex ang sn exp)
[(eof)
(let ([ang (* ang sn (expt 10 exp))])
(make-polar mag ang))]
[(digit r) => d
(next polar+digit+dot r mag ex (+ (* r ang) d) sn (- exp 1))])
(u:exponent+digit (r n0 ex sn ac exp1 exp2 exp-sign) (u:exponent+digit (r n0 ex sn ac exp1 exp2 exp-sign)
[(eof) [(eof)
(if n0 (if (number? n0)
(fail) (fail)
(do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign))))))] (mkrec1 n0 (do-dec-sn/ex sn ex
(* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))))]
[(digit r) => d [(digit r) => d
(next u:exponent+digit r n0 ex sn ac exp1 (+ (* exp2 r) d) exp-sign)] (next u:exponent+digit r n0 ex sn ac exp1 (+ (* exp2 r) d) exp-sign)]
[(#\+) [(sign) => sn2
(if n0 (if n0
(fail) (fail)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
(next u:sign r real ex +1)))] (next u:sign r real ex sn2)))]
[(#\-)
(if n0
(fail)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
(next u:sign r real ex -1)))]
[(#\@) [(#\@)
(if n0 (if n0
(fail) (fail)
(let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
(next polar r mag ex)))] (next u:polar r mag ex)))]
[(#\i) [(#\i)
(let ([n1 (do-dec-sn/ex sn ex (let ([n1 (do-dec-sn/ex sn ex
(* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))]) (* ac (expt 10 (+ exp1 (* exp2 exp-sign)))))])
(next u:done (mkrec n0 n1)))]) (next u:done (mkrec0 n0 n1)))])
(u:exponent+sign (r n0 ex sn ac exp1 exp-sign) (u:exponent+sign (r n0 ex sn ac exp1 exp-sign)
[(digit r) => d [(digit r) => d
@ -249,32 +210,26 @@
(u:exponent (r n0 ex sn ac exp1) (u:exponent (r n0 ex sn ac exp1)
[(digit r) => d [(digit r) => d
(next u:exponent+digit r n0 ex sn ac exp1 d +1)] (next u:exponent+digit r n0 ex sn ac exp1 d +1)]
[(#\+) (next u:exponent+sign r n0 ex sn ac exp1 +1)] [(sign) => sn2 (next u:exponent+sign r n0 ex sn ac exp1 sn2)])
[(#\-) (next u:exponent+sign r n0 ex sn ac exp1 -1)])
(u:digit+dot (r n0 ex sn ac exp) (u:digit+dot (r n0 ex sn ac exp)
[(eof) [(eof)
(do-dec-sn/ex sn ex (* ac (expt 10 exp)))] (mkrec1 n0 (do-dec-sn/ex sn ex (* ac (expt 10 exp))))]
[(digit r) => d [(digit r) => d
(next u:digit+dot r n0 ex sn (+ (* ac r) d) (- exp 1))] (next u:digit+dot r n0 ex sn (+ (* ac r) d) (- exp 1))]
[(#\i) [(#\i)
(let ([n1 (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (let ([n1 (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next u:done (mkrec n0 n1)))] (next u:done (mkrec0 n0 n1)))]
[(#\+) [(sign) => sn2
(if n0 (if n0
(fail) (fail)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next u:sign r real ex +1)))] (next u:sign r real ex sn2)))]
[(#\-)
(if n0
(fail)
(let ([real (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next u:sign r real ex -1)))]
[(#\@) [(#\@)
(if n0 (if n0
(fail) (fail)
(let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 exp)))]) (let ([mag (do-dec-sn/ex sn ex (* ac (expt 10 exp)))])
(next polar r mag ex)))] (next u:polar r mag ex)))]
[(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L)
(if (fx=? r 10) (if (fx=? r 10)
(next u:exponent r n0 ex sn ac exp) (next u:exponent r n0 ex sn ac exp)
@ -283,10 +238,7 @@
(u:digit+ (r n0 ex sn ac) (u:digit+ (r n0 ex sn ac)
[(eof) [(eof)
(let ([n1 (do-sn/ex sn ex ac)]) (mkrec1 n0 (do-sn/ex sn ex ac))]
(if n0
(make-rectangular n0 n1)
n1))]
[(digit r) => d [(digit r) => d
(next u:digit+ r n0 ex sn (+ (* ac r) d))] (next u:digit+ r n0 ex sn (+ (* ac r) d))]
[(#\.) [(#\.)
@ -294,35 +246,26 @@
(next u:digit+dot r n0 ex sn ac 0) (next u:digit+dot r n0 ex sn ac 0)
(fail))] (fail))]
[(#\/) (next u:ratio r n0 ex sn ac)] [(#\/) (next u:ratio r n0 ex sn ac)]
[(#\+) [(sign) => sn2
(if n0 (if n0
(fail) (fail)
(let ([real (do-sn/ex sn ex ac)]) (let ([real (do-sn/ex sn ex ac)])
(next u:sign r real ex +1)))] (next u:sign r real ex sn2)))]
[(#\-)
(if n0
(fail)
(let ([real (do-sn/ex sn ex ac)])
(next u:sign r real ex -1)))]
[(#\i) [(#\i)
(next u:done (mkrec n0 (do-sn/ex sn ex ac)))] (next u:done (mkrec0 n0 (do-sn/ex sn ex ac)))]
[(#\@) [(#\@)
(if n0 (if n0
(fail) (fail)
(let ([mag (do-sn/ex sn ex ac)]) (let ([mag (do-sn/ex sn ex ac)])
(next polar r mag ex)))] (next u:polar r mag ex)))]
[(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L) [(#\e #\E #\s #\S #\f #\F #\d #\D #\l #\L)
(if (fx=? r 10) (if (fx=? r 10)
(next u:exponent r n0 ex sn ac 0) (next u:exponent r n0 ex sn ac 0)
(fail))]) (fail))])
(u:sign-i (r n0 ex sn) (u:sign-i (r n0 ex sn)
[(eof) (mkrec n0 (do-sn/ex sn ex 1))] [(eof) (mkrec0 n0 (do-sn/ex sn ex 1))]
[(#\n) [(#\n) (next u:sign-in r n0 (* sn +inf.0) ex)])
(if n0
(next u:sign-in r n0 (* sn +inf.0) ex)
(next u:sign-in r (* sn +inf.0) #f ex))])
(u:sign-in (r n0 n1 ex) (u:sign-in (r n0 n1 ex)
[(#\f) (next u:sign-inf r n0 n1 ex)]) [(#\f) (next u:sign-inf r n0 n1 ex)])
(u:sign-inf (r n0 n1 ex) (u:sign-inf (r n0 n1 ex)
@ -330,15 +273,11 @@
(u:sign-inf. (r n0 n1 ex) (u:sign-inf. (r n0 n1 ex)
[(#\0) (next u:sign-inf.0 r n0 n1 ex)]) [(#\0) (next u:sign-inf.0 r n0 n1 ex)])
(u:sign-inf.0 (r n0 n1 ex) (u:sign-inf.0 (r n0 n1 ex)
[(eof) (if n1 (make-rectangular n0 n1) n0)] [(eof) (mkrec1 n0 n1)]
[(#\+) (if n1 (fail) (next u:sign r n0 ex +1))] [(sign) => sn2
[(#\-) (if n1 (fail) (next u:sign r n0 ex -1))] (if n0 (fail) (next u:sign r n1 ex sn2))]
[(#\@) (if n1 (fail) (next polar r n0 ex))] [(#\@) (if n0 (fail) (next u:polar r n1 ex))]
[(#\i) [(#\i) (next u:done (mkrec0 n0 n1))])
(next u:done
(if n1
(make-rectangular n0 n1)
(make-rectangular 0.0 n0)))])
(u:dot (r n0 ex sn) (u:dot (r n0 ex sn)
[(digit r) => d [(digit r) => d
@ -359,11 +298,10 @@
(u:sign-nan (r n0 ex) [(#\.) (next u:sign-nan. r n0 ex)]) (u:sign-nan (r n0 ex) [(#\.) (next u:sign-nan. r n0 ex)])
(u:sign-nan. (r n0 ex) [(#\0) (next u:sign-nan.0 r n0 ex)]) (u:sign-nan. (r n0 ex) [(#\0) (next u:sign-nan.0 r n0 ex)])
(u:sign-nan.0 (r n0 ex) (u:sign-nan.0 (r n0 ex)
[(eof) (if n0 (make-rectangular n0 +nan.0) +nan.0)] [(eof) (mkrec1 n0 +nan.0)]
[(#\+) (if n0 (fail) (next u:sign r +nan.0 ex +1))] [(sign) => sn2 (if n0 (fail) (next u:sign r +nan.0 ex sn2))]
[(#\-) (if n0 (fail) (next u:sign r +nan.0 ex -1))] [(#\@) (if n0 (fail) (next u:polar r +nan.0 ex))]
[(#\@) (if n0 (fail) (next polar r +nan.0 ex))] [(#\i) (next u:done (mkrec0 n0 +nan.0))])
[(#\i) (next u:done (mkrec n0 +nan.0))])
(parse-string-h (dr r ex) (parse-string-h (dr r ex)
[(#\x #\X) [(#\x #\X)
@ -381,8 +319,7 @@
(parse-string (dr r ex) (parse-string (dr r ex)
[(#\#) (next parse-string-h dr r ex)] [(#\#) (next parse-string-h dr r ex)]
[(#\+) (next u:sign dr #f ex +1)] [(sign) => sn2 (next u:sign dr #f ex sn2)]
[(#\-) (next u:sign dr #f ex -1)]
[(#\.) [(#\.)
(if (fx=? dr 10) (if (fx=? dr 10)
(next u:dot dr #f ex +1) (next u:dot dr #f ex +1)

2
scheme/last-revision
View File

@ -1 +1 @@
1835 1836

26
scheme/tests/string-to-number.ss
View File

@ -271,17 +271,25 @@
["1.0" . 1.0] ["1.0" . 1.0]
[".5" . 0.5] [".5" . 0.5]
["0.5" . 0.5] ["0.5" . 0.5]
["1e1" . 10.0] ;["1e1" . 10.0]
["1e+1" . 10.0] ["1e0" . 1.0]
;["1e+1" . 10.0]
["1e+0" . 1.0]
["1e-1" . 0.1] ["1e-1" . 0.1]
["1.e1" . 10.0] ;["1.e1" . 10.0]
["1.e+1" . 10.0] ["1.e0" . 1.0]
;["1.e+1" . 10.0]
["1.e+0" . 1.0]
["1.e-1" . 0.1] ["1.e-1" . 0.1]
["1.0e1" . 10.0] ;["1.0e1" . 10.0]
["1.0e+1" . 10.0] ["1.0e0" . 1.0]
;["1.0e+1" . 10.0]
["1.0e+0" . 1.0]
["1.0e-1" . 0.1] ["1.0e-1" . 0.1]
[".5e1" . 5.0] ;[".5e1" . 5.0]
[".5e+1" . 5.0] [".5e0" . 0.5]
;[".5e+1" . 5.0]
[".5e+0" . 0.5]
[".5e-1" . 0.05] [".5e-1" . 0.05]
)) ))
@ -322,7 +330,7 @@
(append (append
real creal real creal
(gensa real creal +) (gensa real creal +)
;(gen real real (lambda (x y) (string-append x "@" y)) make-polar) (gen real real (lambda (x y) (string-append x "@" y)) make-polar)
)) ))
(printf "TESTING ~s tests\n" (length complex)) (printf "TESTING ~s tests\n" (length complex))