generic operators

;; Table abstraction
(define dict-proc (make-hash-table))
(define (put key value)
    (hash-create-handle! dict-proc key value))
(define (get key)
    (hash-get-handle dict-proc key))

;; Tags
(define attach-tag cons)
(define type car)
(define contents cdr)

;; ***********************************************
;; Complex numbers
;; ***********************************************

;; Complex numbers constructor for rectangular and polar

(define (make-rect obj-x obj-y)
    (attach-tag `rect (cons obj-x obj-y)))
(define (make-polar obj-x obj-y)
    (attach-tag `polar (cons obj-x obj-y)))
(define (make-complex obj)
    (attach-tag `complex obj))

;; complex numbers rect selectors
(define (complex-init-rect)
    (define re-rect car)
    (define im-rect cdr)
    (define (mag-rect a)
        (let ([x (re-rect a)]
              [y (im-rect a)]
              [square (lambda (a) (* a a))])
        (sqrt (+ (square x) (square y)))))
    (define (ang-rect a)
        (let ([x (re-rect a)]
              [y (im-rect a)])
              (atan (/ x y))))
    (put (cons `re `rect) re-rect)
    (put (cons `im `rect) im-rect)
    (put (cons `mag `rect) mag-rect)
    (put (cons `ang `rect) ang-rect))

;; complex numbers polar selectors
(define (complex-init-polar)
    (define mag-polar car)
    (define ang-polar cdr)
    (define (re-polar a)
        (let ([r (mag-polar a)]
              [theta (ang-polar a)])
        (* r (cos theta))))
    (define (im-polar a)
        (let ([r (mag-polar a)]
              [theta (ang-polar a)])
        (* r (sin theta))))
    (put (cons `re `polar) re-polar)
    (put (cons `im `polar) im-polar)
    (put (cons `mag `polar) mag-polar)
    (put (cons `ang `polar) ang-polar))

(define (operate op obj)
    (let ([proc (get (cons op (type obj)))])
        (if (not (null? proc)) (proc (contents obj))
            (error "ERROR: operation cannot be performed on object"))))

(define (operate-general op obj-x obj-y)
    (if (eq? (type obj-x) (type obj-y))
        (let ([proc (get (cons op (type obj-x)))])
            (if (not (null? proc)) (proc (contents obj-x) (contents obj-y))
                (error "ERROR: No such operation is defined")))
        (error "ERROR: The types do not match for the operation to occur")))

(define (re obj)
    (operate `re obj))
(define (im obj)
    (operate `im obj))
(define (mag obj)
    (operate `mag obj))
(define (ang obj)
    (operate `ang obj))

(define (+c obj-x obj-y)
    (make-rect (+ (re obj-x) (re obj-y))
               (+ (im obj-y) (im obj-y))))
(define (-c obj-x obj-y)
    (make-rect (- (re obj-x) (re obj-y))
               (- (im obj-y) (im obj-y))))
(define (*c obj-x obj-y)
    (make-polar (* (mag obj-x) (mag obj-y))
                (+ (ang obj-x) (ang obj-y))))
(define (/c obj-x obj-y)
    (make-polar (* (mag obj-x) (mag obj-y))
                       (+ (ang obj-x) (ang obj-y))))

;; Generic selectors
(define (complex-init)
    (define (+complex obj-x obj-y)
        (make-complex (+c obj-x obj-y)))
    (define (-complex obj-x obj-y)
        (make-complex (-c obj-x obj-y)))
    (define (*complex obj-x obj-y)
        (make-complex (*c obj-x obj-y)))
    (define (/complex obj-x obj-y)
        (make-complex (/c obj-x obj-y)))

    (put (cons `add `complex) +complex)
    (put (cons `sub `complex) -complex)
    (put (cons `mul `complex) *complex)
    (put (cons `div `complex) /complex))

;; Generic operations
(define (add obj-x obj-y)
    (operate-general 'add obj-x obj-y))

(define (sub obj-x obj-y)
    (operate-general 'sub obj-x obj-y))

(define (mul obj-x obj-y)
    (operate-general 'mul obj-x obj-y))

(define (div obj-x obj-y)
    (operate-general 'div obj-x obj-y))

;; Driver program
(complex-init-rect)
(complex-init-polar)
(complex-init)
(define a (make-complex (make-rect 2 2)))
(define b (make-complex (make-rect 1 3)))

(format #t "~a\n" (add a b))