Scheme - データによる抽象の構築(階層データ構造と閉包性(階層構造(二進モービル、釣り合っているかテストする述語)))

計算機プログラムの構造と解釈
Gerald Jay Sussman, Julie Sussman
Harold Abelson (原著) 和田 英一 (翻訳)

開発環境

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

計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.2(階層データ構造と閉包性)、2.2.2(階層構造)、問題 2.29-c.を解いてみる。

その他参考書籍

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

問題 2.29-c.

コード(BBEdit, Emacs)

sample.scm

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

;; 二進モービル
;; 構成子
(define (make-mobile left right)
  (list left right))

(define (make-branch length structure)
  (list length structure))

;; 選択子
(define (left-branch mobile)
  (car mobile))

(define (right-branch mobile)
  (car (cdr mobile)))

(define (branch-length branch)
  (car branch))

(define (branch-structure branch)
  (cadr branch))

(define (total-weight mobile)
  (define (branch-weight branch weight)
    ((lambda (structure)
       (if (number? structure)
           (+ weight structure)
           (+ weight
              (total-weight structure))))
     (branch-structure branch)))
  (+ (branch-weight (left-branch mobile) 0)
     (branch-weight (right-branch mobile) 0)))

(define (balanced? mobile)
  (let ((left (left-branch mobile))
        (right (right-branch mobile)))
    (let ((left-length (branch-length left))
          (right-length (branch-length right))
          (left-structure (branch-structure left))
          (right-structure (branch-structure right)))
      (cond ((and (number? left-structure)
                  (number? right-structure))
             (= (* left-length left-structure)
                (* right-length right-structure)))
            ((and (number? left-structure)
                  (not (number? right-structure)))
             (and (= (* left-length left-structure)
                     (* right-length
                        (total-weight right-structure)))
                  (balanced? right-structure)))
            ((number? right-structure)
             (and (= (* left-length
                        (total-weight left-structure))
                     (* right-length right-structure))
                  (balanced? left-structure)))
            (else
             (and (= (* left-length
                        (total-weight left-structure))
                     (* right-length
                        (total-weight right-structure)))
                  (balanced? left-structure)
                  (balanced? right-structure)))))))


(define b1 (make-branch 1 2))
(define b2 (make-branch 2 1))
(define b3 (make-branch 3 4))
(define b4 (make-branch 4 3))
(define m1 (make-mobile b1 b2))
(define m2 (make-mobile b2 b1))
(define m3 (make-mobile b3 b4))
(define m4 (make-mobile b4 b3))
(define m5 (make-mobile b1 b4))
(define m6 (make-mobile b4
                        (make-branch 2
                                     (make-mobile (make-branch 20
                                                               2)
                                                  (make-branch 10
                                                               4)))))

(for-each (lambda (mobile)
            (print mobile ": " (balanced? mobile)))
          (list m1 m2 m3 m4 m5 m6))

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

$ ./sample.scm
((1 2) (2 1)): #t
((2 1) (1 2)): #t
((3 4) (4 3)): #t
((4 3) (3 4)): #t
((1 2) (4 3)): #f
((4 3) (2 ((20 2) (10 4)))): #t
$