M.Hiroi's Home Page

お気楽 Scheme プログラミング入門

パズルの解法 [1]

Copyright (C) 2008-2020 Makoto Hiroi
All rights reserved.

はじめに

今回は「パズル」を題材にプログラムを作ってみましょう。どのプログラミング言語でもそうですが、上達の秘訣は実際にプログラムを作って動作を確認してみることです。ところが、いざとなると「さて何を作ろうか」と困ってしまう方もいるのではないでしょうか。

このようなときにぴったりな題材が「パズルの解法」です。なんといっても、実際にパズルが解けたときの喜びはとても大きく、プログラムを作る意欲をかきたててくれます。そこで、今回はバックトラック法を使って簡単なパズルを解いてみましょう。

●8 クイーン

最初に簡単な例題として、「8 クイーン」を取り上げます。これはコンピュータに解かせるパズルの中でもとくに有名な問題です。8 クイーンは、8 行 8 列のチェスの升目に、8 個のクイーンを互いの利き筋が重ならないように配置する問題です。クイーンは将棋の飛車と角をあわせた駒で、縦横斜めに任意に動くことができます。解答の一例を次に示します。

             列
       0 1 2 3 4 5 6 7
     *-----------------*
   0 | Q . . . . . . . |
   1 | . . . . Q . . . |
   2 | . . . . . . . Q |
行 3 | . . . . . Q . . |
   4 | . . Q . . . . . |
   5 | . . . . . . Q . |
   6 | . Q . . . . . . |
   7 | . . . Q . . . . |
     *-----------------*

  図 : 8 クイーンの解答例

8 クイーンを解くには、基本的にはすべての置き方を試してみるしかありません。最初のクイーンは、盤上の好きなところへ置くことができるので、64 通りの置き方があります。次のクイーンは 63 通り、その次は 62 通りあります。したがって、置き方の総数は 64 から 57 までを掛け算した 178,462,987,637,760 通りあることがわかります。これはとても大きな数ですね。

ところが、解答例を見ればおわかりのように、同じ行と列に 2 つ以上のクイーンを置くことはできません。上図の解答例をリストを使って表すと、 次のようになります。

   0 1 2 3 4 5 6 7      <--- 列の位置
 ------------------
  (0 6 4 7 1 3 5 2)     <--- 要素が行の位置を表す

        図 : 8 クイーンの表現方法

列をリストの位置に、行番号を要素に対応させれば、各要素には 0 から 7 までの数字が重複しないで入ることになります。すなわち、0 から 7 までの順列の総数である 8! = 40320 通りの置き方を調べればよいことになります。数がぐっと減りましたね。パズルを解く場合は、そのパズル固有の性質をうまく使って、調べなければならない置き方の総数を減らすように工夫することが大切です。

順列を生成するプログラムは簡単です。あとは、その順列が 8 クイーンの条件を満たしているかチェックすればいいわけです。このように、正解の可能性があるデータを作り、それが条件を満たしているかテストするという方法を「生成検定法 (generate and test)」といいます。可能性のあるデータをもれなく作るのにバックトラック法は最適です。ただし、生成するデータ数が多くなると、実行時間がとてもかかるという弱点もあるので注意してください。

●斜めの利き筋のチェック

あとは、斜めの利き筋をチェックするだけです。次の図を見てください。

  右斜め上の利き筋          左斜め上の利き筋
   0 1 2 3 4 5 6 7         0 1 2 3 4 5 6 7
*-----------------*        *-----------------*
|//////// | 8   -1 |\\\\\\\\ |
|//////// | 9   -2 |\\\\\\\\ |
|//////// | 10  -3 |\\\\\\\\ |
|//////// | 11  -4 |\\\\\\\\ |
|//////// | 12  -5 |\\\\\\\\ |
|//////// | 13  -6 |\\\\\\\\ |
|//////// | 14  -7 |\\\\\\\\ |
|//////// |        |\\\\\\\\ |
*-----------------*        *-----------------*

 x + y = constant           x - y = constant
 例                         例
 (2 0) (1 1) (0 2) => 2     (5 0) (6 1) (7 1) => 5

               図 : 斜めの利き筋

斜めの利き筋は、行と列の位置を足す、または行から列を引くと一定の値になる、ということを利用すれば簡単にチェックできます。この処理は添字付きのマップ関数を使うと簡単です。次のリストを見てください。

リスト : 添字付きマップ関数

