293 lines
8.8 KiB
EmacsLisp
293 lines
8.8 KiB
EmacsLisp
;;; org-sudoku.el --- Create and solve SUDOKU games in Org tables -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2012-2021 Free Software Foundation, Inc.
|
|
;;
|
|
;; Author: Carsten Dominik <carsten.dominik@gmail.com>
|
|
;; Keywords: outlines, hypermedia, calendar, wp, games
|
|
;; Homepage: https://git.sr.ht/~bzg/org-contrib
|
|
;; Version: 0.01
|
|
;;
|
|
;; This file is not part of GNU Emacs.
|
|
;;
|
|
;; This program 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.
|
|
|
|
;; This program 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. If not, see <https://www.gnu.org/licenses/>.
|
|
;;
|
|
;;; 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 (game)
|
|
(cl-loop for i from 1 to org-sudoku-size do
|
|
(cl-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) game1)
|
|
(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))))
|
|
(cl-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 a)
|
|
(cl-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
|
|
;; FIXME unused.
|
|
;; 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)
|
|
;; FIXME: Unused, potential fault is logic.
|
|
;; 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 GAME.
|
|
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 a)
|
|
(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))
|
|
(cl-loop for ii from 1 to org-sudoku-size do
|
|
(or (= ii i) (push (cons ii j) ll)))
|
|
(cl-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))
|
|
(let (ff)
|
|
(cl-loop for ii from imin to imax do
|
|
(cl-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
|