TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ElpanovEvgeniy on November 20, 2009, 06:23:09 AM

Title: -={Challenge}=- a way through a labyrinth
Post by: ElpanovEvgeniy on November 20, 2009, 06:23:09 AM
It is necessary to write the program finding pass through a labyrinth.

Argument:
Matrix of a labyrinth
0 = a wall
1 = a corridor
2 = start of a labyrinth
-1 = the end of a labyrinth

It is necessary to find pass through a labyrinth.

Code: [Select]
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 0 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 0 0 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(labyrinth l)

Last Edit: Has corrected the list with a labyrinth.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 07:59:35 AM
Interesting challenge!
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 20, 2009, 08:50:47 AM
my contribution.... :lol:
Code: [Select]
(defun c:lab (/ p1 bpx lr)
(setq p1 (getpoint))
(setq bp1 p1)
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 0 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 0 0 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(labyrinth l p1)
(command "._rectang" "_non" bpx "_non" lr)
)

(defun labyrinth (lst p1)
(foreach n lst
(foreach x n
(if (= x 0)
(cube 0 p1)
)
(if (= x 2)
(cube 2 p1)
)
(if (= x -1)
(cube -1 p1)
)
(setq p1 (list (+ (car p1) 1.0) (cadr p1) (caddr p1)))
)
(setq p1 (list (car bp1) (- (cadr p1) 1.0) (caddr p1)))
)
)

(defun cube (value point / ul w1 w10 w11 w40 w73 w72)

(setq ul (polar point 2.35619 0.7071)
lr (polar point 5.49779 0.7071)
)
(if (not bpx)(setq bpx ul))
(if (eq value 0)
(command "._rectang" "_non" ul "_non" lr)
)
(if (eq value 2)
(setq w1  "Start"
w10 ul
w11 ul
w73 1
w72 2
)
)
(if (eq value -1)
(setq w1  "End"
w10 lr
w11 lr
w73 3
w72 0
)
)

(if (and w1 w10 w11 w73 w72)

(setq ltext (entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 1 w1)
(cons 10 w10)
(cons 11 w11)
(cons 40 0.5)
(cons 73 w73)
(cons 72 w72)
)
)
)
)
)

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 08:55:10 AM
haha, nice idea Andrea - but the user still has to trace his/her way through....  ;-)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 20, 2009, 09:01:33 AM
haha, nice idea Andrea - but the user still has to trace his/her way through....  ;-)
Yep..   8-)

I just having fun playing with this..   ;-)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: ElpanovEvgeniy on November 20, 2009, 09:13:32 AM
my contribution.... :lol:

Hi Andrea!
The good start. :)

It is necessary to erase only superfluous rectang...
I hasten to warn, and if there are some ways?
For example
Code: [Select]
((2 1 1)
(1 0 1)
(1 1 -1))
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 10:01:11 AM
Tried implementing the "Right-Hand" Algorithm... and failed.

But will post what I have.. at the moment, I get an endless loop.

<Removed Erroneous code>
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: SEANT on November 20, 2009, 10:17:06 AM
Tried implementing the "Right-Hand" Algorithm... and failed.

But will post what I have.. at the moment, I get an endless loop.

The layout of this maze certainly seems to reward the Left Hand (vs. Right Hand) rule. :-)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 10:22:57 AM
Both left and right should yield good results for an arbitrary maze... I thought,.

Anyway, this works (I think!)

Code: [Select]
(defun labyrinth (lst / get_nth A CHK CHKN I J L LST OLST OP OPN X Y)
;; by Lee McDonnell

(setq oLst '((1 0) (0 -1) (-1 0) (0 1)))

(defun get_nth (u v op)
(setq u (+ (car op) u) v (+ (cadr op) v))
(nth u (nth v lst)))

;; Find Coordinates of Start Position

(setq l lst i 0 j 0)
(while
(progn
(setq x (caar l))

(cond (  (not x) (setq i nil j nil))

(  (= 2 x) nil)

(  (< 1 (length (car l)))
(setq l (cons (cdar l) (cdr l)) i (1+ i)))

(  (setq l (cdr l) j (1+ j) i 0)))))

;; "Wall the Labyrinth"

(setq lst (mapcar
(function
(lambda (x)
(append '(0) x '(0)))) lst))

(repeat (length (car lst))
(setq a (cons 0 a)))

(setq lst (append (list a) lst (list a)) i (1+ i) j (1+ j))

;; Get the first Operator

(foreach x '((1 0) (0 -1) (-1 0) (0 1))

(if (not (zerop (nth (+ (car x) i)
(nth (+ (cadr x) j) lst))))
(setq opn (vl-position x oLst))))

(setq chkn (if (zerop opn) 3 (1- opn)))

(while
(progn

(setq op (nth opn oLst) chk (nth chkn oLst))

;; get Target square

(setq x (get_nth i j op)

;; Get Right hand check

y (get_nth i j chk))

(print (list (1- i) (1- j)))

(cond (  (and (= 1 x) (zerop y))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (or (= 0 x) (= 1 x)) (= 1 y))
(setq chkn (if (= 0 chkn) 3 (1- chkn))
opn  (if (= 0 opn)  3 (1- opn)))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (= 0 x) (or (= -1 y) (= 0 y)))
(setq chkn (if (= 3 chkn) 0 (1+ chkn))
opn  (if (= 3 opn)  0 (1+ opn))))

(  (= -1 x) nil))))   ;; exit

