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

Advertisements

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