;
; sudoku.l - solve a "sudoku" puzzle
;
; Mar 19, 2014 by FUJIWARA Teruyoshi
;
; Copyright: Copyright (c) 2014 FUJIWARA Teruyoshi
; License:   Distributes under the same terms as xyzzy
;
; Usage:
;   1. Eval this file.
;   2. Call the solver function with a initial arrangement as an argument.
;
; (solve-sudoku
;   '(0 3 0  0 6 0  4 0 7
;     0 7 0  0 0 0  0 9 0
;     2 0 0  0 4 0  0 0 5
;
;     0 9 0  0 0 7  8 4 0
;     0 5 0  8 0 6  0 1 0
;     0 1 6  3 0 0  0 7 0
;
;     6 0 0  0 1 0  0 0 2
;     0 8 0  0 0 0  0 3 0
;     7 0 9  0 3 0  0 6 0))

(defun print-board (mat func)
  (format t "--------- result ---------~%")
  (dotimes (i 9)
    (dotimes (j 9)
      (format t "~2D~A" (funcall func (aref mat i j))
              (cond ((= j 2) "|")
                    ((= j 5) "|")
                    ((= j 8) "")
                    (t " "))))
    (format t "~%")
    (if (or (= i 2) (= i 5)) (format t "--------------------------~%"))))

(defun seq (n)
  (labels((seq-reverse (n)
            (if (= n 0) nil
              (cons n (seq-reverse (- n 1))))))
    (reverse (seq-reverse n))))

(defun put (x y n)
  (dotimes (i 9)
    (if (sequencep (aref *board* i y))
        (setf (aref *board* i y) (remove n (aref *board* i y)))))
  (dotimes (j 9)
    (if (sequencep (aref *board* x j))
        (setf (aref *board* x j) (remove n (aref *board* x j)))))
  (let ((xbase (* (truncate x 3) 3))
        (ybase (* (truncate y 3) 3)))
    (dotimes (i 3)
      (dotimes (j 3)
        (let ((ii (+ xbase i))
              (jj (+ ybase j)))
          (if (sequencep (aref *board* ii jj))
              (setf (aref *board* ii jj) (remove n (aref *board* ii jj))))))))
  (setf (aref *board* x y) n)
  (setq *exit* nil))

(defun take-head (n lst)
  (if (= n 0) nil
    (cons (car lst) (take-head (1- n) (cdr lst)))))

(defun count (num lst)
  (setf (nth (- num 1) lst) (+ (nth (- num 1) lst) 1))
  lst)

(defun count-list (lst result)
  (if (= (length lst) 0) result
    (count-list (cdr lst) (count (car lst) result))))

(defun put-block (num x y)
  (dotimes (i 3)
    (dotimes (j 3)
      (if (sequencep (aref *board* (+ x i) (+ y j)))
          (if (find num (aref *board* (+ x i) (+ y j)))
              (put (+ x i) (+ y j) num))))))

(defun put-horizontal (num y)
  (dotimes (i 9)
    (if (sequencep (aref *board* i y))
        (if (find num (aref *board* i y))
            (put i y num)))))

(defun put-vertical (num x)
  (dotimes (i 9)
    (if (sequencep (aref *board* x i))
        (if (find num (aref *board* x i))
            (put x i num)))))

(defun sudoku (initial)
  (setq *board* (make-array '(9 9) :initial-element (seq 9)))
  (setq *exit* t)
  
  ; put initial arrangement
  (dotimes (i 9)
    (dotimes (j 9)
      (if (aref initial i j)
          (put i j (aref initial i j)))))
  
  (loop
    (setq *exit* t)
    
    ; check horizontal cells
    (dotimes (i 9)
      (let ((cn (make-list 9 :initial-element 0)))
        (dotimes (j 9)
          (if (sequencep (aref *board* j i))
              (count-list (aref *board* j i) cn)))
        (if (position 1 cn)
            (put-horizontal (+ (position 1 cn) 1) i))))
    
    ; check vertical cells
    (dotimes (i 9)
      (let ((cn (make-list 9 :initial-element 0)))
        (dotimes (j 9)
          (if (sequencep (aref *board* i j))
              (count-list (aref *board* i j) cn)))
        (if (position 1 cn)
            (put-vertical (+ (position 1 cn) 1) i))))
    
    ; check 3x3 blocks
    (dotimes (k 3)
      (dotimes (l 3)
        (let ((cn (make-list 9 :initial-element 0))
              (kk (* k 3))
              (ll (* l 3)))
          (dotimes (i 3)
            (dotimes (j 3)
              (if (sequencep (aref *board* (+ i kk) (+ j ll)))
                  (count-list (aref *board* (+ i kk) (+ j ll)) cn))))
          (if (position 1 cn)
              (put-block (+ (position 1 cn) 1) kk ll)))))
    
    ; sweep
    (dotimes (i 9)
      (dotimes (j 9)
        (if (sequencep (aref *board* i j))
            (if (= (length (aref *board* i j)) 1)
                (put i j (car (aref *board* i j)))))))
    
    (if *exit* (return)))
  (print-board *board* #'identity))

(defun take (n lst)
  (if (= n 0) nil
    (cons (if (= (car lst) 0)
              nil
            (car lst))
          (take (1- n) (cdr lst)))))

(defun group (n lst)
  (if (null lst) nil
    (cons (take n lst) (group n (nthcdr n lst)))))

(defun solve-sudoku (mat)
  (sudoku (make-array '(9 9) :initial-contents (group 9 mat))))