Here’s a screenshot of the GUI I presented in an earlier post, so you can take a look at it without installing LTK:

Screenshot of CL-Sudoku

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.)

This is just a little follow-up to my last post. As another exercise in continuations, I transformed tree->generator to explicit continuation-passing style. I guess I could also have looked at the expansions of the cl-cont macros, but this is the result of a manual transformation:

(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.]

I’ve decided to try Slava Akhmechet’s cl-cont, a continuations library for Common Lisp. My little example for this purpose was to port the tree->generator function from Teach Yourself Scheme in Fixnum Days to Common Lisp. This function takes a tree and returns a function that will successively yield the leaves of the tree.

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 just read about Bitbucket, a site that provides hosting for Mercurial repositories. So for the two purposes of trying it out and giving anyone interested easier access to the code, I put the files to the Sudoku solver up there. (This gives you a chance to get a working version of the GUI, because I forgot to publish the small change to the non-GUI code the GUI code depends on.)

My original plan, when I created this blog, was to evaluate several GUI toolkits for Common Lisp and write about that, but I didn’t find the time for it. Now LTK is a really simple, small library and so I was able to learn it quickly and now I made a GUI for my Sudoku solver from the previous post with it.

[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)))

I do realise this has been done multiple times already, but I wanted to publish something really programming-related in this blog finally.

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))