SICP Combine operands of different types

之前那一节我们已经实现了不同类型的数据内部的独立运算,接下来我们将实现不同类型的交错运算,

我们主要采取将整数化成分数化成复数的思路来进行计算

之后我们对结果进行化简,即复数到分数到整数的过程

同昨天的代码基本类似,修改了operate部分,将原先的error语句改成了判断哪个级别更高，然后采取对级别低的operand进行raise操作

最后我们在对结果进行drop操作

;;put and get
(define (make-table) 
	(let ((local-table (list '*table*)))
	(define (lookup key-1 key-2)
		(let	((subtable (assoc key-1 (cdr local-table))))
			(if 	subtable
				(let	((record (assoc key-2 (cdr subtable))))
					(if record
						(cdr record)
						false))
				false)))
	(define (insert! key-1 key-2 value)
		(let	((subtable (assoc key-1 (cdr local-table))))
			(if subtable
				(let	((record (assoc key-2 (cdr subtable))))
					(if record
						(set-cdr! record value)
						(set-cdr! subtable
							  (cons (cons key-2 value) (cdr subtable)))))
						(set-cdr! local-table
							  (cons (list key-1 (cons key-2 value)) (cdr local-table)))))
		'OK)
	(define (dispatch m)
		(cond ((eq? m 'lookup-proc) lookup)
			((eq? m 'insert-proc) insert!)
			(else (error "Unknown operation -- TABLE" m))))
	dispatch))
(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc))

;;number
(define (num+ x y) (make-number (+ x y)))
(define (num- x y) (make-number (- x y)))
(define (num* x y) (make-number (* x y)))
(define (num/ x y) (make-number (/ x y)))
(define (make-number n) n)

;;rational
(define (denominator z) (cdr z))
(define (numerator z) (car z))
(define (rat+ x y)
	(make-rat 
		(+ (* (numerator x) (denominator y)) (* (numerator y) (denominator x)))
		(* (denominator x) (denominator y))))
(define (rat- x y)
	(make-rat
		(- (* (numerator x) (denominator y)) (* (numerator y) (denominator x)))
		(* (denominator x) (denominator y))))
(define (rat* x y)
	(make-rat
		(* (numerator x) (numerator y)) (* (denominator x) (denominator y))))
(define (rat/ x y)
	(make-rat
		(* (numerator x) (denominator y)) (* (numerator y) (denominator x))))
(define (make-rat x y)
	(define (reminder x y) (if (< x y) x (reminder (- x y) y)))
	(define (gcd x y)
		(let 	((small (if (< x y) x y))
			(big (if (< x y) y x)))
			(define (iter x y) 
				(if 
					(= 0 (reminder x y))
					y
					(iter x (- y 1))))
			(iter big small)))
	(let ((tmp (gcd x y)))
		(cons 'rational (cons (/ x tmp) (/ y tmp)))))




(put 'number 'add num+)
(put 'number 'sub num-)
(put 'number 'mul num*)
(put 'number 'div num/)
(put 'rational 'add rat+)
(put 'rational 'sub rat-)
(put 'rational 'mul rat*)
(put 'rational 'div rat/)

(define (type z) (if (number? z) 'number (car z)))
(define (content z) (if (number? z) z (cdr z)))
(define (add x y)
	(operate 'add x y))
(define (sub x y)
	(operate 'sub x y))
(define (mul x y)
	(operate 'mul x y))
(define (div x y)
	(operate 'div x y))

(define (operate op obj1 obj2)
	(let	((t1 (type obj1))
		(t2 (type obj2)))
		
		(if 	(eq? t1 t2)
			(let	((proc (get t1 op)))
				(if 	(null? proc)	(error	"operator not defined"(list op obj1 obj2))
					(drop (proc (content obj1) (content obj2)))))
			(cond
				((higher? obj1 obj2) (operate op obj1 (raise obj2)))
				((higher? obj2 obj1) (operate op (raise obj1) obj2))
				(else (error "Not same type!"))))))
	

(define (higher? obj1 obj2)
	(let 	((t1 (type obj1)) (t2 (type obj2)))
		(cond
			((eq? t1 'complex)
				(if	(or (eq? t2 'rational) (eq? t2 'number)) #t #f))
			((eq? t1 'rational)
				(if	(eq? t2 'number) #t #f))
			(else #f))))


(define (int->rat obj)
	(make-rat obj 1))
(define (rat->complex obj)
	(make-rectangle-complex (/ (numerator obj) (denominator obj)) 0))
(put 'number 'raise int->rat)
(put 'rational 'raise rat->complex)
(define (raise obj)
	(let 	((t1 (type obj)))
		((get t1 'raise) (content obj))))


(define (complex-can-drop? obj) (if (= 0 (imag-part obj)) #t #f))
(define (rat-can-drop? obj) (if (= 1 (denominator obj)) #t #f))
(define (number-can-drop? obj) #f)
(put 'complex 'can-drop? complex-can-drop?)
(put 'rational 'can-drop? rat-can-drop?)
(put 'number 'can-drop? number-can-drop?)
(define (complex-drop obj)
	(make-rat (real-part obj) 1))
(define (rat-drop obj)
	(make-number (numerator obj)))
(put 'complex 'drop complex-drop)
(put 'rational 'drop rat-drop)

(define (drop obj)
	(let	((t1 (type obj)))
		(if
			((get t1 'can-drop?) (content obj))
			(drop ((get t1 'drop) (content obj)))
			obj)))


;;complex
;constructor
(define (complex-attach-type type content)
	(cons type content))
(define (complex-type z)
	(if
		(pair? z)
		(car z)
		(error "error data")))
(define (complex-content z)
	(if
		(pair? z)
		(cdr z)
		(error "error data")))
(define (rectangle? z)
	(eq? (complex-type z) 'rectangle))
(define (polar? z)
	(eq? (complex-type z) 'polar))
(define (make-rectangle x y)
	(complex-attach-type 'rectangle (cons x y)))
(define (make-polar r a)
	(complex-attach-type 'polar (cons r a)))

;;selector
(define (rectangle-real-part obj)
	(car obj))
(define (rectangle-imag-part obj)
	(cdr obj))
(define (rectangle-magnitude obj)
	(sqrt (+ (square (car obj)) (square (cdr obj)))))
(define (rectangle-angle obj)
	(atan (car obj) (cdr obj)))
(define (polar-real-part obj)
	(* (car obj) (cos (cdr obj))))
(define (polar-imag-part obj)
	(* (car obj) (sin (cdr obj))))
(define (polar-magnitude obj)
	(car obj))
(define (polar-angle obj)
	(cdr obj))

(put 'rectangle 'real-part rectangle-real-part)
(put 'polar 'real-part 	polar-real-part)
(put 'rectangle 'imag-part rectangle-imag-part)
(put 'polar 'imag-part polar-imag-part)
(put 'rectangle 'magnitude rectangle-magnitude)
(put 'polar 'magnitude polar-magnitude)
(put 'rectangle 'angle rectangle-angle)
(put 'polar 'angle polar-angle)

(define (complex-operate op obj)
	(let	((t1 (type obj)))
		(cond	((eq? t1 'number ) (complex-operate op (raise (raise obj))))
			((eq? t1 'rational) (complex-operate op (raise obj)))
			(else
		(let	((proc (get (complex-type obj) op)))
			(if
				(null? proc)
				(error "no this type" (list op obj))
				(proc (complex-content obj))))))))


(define (real-part obj)
	(complex-operate 'real-part obj))
(define (imag-part obj)
	(complex-operate 'imag-part obj))
(define (magnitude obj)
	(complex-operate 'magnitude obj))
(define (angle obj)
	(complex-operate 'angle obj))


;;operator
(define (+c z1 z2)
	(make-complex (make-rectangle (+ (real-part z1) (real-part z2)) (+ (imag-part z1) (imag-part z2)))))
(define (-c z1 z2)
	(make-complex (make-rectangle (- (real-part z1) (real-part z2)) (- (imag-part z1) (imag-part z2)))))
(define (*c z1 z2)
	(make-complex (make-polar (* (magnitude z1) (magnitude z2)) (+ (angle z1) (angle z2)))))
(define (/c z1 z2)
	(make-complex (make-polar (/ (magnitude z1) (magnitude z2)) (- (angle z1) (angle z2)))))


(define (make-complex z)
	(cons 'complex z))
(define (make-rectangle-complex x y)
	(make-complex (make-rectangle x y)))
(define (make-polar-complex x y)
	(make-complex (make-polar x y)))
(put 'complex 'add +c)
(put 'complex 'sub -c)
(put 'complex 'mul *c)
(put 'complex 'div /c)
(put 'complex 'real-part real-part)
(put 'complex 'imag-part imag-part)
(put 'complex 'magnitude magnitude)
(put 'complex 'angle angle)
(define (c=zero? z)
	(and (= 0 (real-part z)) (= 0 (imag-part z))))
(define (r=zero? z)
	(and (= 0 (numerator z)) (not (= 0 (denominator z)))))
(define (n=zero? z)
	(= 0 z))
(put 'complex '=zero? c=zero?)
(put 'rational '=zero? r=zero?)
(put 'number '=zero? n=zero?)
(define (=zero? z)
	(let	((proc (get (type z) '=zero?)))
		(proc (content z))))