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

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