SICP/ex-2_73-76.scm

(load "util.scm")

(newline) (display "ex-2.73 - deriv data-directed") (newline)

(define *op-table* (make-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) #f))

(display "a. - see comments\n")
; a.

; When exp is an actual expression (and not a number or variable) get is used
; to retrieve the respective procedure from the table.  We can't do this for a
; variable or number, because there is no operator that can be used to access
; the table.

; The new implementation of deriv selects the right procedure based on the
; operator of the expression. If the expression is a number or variable the
; procedure to get the operator will fail. Hence, those two cases are handled
; separately.
(display "\nb.\n")

(define (variable? x) (symbol? x))
(define (=number? exp num)
  (and (number? exp) (= exp num)))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))
(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 (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))

(define (install-deriv-package)
  (define (multiplier operands) (car operands))
  (define (addend operands) (car operands))
  (define (get-remaining-operands operands operator)
    (if (null? (cddr operands))
      (cadr operands)
      (cons operator (cdr operands))))
  (define (multiplicand operands) (get-remaining-operands operands '*))
  (define (augend operands) (get-remaining-operands operands '+))
  (define (deriv-sum operands var)
    (make-sum (deriv (addend operands) var)
              (deriv (augend operands) var)))
  (define (deriv-product operands var)
    (make-sum
      (make-product (multiplier operands)
                    (deriv (multiplicand operands) var))
      (make-product (deriv (multiplier operands) var)
                    (multiplicand operands))))
  ;; interface to the rest of the system
  (put 'deriv '+ deriv-sum)
  (put 'deriv '* deriv-product)
  (display "[installed deriv package]") (newline)
  'done)

(install-deriv-package)

(display "tests:\n")
(assert (deriv '(+ x 3) 'x) 1)
(assert (deriv '(* x 3) 'x) 3)
(assert (deriv '(* x x) 'x) '(+ x x))
(assert (deriv '(* (* x y) (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))

; c.
(display "\nc.\n")

(define (install-deriv-exp-package)
  (define (make-exponentiation base exponent)
    (cond ((=number? exponent 0) 1)
          ((=number? exponent 1) base)
          (else (list '** base exponent))))
  (define (base e) (car e))
  (define (exponent e) (cadr e))
  (define (deriv-exponentiation operands var)
    (let ((u (base operands))
          (n (exponent operands)))
      (make-product
        (make-product n (make-exponentiation u (make-sum n -1)))
        (deriv u var))))
  ;; interface to the rest of the system
  (put 'deriv '** deriv-exponentiation)
  (display "[installed deriv exp package]") (newline)
  'done)

(install-deriv-exp-package)
(display "exp test: ")
(assert (deriv '(** x 4) 'x) '(* 4 (** x 3)))

(display "multiple operands test: ")
(assert (deriv '(+ x 1 x x) 'x) 3)

; d.
(display "\nd.\n")
(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp) (if (same-variable? exp var) 1 0))
        (else ((get (operator exp) 'deriv) (operands exp) var))))

; All we have to do is to add the procedures to the look-up table
; in reverse order:
(put '+ 'deriv (get 'deriv '+))
(put '* 'deriv (get 'deriv '*))
(put '** 'deriv (get 'deriv '**))

(assert (deriv '(+ x 3) 'x) 1)
(assert (deriv '(* x 3) 'x) 3)
(assert (deriv '(* x x) 'x) '(+ x x))
(assert (deriv '(* (* x y) (+ x 3)) 'x) '(+ (* x y) (* y (+ x 3))))


(newline) (display "ex-2.74") (newline)

(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 (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 (list-records recs)
  (map (lambda (rec) (display rec) (newline)) (contents recs))
  (newline))

(define div1-recs
  (attach-tag
    'div1-type
    '(((family "Martin") (first "Felix") (salary 800)(city "Detroit") (number "+1 313-421-5203"))
      ((family "Linus") (first "Torvalds") (salary 120)  (city "Helsinki") (number "+42 420-231-3242"))
      ((family "Helene") (first "Fischer") (salary 500) (city "Frankfurt") (number "+49 17670120304")))))

(define div2-recs
  (attach-tag
    'div2-type
    '(("Barack Obama" (age 55))
      ("Tom Brady" (age 33))
      ("Michael Jordan" (age 58)))))

;(list-records div1-recs)
;(list-records div2-recs)

(define (install-div1-package)
  (define (tag x) (list 'div1-type x))
  (define (get-record key file)
    (cond
      ((null? file) #f)
      ((equal? (cadr (car (car file))) key) (tag (car file)))
      (else (get-record key (cdr file)))))
  (define (get-salary record)
    (cadr (caddr (car record))))
  ; interface to the rest of the system
  (put 'get-record '(key div1-type) get-record)
  (put 'get-salary '(div1-type) get-salary)
  (display "[installed div1 package]") (newline)
  'done)

(install-div1-package)

(display "a.") (newline)
; This is the whole function that the headquarter needs.  The only things they
; need from the division is the get-record function and the type tag for the
; personnel file.
(define (get-record key division-file)
  (apply-generic 'get-record key division-file))

(define martin-rec (get-record (attach-tag 'key "Martin") div1-recs))
(display martin-rec)
(newline)

(display "b.") (newline)
; Straight forward. Division has to know how to get the salary for their
; record.
(define (get-salary record)
  (apply-generic 'get-salary record))
(assert (get-salary martin-rec) 800)

(display "c.") (newline)
; Add implementation for div2 so that we can run tests over multiple divisions'
; records.
(define (install-div2-package)
  (define (tag x) (list 'div2-type x))
  (define (get-record key file)
    (cond
      ((null? file) #f)
      ((equal? (car (car file)) key) (tag (car file)))
      (else (get-record key (cdr file)))))
  (define (get-salary record) (error "Not implemented"))
  (put 'get-record '(key div2-type) get-record)
  (put 'get-salary '(div2-type) get-salary)
  (display "[installed div2 package]") (newline)
  'done)
(install-div2-package)

(define (find-employee-record key division-files)
  (if (null? division-files)
    #f
    (let ((record (get-record key (car division-files))))
      (if (not record)
        (find-employee-record key (cdr division-files))
        record))))

(assert (get-salary (find-employee-record (attach-tag 'key "Helene") (list div1-recs div2-recs))) 500)
(assert (find-employee-record (attach-tag 'key "Hilton") (list div1-recs div2-recs)) #f)
(display (find-employee-record (attach-tag 'key "Tom Brady") (list div1-recs div2-recs)))

(display "\nd. - see comments") (newline)

; No changes have to be made to the system. The new company only has to provide
; the defined proceedures and install them into the system.

(display "[ok]")
(newline)

(newline) (display "ex-2.75 - message passing") (newline)

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

(define (apply-generic op arg) (arg op))

(define img-num (make-from-mag-ang 1 45))

(assert (apply-generic 'magnitude img-num) 1)
(assert (apply-generic 'angle img-num) 45)
(display (apply-generic 'real-part img-num))
(newline)
(display (apply-generic 'imag-part img-num))

(newline) (display "ex-2.76 - see comments") (newline)

; Changes that have to be made for new type:
; explicit-dispatch: each selector has to check for the new type
; data-directed: all operations for the new type have to be implemented
; message-passing: all operations for the new type have to be implemented

; Changes that have to be made for new operation:
; explicit-dispatch: none
; data-directed: the operation has to be implemented for each type
; message-passing: the operation has to be implemented for each type

; For systems where new types are added regularly data-directed or message
; passing is the best system. When new operations have to be added explicit
; dispatch is the best system.

; I like the answer by torinmr: http://community.schemewiki.org/?sicp-ex-2.76