From: Glen Able
Subject: newbie - more on my search program
Date: 
Message-ID: <cnsasi$ojq$1$8302bc10@news.demon.co.uk>
I've been fiddling with my 'su doku' search program.  I now pass a function
to the search which does whatever it wants when a solution is found, and
tells the search to either continue or stop.

So, to find a single solution and abort, I'd use:

(defun find-single-solution (grid)
  (fill-grid grid
             (lambda (grid)
               (print-grid grid)
               nil)))

Instead, to exhaustively count all solutions, I'd use:

(let ((solutions 0))
  (defun count-solutions (grid)
    (setf solutions 0)
    (fill-grid grid
               (lambda (grid)
                 (incf solutions)
                 t))
    solutions))

(Problem: the 'grid' argument is never used in the anonymous function, which
causes a warning.  Best way round this?)

(Question: is there a better way of handing the count?)

The recursive part is now:

(defun fill-grid (grid on-found)
  (let ((free-pos (first-free grid)))
    (if free-pos
        (let ((choices (remove-used
                        grid
                        free-pos
                        (list 1 2 3 4 5 6 7 8 9))))
          (if choices
              (dolist (fill-val choices)
                (fill-grid (next-grid grid free-pos fill-val)
                           on-found))))
      (funcall on-found grid))))

So, if there's space to fill in the grid, it carries on searching, and if
there's no space it funcalls the callback with the filled grid.
Now, my big problem is that I need to actually use the result from the
funcall to decide whether to continue.  So I need to be able to 'break' out
of the dolist loop if a child call to 'fill-grid' decides it has finished.
Can anyone help me achieve this?  I've been trying to do it with 'break' but
I'm not clear on exactly what it breaks from, and suspect there's probably
something cleaner I should be doing in the first place.

thanks,
G.A.

p.s. for the interested, full code is here, run with: (find-single-solution
(nov19)), comments welcomed.

(defun find-single-solution (grid)
  (fill-grid grid
             (lambda (grid)
               (print-grid grid)
               nil)))

(let ((solutions 0))
  (defun count-solutions (grid)
    (setf solutions 0)
    (fill-grid grid
               (lambda (grid)
                 (incf solutions)
                 t))
    solutions))

(defun nov19()
  (zero-to-nil
  #2a((0 0 0 0 3 0 7 0 0)
      (0 1 0 0 0 6 2 0 0)
      (0 0 0 4 7 0 9 0 8)
      (0 0 0 0 0 9 0 5 4)
      (0 0 0 7 0 3 0 0 0)
      (2 9 0 6 0 0 0 0 0)
      (9 0 8 0 4 5 0 0 0)
      (0 0 3 2 0 0 0 6 0)
      (0 0 5 0 6 0 0 0 0))))