(define (map-with-index fn xs)
  (define (mapi i xs)
    (if (null? xs)
        '()
        (cons (fn i (car xs)) (mapi (+ i 1) (cdr xs)))))
  (mapi 0 xs))

関数 map-with-index は関数 fn の第 1 引数に位置 (添字) を、第 2 引数にリストの要素を渡します。実際の処理は局所関数 mapi で行います。引数 i が添字を表します。あとはマップ関数と同じです。簡単な使用例を示しましょう。

gosh[r7rs.user]> (map-with-index cons '(a b c d e))
((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))

たとえば、盤面 (0 6 4 7 1 3 5 2) において、「添字 - 要素」と「添字 + 要素」を計算すると次のようになります。

gosh[r7rs.user]> (map-with-index (lambda (i x) (- i x)) '(0 6 4 7 1 3 5 2))
(0 -5 -2 -4 3 2 1 5)
gosh[r7rs.user]> (map-with-index (lambda (i x) (+ i x)) '(0 6 4 7 1 3 5 2))
(0 7 6 10 5 8 11 9)

どちらの結果も同じ値が含まれていない、つまりクイーンは衝突していないことが分かります。これに対して、盤面 (0 1 2 3 4 5 6 7) は次のような結果になります。

gosh[r7rs.user]> (map-with-index (lambda (i x) (- i x)) '(0 1 2 3 4 5 6 7))
(0 0 0 0 0 0 0 0)
gosh[r7rs.user]> (map-with-index (lambda (i x) (+ i x)) '(0 1 2 3 4 5 6 7))
(0 2 4 6 8 10 12 14)

左斜めの効き筋はすべて同じ値になったので、すべてのクイーンは同じ効き筋に存在していることがわかります。

次は、重複要素があるかチェックする述語 duplicates? を作ります。

リスト : 重複要素の検出

(define (duplicates? pred xs)
  (cond
   ((null? xs) #f)
   ((member (car xs) (cdr xs) pred) #t)
   (else
    (duplicates? pred (cdr xs)))))

duplicates? は重複要素があれば #t を、そうでなければ #f を返します。引数 pred は要素の等値を判定する述語です。最初の節で、xs が空リストならば重複要素がないので #f を返します。次の節で、先頭要素が残りのリストに含まれているか member でチェックし、同じ要素があれば #t を返します。そうでなければ、duplicates? を再帰呼び出しして、次の要素をチェックします。

簡単な使用例を示しましょう。

gosh[r7rs.user]> (duplicates? eqv? '(1 2 1 2))
#t
gosh[r7rs.user]> (duplicates? eqv? '(1 2 3 2))
#t
gosh[r7rs.user]> (duplicates? eqv? '(1 2 3 4))
#f

map-with-index と duplicates? を使うと、クイーンが安全かチェックする述語 safe? は次のようになります。

リスト : クイーンは安全か?

(define (safe? board)
  (and (not (duplicates? eqv? (map-with-index (lambda (i x) (- i x)) board)))
       (not (duplicates? eqv? (map-with-index (lambda (i x) (+ i x)) board)))))

map-with-index で斜めのきき筋を求め、duplicates? で重複要素が無いことを確認するだけです。

●8 クイーンの解法

ここまで作ればあとは簡単です。8 クイーンを解くプログラムは、次のようになります。

リスト : 単純に順列を生成する方法

(define (queen fn ls)
  (permutations
   (lambda (xs)
     (when (safe? xs) (fn xs)))
   ls))

関数 queen は関数 permutations を呼び出して順列を生成します。順列がひとつ完成したらラムダ式が呼び出されます。ここで、述語 safe? を使ってクイーンが衝突していないことを確認します。そうであれば、関数 fn を呼び出します。

それでは実行してみましょう。

gosh[r7rs.user]> (queen print-board '(0 1 2 3))
*---------*
| . Q . . |
| . . . Q |
| Q . . . |
| . . Q . |
*---------*

*---------*
| . . Q . |
| Q . . . |
| . . . Q |
| . Q . . |
*---------*

#<undef>
gosh[r7rs.user]> (queen print-board '(0 1 2 3 4 5 6 7))
*-----------------*
| Q . . . . . . . |
| . . . . Q . . . |
| . . . . . . . Q |
| . . . . . Q . . |
| . . Q . . . . . |
| . . . . . . Q . |
| . Q . . . . . . |
| . . . Q . . . . |
*-----------------*

 ・・・省略・・・

*-----------------*
| . . . . . . . Q |
| . . . Q . . . . |
| Q . . . . . . . |
| . . Q . . . . . |
| . . . . . Q . . |
| . Q . . . . . . |
| . . . . . . Q . |
| . . . . Q . . . |
*-----------------*

#<undef>

print-board は盤面を表示する関数です。print-board の説明は割愛しますので、詳細はプログラムリスト1をお読みください。8 クイーンの場合、解は全部で 92 通りあります。

●プログラムの高速化

ところで、このプログラムは順列を生成してからクイーンの衝突チェックを行っているため、あまり効率的ではありません。最近のパソコンであれば、8 クイーンはこのプログラムでも短時間で解くことができますが、クイーンの個数を増やすと実行時間がかかるようになります。実際に試してみると、実行時間は次のようになりました。

表 : 8 クイーンの実行時間 (秒)

 個数 |   8  |   9  |  10
------+------+------+-------
queen | 0.17 | 1.38 | 14.54 

実行環境 : Ubunts 18.04 (Windows Subsystem for Linux), Intel Core i5-6200U 2.30GHz

クイーンの個数をひとつ増やしただけでも、実行時間はとても遅くなります。なぜかというと、失敗することがわかっている順列も生成しているからです。

たとえば、最初 (0, 0) の位置にクイーンを置くと、次のクイーンは (1, 1) の位置に置くことはできません。したがって、(0 1 X X X X X X) という配置はすべて失敗することがわかるわけですが、順列を発生させてからチェックする方法では、このような無駄を省くことができません。そこで、クイーンの配置を決めるたびに衝突のチェックを行うことにします。これをプログラムすると次のようになります。

リスト : 8 クイーンの解法 (高速版)

;;; 先頭のクイーンが他のクイーンと衝突しないことを確認する
(define (safe-fast? board)
  (let ((xs (map-with-index (lambda (i x) (- i x)) board))
        (ys (map-with-index (lambda (i x) (+ i x)) board)))
    (and (not (member (car xs) (cdr xs)))
         (not (member (car ys) (cdr ys))))))

(define (queen-fast fn ls)
  (define (queen-sub ls board)
    (if (null? ls)
        (fn board)
        (for-each
         (lambda (n)
           (let ((b (cons n board)))
             (when (safe-fast? b)
                   (queen-sub (remove n ls) b))))
         ls)))
  (queen-sub ls '()))

queen-fast の局所関数 queen-sub で順列を生成します。for-each に渡すラムダ式の中で、追加したクイーンが board 内のクイーンと衝突していないか述語 safe-fast? でチェックしています。for-each の中にチェックを入れることで、無駄な順列を生成しないようにするわけです。実行時間は次のようになりました。

    表 : 8 クイーンの実行時間

   個数    |   8   |   9  |  10   |  11   |  12
-----------+-------+------+-------+-------+-------
queen      | 0.17  | 1.38 | 14.54 | ----- | -----
queen-fast | 0.013 | 0.78 |  0.37 |  1.71 |  9.91

実行環境 : Ubunts 18.04 (Windows Subsystem for Linux), Intel Core i5-6200U 2.30GHz

実行時間は大幅に短縮されました。このように、できるだけ早い段階でチェックを入れることで、無駄なデータをカットすることを「枝刈り」と呼びます。バックトラック法を使ってパズルを解く場合、この枝刈りのよしあしによって実行時間が大きく左右されます。

ただし、枝刈りのやり方は問題によって大きく変わります。「斜めの利き筋をチェックする」という枝刈りは、8 クイーン固有の性質を使ったやり方であり、これをそのまま他のパズルに使うことはできません。パズル固有の性質をよく調べて、適切な枝刈りを考えることが重要なのです。

パズル自体はコンピュータに解かせるのですが、枝刈りの条件は私達が考えるわけですね。これも「パズルの解法」のおもしろさのひとつといえるでしょう。解を求めるだけではなく、いかに効率の良い条件を見つけて実行時間を短縮するか、ということでも楽しむことができるわけです。

なお、n 行 n 列の盤面でクイーンの配置を求める問題を "N Queens Problem" といいます。クイーンの個数が増えると queen-fast でも遅くなるので、もっと高速な方法が必要になります。興味のある方は拙作のページ Puzzle De Programming: N Queens Problem をお読みください。


●プログラムリスト1

;;;
;;; queen.scm : 8 Queen の解法
;;;
;;;             Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time))

;;; 整数列の生成
(define (iota s e)
  (if (> s e)
      '()
      (cons s (iota (+ s 1) e))))

;;; 添字付きマップ関数
(define (map-with-index fn xs)
  (define (mapi i xs)
    (if (null? xs)
        '()
        (cons (fn i (car xs)) (mapi (+ i 1) (cdr xs)))))
  (mapi 0 xs))

;;; 重複要素の検出
(define (duplicates? pred xs)
  (cond
   ((null? xs) #f)
   ((member (car xs) (cdr xs) pred) #t)
   (else
    (duplicates? pred (cdr xs)))))

;;; x と等しい要素を削除する
(define (remove x ls)
  (cond
   ((null? ls) '())
   ((equal? (car ls) x)
    (remove x (cdr ls)))
   (else
    (cons (car ls) (remove x (cdr ls))))))

;;; 順列の生成
(define (permutations func ls)
  (define (perm ls a)
    (if (null? ls)
        (func (reverse a))
        (for-each
          (lambda (n)
            (perm (remove n ls) (cons n a)))
          ls)))
  (perm ls '()))

;;; 盤面の表示
(define (print-board board)
  (define (print-line q size)
    (display "| ")
    (do ((x 0 (+ x 1)))
        ((>= x size))
      (display (if (= x q) "Q " ". ")))
    (display "|\n"))

  (define (print-waku size)
    (display "*-")
    (do ((x 0 (+ x 1)))
        ((>= x size))
      (display "--"))
    (display "*\n"))

  (let ((size (length board)))
    (print-waku size)
    (do ((ls board (cdr ls)))
        ((null? ls))
      (print-line (car ls) size))
    (print-waku size)
    (newline)))

;;; 安全確認
(define (safe? board)
  (and (not (duplicates? eqv? (map-with-index (lambda (i x) (- i x)) board)))
       (not (duplicates? eqv? (map-with-index (lambda (i x) (+ i x)) board)))))

;;; 先頭のクイーンが他のクイーンと衝突しないか確認する
(define (safe-fast? board)
  (let ((xs (map-with-index (lambda (i x) (- i x)) board))
        (ys (map-with-index (lambda (i x) (+ i x)) board)))
    (and (not (member (car xs) (cdr xs)))
         (not (member (car ys) (cdr ys))))))

;;; 8 Queen の解法
(define (queen fn ls)
  (permutations
   (lambda (xs)
     (when (safe? xs) (fn xs)))
   ls))

;;; 高速版
(define (queen-fast fn ls)
  (define (queen-sub ls board)
    (if (null? ls)
        (fn board)
        (for-each
         (lambda (n)
           (let ((b (cons n board)))
             (when (safe-fast? b)
                   (queen-sub (remove n ls) b))))
         ls)))
  (queen-sub ls '()))

;;; テスト
(define (test fn n)
  (let ((c 0)
        (s (current-jiffy)))
    (fn (lambda (x) (set! c (+ c 1))) (iota 0 (- n 1)))
    (display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
    (newline)
    c))

●マスターマインド

パズルではありませんが、簡単な例題として「マスターマインド」を解くプログラムを作りましょう。マスターマインドは「数当てゲーム [2]」で作成した、0 から 9 までの重複しない 4 つの数字からなる隠しコードを当てるゲームです。数字は合っているが位置が間違っている個数を cows で表し、数字も位置も合っている個数を bulls で表します。bulls が 4 になると正解です。

     (6 2 8 1) : 正解
---------------------------------
1.   (0 1 2 3) : cows 2 : bulls 0
2.   (1 0 4 5) : cows 1 : bulls 0
3.   (2 3 5 6) : cows 2 : bulls 0
4.   (3 2 7 4) : cows 0 : bulls 1
5.   (3 6 0 8) : cows 2 : bulls 0
6.   (6 2 8 1) : cows 0 : bulls 4

  図 : マスターマインドの動作例

今回は、私達が出した問題をコンピュータに答えてもらうことにします。それはちょっと難しいのではないか、と思った人もいるかもしれませんね。ところが、とても簡単な方法があるのです。このゲームでは、10 個の数字の中から 4 個選ぶわけですから、全体では 10 * 9 * 8 * 7 = 5040 通りのコードしかありません。コードを生成する処理は順列と同じですから、簡単にプログラムできます。

●推測アルゴリズム

次に、この中から正解を見つける方法ですが、質問したコードとその結果を覚えておいて、それと矛盾しないコードを作るようにします。具体的には、4 つの数字の順列を生成し、それが今まで質問したコードと矛盾しないことを確かめます。これは生成検定法と同じですね。

矛盾しているかチェックする方法も簡単で、以前に質問したコードと比較して、bulls と cows が等しいときは矛盾していません。たとえば、次の例を考えてみてください。

(6 2 8 1) が正解の場合

(0 1 2 3) => bulls = 0, cows = 2

           (0 1 2 3)  と比較する
     --------------------------------------------------------
           (0 X X X)  0 から始まるコードは bulls = 1
                      になるので矛盾する。
           ・・・・

           (1 0 3 4)  cows = 3, bulls = 0 になるので矛盾する

           ・・・・

           (1 0 4 5)  cows = 2, bulls = 0 で矛盾しない。
     --------------------------------------------------------

(1 0 4 5) => bulls = 0, cows = 1

次は、(0 1 2 3) と (1 0 4 5) に矛盾しない数字を選ぶ

        図 : マスターマインドの推測アルゴリズム

(0 1 2 3) で bulls が 0 ですから、その位置にその数字は当てはまりません。したがって、(0 X X X) というコードは (0 1 2 3) と比較すると bulls が 1 となるので、矛盾していることがわかります。

次に (1 0 3 4) というコードを考えてみます。(0 1 2 3) の結果は cows が 2 ですから、その中で合っている数字は 2 つしかないわけです。ところが、(1 0 3 4) と (0 1 2 3) と比較すると cows が 3 になります。当たっている数字が 2 つしかないのに、同じ数字を 3 つ使うのでは矛盾していることになりますね。

次に (1 0 4 5) というコードと比較すると、bulls が 0 で cows が 2 となります。これは矛盾していないので、このコードを質問することにします。その結果が bulls = 0, cows = 1 となり、今度は (0 1 2 3) と (1 0 4 5) に矛盾しないコードを選択するのです。

●プログラムの作成

マスターマインドを解くプログラムは次のようになります。

リスト : マスターマインドの解法

;;; 質問結果を格納
(define-record-type Query
  (make-query qcode bulls cows)
  query?
  (qcode qcode)
  (bulls bulls)
  (cows cows))

;;; 解法
(define (solver answer)
  (let loop ((xs (permutations 4 '(0 1 2 3 4 5 6 7 8 9)))
             (n 1)
             (qs '()))
    (cond
     ((null? xs) #f)
     ((check-query (car xs) qs)
      (let* ((code (car xs))
             (b (count-bulls code answer))
             (c (- (count-same-number code answer) b)))
        ;; 表示
        (print-result n code b c)
        (if (= b 4)
            ;; 正解
            (display "Good Job!!\n")
            (loop (cdr xs) (+ n 1) (cons (make-query code b c) qs)))))
     (else
      (loop (cdr xs) n qs)))))

質問した結果はレコード型 Query に格納します。関数 permutations は生成した順列をリストに格納して返します。それを変数 xs にセットします。変数 n は質問回数、変数 qs は Query を格納するリストです。

あとは named-let で xs からコードを取り出し、関数 check-query で今まで質問したコードと矛盾しないかチェックします。矛盾していない場合、正解 answer と code を照合します。関数 count-bulls と count-same-number を使って bulls (b) と cows (c) を求めます。

結果は関数 print-result で表示します。bulls が 4 であれば正解です。display で Good Job!! を表示して処理を終了します。そうでなければ、次のコードをチェックします。このとき、n を +1 して、qs に今質問したコードと結果を追加します。check-query が #f を返した場合は、次のコードをチェックするだけです。

次は、述語 check-query を作ります。

リスト : 今まで質問したコードと矛盾していないか

(define (check-query code qs)
  (let loop ((qs qs))
    (if (null? qs)
        #t
        (let* ((q (car qs))
               (b (count-bulls code (qcode q)))
               (c (- (count-same-number code (qcode q)) b)))
          (and (= b (bulls q)) (= c (cows q)) (loop (cdr qs)))))))

check-query は named-let を使って qs に格納された Query をチェックしていきます。すべてのデータで矛盾がなければ #t を返します。関数 count-bulls と count-same-number を使って bulls と cows を求めて、質問したときの bulls と cows に矛盾しないかチェックします。矛盾している場合、check-query は #f を返します。そうでなければ、次の Query をチェックします。

あとのプログラムは簡単なので説明は割愛します。詳細はプログラムリスト2をお読みください。

●何回で当たるか

これでプログラムは完成です。それでは実行例を示しましょう。

gosh[r7rs.user]> (solver '(9 8 7 6))
1: (0 1 2 3), bulls = 0, cows = 0
2: (4 5 6 7), bulls = 0, cows = 2
3: (5 4 8 9), bulls = 0, cows = 2
4: (6 7 9 8), bulls = 0, cows = 4
5: (8 9 7 6), bulls = 2, cows = 2
6: (9 8 7 6), bulls = 4, cows = 0
Good Job!!
#<undef>
gosh[r7rs.user]> (solver '(9 4 3 1))
1: (0 1 2 3), bulls = 0, cows = 2
2: (1 0 4 5), bulls = 0, cows = 2
3: (2 3 5 4), bulls = 0, cows = 2
4: (3 4 0 6), bulls = 1, cows = 1
5: (3 5 6 1), bulls = 1, cows = 1
6: (6 5 0 2), bulls = 0, cows = 0
7: (7 4 3 1), bulls = 3, cows = 0
8: (8 4 3 1), bulls = 3, cows = 0
9: (9 4 3 1), bulls = 4, cows = 0
Good Job!!
#<undef>

肝心の質問回数ですが、5, 6 回で当たる場合が多いようです。実際に、5040 個のコードをすべて試してみたところ、平均は 5.56 回になりました。これは参考文献「数当てゲーム (MOO, マスターマインド)」の結果と同じです。質問回数の最大値は 9 回で、そのときのコードは (9 4 3 1), (9 2 4 1), (5 2 9 3), (9 2 0 4), (9 2 1 4) でした。

なお、参考文献 1 には平均質問回数がこれよりも少なくなる方法が紹介されています。単純な数当てゲームだと思っていましたが、その奥はけっこう深いようです。興味のある方はいろいろ試してみてください。

-- 参考文献 --------
1. 田中哲郎 「数当てゲーム (MOO, マスターマインド)」, 松原仁、竹内郁雄 編 『bit 別冊 ゲームプログラミング』 pp150 - 157, 共立出版, 1997

●プログラムリスト2

;;;
;;; master1.scm : マスターマインドの解法
;;;
;;;               Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))

;;; x と等しい要素を削除する
(define (remove x ls)
  (cond
   ((null? ls) '())
   ((equal? (car ls) x)
    (remove x (cdr ls)))
   (else
    (cons (car ls) (remove x (cdr ls))))))

;;; マッピングの結果を平坦化する
(define (flatmap fn xs)
  (apply append (map fn xs)))

;;; 順列の生成
(define (permutations n xs)
  (if (zero? n)
      '(())
      (flatmap (lambda (x)
                 (map (lambda (ys) (cons x ys))
                      (permutations (- n 1) (remove x xs))))
               xs)))

;;; pred が真となる要素の個数を数える
(define (count-if pred xs)
  (let loop ((xs xs) (c 0))
    (cond
     ((null? xs) c)
     ((pred (car xs))
      (loop (cdr xs) (+ c 1)))
     (else
      (loop (cdr xs) c)))))

;;; bulls の個数を数える
(define (count-bulls xs ys)
  (count-if (lambda (x) x) (map = xs ys)))

;;; 同じ数字の個数を数える
(define (count-same-number xs ys)
  (count-if (lambda (x) x)
            (map (lambda (x) (member x ys)) xs)))

;;; 質問の結果
(define-record-type Query
  (make-query qcode bulls cows)
  query?
  (qcode qcode)
  (bulls bulls)
  (cows cows))

;;; 質問と矛盾しないか?
(define (check-query code qs)
  (let loop ((qs qs))
    (if (null? qs)
        #t
        (let* ((q (car qs))
               (b (count-bulls code (qcode q)))
               (c (- (count-same-number code (qcode q)) b)))
          (and (= b (bulls q)) (= c (cows q)) (loop (cdr qs)))))))

;;; 結果を表示する
(define (print-result n code b c)
  (display n) (display ": ") (display code)
  (display ", bulls = ") (display b)
  (display ", cows = ") (display c)
  (newline))

;;; 解法
(define (solver answer)
  (let loop ((xs (permutations 4 '(0 1 2 3 4 5 6 7 8 9)))
             (n 1)
             (qs '()))
    (cond
     ((null? xs) #f)
     ((check-query (car xs) qs)
      (let* ((code (car xs))
             (b (count-bulls code answer))
             (c (- (count-same-number code answer) b)))
        ;; 表示
        (print-result n code b c)
        (if (= b 4)
            ;; 正解
            (display "Good Job!!\n")
            (loop (cdr xs) (+ n 1) (cons (make-query code b c) qs)))))
     (else
      (loop (cdr xs) n qs)))))

初版 2008 年 1 月 14 日
改訂 2020 年 9 月 12 日