Subject: update of 3D maze program
Reply-To: jlatala@humpty.Waterloo.NCR.COM
Organization: NCR Corporation, Waterloo, Ont., Canada
From: jlatala@humpty.waterloo.attgis.com (John Latala)
Message-ID: <#x2z50OB9GA.139@rpc1284.daytonoh.ncr.com>
Newsgroups: comp.sys.hp48
Distribution: world
Date: Tue, 09 Dec 1997 16:55:54 -0500
Lines: 461
Path: republic.btigate.com!atl-news-feed1.bbnplanet.com!cpk-news-hub1.bbnplanet.com!news.bbnplanet.com!newsfeed.internetmci.com!204.71.1.53!pull-feed.internetmci.com!rpc1283.ncr.com!rpc1286!rpc1284.daytonoh.ncr.com!jlatala
Xref: republic.btigate.com comp.sys.hp48:4771

Here's a new version of my 3D maze program for the HP48.

There was a display bug that garbled the display when looking down a long
corridor ... the diamond that indicates that the corridor continues was
drawn in the wrong place.

I was also able to speed it up somewhat because it was doing somethings
in a kind of inefficient manner ... most notably the directions were
changed from being 0/1/2/3/4/5 to being 1/2/3/4/5/6. This was done because
in many places the direction is used as an index into a list. With the 0->5
representation I had to keep adding 1 to get a valid list index.

To create a maze do:

	layers rows columns CREATE

will create a valid maze in the variable MAZE and set the variables L, H, W
to the matching values.

	SOLVE

will solve the current maze. Valid keys during SOLVE are:

	'2'     turn up 90 degrees
	'4'     turn left 90 degrees
	'5'     move forward
	'6'     turn right 90 degrees
	'8'	turn down 90 degrees

	'+/-'   turn around
	'+'     move up one floor
	'-'     move down one floor
	'ENTER' quit

