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

= now handles complex numbers properly.

This commit is contained in:
Abdulaziz Ghuloum 2009-04-07 12:05:03 +03:00
parent ffb5a815f8
commit 72b86818f0
2 changed files with 74 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

247
scheme/ikarus.numerics.ss
View File

@ -2167,136 +2167,67 @@
(let () (let ()
(define err (define err
(lambda (x) (die '= "not a number" x))) (lambda (x) (die '= "not a number" x)))
(define fxloopt (define (fx? x y)
(lambda (x y ls) (cond
(cond [(fixnum? y) ($fx= x y)]
[(fixnum? y) [(flonum? y) (fxfl= x y)]
(if (null? ls) [(or (bignum? y) (ratnum? y) (compnum? y)) #f]
($fx= x y) [(cflonum? y)
(if ($fx= x y) (and (flfl= 0.0 ($cflonum-imag y)) (fxfl= x ($cflonum-real y)))]
(fxloopt y (car ls) (cdr ls)) [else (err y)]))
(loopf (car ls) (cdr ls))))] (define (bn? x y)
[(bignum? y) (loopf (car ls) (cdr ls))] (cond
[(flonum? y) [(bignum? y) (bnbn= x y)]
(if (null? ls) [(flonum? y) (bnfl= x y)]
(fxfl= x y) [(or (fixnum? y) (ratnum? y) (compnum? y)) #f]
(if (fxfl= x y) [(cflonum? y)
(flloopt y (car ls) (cdr ls)) (and (flfl= 0.0 ($cflonum-imag y)) (bnfl= x ($cflonum-real y)))]
(loopf (car ls) (cdr ls))))] [else (err y)]))
[(or (ratnum? y) (compnum? y) (cflonum? y)) (define (fl? x y)
(and (pair? ls) (loopf (car ls) (cdr ls)))] (cond
[else (err y)]))) [(flonum? y) (flfl= x y)]
(define bnloopt [(fixnum? y) (flfx= x y)]
(lambda (x y ls) [(bignum? y) (flbn= x y)]
(cond [(ratnum? y) (flrt= x y)]
[(fixnum? y) (loopf (car ls) (cdr ls))] [(compnum? y) #f]
[(bignum? y) [(cflonum? y)
(if (null? ls) (and (flfl= 0.0 ($cflonum-imag y)) (flfl= x ($cflonum-real y)))]
(bnbn= x y) [else (err y)]))
(if (bnbn= x y) (define (rn? x y)
(bnloopt y (car ls) (cdr ls)) (cond
(loopf (car ls) (cdr ls))))] [(flonum? y) (rtfl= x y)]
[(flonum? y) [(ratnum? y) (rtrt= x y)]
(if (null? ls) [(or (fixnum? y) (bignum? y) (compnum? y)) #f]
(bnfl= x y) [(cflonum? y)
(if (bnfl= x y) (and (flfl= 0.0 ($cflonum-imag y)) (rtfl= x ($cflonum-real y)))]
(flloopt y (car ls) (cdr ls)) [else (err y)]))
(loopf (car ls) (cdr ls))))] (define (cn? x y)
[(or (ratnum? y) (compnum? y) (cflonum? y)) (cond
(and (pair? ls) (loopf (car ls) (cdr ls)))] [(compnum? y) (cncn= x y)]
[else (err y)]))) [(cflonum? y) (cncf= x y)]
(define flloopt [(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
(lambda (x y ls) [else (err y)]))
(cond (define (cf? x y)
[(fixnum? y) (cond
(if (null? ls) [(cflonum? y) (cfcf= x y)]
(flfx= x y) [(compnum? y) (cncf= y x)]
(if (flfx= x y) [(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(fxloopt y (car ls) (cdr ls)) (and (flfl= 0.0 ($cflonum-imag x)) (= ($cflonum-real x) y))]
(loopf (car ls) (cdr ls))))] [else (err y)]))
[(bignum? y) (define-syntax doloop
(if (null? ls) (syntax-rules ()
(flbn= x y) [(_ cmp x0 y0 ls0)
(if (flbn= x y) (let loop ([x x0] [y y0] [ls ls0])
(bnloopt y (car ls) (cdr ls)) (if (cmp x y)
(loopf (car ls) (cdr ls))))] (if (null? ls) #t (loop x (car ls) (cdr ls)))
[(flonum? y) (if (null? ls) #f (loopf (car ls) (cdr ls)))))]))
(if (null? ls)
(flfl= x y)
(if (flfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(flrt= x y)
(if (flrt= x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define rtloopt
(lambda (x y ls)
(cond
[(flonum? y)
(if (null? ls)
(rtfl= x y)
(if (rtfl= x y)
(flloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(ratnum? y)
(if (null? ls)
(rtrt= x y)
(if (rtrt= x y)
(rtloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define cnloopt
(lambda (x y ls)
(cond
[(compnum? y)
(if (null? ls)
(cncn= x y)
(if (cncn= x y)
(cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(cflonum? y)
(if (null? ls)
(cncf= x y)
(if (cncf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define cfloopt
(lambda (x y ls)
(cond
[(cflonum? y)
(if (null? ls)
(cfcf= x y)
(if (cfcf= x y)
(cfloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(compnum? y)
(if (null? ls)
(cncf= y x)
(if (cncf= y x)
(cnloopt y (car ls) (cdr ls))
(loopf (car ls) (cdr ls))))]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y))
(and (pair? ls) (loopf (car ls) (cdr ls)))]
[else (err y)])))
(define loopf (define loopf
(lambda (x ls) (lambda (x ls)
(cond (if (number? x)
[(number? x) (if (null? ls)
(if (null? ls) #f
#f (loopf (car ls) (cdr ls)))
(loopf (car ls) (cdr ls)))] (err x))))
[else (err x)])))
(define (cncn= x y) (define (cncn= x y)
(and (and
(= ($compnum-real x) ($compnum-real y)) (= ($compnum-real x) ($compnum-real y))
@ -2313,55 +2244,23 @@
(case-lambda (case-lambda
[(x y) [(x y)
(cond (cond
[(fixnum? x) [(fixnum? x) (fx? x y)]
(cond [(bignum? x) (bn? x y)]
[(fixnum? y) ($fx= x y)] [(flonum? x) (fl? x y)]
[(flonum? y) (fxfl= x y)] [(ratnum? x) (rn? x y)]
[(or (bignum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f] [(compnum? x) (cn? x y)]
[else (err y)])] [(cflonum? x) (cf? x y)]
[(bignum? x)
(cond
[(bignum? y) (bnbn= x y)]
[(flonum? y) (bnfl= x y)]
[(or (fixnum? y) (ratnum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(flonum? x)
(cond
[(fixnum? y) (flfx= x y)]
[(bignum? y) (flbn= x y)]
[(flonum? y) (flfl= x y)]
[(ratnum? y) (flrt= x y)]
[(or (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(ratnum? x)
(cond
[(flonum? y) (rtfl= x y)]
[(ratnum? y) (rtrt= x y)]
[(or (fixnum? y) (bignum? y) (compnum? y) (cflonum? y)) #f]
[else (err y)])]
[(compnum? x)
(cond
[(compnum? y) (cncn= x y)]
[(cflonum? y) (cncf= x y)]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[else (err y)])]
[(cflonum? x)
(cond
[(cflonum? y) (cfcf= x y)]
[(compnum? y) (cncf= y x)]
[(or (fixnum? y) (bignum? y) (flonum? y) (ratnum? y)) #f]
[else (err y)])]
[else (err x)])] [else (err x)])]
[(x y z) (and (= x y) (= y z))] [(x y z) (if (= x y) (= y z) (if (number? z) #f (err z)))]
[(x) (if (number? x) #t (err x))] [(x) (if (number? x) #t (err x))]
[(x y . ls) [(x y . ls)
(cond (cond
[(fixnum? x) (fxloopt x y ls)] [(fixnum? x) (doloop fx? x y ls)]
[(bignum? x) (bnloopt x y ls)] [(bignum? x) (doloop bn? x y ls)]
[(flonum? x) (flloopt x y ls)] [(flonum? x) (doloop fl? x y ls)]
[(ratnum? x) (rtloopt x y ls)] [(ratnum? x) (doloop rn? x y ls)]
[(compnum? x) (cnloopt x y ls)] [(compnum? x) (doloop cn? x y ls)]
[(cflonum? x) (cfloopt x y ls)] [(cflonum? x) (doloop cf? x y ls)]
[else (err x)])])) [else (err x)])]))
=)) =))

2
scheme/last-revision
View File

@ -1 +1 @@
1760 1761