### Author Topic: -={Challenge}=- a way through a labyrinth  (Read 10509 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)
)
)
)
)

(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)
)
)
)
)

(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)))
)
)
(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)
)
)
)

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