Screenshot of the Sudoku LTK GUI

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

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

tree->generator with explicit CPS

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
				    (lambda ()
				      (funcall 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.]

tree->generator in Common Lisp with cl-cont

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

Online repository for the Sudoku solver

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

LTK GUI for the Sudoku solver

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