;comments: define put-coercion and get-coercion in order to load
(define (put-coercion a b f) (put a b f))
(define (get-coercion a b) (get a b))


;;;;;; #1
;;;;;; 2.75
(define (make-from-mag-ang x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* x (cos y)))
	  ((eq? op 'image-part) (* x (sin y)))
	  ((eq? op 'magnitude) x)
	  ((eq? op 'angle) y)
	  (else (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)

;define other test-purpose procedure
(define (apply-generic op arg) (arg op))
;STk> (define complex1 (make-from-mag-ang 10 (/ 3.1415926 6)))
;complex1
;STk> complex1
;#[closure arglist=(op) 1a3ec0]
;STk> (apply-generic 'magnitude complex1)
;10
;STk> (apply-generic 'angle complex1)
;0.523598766666667
;STk> (apply-generic 'real-part complex1)
;8.66025408250255
;STk> (apply-generic 'image-part complex1)
;4.9999999226498

;;;;;; 2.76
;1)
;generic operation with explicit dispatch
;to add a new type of data object, need to add the definition of this new data
;type (make sure no procedure has the same name with procedure in other data type),
;and modify each generic operation to test if the date is in this form as
;well as to call the corresponding function to extract the data.
;to add a new procedure, and add a new generic operation which test all data type,
;and call the corresponding selectors.

;2)
;generic operation with data-directed style
;to add a new type of data object, add the definition of this data type with the selectors
;together as a new package, and then the interface procedures.
;to add a new procedure, need to add the new algorithm for each type in the data structure.

;3)
;generic operations with message-passing-style
;to add a new type of data object, add the corresponing definition of the data type.
;to add a new procedure, modify all constructors to include algorithm for new operation.

;if new types must often be added, message-passing is a great choice
;if new operations must often be added, data-directed style is a great choice


;;;;;; 2.77
;the following code are copied from book for testing purpose
;define sqrt and square
(define (iterative-improve good? improve f)
  (lambda (guess)
    (if (good? f guess)  guess
      ((iterative-improve good? improve f) (improve f guess)))))
(define (good? f guess)
  (< (abs (- (f guess) guess)) 0.00001))
(define (improve_sqrt f guess)
  (/ (+ guess (f guess)) 2))
(define (sqrt n)
  ((iterative-improve good? improve_sqrt (lambda (x) (/ n x))) 1.0))

(define (square x) (* x x))

;early code for tagged data
(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 (install-rectangular-package)
;internal procedure
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
	     (square (imag-part z)))))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
;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))))
  'done)

;omit the polar package

;necessary generic operations
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
	  (apply proc (map contents args))
	  (error
	   "No Method for these types -- APPLY-GENERIC"
	   (list op type-tags))))))

(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))

(define (install-complex-package)
  (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))
;;internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
			 (+ (imag-part z1) (imag-part z2))))
;omit the sub, mul and div procedures
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
;omit the sub, mul and div procedures
  (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))))
;code added by Exercise 2.77 ***Important***
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(install-complex-package)
(install-rectangular-package)

(define z (make-complex-from-real-imag 3 4))

;here is the result without the added codes
;STk> (magnitude z)
;*** Error:
;    No Method for these types -- APPLY-GENERIC(magnitude (complex))
;Current eval stack:
;__________________
;  0    (stk-error "~A" (with-output-to-string (lambda () (for-each (lambda (x) (display x)) args))))

;here is the code with the added codes
;STk> (magnitude z)
;5.00000000005372

;explaination: when we call (magnitude z), z with a tag complex, so the apply-generic call the procedure
;(get 'magnitude '(complex)), yet, we didn't (put 'magnitude '(complex) magnitude), so, an error message.
;after we defined (put 'magnitude '(complex) magnitude), the first call of aplly-generic use the procedure
;(get 'magnitude '(complex)), then it gets another call of magnitude. But this time, the tag (complex) has
;been extracted already, so that the apply-generic will call (get 'magnitude 'rectangular) which is defined as
;(sqrt (+ (square (real-part z)) (square (imag-part z)))) in the rectangular parkage.

