Qbasicnews.com

Qbasicnews.com > QBasic > QB Projects > Has anyone tried A* in QB?
Full Version: Has anyone tried A* in QB?
You're currently viewing a stripped down version of our content. View the full version with proper formatting.

potato

10-10-2004, 12:11 AM
Right now my project is using best-first search method, and it's really crummy.

I've read some articles and I get the jist of A*, but it would take days and either a bunch of arrays or a HUGE array to handle all the calculations and possibilities.

I've got some questions--

1) How fast would A* go in QB for average sized maps (about 10x10)?

2) Do you guys think it's worth trying?

Any other pathfinding suggestions would be helpful, preferably if they can accomplish this:

[Image: logic.gif]
The best path is opaque, the alternate path is slightly transparent.
There's only a one space difference between the two (one takes seven steps, the other takes eight).

My best first search really sucks, too. The BEST it would do is move directly towards the player, falling into the trap at X3 Y0. It's not so much a pathfinding algorithm as it is a "RUN AIMLESSLY INTO THE PLAYER!!!" command. At least it can walk around a 1 block thick or wide obstacle (it can't do mazes, but it can follow edges).

Well, I guess this is just as much an update about the game as it is a suggestion box.[/img]

whitetiger0990

10-10-2004, 12:48 AM
http://forum.qbasicnews.com/viewtopic.php?t=5801

Smile

potato

10-10-2004, 02:20 AM
Quote:
dark_prevail Wrote:excuse my ignorance, but what is an A* algorithm?

the algorithm that will piss you off most when trying to make one.

lol! I forgot about this!

Well, no one actually accomplished it, and I've devised an alternate
solution to my problem (in the Logic file).

I guess this thread can be closed or whatever. Maybe you
guys want to stare at my pretty picture above some more?

whitetiger0990

10-10-2004, 03:44 AM
hey I posted my A* algo.....

potato

10-10-2004, 03:57 AM
Yours is BFS with a bit of read-ahead. It fails to perform
complex routines, though D:

http://send.hokuten.net/astar.bas

I gave it a nice map with one solution, it goes bonkers
and then the program dies when it can't find the solution
after like five steps.

It's still good for simple stuff, and I respect the work you
put into it (from my own game, I know how much of a
pain in the ass ANY kind of AI is to make).

whitetiger0990

10-10-2004, 04:23 AM
yeah mine didn't work all the time

Blitz

10-11-2004, 01:37 AM
Here, full source code.

http://forum.bad-logic.com/viewtopic.php?p=777

Dr_Davenstein

10-27-2004, 10:53 AM
Here's one of mine... I could do it better and cleaner now though...
I hope the code isn't too long for this forum! :???:

