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

0 Members and 1 Guest are viewing this topic.

#### ElpanovEvgeniy

• Water Moccasin
• Posts: 1540
• 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 »

#### Lee Mac

• Seagull
• Posts: 12241
• 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: 2360
##### 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: 12241
• 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: 2360
##### 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: 1540
• 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))`

#### Lee Mac

• Seagull
• Posts: 12241
• 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: 324
##### 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: 12241
• 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: 324
##### 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: 1118
• 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: 2360
##### 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: 1989
##### 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: 1989
##### 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: 2360
##### 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...