(defun make-grid ()
    (make-array '(9 9) :initial-element nil))

(defun copy-grid (src)
  (let ((new-grid (make-grid)))
    (dotimes (row 9)
      (dotimes (col 9)
        (setf (aref new-grid
                    row
                    col)
          (aref src
                row
                col))))
    new-grid))

(defun zero-to-nil (grid)
  (dotimes (row 9)
    (dotimes (col 9)
      (if (eql (aref grid row col)
               0)
          (setf (aref grid row col)
            nil))))
  grid)

(defun show (value)
  (or value "."))

(defun print-row (grid row)
  (format t "~a ~a ~a | ~a ~a ~a | ~a ~a ~a ~%"
    (show (aref grid row 0))
    (show (aref grid row 1))
    (show (aref grid row 2))
    (show (aref grid row 3))
    (show (aref grid row 4))
    (show (aref grid row 5))
    (show (aref grid row 6))
    (show (aref grid row 7))
    (show (aref grid row 8))))

(defun print-grid (grid)
  (dotimes (row 9)
    (print-row grid row)
    (if (or (eql row 2) (eql row 5))
        (format t "------+-------+------~%"))))

(defun first-free-in-row (grid row)
  (dotimes (col 9)
    (if (not (aref grid
                   row
                   col))
        (return (cons row
                      col)))))

(defun first-free (grid)
  (dotimes (row 9)
    (let ((position (first-free-in-row grid row)))
      (if position
          (return position)))))

(defun remove-used-row (grid position list)
  (let ((row (car position)))
    (dotimes (col 9)
      (setf list
        (delete (aref grid
                      row
                      col) list))))
  list)

(defun remove-used-col (grid position list)
  (let ((col (cdr position)))
    (dotimes (row 9)
      (setf list
        (delete (aref grid
                      row
                      col) list))))
  list)

(defun remove-used-block (grid position list)
  (let ((row-start (* 3 (floor (/ (car position) 3))))
        (col-start (* 3 (floor (/ (cdr position) 3)))))
    (dotimes (row 3)
      (dotimes (col 3)
        (setf list
          (delete (aref grid
                        (+ row-start row)
                        (+ col-start col))
                  list)))))
  list)

(defun remove-used (grid position list)
  (remove-used-block grid
                     position
                     (remove-used-col grid
                                      position
                                      (remove-used-row grid
                                                       position
                                                       list))))

(defun next-grid (grid position new-value)
  (let ((next-grid (copy-grid grid)))
    (setf (aref next-grid
                (car position)
                (cdr position))
      new-value)
    next-grid))

(defun fill-grid (grid on-found)
  (let ((free-pos (first-free grid)))
    (if free-pos
        (let ((choices (remove-used
                        grid
                        free-pos
                        (list 1 2 3 4 5 6 7 8 9))))
          (if choices
              (dolist (fill-val choices)
                (fill-grid (next-grid grid free-pos fill-val)
                           on-found))))
      (funcall on-found grid))))
From: Kenny Tilton
Subject: Re: newbie - more on my search program
Date: 
Message-ID: <0wkod.20930$Vk6.7202@twister.nyc.rr.com>
Glen Able wrote:

> I've been fiddling with my 'su doku' search program.  I now pass a function
> to the search which does whatever it wants when a solution is found, and
> tells the search to either continue or stop.
> 
> So, to find a single solution and abort, I'd use:
> 
> (defun find-single-solution (grid)
>   (fill-grid grid
>              (lambda (grid)
>                (print-grid grid)
>                nil)))
> 
> Instead, to exhaustively count all solutions, I'd use:
> 
> (let ((solutions 0))
>   (defun count-solutions (grid)
>     (setf solutions 0)
>     (fill-grid grid
>                (lambda (grid)
>                  (incf solutions)
>                  t))
>     solutions))
> 
> (Problem: the 'grid' argument is never used in the anonymous function, which
> causes a warning.  Best way round this?)

(lambda (grid)
    (declare (ignore grid))
     ....

If you might want a debugging line in there at some point, you can say 
ignorable, in which case if you throw in a print statement you will not 
get an error.


> 
> (Question: is there a better way of handing the count?)
> 
> The recursive part is now:
> 
> (defun fill-grid (grid on-found)
>   (let ((free-pos (first-free grid)))
>     (if free-pos
>         (let ((choices (remove-used
>                         grid
>                         free-pos
>                         (list 1 2 3 4 5 6 7 8 9))))
>           (if choices
>               (dolist (fill-val choices)
>                 (fill-grid (next-grid grid free-pos fill-val)
>                            on-found))))
>       (funcall on-found grid))))
> 
> So, if there's space to fill in the grid, it carries on searching, and if
> there's no space it funcalls the callback with the filled grid.
> Now, my big problem is that I need to actually use the result from the
> funcall to decide whether to continue.  So I need to be able to 'break' out
> of the dolist loop if a child call to 'fill-grid' decides it has finished.
> Can anyone help me achieve this?  I've been trying to do it with 'break' but

break is guaranteed by the spec to put you in a backtrace. (AllegroCL 
gets this wrong, btw.)

The simplest way out is:

     (setf answer (catch :bingo! <etc>))

  and then anyone called can execute (throw :bingo! grid) to return the 
answer.

Or you could structure your code so that everyone returns as soon as 
they see that the search is over. You probably need to leverage Lisp's 
ability to return two values. eg, when the solution is identified, do:

    (values grid (funcall on-found grid))

Then in the dolist where you are repeatedly trying moves:

     (dolist ()
        ...
        (multiple-value-bind (solution keep-going)
            (unless keep-going
                 (return-from fill-grid (values solution nil)))

Or just code up DO or LOOP to watch for the termination notice.

kenny
From: Fred Gilham
Subject: Re: newbie - more on my search program
Date: 
Message-ID: <u7wtwdium4.fsf@snapdragon.csl.sri.com>
Kenny Tilton wrote:
> The simplest way out is:
> 
>      (setf answer (catch :bingo! <etc>))
> 
>   and then anyone called can execute (throw :bingo! grid) to return the 
> answer.

This seems like the right approach.  You have:

(defun find-single-solution (grid)
  (fill-grid grid
             (lambda (grid)
               (print-grid grid)
               nil)))

(let ((solutions 0))
  (defun count-solutions (grid)
    (setf solutions 0)
    (fill-grid grid
               (lambda (grid)
                 (incf solutions)
                 t))
    solutions))



To do what you want, just change find-single-solution to

(defun find-single-solution (grid)
  (catch 'found-solution
    (fill-grid grid
	       (lambda (grid)
		 (print-grid grid)
		 (throw 'found-solution nil)
		 nil))))



I tried this with the following puzzle that has multiple solutions (2,
apparently) and it seems to work OK.

(defun multi-solution ()
  (zero-to-nil
   #2a((9 0 0 0 0 0 0 0 8)
       (5 0 0 2 0 8 0 6 0)
       (0 0 0 3 7 1 0 0 9)
       (0 0 0 0 7 3 0 5 0)
       (2 0 0 0 0 0 0 0 4)
       (0 5 0 1 6 0 0 0 0)
       (8 0 0 0 2 7 3 0 0)
       (0 4 0 3 0 9 0 0 1)
       (7 0 0 0 0 0 0 0 2))))


Calling (find-single-solution (multi-solution)) gives

CL-USER> (find-single-solution (multi-solution))
9 2 3 | 5 4 6 | 7 1 8 
5 1 7 | 2 9 8 | 4 6 3 
4 6 8 | 3 7 1 | 5 2 9 
------+-------+------
1 8 9 | 4 7 3 | 2 5 6 
2 7 6 | 9 8 5 | 1 3 4 
3 5 4 | 1 6 2 | 9 8 7 
------+-------+------
8 9 1 | 6 2 7 | 3 4 5 
6 4 2 | 3 5 9 | 8 7 1 
7 3 5 | 8 1 4 | 6 9 2 
NIL

Calling (count-solutions (multi-solution)) gives

CL-USER> (count-solutions (multi-solution))
2

-- 
Fred Gilham                                       ······@csl.sri.com
"Don't fight it son, confess quickly.  If you hold out too long, you
could jeopardize your credit rating."
                            -- Torture scene from the movie "Brazil"
From: Glen Able
Subject: Re: newbie - more on my search program
Date: 
Message-ID: <cnto46$ni$1@newsg1.svr.pol.co.uk>
"Fred Gilham" <······@snapdragon.csl.sri.com> wrote in message
···················@snapdragon.csl.sri.com...
>
> Kenny Tilton wrote:
> > The simplest way out is:
> >
> >      (setf answer (catch :bingo! <etc>))
> >
>
> To do what you want, just change find-single-solution to
>
> (defun find-single-solution (grid)
>   (catch 'found-solution
>     (fill-grid grid
>        (lambda (grid)
> (print-grid grid)
> (throw 'found-solution nil)
> nil))))
>

Yikes, so you can nonchalantly jump all the way back up the stack and out of
'fill-grid' in one step.

I've gone for Kenny's other suggestion, using return-from, which I wasn't
aware of, and which I've had to struggle to find in any of my ebooks - why
so obscure?  So 'fill-grid' does a return-from with value t if one of its
child calls returns t, or if the 'on-found' call says to stop - very simple.
Btw I don't need multiple values because solutions are handled by passing
them to the callback function.

So now I've been able to efficiently implement these 3 variants, with just
the anonymous function's return value controlling the search.

(defun find-single-solution (grid)

(defun count-solutions (grid)

(defun has-unique-solution (grid)

Thanks guys!
G.A.
From: Fred Gilham
Subject: Re: newbie - more on my search program
Date: 
Message-ID: <u7mzx91q5e.fsf@snapdragon.csl.sri.com>
Glen Able wrote:
> Yikes, so you can nonchalantly jump all the way back up the stack
> and out of 'fill-grid' in one step.

That's nothing.  You should see what Scheme's
call-with-current-continuation lets you do.  Imagine being able to
jump right back in.... :-)

-- 
Fred Gilham                                       ······@csl.sri.com
...every candid Reader will easily understand my Discourse to be
intended only in Defence of *nominal* Christianity, the other having
been for some time wholly laid aside by general Consent, as utterly
inconsistent with all our present Schemes of Wealth and Power.
                                                 --- Jonathan Swift
From: Brian Downing
Subject: Re: newbie - more on my search program
Date: 
Message-ID: <2TBod.136119$HA.75871@attbi_s01>
In article <···········@newsg1.svr.pol.co.uk>,
Glen Able <·········@gmail.com> wrote:
> > To do what you want, just change find-single-solution to
> >
> > (defun find-single-solution (grid)
> >   (catch 'found-solution
> >     (fill-grid grid
> >        (lambda (grid)
> >          (print-grid grid)
> >          (throw 'found-solution nil)
> >          nil))))
> >
> 
> Yikes, so you can nonchalantly jump all the way back up the stack and
> out of 'fill-grid' in one step.
> 
> I've gone for Kenny's other suggestion, using return-from, which I
> wasn't aware of, and which I've had to struggle to find in any of my
> ebooks - why so obscure?

Just to impress upon you that CL's GO and RETURN constructs are not to
be trifled with ( :-) ), RETURN-FROM can "nonchalantly jump all the way
back up the stack" as well:

(defun find-single-solution (grid)
  (block finding-solution
    (fill-grid grid
       (lambda (grid)
         (print-grid grid)
         (return-from finding-solution nil)))))

See, CL's tags and blocks have dynamic extent too, but unlike TRY and
CATCH have lexical scope.  This (IMHO) makes this version a little
cleaner because you don't need dynamic scope to express this here.

This can be an insanely powerful flow control mechanism.  In fact, if
you look at your implementation's expansions for HANDLER-CASE and
RESTART-CASE, it probably uses GO to unwind the stack.

Also, for a little mental excercise, you can implement a working TRY and
CATCH with TAGBODY and GO.  :)

-bcd
-- 
*** Brian Downing <bdowning at lavos dot net>
comp.lang.lisp / 2004 / nov