パズル「九個の？」をSchemeで解く

かれこれ1年以上も解けていないパズルがあった。ペントミノの一種で、9個のクエスチョンマークを9×8のグリッドに詰めるというもの。以下のページでJavaアプレットが遊べる（はず）。

• 九個の？
  http://www.geocities.jp/haayaa2000/puzzle/packing/nine_q.html

実は年末にも一回挑戦している。このときは結局、3日3晩かけても計算が終わらなかった。 解法として思い付くのは、グリッドにクエスチョンマークを置く組み合わせを総当たりで調べる方法のみなんだけど、各クエスチョンマークは上下左右裏表に自在におくことができるため、グリッドのどこかにクエスチョンマークを1つ配置するだけで実は208パターンにもなってしまう。そうすると、調べなければいけない組み合わせはペタオーダーになり、今のコンピュータでは一時的に保持することすら物理的に無理な大きさになる。Gaucheに用意されているcombination-for-eachを使えばいい具合に対処してくれるかもしれないと楽観したけど、やっぱりだめだった。ここまでは咋年末の話。

実際にはクエスチョンマークが安易に重なってしまうようなパターンがほとんどなので、それを無視しつつ組み合わせを求めるようにすれば計算量の爆発が抑えられそうなものだ。そのためのプロシージャは先日作った。というわけで、あらためてこの問題に対峙すべく年末のプログラムを書き直してみた。

; 9q-problem.scm
; 2006/5/26
;
; solver for the "9 questions" quize
; k16.shikano 

(use srfi-1)

(define row 9)
(define line 8)

;; question-mark
(define (face s n)
  (call/cc (lambda (break)
    (cond ((= n 1)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s                (+ s 1)           ; **
                                      (+ s row 1)       ;  *
                     (+ s (* 2 row)) (+ s (* 2 row) 1)  ; **
                     (+ s (* 3 row))                    ; * 
                                                        ;   
                     (+ s (* 5 row)))))                 ; * 
          ((= n 2)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s               (+ s 1)            ; **
                     (+ s row)                          ; * 
                     (+ s (* 2 row)) (+ s (* 2 row) 1)  ; **
                                     (+ s (* 3 row) 1)  ;  *
                                                        ;   
                                     (+ s (* 5 row) 1)  ;  *
                     )))
          ((= n 3)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list                 (+ s 1)            ;  *
                                                        ;   
                                     (+ s (* 2 row) 1)  ;  *
                     (+ s (* 3 row)) (+ s (* 3 row) 1)  ; **
                     (+ s (* 4 row))                    ; * 
                     (+ s (* 5 row)) (+ s (* 5 row) 1)  ; **
                     )))
          ((= n 4)
           (if (or (> (+ (remainder s row) 2) row) (> (+ (quotient s row) 6) line))
               (break '())
               (list s                                  ; * 
                                                        ;   
                     (+ s (* 2 row))                    ; * 
                     (+ s (* 3 row)) (+ s (* 3 row) 1)  ; **
                                     (+ s (* 4 row) 1)  ;  *
                     (+ s (* 5 row)) (+ s (* 5 row) 1)  ; **
                     )))
          ((= n 5)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list s (+ s 2) (+ s 3) (+ s 5)           ; * ** *
                     (+ s row) (+ s row 1) (+ s row 2)   ; ***
                     )))
          ((= n 6)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list s (+ s 2) (+ s 3) (+ s 5)           ; * ** *
                     (+ s row 3) (+ s row 4) (+ s row 5) ;    ***
                     )))
          ((= n 7)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '()) 
               (list s (+ s 1) (+ s 2)                             ; ***
                     (+ s row) (+ s row 2) (+ s row 3) (+ s row 5) ; * ** * 
                     )))
          ((= n 8)
           (if (or (> (+ (remainder s row) 6) row) (> (+ (quotient s row) 2) line))
               (break '())
               (list (+ s 3) (+ s 4) (+ s 5)                       ;    ***
                     (+ s row) (+ s row 2) (+ s row 3) (+ s row 5) ; * ** *
                     )))))))

;; available question-mark faces
(define valid-face-list
  (filter (lambda (x) (not (null? x)))
    (let fs ((s 0))
      (if (> s (- (* row line) 1))
          '()
          (let fn ((n 1))
            (if (> n 8)
                (fs (+ s 1))
                (cons (face s n) (fn (+ n 1)))))))))

;; check if two lists are distinct with each other
(define (distinct? l1 l2)
  (= (length (lset-union eq? l1 l2))
     (+ (length l1) (length l2))))

(define (distinct-cdr ls)
  (let R ((tail (cdr ls)))
    (cond ((null? tail) '())
   ((not (distinct? (car ls) (car tail)))
    (R (cdr tail)))
   (else
    (cons (car tail) (R (cdr tail)))))))

(define (trim-combinations ls n proc)
  (cond ((> n (length ls))
         '())
        ((= n 1)
         (map list ls))
        ((> (- n 1) (length (proc ls)))
         (trim-combinations (cdr ls) n proc))
        (else
         (append
          (map (lambda (x) (cons (car ls) x))
               (trim-combinations (proc ls) (- n 1) proc))
          (trim-combinations (cdr ls) n proc)))))

(trim-combinations valid-face-list 9 distinct-cdr)

これを9q-problem.scmとして、シェルからtimeした結果。

[05:37:46] k16@debian:~/gauche $ time gosh 9q-problem.scm > 9q-result.txt 

real    272m22.609s
user    266m0.799s
sys     0m1.174s

約4時間半。その後、求める組み合わせについてmemoizeとかしてみたりもしたんだけど、実行時間は変わらない。おそらく何か間違ってるんだろう。

気になる結果は、互いに対称かもしれない解が全部で16通り得られた（→解答）。