Scheme - 標準部品化力、オブジェクトおよび状態(可変データでのモデル化(表の表現(二次元の表(局所表の作り方(一般化)))))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

• OS X Mavericks - Apple(OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• Scheme (プログラミング言語)
• Gauche (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の3(標準部品化力、オブジェクトおよび状態)、3.3(可変データでのモデル化)、3.3.3(表の表現)、二次元の表、局所表の作り方、問題 3.25.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)

問題 3.25.

コード(BBEdit, Emacs)

table2.scm

;; -*- coding: utf-8 -*-

(define (make-table)
  (define (same-key? key-1 key-2) (equal? key-1 key-2))
  
  (let ((local-table (list '*table*)))
    (define (lookup keys)
      (define (iter key keys table)
        (if (null? keys)
            (let ((record (assoc key (cdr table))))
              (if record
                  (cdr record)
                  #f))
            (let ((subtable (assoc key (cdr table))))
              (if subtable
                  (iter (car keys) (cdr keys) subtable)
                  #f))))
      (if (null? keys)
          #f
          (iter (car keys) (cdr keys) local-table)))
    (define (insert! keys value)
      (define (iter key keys table)
        (if (null? keys)
            (let ((record (assoc key (cdr table))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! table
                            (cons (cons key value)
                                  (cdr table)))))
            (let ((subtable (assoc key (cdr table))))
              (if subtable
                  (iter (car keys) (cdr keys) subtable)
                  (begin (set-cdr! table
                                   (cons (list key)
                                         (cdr table)))
                         (iter (car keys)
                               (cdr keys)
                               (cadr table)))))))
      (iter (car keys) (cdr keys) local-table)
      'ok)
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unkown operation -- TABLE" m))))
    dispatch))

sample3_25.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(load "./table.scm")

(print "一次元")
(define t1 (make-table))

(for-each (lambda (p)
            (print ((t1 'insert-proc!) (list (car p)) (cdr p)))) ; ok
          (list (cons 1 'a)
                (cons 3 'b)
                (cons 5 'c)
                (cons 7 'd)
                (cons 9 'e)))

(for-each (lambda (key)
            (display key)
            (display ": ")
            (print ((t1 'lookup-proc) (list key))))
          (list 1 2 3 4 5 6 7 8 9 10))

(for-each (lambda (p)
            (print ((t1 'insert-proc!) (list (car p)) (cdr p)))) ; ok
          (list (cons 1 'f)
                (cons 3 'g)
                (cons 5 'h)
                (cons 7 'i)
                (cons 9 'j)))

(for-each (lambda (key)
            (display key)
            (display ": ")
            (print ((t1 'lookup-proc) (list key))))
          (list 1 2 3 4 5 6 7 8 9 10))

(print "二次元")
(define t2 (make-table))

(for-each (lambda (p)
            (print ((t2 'insert-proc!) (car p) (cdr p)))) ; ok
          (list (cons (list 1 1) 'a)
                (cons (list 1 3) 'b)
                (cons (list 2 2) 'c)
                (cons (list 2 4) 'd)))

(for-each (lambda (keys)
            (display keys)
            (display ": ")
            (print ((t2 'lookup-proc) keys)))
          (list (list 1 1)
                (list 1 2)
                (list 1 3)
                (list 1 4)
                (list 2 1)
                (list 2 2)
                (list 2 3)
                (list 2 4)))

(for-each (lambda (p)
            (print ((t2 'insert-proc!) (car p) (cdr p)))) ; ok
          (list (cons (list 1 1) 'e)
                (cons (list 1 3) 'f)
                (cons (list 2 2) 'g)
                (cons (list 2 4) 'h)))

(for-each (lambda (keys)
            (display keys)
            (display ": ")
            (print ((t2 'lookup-proc) keys)))
          (list (list 1 1)
                (list 1 2)
                (list 1 3)
                (list 1 4)
                (list 2 1)
                (list 2 2)
                (list 2 3)
                (list 2 4)))

(for-each (lambda (p)
            (print ((t2 'insert-proc!) (car p) (cdr p)))) ; ok
          (list (cons (list 10) 'i)
                (cons (list 20) 'j)
                (cons (list 30) 'k)
                (cons (list 40) 'l)
                (cons (list 50) 'm)))

(for-each (lambda (keys)
            (display keys)
            (display ": ")
            (print ((t2 'lookup-proc) keys)))
          (list (list 1 1)
                (list 1 2)
                (list 1 3)
                (list 1 4)
                (list 2 1)
                (list 2 2)
                (list 2 3)
                (list 2 4)
                (list 10)
                (list 20)
                (list 30)
                (list 40)
                (list 50)
                (list 60)
                (list 70)
                (list 80)
                (list 90)
                (list 100)))

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample3_25.scm
一次元
ok
ok
ok
ok
ok
1: a
2: #f
3: b
4: #f
5: c
6: #f
7: d
8: #f
9: e
10: #f
ok
ok
ok
ok
ok
1: f
2: #f
3: g
4: #f
5: h
6: #f
7: i
8: #f
9: j
10: #f
二次元
ok
ok
ok
ok
(1 1): a
(1 2): #f
(1 3): b
(1 4): #f
(2 1): #f
(2 2): c
(2 3): #f
(2 4): d
ok
ok
ok
ok
(1 1): e
(1 2): #f
(1 3): f
(1 4): #f
(2 1): #f
(2 2): g
(2 3): #f
(2 4): h
ok
ok
ok
ok
ok
(1 1): e
(1 2): #f
(1 3): f
(1 4): #f
(2 1): #f
(2 2): g
(2 3): #f
(2 4): h
(10): i
(20): j
(30): k
(40): l
(50): m
(60): #f
(70): #f
(80): #f
(90): #f
(100): #f
$