Author Topic: -={Challenge}=- a way through a labyrinth  (Read 10825 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 »
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

Lee Mac

  • Seagull
  • Posts: 12267
  • 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.... :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: 12267
  • 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..   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: 1540
  • 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: 12267
  • 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
AutoCAD 2016 Mechanical

Lee Mac

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

VovKa

  • Swamp Rat
  • Posts: 1153
  • 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: 1992
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: 1992
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: 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...

T.Willey

  • Needs a day job
  • Posts: 5218
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

Please think about donating if this post helped you.

Andrea

  • Water Moccasin
  • Posts: 2360
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 ???

what about all sub-command ??

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: 12267
  • 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: 5218
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 ???

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

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

Please think about donating if this post helped you.

ElpanovEvgeniy

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

I am sorry, I can look a code only tomorrow.
I hope, you perfectly will spend time with this task!
蝸牛そろそろ登れ富士の山 /Kobayashi Issa/

T.Willey

  • Needs a day job
  • Posts: 5218
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

Please think about donating if this post helped you.

Lee Mac

  • Seagull
  • Posts: 12267
  • 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: 5218
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

Please think about donating if this post helped you.

Lee Mac

  • Seagull
  • Posts: 12267
  • 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: 12267
  • 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 »
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)


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


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


added:
lorraine saw this on my screen and asked if I was playing PacMan  :lol:  :-P
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: 12267
  • London, England
Re: -={Challenge}=- a way through a labyrinth
« Reply #29 on: November 21, 2009, 10:30:15 AM »
Very nice Kerry!  :lol:

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!
Be your Best


Michael Farrell
http://primeservicesglobal.com/

Andrea

  • Water Moccasin
  • Posts: 2360
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: 12267
  • 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  :-P  :evil:


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!  :lol:

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: 12267
  • London, England
Re: -={Challenge}=- a way through a labyrinth
« Reply #35 on: November 22, 2009, 07:24:12 AM »
Very nice Kerry!  :lol:

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: 225
Re: -={Challenge}=- a way through a labyrinth
« Reply #36 on: November 22, 2009, 08:30:31 PM »
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

  • 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.
Be your Best


Michael Farrell
http://primeservicesglobal.com/

Lee Mac

  • Seagull
  • Posts: 12267
  • London, England
Re: -={Challenge}=- a way through a labyrinth
« Reply #39 on: November 23, 2009, 01:27:48 PM »
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

  • Swamp Rat
  • Posts: 1153
  • 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)