1 ;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables
3 ;; Copyright (C) 2012 Free Software Foundation, Inc.
5 ;; Author: Carsten Dominik <carsten at orgmode dot org>
6 ;; Keywords: outlines, hypermedia, calendar, wp, games
7 ;; Homepage: http://orgmode.org
10 ;; This file is not yet part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 3, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;; This is a quick hack to create and solve SUDOKU games in org tables.
34 ;; org-sudoku-create Create a new SUDOKU game
35 ;; org-sudoku-solve-field Solve the field at point in a SUDOKU game
36 ;; (this is for cheeting when you are stuck)
37 ;; org-sudoku-solve Solve the entire game
47 (defvar org-sudoku-size
9
48 "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game.
49 Larger games do not seem to work because of limited resources - even though
50 the algorithm is general.")
52 (defvar org-sudoku-timeout
2.0
53 "Timeout for finding a solution when creating a new game.
54 After this timeout, the program starts over from scratch to create
57 ;;; Interactive commands
59 (defun org-sudoku-create (nfilled)
60 "Create a sudoku game."
61 (interactive "nNumber of pre-filled fields: ")
62 (let ((sizesq org-sudoku-size
)
64 (loop for i from
1 to org-sudoku-size do
65 (loop for j from
1 to org-sudoku-size do
66 (push (list (cons i j
) 0) game
)))
67 (setq game
(nreverse game
))
69 (setq game
(org-sudoku-build-allowed game
))
70 (setq game
(org-sudoku-set-field game
(cons 1 1)
71 (1+ (random org-sudoku-size
))))
76 (message "Attempt %d to create a game" (setq cnt
(1+ cnt
)))
77 (setq game1
(org-sudoku-deep-copy game
))
78 (setq game1
(org-sudoku-solve-game
79 game1
'random
(+ (float-time) org-sudoku-timeout
)))
82 (throw 'solved t
))))))
83 (let ((sqrtsize (floor (sqrt org-sudoku-size
))))
84 (loop for i from
1 to org-sudoku-size do
86 (if (and (= (mod i sqrtsize
) 0) (< i org-sudoku-size
))
90 (while (> (length game
) nfilled
)
91 (setq game
(delete (nth (1+ (random (length game
))) game
) game
)))
93 (org-table-put (caar e
) (cdar e
) (int-to-string (nth 1 e
))))
96 (org-table-goto-line 1)
97 (org-table-goto-column 1)
100 (defun org-sudoku-solve ()
101 "Solve the sudoku game in the table at point."
103 (unless (org-at-table-p)
104 (error "not at a table"))
106 (setq game
(org-sudoku-get-game))
107 (setq game
(org-sudoku-build-allowed game
))
108 (setq game
(org-sudoku-solve-game game
))
111 (org-table-put (caar e
) (cdar e
) (int-to-string (nth 1 e
))))
115 (defun org-sudoku-solve-field ()
116 "Just solve the field at point.
117 This works by solving the whole game, then inserting only the single field."
119 (unless (org-at-table-p)
120 (error "Not at a table"))
121 (org-table-check-inside-data-field)
122 (let ((i (org-table-current-dline))
123 (j (org-table-current-column))
125 (setq game
(org-sudoku-get-game))
126 (setq game
(org-sudoku-build-allowed game
))
127 (setq game
(org-sudoku-solve-game game
))
130 (org-table-put i j
(number-to-string
131 (nth 1 (assoc (cons i j
) game
)))
133 (org-table-goto-line i
)
134 (org-table-goto-column j
))
135 (error "No solution"))))
137 ;;; Internal functions
139 (defun org-sudoku-get-game ()
140 "Interpret table at point as sudoku game and read it.
141 A game structure is returned."
142 (let (b e g i j game
)
144 (org-table-goto-line 1)
145 (org-table-goto-column 1)
147 (org-table-goto-line org-sudoku-size
)
148 (org-table-goto-column org-sudoku-size
)
150 (setq g
(org-table-copy-region b e
))
157 (push (list (cons i j
)
158 (string-to-number v
))
164 (defun org-sudoku-build-allowed (game)
166 (loop for i from
1 to org-sudoku-size do
168 (setq numbers
(nreverse numbers
))
169 ;; add the lists of allowed values for each entry
172 (list (car e
) (nth 1 e
)
174 (copy-sequence numbers
)
177 ;; remove the known values from the list of allowed values
180 (setq i
(caar e
) j
(cdar e
) v
(cadr e
))
182 ;; We do have a value here
185 (setq a
(assoc f game
))
186 (setf (nth 2 a
) (delete v
(nth 2 a
))))
187 (cons (cons i j
) (org-sudoku-rel-fields i j
)))))
191 (defun org-sudoku-find-next-constrained-field (game)
192 (setq game
(mapcar (lambda (e) (if (nth 2 e
) e nil
)) game
))
193 (setq game
(delq nil game
))
196 (sort game
(lambda (a b
)
197 (setq va
(nth 1 a
) vb
(nth 1 b
)
198 la
(length (nth 2 a
)) lb
(length (nth 2 b
)))
200 ((and (= va
0) (> vb
0)) t
)
201 ((and (> va
0) (= vb
0)) nil
)
202 ((not (= (* va vb
) 0)) nil
)
204 (if (or (not game
) (> 0 (nth 1 (car game
))))
208 (defun org-sudoku-solve-game (game &optional random stop-at
)
210 If RANDOM is non-nit, select candidates randomly from a fields option.
211 If RANDOM is nil, always start with the first allowed value and try
213 STOP-AT can be a float time, the solver will abort at that time because
214 it is probably stuck."
215 (let (e v v1 allowed next g
)
217 (> (float-time) stop-at
))
220 (while (setq next
(org-sudoku-find-next-constrained-field game
))
221 (setq e
(assoc next game
)
225 (if (= (length allowed
) 1)
226 (setq game
(org-sudoku-set-field game next
(car allowed
)))
228 (setq g
(org-sudoku-deep-copy game
))
230 (setq v1
(car allowed
))
231 (setq v1
(nth (random (length allowed
)) allowed
)))
232 (setq g
(org-sudoku-set-field g next v1
))
233 (setq g
(org-sudoku-solve-game g random stop-at
))
239 (org-sudoku-unknown-field-p game
))
243 (defun org-sudoku-unknown-field-p (game)
244 "Are there still unknown fields in the game?"
245 (delq nil
(mapcar (lambda (e) (if (> (nth 1 e
) 0) nil t
)) game
)))
247 (defun org-sudoku-deep-copy (game)
248 "Make a copy of the game so that manipulating the copy does not change the parent."
250 (list (car e
) (nth 1 e
) (copy-sequence (nth 2 e
))))
253 (defun org-sudoku-set-field (game field value
)
254 "Put VALUE into FIELD, and tell related fields that they cannot be VALUE."
256 (setq i
(car field
) j
(cdr field
))
257 (setq a
(assoc field game
))
258 (setf (nth 1 a
) value
)
261 ;; Remove value from all related fields
264 (setq a
(assoc f game
))
265 (setf (nth 2 a
) (delete value
(nth 2 a
))))
266 (org-sudoku-rel-fields i j
))
269 (defun org-sudoku-rel-fields (i j
)
270 "Compute the list of related fields for field (i j)."
271 (let ((sqrtsize (floor (sqrt org-sudoku-size
)))
272 ll imin imax jmin jmax f
)
274 (loop for ii from
1 to org-sudoku-size do
275 (or (= ii i
) (push (cons ii j
) ll
)))
276 (loop for jj from
1 to org-sudoku-size do
277 (or (= jj j
) (push (cons i jj
) ll
)))
278 (setq imin
(1+ (* sqrtsize
(/ (1- i
) sqrtsize
)))
279 imax
(+ imin sqrtsize -
1))
280 (setq jmin
(1+ (* sqrtsize
(/ (1- j
) sqrtsize
)))
281 jmax
(+ jmin sqrtsize -
1))
282 (loop for ii from imin to imax do
283 (loop for jj from jmin to jmax do
284 (setq ff
(cons ii jj
))
290 ;;; org-sudoku ends here