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