アパート問題をSchemeで

素直なプログラム

昨日Prologで書いたアパート問題をSchemeに翻訳してみる．

最初はいちばん素直なプログラム．このRubyプログラムをほぼ忠実に翻訳したものだ．使用処理系はGauche．

(use gauche.time)
(use srfi-1)
(load "./nd.scm")

(define-syntax name-value
  (syntax-rules ()
    ((_ n ...) (list (cons 'n n) ...))))

(define (solve)
  (let* ((floor (iota 5 1))
         (baker (choose floor))
         (cooper (choose floor))
         (fletcher (choose floor))
         (miller (choose floor))
         (smith (choose floor))
         (answer (name-value baker cooper fletcher miller smith)))
    (assert (lset= = floor (map cdr answer)))
    (assert (not (= baker 5)))
    (assert (not (= cooper 1)))
    (assert (and (not (= fletcher 5)) (not (= fletcher 1))))
    (assert (> miller cooper))
    (assert (not (= 1 (abs (- smith fletcher)))))
    (assert (not (= 1 (abs (- cooper fletcher)))))
    answer))

(define (main args)
  (time (print (solve))))

ただし，nd.scmはOn Lispのchooseとfailを少しだけ書き換えてassertを足したもので，内容はこうなっている．

(define *paths* '())

(define (choose l)
  (if (null? l)
      (fail)
      (let/cc k
              (set! *paths* (cons (lambda () (k (choose (cdr l)))) *paths*))
              (car l))))

(define fail #f)
(let/cc k
        (set! fail (lambda ()
                     (if (null? *paths*)
                         (k #f)
                         (let ((p1 (car *paths*)))
                           (set! *paths* (cdr *paths*))
                           (p1))))))

(define (assert e) (unless e (fail)))

実行結果は次のとおり．

((baker . 3) (cooper . 2) (fletcher . 4) (miller . 5) (smith . 1))
;(time (print (solve)))
; real   0.156
; user   0.141
; sys    0.000

伝統的マクロがよくわからない

少し脱線するが，先のプログラムで，結果をわかりやすく表示するために健全なマクロで定義したname-valueを，define-macroで定義しようとしたら，さっぱりわからない…．どなたか教えてくれるとすごく嬉しいです．

階の割り当ての間に制約を挟む

住人ひとりずつに階を割り当てながら制約条件をチェックするようにsolveを書き直したのが次のプログラム．letがどんどん深くなるのがいやな感じ．これならProlog版の方が簡潔で見やすいな．

(define (solve)
  (let ((baker (choose '(1 2 3 4))))
    (assert (not (= baker 5)))
    (let ((cooper (choose '(2 3 4))))
      (assert (not (= cooper 1)))
      (let ((fletcher (choose '(2 3 4))))
        (assert (and (not (= fletcher 5)) (not (= fletcher 1))))
        (assert (not (= 1 (abs (- cooper fletcher)))))
        (let ((miller (choose '(2 3 4 5))))
          (assert (> miller cooper))
          (let* ((smith (choose '(1 2 3 4 5)))
                 (answer (name-value baker cooper fletcher miller smith)))
            (assert (not (= 1 (abs (- smith fletcher)))))
            (assert (lset= = '(1 2 3 4 5) (map cdr answer)))
            answer))))))

順列を使う

宣言的プログラミングという観点からは邪道とも思える順列利用版は，素直に書くと以下のようになるだろう．

(use util.combinations)

(define (solve)
  (let* ((floor (choose (permutations (iota 5 1))))
         (baker (first floor))
         (cooper (second floor))
         (fletcher (third floor))
         (miller (fourth floor))
         (smith (fifth floor)))
    (assert (not (= baker 5)))
    (assert (not (= cooper 1)))
    (assert (and (not (= fletcher 5)) (not (= fletcher 1))))
    (assert (> miller cooper))
    (assert (not (= 1 (abs (- smith fletcher)))))
    (assert (not (= 1 (abs (- cooper fletcher)))))
    (name-value baker cooper fletcher miller smith)))

しかし，このプログラムはProlog版とは振る舞いが全然違う．こちらは，最初に(1 2 3 4 5)の順列をすべて生成してしまうが，Prolog版ではバックトラックする度に新しい順列を作る．解がひとつしか必要ない場合（今の場合はまさにそう），順列を前もってすべて生成しておくなんて，非決定性計算の醍醐味はまるでなく，下記の決定性計算版とほとんど同じことになってしまう．

(define (solve)
  (filter-map
   (lambda (floor)
     (let ((baker (first floor))
           (cooper (second floor))
           (fletcher (third floor))
           (miller (fourth floor))
           (smith (fifth floor)))
       (and (not (= baker 5))
            (not (= cooper 1))
            (and (not (= fletcher 5)) (not (= fletcher 1)))
            (> miller cooper)
            (not (= 1 (abs (- smith fletcher))))
            (not (= 1 (abs (- cooper fletcher))))
            (name-value baker cooper fletcher miller smith))))
   (permutations (iota 5 1))))

こんなときこそストリームを使うんだろう，と思うのだが，情けないことに，これがすんなりといかない…．続きはまた．