%%HP: T(3)A(D)F(.);
DIR
  CREATE
    \<< 
      0 0 
      \-> l r c d cells
      \<< 
        l r c LRC
        "Creating " l + "x" + r + "x" + c + " maze." + 1 DISP 
        0 CHR 1 CHR + 'd' STO
        "" 1 c START d + NEXT 'd' STO 
        "" 1 r START d + NEXT 'd' STO 
        "" 1 l START d + NEXT 
        'MAZE' STO 
        l 'L' STO 
        r 'H' STO 
        c 'W' STO 
        2 'l' STO 
        2 'r' STO 
        2 'c' STO 
        1 'd' STO 
        l r c 0 PCELL 
        l r c 0 PTRY 
        L 2 / IP W 2 / IP * H 2 / IP * 1 - 'cells' STO
        WHILE 'l==2' EVAL 'r==2' EVAL AND 'c==2' EVAL AND 
        l r c GTRY SWAP OVER 63 == AND NOT REPEAT 
          l "L" \->TAG \->STR 3 DISP 
          r "R" \->TAG \->STR 4 DISP 
          c "C" \->TAG \->STR 5 DISP 
          l r c GTRY "T" \->TAG \->STR 6 DISP
          IF 63 == THEN 
            l r c GBACK 'd' STO 
            l r c d NEWPOS d NEWPOS 'c' STO 'r' STO 'l' STO 
            cells 1 - DUP 'cells' STO \->STR 2 DISP
          ELSE 
            DIRS
            l r c GTRY 1 + GET
            \-> t
            \<<
              IF t SIZE 1 == THEN
                t 1 GET
              ELSE
                t DUP SIZE RANDIR GET
              END
              'd' STO
            \>> 
            l r c 3 DUPN GTRY 2 d 1 - ^ + PTRY
            IF l r c d 1 LEGAL THEN 
              1 2
              START
                l r c d NEWPOS 'c' STO 'r' STO 'l' STO
                l r c 0 PCELL 
                l r c { 2 1 4 3 6 5 } d GET PBACK
              NEXT
              l r c 0 PTRY
            END
          END
        END 
        DROP
      \>>
    \>>
  DISPLAY
    \<< 
      \-> depth clvl crow ccol cdir cup top bot lft rgt dx dy
      \<<
        IF depth 0 == THEN 
          ERASE
        END 
        lft top rgt top LI 
        rgt top rgt bot LI 
        rgt bot lft bot LI 
        lft bot lft top LI 
        lft top lft dx + top dy + LI 
        rgt top rgt dx - top dy + LI 
        lft bot lft dx + bot dy - LI 
        rgt bot rgt dx - bot dy - LI
        IF clvl crow ccol cdir cup 1 GETNEW GCELL 0 == THEN 
          lft dx + top OVER top dy + LI 
          rgt dx - top OVER top dy + LI
        END
        IF clvl crow ccol cdir cup 6 GETNEW GCELL 0 == THEN 
          lft top dy + lft dx + OVER LI 
          lft bot dy - lft dx + OVER LI
        END
        IF clvl crow ccol cdir cup 5 GETNEW GCELL 0 == THEN 
          rgt top dy + rgt dx - OVER LI 
          rgt bot dy - rgt dx - OVER LI
        END
        IF clvl crow ccol cdir cup 2 GETNEW GCELL 0 == THEN 
          lft dx + bot OVER bot dy - LI 
          rgt dx - bot OVER bot dy - LI
        END
        IF clvl crow ccol cdir cup 3 GETNEW GCELL 0 == THEN
          IF rgt lft - 5 dx * > bot top - 5 dy * > AND THEN
            depth 1 + clvl crow ccol cdir cup 3 GETNEW cdir cup top dy + 
            bot dy - lft dx + rgt dx - dx dy DISPLAY
          ELSE 
            lft dx + top dy + rgt dx - bot dy - 
            \-> lft top rgt bot
            \<< 
              lft top rgt top LI 
              rgt top rgt bot LI 
              rgt bot lft bot LI 
              lft bot lft top LI 
              lft top bot + 2 / lft rgt + 2 / top LI
              lft rgt + 2 / top rgt top bot + 2 / LI 
              rgt top bot + 2 / lft rgt + 2 / bot LI 
              lft rgt + 2 / bot lft top bot + 2 / LI
            \>>
          END
        ELSE 
          lft dx + top dy + rgt dx - OVER LI 
          rgt dx - top dy + OVER bot dy - LI 
          rgt dx - bot dy - lft dx + OVER LI 
          lft dx + bot dy - OVER top dy + LI
        END 
        PICT 
        ""
          "L:" + clvl \->STR +
          " R:" + crow \->STR +
          " C:" + ccol \->STR +
          " D:" + "UDNSEW" cdir DUP SUB +
          " U:" + "UDNSEW" cup DUP SUB + 
          1 \->GROB DUP SIZE DROP 2 / # 40h SWAP - # 0h 2 \->LIST SWAP REPL
      \>>
    \>>
  GBACK
    \<< INDEX 1 + MAZE SWAP DUP SUB NUM 2 / 8 MOD \>>
  GCELL
    \<< INDEX 1 + MAZE SWAP DUP SUB NUM 2 MOD \>>
  GDRCELL
    \<< 
      \-> clvl crow ccol cdir cup ddir1 ddir2
      \<< 
        clvl crow ccol cdir cup ddir1 GETNEW cdir cup ddir2 GETNEW GCELL
      \>>
    \>>
  GETNEW
    \<< 
      \-> clvl crow ccol cdir cup ddir
      \<< 
        { 
          { 
            { } 
            { }
            { { 0 1 0 } { 0 -1 0 } { 1 0 0 } { -1 0 0 } { 0 0 -1 } { 0 0 1 } } 
            { { 0 -1 0 } { 0 1 0 } { 1 0 0 } { -1 0 0 } { 0 0 1 } { 0 0 -1 } } 
            { { 0 0 1 } { 0 0 -1 } { 1 0 0 } { -1 0 0 } { 0 1 0 } { 0 -1 0 } } 
            { { 0 0 -1 } { 0 0 1 } { 1 0 0 } { -1 0 0 } { 0 -1 0 } { 0 1 0 } } 
          } 
          {
            { } 
            { } 
            { { 0 1 0 } { 0 -1 0 } { -1 0 0 } { 1 0 0 } { 0 0 1 } { 0 0 -1 } } 
            { { 0 -1 0 } { 0 1 0 } { -1 0 0 } { 1 0 0 } { 0 0 -1 } { 0 0 1 } } 
            { { 0 0 1 } { 0 0 -1 } { -1 0 0 } { 1 0 0 } { 0 -1 0 } { 0 1 0 } } 
            { { 0 0 -1 } { 0 0 1 } { -1 0 0 } { 1 0 0 } { 0 1 0 } { 0 -1 0 } } 
          } 
          { 
            { { 1 0 0 } { -1 0 0 } { 0 1 0 } { 0 -1 0 } { 0 0 1 } { 0 0 -1 } } 
            { { -1 0 0 } { 1 0 0 } { 0 1 0 } { 0 -1 0 } { 0 0 -1 } { 0 0 1 } } 
            { } 
            { } 
            { { 0 0 1 } { 0 0 -1 } { 0 1 0 } { 0 -1 0 } { -1 0 0 } { 1 0 0 } } 
            { { 0 0 -1 } { 0 0 1 } { 0 1 0 } { 0 -1 0 } { 1 0 0 } { -1 0 0 } } 
          } 
          {
            { { 1 0 0 } { -1 0 0 } { 0 -1 0 } { 0 1 0 } { 0 0 -1 } { 0 0 1 } } 
            { { -1 0 0 } { 1 0 0 } { 0 -1 0 } { 0 1 0 } { 0 0 1 } { 0 0 -1 } } 
            { } 
            { } 
            { { 0 0 1 } { 0 0 -1 } { 0 -1 0 } { 0 1 0 } { 1 0 0 } { -1 0 0 } } 
            { { 0 0 -1 } { 0 0 1 } { 0 -1 0 } { 0 1 0 } { -1 0 0 } { 1 0 0 } } 
          } 
          { 
            { { 1 0 0 } { -1 0 0 } { 0 0 1 } { 0 0 -1 } { 0 -1 0 } { 0 1 0 } } 
            { { -1 0 0 } { 1 0 0 } { 0 0 1 } { 0 0 -1 } { 0 1 0 } { 0 -1 0 } } 
            { { 0 1 0 } { 0 -1 0 } { 0 0 1 } { 0 0 -1 } { 1 0 0 } { -1 0 0 } } 
            { { 0 -1 0 } { 0 1 0 } { 0 0 1 } { 0 0 -1 } { -1 0 0 } { 1 0 0 } } 
            { } 
            { } 
          }
          { 
            { { 1 0 0 } { -1 0 0 } { 0 0 -1 } { 0 0 1 } { 0 1 0 } { 0 -1 0 } } 
            { { -1 0 0 } { 1 0 0 } { 0 0 -1 } { 0 0 1 } { 0 -1 0 } { 0 1 0 } }
            { { 0 1 0 } { 0 -1 0 } { 0 0 -1 } { 0 0 1 } { -1 0 0 } { 1 0 0 } } 
            { { 0 -1 0 } { 0 1 0 } { 0 0 -1 } { 0 0 1 } { 1 0 0 } { -1 0 0 } }
            { } 
            { } 
          }
        } 
        cdir GET cup GET ddir GET EVAL 
        \-> dlvl drow dcol
        \<< 
          clvl dlvl +
          IF DUP 1 \>= OVER L \<= AND NOT THEN 
            DROP clvl
          END 
          crow drow +
          IF DUP 1 \>= OVER H \<= AND NOT THEN 
            DROP crow
          END 
          ccol dcol +
          IF DUP 1 \>= OVER W \<= AND NOT THEN 
            DROP ccol
          END
        \>>
      \>>
    \>>
  GTRY
    \<< INDEX MAZE SWAP DUP SUB NUM 64 MOD \>>
  INDEX
    \<< 
      \-> l r c
      \<< 
        H W * l 1 - * W r 1 - * + c 1 - + 2 * 1 +
      \>>
    \>>
  LEGAL
    \<< 
      \-> l r c d x
      \<< 
        {
          \<<
            IF 'l<L-2' EVAL THEN 
              l 2 + r c GCELL x ==
            ELSE 
              0
            END
          \>>
          \<<
            IF 'l>2' EVAL THEN 
              l 2 - r c GCELL x == 
            ELSE 
              0
            END
          \>>
          \<<
            IF 'r<H-2' EVAL THEN 
              l r 2 + c GCELL x ==
            ELSE 
              0
            END
          \>>
          \<<
            IF 'r>2' EVAL THEN 
              l r 2 - c GCELL x ==
            ELSE 
              0
            END
          \>>
          \<<
            IF 'c<W-2' EVAL THEN 
              l r c 2 + GCELL x ==
            ELSE 
              0
            END
          \>>
          \<<
            IF 'c>2' EVAL THEN 
              l r c 2 - GCELL x ==
            ELSE 
              0
            END
          \>> 
        } 
        d GET EVAL
      \>>
    \>>
  LI
    \<< 
      \-> x1 y1 x2 y2
      \<< 
        x1 y1 2 \->LIST 
        x2 y2 2 \->LIST
        LINE
      \>>
    \>>
  LRC
    \<< 
      \-> l r c
      \<<
        IF l 2 MOD 0 == THEN 
          l r c "LEVELS should be odd" DOERR
        END
        IF l 3 < THEN 
          l r c "LEVELS should be >2" DOERR
        END
        IF r 2 MOD 0 == THEN 
          l r c "ROWS should be odd" DOERR
        END
        IF r 3 < THEN 
          l r c "ROWS should be >2" DOERR
        END
        IF c 2 MOD 0 == THEN 
          l r c "COLS should be odd" DOERR
        END
        IF c 3 < THEN 
          l r c "COLS should be >2" DOERR
        END
      \>>
    \>>
  MOVE
    \<< 
      \-> clvl crow ccol cdir cup ddir
      \<<
        IF clvl crow ccol cdir cup ddir GETNEW GCELL 0 == THEN 
          clvl crow ccol cdir cup ddir GETNEW cdir cup ddir GETNEW
        ELSE 
          clvl crow ccol
        END
      \>>
    \>>
  NEWPOS
    \<< 
      4 ROLLD 3 DUPN 
      \-> d l r c tl tr tc
      \<< 
        {
          \<< l 1 + 'tl' STO \>>
          \<< l 1 - 'tl' STO \>>
          \<< r 1 + 'tr' STO \>>
          \<< r 1 - 'tr' STO \>>
          \<< c 1 + 'tc' STO \>>
          \<< c 1 - 'tc' STO \>> 
        } 
        d GET EVAL 
        tl tr tc
      \>>
    \>>
  PBACK
    \<< 
      \-> x
      \<< 
        INDEX 1 + MAZE SWAP DUP2 DUP SUB NUM DUP 2 MOD SWAP 16 / IP 16 * +
        x 8 MOD 2 * + CHR REPL 'MAZE' STO
      \>>
    \>>
  PCELL
    \<< 
      \-> x
      \<< 
        INDEX 1 + MAZE SWAP DUP2 DUP SUB NUM 2 / IP 2 * x 2 MOD + CHR REPL
        'MAZE' STO
      \>>
    \>>
  PTRY
    \<< 
      \-> x
      \<< 
        INDEX MAZE SWAP DUP2 DUP SUB NUM 64 / IP 64 * x 64 MOD + CHR REPL 
        'MAZE' STO
      \>>
    \>>
  RANDIR
    \<< 
      \-> h
      \<< 
        h RAND * IP 1 +
      \>>
    \>>
  SOLVE
    \<< 
      2 2 2 3 1 0 0 1 { } 
      \-> clvl crow ccol cdir cup solved quit redraw keys
      \<<
        IF L 3 \>= L 2 MOD 1 == AND H 3 \>= H 2 MOD 1 == AND AND 
        W 3 \>= W 2 MOD 1 == AND AND L H * W * 2 * MAZE SIZE == AND NOT THEN
          "Bad maze." DOERR
        END
        DO
          IF KEY THEN 
            .1 + keys SWAP + 'keys' STO
          END
          IF redraw keys SIZE 0 == AND THEN 
            clvl crow ccol cdir cup UPDATE 
            7 FREEZE
          END
          IF keys SIZE 0 == THEN 
            0 WAIT
          ELSE  
            keys 1 GET keys 2 OVER SIZE SUB 'keys' STO
          END 
          \-> c
          \<<
            CASE 
              c 51.1 ==
              THEN
                1 'quit' STO
              END 
              c 52.1 ==
              THEN
                { 2 1 4 3 6 5 } cdir GET 'cdir' STO 1 'redraw' STO
              END 
              c 63.1 ==
              THEN
                cdir cup TU90 'cup' STO 'cdir' STO 1 'redraw' STO
              END 
              c 72.1 ==
              THEN
                cdir cup TL90 'cup' STO 'cdir' STO 1 'redraw' STO
              END 
              c 73.1 ==
              THEN
                clvl ccol crow 
                \-> olvl orow ocol
                \<< 
                  clvl crow ccol cdir cup 3 MOVE 
                  'ccol' STO 'crow' STO 'clvl' STO 
                  olvl clvl \=/ orow crow \=/ OR ocol ccol \=/ OR 'redraw' STO
                \>>
              END 
              c 74.1 ==
              THEN
                cdir cup TR90 'cup' STO 'cdir' STO 1 'redraw' STO
              END 
              c 83.1 ==
              THEN
                cdir cup TD90 'cup' STO 'cdir' STO 1 'redraw' STO
              END 
              c 85.1 ==
              THEN
                cdir cup TD90 'cup' STO 'cdir' STO 
                clvl crow ccol cdir cup 3 MOVE 
                'ccol' STO 'crow' STO 'clvl' STO 
                cdir cup TU90 'cup' STO 'cdir' STO 1 'redraw' STO
              END 
              c 95.1 ==
              THEN
                cdir cup TU90 'cup' STO 'cdir' STO 
                clvl crow ccol cdir cup 3 MOVE 
                'ccol' STO 'crow' STO 'clvl' STO 
                cdir cup TD90 'cup' STO 'cdir' STO 
                1 'redraw' STO
              END
            END
          \>> 
          clvl L 1 - == crow H 1 - == AND ccol W 1 - == AND 'solved' STO
        UNTIL solved quit OR END
      \>>
    \>>
  Show
    \<< 
      1 L
      FOR l
        "Layer " l \->STR + TSCROLL 
        H 1
        FOR r 
          ""
          1 W
          FOR c 
            { " " "" } l r c GCELL 1 + GET + 
          NEXT
          TSCROLL 
          -1
        STEP
      NEXT
    \>>
  TD90
    \<< 
      \-> cdir cup
      \<< 
        { 
          { { 1 1 } { 1 1 } { 4 1 } { 3 1 } { 6 1 } { 5 1 } } 
          { { 1 1 } { 1 1 } { 4 2 } { 3 2 } { 6 2 } { 6 2 } } 
          { { 2 3 } { 1 3 } { 1 1 } { 1 1 } { 6 3 } { 5 3 } } 
          { { 2 4 } { 1 4 } { 1 1 } { 1 1 } { 6 4 } { 5 4 } } 
          { { 2 5 } { 1 5 } { 4 5 } { 3 5 } { 1 1 } { 1 1 } } 
          { { 2 6 } { 1 6 } { 4 6 } { 3 6 } { 1 1 } { 1 1 } } 
        } 
        cdir GET cup GET EVAL
      \>>
    \>>
  TL90
    \<< 
      \-> cdir cup
      \<< 
        { 
          { 1 2 5 6 4 3 } 
          { 1 2 6 5 3 4 } 
          { 6 5 3 4 1 2 } 
          { 5 6 3 4 2 1 } 
          { 3 4 2 1 5 6 } 
          { 4 3 1 2 5 6 } 
        } 
        cdir GET cup GET EVAL cup
      \>>
    \>>
  TR90
    \<< 
      \-> cdir cup
      \<< 
        { 
          { 1 2 6 5 3 4 } 
          { 1 2 5 6 4 3 } 
          { 5 6 3 4 2 1 } 
          { 6 5 3 4 1 2 } 
          { 4 3 1 2 5 6 } 
          { 3 4 2 1 5 6 } 
        } 
        cdir GET cup GET EVAL cup 
      \>>
    \>>
  TU90
    \<< 
      \-> cdir cup
      \<< 
        { 
          { { 1 1 } { 1 1 } { 3 2 } { 4 2 } { 5 2 } { 6 2 } } 
          { { 1 1 } { 1 1 } { 3 1 } { 4 1 } { 5 1 } { 6 1 } } 
          { { 1 4 } { 2 4 } { 1 1 } { 1 1 } { 5 4 } { 6 4 } } 
          { { 1 3 } { 2 3 } { 1 1 } { 1 1 } { 5 3 } { 6 3 } } 
          { { 1 6 } { 2 6 } { 3 6 } { 4 6 } { 1 1 } { 1 1 } } 
          { { 1 5 } { 2 5 } { 3 5 } { 4 5 } { 1 1 } { 1 1 } } 
        } 
        cdir GET cup GET EVAL
      \>>
    \>>
  UPDATE
    \<< 
      \-> l r c d u
      \<< 
        { # 0h # 0h } PVIEW 
        0 l r c d u # 0h # 3Fh # 0h # 82h # Ah # 5h DISPLAY
      \>>
    \>>
  ASCLIST 
    { MAZE }
  CST 
    { CREATE SOLVE }
  DIRS 
    { 
      { 6 5 4 3 2 1 } 
      { 6 5 4 3 2   } 
      { 6 5 4 3   1 } 
      { 6 5 4 3     } 
      { 6 5 4   2 1 } 
      { 6 5 4   2   } 
      { 6 5 4     1 } 
      { 6 5 4       } 
      { 6 5   3 2 1 } 
      { 6 5   3 2   } 
      { 6 5   3   1 } 
      { 6 5   3     } 
      { 6 5     2 1 } 
      { 6 5     2   } 
      { 6 5       1 } 
      { 6 5         } 
      { 6   4 3 2 1 } 
      { 6   4 3 2   } 
      { 6   4 3   1 } 
      { 6   4 3     } 
      { 6   4   2 1 } 
      { 6   4   2   } 
      { 6   4     1 } 
      { 6   4       } 
      { 6     3 2 1 } 
      { 6     3 2   } 
      { 6     3   1 } 
      { 6     3     } 
      { 6       2 1 } 
      { 6       2   } 
      { 6         1 } 
      { 6           } 
      {   5 4 3 2 1 } 
      {   5 4 3 2   } 
      {   5 4 3   1 } 
      {   5 4 3     } 
      {   5 4   2 1 } 
      {   5 4   2   } 
      {   5 4     1 } 
      {   5 4       } 
      {   5   3 2 1 } 
      {   5   3 2   } 
      {   5   3   1 } 
      {   5   3     } 
      {   5     2 1 } 
      {   5     2   } 
      {   5       1 } 
      {   5         } 
      {     4 3 2 1 } 
      {     4 3 2   } 
      {     4 3   1 } 
      {     4 3     } 
      {     4   2 1 } 
      {     4   2   } 
      {     4     1 } 
      {     4       } 
      {       3 2 1 } 
      {       3 2   } 
      {       3   1 } 
      {       3     } 
      {         2 1 } 
      {         2   }
      {           1 } 
      {             } 
    }
  H 
    5
  L 
    5
  MAZE
"C2A209F100001000100010001000100010001000100010001000100010001000
1000100010001000100010001000100010001000100010001000100010001000
100010F3000010F3200010001000100010008000100010F3A000A0F380001000
1000100010001000100010001000100010001000100040001000200010001000
1000100010001000100040001000100010001000100010001000100010001000
10001000100010F34000C0F3C00010001000100010001000100010F34000C0F3
C000100010001000100010001000100010001000100010001000100010001000
10001000100010001000100010001000100010001000100010001000100010A8
33"
  W
   5
 END
-- 
john.Latala@Waterloo.NCR.COM

"With your software on a RAID disk subsystem debug time will decrease." - me