[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
sudoku-solver.el -- manual and automatic solver for sudoku puzzles
From: |
Kim F. Storm |
Subject: |
sudoku-solver.el -- manual and automatic solver for sudoku puzzles |
Date: |
Sun, 30 Oct 2005 22:54:15 +0100 |
User-agent: |
Gnus/5.11 (Gnus v5.11) Emacs/22.0.50 (gnu/linux) |
;;; 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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- sudoku-solver.el -- manual and automatic solver for sudoku puzzles,
Kim F. Storm <=