Scheme - 超言語的抽象(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))の4(超言語的抽象)、4.3(Schemeの変形 - 非決定性計算)、4.3.3(非決定性プログラムの例)、論理パズル、問題 4.43.を解いてみる。

その他参考書籍

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

問題 4.43.

コード(BBEdit, Emacs)

sample43.scm

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

(define require
  (lambda (p)
    (if (not p) (amb))))

;; 効率性を考えない手続き
(define (yachts)
  ;; 父親: (娘 ヨットの名前)
  (let ((moore (list (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)
                     (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)))
        (downing (list (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)
                       (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)))
        (hall (list (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)
                    (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)))
        (barnacle (list (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)
                        (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)))
        (parker (list (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa)
                      (amb 'mary 'gabrielle 'lorna 'rosalind 'melissa))))
    ;; Mary の父親は Moore
    (require (eq? (car moore) 'mary))
    (require (not (eq? (cadr moore) 'mary)))
    ;; Barnacle のヨットは Gabrielle
    (require (eq? (cadr barnacle) 'gabrielle))
    (require (not (eq? (car barnacle) 'gabrielle)))
    ;; Moore のヨットは Lorna
    (require (eq? (cadr moore) 'lorna))
    (require (not (eq? (car moore) 'lorna)))
    ;; Hall のヨットは Rosalind
    (require (eq? (cadr hall) 'rosalind))
    (require (not (eq? (car hall) 'rosalind)))
    ;; Downing のヨットは Melissa
    (require (eq? (cadr downing) 'melissa))
    (require (not (eq? (car downing) 'melissa)))
    ;; Barnacle の娘は Melissa
    (require (eq? (car Barnacle) 'melissa))
    ;; Gabrielle の父親
    (let ((gabrielle (amb moore downing hall barnacle parker)))
      (require (eq? (car gabrielle) 'gabrielle))
      (require (eq? (cadr gabrielle) (car parker)))
      (list (list 'moore moore)
            (list 'downing downing)
            (list 'hall hall)
            (list 'barnacle barnacle)
            (list 'parker parker)))))

;; 効率よく走るプログラム
(define (distinct? items)
  (cond ((null? items) #t)
        ((null? (cdr items)) #t)
        ((member (car items) (cdr items)) #f)
        (else (distinct? (cdr items)))))

(define (yachts-fast)
  (let ((moore (list 'mary 'lorna))
        (barnacle (list 'melissa 'gabrielle))
        (hall (list (amb 'gabrielle 'lorna)
                    'rosalind))
        (downing (list (amb 'gabrielle 'lorna 'rosalind)
                       'melissa)))
    (require? (not (distinct? (map car
                                   (list hall downing)))))
    (let ((parker (list (amb 'gabrielle 'lorna 'rosalind)
                        'mary)))
      (require (distinct? (map car (list hall
                                         downing
                                         parker))))
      (let ((gabrielle (amb barnacle hall downing parker)))
        (require (eq? (car gabrielle) 'gabrielle))
        (require (eq? (cadr gabrielle) (car parker)))
        (list (list 'moore moore)
              (list 'downing downing)
              (list 'hall hall)
              (list 'barnacle barnacle)
              (list 'parker parker))))))

;; Mary Ann の姓が Moore だといわれなかった場合
(define (yachts1)
  (let ((barnacle (list 'melissa 'gabrielle))
        (moore (list (amb 'mary 'gabrielle 'rosalind)
                     'lorna))
        (hall (list (amb 'mary 'gabrielle 'lorna)
                    'rosalind)))
    (require (distinct? (map car
                             (list moore hall))))
    (let ((parker (list (amb 'gabrielle 'lorna 'rosalind)
                        'mary)))
      (require (distinct? (map car
                               (list moore hall parker)))
      (let ((downing (list (amb 'mary 'gabrielle 'lorna 'rosalind)
                           'melissa)))
        (require (distinct? (map car
                                 (list moore hall parker downing))))
        (let ((gabrielle (amb moore hall parker downing)))
          (require (eq? (car gabrielle) 'gabrielle))
          (require (eq? (cadr gabrielle) (car parker)))
          (list (list 'moore moore)
                (list 'downing downing)
                (list 'hall hall)
                (list 'barnacle barnacle)
                (list 'parker parker))))))))

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

$ ./sample43.scm
$