TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ElpanovEvgeniy 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.
(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.
-
Interesting challenge!
-
my contribution.... :lol:
(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)
)
)
)
)
)
-
haha, nice idea Andrea - but the user still has to trace his/her way through.... ;-)
-
haha, nice idea Andrea - but the user still has to trace his/her way through.... ;-)
Yep.. 8-)
I just having fun playing with this.. ;-)
-
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
((2 1 1)
(1 0 1)
(1 1 -1))
-
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>
-
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. :-)
-
Both left and right should yield good results for an arbitrary maze... I thought,.
Anyway, this works (I think!)
(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))
-
I also think thats true. This particular layout, though, would be navigated a bit quicker with the left hand.
-
Evgeniy loves keeping people busy for the whole weekend :)
-
well....my way to finish the week ! ;-)
(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)
)
)
)
-
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 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.
-
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:
-
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.
-
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
-
Andrea,
what do you get with this?
( ( 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) )
-
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:
-
Wow! :-o
I am sorry, I can look a code only tomorrow.
I hope, you perfectly will spend time with this task!
-
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.
-
I'm just not sure of the output - at the minute mine just outputs "coordinates" in the list...
-
That is how I was going to do my Lee.
-
My Version 2:
(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 } :-(
-
Final Offering... still not perfect..
(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))
-
How about this .. ?
The code is base (loosely) on the Bellman's flood algorithm.
;|
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)
;;-----------------------------
;;
-
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
;;-----------------------------
;;
;; 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)
-
a couple of variations ...
;;-----------------------------
;;
(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)
;;-----------------------------
;;
-
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
;;-----------------------------
;;
(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)
;;-----------------------------
;;
-
Very nice Kerry! :lol:
This uses the "Dead-End Filling" algorithm... { but doesn't like voids... :-( }
(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))
(http://www.theswamp.org/screens/leemac/Labyrinth.gif)
-
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!
-
here's my new one..
;| ;;
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)
)
)
)
-
I just like to watch it :-P :evil:
(http://www.theswamp.org/screens/leemac/Maze.gif)
-
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.
-
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
-
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. :|
-
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
-
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 :)
-
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.
-
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 (http://www.theswamp.org/index.php?topic=30966.0) ;-)
-
let Autodesk Map guys do the job :)
(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)