contrib/lisp/org-sudoku.el

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