;trace result
;STk> (trace apply-generic)
;STk> (magnitude z)
;.. -> apply-generic with op = magnitude,  args = ((complex rectangular 3 . 4))
;.... -> apply-generic with op = magnitude,  args = ((rectangular 3 . 4))
;.... <- apply-generic returns 5.00000000005372
;.. <- apply-generic returns 5.00000000005372
;5.00000000005372

;we can tell both from the early explaination and the trace result that apply-generic
;has been called twice. first is (get 'magnitude '(complex)), and then it's
;(get 'magnitude '(rectangular))


;;;;;; 2.79
(define (equ? a b)
  (apply-generic 'equ? a b))

;add this procedure to the scheme-number package
(put 'equ? '(scheme-muber scheme-number)
     (lambda (x y) (= x y)))

;add this procedure to the rational package
;notes: no need to test for the common greatest divisor becasue gcd is included
(put 'equ? '(rational rational)
     (lambda (x y) (and (= (numer x) (numer y))
			(= (denom x) (denom y)))))

;add this procedure to the complex package
(put 'equ? '(complex complex)
     (lambda (x y) (and (= (real-part x) (real-part y))
			(= (imag-part x) (imag-part y)))))

;explaination: it's hard to type all the code inside and test for this procedure,
;however, from a programmer's point of view, this procedure should work. When we call
;(equ? a b), it calls the apply-generic with 'equ? and argument list of a b, then we
;will have (get 'equ? list-tags), list-tags will be '(complex complex) if there are
;two complex numbers. It will search for this procedure, if not found, it will return
;#f automatically; if found, test for the equality, then return #t or #f

;;;;;; 2.81
;defining the modified apply-generic from page 196
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
	  (apply proc (map contents args))
	  (if (= (length args) 2)
	      (let ((type1 (car type-tags))
		    (type2 (cadr type-tags))
		    (a1 (car args))
		    (a2 (cadr args)))
		(let ((t1->t2 (get-coercion type1 type2))
		      (t2->t1 (get-coercion type2 type1)))
		  (cond (t1->t2 (apply-generic op (t1->t2 a1) a2))
			(t2->t1 (apply-generic op a1 ((t2->t1) a2)))
			(else (error "No method for these types"
				     (list of type-tags))))))
	      (error "No method for these types"
		     (list op type-tages)))))))
;Louis Reasoner's code
(define (scheme-number->scheme-number n) n)
(define (complex->complex z) z)
(put-coercion 'scheme-number 'scheme-number
	      scheme-number->scheme-number)
(put-coercion 'complex 'complex complex->complex)

;a
(define (exp x y) (apply-generic 'exp x y))
;the following procedure has been added to scheme-number package
(put 'exp '(scheme-number scheme-number)
     (lambda (x y) (tag (expt x y))))

;when we call exp with two scheme-number as arguments, the local variable
;type-tags will have the value '(scheme-number scheme-number), and then
;the proc will be (get 'exp '(scheme-number scheme-number)), which is
;defined in the scheme-number package. Therefore, we need not to use the
;procedure scheme-number->scheme-number to handle this case.

;when we call exp with two complex as arguments, the local variable type-tags
;will have the value '(complex complex), and then proc will be (get 'exp
;'(complex complex)) which is not put in the table, so proc is #f. Now, the
;length is 2, so we try to do coercion. t1 and t2 will be 'complex, a1 and a2
;are the complex numbers. t1->t2 is defined, then we call (apply-generic op
;(t1->t2 a1) a2), notice that (t1->t2 a1) will give the same a1, then we call
;the same apply-generic again. Therefore, we end up with an endless loop

;b
;As illustrated in a, there is no need to add Louis's code. Moveover, Louis's
;code will cause endless loop. 

;c
;modify apply-generic
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tag)))
      (if proc
	  (apply proc (map contents args))
	  (if (= (length args) 2)
	      (let ((type1 (car type-tags))
		    (type2 (cadr type-tags))
		    (a1 (car args))
		    (a2 (cadr args)))
		(if (equal? type1 type2)
		    (error "no method for these types"
			   (list op type-tags))
		    (let ((t1->t2 (get-coercion type1 type2))
			  (t2->t1 (get-coercion type2 type1)))
		      (cond (t1->t2
			     (apply-generic op (t1->t2 a1) a2))
			    (t2->t1
			     (apply-generic op a1 (t2-t1 a2)))
			    (else
			     (error "No method for these types"
				    (list op type-tags)))))))
	  (error "No method for these types"
		 (list op type-tags)))))))

