Add org-sudoku to contrib directory

* contrib/lisp/org-sudoku.el: New file

contrib/README

@@ -46,6 +46,7 @@ org-registry.el          --- A registry for Org links
 org-screen.el            --- Visit screen sessions through Org-mode links
 org-secretary.el         --- Team management with org-mode
 org-special-blocks.el    --- Turn blocks into LaTeX envs and HTML divs
+org-sudoku.el            --- Create and solve SUDOKU puzzles in Org tables
 orgtbl-sqlinsert.el      --- Convert Org-mode tables to SQL insertions
 org-toc.el 	         --- Table of contents for Org-mode buffer
 org-track.el             --- Keep up with Org development

contrib/lisp/org-sudoku.el

@@ -0,0 +1,289 @@
+;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables
+;; Copyright (C) 2008 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