Structure and Interpretation of Computer Programs

#lang planet neil/sicp

;; ======================================================================
;;
;; To test the exercises I need an implementation of put and get.
;; These are taken directly from section 3.3.3 of the book 
;; http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-22.html#%_sec_3.3.3
;;
;; ======================================================================

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

;;
;; Other procedures taken from the book that support the exercise in section 2.4 
;;
(define variable? symbol?)
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))
(define (=number? exp num)
  (and (number? exp) (= exp num)))
(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list '+ a1 a2))))
(define addend car)
(define augend cadr)

(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list '* m1 m2))))
(define multiplier car)
(define multiplicand cadr)

(define (make-exponentiation base exponent)
  (cond ((eq? base 0) 0)
        ((= exponent 0) 1)
        ((= exponent 1) base)
        (else (list '** base exponent))))
(define base car)
(define exponent cadr)


;; Ex 2.73 a
;;
(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp) (if (same-variable? exp var) 1 0))
        (else ((get 'deriv (operator exp)) (operands exp) var))))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp)) 

; The deriv here replaces the explicit check of expression's type and the call to the appropriate procedure to
; actually perform the deriv of the expression with a generic dispatch to a deriv operation installed as a procedure 
; in the dispatch table.
; 
; the get returns a procedure (assuming that the correct deriv procedures are installed) and the retrieved 
; procedure is called passing it the operands also taken from the expression.
;
; Neither number nor variable expressions use an operator or operands so we can't use the same generic diospatch 
; mechanism using the procedures operator and operands. 
;
; It is possible to work around this by changing both procedures and 
; writing 2 new procedures deriv-number and deriv-varibale and installing 
; them into the operations table, but it obfuscates the nature of the problem. 
; i.e. deriving number and variable expression is inherently different from the rest
; 
;
;  (define (operator-b exp)
;    (cond ((number? exp) 'num)
;          ((variable? exp) 'var)
;          (else (car exp))))
;  (define (operands-b exp)
;    (cond ((number? exp) nil)
;          ((variable? exp) nil)
;          (else (cdr exp))))
;  (define (deriv-number exp var) 0)
;  (define (deriv-variable exp var) 
;   (if (same-variable? exp var)
;       1
;       0))
;  (put 'deriv 'num deriv-number)
;  (put 'deriv 'var deriv-variable)
;


;; Ex 2.73 b
;;
(define (deriv-sum exp var) 
  (make-sum (deriv (addend exp) var)
            (deriv (augend exp) var)))

(define (deriv-product exp var) 
  (make-sum (make-product (multiplier exp)
                          (deriv (multiplicand exp) var))
            (make-product (deriv (multiplier exp) var)
                          (multiplicand exp))))

(define (install-deriv)
  (put 'deriv '+ deriv-sum)
  (put 'deriv '* deriv-product)
  'done)

;; Ex 2.73 c
;;
(define (deriv-exponentiation expr var)
  (let ((base (base expr))
        (exponent (exponent expr)))
    (make-product exponent
                  (make-product (make-exponentiation base (make-sum exponent -1))
                                (deriv base var)))))

(define (install-exponentiation-extension)
  (put 'deriv '** deriv-exponentiation)
  'done)

;; Ex 2.73 d
;;
; changing to ((get (operator exp) 'deriv) (operands exp) var)
; means the only changes necessary are to alter each use of put 
; similarly in the installation procedure
;  (put '** 'deriv deriv-exponentiation)
;  (put '+ 'deriv deriv-sum )
;  (put '* 'deriv deriv-product)


;; Ex 2.74a
;;
; Each division has their own file and to needs to provide headquarters with a 

(define (make-hq-file division file)
  (cons division file))
(define (file-division hq-file)
  (car hq-file))
(define (original-file hq-file)
  (cdr hq-file))

(define (get-record employee hq-file)
  ((get 'get-record (file-division hq-file))
   employee (original-file hq-file)))

(define (has-record? employee division)
  ((get 'has-record? division) employee))

;; Ex 2.74b
;;
(define (get-salary hq-file)
  ((get 'get-salary (file-division hq-file))
   (original-record hq-file)))

; The hq record needs the division and the division's record.
(define (make-hq-record division record)
  (cons division record))
(define (record-division hq-record)
  (car hq-record))
(define (original-record hq-record)
  (cdr hq-record))

;; Ex 2.74c
;;
(define (find-employee-record employee files)
  (cond ((null? files) (error "find-employee-record : no such employee." employee))
        ((has-record? employee (file-division (car files)))
         (get-record employee (car files)))
        (else (find-employee-record
               employee (cdr files)))))

;; Ex 2.74d
;;
; Each new company must have it's own unique division identifier (presumable given to them by Insatitable)
; and uses that to provide and install their own specific versions of
;   get-record 
;   has-record?
;   get-salary 
; 
(define (install-ultra-mega-corp)
  (put 'ultra-mega-corp 'get-record ultra-mega-corp-get-record)
  (put 'ultra-mega-corp 'has-record? ultra-mega-corp-has-record?)
  (put 'ultra-mega-corp 'get-salary ultra-mega-corp-get-salary))

(define (ultra-mega-corp-get-record employee file) #t)
(define (ultra-mega-corp-has-record? employee file) #t)
(define (ultra-mega-corp-get-salary employee record) #t)

;; Ex 2.75
;;
(define (make-from-mag-ang x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* x (cos y)))
          ((eq? op 'imag-part) (* x (sin y)))
          ((eq? op 'magnitude) x)
          ((eq? op 'angle)     y)
          (else
           (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)

;; Exercise 2.73

;; Dispatch table.
;;
(define *op-table* (make-equal-hash-table))

(define (put op type proc)
  (hash-table/put! *op-table* (list op type) proc))

(define (get op type)
  (hash-table/get *op-table* (list op type) '()))



(define (deriv exp var)
  (cond ((number? exp) 0)
	((variable? exp) (if (same-variable? exp var) 1 0))
	(else ((get 'deriv (operator exp)) (operands exp)
					   var))))

(define (variable? x) (symbol? x))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp)) 
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (install-deriv-package)
  ;; internal procedures
  (define (addend s) (car s))      ;; the definitions of accessors (augend,
  (define (augend s) (cadr s))     ;; multiplier, etc.) are different from
  (define (multiplier p) (car p))  ;; the originals, because deriv only
  (define (multiplicand p) (cadr p));; passes the expression without the operator
  (define (base e) (car e))
  (define (exponent e) (cadr e))

  (define (sum exp var)                 
    (make-sum (deriv (addend exp) var)
	      (deriv (augend exp) var)))

  (define (product exp var)
    (make-sum
     (make-product (multiplier exp)
		   (deriv (multiplicand exp) var))
     (make-product (deriv (multiplier exp) var)
		   (multiplicand exp))))

  (define (exponentiation exp var)
    (make-product
     (make-product (exponent exp)
		   (make-exponentiation (base exp)
					(make-sum
					 (exponent exp) -1)))))

  (define (=number? exp num)
    (and (number? exp) (= exp num)))

  (define (make-sum a1 a2)
    (cond ((=number? a1 0) a2)
	  ((=number? a2 0) a1)
	  ((and (number? a1) (number? a2)) (+ a1 a2))
	  (else (list '+ a1 a2))))

  (define (make-product m1 m2)
    (cond ((or (=number? m1 0) (=number? m2 0)) 0)
	  ((=number? m1 1) m2)
	  ((=number? m2 1) m1)
	  ((and (number? m1) (number? m2)) (* m1 m2))
	  (else (list '* m1 m2))))

  (define (make-exponentiation u n)
    (cond ((and (number? u) (number? n)) (expt u n))
	  ((=number? n 0) 1)
	  ((=number? n 1) u)
	  (else (list '** u n))))

  ;; interface to the rest of the system
  (put 'deriv '+ sum)
  (put 'deriv '* product)
  (put 'deriv '** exponentiation)
  'done)

(install-deriv-package)
(deriv '(* (* x y) (+ x 3)) 'x)

;; Exercise 2.74

;; a. Each division supplies appropriate procedures tagged with division name.

(define (get-record division employee)
  ((get 'get-record division) employee))

;; b. Filter the division lists

(define (get-salary employee division-list)
  (filter (lambda (division)
	    ((get 'get-salary division) employee))
	  division-list))

;; c.

(define (find-employee-record employee division-list)
  (filter (lambda (division)
            ((get 'get-record division) employee))
          division-list))



;; Exercise 2.75

(define (make-from-real-imag x y)
  (define (dispatch op)
    (cond ((eq? op 'real-part) x)
	  ((eq? op 'imag-part) y)
	  ((eq? op 'magnitude)
	   (sqrt (+ (square x)(square y))))
	  ((eq? op 'angle) (atan y x))
	  (else
	   (error "Unknown op -- MAKE-FROM-REAL-IMAG" op))))
  dispatch)

(define (make-from-mag-ang r a)
  (define (dispatch op)
    (cond ((eq? op 'real-part) (* r (cos a)))
	  ((eq? op 'imag-part) (* r (sin a)))
	  ((eq? op 'mag) r)
	  ((eq? op 'angle) a)
	  (else
	   (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)

(define z (make-from-real-imag 3 4))
(z 'real-part)
(z 'imag-part)
(z 'angle)
(z 'magnitude)