contrib/lisp/org-sudoku.el

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