;since get-coercion and put coericion is not defind, we cannot check for the
;result, but comparing the apply-generic with the code in book, we can conclude
;that this new difinition will check for the same types and returns error without
;trying to do any coercion


;;;;;; 2.83
;assumption: all the data install packages are in the system already
(define (scheme-number->rational n)
  (make-rational (contents n) 1))
(define (rational->real n)
  (let ((datum (contents n)))
    (make-real (/ (numer datum) (denom datum)))))
(define (real->complex n)
  (make-complex-from-real-imag n 0))

(put-coercion 'raise '(scheme-number) scheme-number->rational)
(put-coercion 'raise '(rational) rational->real)
(put-coercion 'raise '(real) real->complex)

(define (raise n)
  (apply-generic 'raise n))

;with the proper package installed, the above codes will add a new
;generic operation named raise to scheme-number, rational, and real


;;;;;; #2
(define-class (random-generator range)
  (instance-vars (count 0))
  (method (number) (set! count (+ count 1))
			     (random range)))

;STk> (define r10 (instantiate random-generator 10))
;r10
;STk> (ask r10 'count)
;0
;STk> (ask r10 'number)
;9
;STk> (ask r10 'count)
;1
;STk> (ask r10 'number)
;0
;STk> (ask r10 'number)
;9
;STk> (ask r10 'count)
;3


;;;;;; #3
(define-class (coke-machine max price)
  (instance-vars (current 0)
		 (amount 0))
  (method (deposit x) (set! amount (+ amount x)))
  (method (coke)
	  (cond ((< amount price) '(not enough money))
		((= current 0) (begin (print '(machine empty please try later))
				      (print '(return amount deposited...))
				      (print amount)
				      (set! amount 0)))
		(else (begin (set! current (- current 1))
			     (print (- amount price))
			     (set! amount 0)))))
  (method (fill n)
	  (if (> (+ n current) max)
	      (begin (print '(reached maximun))
		     (set! current max))
	      (set! current (+ current n)))))

(define my-machine (instantiate coke-machine 80 70))

;STk> (ask my-machine 'deposit 100)
;STk> (ask my-machine 'coke)
;(machine empty please try later)
;(return amount deposited...)
;100
;STk> (ask my-machine 'fill 60)
;STk> (ask my-machine 'fill 30)
;(reached maximun)
;STk> (ask my-machine 'current)
;80
;STk> (ask my-machine 'deposit 25)
;STk> (ask my-machine 'coke)
;(not enough money)
;STk> (ask my-machine 'deposit 50)
;STk> (ask my-machine 'coke)
;5
;STk> (ask my-machine 'amount)
;0
;STk> (ask my-machine 'current)
;79


;;;;;; #4
(define-class (miss-manners obj)
  (method (please mes arg)
	  (ask obj mes arg))
  (default-method
    (se '(error: no method) message)))

;testing sample class
(define-class (a x)
  (method (add n) (set! x (+ n x))
	  x))

(define obj1 (instantiate a 10))
(define fussy (instantiate miss-manners obj1))

;STk> (ask obj1 'add 33)
;43
;STk> (ask fussy 'add 33)
;(error: no method add)
;STk> (ask fussy 'please 'add 33)
;76