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

fixed make-rectangular so that (make-rectangular 1.0 0.0) returns 

a cflonum 1.0+0.0i while (make-rectangular 1.0 0) returns 1.0.
This commit is contained in:
Abdulaziz Ghuloum 2008-07-25 17:46:34 -07:00
parent f332927d23
commit 4909a9ef08
3 changed files with 55 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
scheme/ikarus.numerics.ss
View File

@ -560,14 +560,14 @@
(binary+ y ($compnum-real x)) (binary+ y ($compnum-real x))
(inexact ($compnum-imag x)))] (inexact ($compnum-imag x)))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary+ ($compnum-real x) ($cflonum-real y)) (binary+ ($compnum-real x) ($cflonum-real y))
(binary+ ($compnum-imag x) ($cflonum-imag y)))] (binary+ ($compnum-imag x) ($cflonum-imag y)))]
[else (err '+ y)])] [else (err '+ y)])]
[(cflonum? x) [(cflonum? x)
(cond (cond
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary+ ($cflonum-real x) ($cflonum-real y)) (binary+ ($cflonum-real x) ($cflonum-real y))
(binary+ ($cflonum-imag x) ($cflonum-imag y)))] (binary+ ($cflonum-imag x) ($cflonum-imag y)))]
[(flonum? y) [(flonum? y)
@ -579,7 +579,7 @@
(binary+ ($compnum-real x) y) (binary+ ($compnum-real x) y)
($compnum-imag x))] ($compnum-imag x))]
[(compnum? y) [(compnum? y)
($make-rectangular ($make-cflonum
(binary+ ($cflonum-real x) ($compnum-real y)) (binary+ ($cflonum-real x) ($compnum-real y))
(binary+ ($cflonum-imag x) ($compnum-imag y)))] (binary+ ($cflonum-imag x) ($compnum-imag y)))]
[else (err '+ y)])] [else (err '+ y)])]
@ -758,7 +758,7 @@
(binary- ($compnum-real x) ($compnum-real y)) (binary- ($compnum-real x) ($compnum-real y))
(binary- ($compnum-imag x) ($compnum-imag y)))] (binary- ($compnum-imag x) ($compnum-imag y)))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary- ($compnum-real x) ($cflonum-real y)) (binary- ($compnum-real x) ($cflonum-real y))
(binary- ($compnum-imag x) ($cflonum-imag y)))] (binary- ($compnum-imag x) ($cflonum-imag y)))]
[else [else
@ -770,7 +770,7 @@
($fl- ($cflonum-real x) y) ($fl- ($cflonum-real x) y)
($cflonum-imag x))] ($cflonum-imag x))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary- ($cflonum-real x) ($cflonum-real y)) (binary- ($cflonum-real x) ($cflonum-real y))
(binary- ($cflonum-imag x) ($cflonum-imag y)))] (binary- ($cflonum-imag x) ($cflonum-imag y)))]
[(or (fixnum? y) (bignum? y) (ratnum? y)) [(or (fixnum? y) (bignum? y) (ratnum? y))
@ -778,7 +778,7 @@
(binary- ($cflonum-real x) y) (binary- ($cflonum-real x) y)
($cflonum-imag x))] ($cflonum-imag x))]
[(compnum? y) [(compnum? y)
($make-rectangular ($make-cflonum
(binary- ($cflonum-real x) ($compnum-real y)) (binary- ($cflonum-real x) ($compnum-real y))
(binary- ($cflonum-imag x) ($compnum-imag y)))] (binary- ($cflonum-imag x) ($compnum-imag y)))]
[else [else
@ -803,7 +803,7 @@
(binary* x ($compnum-real y)) (binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))] (binary* x ($compnum-imag y)))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary* x ($cflonum-real y)) (binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))] (binary* x ($cflonum-imag y)))]
[else (err '* y)])] [else (err '* y)])]
@ -822,7 +822,7 @@
(binary* x ($compnum-real y)) (binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))] (binary* x ($compnum-imag y)))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary* x ($cflonum-real y)) (binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))] (binary* x ($cflonum-imag y)))]
[else (err '* y)])] [else (err '* y)])]
@ -831,7 +831,7 @@
[(flonum? y) [(flonum? y)
($fl* x y)] ($fl* x y)]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
($fl* x ($cflonum-real y)) ($fl* x ($cflonum-real y))
($fl* x ($cflonum-imag y)))] ($fl* x ($cflonum-imag y)))]
[(fixnum? y) [(fixnum? y)
@ -841,7 +841,7 @@
[(ratnum? y) [(ratnum? y)
(binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))] (binary/ (binary* x ($ratnum-n y)) ($ratnum-d y))]
[(compnum? y) [(compnum? y)
($make-rectangular ($make-cflonum
(binary* x ($compnum-real y)) (binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))] (binary* x ($compnum-imag y)))]
[else (err '* y)])] [else (err '* y)])]
@ -855,22 +855,26 @@
(binary* x ($compnum-real y)) (binary* x ($compnum-real y))
(binary* x ($compnum-imag y)))] (binary* x ($compnum-imag y)))]
[(cflonum? y) [(cflonum? y)
($make-rectangular ($make-cflonum
(binary* x ($cflonum-real y)) (binary* x ($cflonum-real y))
(binary* x ($cflonum-imag y)))] (binary* x ($cflonum-imag y)))]
[else (binary* y x)])] [else (binary* y x)])]
[(compnum? x) [(compnum? x)
(cond (cond
[(or (fixnum? y) (bignum? y) (ratnum? y) (flonum? y)) [(or (fixnum? y) (bignum? y) (ratnum? y))
($make-rectangular ($make-rectangular
(binary* ($compnum-real x) y) (binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))] (binary* ($compnum-imag x) y))]
[(flonum? y)
($make-cflonum
(binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))]
[(compnum? y) [(compnum? y)
(let ([r0 ($compnum-real x)] (let ([r0 ($compnum-real x)]
[r1 ($compnum-real y)] [r1 ($compnum-real y)]
[i0 ($compnum-imag x)] [i0 ($compnum-imag x)]
[i1 ($compnum-imag y)]) [i1 ($compnum-imag y)])
($make-rectangular (make-rectangular
(- (* r0 r1) (* i0 i1)) (- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))] (+ (* r0 i1) (* i0 r1))))]
[(cflonum? y) [(cflonum? y)
@ -878,14 +882,14 @@
[r1 ($cflonum-real y)] [r1 ($cflonum-real y)]
[i0 ($compnum-imag x)] [i0 ($compnum-imag x)]
[i1 ($cflonum-imag y)]) [i1 ($cflonum-imag y)])
($make-rectangular (make-rectangular
(- (* r0 r1) (* i0 i1)) (- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))] (+ (* r0 i1) (* i0 r1))))]
[else (err '* y)])] [else (err '* y)])]
[(cflonum? x) [(cflonum? x)
(cond (cond
[(flonum? y) [(flonum? y)
($make-rectangular ($make-cflonum
($fl* ($cflonum-real x) y) ($fl* ($cflonum-real x) y)
($fl* ($cflonum-imag x) y))] ($fl* ($cflonum-imag x) y))]
[(cflonum? y) [(cflonum? y)
@ -893,11 +897,11 @@
[r1 ($cflonum-real y)] [r1 ($cflonum-real y)]
[i0 ($cflonum-imag x)] [i0 ($cflonum-imag x)]
[i1 ($cflonum-imag y)]) [i1 ($cflonum-imag y)])
($make-rectangular ($make-cflonum
($fl- ($fl* r0 r1) ($fl* i0 i1)) ($fl- ($fl* r0 r1) ($fl* i0 i1))
($fl+ ($fl* r0 i1) ($fl* i0 r1))))] ($fl+ ($fl* r0 i1) ($fl* i0 r1))))]
[(or (fixnum? y) (bignum? y) (ratnum? y)) [(or (fixnum? y) (bignum? y) (ratnum? y))
($make-rectangular ($make-cflonum
(binary* ($compnum-real x) y) (binary* ($compnum-real x) y)
(binary* ($compnum-imag x) y))] (binary* ($compnum-imag x) y))]
[(compnum? y) [(compnum? y)
@ -905,7 +909,7 @@
[r1 ($compnum-real y)] [r1 ($compnum-real y)]
[i0 ($compnum-imag x)] [i0 ($compnum-imag x)]
[i1 ($compnum-imag y)]) [i1 ($compnum-imag y)])
($make-rectangular (make-rectangular
(- (* r0 r1) (* i0 i1)) (- (* r0 r1) (* i0 i1))
(+ (* r0 i1) (* i0 r1))))] (+ (* r0 i1) (* i0 r1))))]
[else (err '* y)])] [else (err '* y)])]
@ -1115,13 +1119,13 @@
(let ([yr (real-part y)] (let ([yr (real-part y)]
[yi (imag-part y)]) [yi (imag-part y)])
(let ([denom (+ (* yr yr) (* yi yi))]) (let ([denom (+ (* yr yr) (* yi yi))])
($make-rectangular (make-rectangular
(binary/ (* x yr) denom) (binary/ (* x yr) denom)
(binary/ (* (- x) yi) denom))))) (binary/ (* (- x) yi) denom)))))
(define (compx/y x y) (define (compx/y x y)
(let ([xr (real-part x)] (let ([xr (real-part x)]
[xi (imag-part x)]) [xi (imag-part x)])
($make-rectangular (make-rectangular
(binary/ xr y) (binary/ xr y)
(binary/ xi y)))) (binary/ xi y))))
(define (compx/compy x y) (define (compx/compy x y)
@ -1130,7 +1134,7 @@
[yr (real-part y)] [yr (real-part y)]
[yi (imag-part y)]) [yi (imag-part y)])
(let ([denom (+ (* yr yr) (* yi yi))]) (let ([denom (+ (* yr yr) (* yi yi))])
($make-rectangular (make-rectangular
(binary/ (+ (* xr yr) (* xi yi)) denom) (binary/ (+ (* xr yr) (* xi yi)) denom)
(binary/ (- (* xi yr) (* xr yi)) denom))))) (binary/ (- (* xi yr) (* xr yi)) denom)))))
(cond (cond
@ -3672,12 +3676,10 @@
(except (ikarus system $compnums) $make-rectangular)) (except (ikarus system $compnums) $make-rectangular))
(define ($make-rectangular r i) (define ($make-rectangular r i)
;;; should be called with 2 exacts or two inexacts ;;; should be called with 2 exacts
(if (flonum? i) (if (eqv? i 0)
(if (and (fl=? i 0.0) (fl=? (atan 0.0 i) 0.0)) r
r ($make-compnum r i)))
($make-cflonum r i))
(if (eqv? i 0) r ($make-compnum r i))))
(define (make-rectangular r i) (define (make-rectangular r i)
(define who 'make-rectangular) (define who 'make-rectangular)
@ -3686,16 +3688,17 @@
(cond (cond
[(flonum? i) [(flonum? i)
(cond (cond
[(flonum? r) ($make-rectangular r i)] [(flonum? r) ($make-cflonum r i)]
[(or (fixnum? r) (bignum? r) (ratnum? r)) [(or (fixnum? r) (bignum? r) (ratnum? r))
($make-rectangular (inexact r) i)] ($make-cflonum (inexact r) i)]
[else (err r)])] [else (err r)])]
[(eqv? i 0) (if (number? r) r (err r))]
[(or (fixnum? i) (bignum? i) (ratnum? i)) [(or (fixnum? i) (bignum? i) (ratnum? i))
(cond (cond
[(or (fixnum? r) (bignum? r) (ratnum? r)) [(or (fixnum? r) (bignum? r) (ratnum? r))
($make-rectangular r i)] ($make-rectangular r i)]
[(flonum? r) [(flonum? r)
($make-rectangular r (inexact i))] ($make-cflonum r (inexact i))]
[else (err r)])] [else (err r)])]
[else (err i)])) [else (err i)]))
@ -3772,7 +3775,7 @@
[(fixnum? x) 0] [(fixnum? x) 0]
[(bignum? x) 0] [(bignum? x) 0]
[(ratnum? x) 0] [(ratnum? x) 0]
[(flonum? x) 0.0] [(flonum? x) 0]
[(compnum? x) ($compnum-imag x)] [(compnum? x) ($compnum-imag x)]
[(cflonum? x) ($cflonum-imag x)] [(cflonum? x) ($cflonum-imag x)]
[else [else

23
scheme/ikarus.predicates.ss
View File

@ -105,7 +105,11 @@
(sys:ratnum? x)))) (sys:ratnum? x))))
(define real-valued? (define real-valued?
(lambda (x) (real? x))) (lambda (x)
(cond
[(real? x) #t]
[(cflonum? x) (fl=? ($cflonum-imag x) 0.0)]
[else #f])))
(define rational? (define rational?
(lambda (x) (lambda (x)
@ -117,7 +121,13 @@
[else #f]))) [else #f])))
(define rational-valued? (define rational-valued?
(lambda (x) (rational? x))) (lambda (x)
(cond
[(rational? x) #t]
[(cflonum? x)
(and (fl=? ($cflonum-imag x) 0.0)
($flonum-rational? ($cflonum-real x)))]
[else #f])))
(define integer? (define integer?
(lambda (x) (lambda (x)
@ -129,7 +139,14 @@
[else #f]))) [else #f])))
(define integer-valued? (define integer-valued?
(lambda (x) (integer? x))) (lambda (x)
(cond
[(integer? x) #t]
[(cflonum? x)
(and (fl=? ($cflonum-imag x) 0.0)
($flonum-integer? ($cflonum-real x)))]
[else #f])))
(define exact? (define exact?
(lambda (x) (lambda (x)

2
scheme/last-revision
View File

@ -1 +1 @@
1552 1553