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