(princ))
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: SEANT on November 20, 2009, 10:30:19 AM
I also think that’s true.   This particular layout, though, would be navigated a bit quicker with the left hand.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: VovKa on November 20, 2009, 10:47:04 AM
Evgeniy loves keeping people busy for the whole weekend :)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 20, 2009, 11:07:40 AM
well....my way to finish the week !  ;-)

Code: [Select]
(defun c:lab (/ p1)
(setq bpx nil)
(setq p1 (getpoint))
(setq bp1 p1)
(setq walllist nil)
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 0 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 0 0 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(labyrinth l p1)
(command "._rectang" "_non" bpx "_non" lr)
)

(defun labyrinth (lst p1)
(foreach n lst
(foreach x n
(if (= x 0)
(cube 0 p1)
)
(if (= x 2)
(cube 2 p1)
)
(if (= x -1)
(cube -1 p1)
)
(setq p1 (list (+ (car p1) 1.0) (cadr p1) (caddr p1)))
)
(setq p1 (list (car bp1) (- (cadr p1) 1.0) (caddr p1)))
)
)

(defun cube (value point / ul w1 w10 w11 w40 w73 w72)
(setq ul (polar point 2.35619 0.7071)
lr (polar point 5.49779 0.7071)
)
(if (not bpx)
(setq bpx ul)
)
(setq bp2 point)
(if (eq value 0)
(progn (command "._rectang" "_non" ul "_non" lr)
(setq walllist (append walllist (list point)))
)
)
(if (eq value 2)
(setq w1  "Start"
w10 ul
w11 ul
w73 1
w72 2
)
)
(if (eq value -1)
(setq w1  "End"
w10 lr
w11 lr
w73 3
w72 0
)
)
(if (and w1 w10 w11 w73 w72)
(setq ltext (entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 1 w1)
(cons 10 w10)
(cons 11 w11)
(cons 40 0.5)
(cons 73 w73)
(cons 72 w72)
)
)
)
)
)

(defun c:findway ()
(setq nlstx nil
nlst nil
nextpoints nil
)
(way (list bp1) walllist)
(foreach j nlstx (command "_point" j))
)

(defun way (nlst blst)
(setq rnlst (car (reverse nlst)))
(setq nextpoints (list (list (car rnlst) (1+ (cadr rnlst)) (caddr rnlst))
(list (car rnlst) (1- (cadr rnlst)) (caddr rnlst))
(list (1+ (car rnlst)) (cadr rnlst) (caddr rnlst))
(list (1- (car rnlst)) (cadr rnlst) (caddr rnlst))
)
)
(foreach n nextpoints
(if (eq (vl-princ-to-string n) (vl-princ-to-string bp2))
(setq nlstx (append nlst (list bp2)))
)
(if (and (> (car n) (car bpx))
(< (car n) (car lr))
(not (member n blst))
(not (member n nlst))
)
(way (append nlst (list n)) walllist)
)
)
)

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: GDF on November 20, 2009, 11:19:32 AM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: GDF on November 20, 2009, 11:30:57 AM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.

I found it. By Bill Fane, Maze.lsp

It is an old routine and needs a lot of cleanup.

(try) to try it out.

(sol) for the solution.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 20, 2009, 11:41:24 AM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.

I found it. By Bill Fane, Maze.lsp

It is an old routine and needs a lot of cleanup.

(try) to try it out.

(sol) for the solution.

need to convert all english command... :realmad:
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: T.Willey on November 20, 2009, 11:56:35 AM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.

I found it. By Bill Fane, Maze.lsp

It is an old routine and needs a lot of cleanup.

(try) to try it out.

(sol) for the solution.

need to convert all english command... :realmad:

Not hard.  Open in Notepad, and use the replace option ( ctr + h ), and replace ' command " ' with ' command "_. '.  Just check what is being replaced, because some of it shouldn't be, so go one at a time.  Should get most, if not all.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 20, 2009, 12:13:06 PM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.

I found it. By Bill Fane, Maze.lsp

It is an old routine and needs a lot of cleanup.

(try) to try it out.

(sol) for the solution.

need to convert all english command... :realmad:

Not hard.  Open in Notepad, and use the replace option ( ctr + h ), and replace ' command " ' with ' command "_. '.  Just check what is being replaced, because some of it shouldn't be, so go one at a time.  Should get most, if not all.

you thing ???

what about all sub-command ??

eg:
(command "_zoom" "_E")

or ..(command "_-PLOT" .... ? ? ? )

so that can't be done without doing it 1 by 1
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 12:16:05 PM
Andrea,

what do you get with this?

