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

0 Members and 1 Guest are viewing this topic.

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1542
  • 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 »
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

  • Seagull
  • Posts: 12296
  • 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: 2368
Re: -={Challenge}=- a way through a labyrinth
« Reply #2 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)
                        )
              )
  )
  )
)

  
« Last Edit: November 20, 2009, 11:39:14 AM by Andrea »
Keep smile...

Lee Mac

  • Seagull
  • Posts: 12296
  • 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: 2368
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..   8-)

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

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1542
  • Moscow (Russia)
Re: -={Challenge}=- a way through a labyrinth
« Reply #5 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))
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

  • Seagull
  • Posts: 12296
  • 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: 332
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
AutoCAD 2016 Mechanical

Lee Mac

  • Seagull
  • Posts: 12296
  • 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: 332
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
AutoCAD 2016 Mechanical

VovKa

  • Swamp Rat
  • Posts: 1174
  • 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: 2368
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: 2003
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?
BricsCAD 2019x64 Windows 10x64

GDF

  • Water Moccasin
  • Posts: 2003
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?
BricsCAD 2019x64 Windows 10x64

Andrea

  • Water Moccasin
  • Posts: 2368
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...