Common Lispで数独を解くプログラム

お絵描きロジックをボールペンで解くと失敗したときに取り返しがつかない。何問かやってみて結構な頻度で取り返しがつかなくなるのに憤慨したからお絵描きロジックを解くプログラムを書こうと思った。お絵描きロジックを解くアルゴリズムをはっきりさせるのが難しそうだったからとりあえず探索するだけで解ける数独を解くプログラムを書いたってワケ。久々にLispで遊んだ。

(defparameter *nums* '(1 2 3 4 5 6 7 8 9))
(defparameter *rules*
  '(;; rows
    ((0 . 0) (0 . 1) (0 . 2) (0 . 3) (0 . 4) (0 . 5) (0 . 6) (0 . 7) (0 . 8))
    ((1 . 0) (1 . 1) (1 . 2) (1 . 3) (1 . 4) (1 . 5) (1 . 6) (1 . 7) (1 . 8))
    ((2 . 0) (2 . 1) (2 . 2) (2 . 3) (2 . 4) (2 . 5) (2 . 6) (2 . 7) (2 . 8))
    ((3 . 0) (3 . 1) (3 . 2) (3 . 3) (3 . 4) (3 . 5) (3 . 6) (3 . 7) (3 . 8))
    ((4 . 0) (4 . 1) (4 . 2) (4 . 3) (4 . 4) (4 . 5) (4 . 6) (4 . 7) (4 . 8))
    ((5 . 0) (5 . 1) (5 . 2) (5 . 3) (5 . 4) (5 . 5) (5 . 6) (5 . 7) (5 . 8))
    ((6 . 0) (6 . 1) (6 . 2) (6 . 3) (6 . 4) (6 . 5) (6 . 6) (6 . 7) (6 . 8))
    ((7 . 0) (7 . 1) (7 . 2) (7 . 3) (7 . 4) (7 . 5) (7 . 6) (7 . 7) (7 . 8))
    ((8 . 0) (8 . 1) (8 . 2) (8 . 3) (8 . 4) (8 . 5) (8 . 6) (8 . 7) (8 . 8))
    ;; columns
    ((0 . 0) (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) (6 . 0) (7 . 0) (8 . 0))
    ((0 . 1) (1 . 1) (2 . 1) (3 . 1) (4 . 1) (5 . 1) (6 . 1) (7 . 1) (8 . 1))
    ((0 . 2) (1 . 2) (2 . 2) (3 . 2) (4 . 2) (5 . 2) (6 . 2) (7 . 2) (8 . 2))
    ((0 . 3) (1 . 3) (2 . 3) (3 . 3) (4 . 3) (5 . 3) (6 . 3) (7 . 3) (8 . 3))
    ((0 . 4) (1 . 4) (2 . 4) (3 . 4) (4 . 4) (5 . 4) (6 . 4) (7 . 4) (8 . 4))
    ((0 . 5) (1 . 5) (2 . 5) (3 . 5) (4 . 5) (5 . 5) (6 . 5) (7 . 5) (8 . 5))
    ((0 . 6) (1 . 6) (2 . 6) (3 . 6) (4 . 6) (5 . 6) (6 . 6) (7 . 6) (8 . 6))
    ((0 . 7) (1 . 7) (2 . 7) (3 . 7) (4 . 7) (5 . 7) (6 . 7) (7 . 7) (8 . 7))
    ((0 . 8) (1 . 8) (2 . 8) (3 . 8) (4 . 8) (5 . 8) (6 . 8) (7 . 8) (8 . 8))
    ;; squares
    ((0 . 0) (0 . 1) (0 . 2) (1 . 0) (1 . 1) (1 . 2) (2 . 0) (2 . 1) (2 . 2))
    ((3 . 0) (3 . 1) (3 . 2) (4 . 0) (4 . 1) (4 . 2) (5 . 0) (5 . 1) (5 . 2))
    ((6 . 0) (6 . 1) (6 . 2) (7 . 0) (7 . 1) (7 . 2) (8 . 0) (8 . 1) (8 . 2))
    ((0 . 3) (0 . 4) (0 . 5) (1 . 3) (1 . 4) (1 . 5) (2 . 3) (2 . 4) (2 . 5))
    ((3 . 3) (3 . 4) (3 . 5) (4 . 3) (4 . 4) (4 . 5) (5 . 3) (5 . 4) (5 . 5))
    ((6 . 3) (6 . 4) (6 . 5) (7 . 3) (7 . 4) (7 . 5) (8 . 3) (8 . 4) (8 . 5))
    ((0 . 6) (0 . 7) (0 . 8) (1 . 6) (1 . 7) (1 . 8) (2 . 6) (2 . 7) (2 . 8))
    ((3 . 6) (3 . 7) (3 . 8) (4 . 6) (4 . 7) (4 . 8) (5 . 6) (5 . 7) (5 . 8))
    ((6 . 6) (6 . 7) (6 . 8) (7 . 6) (7 . 7) (7 . 8) (8 . 6) (8 . 7) (8 . 8)) ))


