From: Derek Hans
Subject: Checking for deadlocks added
Date: Sun, 04 May 2003 07:49:53 +0000
Message-ID: <zC3ta.133$vS4.1199@news20.bellglobal.com> This is a multi-part message in MIME format.
--------------040108040807080605070508
Content-Type: text/plain; charset=us-ascii; format=flowed
Content-Transfer-Encoding: 7bit
simple deadlock checking added to sokoban - and it still seems to be
working :)! (well, that is, there still are stack overflows...)
--------------040108040807080605070508
Content-Type: text/plain;
name="Solver-0.5 beta clean.lsp"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
filename="Solver-0.5 beta clean.lsp"
(defconstant +map-location+ '/Derek/Programming/Lisp/Sokoban/screens/screen.)
(defconstant +drive+ #\D)
(defun map-file (current-map)
(format nil "~C~C~S~D" +drive+ #\: +map-location+ current-map))
(defvar map-number 1)
(defvar map-size nil)
(defvar total-nodes 0)
(defvar move 0)
(defvar solution 0)
(defvar goals+walls nil)
(defvar boxes nil)
(defvar soko nil)
(defvar reachable nil)
(defun map-size (map-number);expects map-number
"Gets the dimension of the map that is to be solved.
Goes through map line by line, remembering the longest line,
and the total number of lines."
(with-open-file (in-stream (map-file map-number) :direction :input)
(let ((max-width 0)
(width 0)
(length 0))
(do ((char-to-be-processed (read-char in-stream) (read-char in-stream nil 'the-end)))
((not (characterp char-to-be-processed)) (list max-width length))
(cond ((eql char-to-be-processed #\newline)
(incf length)
(if (< max-width width) (setq max-width width))
(setq width 0))
(T
(incf width)))))))
(map-size 10)
;;the symbols for the goals+walls map
;;trans for "translate this symbol into machine code"
(setf (get 'g+w-trans-symbol '#\ ) 0)
(setf (get 'g+w-trans-symbol ···@) 0)
(setf (get 'g+w-trans-symbol '#\.) 1)
(setf (get 'g+w-trans-symbol '#\$) 0)
(setf (get 'g+w-trans-symbol '#\*) 1)
(setf (get 'g+w-trans-symbol '#\#) 2)
;;the symbols for the boxes map
(setf (get 'box-trans-symbol '#\ ) 0)
(setf (get 'box-trans-symbol ···@) 0)
(setf (get 'box-trans-symbol '#\.) 0)
(setf (get 'box-trans-symbol '#\$) 1)
(setf (get 'box-trans-symbol '#\*) 1)
(setf (get 'box-trans-symbol '#\#) 0)
(defun get-map (map-size map-number);expects map-size and map-number
"Reads the map from file and returns an array containing the walls (as 2s),
the goals (as 1s) and empty space (as 0s);
Also returns an array containing all the boxes (as 1s), and a list of the location of the sokoban."
(with-open-file (in-stream (map-file map-number) :direction :input)
(let ( (goals+walls (make-array map-size :element-type '(mod 3) :initial-element 0))
(boxes (make-array map-size :element-type '(mod 2) :initial-element 0))
(soko nil)
(x 0)
(y 0))
(do ((current-char (read-char in-stream) (read-char in-stream nil 'the-end)))
((not (characterp current-char)) (values goals+walls boxes soko))
(cond ((eql current-char #\newline)
(incf y)
(setq x 0))
(T
(setf (aref goals+walls x y) (get 'g+w-trans-symbol current-char))
(setf (aref boxes x y) (get 'box-trans-symbol current-char))
(if (eql current-char ··@) (setq soko (list x y)))
(incf x)))))))
(defun make-loc-hash (goals+walls boxes soko)
"Makes a hash table containing all the open spaces on the map.
Can be used later in order to make the algorithm more efficient
by storing data in an array containing only the open spaces
- not the walls or space outside of the reach of the sokoban. It isn't yet being used."
(let ((loc-hash (make-hash-table :test #'equal))
(stack (list soko)))
(flet ((push-os (x y)
(if (not (or (= (aref goals+walls x y) 2) (gethash (list x y) loc-hash)))
(push (list x y) stack))))
(do ((current-loc soko (car stack))
(count 0 (1+ count)))
((null current-loc) loc-hash)
(pop stack)
(setf (gethash (list (car current-loc) (cadr current-loc)) loc-hash) count)
(push-os (car current-loc) (1- (cadr current-loc)))
(push-os (car current-loc) (1+ (cadr current-loc)))
(push-os (1- (car current-loc)) (cadr current-loc))
(push-os (1+ (car current-loc)) (cadr current-loc))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Here all functions accessed during the recursion are stored
(defun find-reachable (map-size goals+walls boxes soko);needs map-size, soko, goals+walls, boxes
"Returns an array containing all the locations that the sokoban can reach,
taking into account boxes that stop his path. Reachable locations are noted with a 1."
(let ((reachable (make-array map-size :element-type '(mod 2)))
(stack (list soko)))
(labels ((declare-reachable (x y)
(setf (aref reachable x y) 1)
(push (list x y) stack))
(push-os (x y)
(if (and (= (aref reachable x y) 0) (< (aref goals+walls x y) 2) (= (aref boxes x y) 0))
(declare-reachable x y))))
(setf (aref reachable (car soko) (cadr soko)) 1) ;set location of soko to reachable
(do ((current-loc soko (car stack)))
((null current-loc) reachable)
(pop stack)
(push-os (car current-loc) (1- (cadr current-loc)))
(push-os (car current-loc) (1+ (cadr current-loc)))
(push-os (1- (car current-loc)) (cadr current-loc))
(push-os (1+ (car current-loc)) (cadr current-loc))))))
(defun is-reachable (x y reachable); expects reachable
"Check if this location is reachable; return T if it is."
(if (= 1 (aref reachable x y)) T nil))
(defun is-free (x y goals+walls boxes);expects goals+walls and boxes
"Check if this location contains no box or wall. Should probably be made into a macro."
(if (or (= 2 (aref goals+walls x y))
(= 1 (aref boxes x y)))
nil
T))
(defun is-movable (x y d-x d-y goals+walls boxes);expects x and y
"Checks for horizontal or vertical mobility,
depending on if it is with 1 0 or 0 1 - these denoting the direction into which we want to move.
Should probably be turned into a macro."
(if (and (is-free (+ x d-x) (+ y d-y) goals+walls boxes)
(is-free (- x d-x) (- y d-y) goals+walls boxes))
T
nil))
(defun is-not-dead (x y map-size goals+walls boxes);needs map-size, soko, goals+walls, boxes
"Returns an array containing all the locations that the sokoban can reach,
taking into account boxes that stop his path. Reachable locations are noted with a 1."
(if (or (is-movable x y 1 0 goals+walls boxes)
(is-movable x y 0 1 goals+walls boxes))
t
(let ((stack (list (list x y)))
(dead-a (make-array map-size :element-type '(mod 2)))
(dead t))
(flet ((check (x y)
(if (and (= 1 (aref boxes x y)) (= 0 (aref dead-a x y)))
(cond ((or (is-movable x y 1 0 goals+walls boxes)
(is-movable x y 0 1 goals+walls boxes))
(setq dead nil))
(t (push (list x y) stack)
(setf (aref dead-a x y) 1))))))
(do ((current-loc (list x y) (car stack)))
((null current-loc) nil)
(pop stack)
(check (car current-loc) (1- (cadr current-loc)))
(check (car current-loc) (1+ (cadr current-loc)))
(check (1- (car current-loc)) (cadr current-loc))
(check (1+ (car current-loc)) (cadr current-loc))
(if dead
nil
(return t)))))))
(defun move (map-size goals+walls boxes x y new-x new-y depth);expects x and y - the current position of the box to move
"Actually move the box, and call rec-solver with the new values of boxes."
(let* ((linearization-array (make-array (* (car map-size) (cadr map-size)) :displaced-to boxes))
(linear-copied-array (copy-seq linearization-array))
(new-boxes (make-array map-size :displaced-to linear-copied-array)))
(setf (aref new-boxes x y) 0)
(setf (aref new-boxes new-x new-y) 1)
(if (is-not-dead new-x new-y map-size goals+walls new-boxes)
(rec-solver map-size goals+walls new-boxes (list x y) depth))));soko, after this move, takes the spot of the box
(defun move-further (map-size goals+walls boxes orig-x orig-y to-x to-y d-x d-y depth); d for delta
"Recursive function that is told to move to (to-x to-y)
and will recursively check if it can move one further into direction (d-x d-y)."
(multiple-value-bind (to-x to-y)
(do ((given-x to-x (+ given-x d-x)) ;little algorithm to get through tunnels without stopping
(given-y to-y (+ given-y d-y)))
((or (is-free (+ given-x d-y) (+ given-y d-x) goals+walls boxes)
(is-free (- given-x d-y) (- given-y d-x) goals+walls boxes)
(is-free (+ given-x d-x d-y) (+ given-y d-x d-y) goals+walls boxes)
(is-free (- (+ given-x d-x) d-y) (- (+ given-y d-y) d-x) goals+walls boxes)
(not (is-free (+ given-x d-x) (+ given-y d-y) goals+walls boxes)))
(values given-x given-y)))
(if (is-free (+ to-x d-x) (+ to-y d-y) goals+walls boxes)
(move-further map-size goals+walls boxes orig-x orig-y (+ to-x d-x) (+ to-y d-y) d-x d-y depth))
(move map-size goals+walls boxes orig-x orig-y to-x to-y depth)))
(defun attempt-move (map-size goals+walls boxes soko reachable x y depth)
"Try to move the box located at square x y."
(cond ((and (is-free (1+ x) y goals+walls boxes)
(is-free (1- x) y goals+walls boxes))
(if (is-reachable (1+ x) y reachable) (move-further map-size goals+walls boxes x y (1- x) y -1 0 depth))
(if (is-reachable (1- x) y reachable) (move-further map-size goals+walls boxes x y (1+ x) y 1 0 depth))))
(cond ((and (is-free x (1+ y) goals+walls boxes)
(is-free x (1- y) goals+walls boxes))
(if (is-reachable x (1+ y) reachable) (move-further map-size goals+walls boxes x y x (1- y) 0 -1 depth))
(if (is-reachable x (1- y) reachable) (move-further map-size goals+walls boxes x y x (1+ y) 0 1 depth)))))
(defun get-hash-soko (map-size reachable)
(let ((succ nil))
(do ((y 1 (1+ y)))
(succ succ)
(setq succ
(do ((x 1 (1+ x)))
((>= x (car map-size)) nil)
(if (= 1 (aref reachable x y))
(return (list x y))))))))
(defun rec-solver (map-size goals+walls boxes soko depth); expects map-size, goals+walls, loc-hash
"The actual recursive array that goes through all the possible locations."
(incf total-nodes)
(print depth)
(setq depth (1+ depth))
(let* ((reachable (find-reachable map-size goals+walls boxes soko))
(hash-soko (get-hash-soko map-size reachable)))
(cond ((gethash (list hash-soko boxes) past-loc) t)
(t (setf (gethash (list hash-soko boxes) past-loc) t)
(dotimes (y (cadr map-size))
(dotimes (x (car map-size))
(if (= (aref boxes x y) 1)
(attempt-move map-size goals+walls boxes soko reachable x y depth))))))))
(defun print-orig-map (map-number map-size);expects map-size
(with-open-file (in-stream (map-file map-number) :direction :input)
(do ((char-to-be-processed (read-char in-stream) (read-char in-stream nil 'the-end)))
((not (characterp char-to-be-processed)) )
(write-char char-to-be-processed))))
(defun print-map (map-size map)
(dotimes (y (cadr map-size))
(dotimes (x (car map-size))
(if (< 0 (aref map x Y))
(write (aref map x y))
(write-char #\ )))
(write-char #\newline)))
(defun print-map-walls+boxes (map-size goals+walls boxes)
(dotimes (y (cadr map-size))
(dotimes (x (car map-size))
(cond ((= 1 (aref boxes x y)) (write-char #\$))
((< 0 (aref goals+walls x y)) (write (aref goals+walls x y)))
(t (write-char #\ ))))
(write-char #\newline)))
(defun print-rec-solver-input (map-size goals+walls boxes soko depth)
(format T "map-size: (~{~A,~A~})~&goals+walls and boxes: ~&" map-size)
(print-map-walls+boxes map-size goals+walls boxes)
(format T "soko: (~{~A,~A~})~&depth: ~D" soko depth))
(defun print-rec-solver-input (map-size goals+walls boxes soko depth)
(format T "goals+walls and boxes: ~&")
(print-map-walls+boxes map-size goals+walls boxes))
(setq map-size (map-size 4))
(multiple-value-setq (goals+walls boxes soko) (get-map map-size 4))
(setq reachable (find-reachable map-size goals+walls boxes soko))
(defvar past-loc (make-hash-table :test #'equalp)
"Another hash table not currently being used - will be used in futur to remember posititions that have already been visited.")
(setq hash-soko (get-hash-soko map-size reachable))
(clrhash past-loc)
;(print-map map-size boxes)
;(print-map map-size goals+walls)
;(print-map map-size reachable)
;(is-reachable 0 0 reachable)
;(is-free 1 3 goals+walls boxes)
;(is-movable 1 2 1 0 goals+walls boxes)
;(print-map-walls+boxes map-size goals+walls boxes)
;(move map-size goals+walls boxes 2 2 1 2 5)
;(move-further map-size goals+walls boxes 9 0 9 1 0 1 5)
;(attempt-move map-size goals+walls boxes soko reachable 2 2 5)
;(time (gethash (list hash-soko boxes) past-loc))
;(setf (gethash (list hash-soko boxes) past-loc) t)
;(is-movable 2 5 1 0 goals+walls boxes)
;(is-not-dead 3 4 goals+walls boxes)
(rec-solver map-size goals+walls boxes soko 0)
(hash-table-count past-loc)
;(defvar loc-hash (make-loc-hash goals+walls boxes soko)
; "A hash of all spaces that could potentially be reached by the sokoban, ie excluding walls, in the notation of (x y).")
;(rec-solver (map-size 1) goals+walls boxes soko 0)
;(setq reachable (find-reachable (map-size 1) goals+walls boxes soko))
;(print-map (map-size 1) boxes)
;(print-map (map-size 1) goals+walls)
;(print-map (map-size 1) reachable)
;(is-reachable 7 8 reachable)
;(is-reachable 6 7 reachable)
;(is-free 6 7 goals+walls boxes)
;(is-movable 1 5 0 1 goals+walls boxes)
;(is-movable 1 5 1 0 goals+walls boxes)
;(print-map+boxes (map-size 1) goals+walls boxes)
;(list total-nodes)
;(setq total-nodes 0)
--------------040108040807080605070508-- From: Kenny Tilton
Subject: Re: Checking for deadlocks added
Date: Mon, 05 May 2003 18:49:35 +0000
Message-ID: <f06747e2.0305051049.1e19eb73@posting.google.com> Never mind the stack overflow, how are your debugging skills coming?
Pardon another sermon, but...
If you could narrow your problem down a little someone might look at
your code. Now that we know you are a newbie, the key here is to get
you to the point where you understand debugging well enough to get
help from newsgroups. Hunh? The connection is that you have to do
enough debugging to get to a point where you have a specific code
failure you can isolate but which you cannot solve -- then you turn to
more experienced folks for help. Just posting an entire application
and saying it hits a stack overflow does not cut it.
But I get a kick out of horrific code, so I just might fire it up and
see what happens. What is the starting soko set-up you are using now
for testing?
kt