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

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

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

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:

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

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:

(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:

(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:

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

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

;;-----------------------------
;;
(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:

;;-----------------------------
;;
(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:

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