Code: [Select]
( ( 1 1 1 1 1 0 2 0)
( 0 0 1 0 1 1 1 0)
(-1 0 1 0 0 0 1 1)
( 1 0 0 0 1 0 0 1)
( 1 1 0 0 1 0 0 1)
( 0 1 0 1 1 1 1 1)
( 0 1 1 1 0 0 1 0)
( 0 1 0 0 0 0 1 0) )
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: T.Willey on November 20, 2009, 12:45:33 PM
I will dig thru my routines...I remember a routine that would draw up, create a puzzle labyrinth.
Maybe it could help in solving it.

I found it. By Bill Fane, Maze.lsp

It is an old routine and needs a lot of cleanup.

(try) to try it out.

(sol) for the solution.

need to convert all english command... :realmad:

Not hard.  Open in Notepad, and use the replace option ( ctr + h ), and replace ' command " ' with ' command "_. '.  Just check what is being replaced, because some of it shouldn't be, so go one at a time.  Should get most, if not all.

you thing ???

what about all sub-command ??

eg:
(command "_zoom" "_E")

or ..(command "_-PLOT" .... ? ? ? )

so that can't be done without doing it 1 by 1

Ah.... true...

Didn't think about the sub command parts.  Guess it would take more work then.  :wink:
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: ElpanovEvgeniy on November 20, 2009, 03:13:37 PM
Wow!  :-o

I am sorry, I can look a code only tomorrow.
I hope, you perfectly will spend time with this task!
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: T.Willey on November 20, 2009, 03:15:27 PM
I'm trying to come up with a recursive version, but I suck at recursive programing, so this is a double challenge for me.  I think I can do it though.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 03:21:48 PM
I'm just not sure of the output - at the minute mine just outputs "coordinates" in the list...
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: T.Willey on November 20, 2009, 03:30:07 PM
That is how I was going to do my Lee.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 04:50:29 PM
My Version 2:

Code: [Select]
(defun labyrinth (lst / get_nth doups A CHK CHKN CLST I ITM J
L LST OLST OP OPN X Y rLst)
;; by Lee McDonnell

(setq oLst '((1 0) (0 -1) (-1 0) (0 1)))

(defun get_nth (u v op)
(setq u (+ (car op) u) v (+ (cadr op) v))
(nth u (nth v lst)))

(defun doups (lst / x result)
(while (setq x (car lst))
(if (vl-position x (setq lst (cdr lst)))
(setq lst (vl-remove x lst))
(setq result (cons x result))))
(reverse result))

;; Find Coordinates of Start Position

(setq l lst i 0 j 0)
(while
(progn
(setq x (caar l))

(cond (  (not x) (setq i nil j nil))

(  (= 2 x) nil)

(  (< 1 (length (car l)))
(setq l (cons (cdar l) (cdr l)) i (1+ i)))

(  (setq l (cdr l) j (1+ j) i 0)))))

;; "Wall the Labyrinth"

(setq lst (mapcar
(function
(lambda (x)
(append '(0) x '(0)))) lst))

(repeat (length (car lst))
(setq a (cons 0 a)))

(setq lst (append (list a) lst (list a)) i (1+ i) j (1+ j))

;; Get the first Operator

(foreach x '((1 0) (0 -1) (-1 0) (0 1))

(if (not (zerop (nth (+ (car x) i)
(nth (+ (cadr x) j) lst))))
(setq opn (vl-position x oLst))))

(setq chkn (if (zerop opn) 3 (1- opn)))

(while
(progn

(setq op (nth opn oLst)   chk (nth chkn oLst)
x  (get_nth i j op)   y (get_nth i j chk))

(setq cLst (cons (list (1- i) (1- j)) cLst))

(cond (  (and (= 1 x) (zerop y))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (or (= 0 x) (= 1 x)) (= 1 y))
(setq chkn (if (= 0 chkn) 3 (1- chkn))
opn  (if (= 0 opn)  3 (1- opn)))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (= 0 x) (or (= -1 y) (= 0 y)))
(setq chkn (if (= 3 chkn) 0 (1+ chkn))
opn  (if (= 3 opn)  0 (1+ opn))))

(  (= -1 x)
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))) nil))))

(setq cLst (vl-sort (doups (cons (list (1- i) (1- j)) cLst))
(function
(lambda (a b)
(if (= (car a) (car b))
(< (car a) (car b)))))))

(foreach x cLst
(print x)
(entmake (list (cons 0 "POINT") (cons 10 (list (car x) (- (cadr x)))))))

(princ))

