Scheme - データによる抽象の構築(記号データ(例: 集合の表現(二進木としての集合、釣り合った二進木, 和集合, 共通部分)))

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

開発環境

• OS X Yosemite - Apple (OS)
• Emacs(Text Editor)
• Scheme (プログラミング言語)
• kscheme, Gauche (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.3(記号データ)、2.3.3(例: 集合の表現)、問題2.65.を解いてみる。

その他参考書籍

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

問題2.65.

コード(Emacs)

(define equal?
  (lambda (a b)
    (if (and (pair? a) (pair? b))
        (and (eq? (car a) (car b))
             (equal? (cdr a) (cdr b)))
        (eq? a b))))
(define entry (lambda (tree) (car tree)))
(define left-branch (lambda (tree) (cadr tree)))
(define right-branch (lambda (tree) (caddr tree)))
(define make-tree
  (lambda (entry left right)
    (list entry left right)))

(define tree->list
  (lambda (tree)
    (define copy-to-list
      (lambda (tree result-list)
        (if (null? tree)
            result-list
            (copy-to-list (left-branch tree)
                          (cons (entry tree)
                                (copy-to-list (right-branch tree)
                                              result-list))))))
    (copy-to-list tree (quote ()))))

(define list->tree
  (lambda (elements)
    (car (partial-tree elements (length elements)))))

(define partial-tree
  (lambda (elts n)
    (if (= n 0)
        (cons (quote ()) elts)
        (let ((left-size (quotient (- n 1) 2)))
          (let ((left-result (partial-tree elts left-size)))
            (let ((left-tree (car left-result))
                  (non-left-elts (cdr left-result))
                  (right-size (- n (+ left-size 1))))
              (let ((this-entry (car non-left-elts))
                    (right-result (partial-tree (cdr non-left-elts)
                                                right-size)))
                (let ((right-tree (car right-result))
                      (remaining-elts (cdr right-result)))
                  (cons (make-tree this-entry left-tree right-tree)
                        remaining-elts)))))))))


(define union-set
  (lambda (set1 set2)
    (define sorted-list
      (lambda (list1 list2)
        (cond ((null? list1) list2)
              ((null? list2) list1)
              ((< (car list1)
                  (car list2))
               (cons (car list1)
                     (sorted-list (cdr list1)
                                  list2)))
              ((= (car list1)
                  (car list2))
               (cons (car list1)
                     (sorted-list (cdr list1)
                                  (cdr list2))))
              ((> (car list1)
                  (car list2))
               (cons (car list2)
                     (sorted-list list1
                                  (cdr list2)))))))
    
    (let ((list1 (tree->list set1))
          (list2 (tree->list set2)))
      (list->tree (sorted-list list1 list2)))))

(define intersection-set  
  (lambda (set1 set2)
    (define element-of-set?
      (lambda (x set)
        (cond ((null? set) #f)
              ((equal? x (car set)) #t)
              (else (element-of-set? x (cdr set))))))
    (define intersection-list
      (lambda (set1 set2)
        (cond ((or (null? set1) (null? set2)) (quote ()))
              ((element-of-set? (car set1) set2)
               (cons (car set1)
                     (intersection-list (cdr set1) set2)))
              (else
               (intersection-list (cdr set1) set2)))))        
    (let ((list1 (tree->list set1))
          (list2 (tree->list set2)))
      (list->tree (intersection-list list1
                                     list2)))))

(define set1 (list->tree (list 1 3 5 7 9)))
(define set2 (list->tree (list 2 4 6 8 10)))
(define set3 (list->tree (list 1 2 3 4 5)))
(define set4 (list->tree (list 6 7 8 9 10)))
(define set5 (list->tree (list 1 2 3 4 5 6 7 8 9 10)))

(define print (lambda (x) (display x) (newline)))
(define for-each
  (lambda (proc items)
    (if (not (null? items))
        (begin (proc (car items))
               (for-each proc (cdr items)))
        'done)))

(begin (newline)
       (for-each (lambda (set)
                   (print set))
                 (list (union-set set1 set2)
                       (union-set set1 set3)
                       (union-set set1 set4)
                       (union-set set1 set5)
                       (intersection-set set1 set2)
                       (intersection-set set1 set3)
                       (intersection-set set1 set4)
                       (intersection-set set1 set5))))

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

$ kscheme  < sample65.scm
kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> kscm> 
(5 (2 (1 () ()) (3 () (4 () ()))) (8 (6 () (7 () ())) (9 () (10 () ()))))
(4 (2 (1 () ()) (3 () ())) (7 (5 () ()) (9 () ())))
(6 (3 (1 () ()) (5 () ())) (8 (7 () ()) (9 () (10 () ()))))
(5 (2 (1 () ()) (3 () (4 () ()))) (8 (6 () (7 () ())) (9 () (10 () ()))))
()
(3 (1 () ()) (5 () ()))
(7 () (9 () ()))
(5 (1 () (3 () ())) (7 () (9 () ())))
done
kscm> $