Topic: -={Challenge}=- a way through a labyrinth

[ElpanovEvgeniy]

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.

[Lee Mac]

Interesting challenge!

[Andrea]

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

  


[Lee Mac]

haha, nice idea Andrea - but the user still has to trace his/her way through.... 

[Andrea]

haha, nice idea Andrea - but the user still has to trace his/her way through.... 

Yep..   

I just having fun playing with this..   

[ElpanovEvgeniy]

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]

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>

[SEANT]

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.

[Lee Mac]

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


[SEANT]

I also think that’s true.   This particular layout, though, would be navigated a bit quicker with the left hand.

[VovKa]

Evgeniy loves keeping people busy for the whole weekend

[Andrea]

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



[GDF]

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.

[GDF]

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.

[Andrea]

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:

[T.Willey]

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.

[Andrea]

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

[Lee Mac]

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]

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. 

[ElpanovEvgeniy]

Wow! 

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

[T.Willey]

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.

[Lee Mac]

I'm just not sure of the output - at the minute mine just outputs "coordinates" in the list...

[T.Willey]

That is how I was going to do my Lee.

[Lee Mac]

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]

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]

How about this .. ?

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)


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



[Kerry]

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)



[Kerry]

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)

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


[Kerry]

and it seems to handle voids in the pattern as expected.


added:
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)
;;-----------------------------
;;



[Lee Mac]

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


[mjfarrell]

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!

[Andrea]

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


[Lee Mac]

I just like to watch it   

[Kerry]

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.

[Kerry]

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

[Lee Mac]

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]

Good Thread Guys

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]

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

[mjfarrell]

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.

[Lee Mac]

Good Thread Guys

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]

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)