{ Missing Corners }   :-(
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 20, 2009, 07:02:24 PM
Final Offering... still not perfect..

Code: [Select]
(defun labyrinth (lst / get_nth doups cube A CHK CHKN CLST I
ITM J L LST OLST OP OPN X Y rLst u v)
;; by Lee McDonnell

(setvar "PDMODE" 34)
(setvar "PDSIZE" 0.4)

(setq oLst '((1 0) (0 -1) (-1 0) (0 1)))

(defun get_nth (u v op)
(setq u (+ (car op) u) v (+ (cadr op) v))
(nth u (nth v lst)))

(defun doups (lst / x result)
(while (setq x (car lst))
(if (vl-position x (setq lst (cdr lst)))
(setq lst (vl-remove x lst))
(setq result (cons x result))))
(reverse result))

(defun cube (pt / pi/4)
(setq pi/4 (/ pi 4.) d (/ (sqrt 2.) 2.))

(entmake
(append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 62 3)
(cons 10 (polar pt pi/4 d))
(cons 10 (polar pt (* 3 pi/4) d))
(cons 10 (polar pt (* 5 pi/4) d))
(cons 10 (polar pt (* 7 pi/4) d))))))

;; Find Coordinates of Start Position

(setq l lst i 0 j 0)
(while
(progn
(setq x (caar l))

(cond (  (not x) (setq i nil j nil))

(  (= 2 x) nil)

(  (< 1 (length (car l)))
(setq l (cons (cdar l) (cdr l)) i (1+ i)))

(  (setq l (cdr l) j (1+ j) i 0)))))

;; "Wall the Labyrinth"

(setq lst (mapcar
(function
(lambda (x)
(append '(0) x '(0)))) lst))

(repeat (length (car lst))
(setq a (cons 0 a)))

(setq lst (append (list a) lst (list a)) i (1+ i) j (1+ j))

(setq u 1)
(foreach x lst
(setq u (1- u) v -1)
(foreach y x
(setq v (1+ v))
(if (zerop y)
(cube (list v u 0.)))))

;; Get the first Operator

(foreach x '((1 0) (0 -1) (-1 0) (0 1))

(if (not (zerop (nth (+ (car x) i)
(nth (+ (cadr x) j) lst))))
(setq opn (vl-position x oLst))))

(setq chkn (if (zerop opn) 3 (1- opn)))

(while
(progn

(setq op (nth opn oLst)   chk (nth chkn oLst)
x  (get_nth i j op)   y (get_nth i j chk))

(setq cLst (cons (list (1- i) (1- j)) cLst))

(cond (  (and (= 1 x) (zerop y))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (or (= 0 x) (= 1 x)) (= 1 y))
(setq chkn (if (= 0 chkn) 3 (1- chkn))
opn  (if (= 0 opn)  3 (1- opn)))
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))))

(  (and (= 0 x) (or (= -1 y) (= 0 y)))
(setq chkn (if (= 3 chkn) 0 (1+ chkn))
opn  (if (= 3 opn)  0 (1+ opn))))

(  (= -1 x)
(mapcar 'set '(i j) (mapcar '+ (list i j) (nth opn oLst))) nil))))

(setq cLst (vl-sort (doups (cons (list (1- i) (1- j)) cLst))
(function
(lambda (a b)
(if (= (car a) (car b))
(< (car a) (car b)))))))

(if (< 1 (abs (- (apply '+ (car cLst)) (apply '+ (cadr cLst)))))

(cond (  (= 1 (nth (+ 2 (caar cLst)) (nth (1+ (cadar cLst)) lst)))

(setq rLst (cons (list (1+ (caar cLst)) (cadar cLst)) rLst)))

(  (setq rLst (cons (list (caar cLst) (1+ (cadar cLst))) rLst)))))

(setq rLst (cons (car cLst) rLst) cLst (cdr cLst)))

(setq cLst (append cLst rLst))

(foreach x cLst
(print x)
(entmake (list (cons 0 "POINT") (cons 10 (list (1+ (car x)) (- (1+ (cadr x))))) (cons 62 2))))

(princ))
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 08:22:31 AM

The code is base (loosely) on the Bellman's flood algorithm.

Code: [Select]
;|
Argument:
Matrix of a labyrinth
0 = a wall
1 = a corridor
2 = start of a labyrinth
-1 = the end of a labyrinth
|;

;;-----------------------------
;;
(setq l '((1 1 1)
(1 0 -1)
(2 0 1)
(1 0 1)
))
(kdub_labyrinth l)
;;-----------------------------
;;
(setq l '((1 1 1)
(1 0 -1)
(2 0 1)
(1 1 1)
))
(kdub_labyrinth l)
;;-----------------------------
;;
(setq l '((1 1 1) (1 0 -1) (2 1 1) (1 1 1)))
(kdub_labyrinth l)

;;-----------------------------
;;
(setq l '((1 1 1 1 1 0 2 0)
(0 0 1 0 1 1 1 0)
(-1 0 1 0 0 0 1 1)
(1 0 0 0 1 0 0 1)
(1 1 0 0 1 0 0 1)
(0 1 0 1 1 1 1 1)
(0 1 1 1 0 0 1 0)
(0 1 0 0 0 0 1 0)
)
)

(kdub_labyrinth l)
;;-----------------------------
;;
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 0 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 0 0 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(kdub_labyrinth l)

;;-----------------------------
;;

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 08:38:00 AM
The code is base (loosely) on the Bellman's flood algorithm.
Here's some info .. pretty basic, but gives the idea http://micromouse.cannock.ac.uk/maze/fastfloodsolver.htm

