; Slides 15 -- Systems with Generic Operations
; Generic Arithmetic Operations

; load file containg get and put procedures
(load "slides-14-data-directed-programming.scm")


; generic operations definitions
; to use we would need to attach a tag to each
; kind of number and cause the generic procedure
; to dispatch the appropriate package for the
; data types of its arugments
(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))

; package for handling ordinary scheme numbers
; note the key is (scheme-number scheme-number)
; since each takes two arguments, both of which
; are ordinary scheme-numbers
(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  (put 'add
       '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub
       '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul
       '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div
       '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make
       'scheme-number
       (lambda (x) (tag x)))
  'done)

; user of the scheme-number package will create
; tagged ordinary numbers by means of the make
; procedure
(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

; package for performing rational arithmetic
(define (install-rational-package)
  ; internal procedures
  (define numer car)
  (define denom cdr)
  (define (make-rat n d)
    (let ((g (gcd n d)))
         (cons (/ n g) (/ d g))))
  (define (tag x) (attach-tag 'rational x))
  ; interface to rest of system
  (put 'add
       '(rational rational)
       (lambda (x y)
         (tag (make-rat
                (+ (* (numer x) (denom y))
                   (* (numer y) (denom x)))
                (* (denom x) (denom y))))))
  (put 'sub
       '(rational rational)
       (lambda (x y)
         (tag (make-rat
                (- (* (numer x) (denom y))
                   (* (numer y) (denom x)))
                (* (denom x) (denom y))))))
  (put 'mul
       '(rational rational)
       (lambda (x y)
         (tag (make-rat
                (* (numer x) (numer y))
                (* (denom x) (denom y))))))
  (put 'div
       '(rational rational)
       (lambda (x y)
         (tag (make-rat
                (* (numer x) (denom y))
                (* (denom x) (numer y))))))
  (put 'make
       'rational 
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) n d))

; package for handling complex numbers
(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))
  
  ; interface to rest of the system
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  (define (tag z) (attach-tag 'complex z))
  (put 'add
       '(complex complex)
       (lambda (z1 z2)
         (tag (make-from-real-imag
                (+ (real-part z1)
                   (real-part z2))
                (+ (imag-part z1)
                   (imag-part z2))))))
  (put 'sub
       '(complex complex)
       (lambda (z1 z2)
         (tag (make-from-real-imag
               (- (real-part z1)
                   (real-part z2))
                (- (imag-part z1)
                   (imag-part z2))))))
  (put 'mul
       '(complex complex)
       (lambda (z1 z2)
         (tag (make-from-mag-ang
                (* (magnitude z1)
                   (magnitude z2))
                (+ (angle z1) (angle z2))))))
  (put 'div
       '(complex complex)
       (lambda (z1 z2)
         (tag (make-from-mag-ang
                (/ (magnitude z1)
                   (magnitude z2))
                (- (angle z1) (angle 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))))
  'done)

; exporting complex numbers to outside world
(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))

; run the procedures to set up the operations table
; operation-table will hold the triples of
; operations, their type, and the associated action
; (define operation-table ())
; in previous file operation-table initialized
; with rectangular and polar representations
(install-scheme-number-package)
(install-rational-package)
(install-complex-package)

;; to allow operations between mixed types
;; must allow coercion between types
; puts a procedure for coercing a scheme-number
; into a rational number
(put 'coerce
     'scheme-number
     (lambda (n)
       (make-rational (contents n) 1)))

; puts a procedure for coercing a rational number
; into a complex number
(put 'coerce
     'rational
     (lambda (r)
       (make-complex-from-real-imag
          (/ (car (contents r))
             (cdr (contents r)))
          0)))

;; must put precedence information in the operation
;; table to control coercion
(put 'scheme-number 'rational 'precedence)
(put 'scheme-number 'complex 'precedence)
(put 'rational 'complex 'precedence)

; new apply-generic procedure attempts to
; do type coercion if no operator with the
; appropriate type is defined in the operation
; table
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          ; if procedure of appropraite type exists
          ; apply that procedure
          (apply proc (map contents args))
          ; otherwise, attempt to do coercion if
          ; there are two arguments
          (if (= (length args) 2)
            (let ((t1 (car type-tags))
                  (t2 (cadr type-tags))
                  (a1 (car args))
                  (a2 (cadr args)))
              (let ((t1up (get 'coerce t1))
                    (t2up (get 'coerce t2))
                    (p1 (get t1 t2))
                    (p2 (get t2 t1)))
                ; t1up and t2up contain coercion
                ; procedures if they exist
                (cond (p1
                       (apply-generic
                        op
                         (t1up a1)
                         a2))
                      (p2
                       (apply-generic
                        op
                        a1
                        (t2up a2)))
                      (else
                       (error
                        "no method"
                        (list
                         op
                         type-tags))))))       
            (error "no method"
                   (list op type-tags)))))))