org-sudoku.el 8.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289
  1. ;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables
  2. ;; Copyright (C) 2012-2018 Free Software Foundation, Inc.
  3. ;;
  4. ;; Author: Carsten Dominik <carsten at orgmode dot org>
  5. ;; Keywords: outlines, hypermedia, calendar, wp, games
  6. ;; Homepage: https://orgmode.org
  7. ;; Version: 0.01
  8. ;;
  9. ;; This file is not yet part of GNU Emacs.
  10. ;;
  11. ;; This program is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 3, or (at your option)
  14. ;; any later version.
  15. ;; This program is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  18. ;; GNU General Public License for more details.
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22. ;;
  23. ;;; Commentary:
  24. ;;
  25. ;; This is a quick hack to create and solve SUDOKU games in org tables.
  26. ;;
  27. ;; Commands:
  28. ;;
  29. ;; org-sudoku-create Create a new SUDOKU game
  30. ;; org-sudoku-solve-field Solve the field at point in a SUDOKU game
  31. ;; (this is for cheeting when you are stuck)
  32. ;; org-sudoku-solve Solve the entire game
  33. ;;
  34. ;;; Code
  35. (require 'org)
  36. (require 'org-table)
  37. ;;; Customization
  38. (defvar org-sudoku-size 9
  39. "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game.
  40. Larger games do not seem to work because of limited resources - even though
  41. the algorithm is general.")
  42. (defvar org-sudoku-timeout 2.0
  43. "Timeout for finding a solution when creating a new game.
  44. After this timeout, the program starts over from scratch to create
  45. a game.")
  46. ;;; Interactive commands
  47. (defun org-sudoku-create (nfilled)
  48. "Create a sudoku game."
  49. (interactive "nNumber of pre-filled fields: ")
  50. (let ((sizesq org-sudoku-size)
  51. game)
  52. (loop for i from 1 to org-sudoku-size do
  53. (loop for j from 1 to org-sudoku-size do
  54. (push (list (cons i j) 0) game)))
  55. (setq game (nreverse game))
  56. (random t)
  57. (setq game (org-sudoku-build-allowed game))
  58. (setq game (org-sudoku-set-field game (cons 1 1)
  59. (1+ (random org-sudoku-size))))
  60. (catch 'solved
  61. (let ((cnt 0))
  62. (while t
  63. (catch 'abort
  64. (message "Attempt %d to create a game" (setq cnt (1+ cnt)))
  65. (setq game1 (org-sudoku-deep-copy game))
  66. (setq game1 (org-sudoku-solve-game
  67. game1 'random (+ (float-time) org-sudoku-timeout)))
  68. (when game1
  69. (setq game game1)
  70. (throw 'solved t))))))
  71. (let ((sqrtsize (floor (sqrt org-sudoku-size))))
  72. (loop for i from 1 to org-sudoku-size do
  73. (insert "| |\n")
  74. (if (and (= (mod i sqrtsize) 0) (< i org-sudoku-size))
  75. (insert "|-\n")))
  76. (backward-char 5)
  77. (org-table-align))
  78. (while (> (length game) nfilled)
  79. (setq game (delete (nth (1+ (random (length game))) game) game)))
  80. (mapc (lambda (e)
  81. (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e))))
  82. game)
  83. (org-table-align)
  84. (org-table-goto-line 1)
  85. (org-table-goto-column 1)
  86. (message "Enjoy!")))
  87. (defun org-sudoku-solve ()
  88. "Solve the sudoku game in the table at point."
  89. (interactive)
  90. (unless (org-at-table-p)
  91. (error "not at a table"))
  92. (let (game)
  93. (setq game (org-sudoku-get-game))
  94. (setq game (org-sudoku-build-allowed game))
  95. (setq game (org-sudoku-solve-game game))
  96. ;; Insert the values
  97. (mapc (lambda (e)
  98. (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e))))
  99. game)
  100. (org-table-align)))
  101. (defun org-sudoku-solve-field ()
  102. "Just solve the field at point.
  103. This works by solving the whole game, then inserting only the single field."
  104. (interactive)
  105. (unless (org-at-table-p)
  106. (error "Not at a table"))
  107. (org-table-check-inside-data-field)
  108. (let ((i (org-table-current-dline))
  109. (j (org-table-current-column))
  110. game)
  111. (setq game (org-sudoku-get-game))
  112. (setq game (org-sudoku-build-allowed game))
  113. (setq game (org-sudoku-solve-game game))
  114. (if game
  115. (progn
  116. (org-table-put i j (number-to-string
  117. (nth 1 (assoc (cons i j) game)))
  118. 'align)
  119. (org-table-goto-line i)
  120. (org-table-goto-column j))
  121. (error "No solution"))))
  122. ;;; Internal functions
  123. (defun org-sudoku-get-game ()
  124. "Interpret table at point as sudoku game and read it.
  125. A game structure is returned."
  126. (let (b e g i j game)
  127. (org-table-goto-line 1)
  128. (org-table-goto-column 1)
  129. (setq b (point))
  130. (org-table-goto-line org-sudoku-size)
  131. (org-table-goto-column org-sudoku-size)
  132. (setq e (point))
  133. (setq g (org-table-copy-region b e))
  134. (setq i 0 j 0)
  135. (mapc (lambda (c)
  136. (setq i (1+ i) j 0)
  137. (mapc
  138. (lambda (v)
  139. (setq j (1+ j))
  140. (push (list (cons i j)
  141. (string-to-number v))
  142. game))
  143. c))
  144. g)
  145. (nreverse game)))
  146. (defun org-sudoku-build-allowed (game)
  147. (let (i j v numbers)
  148. (loop for i from 1 to org-sudoku-size do
  149. (push i numbers))
  150. (setq numbers (nreverse numbers))
  151. ;; add the lists of allowed values for each entry
  152. (setq game (mapcar
  153. (lambda (e)
  154. (list (car e) (nth 1 e)
  155. (if (= (nth 1 e) 0)
  156. (copy-sequence numbers)
  157. nil)))
  158. game))
  159. ;; remove the known values from the list of allowed values
  160. (mapc
  161. (lambda (e)
  162. (setq i (caar e) j (cdar e) v (cadr e))
  163. (when (> v 0)
  164. ;; We do have a value here
  165. (mapc
  166. (lambda (f)
  167. (setq a (assoc f game))
  168. (setf (nth 2 a) (delete v (nth 2 a))))
  169. (cons (cons i j) (org-sudoku-rel-fields i j)))))
  170. game)
  171. game))
  172. (defun org-sudoku-find-next-constrained-field (game)
  173. (setq game (mapcar (lambda (e) (if (nth 2 e) e nil)) game))
  174. (setq game (delq nil game))
  175. (let (va vb la lb)
  176. (setq game
  177. (sort game (lambda (a b)
  178. (setq va (nth 1 a) vb (nth 1 b)
  179. la (length (nth 2 a)) lb (length (nth 2 b)))
  180. (cond
  181. ((and (= va 0) (> vb 0)) t)
  182. ((and (> va 0) (= vb 0)) nil)
  183. ((not (= (* va vb) 0)) nil)
  184. (t (< la lb))))))
  185. (if (or (not game) (> 0 (nth 1 (car game))))
  186. nil
  187. (caar game))))
  188. (defun org-sudoku-solve-game (game &optional random stop-at)
  189. "Solve GAME.
  190. If RANDOM is non-nit, select candidates randomly from a fields option.
  191. If RANDOM is nil, always start with the first allowed value and try
  192. solving from there.
  193. STOP-AT can be a float time, the solver will abort at that time because
  194. it is probably stuck."
  195. (let (e v v1 allowed next g)
  196. (when (and stop-at
  197. (> (float-time) stop-at))
  198. (setq game nil)
  199. (throw 'abort nil))
  200. (while (setq next (org-sudoku-find-next-constrained-field game))
  201. (setq e (assoc next game)
  202. v (nth 1 e)
  203. allowed (nth 2 e))
  204. (catch 'solved
  205. (if (= (length allowed) 1)
  206. (setq game (org-sudoku-set-field game next (car allowed)))
  207. (while allowed
  208. (setq g (org-sudoku-deep-copy game))
  209. (if (not random)
  210. (setq v1 (car allowed))
  211. (setq v1 (nth (random (length allowed)) allowed)))
  212. (setq g (org-sudoku-set-field g next v1))
  213. (setq g (org-sudoku-solve-game g random stop-at))
  214. (when g
  215. (setq game g)
  216. (throw 'solved g)))
  217. (setq game nil))))
  218. (if (or (not game)
  219. (org-sudoku-unknown-field-p game))
  220. nil
  221. game)))
  222. (defun org-sudoku-unknown-field-p (game)
  223. "Are there still unknown fields in the game?"
  224. (delq nil (mapcar (lambda (e) (if (> (nth 1 e) 0) nil t)) game)))
  225. (defun org-sudoku-deep-copy (game)
  226. "Make a copy of the game so that manipulating the copy does not change the parent."
  227. (mapcar (lambda(e)
  228. (list (car e) (nth 1 e) (copy-sequence (nth 2 e))))
  229. game))
  230. (defun org-sudoku-set-field (game field value)
  231. "Put VALUE into FIELD, and tell related fields that they cannot be VALUE."
  232. (let (i j)
  233. (setq i (car field) j (cdr field))
  234. (setq a (assoc field game))
  235. (setf (nth 1 a) value)
  236. (setf (nth 2 a) nil)
  237. ;; Remove value from all related fields
  238. (mapc
  239. (lambda (f)
  240. (setq a (assoc f game))
  241. (setf (nth 2 a) (delete value (nth 2 a))))
  242. (org-sudoku-rel-fields i j))
  243. game))
  244. (defun org-sudoku-rel-fields (i j)
  245. "Compute the list of related fields for field (i j)."
  246. (let ((sqrtsize (floor (sqrt org-sudoku-size)))
  247. ll imin imax jmin jmax f)
  248. (setq f (cons i j))
  249. (loop for ii from 1 to org-sudoku-size do
  250. (or (= ii i) (push (cons ii j) ll)))
  251. (loop for jj from 1 to org-sudoku-size do
  252. (or (= jj j) (push (cons i jj) ll)))
  253. (setq imin (1+ (* sqrtsize (/ (1- i) sqrtsize)))
  254. imax (+ imin sqrtsize -1))
  255. (setq jmin (1+ (* sqrtsize (/ (1- j) sqrtsize)))
  256. jmax (+ jmin sqrtsize -1))
  257. (loop for ii from imin to imax do
  258. (loop for jj from jmin to jmax do
  259. (setq ff (cons ii jj))
  260. (or (equal ff f)
  261. (member ff ll)
  262. (push ff ll))))
  263. ll))
  264. ;;; org-sudoku ends here