On Tue, Jan 08, 2008 at 11:25:18AM -0800, Brad Beyenhof wrote:
On Jan 8, 2008 11:05 AM, Barry Gershenfeld <[EMAIL PROTECTED]> wrote:
real 0m37.930s
user 0m0.000s
sys 0m0.000s
[snip]
(Okay peanut gallery, this is where you post /your/ time...)
I didn't use any gcc options when compiling, and it's running on my
Ubuntu 7.10 server (a Linode VPS). I changed my "blank" character in
the source code to an underscore so I wouldn't have to quote the
arguments:
$ time ./a.out 2468135_7 12345678_ > sli.txt
real 0m4.711s
user 0m3.070s
sys 0m0.190s
Ok, my turn. The code, in Common Lisp, is attached below. Running this
interactively with SBCL on a 2.4Ghz Intel Core 2 DUO.
For the given example
(time (solve '(2 4 6 8 1 3 5 nil 7)))
Evaluation took:
0.628 seconds of real time
0.600038 seconds of user run time
0.028002 seconds of system run time
[Run times include 0.188 seconds GC run time.]
0 calls to %EVAL
0 page faults and
83,066,512 bytes consed.
I may have to look at the other solutions, since this thing is
significantly faster than either solution posted so far. I didn't try any
optimization.
I spent probably 8 hours last night learning enough common lisp (I know
scheme), and then about 5 hours this evening writing this.
Interestingly, the full space search
(time (solve '(1 2 3 4 5 6 8 7 nil)))
is 0.828 seconds. (It doesn't print anything if there is no solution).
It runs quite a bit slower if you print out the boards during the run, or
even time the printing of the solution.
To be honest, I'm completely surprised by these results. I give this
language and at least this implementation a lot of credit.
So, any ideas on what I should write next? This was a perfect problem for
learning this language.
Dave
----------------------------------------------------------------------
;;; Brute-force solution to the 9-square (or 15-square or whatever)
;;; problem.
;; Dimensions of board to solve.
(defconstant width 3 "Width of board in squares")
(defconstant height 3 "Height of board in squares")
(defconstant full-size (* width height) "Total number of board squares")
(defun valid-x-p (x)
(and (>= x 0)
(< x width)))
(defun valid-y-p (y)
(and (>= y 0)
(< y height)))
;; A given board is represented as a simple vector with the squares
;; given as integers starting at 1. The empty square has the value
;; NIL.
(defconstant solved-board
(let ((nums (loop for i from 1 to full-size
collect (and (< i full-size) i))))
(make-array full-size :initial-contents nums))
"The final solved board")
(defun show-board (board)
"Show the board in a readable format"
(loop for y from 0 to (1- height)
do (loop for x from 0 to (1- width)
for pos from (* width y)
do (format t " [EMAIL PROTECTED]" (or (elt board pos) "_")))
do (format t "~%")))
(defun nless (a b)
"Numeric sorting, except that 'nil' is larger than other numbers"
(< (or a full-size) (or b full-size)))
;; Given a board as a list, convert to vector format, and make sure it
;; is valid.
(defun make-board (items)
(let* ((board (make-array full-size :initial-contents items))
(sboard (copy-seq board)))
(unless (equalp (sort sboard #'nless) solved-board)
(error "Board does not have proper numbers"))
board))
;; Given a particular board, compute a unique bignum defining the
;; possible position. Treats the empty space as value full-size, and
;; simply computes the number base (1+ full-size).
(defun compute-cookie (board)
(loop for item across board
for power = 1 then (* power 10)
sum (* power (or item full-size))))
;; Pre-compute all possible moves from a given position.
(defun one-move (x y)
"Compute the valid moves from the given X and Y"
(loop for (dx dy) in '((-1 0) (1 0) (0 -1) (0 1))
nconc (let ((nx (+ x dx))
(ny (+ y dy)))
(and (valid-x-p nx) (valid-y-p ny)
(list (+ (* width ny) nx))))))
(defconstant all-moves-list
(loop for y from 0 to (1- height)
nconc (loop for x from 0 to (1- width)
for pos from (* width y)
collect (one-move x y)))
"All valid moves, as a single array")
(defconstant all-moves (make-array full-size :initial-contents all-moves-list))
;; Given a particular board, exchange the specified two pieces,
;; non-destructively (copies the board first).
(defun exchange (board a b)
(let ((board2 (copy-seq board)))
(setf (elt board2 a) (elt board b))
(setf (elt board2 b) (elt board a))
board2))
;; Given a particular board, return a list of the boards that are
;; reachable from this board.
(defun find-reachable (board)
(loop with my-pos = (position nil board)
for pos in (elt all-moves my-pos)
collect (exchange board my-pos pos)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A simple FIFO. New nodes are inserted at the tail, and removed
;;; from the head. The HEAD is the head of the list, and the TAIL is
;;; the cons cell of the last member of the list.
(defstruct fifo
(head nil)
(tail nil))
(defun fifo-empty-p (f)
(not (fifo-head f)))
(defun fifo-append (f item)
"Append the given ITEM to the end of the fifo F"
(let ((tmp (list item)))
(if (fifo-tail f)
(setf (rest (fifo-tail f)) tmp)
(setf (fifo-head f) tmp))
(setf (fifo-tail f) tmp))
f)
(defun fifo-append-many (f items)
"Append a list of ITEMS to the end of fifo F"
(loop for item in items
do (fifo-append f item))
f)
;; TODO: Return multiple values for more information.
(defun fifo-take (f)
"Remove an item from the fifo, returning NIL if empty."
(if (fifo-head f)
(let ((item (first (fifo-head f))))
(setf (fifo-head f) (rest (fifo-head f)))
(unless (fifo-head f)
(setf (fifo-tail f) nil))
item)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Wrap it all up, doing a breadth-first search for a solution.
;;; Takes INITIAL-ITEMS as a list of the initial board.
(defun solve (initial-items)
(do* ((start (make-board initial-items))
(todo (fifo-append (make-fifo) (list start (list start))))
(seen (let ((hash (make-hash-table :test 'equalp)))
(setf (gethash (compute-cookie start) hash) t)
hash)))
((fifo-empty-p todo) nil)
(let* ((entry (fifo-take todo))
(cur (first entry))
(seq (second entry)))
;(format t "Trying: ~A~%" seq)
;(show-board cur)
(when (equalp cur solved-board)
;(format t "Found solution!!!: ~A~%" seq)
(return-from solve (reverse seq)))
(loop for move in (find-reachable cur)
do (unless (gethash (compute-cookie move) seen)
(setf (gethash (compute-cookie move) seen) t)
(fifo-append todo (list move (cons move seq))))))))
(defun show-solve (initial-items)
(let*
((solution (time (solve initial-items))))
(when solution
(format t "Solution in ~A moves:~%" (1- (length solution)))
(loop for move in solution
for count from 0
do (format t "~%Move #~A:~%" count)
do (show-board move)))))
(defvar sample-board (make-board '(5 4 3 2 1 nil 8 6 7)))
--
[email protected]
http://www.kernel-panic.org/cgi-bin/mailman/listinfo/kplug-lpsg
