;;; sudoku.el --- solve (or have solved for you) sudoku puzzles
;;;
;;; This package lets you work on sudoku puzzles. It lets you enter,
;;; save, and restore puzzles, has undo and checkpointing, and
;;; displays in faces and formats that let you concentrate on the
;;; logic of the puzzles rather than the bookkeeping necessary. It
;;; also can provide hints, or actually solve the puzzle for you. For
;;; a fuller description see the documentation for the function SUDOKU
;;; below.
;;;
;;; feel free to use and distribute this code, and maybe drop me a
;;; note if you find it fun
;;;
;;; Author: russell young 2005 (sudoku@young-0.com)
;;; URL: http://www.young-0.com/php/emacs/sudoku.el
;;;
;;; Copyright: This is released in the public domain
 
(require 'cl)
(load "cl-extra")
 
(defgroup sudoku nil
  "Sudoku: This is a package for playing the popular puzzle game.  It
makes it easier by organizing all the data and displaying it in a
format that is easy to see, allowing you to concentrate on the logic
of solving the puzzles, rather than on the bookkeeping. If you are
stuck or just impatient, hit 'a' to get a hint for the next move. It
also will solve them for you, and provide a list of the logic used to
solve the puzzles.
 
Among other things, this offers displays of the current contents of
each cell and the possibilities of each cell, provides undo and
checkpointing capability, and lets you change faces to experiment with
a branch."
  :group 'games)
 
(defcustom sudoku-possibles-display t
  "Display an array of cells showing the possible values for each"
  :group 'sudoku
  :type 'boolean)
 
(defcustom sudoku-selected-display t
  "Display an array of cells showing the contents of each cell"
  :group 'sudoku
  :type 'boolean)
 
(defcustom sudoku-confirm-quit t
  "Get confirmation before quitting if there is a live game"
  :group 'sudoku
  :type 'boolean)
 
(defcustom sudoku-reuse-buffer t
  "If set and there is an active game in the buffer, open up a new one
Otherwise reuse the buffer even if it means losing an active game"
  :group 'sudoku
  :type 'boolean)
 
(defcustom  sudoku-solve-delay 1
  "Delay between steps in SUDOKU-SOLVE
If nil or 0 use no delay"
  :group 'sudoku
  :type 'number)
 
(defcustom sudoku-max-cycle-check 5
  "One of the help checks is to look for cycles. This limits the size.
Larger cycles take longer to find, and are not likely to be as useful
anyway. If this check fails it is time to start guessing"
  :group 'sudoku
  :type 'integer)
 
(defcustom sudoku-solution-heuristics '(sudoku-finish-clearing-cycle 
										sudoku-check-singles
										sudoku-check-empty
										sudoku-check-only
										sudoku-check-cycles
										sudoku-guess)
 
  "This is a list of functions called in order to find the next move
 
Currently the ones supplied are sudoku-check-singles,
sudoku-check-only, sudoku-check-empty, sudoku-check-cycles, and
sudoku-guess. These can be added or taken out - in particular, some
people might not want to let the solution try guessing. Really they
are all special cases of SUDOKU-CHECK-CYCLES, and you could get away 
with just using that one, but I wrote them kind of in the order I
would use them myself to solve puzzles, so the solution generated
is similar to what I would find on my own.
 
This series usually solves puzzles, but in some cases it cannot
proceed and has to guess. I would welcome anyone to write another
heuristic that would solve this case, or if someone will send me an
algorithm I will code it myself. For example, 6 of the first 20 of
Royle's puzzles require guessing for this to solve.
 
In order to add a new function it must take no arguments, and return a
list of length 4 consisting of (in order):
 - a string explaining the move
 - a function to call to implement the move. This function takes 2 args,
the cell and the number in the cell to be chosen
 - the cell affected
 - the number in the cell affected
  "
  :group 'sudoku
  :type 'sexp)
 
(defcustom sudoku-boss-buffer "*shell*"
  "Pop to this buffer when the boss key is hit
If the buffer does not exist then just bury the sudoku buffer"
  :group 'sudoku
  :type 'string)
 
(defface sudoku-error-face
  '((t
	 (:weight bold :background "Red")))
  "face for sudoku error"
  :group 'sudoku)
 
(defface sudoku-button-face
  '((t
	 (:weight bold :background "grey" :foreground "black")))
  "face for sudoku command buttons"
  :group 'sudoku)
 
(defface sudoku-button-pressed-face
  '((t
	 (:weight bold :background "black" :foreground "grey")))
  "face for buttons that are pressed"
  :group 'sudoku)
 
(defface sudoku-initial-face
  '((t
	 (:weight bold :foreground "Red")))
  "face for initial sudoku selections"
  :group 'sudoku)
 
(defface sudoku-face-0 
  '((t
	 (:foreground "Green")))
  "Face for playing sudoku"
  :group 'sudoku)
 
(defface sudoku-face-1
  '((t
	 (:foreground "yellow")))
  "Face for playing sudoku"
  :group 'sudoku)
 
(defface sudoku-face-2 
  '((t
	 (:foreground "blue")))
  "Face for playing sudoku"
  :group 'sudoku)
 
(defcustom sudoku-face-choices '(sudoku-face-0 sudoku-face-1 sudoku-face-2)
  "These faces are used to display selected numbers
They are used in turn to show checkpoint \(guess\) levels"
  :group 'sudoku
  :type 'list)
 
(defvar sudoku-mode-hooks nil)
 
(defvar sudoku-desc nil
  "the descriptor for the buffer's puzzle
See the description in SUDOKU-MAKE-DATA-STRUCT")
 
(defvar sudoku-undo-list ()
  "keeps a list of moves for the undo function")
(defvar sudoku-redo-list ())
 
(defvar sudoku-checkpoint-stack ()
  "Checkpoint backtracking locations to allow easy recovery
The last member is the initial position")
 
(defconst sudoku-possibilities-board-width 64
  "width of possibilities board and padding, used to draw selection board
properly")
 
(defconst sudoku-top-row 4
  "Leaves some space on top of the display for title and status")
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Functions mapped to keys
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; I prefer using tables to set up key mappings
(flet ((make-keymap (desc)
					(let ((map (make-sparse-keymap)))
					  (mapc (lambda (x) (define-key map
										  (car x) (cdr x))) desc)
					  map)))
  (setq sudoku-map
		(make-keymap
		 '(([return] . sudoku-select-choice)
		   ([mouse-1] . sudoku-mouse-select-choice)
		   ([down-mouse-1] . sudoku-show-button-press)
		   ([drag-mouse-1] . sudoku-unpress-cancelled-button)
		   ([delete] . sudoku-remove-choice)
		   ([backspace] . sudoku-remove-choice)
		   ([mouse-3] . sudoku-mouse-remove-choice)
		   ("n" lambda () (interactive) (when (y-or-n-p "Really
start a new game? ") (sudoku)))
		   ("q" . sudoku-quit)
		   ("\C-x\C-s" . sudoku-save)
		   ("\C-_" . sudoku-undo)
		   ("\C-z" . sudoku-undo)
		   ("\C-y" . sudoku-redo)
		   ("a" . sudoku-assist)
		   ("S" . sudoku-solve)
		   ("c" . sudoku-checkpoint)
		   ("r" . sudoku-to-checkpoint)
		   ("R" . sudoku-restart)
		   ("u" . sudoku-uncheckpoint)
		   ("?" lambda () (interactive) (describe-function 'sudoku))
		   ("h" lambda () (interactive) (describe-function 'sudoku))
		   ("C" . sudoku-customize)
		   ("l" . sudoku-draw)
		   ([?\C-l] . sudoku-draw)
		   ("p" . sudoku-toggle-possibilities)
		   ("s" . sudoku-toggle-selected)
		   ("j" . sudoku-jump-other-board)
		   ([tab] . sudoku-tab)
		   ([left] . sudoku-left)
		   ([right] . sudoku-right)
		   ([up] lambda () (interactive) (sudoku-vertical t))
		   ([down] lambda () (interactive) (sudoku-vertical nil))
		   ("0" . sudoku-right)
		   ("z" . sudoku-boss))))
 
  (loop for i from 1 to 9
		do (define-key sudoku-map (number-to-string i)
			 'sudoku-init-to))
  )
 
;;
;; movement commands and positioning
;;
 
(defun sudoku-on-board ()
  "Finds which board POINT is currently on"
  (if (get-text-property (point) 'sudoku-cell)
	  (if (or (not sudoku-possibles-display) (> (current-column)
												sudoku-possibilities-board-width))
		  'selected 'possibles)))
 
(defun sudoku-jump-other-board ()
  "If both selected and possibles display are visible, this jumps between
them"
  (interactive)
  (and sudoku-possibles-display sudoku-selected-display
	   (let ((cell (get-text-property (point) 'sudoku-cell)))
		 (if cell
			 (sudoku-goto-cell cell (equal (sudoku-on-board)
										   'possibles))
		   (beep)))))
 
(defun sudoku-vertical (up)
  "Moves up or down on a sudoku board
Remains on the current board and in the current column"
  (if (get-text-property (point) 'sudoku-cell)
	  (let ((column (current-column))
			(dir (if up -1 1))
			(start (point)))
		(forward-line dir)
		(forward-char column)
		(while (and (not (= start (point)))(not (get-text-property
												 (point) 'sudoku-cell)))
		  (forward-line dir)
		  (if (< column (- (line-end-position)
						   (line-beginning-position)))
			  (forward-char column))
		  (if up
			  (if (> 3 (previous-single-char-property-change
						(point) 'sudoku-cell))
				  (goto-char (point-max)))
			(if (> (next-single-char-property-change (point)
													 'sudoku-cell) (buffer-size))
				(goto-char 0)))))
	(if up (sudoku-left) (sudoku-right))))
 
(defun sudoku-right ()
  "Moves right on a sudoku board
When it reaches the edge continue to the next board, or wrap to the start"
  (interactive)
  (if (get-text-property (1+ (point)) 'sudoku-cell)
	  (forward-char 1)
	(goto-char (next-single-char-property-change (1+ (point))
												 'sudoku-cell))
	(if (> (point) (buffer-size))
		(goto-char (next-single-char-property-change 1
													 'sudoku-cell)))))
 
(defun sudoku-left ()
  "Moves left on a sudoku board
When it reaches the edge continue to the next board, or wrap to the end"
  (interactive)
  (if (get-text-property (1- (point)) 'sudoku-cell)
	  (forward-char -1)
	(goto-char (1- (previous-single-char-property-change (1- (point))
														 'sudoku-cell)))
	(if (= (point) 0)
		(goto-char (previous-single-char-property-change
					(buffer-size) 'sudoku-cell)))))
 
(defun sudoku-tab ()
  "Jumps to the beginning of the next cell
This remains on the same board. To move to the other one use 
the command \\[sudoku-jump-other-board]"
  (interactive)
  (let ((cell (get-text-property (point) 'sudoku-cell)))
	(if (not cell) (sudoku-right)
	  (setq cell (sudoku-next cell 'row))
	  (if (= 0 (cdr (nth 6 cell))) (setq cell (sudoku-next cell
														   'column)))
	  (sudoku-goto-cell cell (equal 'selected (sudoku-on-board))))))
 
;;;
;;; eye candy: set up my own button system for commands.
;;; Draws buttons at the bottom of the screen, change color 
;;; when pressed, perform a command when released
;;;
(setq sudoku-button-commands 
	  '((init ("Start play" sudoku-end-init)
			  ("Undo" sudoku-undo)
			  ("Quit" sudoku-quit))
		(play ("Undo" sudoku-undo)
			  ("Begin guess" sudoku-checkpoint)
			  ("Accept guess" sudoku-uncheckpoint)
			  ("Undo guess" sudoku-to-checkpoint ?p)
			  ("Restart" sudoku-to-checkpoint ?r)
			  ("Quit" sudoku-quit))
		(over ("Restart" sudoku-to-checkpoint ?r)
			  ("Quit" sudoku-quit))))
 
 
(defun sudoku-command-buttons (set)
  "Sets up command buttons according to the descriptor"
  (let ((point (point))
		(buffer-read-only nil)
		string length)
	(goto-char (point-max))
	(delete-region (line-beginning-position) (line-end-position))
	(mapc (lambda (x)
			(setq string (car x) length (length string))
			(put-text-property 0 length 'sudoku-command (cdr x)
							   string)
			(put-text-property 0 length 'face
							   'sudoku-button-face string)
			(insert "    " string)) 
		  (cdr (assoc set sudoku-button-commands)))))
 
(defun sudoku-show-button-press (event &optional face)
  "Changes the face of the button selected"
  (interactive "e")
  (mouse-set-point event)
  (if (get-text-property (point) 'sudoku-command)
	  (let ((start (previous-single-char-property-change (point) 'face))
			(end (next-single-char-property-change (point)
												   'face))
			(buffer-read-only nil))
		(put-text-property start end 'face (or face
											   'sudoku-button-pressed-face)))))
 
(defun sudoku-unpress-cancelled-button (event)
  "Bound to drag-mouse-1 so buttons will revert to unpressed face properly"
  (interactive "e")
  (sudoku-show-button-press (list 'mouse-1 (second event))
							'sudoku-button-face)
  (mouse-set-point event))
 
;;
;; checkpointing, undoing, redoing
;;
 
(defun sudoku-checkpoint (&optional noask)
  "Checkpoints the current state to allow easy recovery if guesses turn out
wrong
This will also change the display face of the new choices"
  (interactive)
  (if (or noask (y-or-n-p "Make a checkpoint here? "))
	  (let ((state (mapcar (lambda (cell) (cons (nth 7 cell) (copy-list
															  (car cell)))) sudoku-desc)))
		(setq sudoku-checkpoint-stack (cons state
											sudoku-checkpoint-stack))
		(sudoku-add-to-undo 'checkpoint)
		(or noask (message "Added checkpoint")))))
 
(defun sudoku-uncheckpoint ()
  "Removes a checkpoint
Since checkpoints change the display face, when a checkpoint is accepted
the face changes to the previous checkpoint face."
  (interactive)
  (if (< 1 (length sudoku-checkpoint-stack))
	  (let ((state (car sudoku-checkpoint-stack))
			(length (length sudoku-checkpoint-stack)))
		(mapc (lambda (cell) (if (equal (nth 7 cell) length) (setf
															  (nth 7 cell) (1- length)))) sudoku-desc)
		(setq sudoku-checkpoint-stack (cdr sudoku-checkpoint-stack))
		(setq sudoku-undo-list (delete* '(checkpoint)
										sudoku-undo-list :test 'equal))
		(sudoku-draw t)
		(message "deleted checkpoint")
		)))
 
(defun sudoku-to-checkpoint (&optional choice nodraw)
  "Restores the board to the selected state
This can be used both to restore the initial state or any later
states that have been saved by the solver"
  (interactive)
  (when (< 0 (length sudoku-checkpoint-stack))
	(let* ((restart (case (or choice (read-char (if (< 1 (length
														  sudoku-checkpoint-stack))

													"Revert to previous (p) or restart (r)? "

												  "Restart puzzle? ")))
					  ((?R ?r ?Y ?y) (setq
									  sudoku-checkpoint-stack (last sudoku-checkpoint-stack)) t)
					  ((?P ?p) nil)
					  (t (error "Unrecognized
reply")))))
	  (loop for cell in sudoku-desc
			for data in (car sudoku-checkpoint-stack)
			do (setf (nth 7 cell) (car data)
					 (car cell) (copy-list (cdr data))))
	  (if (listp sudoku-undo-list)
		  (setq sudoku-undo-list (nthcdr (position '(checkpoint)
												   sudoku-undo-list :test 'equal :from-end restart) sudoku-undo-list)))
	  (setq sudoku-redo-list nil)
	  (unless nodraw 
		(sudoku-draw t)
		(use-local-map sudoku-map)
		(message "reverted to checkpoint"))
	  )))
 
(defun sudoku-restart () 
  "Does a restart without any confirmation"
  (interactive) (sudoku-to-checkpoint ?r))
 
(defun sudoku-end-init ()
  "Terminates interactive initialization"
  (sudoku-command-buttons 'play)
  (sudoku-checkpoint t))
 
(defun sudoku-undo ()
  "Undoes the most recent command
This does more than just undoes the command, it also restores all the cells
to the state they were in before the command was executed"
  (interactive)
  (if sudoku-undo-list
	  (multiple-value-bind (command number cell contents cells) (car
																 sudoku-undo-list)
		(setq sudoku-redo-list (cons (car sudoku-undo-list)
									 sudoku-redo-list)
			  sudoku-undo-list (cdr sudoku-undo-list))
		(case command
		  ('checkpoint (setq sudoku-checkpoint-stack (cdr
													  sudoku-checkpoint-stack)))
		  ('remove (setf (car cell) (cons number (car cell)))
				   (sudoku-redraw-cell cell))
		  ('select (setf (car cell) contents
						 (nth 7 cell) nil)
				   (sudoku-redraw-cell cell)
				   (mapc (lambda (cell)
						   (setf (car cell) (cons
											 number (car cell)))
						   (sudoku-redraw-cell
							cell))
						 cells))
		  (t (error (format "Bad command on undo list: %s"
							command))))
		(sudoku-stats)
		(message "Undo!"))
	(message "Undo list empty")))
 
(defun sudoku-redo ()
  "Puts back a command removed with the \\[sudoku-undo] command"
  (interactive)
  (if sudoku-redo-list
	  (multiple-value-bind (command number cell) (car sudoku-redo-list)
		;; The REDO list gets erased whenever a command is executed,
		;; so protect it here by shadowing the real list
		(let ((sudoku-redo-list nil))
		  (case command
			('checkpoint (sudoku-checkpoint t))
			('remove (sudoku-remove number cell))
			('select (sudoku-choose number cell))
			(t (error (format "Corrupted redo list: %s"
							  command))))
		  )
		(setq sudoku-redo-list (cdr sudoku-redo-list))
		)
	(message "Redo list empty"))
  )
 
(defun sudoku-add-to-undo (&rest new)
  (setq sudoku-redo-list nil
		sudoku-undo-list (cons new sudoku-undo-list)))
 
;;
;; commands that change the game
;;
 
(defun sudoku-mouse-remove-choice (event)
  (interactive "e")
  (mouse-set-point event)
  (sudoku-remove-choice))
 
(defun sudoku-remove-choice ()
  "Removes the selected number from the possibilities"
  (interactive)
  (let ((point (point)))
	(sudoku-remove (- (char-after) ?0) (get-text-property (point)
														  'sudoku-cell))
	(goto-char point)))
 
(defun sudoku-remove (number cell)
  (sudoku-remove-from-cell number cell)
  (sudoku-add-to-undo 'remove number cell))
 
(defun sudoku-mouse-select-choice (event)
  (interactive "e")
  (sudoku-show-button-press event 'sudoku-button-face)
  (if (eq (sudoku-on-board) 'possibles)
	  (sudoku-select-choice)
	(let ((prop (get-text-property (point) 'sudoku-command)))
	  (if prop (eval prop)))
	))
 
(defun sudoku-select-choice ()
  "sets the selected number in the current square
Also clears the number from all relevent cells"
  (interactive)
  (let ((point (point)))
	(case (sudoku-on-board)
	  ('possibles (if (looking-at "[1-9]") (sudoku-choose (- (char-after) ?0)) (beep)))
	  ('selected (sudoku-input))
	  (t (beep)))
	(sudoku-stats)
	(goto-char point)))
 
(defun sudoku-init-to ()
  "initializes the current cell to the number which invoked the function"
  (interactive)
  (let ((cell (get-text-property (point) 'sudoku-cell))
		(point (point)))
	(if (not cell) (beep)
	  (sudoku-choose (- last-command-char ?0) cell)
	  (sudoku-stats)
	  (goto-char point)
	  (sudoku-right))))
 
(defun sudoku-input ()
  "Prompt for and read a number"
  (if (looking-at "\\.")
	  (let ((char (- (read-char "Enter digit or . : ") ?0)))
		(if (and (< 0 char) (< char 10)) (sudoku-choose char)
		  (or (= char (- ?. ?0)) (beep))))))
 
(defun sudoku-quiet-choose (number cell)
  (or (member number (car cell)) (error "Not a member of current cell"))
  (setf (car cell) (list number)
		(nth 7 cell) (length sudoku-checkpoint-stack))
  (append (sudoku-remove-from-set cell number 'row)
		  (sudoku-remove-from-set cell number 'column)
		  (sudoku-remove-from-set cell number 'square)))

(defun sudoku-choose (number &optional cell supress)
  "Update the data structures and the display with the selected number"
  (or cell (setq cell (get-text-property (point) 'sudoku-cell)))
  (sudoku-add-to-undo 'select number cell (car cell)
					  (sudoku-quiet-choose number cell))
  (or supress (sudoku-redraw-cell cell)))

(defun sudoku-redraw-cell (cell)
  (and sudoku-selected-display (sudoku-fill-selected-cell cell))
  (and sudoku-possibles-display (sudoku-fill-possibles-cell cell)))

(defun sudoku-remove-from-set (start number direction)
  "Remove a number from all other cells in a given set (across, down,
square)"
  (loop for i from 1 to 8
		for cell = (sudoku-next start direction) then (sudoku-next cell direction)
		if (sudoku-remove-from-cell number (setq cell (sudoku-next cell direction))) collect cell))
 
(defun sudoku-remove-from-cell (number cell)
  (when (member number (car cell))
	(setf (car cell) (delete number (car cell)))
	(if sudoku-possibles-display (sudoku-fill-possibles-cell cell))
	cell))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Set up and run
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun sudoku-make-data-struct ()
  "Builds an initial data structure for a game"
  ;; makes the sudoku data structure. It is a list of 81 cell descriptors
  ;; with the contents as described below.
  ;; I thought about making it an array, but it doesn't make that much
  ;; difference
  (let ((all (loop for row from 0 to 8
				   for nrow from (+ sudoku-top-row 2) by 4
				   for prow = (+ sudoku-top-row 2) then (+
														 prow (if (= 0 (mod row 3)) 2 1))
				   append (loop for col from 0 to 8
								for ncol = 3
								then (+ ncol (if (= 0 (mod col 3)) 7 6))
								for pcol = 2
								then (+ pcol (if (= 0 (mod col 3)) 4 1)) 
								collect
								(list (copy-list '(1 2 3 4 5 6 7 8 9)) ; list of possibilities

									  nil ; link to next across cell

									  nil ; link to next down cell

									  nil ; link to next square cell

									  (cons prow pcol) ; display location of selected

									  (cons nrow ncol) ; display location of possibles

									  (cons row col) ; logical location of cell

									  nil))))) ; checkpoint level
	;; fill in the links
	(loop for row from 0 to 72 by 9
		  for column from 0 to 8
		  for square = 0 then (+ square (if (= 0 (mod (+ square 3)
													  9)) 21 3))
		  do (loop repeat 9
				   for r-prev = nil then r
				   for c-prev = nil then c
				   for s-prev = nil then s
				   for r = row then (1+ r)
				   for c = column then (+ 9 c)
				   for s = square then (+ s (if (= 0 (mod
													  (1+ s) 3)) 7 1))
				   do (if r-prev
						  (setf (nth 1 (nth r-prev
											all)) (nth r all)
											(nth 2 (nth
													c-prev all)) (nth c all)
											(nth 3 (nth
													s-prev all)) (nth s all)))
				   finally (setf (nth 1 (nth r all)) (nth
													  row all)
								 (nth 2 (nth
										 c all)) (nth column all)
								 (nth 3 (nth
										 s all)) (nth square all)))
		  )
	all))
 
(defun sudoku (&optional file)
  "This is an environment for solving sudoku puzzles
 
It takes care of the bookkeeping needed to solve them and lets you
concentrate on the logic. If that is not good enough, it can also
provide hints of the next move, or actually solve the puzzles for you
and report the steps it used, and the reason for each step.
 
You can choose to view a board displaying all the filled cells and/or
one showing the possibilities remaining for each cell. You can also
undo recent moves, or checkpoint a state, make some guesses, and
return to it if it does not work.
 
To play start it up with \"M-x sudoku\". Or, you can visit a sudoku
puzzle that was saved from a sudoku buffer, or enther 'M-x
sudoku-mode' while visiting a file and it will try to figure out the
initial board.
 
In general you can either use the mouse to select cells, or move the
cursor to a cell, and either type a digit to fill in or RETURN to
select it, DEL or BACKSPACE to remove \(possibilities array only\). If
you read a file you can just start, otherwise you first need to select
the initial values and click \"Start playing\" on the bottom, or set a
checkpoint.
 
\\[sudoku] Start a new empty puzzle
\\[sudoku-17] Load a new game from Gordon Royle's collection of minimal 
initialization games
\\[sudoku-mode] Try interpreting the current buffer as sudoku data
\\[sudoku-save] Save the current puzzle
\\[sudoku-quit] Quit the current puzzle
 
Movement keys: arrows tab 0
1-9 Fill in the current cell with the entered digit
\\[sudoku-select-choice] Select the current number \(keyboard\)
\\[sudoku-mouse-select-choice] Select the current number \(pointer\)
\\[sudoku-remove-choice] Remove the current number as a possibility
\(keyboard\)
\(possibility array only\)
\\[sudoku-mouse-remove-choice] Remove the current number as a possibility
\(pointer\)
\(possibility array only\)
\\[sudoku-undo] undo
\\[sudoku-redo] redo step that was just undone
 
\\[sudoku-checkpoint] Checkpoint current position. Future selections will be
in 
a different face
\\[sudoku-to-checkpoint] Restore position from  most recent checkpoint
\\[sudoku-restart] Restart from the initial position
\\[sudoku-uncheckpoint] Accept the results of the most recent guess and
delete the checkpoint
\\[sudoku-assist] Assist if you are stuck by suggesting the next move
\\[sudoku-solve] Uses heuristics to try to solve the puzzle
\\[sudoku-show-solution] Solves the puzzle and displays in a buffer the
steps used
 
\\[sudoku-jump-other-board] Jump to other board
\\[sudoku-toggle-selected] Toggle selected display
\\[sudoku-toggle-possibilities] Toggle possibilities display
\\[sudoku-draw] Redraw the display
\\[sudoku-boss] Boss key \(bury the buffer\)
 
\\[sudoku-customize] Set options in the emacs customization buffer
"
  (interactive)
  (let ((buffer (if sudoku-reuse-buffer "*sudoku*"
				  (loop with i = 0
						for buffer = "*sudoku*" then
						(format "*sudoku-%d*" (setq i (1+ i)))
						while (and (get-buffer
									buffer) (with-current-buffer buffer sudoku-desc))
						finally return buffer))))
	(switch-to-buffer (get-buffer-create buffer)))
  (sudoku-mode t))
 
(defun sudoku-mode (&optional new)
  (interactive)
  (unless (eq major-mode 'sudoku-mode)
	(kill-all-local-variables)
	(buffer-disable-undo)
	(make-variable-buffer-local 'sudoku-desc)
	(make-variable-buffer-local 'sudoku-saved-comment)
	(make-variable-buffer-local 'sudoku-undo-list)
	(make-variable-buffer-local 'sudoku-redo-list)
	(make-variable-buffer-local 'sudoku-checkpoint-stack)
	(use-local-map sudoku-map)
	(setq sudoku-desc (sudoku-make-data-struct)
		  sudoku-undo-list ()
		  sudoku-redo-list ()
		  sudoku-checkpoint-stack ()
		  buffer-read-only nil
		  major-mode 'sudoku
		  mode-name "sudoku")
	(unless new
	  (sudoku-convert-buffer)
	  (sudoku-end-init))
	(sudoku-draw)
	(sudoku-stats)
	(run-hooks'sudoku-mode-hooks)
	(setq buffer-read-only t)))
 
(defvar sudoku-17-file "d:Users/cn1yr030/emacs/sudoku-17"
  "Local location of Gordon Royle's database of minimal sudoku puzzles.
Available at http://www.csse.uwa.edu.au/~gordon/sudoku17")
 
(defun sudoku-17 (&optional which)
  "Gets a new game from Gordon Royle's list of minimal puzzles
These are puzzles with just 17 squares set, which is currently
believed \(but not proven\) to be the fewest possible.
 
\\[sudoku-17] gets a random puzzle from the database, or with a
prefix argument you can get a particular one."
  (interactive "P")
  (set-buffer (find-file-noselect sudoku-17-file))
  (let ((lines (count-lines 1 (buffer-size))))
	(or (numberp which)
		(setq which (random lines)))
	(if (or (> 0 which) (> which lines))
		(error "Must be between 0 and %d" lines)))
  (goto-line which)
  (let ((contents (buffer-substring (line-beginning-position)
									(line-end-position))))
	(sudoku)
	(setq sudoku-saved-comment (format "Gordon Royle's minimal puzzle #%d" which))
	(sudoku-create-from-string contents)
	(sudoku-checkpoint t)
	(sudoku-draw)))
 
;;;
;;; Create new games
;;;
;;; This is kind of cheating, I could not find a good way to generate
;;; real random games. I start with different completed games, permute
;;; the rows, columns, and numbers, and then eliminate numbers until
;;; it looks good.
(setq sudoku-boards 
 	  '("219835476784691352536274198321547689695128743478369215143986527952713864867452931"
		"286359741951467823743821956427936518569182437318745692674513289832694175195278364"
		))
 
 
(defun sudoku-create-from-string (string)
  (if sudoku-desc 
	  (loop for cell in sudoku-desc
			do (setf (car cell) (copy-list '(1 2 3 4 5 6 7 8 9))
					 (nth 7 cell) nil))
	(sudoku))
  (loop with failed = nil
		for value across string
		for cell in sudoku-desc
		do (setq value (- value ?0))
		(when (and (<= 1 value) (<= value 9))
		  (if (member value (car cell))
			  (setf (car cell) (list value)
					(nth 7 cell) -1
					failed (or (member nil
									   (sudoku-remove-from-set cell value 'row))
							   (member nil
									   (sudoku-remove-from-set cell value 'column))
							   (member nil
									   (sudoku-remove-from-set cell value 'square))))
			(setq failed t))
		  )
		if failed return nil
		finally return (not failed)
		)
  )
 
(defun sudoku-quit ()
  (interactive)
  (when (or (not sudoku-confirm-quit) (y-or-n-p "Really kill buffer? "))
	(set-buffer-modified-p nil)
	(kill-buffer nil)))
 
(defun sudoku-boss ()
  "bury the buffer quickly"
  (interactive)
  (if (get-buffer sudoku-boss-buffer) 
	  (switch-to-buffer sudoku-boss-buffer)
	(bury-buffer)))
 
(defun sudoku-customize ()
  (interactive)
  (customize-group 'sudoku))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Reading and writing files
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun sudoku-convert-buffer ()
  "Reads a file and tries to interpret it as sudoku input
If it is a file written by this package it recovers the full
state. If it is not written by this package it tries to guess
what the contents mean"
  (let ((desc sudoku-desc)
		(buffer-read-only nil))
	(goto-char 0)
	(if (looking-at ";-\\*-sudoku-\\*-")
		(sudoku-restore desc)
	  (sudoku-import desc))
	(erase-buffer))
  )
 
(defun sudoku-import (desc)
  "Tries to read an initial sudoku state from a submitted file
This is not used for files saved with SUDOKU-SAVE, see SUDOKU-RESTORE.
It assumes:
- the file starts on the first line
- empty cells are indicated by either ' ', '-' or '.', and
  a line is terminated by '\n'
- other characters (for instance '|') are ignored"
  (let* ((i 0)
		 (line 0)
		 (sudoku-possibles-display nil)
		 (sudoku-selected-display nil)
		 number)
	(goto-char 0)
	(while (and (< line 9) (re-search-forward "[-0. \n]\\|\\([1-9]\\)"
											  nil t))
	  (if (match-beginning 1) 
		  (sudoku-choose (- (aref (match-string 0) 0) ?0)
						 (nth (+ (* 9 line) i)
							  desc)))
	  (if (equal (match-string 0) "\n")
		  (setq line (1+ line) i 0)
		(if (< i 8) (setq i (1+ i))
		  (setq i 0 line (1+ line))
		  (forward-line 1))))))
 
(defvar sudoku-saved-comment "")
;;; Format: originally I just dumped the contents of the list and the
;;; face into a list to read. This worked, but for to reduce the file
;;; size (not really necessary, but just because) now if the cell is
;;; untouched (0-9) it stores it as nil, and if the cell has been
;;; selected it stores the face and the number, otherwise it just
;;; stores the contents. It cuts the size about in half (2k to 1k),
;;; and is not really that complicated.
(defun sudoku-save ()
  (interactive)
  "Saves a sudoku game so it can be restored later"
  (or buffer-file-name 
	  (let ((file (read-file-name "Save as: ")))
		(rename-buffer (file-name-nondirectory file))
		(setq buffer-file-name file)))
  (let ((desc sudoku-desc)
		(file buffer-file-name)
		(comment (read-from-minibuffer "Comment? "
									   sudoku-saved-comment)))
	(if (equal comment "") (setq comment sudoku-saved-comment)
	  (setq sudoku-saved-comment comment))
	(with-temp-buffer
	  (insert ";-*-sudoku-*-\nComment " comment "\n(setq
sudoku-init-data '(\n\n\n))  ")
	  (backward-char 5)
	  (mapc (lambda (cell) (insert (case (length (car cell))
									 (9
									  "()")
									 (1
									  (format "(-%d %s)" (caar cell) (nth 7 cell)))
									 (t
									  (format "%s" (car cell)))) "\n")) desc)
	  (setq buffer-file-name file)
	  (basic-save-buffer))

										;  (write-region 1 (buffer-size) file))
	(set-buffer-modified-p nil)))
 
;;; This suppresses the question about the file changing on disk
(defadvice ask-user-about-supersession-threat (around not-for-sudoku
													  activate)
  (or (equal major-mode 'sudoku) ad-do-it))
 
(defun sudoku-restore (desc)
  "Reads a sudoku state file saved by SUDOKU-SAVE"
  (or (re-search-forward "Comment \\(.*\\)\n\\((setq sudoku-init-data\\)"
						 nil t)
	  (error "This does not appear to be a sudoku file"))
  (let (sudoku-init-data)
	(setq sudoku-saved-comment (match-string 1))
	(eval-region (match-beginning 2) (buffer-size))
	(loop for cell in desc
		  for data in sudoku-init-data
		  do (if data (if (< 0 (car data))
						  (setf (car cell) data)
						(setf (car cell) (list (-
												(car data)))
							  (nth 7 cell)
							  (second data))
						(nth 0 cell) (cdr data))
			   (setf (nth 0 cell) (copy-list '(1 2 3 4 5 6 7 8
												 9))))
		  )))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Handle the statistics
;;
;; There could be a lot more done here, but I am starting to get tired
;; of this program. Currently it just gets a list of filled-in cells
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun sudoku-stats ()
  (save-excursion
	(let* ((buffer-read-only nil)
		   (stats (loop repeat 9
						for across = (car
									  sudoku-desc) then (sudoku-next-set across 'row)
						for down = (car sudoku-desc)
						then (sudoku-next-set down 'column)
						for square = (car
									  sudoku-desc) then (sudoku-next-set square 'square)
						collect (sudoku-stats-set
								 across 'row) into rows
						collect (sudoku-stats-set
								 down 'column) into columns
						collect (sudoku-stats-set
								 square 'square) into squares
						finally return (list rows
											 columns squares)))
		   (total (apply '+ (car stats)))
		   (message (if (> 0 total) "Oops - there is a problem, undo
and retry"
					  (if (= 81 total) (progn

										 (sudoku-command-buttons 'over)

										 "You Win!")
						(sudoku-command-buttons (if
													(= 0 (length sudoku-checkpoint-stack)) 'init 'play))
						(format "%d cells filled"
								total)))))
	  (goto-line 3)
	  (delete-region (line-beginning-position) (line-end-position))
	  (insert message)
	  total)))
 
(defun sudoku-stats-set (start direction)
  (loop repeat 9
		for cell = start then (sudoku-next cell direction)
		unless (car cell) return -100
		if (nth 7 cell) sum 1))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Utility functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun sudoku-goto-cell (cell selected &optional number)
  (let ((xy (if (and number (not selected)) 
				(cons (mod (1- number) 3) (/ (1- number) 3))
			  '(0 . 0)))
		(location (nth (if selected 4 5) cell)))
	(goto-line (+ (cdr xy) (car location)))
	(and selected sudoku-possibles-display (forward-char
											sudoku-possibilities-board-width))
	(forward-char (+ (car xy) (cdr location))))
  )
 
(defun sudoku-nth (cell which n)
  (loop repeat (1+ n)
		for c = cell then (sudoku-next c which)
		finally return c))
 
(defun sudoku-next (cell which)
  (nth (or (cdr (assoc which '((row . 1) (column . 2) (square . 3))))
		   (error (format "Bad arg '%s' to s2-next" which)))
	   cell))
 
(defun sudoku-next-set (cell type)
  "Finds the next set of the given TYPE following CELL
For example, the next column after the one headed by cell 0 is the
one headed by cell 1, or the next square after the one starting at 
cell 0 is the one starting at cell 3"
  (case type
	('row (sudoku-next cell 'column))
	('column (sudoku-next cell 'row))
	('square (if (< 5 (cdr (nth 6 cell)))
				 (setq cell (sudoku-nth cell 'column 3)))
			 (sudoku-nth cell 'row 3))
	('v-square (if (< 5 (car (nth 6 cell)))
				   (setq cell (sudoku-nth cell 'row 3)))
			   (sudoku-nth cell 'column 3))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Drawing
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; gets the proper face for drawing at the given checkpoint level
(defun sudoku-level-face (which)
  (if which
	  (if (< 0 which) 
		  (nth (mod (1- which) (length sudoku-face-choices))
			   sudoku-face-choices)
		'sudoku-initial-face)))
 
(defun sudoku-current-face (cell)
  "Finds the proper face to use to display the current choices
The faces come from the SUDOKU-FACE-CHOICES list, each checkpointed
level moves up to the next on the list"
  (sudoku-level-face (nth 7 cell)))
 
(defun sudoku-draw (&optional reuse-board)
  "Draws the entire sudoku buffer
If REUSE-BOARD is set it does not bother redrawing the board,
just writes over the cells"
  (interactive)
  (let ((buffer-read-only nil)
		(point (point)))
	(unless reuse-board
	  (erase-buffer)
	  (insert "Russell's Sudoku Helper; ? for help\n"
			  (or buffer-file-name "") " " sudoku-saved-comment)
	  (insert-char ?\n (1- sudoku-top-row))
	  (if sudoku-possibles-display
		  (sudoku-insert-blank-possibles-grid (car sudoku-desc)))
	  (if sudoku-selected-display 
		  (sudoku-insert-blank-selected-grid (car sudoku-desc)))
	  (goto-char (point-max))
	  (insert "\n")
	  (sudoku-command-buttons (if sudoku-checkpoint-stack 'play 'init))
	  )
	(if sudoku-possibles-display
		(mapc 'sudoku-fill-possibles-cell sudoku-desc))
	(if sudoku-selected-display
		(mapc 'sudoku-fill-selected-cell sudoku-desc))
	(goto-char point)))
 
;;;
;;; possibles grid
;;;
;;; The possibles grid shows the numbers that have not yet been
;;; eliminated from a cell
(defun sudoku-insert-blank-possibles-grid (cell)
  (let ((= (concat (make-string 59 ?=) "     \n"))
		(- (concat (make-string 59 ?-) "     \n"))
		(row "||     |     |     ||     |     |     ||     |     |     ||     \n"))
	(insert = row row row - row row row - row row row
			= row row row - row row row - row row row
			= row row row - row row row - row row row
			=)))

(defun sudoku-fill-possibles-cell (cell &optional face)
  (let ((buffer-read-only nil))
	(sudoku-goto-cell cell nil)
	(or face (setq face (sudoku-current-face cell)))
	(sudoku-insert-3 '(1 2 3) cell face)
	(sudoku-insert-3 '(4 5 6) cell face)
	(sudoku-insert-3 '(7 8 9) cell face)
	))
 
(defun sudoku-insert-3 (set cell face)
  (delete-char 3)
  (let* ((contents (car cell))
		 (column (current-column))
		 (string (mapconcat (lambda (x) (if (member x contents)
											(make-string 1 (+ ?0 x)) " ")) set "")))
	(or contents (setq string "XXX" face 'sudoku-error-face))
	(put-text-property 0 3 'sudoku-cell cell string)
	(put-text-property 0 3 'face face string)
	(insert string)
	;; NEXT-LINE appears to be broken
	(forward-line 1)
	(forward-char column)))
 
 
;;;
;;; selected grid
;;;
;;; This is the grid showing cells that have already been filled in
(defun sudoku-insert-blank-selected-grid (cell)
  (let ((- (make-string 19 ?-))
		(row "|     |     |     |")
		(location (fifth cell))
		(next-line-add-newlines t))
	(goto-line (1- (car location)))
	(end-of-line)
	(mapc (lambda (x) (insert x) (next-line 1))(list - row row row - row
													 row row - row row row -))))
 
(defun sudoku-fill-selected-cell (cell)
  (sudoku-goto-cell cell t)
  (let ((buffer-read-only nil)
		(face (sudoku-current-face cell))
		(string (if (nth 7 cell) (number-to-string (caar cell))
				  ".")))
	(if (= 0 (length (car cell)))
		(setq string "X"
			  face 'sudoku-error-face))
	(put-text-property 0 1 'sudoku-cell cell string)
	(put-text-property 0 1 'face face string)
	(delete-char 1)
	(insert string)))
 
(defun sudoku-toggle-possibilities ()
  (interactive)
  (setq sudoku-possibles-display (not sudoku-possibles-display))
  (if (or sudoku-possibles-display sudoku-selected-display)
	  (sudoku-draw)
	(sudoku-toggle-selected)))
 
(defun sudoku-toggle-selected ()
  (interactive)
  (setq sudoku-selected-display (not sudoku-selected-display))
  (if (or sudoku-possibles-display sudoku-selected-display)
	  (sudoku-draw)
	(sudoku-toggle-possibilities)))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Assistance
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
;;; Hints are provided by a series of heuristic algorithms arranged in
;;; order from short and simple to longer and more complex. They need
;;; to return nil if they cannot find a move, or non-nil if they
;;; succeed. Somewhere in their execution they need to call
;;; SUDOKU-HELP-RETURN if they succeed, where the move is reported,
;;; logged, and executed as necessary.
 
;;; When this is bound it holds:
;;; DELAY:  the amount of time to delay, nil for 0 or a positive int
;;; BUFFER: the buffer to log moves in
;;; COUNT:  the number of moves logged in the buffer, not including comments
(defconst sudoku-solution-state nil
  "Used to hold information during the sudoku solve function
Actually this is never written to, but bound with LET so it only has a
value in the necessary scope.")
 
 
(defconst sudoku-guess-stack ()
  "Keeps track of guesses to allow backtracking in case of error
Actually this is never written to, but bound with LET so it only has a
value in the necessary scope.")
 
;;; Applies the result of the search for assistance in the way
;;; required by the current state - that is, some combination of
;;; displaying the solution, executing it, or and logging it.
(defun sudoku-help-return (function cell number &rest args)
  (sudoku-goto-cell cell (not sudoku-possibles-display) number)
  (let ((continue t))
	(if (not sudoku-solution-state)
		(apply 'message args)
	  (apply 'sudoku-message args)
	  (if (not (car sudoku-solution-state))
		  (funcall function number cell)
		(when sudoku-possibles-display
		  (sudoku-fill-possibles-cell cell 'sudoku-error-face)
		  (unless (sit-for delay)
			(discard-input)
			(and (y-or-n-p "Quit solving? ") 
				 (setq delay 0
					   sudoku-solution-state nil))))
		(funcall function number cell)
		(unless (sit-for delay) 
		  (discard-input) 
		  (and (y-or-n-p "Quit solving? ")
			   (setq sudoku-solution-state nil)))))
	t))
 
;;; Displays the message in the appropriate way and updates state as
;;; needed
(defun sudoku-message (&rest args)
  (multiple-value-bind (delay buffer count string face count-string)
	  sudoku-solution-state
	(setq string (apply 'format args))
	(if (string-match "^[-+01]" string)
		(setq face 'sudoku-error-face
			  count-string ""
			  string (substring string 1))
	  (setq count (1+ count)
			count-string (number-to-string count)
			face (sudoku-level-face (1+ (length
										 sudoku-guess-stack)))))
	(if buffer
		(with-current-buffer buffer
		  (put-text-property 0 (length string) 'face face string)
		  (insert count-string "\t" string "\n"))

										;  (message string))
	  )
	(message string)
	(setf (third sudoku-solution-state) count)))
 
(defun sudoku-assist ()
  "Tries various heuristics to guess the next move.  If this fails it
means either the puzzle cannot be solved, you need to guess, or \(most
likely\) that it you need to find a cycle of length > 2 \(see
SUDOKU-CHECK-CYCLES\)"
  (interactive)
  (or (loop for check in sudoku-solution-heuristics
			   thereis (funcall check)
			   )
	  (progn (message "Sorry, I'm stuck")
			 nil)))
 
(defun sudoku-solve (&optional supress)
  "Solves the current sudoku puzzle
If the variable sudoku-solve-delay is > 0 it will pause for that long
in between moves so the user can kind of follow the progress. If the
possibles board is showing it will first jump to the next affected
cell and highlight it so you can have a chance to see what is
happening.
 
Any input event will offer you the choice of quitting the solver, so
to make it pause for longer hit any key"
  (interactive)
  (let* ((buffer-read-only nil)
		 (sudoku-guess-stack nil)
		 (use-guessing (member 'sudoku-guess sudoku-solution-heuristics))
		 (delay (if (and sudoku-solve-delay (< 0 sudoku-solve-delay)) sudoku-solve-delay))
		 (sudoku-solution-state (or sudoku-solution-state (list delay nil 0 0)))
		 solved)
	(while (and sudoku-solution-state
				(< (setq solved (sudoku-stats)) 81) 
				(if (<= 0 solved) (sudoku-assist)
				  (and use-guessing (sudoku-next-guess nil)))))
	(if sudoku-solution-state (sudoku-message (if (= solved 81) "1Solved!"
												(if (> 0 solved) "0Puzzle cannot be solved (I think)"
												  "0I am stuck, you need to guess"))))
	(or supress (message "Solver finished"))
	(= solved 81)))

(defun sudoku-show-solution ()
  "Solve the puzzle and show the logic used to find it
This calls SUDOKU-SOLVE with the environment set up properly to put
the steps in a buffer"
  (interactive)
  (let* ((buffer-name (buffer-name))
		 (buffer (concat "*"
						 (progn (string-match
								 "\\*?\\([^*]*\\)" buffer-name) (match-string 1 buffer-name))
						 "-solution*"))
		 (sudoku-solution-state (list nil buffer 0)))
	(with-current-buffer (get-buffer-create buffer)
	  (setq buffer-read-only nil)
	  (erase-buffer))
	(sudoku-solve)
	(switch-to-buffer buffer)
	(goto-char 0)
	(setq buffer-read-only t)))
 
;;; Following are the different check methods. You can choose which to
;;; include by setting the variable SUDOKU-SOLUTION-HEURISTICS. There
;;; are currently 5, counting guessing. Actually only one is needed,
;;; SUDOKU-CHECK-CYCLES should find everything else, but the others
;;; are there to mimic the way I (and most people, I think) solve -
;;; first check the easy possibilities, then progressively go to the
;;; harder ones. As a result, the solution generated by
;;; SUDOKU-SHOW-SOLUTION should pretty much be the same as a person
;;; would get by solving it.
 
;;; First check: simply check for cells with a single possibility
(defun sudoku-check-singles ()
  (let ((hint (loop for cell in sudoku-desc
					if (and (= 1 (length (car cell)))
							(not (nth 7 cell)))
					return cell)))
	(if hint (sudoku-help-return 'sudoku-choose hint (caar hint) "Single value %d in cell %s" (caar hint) (nth 6 hint)))))
 
;;; second check: check for 3 rows/columns with a number set in 2 of
;;; the intersecting squares, where there is only one possibility for
;;; that number in the 3rd.
;;; Example: the square X must be 1 in the following fragment
;;; ...|...|..1
;;; -----------
;;; 123|...|...
;;; ...|123|...
;;; ...|...|.X.
;;; -----------
;;; ...|...|1..
;;;
;;; These cases all are caught by check 3 (sudoku-check-only) as well.
;;; I have included it as another case because this type is fairly
;;; easy to check for on a partially completed puzzle, without needing
;;; to see the remaining possibilities. If you don't want it remove it
;;; from SUDOKU-SOLUTION-HEURISTICS
(defun sudoku-check-empty ()
  (setq c (car sudoku-desc) c1 (car sudoku-desc))
  (or (sudoku-check-empty-sets c 'column)
	  (sudoku-check-empty-sets (setq c (sudoku-next-set c 'square))
							   'column)
	  (sudoku-check-empty-sets (sudoku-next-set c 'square) 'column)
	  (sudoku-check-empty-sets c1 'row)
	  (sudoku-check-empty-sets (setq c1 (sudoku-next-set c1 'v-square))
							   'row)
	  (sudoku-check-empty-sets (sudoku-next-set c1 'v-square) 'row)))
 
(defun sudoku-check-empty-sets (cell dir)
  (let* ((start cell)
		 (set-0 (sudoku-get-filled cell dir))
		 (set-1 (sudoku-get-filled (setq cell (sudoku-next-set cell
															   dir)) dir))
		 (set-2 (sudoku-get-filled (setq cell (sudoku-next-set cell
															   dir)) dir)))
	(or (sudoku-check-empty-square (sudoku-check-empty-pairs set-0 set-1
															 set-2) dir)
		(sudoku-check-empty-square (sudoku-check-empty-pairs set-0
															 set-2 set-1) dir)
		(sudoku-check-empty-square (sudoku-check-empty-pairs set-1
															 set-2 set-0) dir))))
 
(defun sudoku-check-empty-square (possibilities dir)
  (let ((found ())
		poss)
	(while (and possibilities (not (= 1 (length found))))
	  (setq poss (car possibilities)
			possibilities (cdr possibilities)
			found (loop with start = (* 3 (- 3 (/ (nth 1 poss)
												  3) (/ (nth 2 poss) 3)))
						repeat 3
						with number = (car poss)
						for c = (sudoku-nth (nth 3
												 poss) dir start) then (sudoku-next c dir)
						if (member number (car c))
						collect c)))
	(if (= 1 (length found))
		(sudoku-help-return 'sudoku-choose (car found) (car poss)
							"Number %s is in neighboring %ss but not this square, only one possibility"
							(car poss) dir))))
 
(defun sudoku-check-empty-pairs (first second third)
  (let ((x (cdr first))
		(y (cdr second))
		(z (cdr third)))
	(loop with num2
		  for num in x
		  if (and (not (assoc (car num) z)) (setq num2 (assoc (car
															   num) y)))
		  collect (list (car num) (cdr num) (cdr num2) (car third)))
	))
 
(defun sudoku-get-filled (start dir)
  (cons start
		(loop for i from 0 to 8
			  for cell = start then (sudoku-next cell dir)
			  append (if (= 1 (length (car cell))) (list (cons
														  (caar cell) i)))))
  )
 
;;; third check: check for rows, columns, or squares where a
;;; particular number only appears once
;;; Checks all rows, columns, and squares in the puzzle
(defun sudoku-check-only ()
  (or (sudoku-check-only-dir 'row)
	  (sudoku-check-only-dir 'column)
	  (sudoku-check-only-dir 'square)))

(defun sudoku-check-only-dir (dir)
  (loop repeat 9
		for cell = (car sudoku-desc) then (sudoku-next-set cell dir)
		if (sudoku-check-only-set cell dir) return t))
 
(defun sudoku-check-only-set (start dir)
  (let* ((result (loop repeat 9
					   with none = '(1 2 3 4 5 6 7 8 9)
					   with once = ()
					   for cell = start then
					   (sudoku-next cell dir)
					   do (mapc (lambda (x) (if (assoc x
													   once) 

												(setq once (delete* x once :test (lambda (x entry) (= x (car entry)))))

											  (when (member x none)

												(setq none (remove x none))

												(or (nth 7 cell) (setq once (cons (list x cell) once))))))
								(car cell))
					   unless (or none once) return nil
					   ;; not really necessary
					   finally return once))
		 (hint (car result)))
	(if hint
		(sudoku-help-return 'sudoku-choose (second hint) (car hint) 
							"Only occurence of %s in %s in cell %s" (car hint) dir (nth 6 (second hint))))
	))

;;; fourth check: look for cycles. A cycle is a group of n cells in a
;;; single [row column square] where the union of the possible
;;; contents contains exactly n digits. Example: a row has cells that
;;; contains (2, 3), (3, 4), and (2, 3, 4). Any other cell in that row
;;; cannot contain 2, 3, or 4
;;;
;;; checking for cycles is fairly slow and not something that is easy
;;; to do without the computer, so it should go last. I added a couple
;;; of things to optimize it: first, prune any branches which have
;;; already appeared in a lower cycle, and second, if a cycle can
;;; clear more than a single cell cache the other cells and redo
;;; them. Together these cut solution time in half for a test puzzle
;;; that needs to look for cycles a few times.
 
(defun sudoku-check-cycles ()
  ;; speed enhancement: keep track if a cell is in a cycle for a set,
  ;; and if it is it is no longer needed to test it for longer cycles
  ;; in that direction. There may be a way to use this for another
  ;; check to eliminate (or lessen) the need for guessing
  (loop for cell in sudoku-desc
		do (setf (nthcdr 8 cell) (list nil)))
  (loop with result
		for i from 2 to sudoku-max-cycle-check
		thereis (sudoku-n-cycles i))
  )
 
;;; looks for cycles of length of n
(defun sudoku-n-cycles (n)
  (loop with result
		repeat 9
		for down = (car sudoku-desc) then (sudoku-next-set down
														   'column)
		for across = (car sudoku-desc) then (sudoku-next-set across
															 'row)
		for square = (car sudoku-desc) then (sudoku-next-set square
															 'square)
		thereis (or (sudoku-n-cycles-dir n across 'row () () 9)
					(sudoku-n-cycles-dir n down 'column
										 () () 9)
					(sudoku-n-cycles-dir n square
										 'square () () 9))
		)
  )
 
;;; recursively finds cycles of length n, given a starting point
(defun sudoku-n-cycles-dir (n start dir members cycle remaining)
  (loop for i from 1 to remaining
		with union
		for cell = start then (sudoku-next cell dir)
		thereis (unless (member dir (nth 8 cell)) ;; suppress check if the cell is already in a cycle
				  (setq union (union cycle (car cell)))
				  (if (and (not (nth 7 cell)) (<= (length
												   union) n))
					  (if (< (length members) (1- n))
						  (sudoku-n-cycles-dir n
											   (sudoku-next cell dir) dir (cons cell members) union (- remaining i))
						(setf (nth 8 cell) (cons dir
												 (nth 8 cell)))

						(sudoku-cycles-check-outsiders dir union (cons cell members) "")
						))))
  )
 
;;; a cycle has been found, see if it affects any other cells. If not
;;; the program should keep on looking, if it does then it has
;;; finished
(defun sudoku-cycles-check-outsiders (dir cycle members cached)
  (loop repeat 9
		with found
		for cell = (car members) then (sudoku-next cell dir)
		do (or (find cell members) (setq found (intersection (car cell) cycle)))
		if found return (progn (setq sudoku-current-cycle (list dir	cycle members "(cached) "))
							   (sudoku-help-return 'sudoku-remove cell (car found)
												   "%s%d-cycle %s in %s, can remove %d from %s" cached (length cycle) cycle 
												   
												   dir

												   (car found) (nth 6 cell)))))
 
;;; method 4-a: finding cycles is kind of expensive, and then it only
;;; sets a single cell even though there might be others it solves as
;;; well. If a previous cycle was found and not completely used this
;;; uses that cycle to see if any others can be cleared, saving time.
;;;
;;; It can either be at the head of SUDOKU-SOLUTION-HEURISTICS, or
;;; just before SUDOKU-CHECK-CYCLES
 
(defvar sudoku-current-cycle nil
  "cache any possibilities after a cycle is found so they can be
filled in for free next time")
 
(defun sudoku-finish-clearing-cycle ()
  (if sudoku-current-cycle 
	  (or (apply 'sudoku-cycles-check-outsiders sudoku-current-cycle)
		  (setq sudoku-current-cycle nil))))
 
;;; fifth: guessing. I do not know of another approach after the above
;;; all fail besides looking ahead in one way or another.
;;;
;;; Guessing chooses a cell with the fewest possibilities, chooses one
;;; of them, and continues. If the branch fails it will backtrack to
;;; the preceeding guess and change that, or if all have been
;;; exhausted it will jump to an earlier guess.
;;; This should only run during SOLVE or SHOW, in ASSIST it will
;;; just report no possibilities can be found.
(defun sudoku-guess ()
  (if sudoku-solution-state	;;  make sure this is only done during SOLVE
	  (let ((guess-cell (loop with min = 9
							  with champ = (car
											sudoku-desc)
							  for cell in
							  sudoku-desc
							  do (if (and (not
										   (nth 7 cell)) (< (length (car cell)) min)) 

									 (setq min (length (car cell)) champ cell))
							  until (= min 2)
							  finally return
							  champ)))
		(setq sudoku-guess-stack (cons (cons guess-cell (car
														 guess-cell)) sudoku-guess-stack))
		(sudoku-checkpoint t)
		(sudoku-next-guess t))
	(message "Sorry, I can't help you, try guessing")))
 
(defun sudoku-next-guess (first)
  (let* ((cell (caar sudoku-guess-stack))
		 (remaining (cdar sudoku-guess-stack))
		 (number (car remaining)))
	(sudoku-message (if first "+All heuristics failed, guess %d"
					  "0Guess %d failed, trying next value for cell %s") (length sudoku-guess-stack) (nth 6 cell))
	(if (not remaining) 
		(progn 
		  (sudoku-message "-All guesses at %s failed, backing off"
						  (nth 6 cell))
		  (sudoku-uncheckpoint)
		  (if (setq sudoku-guess-stack (cdr sudoku-guess-stack))
			  (sudoku-next-guess nil)
			))
	  (sudoku-to-checkpoint ?p)
	  (sudoku-choose (car remaining) cell)
	  (setf (cdar sudoku-guess-stack) (cdr remaining))
	  (sudoku-help-return 'sudoku-choose cell number "Guessing value of %d at %s" number (nth 6 cell)))))

(provide 'sudoku)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Experimental: generate games
;;
;; I looked into generating games, but it is not so simple (I
;; think). The only thing here that really works is shuffling - I
;; think the way to do this is make a database of different games, and
;; then use sudoku-shuffle-board to randomize the puzzle.
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun populate-board ()
  (loop with board = (loop repeat 9 collect (make-vector 9 0))
		with rows = (loop repeat 9 collect (list nil 0 1 2 3 4 5 6 7
												 8))
		for i from 1 to 9
		do (insert-number i board rows)
		finally return board))
  
(defun insert-number (num board remaining)
  (loop for row-num from 0
		for r-row in remaining
		for row in board
		for rest-of-board on (mapcar 'copy-list remaining)
		for this-row = (car rest-of-board)
		for col = (nth (random (length (cdr this-row))) (cdr
														 this-row))
		do (aset row col num)
										; set in result array
		(delete* col r-row)
										; remove from possibilities for later numbers
		(mapc (lambda (r) (delete* col r)) rest-of-board) ;
		remove from remaining columns for this num
		(remove-from-sq col row-num rest-of-board)
										; clean out rest of current square
		))
 
(defun remove-from-sq (col row-num rest-of-board)
  (loop repeat (- 2 (mod row-num 3))
		for row in (cdr rest-of-board)
		with start = (* 3 (/ col 3))
		do (delete* start row)
		(delete* (+ 1 start) row)
		(delete* (+ 2 start) row)
		)
  )
 
(defun sudoku-shuffle-board ()
  (let ((board (copy-seq (nth (random (length sudoku-boards))
							  sudoku-boards))))
	(loop repeat 81
		  with permuted = (shuffle-vector "123456789") 
		  for a across-ref board
		  do (setf a (aref permuted (- a ?1))))
	(sudoku-shuffle-set board '(54 63 72) t)
	(sudoku-shuffle-set board '(27 36 45) t)
	(sudoku-shuffle-set board '(0 9 18) t)
	(sudoku-shuffle-set board '(6 7 8) nil)
	(sudoku-shuffle-set board '(3 4 5) nil)
	(sudoku-shuffle-set board '(0 1 2) nil)
	board))

;;; randomly permute sets of 3 rows or columns
(defun sudoku-shuffle-set (board starts row)
  (mapc (lambda (x) (sudoku-swap-sets board (nth (car x) starts) (nth (cdr
																	   x) starts) (if row 1 9)))
		(nth (random 6) '(() ((0 . 1)) ((0 . 2)) ((1 . 2)) ((0 . 1)
															(1 . 2)) ((0 . 2) (1 . 2))))))
 
;;; swap the given 2 rows or columns in the board
(defun sudoku-swap-sets (board set0 set1 inc)
  (loop repeat 9
		with temp
		for s0 from set0 by inc
		for s1 from set1 by inc
		do (setf temp (aref board s0)
				 (aref board s0) (aref board s1)
				 (aref board s1) temp)))
 
(defun sudoku-create ()
  (interactive)
;  (sudoku-create-from-string (sudoku-shuffle-board))
  (sudoku-create-from-string (car sudoku-boards))
  (setq sudoku-saved-comment "Automatically generated puzzle"
		sudoku-desc
		(loop with sudoku-solution-heuristics = '(sudoku-finish-clearing-cycle 
												  sudoku-check-singles
												  sudoku-check-only
												  sudoku-check-cycles)
			  with sudoku-solution-state = '(nil nil 0)
			  with desc = sudoku-desc
			  with sudoku-desc = (sudoku-make-data-struct)
			  for i from 0
			  while (sudoku-reveal i desc)
			  finally return sudoku-desc
		))
  (sudoku-draw))

(defun sudoku-reveal (count desc)
  (setq sudoku-checkpoint-stack nil
		sudoku-undo-list nil)
  (let* ((unsolved (loop for cell in sudoku-desc
						 if (cdar cell) collect cell))
		 (cell (nth (random (length unsolved)) unsolved))
		 (which (nth 6 cell))
		 (value (caar (nth (+ (* 9 (car which)) (cdr which)) desc))))
	(sudoku-choose value cell)
	(not (when (< 17 count)
		   (sudoku-checkpoint t)
		   (prog1 (sudoku-solve t)
;			 (debug i (length unsolved))
			 (sudoku-to-checkpoint ?p t)))
	)))


 	  '("219835476784691352536274198321547689695128743478369215143986527952713864867452931")
;;; sudoku.el ends here