emacs-orgmode@gnu.org archives
 help / color / mirror / code / Atom feed
blob bf9a69954688f862f59da233b14795f1aa00f8f5 8999 bytes (raw)
name: contrib/lisp/org-sudoku.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
 
;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables
;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp, games
;; Homepage: http://orgmode.org
;; Version: 0.01
;;
;; This file is not yet part of GNU Emacs.
;;
;; GNU Emacs 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 3, or (at your option)
;; any later version.

;; GNU Emacs 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;; Commentary:
;;
;; This is a quick hack to create and solve SUDOKU games in org tables.
;;
;; Commands:
;;
;; org-sudoku-create         Create a new SUDOKU game
;; org-sudoku-solve-field    Solve the field at point in a SUDOKU game
;;                           (this is for cheeting when you are stuck)
;; org-sudoku-solve          Solve the entire game
;;

;;; Code

(require 'org)
(require 'org-table)

;;; Customization

(defvar org-sudoku-size 9
  "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game.
Larger games do not seem to work because of limited resources - even though
the algorithm is general.")

(defvar org-sudoku-timeout 2.0
  "Timeout for finding a solution when creating a new game.
After this timeout, the program starts over from scratch to create
a game.")

;;; Interactive commands

(defun org-sudoku-create (nfilled)
  "Create a sudoku game."
  (interactive "nNumber of pre-filled fields: ")
  (let ((sizesq org-sudoku-size)
	game)
    (loop for i from 1 to org-sudoku-size do
	  (loop for j from 1 to org-sudoku-size do
		(push (list (cons i j) 0) game)))
    (setq game (nreverse game))
    (random t)
    (setq game (org-sudoku-build-allowed game))
    (setq game (org-sudoku-set-field game (cons 1 1)
				     (1+ (random org-sudoku-size))))
    (catch 'solved
      (let ((cnt 0))
	(while t
	  (catch 'abort
	    (message "Attempt %d to create a game" (setq cnt (1+ cnt)))
	    (setq game1 (org-sudoku-deep-copy game))
	    (setq game1 (org-sudoku-solve-game
			 game1 'random (+ (float-time) org-sudoku-timeout)))
	    (when game1
	      (setq game game1)
	      (throw 'solved t))))))
    (let ((sqrtsize (floor (sqrt org-sudoku-size))))
      (loop for i from 1 to org-sudoku-size do
	    (insert "| |\n")
	    (if (and (= (mod i sqrtsize) 0) (< i org-sudoku-size))
		(insert "|-\n")))
      (backward-char 5)
      (org-table-align))
    (while (> (length game) nfilled)
      (setq game (delete (nth (1+ (random (length game))) game) game)))
    (mapc (lambda (e)
	    (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e))))
	  game)
    (org-table-align)
    (org-table-goto-line 1)
    (org-table-goto-column 1)
    (message "Enjoy!")))

(defun org-sudoku-solve ()
  "Solve the sudoku game in the table at point."
  (interactive)
  (unless (org-at-table-p)
    (error "not at a table"))
  (let (game)
    (setq game (org-sudoku-get-game))
    (setq game (org-sudoku-build-allowed game))
    (setq game (org-sudoku-solve-game game))
    ;; Insert the values
    (mapc (lambda (e)
	    (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e))))
	  game)
    (org-table-align)))

(defun org-sudoku-solve-field ()
  "Just solve the field at point.
This works by solving the whole game, then inserting only the single field."
  (interactive)
  (unless (org-at-table-p)
    (error "Not at a table"))
  (org-table-check-inside-data-field)
  (let ((i (org-table-current-dline))
	(j (org-table-current-column))
	game)
    (setq game (org-sudoku-get-game))
    (setq game (org-sudoku-build-allowed game))
    (setq game (org-sudoku-solve-game game))
    (if game
	(progn
	  (org-table-put i j (number-to-string
			      (nth 1 (assoc (cons i j) game)))
			 'align)
	  (org-table-goto-line i)
	  (org-table-goto-column j))
      (error "No solution"))))

;;; Internal functions

(defun org-sudoku-get-game ()
  "Interpret table at point as sudoku game and read it.
A game structure is returned."
  (let (b e g i j game)

    (org-table-goto-line 1)
    (org-table-goto-column 1)
    (setq b (point))
    (org-table-goto-line org-sudoku-size)
    (org-table-goto-column org-sudoku-size)
    (setq e (point))
    (setq g (org-table-copy-region b e))
    (setq i 0 j 0)
    (mapc (lambda (c)
	    (setq i (1+ i) j 0)
	    (mapc
	     (lambda (v)
	       (setq j (1+ j))
	       (push (list (cons i j)
			   (string-to-number v))
		     game))
	     c))
	  g)
    (nreverse game)))

(defun org-sudoku-build-allowed (game)
  (let (i j v numbers)
    (loop for i from 1 to org-sudoku-size do
	  (push i numbers))
    (setq numbers (nreverse numbers))
    ;; add the lists of allowed values for each entry
    (setq game (mapcar
		(lambda (e)
		  (list (car e) (nth 1 e)
			(if (= (nth 1 e) 0)
			    (copy-sequence numbers)
			  nil)))
		game))
    ;; remove the known values from the list of allowed values
    (mapc
     (lambda (e)
       (setq i (caar e) j (cdar e) v (cadr e))
       (when (> v 0)
	 ;; We do have a value here
	 (mapc
	  (lambda (f)
	    (setq a (assoc f game))
	    (setf (nth 2 a) (delete v (nth 2 a))))
	  (cons (cons i j) (org-sudoku-rel-fields i j)))))
     game)
    game))

(defun org-sudoku-find-next-constrained-field (game)
  (setq game (mapcar (lambda (e) (if (nth 2 e) e nil)) game))
  (setq game (delq nil game))
  (let (va vb la lb)
    (setq game
	  (sort game (lambda (a b)
		       (setq va (nth 1 a) vb (nth 1 b)
			     la (length (nth 2 a)) lb (length (nth 2 b)))
		       (cond
			((and (= va 0) (> vb 0)) t)
			((and (> va 0) (= vb 0)) nil)
			((not (= (* va vb) 0)) nil)
			(t (< la lb))))))
    (if (or (not game) (> 0 (nth 1 (car game))))
	nil
      (caar game))))

(defun org-sudoku-solve-game (game &optional random stop-at)
  "Solve GAME.
If RANDOM is non-nit, select candidates randomly from a fields option.
If RANDOM is nil, always start with the first allowed value and try
solving from there.
STOP-AT can be a float time, the solver will abort at that time because
it is probably stuck."
  (let (e v v1 allowed next g)
    (when (and stop-at
	       (> (float-time) stop-at))
      (setq game nil)
      (throw 'abort nil))
    (while (setq next (org-sudoku-find-next-constrained-field game))
      (setq e (assoc next game)
	    v (nth 1 e)
	    allowed (nth 2 e))
      (catch 'solved
	(if (= (length allowed) 1)
	    (setq game (org-sudoku-set-field game next (car allowed)))
	  (while allowed
	    (setq g (org-sudoku-deep-copy game))
	    (if (not random)
		(setq v1 (car allowed))
	      (setq v1 (nth (random (length allowed)) allowed)))
	    (setq g (org-sudoku-set-field g next v1))
	    (setq g (org-sudoku-solve-game g random stop-at))
	    (when g
	      (setq game g)
	      (throw 'solved g)))
	  (setq game nil))))
    (if (or (not game)
	    (org-sudoku-unknown-field-p game))
	nil
      game)))

(defun org-sudoku-unknown-field-p (game)
  "Are there still unknown fields in the game?"
  (delq nil (mapcar (lambda (e) (if (> (nth 1 e) 0) nil t)) game)))

(defun org-sudoku-deep-copy (game)
  "Make a copy of the game so that manipulating the copy does not change the parent."
  (mapcar (lambda(e)
	    (list (car e) (nth 1 e) (copy-sequence (nth 2 e))))
	  game))

(defun org-sudoku-set-field (game field value)
  "Put VALUE into FIELD, and tell related fields that they cannot be VALUE."
  (let (i j)
    (setq i (car field) j (cdr field))
    (setq a (assoc field game))
    (setf (nth 1 a) value)
    (setf (nth 2 a) nil)

    ;; Remove value from all related fields
    (mapc
     (lambda (f)
       (setq a (assoc f game))
       (setf (nth 2 a) (delete value (nth 2 a))))
     (org-sudoku-rel-fields i j))
    game))

(defun org-sudoku-rel-fields (i j)
  "Compute the list of related fields for field (i j)."
  (let ((sqrtsize (floor (sqrt org-sudoku-size)))
	ll imin imax jmin jmax f)
    (setq f (cons i j))
    (loop for ii from 1 to org-sudoku-size do
	  (or (= ii i) (push (cons ii j) ll)))
    (loop for jj from 1 to org-sudoku-size do
	  (or (= jj j) (push (cons i jj) ll)))
    (setq imin (1+ (* sqrtsize (/ (1- i) sqrtsize)))
	  imax (+ imin sqrtsize -1))
    (setq jmin (1+ (* sqrtsize (/ (1- j) sqrtsize)))
	  jmax (+ jmin sqrtsize -1))
    (loop for ii from imin to imax do
	  (loop for jj from jmin to jmax do
		(setq ff (cons ii jj))
		(or (equal ff f)
		    (member ff ll)
		    (push ff ll))))
    ll))

;;; org-sudoku ends here

debug log:

solving bf9a699 ...
found bf9a699 in https://list.orgmode.org/orgmode/87pqc9harc.fsf@Rainer.invalid/
found 768729c in https://git.savannah.gnu.org/cgit/emacs/org-mode.git
preparing index
index prepared:
100644 768729cd7b48ed6ffbe97dd5742d840880d23151	contrib/lisp/org-sudoku.el

applying [1/1] https://list.orgmode.org/orgmode/87pqc9harc.fsf@Rainer.invalid/
diff --git a/contrib/lisp/org-sudoku.el b/contrib/lisp/org-sudoku.el
index 768729c..bf9a699 100644

Checking patch contrib/lisp/org-sudoku.el...
Applied patch contrib/lisp/org-sudoku.el cleanly.

index at:
100644 bf9a69954688f862f59da233b14795f1aa00f8f5	contrib/lisp/org-sudoku.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).