The exercise asks us to make a procedure drop that simplifies numbers. e.g. Complex to Real (if possible) and then modify the existing apply-generic so that it can simplify the number after calculating it.
Simply adding drop should work, and it does work outside the procedure in same conditions. But it gives me an error when added to apply-generic.
Here is the complete code:
(define (attach-tag type-tag contents)
(cons type-tag contents))
(define (type-tag datum)
(if (pair? datum)
(car datum)
(error "Bad tagged datum: TYPE-TAG" datum)))
(define (contents datum)
(if (pair? datum)
(cdr datum)
(error "Bad tagged datum: CONTENTS" datum)))
(define (put-coercion type1 type2 function)
(put type1 type2 function))
(define (get-coercion type1 type2)
(get type1 type2))
(define (element? ls e)
(cond ((null? ls) #f)
((eq? (car ls) e) #t)
(else (element? (cdr ls) e))))
(define (compose f g) (lambda (x) (f (g x))))
(define (double f) (compose f f))
(define (identity x) x)
(define (compose-n f n)
(cond ((= n 0) identity)
((even? n) (compose-n (double f) (/ n 2)))
(else (compose f (compose-n f (- n 1))))))
(define tower (list (list 'integer 0)
(list 'real 1)
(list 'complex 2)))
(define (child? ti t1 tower)
(define (iter t tow)
(cond
((null? tow) (error "Not located in Tower" t))
((eq? t (caar tow)) (cadar tow))
(else (iter t (cdr tow)))))
(if (< (- (iter t1 tower) (iter ti tower)) 1)
#f
(- (iter t1 tower) (iter ti tower))))
(define (ti->t1 ti t1)
(if (child? ti t1 tower)
(compose-n raise (child? ti t1 tower))
(get-coercion ti t1)))
(define (map-ls proc-ls arg-ls)
(if (null? proc-ls)
'()
(cons ((car proc-ls) (car arg-ls))
(map-ls (cdr proc-ls) (cdr arg-ls)))))
(define (iterator t op ty args)
(if (null? t)
(error "No method for these types"
(list op ty))
(let ((getter (map
(lambda (x) (ti->t1 x (car t))) ty)
))
(if (element? getter #f)
(iterator (cdr t) op ty args)
(let ((eq-tags
(map type-tag (map-ls getter args))))
(let ((proc (get op eq-tags)))
(if proc
(apply proc (map contents
(map-ls getter args)))
(iterator (cdr t) op ty args))))))))
(define (drop x)
(if (or (eq? (type-tag x) 'integer)
(not (project x)))
x
(drop (project x))))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(drop (apply proc (map contents args)))
(if (element? (map
(lambda (x) (eq? x (car type-tags)))
type-tags) #f)
(drop (iterator type-tags op type-tags args))
(error "No method for these types"
(list op type-tags))
)))))
(define (install-integer-package)
;;internal Procedures
(define (add x y)(+ (contents x) (contents y)))
(define (sub x y)(- (contents x) (contents y)))
(define (mul x y)(* (contents x) (contents y)))
(define (exp x y)(expt (contents x) (contents y)))
(define (make x) x)
(define (equ? x y)(= (contents x) (contents y)))
;;External Procedures
(define (tag x)
(attach-tag 'integer x))
(put 'add '(integer integer)
(lambda (x y) (tag (+ x y))))
(put 'sub '(integer integer)
(lambda (x y) (tag (- x y))))
(put 'mul '(integer integer)
(lambda (x y) (tag (* x y))))
(put 'div '(integer integer)
(lambda (x y) (make-rational x y)))
(put 'make 'integer
(lambda (x) (tag (make x))))
(put 'equ? '(integer integer)
(lambda (x y) (equ? x y)))
(put '=zero? '(integer)
(lambda (x) (= (contents x) 0)))
(put 'exp '(integer integer)
(lambda (x y) (tag (exp x y))))
(put 'raise '(integer)
(lambda (x) (make-real (* x 1.0))))
'done)
(define (install-real-package)
;;internal Procedures
(define (add x y)(+ (contents x) (contents y)))
(define (sub x y)(- (contents x) (contents y)))
(define (mul x y)(* (contents x) (contents y)))
(define (div x y)(/ (contents x) (contents y)))
(define (exp x y)(expt (contents x) (contents y)))
(define (make x) x)
(define (equ? x y)(= (contents x) (contents y)))
;;External Procedures
(define (tag x)
(attach-tag 'real x))
(put 'add '(real real)
(lambda (x y) (tag (add x y))))
(put 'sub '(real real)
(lambda (x y) (tag (sub x y))))
(put 'mul '(real real)
(lambda (x y) (tag (mul x y))))
(put 'div '(real real)
(lambda (x y) (tag (div x y))))
(put 'make 'real
(lambda (x) (tag (make x))))
(put 'equ? '(real real)
(lambda (x y) (equ? x y)))
(put '=zero? '(real)
(lambda (x) (= (contents x) 0)))
(put 'exp '(real real)
(lambda (x y) (tag (exp x y))))
(put 'raise '(real)
(lambda (x) (make-complex-from-real-imag
x 0)))
(put 'project '(real)
(lambda (x)(if (= (round x) x)
(make-integer (round x))
#f)))
'done)
(define (install-rectangular-package)
;; internal procedures
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (make-from-real-imag x y)
(cons x y))
(define (magnitude z)
(sqrt (+ (square (real-part z))
(square (imag-part z)))))
(define (angle z)
(atan (imag-part z) (real-part z)))
(define (make-from-mag-ang r a)
(cons (* r (cos a)) (* r (sin a))))
(define (equ? z1 z2)
(and (= (real-part z1) (real-part z2))
(= (real-part z1) (real-part z2))))
;; interface to the rest of the system
(define (tag x)
(attach-tag 'rectangular x))
(put 'real-part '(rectangular) real-part)
(put 'imag-part '(rectangular) imag-part)
(put 'magnitude '(rectangular) magnitude)
(put 'angle '(rectangular) angle)
(put 'make-from-real-imag 'rectangular
(lambda (x y)
(tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'rectangular
(lambda (r a)
(tag (make-from-mag-ang r a))))
(put 'equ? '(rectangular rectangular)
(lambda (z1 z2)
(equ? z1 z2)))
(put '=zero? '(rectangular)
(lambda (x) (and (= (real-part x) 0)
(= (imag-part x) 0))))
'done)
(define (install-polar-package)
;; internal procedures
(define (magnitude z) (car z))
(define (angle z) (cdr z))
(define (make-from-mag-ang r a) (cons r a))
(define (real-part z)
(* (magnitude z) (cos (angle z))))
(define (imag-part z)
(* (magnitude z) (sin (angle z))))
(define (make-from-real-imag x y)
(cons (sqrt (+ (square x) (square y)))
(atan y x)))
(define (equ? z1 z2)
(and (= (magnitude z1) (magnitude z2))
(= (angle z1) (angle z2))))
;; interface to the rest of the system
(define (tag x) (attach-tag 'polar x))
(put 'real-part '(polar) real-part)
(put 'imag-part '(polar) imag-part)
(put 'magnitude '(polar) magnitude)
(put 'angle '(polar) angle)
(put 'make-from-real-imag 'polar
(lambda (x y)
(tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'polar
(lambda (r a)
(tag (make-from-mag-ang r a))))
(put 'equ? '(polar polar)
(lambda (z1 z2)
(equ? z1 z2)))
(put '=zero? '(polar)
(lambda (x) (and (= (magnitude x) 0)
(= (angle x) 0))))
'done)
(define (install-complex-package)
;; imported procedures from rectangular and polar packages
(define (make-from-real-imag x y)
((get 'make-from-real-imag
'rectangular)
x y))
(define (make-from-mag-ang r a)
((get 'make-from-mag-ang 'polar)
r a))
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))
;; internal procedures
(define (add-complex z1 z2)
(make-from-real-imag
(+ (real-part z1) (real-part z2))
(+ (imag-part z1) (imag-part z2))))
(define (sub-complex z1 z2)
(make-from-real-imag
(- (real-part z1) (real-part z2))
(- (imag-part z1) (imag-part z2))))
(define (mul-complex z1 z2)
(make-from-mag-ang
(* (magnitude z1) (magnitude z2))
(+ (angle z1) (angle z2))))
(define (div-complex z1 z2)
(make-from-mag-ang
(/ (magnitude z1) (magnitude z2))
(- (angle z1) (angle z2))))
;; interface to rest of the system
(define (tag z) (attach-tag 'complex z))
(put 'add '(complex complex)
(lambda (z1 z2)
(tag (add-complex z1 z2))))
(put 'sub '(complex complex)
(lambda (z1 z2)
(tag (sub-complex z1 z2))))
(put 'mul '(complex complex)
(lambda (z1 z2)
(tag (mul-complex z1 z2))))
(put 'div '(complex complex)
(lambda (z1 z2)
(tag (div-complex z1 z2))))
(put 'make-from-real-imag 'complex
(lambda (x y)
(tag (make-from-real-imag x y))))
(put 'make-from-mag-ang 'complex
(lambda (r a)
(tag (make-from-mag-ang r a))))
(put 'real-part '(complex) real-part)
(put 'imag-part '(complex) imag-part)
(put 'magnitude '(complex) magnitude)
(put 'angle '(complex) angle)
(put 'equ? '(complex complex) equ?)
(put '=zero? '(complex) =zero?)
(put 'project '(complex)
(lambda (x)(if (= (imag-part x) 0)
(make-real(real-part x))
#f)))
'done)
(define (add x y) (apply-generic 'add x y))
(define (sub x y) (apply-generic 'sub x y))
(define (mul x y) (apply-generic 'mul x y))
(define (div x y) (apply-generic 'div x y))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (exp x y) (apply-generic 'exp x y))
(define (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (make-integer n)
((get 'make 'integer) n))
(define (make-real n)
((get 'make 'real) n))
(define (make-complex-from-real-imag x y)
((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
((get 'make-from-mag-ang 'complex) r a))
(install-rectangular-package)
(install-polar-package)
(install-integer-package)
(install-complex-package)
;(install-rational-package)
(install-real-package)
(define (install-coercion-package)
;;internal definintion
(define (integer->complex n)
(make-complex-from-real-imag
(contents n) 0))
(define (integer->integer n) n)
(define (complex->complex z) z)
(define (rational->rational r) r)
(define (real->real r) r)
;;External definition
(put-coercion 'integer 'integer integer->integer)
(put-coercion 'complex 'complex complex->complex)
(put-coercion 'integer 'complex integer->complex)
(put-coercion 'rational 'rational rational->rational)
(put-coercion 'real 'real real->real)
'done)
(install-coercion-package)
(sub (make-complex-from-real-imag 4 1)
(make-complex-from-real-imag 3 1))
(define proc (get 'sub '(complex complex)))
(define args (list (make-complex-from-real-imag 4 1)
(make-complex-from-real-imag 3 1)))
(display (apply proc (map contents args)))
The code works fine if I apply the drop procedure after I have done, i.e.
(drop (apply-generic op .args)) works fine. But the way I have implemented apply-generic
doing (drop (apply-generic op .args)) should be equivalent to
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(drop (apply proc (map contents args)))
(if(element?(map
(lambda (x) (eq? x (car type-tags)))
type-tags) #f)
(drop (iterator type-tags op type-tags args))
(error "No method for these types"
(list op type-tags))
)))))
But it gives me error that Bad tagged datum: TYPE-TAG 4 . Please help.
Turns out that I had not made a condition to only apply drop when performing arithmetic operations, thus the apply-generic procedure was trying to drop
the argument when I was taking real-part z and giving me the type-tag error.
Final Code:
(define arithmetic (list 'add 'sub 'mul 'div))
(define (apply-generic op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(if (element? arithmetic op)
(drop (apply proc (map contents args)))
(apply proc (map contents args)))
(if (element? (map
(lambda (x) (eq? x (car type-tags)))
type-tags) #f)
(iterator type-tags op type-tags args)
(error "No method for these types"
(list op type-tags))
)))))
There were also some problems with my implementation of install-real-package and equ? procedures but they were unrelated
I also ended up changing my drop procedure to be in line with the parameters of the exercise
(define (drop num)
(if (and (not (eq? (type-tag num) 'integer))
(equ? (raise (project num)) num))
(drop (project num))
num))