CL-Sudoku's LTK GUI, displaying its solutions to an empty puzzle

(This is from the latest version that you can find at Bitbucket, not from the one posted here.)

(defun tree->generator (tree)
  (let (generate-leaves)
    (setf generate-leaves
	  (lambda ()
	    (labels ((recur (tree cont)
		       (cond ((null tree) ; empty leaf: continue.
			      (funcall cont))
			     ((consp tree) ; recurse into branches:
			      (recur (car tree)
				     (lambda ()
				       (recur (cdr tree) cont))))
			     ('otherwise ; leaf with a value:
			      (setf generate-leaves ; update generator
				    cont)
			      tree))))	      ; and return the value.
	      (recur tree
		     (lambda () nil))))) ; return nil after exhaustion.
    (lambda ()
      (funcall generate-leaves))))

[EDIT: I realized the potential for further simplification right after publishing the post. So now the call to and return from generate-leaves in the above code aren't in CPS anymore, only recur has to be in CPS.]

Here’s the code:

(defun/cc tree->generator (tree)
  (let (generate-leaves)
    (setf generate-leaves
	  (lambda (caller)
	    (labels ((recur (tree)
		       (cond ((null tree))  ; empty leaf: continue
			     ((consp tree)  ; recurse into branches
			      (recur (car tree))
			      (recur (cdr tree)))
			     ('otherwise ; leaf with a value:
			      (call/cc
			       (lambda (rest-of-tree)
				 ;; update generator
				 (setf generate-leaves
				       (lambda (new-caller)
					 (setf caller new-caller)
					 (funcall rest-of-tree)))
				 ;; return the value
				 (funcall caller tree)))))))
	      (recur tree))
	    (funcall caller nil)))     ; return value after exhaustion
    (lambda ()
      (call/cc generate-leaves))))

The comments are my own, so I could understand how this function works. I did also add the explicit caller argument to generate-leaves, keeping variables as local as possible is generally a good thing (and I didn’t like those dummy values). These changes aren’t specific to CL, I did a Scheme version with those too.

There was one problem that took me quite some time to solve: (SETF SYMBOL-FUNCTION) will always operate on the global binding, so I couldn’t use LABELS to define generate-leaves. Therefore, I had to use this trick of splitting the definition into a LET and a SETF to get a local function definition that could modify its own binding. In contrast, porting the continuations stuff was easy: that worked just like in Scheme.

Here’s a little usage example:

CL-USER> (defparameter *g* (tree->generator '((1 2) (3 (4 5)))))
*G*
CL-USER> (funcall *g*)
1
CL-USER> (funcall *g*)
2
CL-USER> (funcall *g*)
3
CL-USER> (funcall *g*)
4
CL-USER> (funcall *g*)
5
CL-USER> (funcall *g*)
NIL

[I've posted a screenshot.]

So here’s the code:

(in-package #:sudoku-gui)

(defun main ()
  (let ((*wish-args* '("-name" "CL-Sudoku")))
    (with-ltk ()
      (let* ((f (make-instance 'frame))
	     (puzzle-frame (make-instance 'frame
					  :master f))
	     (button-frame (make-instance 'frame
					  :master f))
	     (fields (make-array '(9 9)))
	     (clear-button (make-instance 'button
					  :master button-frame
					  :text "Clear"
					  :command (lambda ()
						     (update-fields
						      (make-array
						       '(9 9)
						       :initial-element "")
						      fields))))
	     (solve-button (make-instance 'button
					  :master button-frame
					  :text "Solve"
					  :command (lambda ()
						     (update-fields
						      (solve-puzzle fields)
						      fields)))))
	(pack f)
	(pack puzzle-frame)
	(pack button-frame)
	(dotimes (row 3)
	  (dotimes (col 3)
	    (let ((box (make-box row col puzzle-frame fields)))
	      (grid box row col))))
	(pack clear-button :side :left)
	(pack solve-button :side :left)))))

(defun update-fields (array fields)
  (dotimes (row 9)
    (dotimes (col 9)
      (setf (text (aref fields row col))
	    (aref array row col)))))

(defun make-box (row col frame fields)
  (let ((box (make-instance 'labelframe
			    :master frame
			    :text "")))
    (dotimes (inner-row 3)
      (dotimes (inner-col 3)
	(let ((field (make-instance 'spinbox
				    :master box
				    :width 1
				    :relief "solid"
				    :values "[list {} 1 2 3 4 5 6 7 8 9]"
				    :wrap t)))
	  (grid field inner-row inner-col)
	  (setf (aref fields
		      (+ inner-row (* row 3))
		      (+ inner-col (* col 3)))
		field))))
    box))

(defun field-val (field)
  (let ((str (text field)))
    (and (plusp (length str))
	 (digit-char-p (char str 0)))))

(defun solve-puzzle (fields)
  (let ((array (make-array '(9 9) :initial-element nil)))
    (dotimes (row 9)
      (dotimes (col 9)
	(setf (aref array row col)
	      (field-val (aref fields row col)))))
    (solve-array array t)))

It’s almost uncommented, but should be understandable in spite of that because I used mostly very short functions with (hopefully) speaking names.

So here’s my code:

(defpackage sudoku
  (:use #:cl)
  (:export #:solve))

(in-package #:sudoku)

(defun empty-fields (array)
  (loop for row from 0 below 9
     nconc (loop for col from 0 below 9
	      when (null (aref array row col))
	      collect (cons row col))))

(defun legal-sudoku-p (array row col n)
  (and (unique-p n (array-row array row))
       (unique-p n (array-col array col))
       (unique-p n (array-box array row col))))

(defun unique-p (item seq)
  (= 1 (count item seq)))

(defun array-row (array row)
  (loop for col from 0 below 9 collect (aref array row col)))

(defun array-col (array col)
  (loop for row from 0 below 9 collect (aref array row col)))

(defun array-box (array row col)
  (loop
     with upper = (- row (mod row 3))
     and left = (- col (mod col 3))
     for i from 0 below 9
     collect (box-ref array upper left i)))

(defun box-ref (array upper left index)
  (multiple-value-bind (row col) (floor index 3)
    (aref array (+ upper row) (+ left col))))

(defun solve (lists &optional just-one)
  (let ((array (make-array '(9 9) :initial-contents lists)))
    (catch 'just-one
      (backtrace array (empty-fields array) just-one))))

(defun backtrace (array empty-fields just-one)
  (if (endp empty-fields)
      (if just-one
	  (throw 'just-one array)
	  (list (adjust-array		; this will copy the array
		 (make-array '(9 9) :displaced-to array)
		 '(9 9))))
      (loop
	 with row = (caar empty-fields)
	 and col = (cdar empty-fields)
	 for i from 1 to 9
	 do (setf (aref array row col) i)
	 when (legal-sudoku-p array row col i)
	 nconc (backtrace array (cdr empty-fields) just-one)
	 finally (setf (aref array row col) nil))))

Usage examples:

CL-USER> (time
	  (sudoku:solve '(( 3  nil nil  1   8   5   6   2   9 )
			  (nil nil  5  nil nil nil  8  nil  4 )
			  (nil  6   8  nil nil nil nil nil nil)
			  (nil nil nil  7  nil nil  5  nil nil)
			  (nil  2  nil nil  6  nil nil  8  nil)
			  (nil nil  3  nil nil  9  nil nil nil)
			  (nil nil nil nil  5  nil  1   6  nil)
			  ( 4  nil nil nil  3  nil nil nil nil)
			  ( 7  nil nil nil nil  2  nil nil nil))))
Evaluation took:
  1.093 seconds of real time
  1.056066 seconds of user run time
  0.008 seconds of system run time
  [Run times include 0.056 seconds GC run time.]
  0 calls to %EVAL
  0 page faults and
  41,767,504 bytes consed.
(#2A((3 4 7 1 8 5 6 2 9)
     (1 9 5 2 7 6 8 3 4)
     (2 6 8 3 9 4 7 5 1)
     (6 8 4 7 2 1 5 9 3)
     (9 2 1 5 6 3 4 8 7)
     (5 7 3 8 4 9 2 1 6)
     (8 3 9 4 5 7 1 6 2)
     (4 1 2 6 3 8 9 7 5)
     (7 5 6 9 1 2 3 4 8)))
CL-USER> (time
	  (sudoku:solve '(( 3  nil nil  1   8   5   6   2   9 )
			  (nil nil  5  nil nil nil  8  nil  4 )
			  (nil  6   8  nil nil nil nil nil nil)
			  (nil nil nil  7  nil nil  5  nil nil)
			  (nil  2  nil nil  6  nil nil  8  nil)
			  (nil nil  3  nil nil  9  nil nil nil)
			  (nil nil nil nil  5  nil  1   6  nil)
			  ( 4  nil nil nil  3  nil nil nil nil)
			  ( 7  nil nil nil nil  2  nil nil nil)) t))
Evaluation took:
  0.012 seconds of real time
  0.012001 seconds of user run time
  0.0 seconds of system run time
  0 calls to %EVAL
  0 page faults and
  499,712 bytes consed.
#2A((3 4 7 1 8 5 6 2 9)
    (1 9 5 2 7 6 8 3 4)
    (2 6 8 3 9 4 7 5 1)
    (6 8 4 7 2 1 5 9 3)
    (9 2 1 5 6 3 4 8 7)
    (5 7 3 8 4 9 2 1 6)
    (8 3 9 4 5 7 1 6 2)
    (4 1 2 6 3 8 9 7 5)
    (7 5 6 9 1 2 3 4 8))

So forget my previous post and the quick hack I presented there and just use dblatex, i.e. dblatex -bpdftex. Both calls will produce PDF output directly, but the second one goes directly from LaTeX to PDF, without intermediate steps of DVI and PS.

But neither of the necessary packages for this task which are mentioned in the HOWTO is in Ubuntu feisty. xmlto is there, but needs passivetex, which was in earlier Ubuntu releases, but was removed (It was removed from Debian, too.). fop is also not in Ubuntu, though it is in Debian.

But I found another package in Ubuntu: db2latex-xsl, which contains XSL stylesheets to turn DocBook XML into LaTeX with the help of a XSL processor like xsltproc. The LaTeX file can then be processed with pdflatex to produce PDF.

Here is the shell script I wrote for this:

$ cat ~/bin/db2latex
#!/bin/sh

PATH=/bin:/usr/bin

for i
do
    basename=`basename "$i" .xml`
    xsltproc -nonet -o "$basename.tex" \\
    /usr/share/xml/docbook/stylesheet/db2latex/latex/docbook.xsl "$i"
done

Call this with db2latex foo.xml and then pdflatex foo.tex to get a PDF file foo.pdf from a source file foo.xml.