SICP 3.3.3 表の表現

github.com

3.3.2の最後のデキューの実装でちょっと燃え尽きた感があったのと、次の「デジタル回路のシミュレーター」が楽しみ過ぎて3.3.2はざっくりとだけ...

(define (assoc key records)
  (cond ((null? records) false)
        ((equal? key (caar records)) (car records))
        (else (assoc key (cdr records)))))

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (same-key? key))

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

; ex-3.24
(define (make-table same-key?)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (same-key? key-1 (cdr local-table))))
        (if subtable
          (let ((record (same-key? key-2 (cdr subtable))))
            (if record
              (cdr record)
              #f))
          #f)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (same-key? key-1 (cdr local-table))))
        (if subtable
          (let ((record (same-key? 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 (search key records)
  (cond ((null? records) #f)
        ((equal? key (caar records)) (car records))
        ((and (number? key) (< (abs (- key (caar records))) 0.5)) (car records))
        (else (search key (cdr records)))))

; ex-3.26
(define (make-table)
  (let ((local-table '*table*))
    (define (key-tree tree)
      (car tree))
    (define (value-tree tree)
      (cadr tree))
    (define (left-branch tree)
      (caddr tree))
    (define (right-branch tree)
      (cadddr tree))
    (define (make-tree key value left right)
      (list key value left right))
    (define (set-value-tree! tree value)
      (set-car! (cdr tree) value))
    (define (set-left-branch-tree! tree left)
      (set-car! (cddr tree) left))
    (define (set-right-branch-tree! tree right)
      (set-car! (cdddr tree) right))

    (define (lookup key)
      (define (iter key tree)
        (cond ((null? key) #f)
              ((= key (key-tree tree)) (value-tree tree))
              ((< key (key-tree tree))
               (iter key (left-branch tree)))
              ((> key (key-tree tree))
               (iter key (right-branch tree)))))
      (iter key local-table))

    (define (insert! key value)
      (define (make-branch key value)
        (make-tree key value '() '()))
      (define (iter key value tree)
        (cond ((eq? tree '*table*)
               (set! local-table (make-branch key value)))
              ((= key (key-tree tree))
               (set-value-tree! tree value))
              ((< key (key-tree tree))
               (if (null? (left-branch tree))
                 (set-left-branch-tree! tree (make-branch key value))
                 (iter key value (left-branch tree))))
              ((> key (key-tree tree))
               (if (null? (right-branch tree))
                 (set-right-branch-tree! tree (make-branch key value))
                 (iter key value (right-branch tree))))))
      (iter key value local-table)
      'ok)

    (define (print-table)
      (display local-table)
      (newline))

    (define (dispatch m)
      (cond ((eq? m 'print-table) print-table)
            ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation TABLE" m))))
    dispatch))

(define tb (make-table))
(define lookup (tb 'lookup-proc))
(define insert! (tb 'insert-proc!))
(define print-table (tb 'print-table))

; ex-3.27
(define (fib n)
  (cond ((= n 0) 0)
        ((= n 1) 1)
        (else (+ (fib (- n 1))
                 (fib (- n 2))))))

(define (memoize f)
  (let ((table (make-table)))
    (lambda (x)
      (let ((previously-computed-result (lookup x table)))
        (or previously-computed-result
            (let ((result (f x)))
              (insert! x result table)
              result))))))

(define memo-fib
  (memoize (lambda (n)
             (cond ((= n 0) 0)
                   ((= n 1) 1)
                   (else (+ (memo-fib (- n 1))
                            (memo-fib (- n 2))))))))

SICP 3.3.2 キューの表現

github.com

; 3.3.2 キューの表現
; 3.3.scmはconsを自前実装しているのでファイルを分ける(dispatchを返して意図したように動かないので)

(define (make-queue) (cons '() '()))

(define (front-ptr queue) (car queue))
(define (rear-ptr queue) (cdr queue))
(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))

(define (empty-queue? queue) (null? (front-ptr queue)))

(define (front-queue queue)
  (if (empty-queue? queue)
    (error "FRONT called with an empty queue" queue)
    (car (front-ptr queue))))

(define (insert-queue! queue item)
  (let ((new-pair (cons item '())))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-pair)
           (set-rear-ptr! queue new-pair)
           queue)
          (else
            (set-cdr! (rear-ptr queue) new-pair)
            (set-rear-ptr! queue new-pair)
            queue))))

(define (delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "DELETE! called with an empty queue" queue))
        (else
          (set-front-ptr! queue (cdr (front-ptr queue)))
          queue)))

; ex-3.21
; queueは以下の様になっている。
;
; q→OO--------
;   ↓        ↓
;   OO→OO→OO→OO
;   ↓  ↓  ↓  ↓
;   a  b  c  d
;
; 最初の対で常に先頭と末尾を指し示している。
; よって印字した時に((a b c d) d)のようになってしまう。
(define (print-queue queue)
  (print (car queue)))

(define q1 (make-queue))
(print "************************** ex-3.21")
(print-queue q1)

(insert-queue! q1 'a)
(print-queue q1)
(insert-queue! q1 'b)
(print-queue q1)
(delete-queue! q1)
(print-queue q1)
(delete-queue! q1)
(print-queue q1)

; ex-3.22
(define (make-queue-dispatch)
  (let ((front-ptr '())
        (rear-ptr '()))
    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))
    (define (empty-queue?) (null? front-ptr))
    (define (front-queue)
      (if (empty-queue?)
        (error "FRONT called with an empty queue" front-ptr)
        (car front-ptr)))
    (define (rear-queue)
      (if (empty-queue?)
        (error "FRONT called with an empty queue" rear-ptr)
        (car rear-ptr)))
    (define (insert-queue! item)
      (let ((new-pair (cons item '())))
        (cond ((empty-queue?)
               (set-front-ptr! new-pair)
               (set-rear-ptr! new-pair)
               front-ptr)
              (else
                (set-cdr! rear-ptr new-pair)
                (set-rear-ptr! new-pair)
                front-ptr))))
    (define (delete-queue!)
      (cond ((empty-queue?)
             (error "DELETE! called with an empty queue" front-ptr))
            (else
              (set-front-ptr! (cdr front-ptr))
              front-ptr)))
    (define (print-queue)
      (print front-ptr))
    (define (dispatch m)
      (cond ((eq? m 'insert-queue!) insert-queue!)
            ((eq? m 'delete-queue!) delete-queue!)
            ((eq? m 'front) front-queue)
            ((eq? m 'rear) rear-queue)
            ((eq? m 'print-queue) (print-queue))
            (else
              (error "Undefined operation -- MAKE-QUEUE" m))))

    dispatch))

(define q (make-queue-dispatch))
(print "************************** ex-3.22")
((q 'insert-queue!) 'a)
(q 'print-queue)
((q 'insert-queue!) 'b)
(q 'print-queue)
((q 'insert-queue!) 'c)
(q 'print-queue)
((q 'delete-queue!))
(q 'print-queue)
((q 'delete-queue!))
(q 'print-queue)
((q 'insert-queue!) 'd)
(q 'print-queue)
((q 'delete-queue!))
(q 'print-queue)
((q 'delete-queue!))
(q 'print-queue)
; ((q 'delete-queue!))

; ex-3.23
;
; dq->OO
;     ↓↓
;     OO
;     ↓
;     aO
;
; dq->OO--
;     ↓  ↓
;   ->OO→OO
;   | ↓  ↓
;   | bO aO
;   |-----|(以下はb-ptrで代用)
;
; dq->OO-----
;     ↓     ↓
;     OO→OO→OO
;     ↓  ↓  ↓
;     cO bO aO
;         ↓  ↓
;         cp b-ptr

; debug
; https://wat-aro.hatenablog.com/entry/2015/11/20/184629
(define (value-ptr ptr) (caar ptr))
(define (prev-ptr ptr) (cdar ptr))
(define (next-ptr ptr) (cdr ptr))
(define (print-deque queue)
  (let recur ((deque (front-ptr queue)))
    (cond ((null? deque) '())
          (else
            (cons (value-ptr deque)
                  (recur (next-ptr deque)))))))

(define (make-deque) (cons '() '()))
(define (deque-front-ptr deque) (car deque))
(define (deque-rear-ptr deque) (cdr deque))
(define (empty-deque? deque) (null? (deque-front-ptr deque)))

(define (front-deque deque)
  (if (empty-deque? deque)
    (error "FRONT called with an empty deque" deque)
    (car (deque-front-ptr deque))))

(define (rear-deque deque)
  (if (empty-deque? deque)
    (error "REAR called with an empty deque" deque)
    (car (deque-rear-ptr deque))))

; (front-insert-deque! deque 'a)
(define (front-insert-deque! deque item)
  (let ((new-pair (list (list item))))
    (cond ((empty-deque? deque)
           ; 最初はfront,rear共に同じitemに向ける
           (set-front-ptr! deque new-pair)
           (set-rear-ptr! deque new-pair)
           deque)
          (else
            (let ((before-front-item (car (front-ptr deque))))
              (set-cdr! new-pair (front-ptr deque))
              ; dequeのfrontをnew-pairに向ける.
              ; new-pairのcdrは既にdequeを向いているのでfrontにinsertした事になっている
              (set-front-ptr! deque new-pair)
              ;prev-item
              (set-cdr! before-front-item (front-ptr deque)))
            deque))))

(define (rear-insert-deque! deque item)
  (let ((new-pair (list (list item))))
    (cond ((empty-deque? deque)
           ; 最初はfront,rear共に同じitemに向ける
           (set-front-ptr! deque new-pair)
           (set-rear-ptr! deque new-pair)
           deque)
          (else
            ; prev-item
            (set-cdr! (car new-pair) (rear-ptr deque))
            ; dequeのcdr(rear)のcdrをnew-pairに向ける(rearへのinsert)
            (set-cdr! (cdr deque) new-pair)
            ; dequeのrearをnew-pairに向ける
            (set-rear-ptr! deque new-pair)
            deque))))

(define (front-delete-deque! deque)
  (cond ((empty-deque? deque)
         (error "DELETE! called with an empty deque" deque))
        (else
          ; dequeのcar(先頭)のcdr(次のitem)をdequeのcar(front)にsetする(frontのdelete)
          (set-front-ptr! deque (cdr (car deque)))
          ; ゴミ掃除
          (set-cdr! (car (front-ptr deque)) '())
          deque)))

(define (rear-delete-deque! deque)
  (cond ((empty-deque? deque)
         (error "DELETE! called with an empty deque" deque))
        (else
          (set-rear-ptr! deque (cdr (car (rear-ptr deque))))
          ; ゴミ掃除
          (set-cdr! (rear-ptr deque) '())
          deque)))

(print "************************** ex-3.23")
(define dq (make-deque))
;;;;;;;;;;;;;;;;;;; front-insert-deque!
(print "insert-queue!")
;
; dq->OO
;     ↓↓
;     OO
;     ↓
;     aO
(front-insert-deque! dq 'a)
(print (print-deque dq))

; dq->OO--
;     ↓  ↓
;   ->OO→OO
;   | ↓  ↓
;   | bO aO
;   |-----|(以下はb-ptrで代用)

(front-insert-deque! dq 'b)
(print (print-deque dq))

; dq->OO-----
;     ↓     ↓
;     OO→OO→OO
;     ↓  ↓  ↓
;     cO bO aO
;         ↓  ↓
;         cp b-ptr
(front-insert-deque! dq 'c)
(print (print-deque dq))

;;;;;;;;;;;;;;;;;;; rear-insert-deque!
(print "rear-insert-deque!")
; dq->OO--------
;     ↓        ↓
;     OO→OO→OO→OO
;     ↓  ↓  ↓  ↓
;     cO bO aO dO
;         ↓  ↓  ↓
;         cp bp ap
(rear-insert-deque! dq 'd)
(print (print-deque dq))

; dq->OO-----------
;     ↓           ↓
;     OO→OO→OO→OO→OO
;     ↓  ↓  ↓  ↓  ↓
;     cO bO aO dO eO
;         ↓  ↓  ↓  ↓
;         cp bp ap dp
(rear-insert-deque! dq 'e)
(print (print-deque dq))

;;;;;;;;;;;;;;;;;;; front-delete-deque!
(print "front-delete-deque!")
; dq->OO-----------
;        ↓        ↓
;     OO→OO→OO→OO→OO
;     ↓  ↓  ↓  ↓  ↓
;     cO bO aO dO eO
;            ↓  ↓  ↓
;            bp ap dp
(front-delete-deque! dq)
(print (print-deque dq))

; dq->OO-----------
;           ↓     ↓
;     OO→OO→OO→OO→OO
;     ↓  ↓  ↓  ↓  ↓
;     cO bO aO dO eO
;               ↓  ↓
;               ap dp
(front-delete-deque! dq)
(print (print-deque dq))

;;;;;;;;;;;;;;;;;;; rear-delete-deque!
(print "rear-delete-deque!")
; dq->OO--------
;           ↓  ↓
;     OO→OO→OO→OO OO
;     ↓  ↓  ↓  ↓  ↓
;     cO bO aO dO eO
;              ↓  ↓
;              ap dp
(rear-delete-deque! dq)
(print (print-deque dq))

; dq->OO------
;           ↓↓
;     OO→OO→OO OO OO
;     ↓  ↓  ↓  ↓  ↓
;     cO bO aO dO eO
;              ↓  ↓
;              ap dp
(rear-delete-deque! dq)
(print (print-deque dq))

SICP 3.3.1 可変リスト構造

github.com

; ex-3.12
(define (append x y)
  (if (null? x)
    y
    (cons (car x) (append (cdr x) y))))

(define (append! x y)
  (set-cdr! (last-pair x) y))

(define (last-pair x)
  (if (null? (cdr x))
    x
    (last-pair (cdr x))))
;
; (define x (list 'a 'b))
; (define y (list 'c 'd))
; (define z (append x y))
;
; z
; (a b c d)
;
; (cdr x)
; (応答)
; (b)
; z->OO->OO--->OO
;    ↓   ↓　　 ↓
; x->OO->OO y->OO->OO
;    ↓   ↓     ↓   ↓
;    a   b     c   d
; 上記図のcdrなので(b)
;
; (define w (append! x y))
;
; w
; (a b c d)
;
; (cdr x)
; (応答)
; (b c d)
;    w       y
;    ↓       ↓
; x->OO->OO->OO->OO
;    ↓   ↓   ↓   ↓
;    a   b   c   d
; 上記図のcdrなので(b c d)

; ex-3.13
(define (make-cycle x)
  (set-cdr! (last-pair x) x)
  x)

; (define z (make-cycle (list 'a 'b 'c)))
; gosh$ (define z (make-cycle (list 'a 'b 'c)))
;z
;gosh$ z
;#0=(a b c . #0#)
;

;   __________
;   ↓        |
; z→OO->OO->OO
;   ↓   ↓   ↓
;   a   b   c

; ex-3.14
(define (mystery x)
  (define (loop x y)
    (if (null? x)
      y
      (let ((temp (cdr x)))
        (set-cdr! x y)
        ; (print "x: " x)
        (loop temp x))))
  (loop x '()))

; 一般にmysteryが何をするか説明せよ.
; 1-loop(x: ('a 'b 'c 'd), y: ())
; temp: ('b 'c 'd)
; x: (a)
; (loop ('b 'c 'd) (a))
;
; 2-loop(x: ('b 'c 'd), y: (a))
; temp: ('c 'd)
; x: (b a)
; (loop (c d) (b a))
;
; 3-loop(x: (c d), y: (b a))
; temp: (d)
; x: (c b a)
; (loop (d) (c b a))
;
; 4-loop(x: (d), y: (c b a))
; temp: ()
; x: (d c b a)
; (loop () (d c b a))
;
; 5-loop
; return y(d c b a)
;
; listをreverseする、元のlistは壊れる.

(define v (list 'a 'b 'c 'd))
; vが束縛されているリストを表現する箱とポインタを描け.
;
; v→OO→OO→OO→OO
;   ↓  ↓  ↓  ↓
;   a  b  c  d

(define w (mystery v))
; この式を評価した後の構造vとwを示すポインタと箱を描け.
;
;            v
;            ↓
; w→OO→OO→OO→OO
;   ↓  ↓  ↓  ↓
;   d  c  b  a

; gosh$ (define v (list 'a 'b 'c 'd))
; v
; gosh$ (define w (mystery v))
; w
; gosh$ v
; (a)
; gosh$ w
; (d c b a)


(define x (list 'a 'b))
(define z1 (cons x x))
(define z2 (cons (list 'a 'b) (list 'a 'b)))

(define (set-to-wow! x)
  (set-car! (car x) 'wow)
  x)

; z1
; ((a b) a b)
;
; (set-to-wow! z1)
; ((wow b) wow b)
;
; z2
; ((a b) a b)
;
; (set-to-wow! z2)
; ((wow b) a b)

; ex-3.15
; z1
; z1→OO
;    ↓↓
;  x→OO→OO
;    ↓  ↓
;    a  b
;
; (set-to-wow! z1)
; z1→OO
;    ↓↓
;  x→OO→OO
;    ↓  ↓
; a wow b
;
; z2
; z2→OO→OO→OO
;    |  ↓  ↓
;    |  a  b
;    |  ↑  ↑
;    -→ OO→OO
;
; (set-to-wow! z2)
; z2→OO→OO→OO
;    |  ↓  ↓
;    |  a  b
;    |     ↑
;    -→ OO→OO
;       ↓
;      wow

; ex-3.16
(define (count-pairs x)
  (if (not (pair? x))
    0
    (+ (count-pairs (car x))
       (count-pairs (cdr x))
       1)))

(define x (cons 'd (cons 'a '())))
; x→OO→OO
;   ↓  ↓
;   d  a
(set-car! x (cons 'b (cdr x)))
;   b
;   ↑
;   OO--
;   ↑  ↓
; x→OO→OO
;      ↓
;      a
(count-pairs x)
; 4
x
; ((b a) a)

(define x (cons 'a (cons 'b (cons 'c '()))))
; x→OO→OO→OO
;   ↓  ↓  ↓
;   a  b  c
(set-car! (cdr x) (cdr (cdr x)))
;       ___
;      |  ↓
; x→OO→OO→OO
;   ↓     ↓
;   a  b  c
(set-car! x (cdr x))
;       ___
;      |  ↓
; x→OO→OO→OO
;   |--↑  ↓
;         c
;   a  b
;
; ※ a,bはポインタから外れている(この図だけ見にくいので注釈)
(count-pairs x)
; 7
x
; (((c) c) (c) c)

(define x (cons 'a (cons 'b (cons 'c '()))))
(make-cycle x)
; #0=(a b c . #0#)
;
;   _______
;   ↓      |
; x→OO→OO→OO
;   ↓  ↓  ↓
;   a  b  c
; (count-pairs x)
; 無限ループ

; ex-3.17
(define (make-count-pairs walks)
  (define (count-pairs x)
    (print "walks: " walks)
    (print "x: " x)
    (print "memq: " (memq x walks))
    (cond ((not (pair? x)) 0)
          ((memq x walks) 0)
          (else
            (set! walks (cons x walks))
            (print "after set! walks: " walks)
            (+ (count-pairs (car x))
               (count-pairs (cdr x))
               1))))
  count-pairs)

(define CP (make-count-pairs '()))

(define x (cons 'a (cons 'b (cons 'c '()))))
; (print (CP x))

(define x (cons 'd (cons 'a '())))
(set-car! x (cons 'b (cdr x)))
; (print (CP x))

(define x (cons 'a (cons 'b (cons 'c '()))))
(set-car! (cdr x) (cdr (cdr x)))
(set-car! x (cdr x))
; (print (CP x))

; ex-3.18
(define (circulate? items)
  (define walks '())
  (define (has-circulate? x)
    (if (memq x walks)
      #t
      (begin (set! walks (cons x walks)) #f)))
  (define (circulate?-iter i)
    (if (not (pair? i))
      #f
      (if (has-circulate? (car i))
        #t
        (circulate?-iter (cdr i)))))
  (circulate?-iter items))

(define z (make-cycle (list 'a 'b 'c)))

(print (circulate? z))
(print (circulate? (list 'a 'b 'c)))
(print (circulate? 'a))

; ex-3.19
; pass

; ex-3.20
(define (cons x y)
  (define (set-x! v) (set! x v))
  (define (set-y! v) (set! y v))
  (define (dispatch m)
    (cond ((eq? m 'car) x)
          ((eq? m 'cdr) y)
          ((eq? m 'set-car!) set-x!)
          ((eq? m 'set-cdr!) set-y!)
          (else (error "Undefined operation -- CONS" m))))
  dispatch)

(define (car z) (z 'car))
(define (cdr z) (z 'cdr))
(define (set-car! z new-value)
  ((z 'set-car!) new-value)
  z)
(define (set-cdr! z new-value)
  ((z 'set-cdr!) new-value)
  z)

; 上の手続きを使って一連の式の評価を示す環境の図を描け
(define x (cons 1 2))
(define z (cons x x))
(set-car! (cdr z) 17)
(car x)
; 17

;(define x (cons 1 2))
; car, cdr, set-car!, set-cdrの図は省略
;
;             パラメタ:x y
;             本体: (define (set-x! ...
;             ↑
;             OO
;             ↓↑(cons)
;             _____________________________________________________________________
; 大域領域 -> |cons:
;             |car:
;             |cdr:
;             |set-car!:
;             |set-cdr!:
;             |x:
;             ---------------------------------------------------------------------
;             ↓(x)                    ↑
;             OO---------------------→E1->|x:1      |
;                                         |y:2      |
;             ↓                           |set-x!:  |←→OO→パラメタ:v, 本体:(set! x v)
;             パラメタ:x,y                |set-y!:  |←→OO→パラメタ:v, 本体:(set! y v)
;             本体: (cond ((eq? ...       |dispatch:|←→OO→パラメタ:m, 本体:(cond ...
;
; (define z (cons x x))
;             _____________________________________________________________________
; 大域領域 -> |cons:
;             |car:
;             |cdr:
;             |set-car!:
;             |set-cdr!:
;             |x:
;             |z:
;             ---------------------------------------------------------------------
;             ↓(x)                    ↑
;             OO---------------------→E1->|x:1      |
;                                         |y:2      |
;             ↓                           |set-x!:  |←→OO→パラメタ:v, 本体:(set! x v)
;             パラメタ:x,y                |set-y!:  |←→OO→パラメタ:v, 本体:(set! y v)
;             本体: (cond ((eq? ...       |dispatch:|←→OO→パラメタ:m, 本体:(cond ...
;
;             ↓(大域のz)              ↑(大域)
;             OO---------------------→E2->|x:x      |
;                                         |y:y      |
;             ↓                           |set-x!:  |←→OO→パラメタ:v, 本体:(set! x v)
;             パラメタ:x,y                |set-y!:  |←→OO→パラメタ:v, 本体:(set! y v)
;             本体: (cond ((eq? ...       |dispatch:|←→OO→パラメタ:m, 本体:(cond ...
;
; (set-car! (cdr z) 17)
;             _____________________________________________________________________
; 大域領域 -> |cons:
;             |car:
;             |cdr:
;             |set-car!:
;             |set-cdr!:
;             |x:
;             |z:
;             ---------------------------------------------------------------------
;             ↓(x)                    ↑
;             OO---------------------→E1->|x:1      |←E4→|m: 'set-car!|(dispatch)
;                                         |y:2      |
;             ↓                           |set-x!:  |←E5→|v: 17|(set-x!)
;             パラメタ:x,y                |set-y!:  |
;             本体: (cond ((eq? ...       |dispatch:|
;
;             ↓(大域のz)              ↑(大域)
;             OO---------------------→E2->|x:x      |
;                                         |y:x      |
;             ↓                           |set-x!:  |←→OO→パラメタ:v, 本体:(set! x v)
;             パラメタ:x,y                |set-y!:  |←→OO→パラメタ:v, 本体:(set! y v)
;             本体: (cond ((eq? ...       |dispatch:|←→OO→パラメタ:m, 本体:(cond ...
;
;                                      ↑(大域)
;                                     E3→|z:z          |
;                                        |new-value: 17|
;
; (car x)
;             _____________________________________________________________________
; 大域領域 -> |cons:
;             |car:
;             |cdr:
;             |set-car!:
;             |set-cdr!:
;             |x:
;             |z:
;             ---------------------------------------------------------------------
;             ↓(x)                    ↑
;             OO---------------------→E1->|x:1      |←E4→|m: 'set-car!|(dispatch)
;                                         |y:2      |
;             ↓                           |set-x!:  |←E5→|v: 17|(set-x!)
;             パラメタ:x,y                |set-y!:  |
;             本体: (cond ((eq? ...       |dispatch:|←E6→|m: 'car|(dispatch)
;
;             ↓(大域のz)              ↑(大域)
;             OO---------------------→E2->|x:x      |
;                                         |y:x      |
;             ↓                           |set-x!:  |←→OO→パラメタ:v, 本体:(set! x v)
;             パラメタ:x,y                |set-y!:  |←→OO→パラメタ:v, 本体:(set! y v)
;             本体: (cond ((eq? ...       |dispatch:|←→OO→パラメタ:m, 本体:(cond ...
;
;                                      ↑(大域)
;                                     E3→|z:z          |
;                                        |new-value: 17|

SICP 3.2 評価の環境モデル

見にくい...↓こちらで見れる

github.com

; ex-3.9
;
; 再帰版
;             _____________________________________
; 大域領域 -> |                                   |
;             -------------------------------------
;                 ↑        ↑        ↑
;             E1→|n:3| E2→|n:2| E3→|n:1|
;             (if (= n 1)
;               1
;               (* n (factorial (- n 1))))
;             E1 ~ E1同じ↑
;
; 反復版
;             _____________________________________
; 大域領域 -> |                                   |
;             -------------------------------------
;              ↑
;              E1→|n:3|
;              (fact-iter 1 1 n)
;                                ↑
;                                E2→|product:1  |
;                                   |counter:1  |
;                                   |max-count:3|
;                                   (fact-iter (* counter product)
;                                              (+ counter 1)
;                                              max-count)
;
; E3 product:1, counter:2, max-count:6
; E4 product:2, counter:3, max-count:6
; E5 product:6, counter:4, max-count:6
; E6 product:24, counter:5, max-count:6
; E6 product:120, counter:6, max-count:6
; E6 product:720, counter:7, max-count:6

; ex-3.10
;
; (define W1 (make-withdraw 100))
; (W1 50)
; (define W2 (make-withdraw 100))
;---------------------------------------------
;
; (define W1 (make-withdraw 100))
;             _____________________________________________________________________
; 大域領域 -> |make-withdraw:                                                     |
;             |W1:                                                                |
;             ---------------------------------------------------------------------
;             ↑                         ↓(W1)     ↑               ↑(make-withdraw:)
;             E1→|initial-balance:100|  OO--->E2→|balance:100|    OO
;                                       ↓                         ↓
;                                       パラメタ: amount          パラメタ:initial-amount
;                                       本体: (lambda (amount)... 本体: (lambda (balance)...
;
; (W1 50)
;             _____________________________________________________________________
; 大域領域 -> |make-withdraw:                                                     |
;             |W1:                                                                |
;             ---------------------------------------------------------------------
;              ↓(W1)      ↑
;              OO-------->E2→|balance:100|
;              ↓            ↑
;              パラメタ:   |amount: 50|
;              本体:
;
;             _____________________________________________________________________
; 大域領域 -> |make-withdraw:                                                     |
;             |W1:                                                                |
;             ---------------------------------------------------------------------
;              ↓(W1)      ↑
;              OO-------->E2→|balance:50|
;              ↓
;              パラメタ:
;              本体:
;
; (define W2 (make-withdraw 100))
;             _____________________________________________________________________
; 大域領域 -> |make-withdraw:                                                     |
;             |W1:                                                                |
;             |W2:                                                                |
;             ---------------------------------------------------------------------
;              ↓(W1)      ↑                ↑                       ↓(W2)    ↑
;              OO-------->E2→|balance:50|  E3|initial-balance:100| OO--->E4|balance:100|
;              ↓                                                   ↓
;              パラメタ:                                           パラメタ: amount
;              本体:                                               本体: (lambda (amount)...
; memo:
;   defineされた時にOO(対になるオブジェクト) が作られる.
;   評価された時に環境が作られるが作られる.


; ex-3.11
;
; (define acc (make-account 50))
;
; ((acc 'deposit) 40)
; 90
;
; ((acc 'withdraw) 60)
; 30
;
; (define acc2 (make-account 100))
;---------------------------------------------
;
; (define acc (make-account 50))
;             _____________________________________________________________________
; 大域領域 -> |make-account:
;             |acc:
;             ---------------------------------------------------------------------
;             ↑↓(make-account)               ↓(acc)                 ↑  ____________
;             OO                             OO--------------------→E1→|balance:50|
;             ↓                              ↓                         |withdraw: |<->OO->パラメタ:amount, 本体: (if (>= balance amount) ...
;             パラメタ: balance:             パラメタ: m               |deposit:  |<->OO->パラメタ:amount, 本体: (set! balance ...
;             本体: (define (withdraw ...    本体: (cond ((eq? ...     |dispatch: |<->OO->パラメタ:m, 本体: (cond ((eq? ...
;
;
; ((acc 'deposit) 40)
;             _____________________________________________________________________
; 大域領域 -> |make-account:
;             |acc:
;             ---------------------------------------------------------------------
;             ↑↓(make-account)               ↓(acc)                 ↑   ___________
;             OO                             OO--------------------→E1→|balance:90|
;             ↓                              ↓                         |withdraw: |<->OO->パラメタ:amount, 本体: (if (>= balance amount) ...
;             パラメタ: balance:             パラメタ: m               |deposit:  |<->OO->パラメタ:amount, 本体: (set! balance ...
;             本体: (define (withdraw ...    本体: (cond ((eq? ...     |dispatch: |<->OO->パラメタ:m, 本体: (cond ((eq? ...
;                                                                      ------------
;                                                                      ↑       ↑
;                                                         E2→|m: 'deposit| E3→|amount: 40|
; ((acc 'withdraw) 60)
;             _____________________________________________________________________
; 大域領域 -> |make-account:
;             |acc:
;             ---------------------------------------------------------------------
;             ↑↓(make-account)               ↓(acc)                 ↑   ___________
;             OO                             OO--------------------→E1→|balance:30|
;             ↓                              ↓                         |withdraw: |<->OO->パラメタ:amount, 本体: (if (>= balance amount) ...
;             パラメタ: balance:             パラメタ: m               |deposit:  |<->OO->パラメタ:amount, 本体: (set! balance ...
;             本体: (define (withdraw ...    本体: (cond ((eq? ...     |dispatch: |<->OO->パラメタ:m, 本体: (cond ((eq? ...
;                                                                      ------------
;                                                                      ↑       ↑
;                                                        E4→|m: 'withdraw| E5→|amount: 60|
;
;
; (define acc2 (make-account 100))
;             _____________________________________________________________________
; 大域領域 -> |make-account:
;             |acc:
;             |acc2:
;             ---------------------------------------------------------------------
;             ↑↓(make-account)               ↓(acc)                 ↑  ____________
;             OO                             OO--------------------→E1→|balance:50|
;             ↓                              ↓                         |withdraw: |<->OO->パラメタ:amount, 本体: (if (>= balance amount) ...
;             パラメタ: balance:             パラメタ: m               |deposit:  |<->OO->パラメタ:amount, 本体: (set! balance ...
;             本体: (define (withdraw ...    本体: (cond ((eq? ...     |dispatch: |<->OO->パラメタ:m, 本体: (cond ((eq? ...
;
;                                            ↓(acc2)                ↑(大域)
;                                            OO--------------------→E6→|balance:100|
;                                            ↓                         |withdraw:  |<->OO->パラメタ:amount, 本体: (if (>= balance amount) ...
;                                            パラメタ: m               |deposit:   |<->OO->パラメタ:amount, 本体: (set! balance ...
;                                            本体: (cond ((eq? ...     |dispatch:  |<->OO->パラメタ:m, 本体: (cond ((eq? ...

SICP 3.1 代入と局所状態

; 3.1.1 局所状態変数

; withdraw以外のどこからでもbalanceにアクセス出来る.
; withdrawからだけアクセス出来るようにしたい.
(define balance 100)
(define (withdraw amount)
  (if (>= balance amount)
    ; beginは順次評価していって最後の式を返す
    ; set!は破壊的な再代入
    (begin (set! balance (- balance amount))
           balance)
    "Insufficient funds"))

; gosh$ (withdraw 25)
; 75
; gosh$ (withdraw 25)
; 50
; gosh$ (withdraw 100)
; "Insufficient funds"

; letを使って初期値100に束縛した局所変数balanceを持つ「環境」を作る.
; これはwithdrawとまったく一緒に振る舞うが、balanceにはnew-withdrawしかアクセス出来ない.
;
; set!と局所変数を組み合わせるのは一般的なプログラム技法だが、困ったことに重大な問題を惹き起こす。
; はじめに手続きを説明した時、手続き作用の意味の解釈の用意として、評価の置き換えモデルを説明した(1.1.5)
; 手続きの作用とは仮パラメタをその値で取替、手続きの本体を評価すること。
; 問題は言語に代入を取り入れると置き換えは最早手続き作用の適切なモデルにならない(なぜそうかは3.1.3節で説明する)。
;
; 上記で言いたいのはつまり「再代入という破壊的な操作を取り入れると、引数に対して関数の本体である手続きを作用させる時に問題が生じる。どんな問題が生じるかは後で説明する。取り敢えず駄目なんだよ」.
(define new-withdraw
  (let ((balance 100))
    (lambda (amount)
      (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
    "Insufficient funds"))))

; gosh$ (new-withdraw 25)
; 75
; gosh$ (new-withdraw 25)
; 50
; gosh$ (new-withdraw 100)
; "Insufficient funds"

; balanceは局所変数として状態維持される(違和感ある)
(define (make-withdraw balance)
  (lambda (amount)
      (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds")))

(define W1 (make-withdraw 100))
(define W2 (make-withdraw 100))

; gosh$ (W1 50)
; 50
; gosh$ (W2 70)
; 30
; gosh$ (W2 40)
; "Insufficient funds"
; gosh$ (W1 40)
; 10

; balanceは局所変数として状態維持される(違和感ある(2回目))
(define (make-account balance)
  (define (withdraw amount)
    (if (>= balance amount)
      (begin (set! balance (- balance amount))
             balance)
      "Insufficient funds"))

  (define (deposiot amount)
    (set! balance (+ balance amount))
    balance)

  ; メッセージパッシング流のプログラミング
  (define (dispatch m)
    (cond ((eq? m 'withdraw) withdraw)
          ((eq? m 'deposit) deposiot)
          (else (error "Unknown request -- MAKE-ACCOUNT"
                       m))))
  dispatch)

; gosh$ (define acc (make-account 100))
; acc
; gosh$ ((acc 'withdraw) 50)
; 50
; gosh$ ((acc 'withdraw) 60)
; "Insufficient funds"
; gosh$ ((acc 'deposit) 40)
; 90
; gosh$ ((acc 'withdraw) 60)
; 30
; gosh$ (define acc2 (make-account 100))
; acc2
; gosh$ ((acc2 'withdraw) 10)
; 90

; ex-3.1
(define (make-accumulator balance)
  (lambda (amount)
    (begin (set! balance (+ balance amount))
           balance)))

(define A (make-accumulator 5))
(define B (make-accumulator 5))
; (print (A 10))
; 15
; (print (A 10))
; 25
; (print (B 1))
; 6

; ex-3.2
; (define mfじゃなくてlambda使ってるけどこんな感じ
(define (make-monitored proc)
  (let ((counter 0))
    (lambda (x)
      (cond ((eq? x 'how-many-calls?) counter)
            ((eq? x 'reset-count) (set! counter 0))
            (else
              (begin (set! counter (+ counter 1))
                     (proc x)))))))

; 無理やりdispatchでやってみた
(define (make-monitored proc)
  (let ((counter 0))
    (define (do-proc x) (begin (set! counter (+ counter 1))
                               (proc x)))
    (define (return-counter x) counter)
    (define (reset-counter x) (set! counter 0))

    (define (dispatch m)
      (cond ((eq? m 'how-many-calls?) (return-counter m))
            ((eq? m 'reset-count) (reset-counter m))
            (else (do-proc m))))
    dispatch))

(define s (make-monitored sqrt))
; (print (s 100))
; 10
; (print (s 100))
; 10
; (print (s 'how-many-calls?))
; 2
; (print (s 'reset-count))
; 0
; (print (s 'how-many-calls?))
; 0

; ex-3.3
(define (make-account balance my-password)
  (define (withdraw amount)
    (if (>= balance amount)
      (begin (set! balance (- balance amount))
             balance)
      "Insufficient funds"))

  (define (deposiot amount)
    (set! balance (+ balance amount))
    balance)

  (define (dispatch password m)
    (if (eq? my-password password)
      (cond ((eq? m 'withdraw) withdraw)
            ((eq? m 'deposit) deposiot)
            (else (error "Unknown request -- MAKE-ACCOUNT" m)))
      (error "Incorrect password")))
  dispatch)

; (define acc (make-account 100 'secret-password))
;
; (print ((acc 'secret-password 'withdraw) 40))
; 60
;
; (print ((acc 'some-other-password 'deposit) 50))
; "Incorrect password"

; ex-3.3
(define (make-account balance my-password)
  (let ((access-counter 0))
    (define (withdraw amount)
      (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))

    (define (deposiot amount)
      (set! balance (+ balance amount))
      balance)

    (define (call-the-cops)
      (error "call-the-cops"))

    (define (dispatch password m)
      (if (>= access-counter 7)
        (call-the-cops)
        (if (eq? my-password password)
          (begin (set! access-counter 0)
                 (cond ((eq? m 'withdraw) withdraw)
                       ((eq? m 'deposit) deposiot)
                       (else (error "Unknown request -- MAKE-ACCOUNT" m))))
          (begin (set! access-counter (+ access-counter 1))
                 (print "access-counter " access-counter)
                 (error "Incorrect password")))))
    dispatch))

;;;;;;; 7回連続で失敗、8回目で`call-the-cops`
; gosh$ (define acc (make-account 100 'pass))
; acc
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 1
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 2
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 3
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 4
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 5
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 6
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 7
; gosh$ ((acc 'some-other-password 'deposit) 50)
; *** ERROR: call-the-cops
;
;;;;;;; 途中で成功するとcounterは0に戻る
; gosh$ (define acc (make-account 100 'pass))
; acc
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 1
; *** ERROR: Incorrect password
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 2
; *** ERROR: Incorrect password
; gosh$ ((acc 'pass 'deposit) 50)
; 150
; gosh$ ((acc 'some-other-password 'deposit) 50)
; access-counter 1
; *** ERROR: Incorrect password

; 3.1.2 代入を取り入れた利点

; randの実装
; https://boxnos.hatenablog.com/entry/20080422/1208863688
(define random-init 12345)
(define (rand-update x)
   (modulo (+ (* 214013 x) 253011) 32767))
(define rand
  (let ((x random-init))
    (lambda ()
      (set! x (rand-update x))
      x)))

; πの近似値
; πの近似値を得るには多数回の実験を行う.
; 各実験で二つの整数をランダムに選び、そのGCDが1かどうかのテストを行う.
; テストが成功した回数の比率が6/π^2の推定を与え, これからπの近似を得る。
(define (estimate-pi trials)
  (sqrt (/ 6 (monte-carlo trials cesaro-test))))

(define (cesaro-test)
  (= (gcd (rand) (rand)) 1))

(define (monte-carlo trials experiment)
  (define (iter trials-remaining trials-passed)
    (cond ((= trials-remaining 0)
           (/ trials-passed trials))
          ((experiment)
           (iter (- trials-remaining 1) (+ trials-passed 1)))
          (else
            (iter (- trials-remaining 1) trials-passed))))
  (iter trials 0))

; ex-3.5
(use srfi-27)
(define (random-in-range low high)
  (let ((range (- high low)))
    (+ low (random-integer range))))

(define (estimate-integral p x1 x2 y1 y2 trials)
  (*
    (monte-carlo trials (lambda () (p (random-in-range x1 x2) (random-in-range y1 y2))))
    (* (- x2 x1) (- y2 y1))))

; 面積と面積から算出した円周率piを表示する手続き
(define (pi-from-monte-carlo-simulation circle-area radius)
  ; (display circle-area)
  ; (newline)
  (/ circle-area radius))

; 中心(5, 7) 半径3 の円の場合
; テスト手続き
(define (p-test x y)
  (<= (+ (square (- x 5)) (square (- y 7))) (square 3)))

; (print (pi-from-monte-carlo-simulation (estimate-integral p-test 2 8 4 10 100000.0) (square 3)))
; 2.99488

; ex-3.6
(define rand
  (let ((x random-init))
    (define generate
      (lambda ()
        (set! x (rand-update x)) x))

    (define (reset new-value)
      (begin (set! x new-value) x))

    (define (dispatch m)
      ; (print "x " x)
      (cond ((eq? m 'generate) (generate))
            ((eq? m 'reset) reset)
            (else (error "Unknown requeset -- RAND" m))))
    dispatch))

; gosh$ (rand 'generate)
; x 12345
; 10917
; gosh$ (rand 'generate)
; x 10917
; 18162
; gosh$ ((rand 'reset) 100)
; x 18162
; 100
; gosh$ (rand 'generate)
; x 100
; 28091

; ex-3.7
(define (make-account balance my-password)
  (define (withdraw amount)
    (if (>= balance amount)
      (begin (set! balance (- balance amount))
             balance)
      "Insufficient funds"))

  (define (deposiot amount)
    (set! balance (+ balance amount))
    balance)

  (define (dispatch password m)
    (if (eq? my-password password)
      (cond ((eq? m 'withdraw) withdraw)
            ((eq? m 'deposit) deposiot)
            ((eq? m 'password?) #t)
            (else (error "Unknown request -- MAKE-ACCOUNT" m)))
      (error "Incorrect password")))
  dispatch)

(define (make-joint account account-password new-password)
  (define (dispatch password m)
    (if (and (account account-password 'password?) (eq? new-password password))
      (account account-password m)
      (error "Incorrect joint password")))
  dispatch)

(define peter-acc (make-account 100 'open-sesame))
(define paul-acc
 (make-joint peter-acc 'open-sesame 'rosebud))

; (print (peter-acc 'open-sesame 'password?))
; #t

; (print ((peter-acc 'open-sesame 'withdraw) 40))
; 60
; (print ((peter-acc 'open-sesame 'deposit) 50))
; 110
; (print ((paul-acc 'rosebud 'withdraw) 40))
; 70
; (print ((paul-acc 'rosebud 'deposit) 50))
; 120

; (print ((paul-acc 'rosebuda 'deposit) 50))
; Incorrect joint password
; (print ((peter-acc 'rosebuda 'withdraw) 40))
; Incorrect password

; ex-3.8
; 日本語が理解できぬ...

SICP 2.5 汎用演算のシステム

問題2.85で意図しない動作に。 修正しようにも1fileで雑に書き進めたので修正厳しいので2.85以降は飛ばすことに。

もうapply-genericええやろ...(疲労)

2週目、又は一旦全部終わったら2.4と2.5をやり直そうと思います。 1周目から完璧を求めると挫折するので妥協を...いやこれは妥協ではない、政治的妥結である(錯乱

そういえばググってget/putとかコピペして使えるようにしながら進めたけど、これ本来は「動かないコード」なんですよね... Try&Errorしないで脳内だけで進めるの、厳しすぎじゃないですか？(やれる人たち天才かよ...)

(load "./2.4.scm")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; https://sicp.sourceacademy.org/chapters/2.5.1.html
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

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

  ; ex-2.79追加
  (put 'equ? '(scheme-number scheme-number) =)
  ; ex-2.80追加
  (put 'zero? '(scheme-number)
       (lambda (x) (= x 0)))
  ; ex-2.81追加
  (put 'exp '(scheme-number scheme-number)
       (lambda (x y) (tag (expt x y))))

  ; ex-2.83追加
  (put 'raise '(scheme-number)
       (lambda (x) (make-rational x 1)))

  (put 'make 'scheme-number
       (lambda (x) (tag x)))

  'done)

(define (make-scheme-number n)
  ((get 'make 'scheme-number) n))

(define (install-rational-package)
  ;; internal procedures
  (define (numer x) (car x))
  (define (denom x) (cdr x))

  (define (make-rat n d)
    (print "make-rat " n d)
    (let ((g (gcd n d)))
      (cons (/ n g) (/ d g))))

  (define (add-rat x y)
    (make-rat (+ (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (sub-rat x y)
    (make-rat (- (* (numer x) (denom y))
                 (* (numer y) (denom x)))
              (* (denom x) (denom y))))
  (define (mul-rat x y)
    (make-rat (* (numer x) (numer y))
              (* (denom x) (denom y))))
  (define (div-rat x y)
    (make-rat (* (numer x) (denom y))
              (* (denom x) (numer y))))

  ; ex-2.79追加
  (define (equ? x y)
    (= (* (numer x) (denom y)) (* (numer y) (denom x))))
  ; ex-2.80追加
  (define (zero? x)
    (= 0 (numer x)))

  ; ex-2.83追加
  (define (raise-rat x)
    (make-real (/ (* (numer x) 1.0) (denom x))))

  ;; interface to rest of the system
  (define (tag x) (attach-tag 'rational x))
  (put 'add '(rational rational)
       (lambda (x y) (tag (add-rat x y))))
  (put 'sub '(rational rational)
       (lambda (x y) (tag (sub-rat x y))))
  (put 'mul '(rational rational)
       (lambda (x y) (tag (mul-rat x y))))
  (put 'div '(rational rational)
       (lambda (x y) (tag (div-rat x y))))

  ; ex-2.79追加
  (put 'equ? '(rational rational) equ?)
  ; ex-2.80追加
  (put 'zero? '(rational) zero?)
  ; ex-2.83追加
   (put 'raise '(rational)
       (lambda (x) (make-real (/ (* (numer x) 1.0) (denom x)))))
  ; (put 'raise '(rational)
  ;     (lambda (x) (raise-rat x)))

  ; ex-2.85追加
  (put 'project 'rational
       (lambda (x) (make-scheme-number (round (/ (numer x) (denom x))))))

  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

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


; ex-2.77
; (define z3 (make-complex-from-real-imag 1 2))
; (magnitude z3)
; apply-genericは2回呼び出される.
;
; * 最初にdefine z3が実行される
; * z3は(complex rectangular 1 . 2)になる
;
; * 2.4.scmのdefine magnitudeが実行される
;   * zは(complex rectangular 1 . 2)
; * apply-genericが呼び出される
; * proc実行されてcomplexタグのmagnitudeが呼び出される
; * complexのmagnitudeから2.4.scmで定義されたdefine magnitudeがもう一度呼び出される
;   * zは(rectangular 1 . 2)
; * apply-genericが呼び出される
; * proc実行されてrectangularタグのmagnitudeが呼び出される
; * rectangularのmagnitudeが実行されて計算される

(define (install-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ; (print "complex make-from-real-imag")
    ((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))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))

  ; ex-2.79追加
   (define (equ? x y)
     (and (= (real-part x) (real-part y)) (= (imag-part x) (imag-part y))))
  ; ex-2.80追加
   (define (zero? x)
     (and (= (real-part x) 0) (= (imag-part x) 0)))

  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))

  ; ex-2.77追加
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)

  ; ex-2.79追加
  (put 'equ? '(complex complex) equ?)

  ; ex-2.80追加
  (put 'zero? '(complex) zero?)

  ; ex-2.85追加
  (put 'project 'complex
       (lambda (x) (make-real (real-part x))))

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

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

(install-scheme-number-package)
(install-rational-package)
(install-complex-package)

; (define z3 (make-complex-from-real-imag 1 2))
; (print z3)
; (print "****************************")
; (print (magnitude z3))

; ex-2.78
(define (attach-tag type-tag contents)
  (if (eq? type-tag 'scheme-number)
    contents
    (cons type-tag contents)))

(define (type-tag datum)
  (cond ((number? datum) 'scheme-number)
        ((pair? datum) (car datum))
        (else "Bad tagged datum -- TYPE-TAG" datum)))

(define (contents datum)
  (cond ((number? datum) datum)
        ((pair? datum) (cdr datum))
        (else "Bad tagged datum - CONTENTS" datum)))

; ex-2.79
(define (equ? x y) (apply-generic 'equ? x y))

#|
(define sn1 (make-scheme-number 1))
(define sn2 (make-scheme-number 3))
(define sn3 (make-scheme-number 3))
(print (equ? sn1 sn2))
(print (equ? sn2 sn3))

(define r1 (make-rational 1 2))
(define r2 (make-rational 1 1))
(define r3 (make-rational 1 1))
(print (equ? r1 r2))
(print (equ? r2 r3))

(define c1 (make-complex-from-real-imag 1 2))
(define c2 (make-complex-from-real-imag 1 1))
(define c3 (make-complex-from-real-imag 1 1))
(print (equ? c1 c2))
(print (equ? c2 c3))

; ex-2.80

(define (zero? x) (apply-generic 'zero? x))
(define sn1 (make-scheme-number 1))
(define sn2 (make-scheme-number 0))
(print (zero? sn1))
(print (zero? sn2))

(define r1 (make-rational 1 0))
(define r2 (make-rational 0 2))
(print (zero? r1))
(print (zero? r2))

(define c1 (make-complex-from-real-imag 1 0))
(define c2 (make-complex-from-real-imag 0 1))
(define c3 (make-complex-from-real-imag 0 0))
(print (zero? c1))
(print (zero? c2))
(print (zero? c3))
|#

; 2.5.2 異なる型のデータの統合
(define (add-complex-to-schemenum z x)
  (make-from-real-imag (+ (real-part z) x)
                       (imag-part z)))

(put 'add '(complex scheme-number)
     (lambda (z x) (tag (add-complex-to-schemenum z x))))

(define (scheme-number->complex n)
  (make-complex-from-real-imag (contents n) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; put-coercion,get-coercion for SICP 2.5.2
; https://gist.github.com/kinoshita-lab/b76a55759a0d0968cd97
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define coercion-list '())

(define (clear-coercion-list)
  (set! coercion-list '()))

(define (put-coercion type1 type2 item)
  (if (get-coercion type1 type2) coercion-list
    (set! coercion-list
      (cons (list type1 type2 item)
            coercion-list))))

(define (get-coercion type1 type2)
  (define (get-type1 listItem)
    (car listItem))
  (define (get-type2 listItem)
    (cadr listItem))
  (define (get-item listItem)
    (caddr listItem))
  (define (get-coercion-iter list type1 type2)
    (if (null? list) #f
      (let ((top (car list)))
        (if (and (equal? type1 (get-type1 top))
                 (equal? type2 (get-type2 top))) (get-item top)
          (get-coercion-iter (cdr list) type1 type2)))))
  (get-coercion-iter coercion-list type1 type2))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(put-coercion 'scheme-number 'complex scheme-number->complex)

(define (apply-generic op . args)
  ; (print op)
  ; (print args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      ; (print proc)
      (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)))
              ; (print t1->t2)
              ; (print t2->t)
              (cond (t1->t2
                      ; (print "hoge")
                      (apply-generic op (t1->t2 a1) a2))
                    (t2->t1
                      ; (print "fuga")
                      (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)))))))

; ex-2.81
(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)
(define (exp x y) (apply-generic 'exp x y))

; a.
(define c1 (make-complex-from-real-imag 1 2))
(define c2 (make-complex-from-real-imag 1 1))
; (exp c1 c2)
; procが常に#fなので無限ループに陥る

; b.
; 正しくない, このままだと動かない

; c.
(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)))
            (if (eq? type1 type2) ; 追加
              (error "eq type1 type2") ; 追加
              (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)))))))

; (exp c1 c2)
; *** ERROR: eq type1 type2

; ex-2.82
(define (apply-generic op . args)
  (define (coercion args my-type)
    (if (null? args)
      ()
      (let ((a1 (car args)))
        (let ((t2->t1 (get-coercion (type-tag a1) my-type)))
          ; (print "t2->t1 " t2->t1)
          (if t2->t1
            (cons (t2->t1 a1) (coercion (cdr args) my-type))
            (cons a1 (coercion (cdr args) my-type)))))))

  (define (search types)
    ; (print "---------------------------")
    (let ((my-type (car types)))
      ; (print my-type)
      (let ((my-args (coercion args my-type)))
        ; (print "my-args " my-args)
        (let ((proc (get op (map type-tag my-args))))
          ; (print "proc " proc)
          (if proc
            (apply proc (map contents my-args))
            (search (cdr types)))))))

  ; (print "types" (map type-tag args))
  (search (map type-tag args)))

(put 'add '(scheme-number scheme-number scheme-number)
     (lambda (x y z) (+ x y z)))

(put 'add '(complex complex complex)
     (lambda (x y z) (add (add (cons 'complex x)
                               (cons 'complex y))
                          (cons 'complex z))))

(define (add . args)
  (apply apply-generic (cons 'add args)))

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

(put-coercion 'scheme-number 'complex scheme-number->complex)

; (print (add z 2 2))
; (complex rectangular 7 . 4)

; ex-2.83
(define (raise x) (apply-generic 'raise x))

;; 実数算術演算パッケージ
(define (install-real-package)
  (define (tag x)
    (print "real-tag")
    (attach-tag 'real x))
  (put 'add '(real real)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real real)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real real)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real real)
       (lambda (x y) (tag (/ x y))))
  (put 'equ? '(real real)
       (lambda (x y) (= x y)))
  (put '=zero? '(real)
       (lambda (x) (= x 0.0)))
  (put 'make 'real
       (lambda (x) (tag x)))


  (put 'raise '(real)
       (lambda (x) (make-complex-from-real-imag x 0)))

  ; ex-2.85追加
  (put 'project 'real
       (lambda (x)
         (let ((rat (rationalize
                      (inexact->exact x) 1/100)))
           (make-rational
             (numerator rat)
             (denominator rat)))))

  'done)

(define (make-real n)
  ((get 'make 'real) n))

(install-real-package)

; (print (raise 1))
; (print (raise (make-rational 1 2)))
; (print (raise (make-real 1.5)))

; (define i 2)
; (print (raise i))
; (print (raise (raise i)))
; (print (raise (raise (raise i))))

; ex-2.84
(define (higher-type x y)
  (let ((tower '(complex real rational scheme-number))) ;; 型の塔
    (define (iter twr)
      (if (null? twr)
        #f
        (cond ((eq? x (car twr)) x)
              ((eq? y (car twr)) y)
              (else (iter (cdr twr))))))
    (iter tower)))

(define (coerce-higher-type items)
  (let ((item1 (car items))
        (item2 (cadr items)))
    (let ((type1 (type-tag item1))
          (type2 (type-tag item2)))
      (if (eq? type1 type2)
        items
        (let ((tag (higher-type type1 type2)))
          (if (eq? tag type1)
            (coerce-higher-type (list item1 (raise item2)))
            (coerce-higher-type (list (raise item1) item2))))))))

(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)))
            (if (eq? type1 type2)
              (error "E1. No method for these types" (list op type-tags))
              (let ((coerced-args (coerce-higher-type args)))
                (let ((proc (get op (map type-tag coerced-args))))
                  (if proc
                    (apply proc (map contents coerced-args))
                    (error "E2.No method for these types" (list op type-tags)))))))
          (error "E3. No method for these types" (list op type-tags)))))))

; ex-2.85
(define (drop x)
  (print "******************************")
  (print "*******drop " x)
  (let ((project-proc (get 'project (type-tag x))))
    (if project-proc
      (let ((project-number (project-proc (contents x))))
        (print "project-number " project-number)
        (print "raise-project-number " (raise project-number))

        (if (equ? project-number (raise project-number))
          (drop project-number)
          x))
      x)))

(define (apply-generic op . args)
  (print "**********apply " op args)

  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (print "proc " proc)
      (if proc
        ; (apply proc (map contents args)) ;; drop
        (drop (apply proc (map contents args))) ;; drop
        (if (= (length args) 2)
          (let ((type1 (car type-tags))
                (type2 (cadr type-tags)))
            (if (eq? type1 type2)
              (error "E1. No method for these types" (list op type-tags))
              (let ((coerced-args (coerce-higher-type args)))
                (let ((proc (get op (map type-tag coerced-args))))
                  (if proc
                    (drop (apply proc (map contents coerced-args))) ;; drop
                    (error "E2.No method for these types" (list op type-tags)))))))
          (error "E3. No method for these types" (list op type-tags)))))))

(define rat (make-rational 2 4))
(define rel (make-real 3.0))
(define cpx (make-complex-from-real-imag 2 0))

; (print (drop rat))
; (print (drop cpx))
; (print (add rat rel))
; (print (add cpx rel))

; the tower
; raise ↑
; project ↓
;
; 複素数(complex)
; ↑
; 実数(real)
; ↑
; 有理数(rational)
; ↑
; 整数(scheme-number)

SICP 2.4 抽象データの多重表現

get,putが出てきてから動かせなくてしんどくなり、apply-genericで混乱したので色々検索。

github.com

ここで3.3.3のget,putの実装を載せてくれていたので動かしながら理解することが出来て助かりました。

; 2.4.1  複素数の表現
(define (add-complex z1 z2)
  (make-from-real-imag (+ (real-part z1) (real-part z2))
                       (+ (imag-part z1) (imag-part z2))))

(define (sub-complex z1 z2)
  (make-from-real-imag (- (real-part z1) (real-part z2))
                       (- (imag-part z1) (imag-part z2))))

(define (mul-complex z1 z2)
  (make-from-real-imag (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))

(define (div-complex z1 z2)
  (make-from-real-imag (/ (magnitude z1) (magnitude z2))
                       (- (angle z1) (angle z2))))

; Ben
; 直交座標形式での表現
(define (real-part z) (car z))

(define (imag-part z) (cdr z))

(define (magnitude z)
  (sqrt (+ (square (real-part z)) (square (imag-part z)))))

(define (angle z)
  (atan (imag-part z) (real-part z)))

; これがz
(define (make-from-real-imag x y) (cons x y))

; これがz
(define (make-from-mag-ang r a)
  (cons (* r (cos a)) (* r (sin a))))

; (print (magnitude (make-from-real-imag 1 2)))
; 2.23606797749979
;
; (print (magnitude (make-from-mag-ang 2 3)))
; 1.9999999999999998

; Alyssa
; 極座標形式
(define (real-part z)
  (* (magnitude z) (cos (angle z))))

(define (imag-part z)
  (* (magnitude z) (sin (angle z))))

(define (magnitude z) (car z))

(define (angle z) (cdr z))

(define (make-from-real-imag x y)
  (cons (sqrt (+ (square x) (square y)))
        (atan x y)))

(define (make-from-mag-ang r a) (cons r a))

; (print (magnitude (make-from-real-imag 1 2)))
; 2.23606797749979

; (print (magnitude (make-from-mag-ang 2 3)))
; 2

; 2.4.2 タグつきデータ

(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 (rectangular? z)
  (eq? (type-tag z) 'rectangular))

; 極座標形式
(define (polar? z)
  (eq? (type-tag z) 'polar))

; Benの改訂版直交座標表現
(define (real-part-rectangular z) (car z))

(define (imag-part-rectangular z) (cdr z))

(define (magnitude-rectangular z)
  (sqrt (+ (square (real-part-rectangular z))
           (square (imag-part-rectangular z)))))

(define (angle-rectangular z)
  (atan (imag-part-rectangular z)
        (real-part-rectangular z)))

(define (make-from-real-imag-rectangular x y)
  (attach-tag 'rectangular (cons x y)))

(define (make-from-mag-ang-rectangular r a)
  (attach-tag 'rectangular
              (cons (* r (cos a)) (* r (sin a)))))

; Alyssaの改訂版極座標表現
(define (real-part-polar z)
  (* (magnitude-polar z) (cos (angle-polar z))))

(define (imag-part-polar z)
  (* (magnitude-polar z) (sin (angle-polar z))))

(define (magnitude-polar z) (car z))

(define (angle-polar z) (cdr z))

(define (make-from-real-imag-polar x y)
  (attach-tag 'polar
              (cons (sqrt (+ (square x) (square y)))
                    (atan y x))))

(define (make-from-mag-ang-polar r a)
  (attach-tag 'polar (cons r a)))

;;;;;;;;;;;

(define (real-part z)
  (cond ((rectangular? z)
         (real-part-rectangular (contents z)))
        ((polar? z)
         (real-part-polar (contents z)))
        (else (error "Unknown type -- REAL-PART" z))))

(define (imag-part z)
  (cond ((rectangular? z)
         (imag-part-rectangular (contents z)))
        ((polar? z)
         (imag-part-polar (contents z)))
        (else (error "Unknown type -- IMAG-PART" z))))

(define (magnitude z)
  (cond ((rectangular? z)
         (magnitude-rectangular (contents z)))
        ((polar? z)
         (magnitude-polar (contents z)))
        (else (error "Unknown type -- MAGNITUDE" z))))

(define (angle z)
  (cond ((rectangular? z)
         (angle-rectangular (contents z)))
        ((polar? z)
         (angle-polar (contents z)))
        (else (error "Unknown type -- ANGLE" z))))

(define (add-complex z1 z2)
  (make-from-real-imag (+ (real-part z1) (real-part z2))
                       (+ (imag-part z1) (imag-part z2))))

; 最期に複素数を構成するのにBenの表現を使うかAlyssaの表現を使うか決めなければならない。
; 1つの合理的な決め方は実部と虚部があれば直交座標数を構成し、絶対値と偏角があれば極座標数を構成することだ.
(define (make-from-real-imag x y)
  (make-from-real-imag-rectangular x y))

(define (make-from-mag-ang r a)
  (make-from-mag-ang-polar r a))

; (print (magnitude (make-from-real-imag 1 2)))
; 2.23606797749979

; (print (magnitude (make-from-mag-ang 2 3)))
; 2

; 2.4.3 データ主導プログラミングと加法性

; get/putは言語に組み込まれていると仮定 => 今の段階では動かない
; 3.3.3で実装するらしい.

; 2.4.3では実行してないが、実際には
; (install-rectangular-package)
; (install-polar-package)
; の様に実行する必要がある.

(define (install-rectangular-package)
  ;; internal procedures
  (define (real-part z) (car z))
  (define (imag-part z) (cdr z))
  (define (make-from-real-imag x y) (cons x y))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-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)

(define (install-polar-package)
  ;; internal procedures
  (define (magnitude z) (car z))
  (define (angle z) (cdr z))
  (define (make-from-mag-ang r a) (cons r a))
  (define (real-part z)
    (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))

  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

; (magnitude z1)
(define (apply-generic op . args)
  (print op) ; magnitude
  (print args) ; ((rectangular 1 . 2))
  (let ((type-tags (map type-tag args)))
    (print type-tags) ; (rectangular)
    (let ((proc (get op type-tags)))
      (print proc) ; #<closure ((install-rectangular-package magnitude) z)>
      (print (map contents args)) ; ((1 . 2))
      (if proc
        ; (())リストになっているのでapplyしている
        (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 (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))

; ch2support.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------
;;;from section 3.3.3 for section 2.4.3
;;; to support operation/type table for data-directed dispatch

(define (assoc key records)
  (cond ((null? records) #f)
        ((equal? key (caar records)) (car records))
        (else (assoc key (cdr records)))))

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

;;;-----------

(install-rectangular-package) ; don't forget! otherwise "the object #f is not applicable"
(install-polar-package)

(define z1 (make-from-real-imag 1 2))
(define z2 (make-from-mag-ang 2 3))
(print (magnitude z1))
; 2.23606797749979
; (print (imag-part z2))
; 0.2822400161197344

; ex-2.75
(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 'mgnitude) r)
          ((eq? op 'angle) a)
          (else (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)