Code:
'$DYNAMIC
DEFINT A-Z
DECLARE FUNCTION CheckBounds% ()
DECLARE SUB MakeDungeon (IsFirstMaze%)
DECLARE SUB FixWalls ()
DECLARE SUB FixMaze ()
DECLARE SUB RandomizeMonsters ()
DECLARE SUB Waiter (Amount#)
DECLARE SUB Square (X%, Y%, Col%)
DECLARE SUB DrawMaze ()
DECLARE SUB FindPath (M%, StartX%, StartY%, TargX%, TargY%)

COMMON SHARED MazeLength, MazeHeight, TotalMonsters, TotalRooms
CONST True = -1, OpenL = 1, CloseL = -1, Null = 0
CONST GryHi = 15, BluHi = 1, RedHi = 4, GrnHi = 2

SCREEN 12
WIDTH 80, 60
RANDOMIZE TIMER

MazeLength = 50
MazeHeight = 50
TotalMonsters = 16
TotalRooms = 16

TYPE MonsterStuff
X AS INTEGER
Y AS INTEGER
Hp AS INTEGER
  TargX AS INTEGER
  TargY AS INTEGER
  TempX AS INTEGER
  TempY AS INTEGER
  WalkCnt AS INTEGER
  AMoves AS INTEGER
  HitTarg AS INTEGER
END TYPE

TYPE MazeStuff
AssY AS INTEGER
Exposed AS INTEGER
InRad AS INTEGER
Col AS INTEGER
Typ AS INTEGER
END TYPE

TYPE RoomStuff
X AS INTEGER
Y AS INTEGER
Sx AS INTEGER
Sy AS INTEGER
Lit AS INTEGER
END TYPE

TYPE PathStuff
Cs AS INTEGER
  Px AS INTEGER
  Py AS INTEGER
   F AS INTEGER
   G AS INTEGER
   H AS INTEGER
   P AS INTEGER
END TYPE

TYPE WalkStuff
X AS INTEGER
Y AS INTEGER
END TYPE

DIM SHARED Rm(TotalRooms) AS RoomStuff, Sort(1 TO MazeLength, 1 TO MazeHeight) AS INTEGER
DIM SHARED Maz(1 TO MazeLength, 1 TO MazeHeight) AS MazeStuff, Mark(1 TO MazeLength, 1 TO MazeHeight) AS INTEGER
DIM SHARED Mnstr(1 TO TotalMonsters)  AS MonsterStuff
DIM SHARED Path(1 TO MazeLength, 1 TO MazeHeight) AS PathStuff
DIM SHARED Walk(1 TO ((MazeLength * MazeHeight) \ 2)) AS WalkStuff, TPath(1 TO TotalMonsters, 1 TO TotalMonsters) AS WalkStuff


DO
COLOR (15)
LOCATE 58, 1
PRINT "Building maze, Please Wait.."
  MakeDungeon 1
   LOCATE 58, 1
   PRINT STRING$(28, 32)

RandomizeMonsters
  FOR M = 1 TO TotalMonsters
   Fx = Mnstr(M).X
   Fy = Mnstr(M).Y
    Tx = Mnstr(M).TargX
    Ty = Mnstr(M).TargY
     FindPath M, Tx, Ty, Fx, Fy
  NEXT
   DrawMaze

DO
In$ = INKEY$
GoodCnt = 0
  GotPath = False
   StartAt = StartAt + 1
   IF StartAt > TotalMonsters THEN StartAt = 1
    Fx = Mnstr(StartAt).X
    Fy = Mnstr(StartAt).Y
     Tx = Mnstr(StartAt).TargX
     Ty = Mnstr(StartAt).TargY
      FindPath StartAt, Tx, Ty, Fx, Fy

FOR M = 1 TO TotalMonsters
Mnstr(M).HitTarg = False
Ox = Mnstr(M).X
Oy = Mnstr(M).Y
OWalkCnt = Mnstr(M).WalkCnt
  Mnstr(M).WalkCnt = Mnstr(M).WalkCnt + 1
   IF Mnstr(M).WalkCnt > Mnstr(M).AMoves THEN
    Mnstr(M).WalkCnt = Mnstr(M).AMoves
   END IF
     Mnstr(M).TempX = TPath(M, Mnstr(M).WalkCnt).X
     Mnstr(M).TempY = TPath(M, Mnstr(M).WalkCnt).Y

      IF Mnstr(M).X < Mnstr(M).TempX THEN Mnstr(M).X = Mnstr(M).X + 1
      IF Mnstr(M).X > Mnstr(M).TempX THEN Mnstr(M).X = Mnstr(M).X - 1
       IF Mnstr(M).Y < Mnstr(M).TempY THEN Mnstr(M).Y = Mnstr(M).Y + 1
       IF Mnstr(M).Y > Mnstr(M).TempY THEN Mnstr(M).Y = Mnstr(M).Y - 1

        SELECT CASE Maz(Mnstr(M).X, Mnstr(M).Y).AssY
         CASE 24, 25, 176, 234
          'These are walkable tiles...
         CASE ELSE
          'These are walls...
          Mnstr(M).X = Ox
          Mnstr(M).Y = Oy
          Mnstr(M).WalkCnt = OWalkCnt
        END SELECT


     IF Mnstr(M).X = Mnstr(M).TargX AND Mnstr(M).Y = Mnstr(M).TargY THEN
       Mnstr(M).X = Ox
       Mnstr(M).Y = Oy
       Mnstr(M).HitTarg = True
     END IF

      FOR C = 1 TO TotalMonsters
       IF C <> M THEN
        IF Mnstr(C).Hp > 0 THEN
         IF Mnstr(M).X = Mnstr(C).X AND Mnstr(M).Y = Mnstr(C).Y THEN
          Mnstr(M).X = Ox
          Mnstr(M).Y = Oy
          Mnstr(M).WalkCnt = OWalkCnt
           IF Mnstr(C).HitTarg THEN Mnstr(M).HitTarg = True
         END IF
        END IF
       END IF
      NEXT

   COLOR (Maz(Ox, Oy).Col)
    LOCATE Oy, Ox
     PRINT CHR$(Maz(Ox, Oy).AssY)
   MonCol = M - 1
   IF MonCol = 0 THEN MonCol = 15
   COLOR (MonCol)
    LOCATE Mnstr(M).Y, Mnstr(M).X
     PRINT CHR$(2)
      Square Mnstr(M).TargX, Mnstr(M).TargY, 7
     IF Mnstr(M).X = Ox AND Mnstr(M).Y = Oy THEN
      IF Mnstr(M).HitTarg THEN
       GoodCnt = GoodCnt + 1
      END IF
     END IF
NEXT

Waiter .075
IF In$ = CHR$(27) THEN GOTO Ender
Loops = Loops + 1
IF Loops >= 250 THEN EXIT DO
LOOP UNTIL GoodCnt >= TotalMonsters
Loops = 0
LOOP

Ender:
SYSTEM

REM $STATIC
FUNCTION CheckBounds%
'This function scans the entire level and returns true if it's good...

TotalDots = 0
FOR Y = 1 TO MazeHeight
FOR X = 1 TO MazeLength
  Sort(X, Y) = True
  Mark(X, Y) = True
NEXT
NEXT

FOR Y = 2 TO MazeHeight - 1
FOR X = 2 TO MazeLength - 1
   IF Maz(X, Y).AssY = 0 THEN
    TotalDots = TotalDots + 1
    Sort(X, Y) = 1
    Mark(X, Y) = 0
   END IF
NEXT
NEXT



Tys = MazeHeight - 1
Txs = MazeLength - 1

FOR Y = 2 TO Tys
FOR X = 2 TO Txs
IF Sort(X, Y) <> True AND NOT GotTheMark THEN
  GotTheMark = True
  Mark(X, Y) = True
END IF
NEXT
NEXT


FOR Y1 = 2 TO Tys
FOR X1 = 2 TO Txs
YBegin = Y1 - (Tys - (Tys - Y1))
YFinal = Y1 + (Tys - Y1)
XBegin = X1 - (Txs - (Txs - X1))
XFinal = X1 + (Txs - X1)
Cnt1 = 0: Cnt2 = 0
FakeDots = FakeDots + 1
FOR Y2 = YBegin TO YFinal
FOR X2 = XBegin TO XFinal
  IF X2 >= 2 AND X2 <= Txs AND Y2 >= 2 AND Y2 <= Tys THEN
   Ok1 = Sort(X2 - 1, Y2) <> True AND Mark(X2 - 1, Y2)
   Ok2 = Sort(X2 + 1, Y2) <> True AND Mark(X2 + 1, Y2)
   Ok3 = Sort(X2, Y2 - 1) <> True AND Mark(X2, Y2 - 1)
   Ok4 = Sort(X2, Y2 + 1) <> True AND Mark(X2, Y2 + 1)
   Ok = Ok1 OR Ok2 OR Ok3 OR Ok4
       IF Ok AND Sort(X2, Y2) <> True THEN
         Mark(X2, Y2) = True
          Cnt1 = Cnt1 + 1
           IF Sort(X2, Y2) = 1 THEN
            Cnt2 = Cnt2 + 1
             CountDots = CountDots + 1
             Sort(X2, Y2) = 0
            IF CountDots = TotalDots THEN GOTO Finale
           END IF
       END IF
  END IF
NEXT
NEXT

IF Cnt1 = OCnt1 AND Cnt2 = OCnt2 THEN GOTO Finale
OCnt1 = Cnt1
OCnt2 = Cnt2
NEXT
NEXT

Finale:
IF TotalDots = CountDots THEN CheckBounds% = True


END FUNCTION

SUB DrawMaze

FOR Y = 1 TO MazeHeight
FOR X = 1 TO MazeLength
  COLOR (Maz(X, Y).Col)
  LOCATE Y, X
  PRINT CHR$(Maz(X, Y).AssY)
NEXT
NEXT
END SUB

SUB FindPath (M%, StartX%, StartY%, TargX%, TargY%)
IF StartX = TargX AND StartY = TargY THEN
AlreadyThere = True
GOTO Finalize
END IF
REDIM Path(1 TO MazeLength, 1 TO MazeHeight)  AS PathStuff
Path(StartX, StartY).Cs = OpenL
  FOR C = 1 TO TotalMonsters
   IF C <> M THEN
    IF Mnstr(C).Hp > 0 THEN
    'This gives a penalty to the nodes that are taken by the other monsters.
    'It encourages the algo to find another path.
     Path(Mnstr(C).X, Mnstr(C).Y).P = 1000
    END IF
   END IF
  NEXT
  OnOpenList = 1
  Walk(1).X = StartX
  Walk(1).Y = StartY
  

DO
OCurX = CurX
OCurY = CurY
CurScore = 10000
FOR C = 1 TO OnOpenList
IF Walk(C).X > 0 AND Walk(C).Y > 0 THEN
   IF Path(Walk(C).X, Walk(C).Y).Cs = OpenL THEN
    IF Path(Walk(C).X, Walk(C).Y).F <= CurScore THEN
     CurX = Walk(C).X
     CurY = Walk(C).Y
      CurScore = Path(Walk(C).X, Walk(C).Y).F
      TempC = C
    END IF
   END IF
END IF
NEXT

Path(CurX, CurY).Cs = CloseL
Walk(TempC).X = 0
Walk(TempC).Y = 0

IF CurX = TargX AND CurY = TargY THEN EXIT DO
IF CurX = OCurX AND CurY = OCurY THEN EXIT DO
OldHole = False
FOR Y = -1 TO 1
FOR X = -1 TO 1
  Tx = X + CurX
  Ty = Y + CurY
   IF X = 0 OR Y = 0 THEN MoveCost = 10 ELSE MoveCost = 14
   IF Tx = CurX AND Ty = CurY THEN GOTO SkipNode
  

   SELECT CASE Maz(Tx, Ty).AssY
    CASE 24, 25, 176, 234

    CASE ELSE
     GOTO SkipNode
   END SELECT


   IF Path(Tx, Ty).Cs = Null THEN  
     Path(Tx, Ty).Cs = OpenL
      Path(Tx, Ty).Px = CurX

      Path(Tx, Ty).Py = CurY
       Path(Tx, Ty).G = Path(CurX, CurY).G + MoveCost
       Path(Tx, Ty).H = (ABS(Tx - TargX) + ABS(Ty - TargY)) * 10
       Path(Tx, Ty).F = Path(Tx, Ty).G + Path(Tx, Ty).H + Path(Tx, Ty).P
        IF OldHole THEN
         OnOpenList = OnOpenList + 1
          Walk(OnOpenList).X = Tx
          Walk(OnOpenList).Y = Ty
        ELSE
         OldHole = True
          Walk(TempC).X = Tx
          Walk(TempC).Y = Ty
        END IF
   END IF
SkipNode:
NEXT
NEXT

LOOP

Finalize:
Mnstr(M).WalkCnt = 0
Mnstr(M).AMoves = 1
IF AlreadyThere THEN
   TPath(M, 1).X = StartX
   TPath(M, 1).Y = StartY
  EXIT SUB
END IF
       Tx = Mnstr(M).X
       Ty = Mnstr(M).Y
        FOR C = 1 TO TotalMonsters
         TPath(M, C).X = Path(Tx, Ty).Px
         TPath(M, C).Y = Path(Tx, Ty).Py
          Tx2 = Path(Tx, Ty).Px
          Ty2 = Path(Tx, Ty).Py
           Tx = Tx2
           Ty = Ty2
            IF C > 1 THEN
             Mnstr(M).AMoves = C - 1
            END IF
             IF Tx = 0 OR Ty = 0 THEN
              EXIT FOR
             END IF
        NEXT
END SUB

SUB FixMaze

FOR Y = 1 TO MazeHeight
FOR X = 1 TO MazeLength
  Sort(X, Y) = 0
  Maz(X, Y).Typ = 0
  IF Maz(X, Y).AssY = True THEN
   Sort(X, Y) = True
  END IF
NEXT
NEXT

FOR Y = 1 TO MazeHeight
FOR X = 1 TO MazeLength
  Nw = 0
  Nr = 0
  Ne = 0
  WS = 0
  ES = 0
  Sw = 0
  St = 0
  Se = 0

  IF X > 1 AND Y > 1 THEN
   Nw = Sort(X - 1, Y - 1) = True
  END IF
   IF Y > 1 THEN
    Nr = Sort(X, Y - 1) = True
   END IF
    IF Y > 1 AND X < MazeLength THEN
     Ne = Sort(X + 1, Y - 1) = True
    END IF
     IF X > 1 THEN
      WS = Sort(X - 1, Y) = True
     END IF
      Md = Sort(X, Y) = True
     IF X < MazeLength THEN
      ES = Sort(X + 1, Y) = True
     END IF
    IF X > 1 AND Y < MazeHeight THEN
     Sw = Sort(X - 1, Y + 1) = True
    END IF
   IF Y < MazeHeight THEN
    St = Sort(X, Y + 1) = True
   END IF
  IF X < MazeLength AND Y < MazeHeight THEN
   Se = Sort(X + 1, Y + 1) = True
  END IF


    TLcn = NOT Nr AND NOT WS AND St AND ES AND Md
    BLcn = NOT St AND NOT WS AND Nr AND ES AND Md
     TRcn = NOT Nr AND NOT ES AND St AND WS AND Md
     BRcn = NOT St AND NOT ES AND Nr AND WS AND Md
      Hori = NOT Nr AND NOT St AND WS AND ES AND Md
      Vert = NOT WS AND NOT ES AND Nr AND St AND Md
       TopT = NOT Nr AND St AND WS AND ES AND Md
       BotT = NOT St AND Nr AND WS AND ES AND Md
        LevT = NOT WS AND ES AND Nr AND St AND Md
        RigT = NOT ES AND WS AND Nr AND St AND Md
         Tend = NOT ES AND NOT WS AND NOT Nr AND St AND Md
         Bend = NOT ES AND NOT WS AND NOT St AND Nr AND Md
          Lend = NOT Nr AND NOT St AND NOT WS AND ES AND Md
          Rend = NOT Nr AND NOT St AND NOT ES AND WS AND Md
           Cros = Nr AND St AND ES AND WS AND Md
           Midl = Md AND NOT Nr AND NOT St AND NOT ES AND NOT WS


    IF TLcn THEN Maz(X, Y).AssY = 201: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
    IF BLcn THEN Maz(X, Y).AssY = 200: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
     IF TRcn THEN Maz(X, Y).AssY = 187: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
     IF BRcn THEN Maz(X, Y).AssY = 188: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
      IF Hori THEN Maz(X, Y).AssY = 205: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
      IF Vert THEN Maz(X, Y).AssY = 186: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
       IF TopT THEN Maz(X, Y).AssY = 203: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
       IF BotT THEN Maz(X, Y).AssY = 202: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
        IF LevT THEN Maz(X, Y).AssY = 204: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
        IF RigT THEN Maz(X, Y).AssY = 185: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
         IF Tend THEN Maz(X, Y).AssY = 186: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
         IF Bend THEN Maz(X, Y).AssY = 186: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
          IF Lend THEN Maz(X, Y).AssY = 205: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
          IF Rend THEN Maz(X, Y).AssY = 205: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
           IF Cros THEN Maz(X, Y).AssY = 206: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
           IF Midl THEN Maz(X, Y).AssY = 254: Maz(X, Y).Col = BluHi: Maz(X, Y).Typ = True
  IF Maz(X, Y).AssY = 0 THEN Maz(X, Y).AssY = 176: Maz(X, Y).Col = 8: Maz(X, Y).Typ = 0
NEXT
NEXT

FOR Y1 = 1 TO MazeHeight
FOR X1 = 1 TO MazeLength
  IF Maz(X1, Y1).AssY < 0 THEN
   Maz(X1, Y1).AssY = 177 + INT(RND * 2)
   Maz(X1, Y1).Typ = True
   Maz(X1, Y1).Col = 8
  END IF
NEXT
NEXT

FOR R = 1 TO TotalRooms
FOR Y = Rm(R).Y - 1 TO Rm(R).Y + Rm(R).Sy + 1
  FOR X = Rm(R).X - 1 TO Rm(R).X + Rm(R).Sx + 1
   InXBox = X >= Rm(R).X AND X <= Rm(R).X + Rm(R).Sx
   InYBox = Y >= Rm(R).Y AND Y <= Rm(R).Y + Rm(R).Sy
    Corner1 = X = Rm(R).X - 1 AND Y = Rm(R).Y - 1
    Corner2 = X = Rm(R).X + Rm(R).Sx + 1 AND Y = Rm(R).Y - 1
     Corner3 = X = Rm(R).X - 1 AND Y = Rm(R).Y + Rm(R).Sy + 1
     Corner4 = X = Rm(R).X + Rm(R).Sx + 1 AND Y = Rm(R).Y + Rm(R).Sy + 1
      OnCorner = Corner1 OR Corner2 OR Corner3 OR Corner4

    IF NOT InXBox OR NOT InYBox THEN
     IF Maz(X, Y).AssY = 176 AND NOT OnCorner THEN
      Maz(X, Y).AssY = 234
      Maz(X, Y).Col = 9
      Maz(X, Y).Typ = True
     END IF
    END IF
  NEXT
NEXT
NEXT
END SUB

SUB FixWalls
FOR Y = 1 TO MazeHeight
  FOR X = 1 TO MazeLength
    IF Maz(X, Y).AssY <> 0 THEN
     Maz(X, Y).AssY = -3
    END IF
  NEXT
NEXT

FOR Y = 1 TO MazeHeight
  FOR X = 1 TO MazeLength
   FOR Y2 = Y - 1 TO Y + 1
    FOR X2 = X - 1 TO X + 1
     IF X2 >= 1 AND Y2 >= 1 AND X2 <= MazeLength AND Y2 <= MazeHeight THEN
      IF Maz(X, Y).AssY = 0 THEN
       IF Maz(X2, Y2).AssY <> 0 THEN
        Maz(X2, Y2).AssY = -1
       END IF
      END IF
     END IF
    NEXT
   NEXT
  NEXT
NEXT
END SUB

SUB MakeDungeon (IsFirstMaze%)
StartAgain:
  FOR Y = 1 TO MazeHeight
   FOR X = 1 TO MazeLength
     Maz(X, Y).AssY = True
     Maz(X, Y).Exposed = False
   NEXT
  NEXT

IF IsFirstMaze% = 1 THEN
StartRooms = 1
ELSE
StartRooms = 2
IF NOT StartAgainFlag THEN
  Rm(1).X = Rm(TotalRooms).X
  Rm(1).Y = Rm(TotalRooms).Y
  Rm(1).Sx = Rm(TotalRooms).Sx
  Rm(1).Sy = Rm(TotalRooms).Sy
END IF
   FOR Ry = Rm(1).Y TO Rm(1).Y + Rm(1).Sy
    FOR Rx = Rm(1).X TO Rm(1).X + Rm(1).Sx
     Maz(Rx, Ry).AssY = 0
    NEXT
   NEXT
END IF

StartAgainFlag = True

FOR Rooms = StartRooms TO TotalRooms
Rm(Rooms).X = -1000
Rm(Rooms).Y = -1000
Rm(Rooms).Sx = 1
Rm(Rooms).Sy = 1
Rm(Rooms).Lit = False
IF INT(RND * 100) >= 75 THEN Rm(Rooms).Lit = True
NEXT

Rooms = StartRooms
RandomRooms:
DO
RANDOMIZE TIMER
Rm(Rooms).X = 2 + INT(RND * (MazeLength - 2))
Rm(Rooms).Y = 2 + INT(RND * (MazeHeight - 2))
Rm(Rooms).Sx = 3 + INT(RND * 5)
Rm(Rooms).Sy = 3 + INT(RND * 5)
IF Rm(Rooms).X + Rm(Rooms).Sx > MazeLength - 1 THEN GOTO RandomRooms
IF Rm(Rooms).Y + Rm(Rooms).Sy > MazeHeight - 1 THEN GOTO RandomRooms

FOR R2 = 1 TO TotalRooms
IF R2 <> Rooms THEN
  InX = Rm(R2).X + (Rm(R2).Sx + 3) >= Rm(Rooms).X AND Rm(R2).X <= Rm(Rooms).X + (Rm(Rooms).Sx + 3)
  InY = Rm(R2).Y + (Rm(R2).Sy + 3) >= Rm(Rooms).Y AND Rm(R2).Y <= Rm(Rooms).Y + (Rm(Rooms).Sy + 3)
  InBox = InX AND InY
   IF InBox THEN GOTO RandomRooms
END IF
NEXT

FOR Ey = Rm(Rooms).Y TO Rm(Rooms).Y + Rm(Rooms).Sy
FOR Ex = Rm(Rooms).X TO Rm(Rooms).X + Rm(Rooms).Sx
  IF Ex >= 2 AND Ex <= MazeLength - 1 AND Ey >= 2 AND Ey <= MazeHeight - 1 THEN
   Maz(Ex, Ey).AssY = 0
  END IF
NEXT
NEXT
Rooms = Rooms + 1
LOOP UNTIL Rooms >= TotalRooms + 1

AtX = Rm(1).X + (Rm(1).Sx \ 2)
AtY = Rm(1).Y + (Rm(1).Sy \ 2)

FOR Rooms = 1 TO TotalRooms
TryRoomsAgain:

FOR Fy = 1 TO MazeHeight
  FOR Fx = 1 TO MazeLength
   Sort(Fx, Fy) = Maz(Fx, Fy).AssY
  NEXT
NEXT

AtX = Rm(Rooms).X + INT(RND * ((Rm(Rooms).Sx)))
AtY = Rm(Rooms).Y + INT(RND * ((Rm(Rooms).Sy)))
  IF Rooms < TotalRooms THEN
   TargX = Rm(Rooms + 1).X + INT(RND * (Rm(Rooms + 1).Sx))
   TargY = Rm(Rooms + 1).Y + INT(RND * (Rm(Rooms + 1).Sy))
  ELSE
   TargX = Rm(1).X + INT(RND * (Rm(1).Sx))
   TargY = Rm(1).Y + INT(RND * (Rm(1).Sy))
  END IF

HitTarget = 0


DO
  AddX = 0
  AddY = 0
IF AtX < TargX THEN AddX = 1
IF AtX > TargX THEN AddX = -1
IF AtY < TargY THEN AddY = 1
IF AtY > TargY THEN AddY = -1

FOR R = 1 TO TotalRooms
  InX = AtX >= Rm(R).X - 1 AND AtX <= Rm(R).X + Rm(R).Sx + 1
  InY = AtY >= Rm(R).Y - 1 AND AtY <= Rm(R).Y + Rm(R).Sy + 1
   OnXBorder = AtX = Rm(R).X - 1 OR AtX = Rm(R).X + Rm(R).Sx + 1
   OnYBorder = AtY = Rm(R).Y - 1 OR AtY = Rm(R).Y + Rm(R).Sy + 1
   OnBorder = InX AND InY
    IF OnBorder THEN EXIT FOR
NEXT

IF OnBorder THEN
  IF OnXBorder AND NOT OnYBorder THEN AddY = 0
  IF OnYBorder AND NOT OnXBorder THEN AddX = 0
END IF

   IF AddX <> 0 AND AddY <> 0 THEN
    RandGo = INT(RND * 2)
    IF RandGo = 0 THEN AddX = 0
    IF RandGo = 1 THEN AddY = 0
   END IF
    IF AddX = 0 AND AddY = 0 THEN GOTO TryRoomsAgain

  AtX = AtX + AddX
  AtY = AtY + AddY

   FOR AtY2 = AtY - 1 TO AtY + 1
    FOR AtX2 = AtX - 1 TO AtX + 1
     IF AtX2 >= 2 AND AtX2 <= MazeLength - 1 AND AtY2 >= 2 AND AtY2 <= MazeHeight - 1 THEN
      InX = AtX2 >= Rm(Rooms).X AND AtX2 <= Rm(Rooms).X + Rm(Rooms).Sx
      InY = AtY2 >= Rm(Rooms).Y AND AtY2 <= Rm(Rooms).Y + Rm(Rooms).Sy
       InStartBox = InX AND InY
        IF Sort(AtX2, AtY2) = 0 THEN
         IF NOT InStartBox THEN
          IF AtX2 = AtX OR AtY2 = AtY THEN
           HitTarget = True
          END IF
         END IF
        END IF
     END IF
    NEXT
   NEXT

Sort(AtX, AtY) = 3

IF AtX = TargX AND AtY = TargY THEN HitTarget = True
   IF NOT HitTarget THEN
    FOR R = 1 TO TotalRooms
     Corner1 = AtX = Rm(R).X - 1 AND AtY = Rm(R).Y - 1
     Corner2 = AtX = Rm(R).X + Rm(R).Sx + 1 AND AtY = Rm(R).Y - 1
      Corner3 = AtX = Rm(R).X - 1 AND AtY = Rm(R).Y + Rm(R).Sy + 1
      Corner4 = AtX = Rm(R).X + Rm(R).Sx + 1 AND AtY = Rm(R).Y + Rm(R).Sy + 1
       OnCorner5 = Corner1 OR Corner2 OR Corner3 OR Corner4
       OnCorner = OnCorner5 AND Rooms <> R
     IF OnCorner THEN
      GOTO TryRoomsAgain
     END IF
    NEXT
  END IF

LOOP UNTIL HitTarget

   FOR FixY = 1 TO MazeHeight
    FOR FixX = 1 TO MazeLength
     IF Sort(FixX, FixY) = 3 THEN
      Maz(FixX, FixY).AssY = 3
      Sort(FixX, FixY) = 0
     END IF
    NEXT
   NEXT
NEXT


   FOR FixY = 1 TO MazeHeight
    FOR FixX = 1 TO MazeLength
     IF Maz(FixX, FixY).AssY = 3 THEN
      Maz(FixX, FixY).AssY = 0
     END IF
    NEXT
   NEXT


IF NOT CheckBounds% THEN GOTO StartAgain

FOR Y = 1 TO MazeHeight
  FOR X = 1 TO MazeLength
    IF Y = 1 OR Y = MazeHeight OR X = 1 OR X = MazeLength THEN
     Maz(X, Y).AssY = True
    END IF
  NEXT
NEXT

FixWalls
FixMaze

X1 = Rm(1).X + (Rm(1).Sx \ 2)
Y1 = Rm(1).Y + (Rm(1).Sy \ 2)
X2 = Rm(TotalRooms).X + (Rm(TotalRooms).Sx \ 2)
Y2 = Rm(TotalRooms).Y + (Rm(TotalRooms).Sy \ 2)

Maz(X1, Y1).AssY = 24
Maz(X1, Y1).Col = RedHi

Maz(X2, Y2).AssY = 25
Maz(X2, Y2).Col = BluHi

END SUB

SUB RandomizeMonsters
RandomTarg:
TargX = 1 + INT(RND * MazeLength)
TargY = 1 + INT(RND * MazeHeight)
SELECT CASE Maz(TargX, TargY).AssY
  CASE 24, 25, 176, 234
  CASE ELSE
   GOTO RandomTarg
END SELECT

FOR M = 1 TO TotalMonsters
RandomPos:
Mnstr(M).X = 1 + INT(RND * MazeLength)
Mnstr(M).Y = 1 + INT(RND * MazeHeight)
Mnstr(M).TargX = TargX
Mnstr(M).TargY = TargY
Mnstr(M).Hp = 100
Mnstr(M).HitTarg = False
   SELECT CASE Maz(Mnstr(M).X, Mnstr(M).Y).AssY
    CASE 24, 25, 176, 234
    CASE ELSE
     GOTO RandomPos
   END SELECT
IF Mnstr(M).X = TargX AND Mnstr(M).Y = TargY THEN GOTO RandomPos
  FOR M2 = 1 TO TotalMonsters
   IF M2 <> M THEN
    IF Mnstr(M).X = Mnstr(M2).X AND Mnstr(M).Y = Mnstr(M2).X THEN GOTO RandomPos
   END IF
  NEXT
NEXT
END SUB

SUB Square (X%, Y%, Col%)
COLOR (15)
LOCATE Y, X
PRINT "X"
END SUB

SUB Waiter (Amount#)
TTime# = TIMER + Amount#
DO: LOOP UNTIL TIMER > TTime#
END SUB
Qbasicnews.com > QBasic > QB Projects > Has anyone tried A* in QB?