It's still a bit rough, but I <think> it will handle most data patterns.

Nice problem Evgeniy :) ... took a little longer than I'd anticipated.  :|

Regards
Kerry

Code: [Select]

;;-----------------------------
;;
;; CodeHimBelonga kdub@theSwamp (20091121)

(defun kdub_labyrinth (l /
BP1
CELL
CELLCOUNT
COL
FRONTIERMAP
HEIGHT
INDEX
INGATE
LST
OFFSETMAP
OUTGATE
P0
P1
PPT
PREVIOUSCELL
ROW
ROWWALL
ROWWIDTH
SINGLEARRAY
TRIPMAP
XCELL
;;
_checkfrontier
_replace_nth
_DrawGate
_DrawCube
)
;;-----------------------------
;; LIBRARY
(defun _checkfrontier (cell offset / )
(if (and (not (minusp (setq index (+ cell offset))))
(= 1 (nth index FrontierMap))
)
(progn                                 ; if the cell is an unvisited corridor cell
(setq FrontierMap  (_replace_nth FrontierMap previousCell index)
previousCell index
OffsetMap    (_replace_nth OffsetMap index (- offset))
)
;;;        (princ (strcat "\n   Frontier Cell :" (itoa index)))
;;;        (princ (strcat "\n  FrontierMap: "
;;;                       (vl-princ-to-string FrontierMap)
;;;               )
;;;        )
;;;        (princ (strcat "\n  OffsetMap  : "
;;;                       (vl-princ-to-string OffsetMap)
;;;                       "\n"
;;;               )
;;;        )
)
)
)
;;-----------------------------
(defun _replace_nth (lst i itm)
(if lst
(if (> i 0)
(cons (car lst) (_replace_nth (cdr lst) (1- i) itm))
(cons itm (cdr lst))
)
)
)
;;-----------------------------
(defun _DrawGate (PT ST /)
(entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 1 ST)
(cons 10 (polar PT 2.35619 0.7071))
;;(cons 11 (polar PT 5.49779 0.7071))
(cons 11 PT)
'(40 . 0.5)
'(41 . 1.0)
'(50 . 0.0)
'(51 . 0.0)
'(71 . 1)
'(72 . 1)
'(73 . 2)
)
)
)
;;-----------------------------
(defun _DrawCube (PT /)
(command "._rectang"
"_non"
(polar PT 2.35619 0.7071)
"_non"
(polar PT 5.49779 0.7071)
)
)
;;-----------------------------
;;-----------------------------
;;
(repeat (+ 2 (length (car l))) (setq rowWall (cons 0 rowWall)))
(setq lst         (append (list rowWall)
(mapcar (function (lambda (x) (append '(0) x '(0)))) l)
(list rowWall)
)
height      (length lst)
rowWidth    (length (car lst))
SingleArray (apply 'append lst)
cellcount   (length SingleArray)
InGate      (vl-position 2 SingleArray) ; zero based
OutGate     (vl-position -1 SingleArray) ; zero based
)
(setq FrontierMap  (_replace_nth SingleArray InGate 1)
FrontierMap  (_replace_nth FrontierMap OutGate 1)
OffsetMap    FrontierMap
cell         OutGate
previousCell Cell
)
(while (/= cell InGate)
;; (princ (strcat "\nCell :" (itoa cell)))
;; Find the Cells Neighbours
(_checkfrontier cell 1)
(_checkfrontier cell -1)
(_checkfrontier cell rowWidth)
(_checkfrontier cell (- rowWidth))
(setq cell (nth cell FrontierMap))
)
(setq xcell (+ cell (nth cell OffsetMap)))
(while (/= xcell OutGate)
(setq TripMap (cons xcell TripMap)
xcell   (+ xcell (nth xcell OffsetMap))
)
)
;;-----------------------------
(setq P0 (getpoint)
P1 P0
)
(foreach n lst
(foreach x n
(if (= x 0)
(_Drawcube P1)
)
(setq p1 (list (+ (car p1) 1.0) (cadr p1) (caddr p1)))
)
(setq p1 (list (car P0) (- (cadr p1) 1.0) (caddr p1)))
)
;;-----------------------------
(_DrawGate (polar (polar P0 (* PI 1.5) (/ InGate rowWidth))
0.0
(rem InGate rowWidth)
)
"S"
)
(_DrawGate (polar (polar P0 (* PI 1.5) (/ OutGate rowWidth))
0.0
(rem OutGate rowWidth)
)
"E"
)
;;-----
(setvar "PDMODE" 34)
(setvar "PDSIZE" 0.25)
(foreach x TripMap
(setq row (/ x rowWidth)
col (rem x rowWidth)
ppt (polar (polar P0 (* PI 1.5) (/ x rowWidth))
0.0
(rem x rowWidth)
)
)
(entmake (list (cons 0 "POINT") (cons 10 ppt) (cons 62 2)))
)
(princ)
)

