Date: Sun, 30 Oct 2005 13:11:29 -0800
From: George M Georgiou <georgiou@csusb.edu>
Subject: [gnu.emacs.sources] sudoku-solver.el -- manual and automatic solver
 for sudoku puzzles

Things are heating up in emacs-lisp.  This one purports to be a sudoku
solver.

Date: Sun, 30 Oct 2005 22:54:15 +0100
From: no-spam@cua.dk (Kim F. Storm)
Subject: sudoku-solver.el -- manual and automatic solver for sudoku puzzles
Message-id: <m31x22isc8.fsf@kfs-l.imdomain.dk>
Organization: StormWare
Newsgroups: gnu.emacs.sources
NNTP-posting-host: 80.62.38.68

;;; sudoku-solver.el --- solver for sudoku puzzles

;; Copyright (C) 2005 Kim F. Storm <s t o r m @ c u a . d k>

;; Author: Kim F. Storm <s t o r m @ c u a . d k>
;; Keywords: games puzzles
;; Version: 1.0

;; sudoku-solver.el is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; sudoku-solver.el is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;;; Commentary:

;; The aim of sudoku-solver is help solving SU DOKU puzzles.

;; To enter a puzzle, do:
;;
;; (require 'sudoku-solver)
;; M-x sudoku RET  (for a 9x9 sudoku)
;; C-u 1 6 M-x sudoku RET (for a 16x16 sudoku)
;;
;; Move cursor to top left corner of grid and press "E".
;; Now enter the sudoku puzzle by use of the 1-9 (or 0-9 a-f) keys,
;; Use SPACE to skip over blank field.
;;
;; Use RET to auto solve ONE cell
;; Use TAB to auto solve the whole sudoku.
;;
;; You can also solve puzzles manually.
;;
;; Move between cells with arrow keys or mouse.
;; Enter 1-9 to set a cell value.
;; Use . to clear a cell.
;; Use + 1-9 to color cells where you can enter 1-9.
;; Use - to uncolor all cells.
;; Use T to show/hide possible candicates for current cells as you move the cursor.
;; Use ? to show candidates for current cell once.
;; Use SPC to cycle through various hints.

;;; TODO:

;; Allow undo during entering a sudoku puzzle.

;;; Code:

;; Customize options.

(defgroup sudoku nil
  "sudoku - Su Doku puzzle solver."
  :group  'games
  :prefix "sudoku-")

(defcustom sudoku-size 9
  "*Size (height/width) of the playing area."
  :type  'integer
  :group 'sudoku)

(defcustom sudoku-save-direcory "~/.sudoku/"
  "*Directory for saved sudoku grids."
  :type  'string
  :group 'sudoku)

(defcustom sudoku-mode-hook nil
  "*Hook run on starting sudoku."
  :type  'hook
  :group 'sudoku)

(defface sudoku '((t (:height 2.0 :width expanded)))
  "*Base face for sudoku grid."
  :group 'sudoku)

(defface sudoku-highlight '((t (:background "lightgreen" :inherit sudoku)))
  "*Highlight face for sudoku cells."
  :group 'sudoku)

(defface sudoku-highlight-2 '((t (:background "lightblue" :inherit sudoku)))
  "*Highlight face for sudoku cells."
  :group 'sudoku)

;; Non-customize variables.

(defvar sudoku-grid nil
  "sudoku grid contents.")

(defvar sudoku-first-char ?1
  "first char in grid.")

(defvar sudoku-all-candidates-list nil
  "list of all possible candidates.")

(defvar sudoku-block-width 3
  "width of sudoku cells")

(defvar sudoku-block-height 3
  "height of sudoku cells")

(defvar sudoku-x 2
  "X position of cursor.")

(defvar sudoku-y 2
  "Y position of cursor.")

(defvar sudoku-buffer-name "*sudoku*"
  "Name of the sudoku play buffer.")

(defvar sudoku-mode-map nil
  "Local keymap for the sudoku game.")

(defvar sudoku-hint -1)

(defvar sudoku-candidate-pos nil)

(defvar sudoku-hint-pos nil)

(defvar sudoku-saved-grid nil)

(defvar sudoku-analyze-max nil)

(defvar sudoku-undo-list nil)

(defvar sudoku-stop)

(defvar sudoku-first-found nil)

(defvar sudoku-show-candidates t)

;; Keymap.

(unless sudoku-mode-map
  (let ((map (make-sparse-keymap)) (i 0))
    (suppress-keymap map t)
    (define-key map "H"                       #'describe-mode)
    (define-key map "Q"		              #'sudoku-quit-game)
    (define-key map "E"		              #'sudoku-enter-grid)
    (define-key map "S"		              #'sudoku-save-grid)
    (define-key map "L"		              #'sudoku-load-grid)
    (define-key map "U"		              #'sudoku-undo)
    (define-key map "\t"	              #'sudoku-auto-solve)
    (define-key map "\r"                      #'sudoku-next-hint)
    (define-key map " "                       #'sudoku-hint)
    (define-key map "?"                       #'sudoku-reveal-candidate-1)
    (define-key map "T"                       #'sudoku-toggle-show-candidates)
    (define-key map [up]                      #'sudoku-up)
    (define-key map [down]                    #'sudoku-down)
    (define-key map [left]                    #'sudoku-left)
    (define-key map [right]                   #'sudoku-right)
    (define-key map [(control a)]             #'sudoku-bol)
    (define-key map [(control e)]             #'sudoku-eol)
    (define-key map [(control p)]             #'sudoku-up)
    (define-key map [(control n)]             #'sudoku-down)
    (define-key map [(control b)]             #'sudoku-left)
    (define-key map [(control f)]             #'sudoku-right)
    (define-key map [home]                    #'sudoku-bol)
    (define-key map [end]                     #'sudoku-eol)
    (define-key map [prior]                   #'sudoku-first)
    (define-key map [next]                    #'sudoku-last)
    (define-key map [down-mouse-1]            #'sudoku-set-mouse)
    (define-key map [mouse-1]                 #'ignore)
    (while (< i sudoku-size)
      (define-key map (vector (+ (if (> i 10) (- ?a -10) sudoku-first-char) i))
					      #'sudoku-enter-char)
      (setq i (1+ i)))
    (define-key map "."			      #'sudoku-clear-char)
    (define-key map "+"                       #'sudoku-color-chars)
    (define-key map "-"                       #'sudoku-uncolor-all-cells)
    (define-key map [(control ?c) (control ?c)]   #'sudoku-analyze)
    (define-key map "A"                       #'sudoku-analyze)
    (define-key map ","                       #'sudoku-analyze)
    (setq sudoku-mode-map map)))

;; Menu definition.

(easy-menu-define sudoku-mode-menu sudoku-mode-map "sudoku menu."
  '("sudoku"
    ["New grid"               sudoku-new-grid  t]
    ["Save grid"              sudoku-save-grid  t]
    ["Load grid"              sudoku-load-grid  t]
    ["Enter grid"             sudoku-enter-grid  t]
    ["Quit grid"              sudoku-quit-game t]))

;; Gameplay functions.

(put 'sudoku-mode 'mode-class 'special)

(defun sudoku-mode ()
  "A mode for playing `sudoku'

The key bindings for sudoku-mode are:

\\{sudoku-mode-map}"
  (kill-all-local-variables)
  (use-local-map sudoku-mode-map)
  (setq major-mode 'sudoku-mode
        mode-name  "sudoku")
  (run-mode-hooks 'sudoku-mode-hook)
  (setq buffer-read-only t
        truncate-lines   t)
  (buffer-disable-undo))

;;;###autoload
(defun sudoku (&optional size)
  "Play sudoku.

The object of sudoku is very simple, by moving around the grid and flipping
squares you must fill the grid.

sudoku keyboard bindings are:
\\<sudoku-mode-map>
Next hint                 \\[sudoku-next-hint]
Move up                   \\[sudoku-up]
Move down                 \\[sudoku-down]
Move left                 \\[sudoku-left]
Move right                \\[sudoku-right]"

  (interactive "P")
  (sudoku-mode-setup (or size 9) nil))


(defun sudoku-mode-setup (size init)
  (let ((inhibit-read-only t))
    (switch-to-buffer sudoku-buffer-name)
    (sudoku-mode)
    (setq sudoku-size size)
    (setq sudoku-first-char (if (> sudoku-size 9) ?0 ?1))
    (setq sudoku-all-candidates-list (number-sequence 0 (1- sudoku-size)))
    (if (or (not sudoku-grid) (not (= sudoku-size (length (aref sudoku-grid 0)))))
	(sudoku-new-grid))
    (when init
      (sudoku-iterate-grid
	#'(lambda (cell y x)
	    (sudoku-set-symbol (or (car init) -1) y x)
	    (setq init (cdr init)))))
    (sudoku-position-cursor t)))

(defun sudoku-new-grid ()
  "Start a new `sudoku'."
  (interactive)
  (when (if (interactive-p) (y-or-n-p "Start a new game? ") t)
    (erase-buffer)
    (set (make-local-variable 'sudoku-block-height) (floor (sqrt sudoku-size)))
    (set (make-local-variable 'sudoku-block-width) (/ sudoku-size sudoku-block-height))
    (set (make-local-variable 'sudoku-x) 0)
    (set (make-local-variable 'sudoku-y) 0)
    (set (make-local-variable 'sudoku-grid) (sudoku-make-new-grid))
    (set (make-local-variable 'sudoku-undo-list) nil)
    (set (make-local-variable 'sudoku-show-candidates) sudoku-show-candidates)

    (sudoku-draw-grid)))

(defun sudoku-quit-game ()
  "Quit the current game of `sudoku'."
  (interactive)
  (if (y-or-n-p "Quit? ")
      (kill-buffer sudoku-buffer-name)))

(defun sudoku-make-new-grid ()
  "Create and return a new `sudoku' grid structure."
  (let ((grid (make-vector sudoku-size nil))
	(i 0))
    (while (< i sudoku-size)
      (aset grid i (make-vector sudoku-size nil))
      (setq i (1+ i)))
    grid))

(defun sudoku-cell (&optional y x grid)
  "Return the value of the cell in GRID at location X,Y."
  (aref (aref (or grid sudoku-grid) (or y sudoku-y)) (or x sudoku-x)))

(defun sudoku-set-cell (y x value)
  "Set the value of cell X,Y in GRID to VALUE."
  (aset (aref sudoku-grid y) x value))

;; Candidates are represented as bit masks

(defsubst sudoku-is-candidate-p (candidates v)
  (/= (logand candidates (lsh 1 v)) 0))

(defsubst sudoku-add-candidate (candidates v)
  (logior candidates (lsh 1 v)))

(defsubst sudoku-delete-candidate (candidates v)
  (logand candidates (lognot (lsh 1 v))))

(defsubst sudoku-all-candidates ()
  (1- (lsh 1 sudoku-size)))

(defun sudoku-iterate-candidates (candidates fns)
  (let ((v 0))
    (while (< v sudoku-size)
      (if (sudoku-is-candidate-p candidates v)
	  (if (funcall fns v)
	      (setq v sudoku-size)))
      (setq v (1+ v)))))

(put 'sudoku-iterate-candidates 'lisp-indent-function 1)

(defun sudoku-count-candidates (candidates)
  (let ((v 0) (n 0))
    (while (< v sudoku-size)
      (if (sudoku-is-candidate-p candidates v)
	  (setq n (1+ n)))
      (setq v (1+ v)))
    n))

;; Each cell is represented by a vector with the following elements:
;;
;; 0 - internal cell value, -1 means empty cell
;; 1 - buffer position for displaying cell value
;; 2 - bitmask of possible cell values
;; 3 - number of possible cell values

(defun sudoku-init-cell (y x pos)
  (sudoku-set-cell y x (vector -1 pos 0 0)))

(defsubst sudoku-cell-value (cell)
  (aref cell 0))

(defsubst sudoku-cell-set-value (cell value)
  (aset cell 0 value))

(defsubst sudoku-cell-pos (cell)
  (aref cell 1))

(defsubst sudoku-cell-set-pos (cell pos)
  (aset cell 1 pos))

(defsubst sudoku-cell-mask (cell)
  (aref cell 2))

(defsubst sudoku-cell-set-mask (cell mask &optional count)
  (aset cell 2 mask)
  (aset cell 3 (or count (sudoku-count-candidates mask))))

(defsubst sudoku-cell-count (cell)
  (aref cell 3))

(defun sudoku-cell-next-value (cell &optional last)
  (let* ((mask (sudoku-cell-mask cell))
	 (n (or last 0))
	 (b (lsh 1 n)))
    (while (and (< n sudoku-size) (/= mask 0))
      (if (/= (logand mask b) 0)
	  (setq mask 0)
	(setq b (lsh b 1)
	      n (1+ n))))
    (if (< n sudoku-size) n -1)))

;; Return cell VALUE or if empty only candidate for cell
;; nil otherwise.
(defun sudoku-cell-value-or-candidate (cell)
  (cond
   ((>= (sudoku-cell-value cell) 0)
    (sudoku-cell-value cell))
   ((= (sudoku-cell-count cell) 1)
    (sudoku-cell-next-value cell))))


(defsubst sudoku-cell-exclude-value (cell value)
  (sudoku-cell-set-mask cell
   (logand (sudoku-cell-mask cell) (lognot (lsh 1 value)))))

(defsubst sudoku-cell-in-mask-p (cell value)
  (/= (logand (sudoku-cell-mask cell) (lsh 1 value)) 0))

(defsubst sudoku-value (&optional y x)
  (sudoku-cell-value (sudoku-cell y x)))

(defsubst sudoku-set-value (y x value)
  (sudoku-cell-set-value (sudoku-cell y x) value))

(defsubst sudoku-count (&optional y x)
  (sudoku-cell-count (sudoku-cell y x)))

(defsubst sudoku-mask (&optional y x)
  (sudoku-cell-mask (sudoku-cell y x)))

(defsubst sudoku-set-mask (y x mask &optional count)
  (sudoku-cell-set-mask (sudoku-cell y x) mask count))

(defsubst sudoku-pos (&optional y x)
  (sudoku-cell-pos (sudoku-cell y x)))

(defsubst sudoku-set-pos (y x pos)
  (sudoku-cell-set-pos (sudoku-cell y x) pos))

(defun sudoku-delete-candidates (y x excluded)
  (let ((cell (sudoku-cell y x)))
    (sudoku-cell-set-mask cell
     (logand (sudoku-cell-mask cell) (lognot excluded)))))

(defun sudoku-goto-cell (&optional y x)
  (setq sudoku-y (or y sudoku-y)
	sudoku-x (or x sudoku-x))
  (goto-char (sudoku-pos sudoku-y sudoku-x)))

(defun sudoku-iterate-row (y fns)
  (let ((x 0))
    (while (< x sudoku-size)
      (funcall fns (sudoku-cell y x) y x)
      (setq x (1+ x)))))

(put 'sudoku-iterate-row 'lisp-indent-function 1)

(defun sudoku-iterate-col (x fns)
  (let ((y 0))
    (while (< y sudoku-size)
      (funcall fns (sudoku-cell y x) y x)
      (setq y (1+ y)))))

(put 'sudoku-iterate-col 'lisp-indent-function 1)

(defun sudoku-block-yx (&optional y x)
  (setq y (or y sudoku-y) x (or x sudoku-x))
  (let ((by (* (floor (/ y sudoku-block-height)) sudoku-block-height))
	(bx (* (floor (/ x sudoku-block-width)) sudoku-block-width)))
    (cons by bx)))

(defun sudoku-iterate-block (y x fns)
  (let ((by (sudoku-block-yx y x)) bx y x)
    (setq bx (cdr by) by (car by))
    (setq y by)
    (while (< y (+ by sudoku-block-height))
      (setq x bx)
      (while (< x (+ bx sudoku-block-width))
	(funcall fns (sudoku-cell y x) y x)
	(setq x (1+ x)))
      (setq y (1+ y)))))

(put 'sudoku-iterate-block 'lisp-indent-function 2)

(defun sudoku-count-value-row (y v)
  (let ((n 0))
    (sudoku-iterate-row y
      #'(lambda (cell y1 x1)
	  (if (sudoku-cell-in-mask-p cell v)
	      (setq n (1+ n)))))
    n))

(defun sudoku-count-value-col (x v)
  (let ((n 0))
    (sudoku-iterate-col x
      #'(lambda (cell y1 x1)
	  (if (sudoku-cell-in-mask-p cell v)
	      (setq n (1+ n)))))
    n))

(defun sudoku-count-value-block (y x v)
  (let ((n 0))
    (sudoku-iterate-block y x
      #'(lambda (cell y1 x1)
	  (if (sudoku-cell-in-mask-p cell v)
	      (setq n (1+ n)))))
    n))

(defun sudoku-iterate-block-row (y x fns)
  (let ((bx (cdr (sudoku-block-yx y x))))
    (setq x bx)
    (while (< x (+ bx sudoku-block-width))
      (funcall fns (sudoku-cell y x) y x)
      (setq x (1+ x)))))

(put 'sudoku-iterate-block-row 'lisp-indent-function 2)

(defun sudoku-iterate-block-col (y x fns)
  (let ((by (car (sudoku-block-yx y x))))
    (setq y by)
    (while (< y (+ by sudoku-block-height))
      (funcall fns (sudoku-cell y x) y x)
      (setq y (1+ y)))))

(put 'sudoku-iterate-block-col 'lisp-indent-function 2)

(defun sudoku-in-block-p (by bx y x)
  (and (>= y by) (< y (+ by sudoku-block-height))
       (>= x bx) (< x (+ bx sudoku-block-width))))

(defun sudoku-iterate-grid (fns)
  (let (y x sudoku-stop)
    (setq y 0)
    (while (and (< y sudoku-size) (not sudoku-stop))
      (setq x 0)
      (while (and (< x sudoku-size) (not sudoku-stop))
	(funcall fns (sudoku-cell y x) y x)
	(setq x (1+ x)))
      (setq y (1+ y)))))

(put 'sudoku-iterate-grid 'lisp-indent-function 0)

(defun sudoku-iterate-blocks (fns)
  (let (by bx)
    (setq by 0)
    (while (< by sudoku-size)
      (setq bx 0)
      (while (< bx sudoku-size)
	(funcall fns by bx)
	(setq bx (+ bx sudoku-block-width)))
      (setq by (+ by sudoku-block-height)))))

(put 'sudoku-iterate-blocks 'lisp-indent-function 0)

(defun sudoku-iterate-empty-cells (fns)
  (let (y x)
    (setq y 0)
    (while (< y sudoku-size)
      (setq x 0)
      (while (< x sudoku-size)
	(let ((cell (sudoku-cell y x)))
	  (if (< (sudoku-cell-value cell) 0)
	      (funcall fns cell y x)))
	(setq x (1+ x)))
      (setq y (1+ y)))))

(put 'sudoku-iterate-empty-cells 'lisp-indent-function 0)

(defun sudoku-iterate-full-cells (fns)
  (let (y x)
    (setq y 0)
    (while (< y sudoku-size)
      (setq x 0)
      (while (< x sudoku-size)
	(let ((cell (sudoku-cell y x)))
	  (if (>= (sudoku-cell-value cell) 0)
	      (funcall fns cell y x)))
	(setq x (1+ x)))
      (setq y (1+ y)))))

(put 'sudoku-iterate-full-cells 'lisp-indent-function 0)

(defun sudoku-iterate-rcb (y x f)
  (sudoku-iterate-row y f)
  (sudoku-iterate-col x f)
  (sudoku-iterate-block y x f))

(put 'sudoku-iterate-rcb 'lisp-indent-function 2)

(defun sudoku-exclude-value-rcb (y x v)
  (sudoku-iterate-rcb y x
    #'(lambda (cell1 y1 x1)
	(sudoku-cell-exclude-value cell1 v))))

(defun sudoku-count-char (c &optional y x)
  (let* ((n 0))
    (sudoku-iterate-rcb (or y sudoku-y) (or x sudoku-x)
      #'(lambda (cell y1 x1)
	  (if (= (sudoku-cell-value cell) c)
	      (setq n (1+ n)))))
    n))

(defun sudoku-count-all ()
  (let ((n 0))
    (sudoku-iterate-grid
      #'(lambda (cell y x)
	  (setq n (+ n (sudoku-cell-count cell)))))
    n))

;; Level 0
;; No analysis

(defun sudoku-reset-candidates ()
  (sudoku-iterate-grid
    #'(lambda (cell y x)
	(sudoku-cell-set-mask cell 0 0))))

;; Level 1
;; Initialize candidate masks + counts.
;; Block out specified values in same rows/columns/block

(defun sudoku-analyze-1-aux ()
  (sudoku-iterate-grid
    #'(lambda (cell y x)
	(if (>= (sudoku-cell-value cell) 0)
	    (sudoku-cell-set-mask cell 0 0)
	  (let* ((mask (sudoku-all-candidates)))
	    (sudoku-iterate-rcb y x
	      #'(lambda (cell1 y1 x1)
		  (if (setq x1 (sudoku-cell-value cell1))
		      (setq mask (sudoku-delete-candidate mask x1)))))
	    (if (and (= (sudoku-cell-set-mask cell mask) 1)
		     (not sudoku-first-found))
		(setq sudoku-first-found (cons y x))))))))

;; Level 2
;; Identify cells with just one candidate, and block out
;; other occurrences in same row/col/block.

(defsubst sudoku-cell-fix-candidate (cell v)
  (sudoku-cell-set-mask cell (lsh 1 v) 1))

(defun sudoku-analyze-2-aux ()
  (sudoku-iterate-grid
    #'(lambda (cell y x)
	(if (= (sudoku-cell-count cell) 1)
	    (let ((v (sudoku-cell-next-value cell)))
	      (sudoku-exclude-value-rcb y x v)
	      (sudoku-cell-fix-candidate cell v))))))

;; Level 3
;; Identify block-rows or block-columns which exclusively contain a
;; specific value.
;; Exclude that value from the rest of that row/column in the grid.

(defun sudoku-analyze-3-aux ()
  (sudoku-iterate-blocks
    #'(lambda (by bx)
	(let ((v 0) found n x y z)
	  (while (< v sudoku-size)
	    (setq y by
		  n 0
		  z nil)
	    (while (< y (+ by sudoku-block-height))
	      (setq found nil)
	      (sudoku-iterate-block-row y bx
		#'(lambda (cell y x)
		    (when (sudoku-cell-in-mask-p cell v)
		      (setq found t))))
	      (if found
		  (setq z y
			n (1+ n)))
	      (setq y (1+ y)))
	    (when (= n 1)
	      (sudoku-iterate-row z
		#'(lambda (cell1 y1 x1)
		    (if (not (sudoku-in-block-p by bx y1 x1))
			(sudoku-cell-exclude-value cell1 v)))))
	    (setq x bx
		  n 0
		  z nil)
	    (while (< x (+ bx sudoku-block-width))
	      (setq found nil)
	      (sudoku-iterate-block-col by x
		#'(lambda (cell y x)
		    (when (sudoku-cell-in-mask-p cell v)
		      (setq found t))))
	      (when found
		(setq z x
		      n (1+ n)))
	      (setq x (1+ x)))
	    (when (= n 1)
	      (sudoku-iterate-col z
		#'(lambda (cell1 y1 x1)
		    (if (not (sudoku-in-block-p by bx y1 x1))
			(sudoku-cell-exclude-value cell1 v)))))
	    (setq v (1+ v)))))))

;; Level 4
;; Identify cell which in row/col/block which is the only
;; cell containing a specific value.
;; Set that value as only candidate for the cell.
;; Exclude that value from other cells (as if cell already
;; had that value).

(defun sudoku-analyze-4-aux ()
  (sudoku-iterate-grid
    #'(lambda (cell y x)
       (unless (or (>= (sudoku-cell-value cell) 0)
		    (<= (sudoku-cell-count cell) 1))
	  (sudoku-iterate-candidates (sudoku-cell-mask cell)
	    #'(lambda (v)
		(when (or (= (sudoku-count-value-row y v) 1)
			  (= (sudoku-count-value-col x v) 1)
			  (= (sudoku-count-value-block y x v) 1))
		  (sudoku-exclude-value-rcb y x v)
		  (sudoku-cell-set-mask cell (lsh 1 v))
		  t)))))))

(defun sudoku-analyze (&optional max)
  (interactive "P")
  (sudoku-reset-candidates)
  (let ((last -1) cur (iter 0) (level 0))
    (while (and (or max
		    (= (sudoku-count-matches) 0))
		(or (/= last (setq cur (sudoku-count-all)))
		    (< iter 4)))
      (setq last cur)
      (if (> (setq level (1+ level)) 4)
	  (setq level 2))
      (cond
       ((= level 1) (sudoku-analyze-1-aux))
       ((= level 2) (sudoku-analyze-2-aux))
       ((= level 3) (sudoku-analyze-3-aux))
       ((= level 4) (sudoku-analyze-4-aux)))
      (setq iter (1+ iter)))
    (let ((matches (sudoku-count-matches)))
      (message "Found %d candidate%s (in %d rounds)" matches (if (= matches 1) "" "s") iter))))

(defun sudoku-count-matches ()
  (let ((count 0))
    (sudoku-iterate-grid
      #'(lambda (cell y x)
	  (if (and (< (sudoku-cell-value cell) 0)
		   (= (sudoku-cell-count cell) 1))
	      (setq count (1+ count)))))
    count))

(defun sudoku-toggle-show-candidates ()
  (interactive)
  (if (setq sudoku-show-candidates (not sudoku-show-candidates))
      (sudoku-show-candidates)
    (sudoku-hide-candidates)))

(defun sudoku-reveal-candidate-1 ()
  (interactive)
  (let ((sudoku-show-candidates t))
    (sudoku-show-candidates t)))

(defun sudoku-show-candidates (&optional reveal-1)
  (if (and sudoku-candidate-pos
	   sudoku-show-candidates)
      (let ((inhibit-read-only t)
	    (s "") (n (* sudoku-size 2)))
	(if (and (= (sudoku-count) 1)
		 (not reveal-1))
	    (setq s " ?"
		  n (- n 2))
	  (sudoku-iterate-candidates (sudoku-mask)
	    #'(lambda (v)
		(setq s (format "%s %c" s (sudoku-symbol-to-char v))
		      n (- n 2))
		nil)))
	(save-excursion
	  (goto-char sudoku-candidate-pos)
	  (delete-char (* sudoku-size 2))
	  (insert (propertize s 'face 'sudoku))
	  (if (> n 0)
	      (insert-char ?\s n))))))

(defun sudoku-hide-candidates ()
  (let ((inhibit-read-only t)
	(n (* sudoku-size 2)))
    (if sudoku-candidate-pos
	(save-excursion
	  (goto-char sudoku-candidate-pos)
	  (delete-char (* sudoku-size 2))
	  (insert-char ?\s n)))))

(defun sudoku-validate (c &optional y x)
  (= (sudoku-count-char c y x) 0))

(defun sudoku-draw-separator ()
  (let ((p 0))
    (insert-char ?+ 1)
    (while (< p sudoku-block-height)
      (insert-char ?- (1+ (* sudoku-block-width 2)))
      (insert-char ?+ 1)
      (setq p (1+ p))))
  (insert "\n"))

(defun sudoku-draw-row (y)
  (let ((x 0) p)
    (insert "| ")
    (while (< x sudoku-size)
      (setq p 0)
      (while (< p sudoku-block-width)
	(sudoku-init-cell y x (point))
	(insert ". ")
	(setq p (1+ p)
	      x (1+ x)))
      (insert "| "))
    (insert "\n")))

(defun sudoku-draw-grid ()
  "Draw the sudoku grid"
  (let ((inhibit-read-only t)
	(y 0) q)
    (sudoku-draw-separator)
    (while (< y sudoku-size)
      (setq q 0)
      (while (< q sudoku-block-height)
	(sudoku-draw-row y)
	(setq q (1+ q)
	      y (1+ y)))
      (sudoku-draw-separator))
    (insert "Candidates:")
    (setq sudoku-candidate-pos (point))
    (insert-char ?\s (* sudoku-size 2))
    (insert "\nHint: ?\n")
    (setq sudoku-hint-pos (- (point-max) 2))
    (sudoku-uncolor-all-cells)))

(defun sudoku-position-cursor (&optional quiet)
  "Position the cursor on the grid."
  (sudoku-goto-cell)
  (if (not quiet)
      (sudoku-show-candidates)))



;; Keyboard response functions.

(defun sudoku-up ()
  "Move up."
  (interactive)
  (unless (zerop sudoku-y)
    (setq sudoku-y (1- sudoku-y)))
  (sudoku-position-cursor))

(defun sudoku-down ()
  "Move down."
  (interactive)
  (when (< sudoku-y (1- sudoku-size))
    (setq sudoku-y (1+ sudoku-y)))
  (sudoku-position-cursor))

(defun sudoku-left ()
  "Move left."
  (interactive)
  (unless (zerop sudoku-x)
    (setq sudoku-x (1- sudoku-x)))
  (sudoku-position-cursor))

(defun sudoku-right ()
  "Move right."
  (interactive)
  (when (< sudoku-x (1- sudoku-size))
    (setq sudoku-x (1+ sudoku-x)))
  (sudoku-position-cursor))

(defun sudoku-bol ()
  "Move to beginning of line."
  (interactive)
  (setq sudoku-x 0)
  (sudoku-position-cursor))

(defun sudoku-eol ()
  "Move to end of line."
  (interactive)
  (setq sudoku-x (1- sudoku-size))
  (sudoku-position-cursor))

(defun sudoku-top ()
  "Move to the first cell."
  (interactive)
  (setq sudoku-y 0)
  (sudoku-position-cursor))

(defun sudoku-bottom ()
  "Move to the last cell."
  (interactive)
  (setq sudoku-y (1- sudoku-size))
  (sudoku-position-cursor))

(defun sudoku-set-mouse (e)
  "Set cell on mouse click."
  (interactive "e")
  (mouse-set-point e)
  (let ((y 1) (x 1))
    (while (and (< y sudoku-size)
		(<= (sudoku-pos y 0) (point)))
      (setq y (1+ y)))
    (setq y (1- y))
    (while (and (< x sudoku-size)
		(<= (sudoku-pos y x) (point)))
      (setq x (1+ x)))
    (sudoku-goto-cell y (1- x))))

;;; Setup board

(defun sudoku-show-symbol (&optional y x hint)
  (if (and x y)
      (sudoku-goto-cell y x))
  (let* ((inhibit-read-only t)
	 (cell (sudoku-cell y x))
	 (c (sudoku-cell-value cell)))
    (delete-char 1)
    (insert (propertize
	     (char-to-string
	      (cond
	       ((< c 0)
		(if (and hint (= (sudoku-cell-count cell) 1))
		    ?_ ?.))
	       ((and (>= c 0) (<= c 9)) (+ c sudoku-first-char))
	       (t (+ c -10 ?A)))) 'face 'sudoku))
    (backward-char 1)))

(defun sudoku-record-undo (boundary)
  (setq sudoku-undo-list (cons (or boundary (cons sudoku-y sudoku-x)) sudoku-undo-list)))

(defun sudoku-undo ()
  (interactive)
  (while (consp (car sudoku-undo-list))
    (sudoku-set-symbol -1 (car (car sudoku-undo-list)) (cdr (car sudoku-undo-list)))
    (setq sudoku-undo-list (cdr sudoku-undo-list)))
  (setq sudoku-undo-list (cdr sudoku-undo-list))
  (sudoku-analyze)
  (sudoku-hide-candidates))

(defun sudoku-set-symbol (c &optional y x)
  (if (and x y)
      (sudoku-goto-cell y x))
  (if (and (>= c 0) (not (sudoku-validate c)))
      (ding)
    (sudoku-set-value sudoku-y sudoku-x c)
    (sudoku-set-mask sudoku-y sudoku-x 0 0)
    (sudoku-show-symbol)))

(defun sudoku-enter-char ()
  (interactive)
  (sudoku-clear-char)
  (let ((g (sudoku-char-to-symbol (aref (this-single-command-keys) 0))))
    (sudoku-set-symbol g))
  (sudoku-record-undo t)
  (sudoku-record-undo nil)
  (sudoku-analyze)
  (sudoku-hide-candidates))

(defun sudoku-clear-char ()
  (interactive)
  (sudoku-set-symbol -1)
  (sudoku-analyze)
  (sudoku-show-candidates))

(defun sudoku-char-to-symbol (c)
  (cond
   ((and (>= c ?a) (<= c ?z)
	 (< (setq c (+ (- c ?a) 10)) sudoku-size))
    c)
   ((and (>= c sudoku-first-char) (<= c ?9)
	 (< (setq c (- c sudoku-first-char)) sudoku-size))
    c)
   (t -1)))

(defun sudoku-symbol-to-char (c)
  (cond
   ((< c 0) ?.)
   ((<= (setq c (+ c sudoku-first-char)) ?9) c)
   (t (+ (- c ?9 1) ?A))))

(defun sudoku-enter-grid ()
  (interactive)
  (sudoku-hide-candidates)
  (sudoku-record-undo t)
  (let ((y sudoku-y) (x sudoku-x))
    (while (< y sudoku-size)
      (while (< x sudoku-size)
	(sudoku-goto-cell y x)
	(reset-this-command-lengths)
	(let ((c (read-char-exclusive)) g)
	  (cond
	   ((and (setq g (sudoku-char-to-symbol c))
		 (sudoku-validate g))
	    (sudoku-set-symbol g)
	    (sudoku-record-undo nil))
	   ((or (= c ?\C-g)
		(= c ?q))
	    (ding) (setq x sudoku-size y sudoku-size))
	   ((= c ?\s) (sudoku-set-symbol -1))
	   ((= c ?\r)
	    (if (= x 0)
		(setq y (- y 2) x sudoku-size)
	      (setq x (- x 2))))
	   (t (ding)
	      (setq x (1- x)))))
	(setq x (1+ x)))
      (setq y (1+ y)
	    x 0)))
  (sudoku-analyze)
  (sudoku-show-candidates))


(defun sudoku-auto-solve (&optional max)
  (interactive "P")
  (sudoku-analyze max)
  (sudoku-hide-candidates)
  (let ((boundary t))
    (sudoku-iterate-grid
      #'(lambda (v y x)
	  (when (and (< (sudoku-cell-value v) 0)
		     (= (sudoku-cell-count v) 1))
	    (sudoku-set-symbol (sudoku-cell-next-value v) y x)
	    (when boundary
	      (sudoku-record-undo t)
	      (setq boundary nil))
	    (sudoku-record-undo nil)
	    (setq sudoku-stop (not max)))))))


(defun sudoku-show-hint (v)
  (when sudoku-hint-pos
    (save-excursion
      (goto-char sudoku-hint-pos)
      (let ((inhibit-read-only t))
	(delete-char 1)
	(if v
	    (insert (propertize v 'face 'sudoku))
	  (insert " "))))))

(defun sudoku-color-cell (face &optional y x)
  (let ((pos (sudoku-pos y x))
	(inhibit-read-only t))
    (put-text-property pos (1+ pos) 'face face)))

(defun sudoku-uncolor-all-cells (&optional face face2)
  (interactive)
  (sudoku-show-hint nil)
  (if (not face)
      (let ((inhibit-read-only t))
	(put-text-property (point-min) (point-max) 'face 'sudoku))
    (sudoku-iterate-grid
      #'(lambda (v y x)
	  (if (< (sudoku-cell-value v) 0)
	      (sudoku-color-cell
	       (if (and face2 (= (sudoku-cell-count v) 2)) face2 face) y x))))))

(defun sudoku-color-symbols (c)
  (sudoku-uncolor-all-cells 'sudoku-highlight 'sudoku-highlight-2)
  (sudoku-show-hint (char-to-string (sudoku-symbol-to-char c)))
  (when (>= c 0)
    (sudoku-iterate-grid
      #'(lambda (v y x)
	  (when (= (sudoku-cell-value v) c)
	    (sudoku-iterate-rcb y x
	      #'(lambda (v y1 x1)
		  (sudoku-color-cell 'sudoku y1 x1))))))))

(defun sudoku-color-chars (c)
  (interactive "cColor char: ")
  (sudoku-color-symbols (sudoku-char-to-symbol c)))

(defun sudoku-hint ()
  (interactive)
  (if (or (not (eq last-command this-command))
	  (= (setq sudoku-hint (1+ sudoku-hint)) sudoku-size))
      (setq sudoku-hint 0))
  (cond
   ((and (>= sudoku-hint 0)
	 (not (eq last-command this-command)))
    (setq sudoku-hint -1)
    (sudoku-show-hint nil)
    (sudoku-iterate-grid
      #'(lambda (v y x)
	  (when (< (sudoku-cell-value v) 0)
	    (sudoku-show-symbol y x t)))))
   (t
    (sudoku-color-symbols sudoku-hint))))

(defun sudoku-next-hint ()
  (interactive)
  (let ((this-command last-command))
    (sudoku-hint)))

(defun sudoku-save-grid (file)
  (interactive
   (list
    (read-file-name "Save Sudoku to file: "
		    sudoku-save-direcory nil nil nil)))
  (setq file (expand-file-name file sudoku-save-direcory))
  (if (and (/= (aref (file-name-nondirectory file) 0) ?,)
	   (file-exists-p file)
	   (not (yes-or-no-p "Overwrite existing file? ")))
      (error "Choose another file name"))
  (let (g)
    (sudoku-iterate-grid
      #'(lambda (v y x)
	  (setq g (cons (sudoku-cell-value v) g))))
    (setq g (nreverse g))
    (make-directory (file-name-directory file) t)
    (with-temp-file file
      (insert (format "(setq grid '(%d" sudoku-size))
      (while g
	(insert (format " %d" (car g)))
	(setq g (cdr g)))
    (insert "))\n"))))

(defun sudoku-load-grid (file)
  (interactive
   (list
    (read-file-name "Load Sudoku from file: "
		    sudoku-save-direcory nil t nil)))
  (let (grid)
    (load-file (expand-file-name file sudoku-save-direcory))
    (when grid
      (sudoku-mode-setup (car grid) (cdr grid)))))


(provide 'sudoku-solver)

;;; sudoku.el ends here

-- 
Kim F. Storm  http://www.cua.dk