;; collect rules relative to pos
(defun collect-rules (pos rules)
  (remove-if-not (lambda (ru)
                   (member pos ru
                           :test #'equal))
                 rules))

;; parse text file containing question
;; and generate candidates table
(defun parse-question (filename nums)
  (with-open-file (ifs filename
                       :direction :input)
    (let* ((ta (make-hash-table :test #'equal))
           (str (read-line ifs nil))
           (row (read-from-string str t nil :start 0))
           (clm (read-from-string str t nil :start 2))
           (lst nil))
      (loop for r
         below row
         do (let ((s (read-line ifs nil)))
              (loop for c
                 below clm
                 do (let ((val (read-from-string s t nil :start (* c 2))))
                      (if (= val 0)
                          (setf (gethash (cons r c) ta) nums)
                          (setf (gethash (cons r c) ta) (cons val nil)))
                      (setq lst (cons (cons r c) lst))))))
      (values row clm (reverse lst) ta))))


;; check whether a value can be put
;; under a rule and condition
(defun validp-each (val rule certain)
  (not (find (list val) (mapcar (lambda (key)
                                  (gethash key certain))
                                rule)
             :test #'equal)))

;; check whether a value can be put at pos
;; under the condition and rules relative to the value
(defun validp (pos val rules certain)
  (let ((rule (collect-rules pos rules)))
    (every (lambda (v)
             (not (null v)))
           (mapcar (lambda (r)
                     (validp-each val r certain))
                   rule))))

;; return next candidates table
(defun possible-list (certain nums poslist rules)
  (let ((tmphash (make-hash-table :test #'equal)))
    (mapc (lambda (pair)
            (let* ((pos (car pair))
                   (possibility (cdr pair))
                   (certain? (gethash pos certain)))
              (if (= 1 (list-length certain?))
                  (setf (gethash pos tmphash) certain?)
                  (setf (gethash pos tmphash) possibility))))
          (mapcar (lambda (pos)
                    (cons pos
                          (remove-if-not (lambda (n)
                                           (validp pos n rules certain))
                                         nums)))
                  poslist))
    tmphash))

;; count elements with only 1 possible value
(defun count-certain (certain)
  (count-if (lambda (v)
              (= 1 (length v)))
            (loop for val
               being the hash-values in certain
               collect val)))

;; check consistency
(defun inconsistentp (certain rules)
  (let ((values (loop for val
                   being the hash-values in certain
                   collect val)))
    (cond ((some #'null values) t)
          ((some (lambda (val)
                   (> (list-length val) 1))
                 values)
           nil)
          ((ruleviolatedp certain rules) t)
          (t nil))))

(defun ruleviolatedp (certain rules)
  (some #'null
        (mapcar (lambda (val1)
                  (let ((lst (mapcar (lambda (val2)
                                       (gethash val2 certain))
                                     val1)))
                    (= (list-length lst)
                       (list-length
                        (remove-duplicates lst :test #'equal)))))
                rules)))

;; check if solved or not
(defun solvedp (certain rules)
  (and (not (ruleviolatedp certain rules))
       (every (lambda (v)
                (= 1 (list-length v)))
              (loop for val
                 being the hash-values in certain
                 collect val))))

(defun print-solution (certain row clm)
  (loop for r
     below row
     do (progn
          (loop for c
             below clm
             do (format t "~S " (car (gethash (cons r c) certain))))
          (format t "~%")))
  (format t "~%"))

(defun smallest-uncertain (certain num)
  (let ((cand (find-if (lambda (pair)
                         (= (list-length (cdr pair)) num))
                       (loop for key
                          being the hash-keys in certain using (hash-value val)
                          collect (cons key val)))))
    (if cand
        cand
        (smallest-uncertain certain (+ 1 num)))))

;; solve sudoku
(defun solve (certain nums poslist rules row clm solutions)
  (let ((sol1 solutions))
    (cond ((inconsistentp certain rules) nil)
          ((solvedp certain rules)
           (setf sol1 (cons certain sol1))
           )
          (t (let ((next (possible-list certain nums poslist rules)))
               (if (< (count-certain certain) (count-certain next))
                   (setf sol1 (solve next nums poslist rules row clm sol1))
                   (let ((first-uncertain (smallest-uncertain certain 2)))
                     (mapc (lambda (val)
                             (progn (setf
                                     (gethash (car first-uncertain) next)
                                     (list val))
                                    (setf sol1
                                          (solve
                                           next nums poslist rules row clm sol1))))
                           (cdr first-uncertain)))))))
    sol1))

(defun run (pathname)
  (multiple-value-bind (r c l ta)
      (parse-question pathname *nums*)
    (time (mapc (lambda (s) (print-solution s r c))
                (solve ta *nums* l *rules* r c nil)))))

sudoku-sample.txt

9 9
0 0 5 3 0 0 0 0 0
8 0 0 0 0 0 0 2 0
0 7 0 0 1 0 5 0 0
4 0 0 0 0 5 3 0 0
0 1 0 0 7 0 0 0 6
0 0 3 2 0 0 0 8 0
0 6 0 5 0 0 0 0 9
0 0 4 0 0 0 0 3 0
0 0 0 0 0 9 7 0 0

こんなファイルを用意して

CL_USER> (run "sudoku-sample.txt")

ってやると

1 4 5 3 2 7 6 9 8
8 3 9 6 5 4 1 2 7
6 7 2 9 1 8 5 4 3
4 9 6 1 8 5 3 7 2
2 1 8 4 7 3 9 5 6
7 5 3 2 9 6 4 8 1
3 6 7 5 4 2 8 1 9
9 8 4 7 6 1 2 3 5
5 2 1 8 3 9 7 6 4

Evaluation took:
  14.176 seconds of real time
  14.289376 seconds of total run time (14.124370 user, 0.165006 system)
  [ Run times consist of 0.356 seconds GC time, and 13.934 seconds non-GC time. ]
  100.80% CPU
  39,602,840,884 processor cycles
  1,647,842,864 bytes consed

こんな感じに結果が出る。

答えが一つと決まってるならいいんだけど複数のあり得る答えがある場合もあるから結局全探索する事になって難しい問題だと時間がかかる。高速化を図ろうかな。