(princ)

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 08:56:48 AM
a couple of variations ...

Code: [Select]
;;-----------------------------
;;
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 1 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 1 1 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(kdub_labyrinth l)

;;-----------------------------
;;
;;-----------------------------
;;
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 1 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 1 1 1 0 1 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(kdub_labyrinth l)

;;-----------------------------
;;

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 09:15:17 AM
and it seems to handle voids in the pattern as expected.

lorraine saw this on my screen and asked if I was playing PacMan  :lol:  :-P
Code: [Select]

;;-----------------------------
;;
(setq l '((1 1 -1 0 2 1 1 0)
(0 1 1 0 1 1 1 0)
(1 1 0 1 0 0 1 1)
(1 0 0 1 1 0 0 1)
(1 1 0 0 1 0 0 1)
(0 1 0 1 0 1 1 1)
(0 1 1 1 1 1 1 0)
(0 1 0 0 0 0 1 0)
)
)

(kdub_labyrinth l)
;;-----------------------------
;;

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 21, 2009, 10:30:15 AM
Very nice Kerry!  :lol:

This uses the "Dead-End Filling" algorithm... { but doesn't like voids...   :-( }

Code: [Select]
(defun labyrinth (lst / x@ij getsum cube A B D I J NLST U V X flag)
;; by Lee McDonnell

(setvar "PDMODE" 34)
(setvar "PDSIZE" 0.4)

(defun x@ij (x i j l / a b)
(setq a -1)
(mapcar
(function
(lambda (u)
(setq b -1 a (1+ a))
(mapcar
(function
(lambda (v)
(setq b (1+ b))
(if (and (= i b) (= j a)) x v))) u))) l))

(defun getSum (i j l / rl)
(setq rl (list (nth (1+ i) (nth j l))
(nth i (nth (1- j) l))
(nth (1- i) (nth j l))
(nth i (nth (1+ j) l))))
(setq rl (subst 1 -1 rl) rl (subst 1 2 rl))
(apply '+ rl))

(defun cube (pt / pi/4)
(setq pi/4 (/ pi 4.) d (/ (sqrt 2.) 2.))

(entmake
(append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 62 3)
(cons 10 (polar pt pi/4 d))
(cons 10 (polar pt (* 3 pi/4) d))
(cons 10 (polar pt (* 5 pi/4) d))
(cons 10 (polar pt (* 7 pi/4) d))))))

;; "Wall the Labyrinth"

(setq nlst (mapcar
(function
(lambda (x)
(append '(0) x '(0)))) lst))

(repeat (length (car nlst))
(setq a (cons 0 a)))
(setq nlst (append (list a) nlst (list a)))

(setq u 1 flag t)
(foreach x nlst
(setq u (1- u) v -1)
(foreach y x
(setq v (1+ v))
(if (zerop y)
(cube (list v u 0.)))))

(while flag

(setq j 0 flag nil)
(foreach x lst
(setq i 0 j (1+ j))

(foreach y x
(setq i (1+ i))

(if (and (= 1 (nth i (nth j nlst)))
(not (vl-position (nth i (nth j nLst)) '(-1 2))))
(if (= 1 (getSum i j nlst))
(progn
(cube (list i (- j) 0))
(setq flag t nlst (x@ij 0 i j nlst))))))))

(setq u 1)
(foreach x nlst
(setq u (1- u) v -1)
(foreach y x
(setq v (1+ v))
(if (= 1 y)
(entmake (list (cons 0 "POINT") (cons 10 (list v u)) (cons 62 2))))))

(princ))

(http://www.theswamp.org/screens/leemac/Labyrinth.gif)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: mjfarrell on November 21, 2009, 11:02:34 AM
interesting possible application to using this to program a tool(s) optimum cutting path....

what if the labyrinth were 3D?

crazy good work and interesting to watch the evolution!
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Andrea on November 21, 2009, 02:26:16 PM
here's my new one..

Code: [Select]
;| ;;
FINDWAY in LABYRINTH ;;
by: Andrea Andreetti nov. 20 2009 ;;
|;

(defun c:lab (/ p1)
(setq bpx nil)
(setq p1 (getpoint))
(setq sp (polar p1 2.35619 0.7071))
(setq bp1 p1)
(setq walllist nil)

(setq l '( ( 1 1 1 1 1 0 2 0)
( 0 0 1 0 1 1 1 0)
(-1 0 1 0 0 0 1 1)
( 1 0 0 0 1 0 0 1)
( 1 1 0 0 1 0 0 1)
( 0 1 0 1 1 1 1 1)
( 0 1 1 1 0 0 1 0)
( 0 1 0 0 0 0 1 0) )
)

;;;  (setq l '((2 0 1 1 1 1 1 1 1 0 1 0 0 1 1 1)
;;;            (1 0 1 0 0 0 1 0 1 1 1 1 1 1 1 1)
;;;            (1 0 1 0 1 0 1 0 0 0 1 0 0 0 0 0)
;;;            (1 0 1 1 1 0 1 1 0 1 1 1 1 1 1 1)
;;;            (1 1 1 1 0 0 0 1 0 0 0 0 0 0 0 1)
;;;            (1 0 0 0 0 1 0 1 1 1 0 1 1 0 1 1)
;;;            (1 1 1 1 0 1 0 1 0 1 0 1 1 0 1 0)
;;;            (0 0 1 0 0 1 0 0 0 1 0 1 1 1 1 1)
;;;            (1 0 1 1 0 1 1 1 1 1 1 1 0 0 0 1)
;;;            (1 1 1 1 1 1 0 1 0 0 0 0 0 1 1 -1)
;;;           )
;;;  )
(labyrinth l p1)
(command "._rectang" "_non" sp "_non" lr)
)

(defun labyrinth (lst p1)
(setq points nil)
(foreach n lst
(foreach x n
(setq points (append points (list p1)))
(if (= x 0)
(cube 0 p1)
)
(if (= x 2)
(progn
(setq _start p1)
(cube 2 p1)
)
)
(if (= x -1)
(progn
(setq _end p1)
(cube -1 p1)
)
)
(setq p1 (list (+ (car p1) 1.0) (cadr p1) (caddr p1)))
)
(setq p1 (list (car bp1) (- (cadr p1) 1.0) (caddr p1)))
)
)

(defun cube (value point / ul w1 w10 w11 w40 w73 w72)
(setq ul (polar point 2.35619 0.7071)
lr (polar point 5.49779 0.7071)
)
(if (not bpx)
(setq bpx ul)
)
(setq bp2 point)
(if (eq value 0)
(progn (command "._rectang" "_non" ul "_non" lr)
(setq walllist (append walllist (list point)))
)
)
(if (eq value 2)
(progn
(setq w1  "{\\fArial|b0|i0|c0|p34;\\C1;S}"
w10 _start
w11 _start
)
(setq Start-T (createMT w1 w10 w11))
)
)
(if (eq value -1)
(progn
(setq w1  "{\\fArial|b0|i0|c0|p34;\\C3;E}"
w10 _end
w11 _end
)
(setq End-T (createMT w1 w10 w11))
)
)
)

(defun createMT (w1 w10 w11)
(if (and w1 w10 w11 )
(entmakex (list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1 w1)
(cons 10 w10)
(cons 11 w11)
(cons 40 0.5)
'(50 . 0.0)
'(71 . 5)
'(72 . 5)
'(73 . 1)

)
)
)
)

(defun c:findway (/ nlstx nlst nextpoints _start _end dn)
(vla-startundomark
)
(setq nlstx nil
nlst nil
nextpoints nil
)
(setq _startx (cdr (assoc 10 (entget start-t))))
(setq dn (distance _startx (car points)))
(setq _start (car points))
(foreach n (cdr points)
(if (< (distance _startx n) dn)
(progn (setq dn (distance _startx n)) (setq _start n))
)
)
(setq _endx (cdr (assoc 10 (entget end-t))))
(setq dn (distance _endx (car points)))
(setq _end (car points))
(foreach n (cdr points)
(if (< (distance _endx n) dn)
(progn (setq dn (distance _endx n)) (setq _end n))
)
)
(way (list _start) walllist)
(foreach j nlstx (command "_point" j))
(vla-endundomark
)
)

(defun way (nlst blst)
(setq rnlst (car (reverse nlst)))
(setq nextpoints (list (list (car rnlst) (1+ (cadr rnlst)) (caddr rnlst))
(list (car rnlst) (1- (cadr rnlst)) (caddr rnlst))
(list (1+ (car rnlst)) (cadr rnlst) (caddr rnlst))
(list (1- (car rnlst)) (cadr rnlst) (caddr rnlst))
)
)
(foreach n nextpoints
(if (eq (vl-princ-to-string n) (vl-princ-to-string _end))
(setq nlstx (append nlst (list _end)))
)
(if (and (> (car n) (car sp))
(< (car n) (car lr))
(not (member n blst))
(not (member n nlst))
)
(way (append nlst (list n)) walllist)
)
)
)

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 21, 2009, 03:31:46 PM
I just like to watch it  :-P  :evil:

(http://www.theswamp.org/screens/leemac/Maze.gif)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 11:54:19 PM
Very nice Kerry!  :lol:

This uses the "Dead-End Filling" algorithm... { but doesn't like voids...   :-( }

< .... >

Thanks Lee ..

I had a look at the filling algorithm ... there are actually a few interesting options.

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 21, 2009, 11:59:41 PM
Andrea,

I didn't run your code .. just had a look at the source.

I think you need to devise a method to eliminate superfluous cells in your path list.

Regards
Kerry

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 22, 2009, 07:24:12 AM
Very nice Kerry!  :lol:

This uses the "Dead-End Filling" algorithm... { but doesn't like voids...   :-( }

< .... >

Thanks Lee ..

I had a look at the filling algorithm ... there are actually a few interesting options.

It seems to produce good results for a "simple" maze, but it will fail with loops and voids - I'm trying to figure out a way to detect loops and such, but it seems impossible using my current methods.  :|
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: wizman on November 22, 2009, 08:30:31 PM
interesting possible application to using this to program a tool(s) optimum cutting path....

what if the labyrinth were 3D?

crazy good work and interesting to watch the evolution!

i remember seeing this on jtb:http://blog.jtbworld.com/2009/02/space-filling-curves-in-theory-and.html

Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Kerry on November 22, 2009, 11:36:41 PM
interesting possible application to using this to program a tool(s) optimum cutting path....

what if the labyrinth were 3D?

crazy good work and interesting to watch the evolution!

I don't see the relationship between this and a cutting path optimiser ... care to elucidate ?

3d would be possible but I'd need an incentive :)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: mjfarrell on November 23, 2009, 12:43:41 PM
interesting possible application to using this to program a tool(s) optimum cutting path....

what if the labyrinth were 3D?

crazy good work and interesting to watch the evolution!

I don't see the relationship between this and a cutting path optimiser ... care to elucidate ?

3d would be possible but I'd need an incentive :)

From my perspective a tool path is much like a maze, only the goal is to remove material, and leave some behind; this seems like it would adapt to that purpose.
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: Lee Mac on November 23, 2009, 01:27:48 PM
interesting possible application to using this to program a tool(s) optimum cutting path....

what if the labyrinth were 3D?

crazy good work and interesting to watch the evolution!

i remember seeing this on jtb:http://blog.jtbworld.com/2009/02/space-filling-curves-in-theory-and.html

Reminds me of:

http://www.theswamp.org/index.php?topic=30966.0 (http://www.theswamp.org/index.php?topic=30966.0)   ;-)
Title: Re: -={Challenge}=- a way through a labyrinth
Post by: VovKa on November 23, 2009, 04:18:56 PM
let Autodesk Map guys do the job :)
Code: [Select]
(defun SolveLabyrinth
(SS StartPoint EndPoint / VariablesID TopologyName TopologyID TraceID Path)
(setq TopologyName "SolveLabyrinth")
(if (and (setq VariablesID (tpm_varalloc))
(tpm_varset VariablesID "CREATE_NODE" 0)
(tpm_mntbuild VariablesID TopologyName "" 2 nil SS)
(tpm_varfree VariablesID)
(setq TopologyID (tpm_acopen TopologyName nil))
(setq TraceID (tpm_tracealloc TopologyID))
(tpm_traceshort TraceID
(tpm_elemfind TopologyID 1 StartPoint)
(tpm_elemfind TopologyID 1 EndPoint)
)
)
(while (and (tpm_traceshortscan TraceID 3) (tpm_traceshortscan TraceID 3))
(setq Path
(cons
(entget
(cdr (assoc -2 (tpm_elemget TopologyID (tpm_traceshortscan TraceID 0))))
)
Path
)
)
)
)
(tpm_tracefree TraceID)
(tpm_acclose TopologyID)
(tpm_mnterase TopologyName)
Path
)
(defun test (lst / SS StartPoint EndPoint lst y x Step)
(setq Step 10.0
y    0
)
(mapcar (function
(lambda (r nr)
(setq x 0)
(mapcar (function
(lambda (rc rnc nrc / p)
(setq p (list (* x Step) (* y Step)))
(if (and (not (zerop (* rc rnc))) (< (1+ x) (length r)))
(ssadd (entmakex (list (cons 0 "LINE")
(cons 10 p)
(list 11 (* (1+ x) Step) (* y Step))
)
)
SS
)
)
(if (and (not (zerop (* rc nrc))) (< (1+ (abs y)) (length lst)))
(ssadd (entmakex (list (cons 0 "LINE")
(cons 10 p)
(list 11 (* x Step) (* (1- y) Step))
)
)
SS
)
)
(cond ((= rc 2) (setq StartPoint p))
((= rc -1) (setq EndPoint p))
)
(setq x (1+ x))
)
)
r
(append (cdr r) (list (car r)))
nr
)
(setq y (1- y))
)
)
lst
(append (cdr lst) (list (car lst)))
)
(if (and SS
(or StartPoint (setq StartPoint (getpoint "\nEntrance: ")))
(or EndPoint (setq EndPoint (getpoint StartPoint "\nExit: ")))
)
(foreach Ent (SolveLabyrinth SS StartPoint EndPoint)
(vla-put-Color (vlax-ename->vla-object (entmakex Ent)) 3)
)
)
)
(setq l '((2 0 1 1 1 1 1 1 1 0)
(1 0 1 0 0 0 1 0 1 1)
(1 0 1 0 1 0 1 0 0 0)
(1 0 1 1 1 0 1 1 0 1)
(1 1 1 1 0 0 0 1 0 1)
(1 0 0 0 0 1 0 1 1 1)
(1 1 1 1 0 1 0 1 0 1)
(0 0 1 0 0 1 0 0 0 1)
(1 0 1 1 0 1 1 1 0 1)
(1 1 1 1 1 1 0 1 0 -1)
)
)
(test l)