### Author Topic: -={Challenge}=- a way through a labyrinth  (Read 16630 times)

0 Members and 1 Guest are viewing this topic.

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1544
• Moscow (Russia)
##### -={Challenge}=- a way through a labyrinth
« 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.
« Last Edit: November 20, 2009, 06:53:30 AM by ElpanovEvgeniy »
Stay home. Stay safe. Save lives.

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #1 on: November 20, 2009, 07:59:35 AM »
Interesting challenge!

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #2 on: November 20, 2009, 08:50:47 AM »
my contribution....
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)                        )              )  )  ))  `
« Last Edit: November 20, 2009, 11:39:14 AM by Andrea »
Keep smile...

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #3 on: November 20, 2009, 08:55:10 AM »
haha, nice idea Andrea - but the user still has to trace his/her way through....

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #4 on: November 20, 2009, 09:01:33 AM »
haha, nice idea Andrea - but the user still has to trace his/her way through....
Yep..

I just having fun playing with this..
« Last Edit: November 20, 2009, 09:43:27 AM by Andrea »
Keep smile...

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1544
• Moscow (Russia)
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #5 on: November 20, 2009, 09:13:32 AM »
my contribution....

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))`
Stay home. Stay safe. Save lives.

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #6 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>
« Last Edit: November 20, 2009, 10:25:09 AM by Lee Mac »

#### SEANT

• Bull Frog
• Posts: 344
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #7 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.
Sean Tessier

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #8 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))`
« Last Edit: November 20, 2009, 10:26:33 AM by Lee Mac »

#### SEANT

• Bull Frog
• Posts: 344
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #9 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.
Sean Tessier

#### VovKa

• Swamp Rat
• Posts: 1370
• Ukraine
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #10 on: November 20, 2009, 10:47:04 AM »
Evgeniy loves keeping people busy for the whole weekend

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #11 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))             (> (cadr n) (cadr lr))             (< (cadr n) (cadr bpx))             (not (member n blst))             (not (member n nlst))        )      (way (append nlst (list n)) walllist)    )  ))`
« Last Edit: November 20, 2009, 11:39:31 AM by Andrea »
Keep smile...

#### GDF

• Water Moccasin
• Posts: 2059
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #12 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.
Why is there never enough time to do it right, but always enough time to do it over?

#### GDF

• Water Moccasin
• Posts: 2059
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #13 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.
Why is there never enough time to do it right, but always enough time to do it over?

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #14 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:
Keep smile...

#### T.Willey

• Needs a day job
• Posts: 5247
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #15 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.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #16 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

eg:
(command "_zoom" "_E")

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

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

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #17 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) )`

#### T.Willey

• Needs a day job
• Posts: 5247
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #18 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

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

I don't want to ' end-up ', I want to ' become '. - Me

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1544
• Moscow (Russia)
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #19 on: November 20, 2009, 03:13:37 PM »
Wow!

I am sorry, I can look a code only tomorrow.
I hope, you perfectly will spend time with this task!
Stay home. Stay safe. Save lives.

#### T.Willey

• Needs a day job
• Posts: 5247
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #20 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.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #21 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...

#### T.Willey

• Needs a day job
• Posts: 5247
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #22 on: November 20, 2009, 03:30:07 PM »
That is how I was going to do my Lee.
Tim

I don't want to ' end-up ', I want to ' become '. - Me

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #23 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))                     (< (cadr a) (cadr 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 }

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #24 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))                     (< (cadr a) (cadr b))                     (< (car a) (car b)))))))    (while (cadr cLst)      (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))`

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #25 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 labyrinth0 = a wall1 = a corridor2 = 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);;-----------------------------;;`
« Last Edit: November 21, 2009, 08:33:37 AM by Kerry Brown »
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #26 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)`
« Last Edit: November 21, 2009, 09:00:17 AM by Kerry Brown »
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #27 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);;-----------------------------;;`
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #28 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
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);;-----------------------------;;`
« Last Edit: November 21, 2009, 09:24:34 AM by Kerry Brown »
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #29 on: November 21, 2009, 10:30:15 AM »
Very nice Kerry!

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))`
« Last Edit: November 21, 2009, 11:00:34 AM by Lee Mac »

#### mjfarrell

• Seagull
• Posts: 14444
• Every Student their own Lesson
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #30 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!

Michael Farrell
http://primeservicesglobal.com/

#### Andrea

• Water Moccasin
• Posts: 2372
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #31 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)  (vl-load-com)  (vla-startundomark    (vla-get-activedocument (vlax-get-acad-object))  )  (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    (vla-get-activedocument (vlax-get-acad-object))  ))(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))             (> (cadr n) (cadr lr))             (< (cadr n) (cadr sp))             (not (member n blst))             (not (member n nlst))        )      (way (append nlst (list n)) walllist)    )  ))`

Keep smile...

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #32 on: November 21, 2009, 03:31:46 PM »
I just like to watch it

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #33 on: November 21, 2009, 11:54:19 PM »
Very nice Kerry!

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.

Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #34 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

Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #35 on: November 22, 2009, 07:24:12 AM »
Very nice Kerry!

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.

#### wizman

• Bull Frog
• Posts: 283
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #36 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

#### Kerry

• Mesozoic relic
• Seagull
• Posts: 11654
• class keyThumper<T>:ILazy<T>
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #37 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
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

--> Donate to theSwamp<--

#### mjfarrell

• Seagull
• Posts: 14444
• Every Student their own Lesson
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #38 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.

Michael Farrell
http://primeservicesglobal.com/

#### Lee Mac

• Seagull
• Posts: 12514
• London, England
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #39 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

#### VovKa

• Swamp Rat
• Posts: 1370
• Ukraine
##### Re: -={Challenge}=- a way through a labyrinth
« Reply #40 on: November 23, 2009, 04:18:56 PM »
let Autodesk Map guys do the job
Code: [Select]
`(vl-load-com)(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 SS   (ssadd) 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)`