Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
A* Pathfinding Demo
| Uploader: |  AndT |
| Datum/Zeit: | 03.12.2007 17:20:41 |
'' ------------------------------------------------------------------
'' A* Demonstration using Manhattan Distance Hueristic
'' by coderJeff - November 2007
'' ------------------------------------------------------------------
''
'' The intent of this demonstration was to provide a sample program that
'' displays results similar to "A* Pathfinding for Beginners" tutorial
'' by Patrick Lester, found at:
'' http://www.policyalmanac.org/games/aStarTutorial.htm
''
'' Compiled using FreeBASIC 0.18.3 - however, early versions of FreeBASIC
'' should work.
''
''
'' INSTRUCTIONS
'' ------------
'' LEFT mouse button to set the starting tile
'' RIGHT mouse button to set the ending tile
'' MIDDLE mouse button to toggle the solid tiles
'' ESCAPE key to exit
''
'' ------------------------------------------------------------------
#include once "fbgfx.bi"
const TRUE = -1
const FALSE = 0
const NULL = 0
const SCREEN_W = 640
const SCREEN_H = 480
const CELL_SIZE_W = 64
const CELL_SIZE_H = 64
const CELL_W = SCREEN_W \ CELL_SIZE_W
const CELL_H = SCREEN_H \ CELL_SIZE_H
const CELL_COUNT = CELL_W * CELL_H
#define CELLINDEX(x,y) ((CELL_W*(y))+(x))
const STATE_NONE = 0
const STATE_OPEN = 1
const STATE_CLOSED = 2
''
type Cell
'' Cell Properties
x as integer
y as integer
IsSolid as integer
'' Information needed for A* computation
parent as Cell Ptr
state as integer
f as integer
g as integer
h as integer
end type
''
dim shared Map( 0 to CELL_COUNT - 1 ) as CELL
dim shared StartIndex as integer
dim shared StartCell as Cell ptr
dim shared EndIndex as integer
dim shared EndCell as Cell ptr
dim shared fnt as fb.image ptr
'' ------------------------------------------------------------------
'' CELLS
'' ------------------------------------------------------------------
''
sub CellClearAll()
for y as integer = 0 to CELL_H - 1
for x as integer = 0 to CELL_W - 1
with Map( CELLINDEX(x,y) )
.x = x
.y = y
.IsSolid = FALSE
end with
next
next
end sub
''
sub CellSetSolid( byval x as integer, byval y as integer, byval flag as integer )
dim n as integer = CELLINDEX(x,y)
Map( n ). IsSolid = flag
end sub
''
sub CellSetStart( byval x as integer, byval y as integer )
StartIndex = CELLINDEX(x,y)
StartCell = @Map( StartIndex )
end sub
''
sub CellSetEnd( byval x as integer, byval y as integer )
EndIndex = CELLINDEX(x,y)
EndCell = @Map( EndIndex )
end sub
''
sub CellToggleSolid( byval x as integer, byval y as integer )
with Map( CELLINDEX(x,y) )
if( .IsSolid ) then
.IsSolid = FALSE
else
.IsSolid = TRUE
end if
end with
end sub
'' ------------------------------------------------------------------
'' DISPLAY
'' ------------------------------------------------------------------
''
function CreateNumberFont() as fb.image ptr
dim fontdata as zstring ptr = @ _
" XXXXX XX XXXXX XXXXX X X XXXXX XXXXX XXXXX XXXXX XXXXX" _
" X X X X X X X X X X X X X X" _
" X X X XXXXX XXXXX XXXXX XXXXX XXXXX X XXXXX XXXXX" _
" X X X X X X X X X X X X X" _
" XXXXX XXXXX XXXXX XXXXX X XXXXX XXXXX X XXXXX X"
fnt = ImageCreate( 6 * 10, 6 )
dim p as byte ptr = cast( byte ptr, fnt + 1 )
p[0] = 0
p[1] = asc("0")
p[2] = asc("9")
for i as integer = 0 to 9
p[i+3] = 6
next
for y as integer = 1 to 5
for x as integer = 0 to 10 * 6 - 1
if( fontdata[ (y-1)*10 * 6 + x] = asc("X") ) then
pset fnt,( x, y ), RGB( 255, 255, 255 )
else
pset fnt,( x, y ), RGB( 255, 0, 255 )
end if
next
next
function = fnt
end function
''
sub DrawCell( byval x as integer, byval y as integer )
dim xx as integer = x * CELL_SIZE_W
dim yy as integer = y * CELL_SiZE_H
dim n as integer = CELLINDEX(x,y)
if( Map(n).IsSolid ) then
line( xx, yy ) - ( xx + CELL_SIZE_W - 1, yy + CELL_SIZE_H - 1 ), RGB(0,0,127), bf
end if
if( n = StartIndex ) then
line( xx, yy ) - ( xx + CELL_SIZE_W - 1, yy + CELL_SIZE_H - 1 ), RGB(0,127,0), bf
end if
if( n = EndIndex ) then
line( xx, yy ) - ( xx + CELL_SIZE_W - 1, yy + CELL_SIZE_H - 1 ), RGB(127,0,0), bf
end if
if( Map(n).state <> STATE_NONE ) then
if( Map(n).state = STATE_OPEN ) then
line( xx + 1, yy + 1 ) - ( xx + CELL_SIZE_W - 1 - 1, yy + CELL_SIZE_H - 1 - 1), RGB(0,255,0), b
elseif( Map(n).state = STATE_CLOSED ) then
line( xx + 1, yy + 1 ) - ( xx + CELL_SIZE_W - 1 - 1, yy + CELL_SIZE_H - 1 - 1), RGB(0,255,255), b
line( xx + 2, yy + 2 ) - ( xx + CELL_SIZE_W - 1 - 2, yy + CELL_SIZE_H - 1 - 2), RGB(0,255,255), b
line( xx + 3, yy + 3 ) - ( xx + CELL_SIZE_W - 1 - 3, yy + CELL_SIZE_H - 1 - 3), RGB(0,255,255), b
end if
if( Map(n).parent ) then
dim x1 as integer = xx + CELL_SIZE_W \ 2
dim y1 as integer = yy + CELL_SIZE_H \ 2
dim dx as integer = ( Map(n).parent->x * CELL_SIZE_W + CELL_SIZE_W \ 2 - x1 )
dim dy as integer = ( Map(n).parent->y * CELL_SIZE_H + CELL_SIZE_H \ 2 - y1 )
dim nn as integer = sqr( dx * dx + dy * dy )
dim mm as integer = CELL_SIZE_W \ 3
circle( x1, y1 ), 3, RGB( 191, 191, 191 )
line( x1, y1 ) - ( x1 + dx * mm \ nn, y1 + dy * mm \ nn ), RGB( 191, 191, 191 )
end if
draw string ( xx + 5, yy + 5 ), str( Map(n).f ), , fnt
draw string ( xx + 5, yy + CELL_SIZE_H - 6 - 5), str( Map(n).g ), , fnt
draw string ( xx + CELL_SIZE_W - 5 - len( str( Map(n).h )) * 6, yy + CELL_SIZE_H - 6 - 5), str( Map(n).h ), , fnt
end if
line( xx, yy ) - ( xx + CELL_SIZE_W - 1, yy + CELL_SIZE_H - 1 ), RGB(31,31,63), b
end sub
''
sub DrawMap()
for y as integer = 0 to CELL_H - 1
for x as integer = 0 to CELL_W - 1
DrawCell x, y
next
next
end sub
''
sub DrawPath()
dim c as CELL ptr = EndCell
while( c->parent )
dim x1 as integer = c->x * CELL_SIZE_W + CELL_SIZE_W \ 2
dim y1 as integer = c->y * CELL_SIZE_H + CELL_SIZE_H \ 2
circle( x1, y1 ), 9, RGB( 191, 0, 0 ),,,,f
c = c->parent
wend
end sub
'' ------------------------------------------------------------------
'' A* Computations
'' ------------------------------------------------------------------
''
function ASTAR_GetLowestF( ) as CELL ptr
dim c as CELL ptr = NULL
for i as integer = 0 to CELL_COUNT - 1
if( Map( i ).State = STATE_OPEN ) then
if( c = NULL ) then
c = @Map(i)
else
if( Map(i).f < c->f ) then
c = @Map(i)
end if
end if
end if
next
function = c
end function
''
function ASTAR_CheckNeighbour( byval parent as CELL ptr, byval x as integer, byval y as integer, cost as integer ) as integer
function = FALSE
if( x < 0 or x >= CELL_W ) then
exit function
end if
if( y < 0 or y >= CELL_H ) then
exit function
end if
dim c as CELL ptr = @Map( CELLINDEX(x, y) )
if( c->IsSolid ) then
exit function
end if
if( c->state = STATE_OPEN ) then
if( parent->g + cost < c->g ) then
c->state = STATE_NONE
end if
elseif( c->state = STATE_CLOSED ) then
if( parent->g + cost < c->g ) then
c->state = STATE_NONE
end if
end if
if( c->state = STATE_NONE ) then
c->state = STATE_OPEN
c->g = parent->g + cost
'' This is the Manhattan Distance Heuristic
c->h = abs( c->x - EndCell->x ) * 10 + abs( c->y - EndCell->y ) * 10
c->f = c->g + c->h
c->parent = parent
end if
function = TRUE
end function
''
function ASTAR_CheckNeighbours( byval parent as CELL Ptr, byval x as integer, byval y as integer ) as integer
const DIR_N = 1
const DIR_S = 2
const DIR_W = 4
const DIR_E = 8
dim flag as integer
'' Check all orthogonal directions first N S E W
if( ASTAR_CheckNeighbour( parent, x - 1, y , 10 ) ) then
flag or= DIR_W
end if
if( ASTAR_CheckNeighbour( parent, x , y - 1, 10 ) ) then
flag or= DIR_N
end if
if( ASTAR_CheckNeighbour( parent, x , y + 1, 10 ) ) then
flag or= DIR_S
end if
if( ASTAR_CheckNeighbour( parent, x + 1, y , 10 ) ) then
flag or= DIR_E
end if
'' Only allow a diagonal movement if both orthogonal
'' directions are also allowed
if( ( flag and ( DIR_N or DIR_W )) = ( DIR_N or DIR_W ) ) then
ASTAR_CheckNeighbour( parent, x - 1, y - 1, 14 )
end if
if( ( flag and ( DIR_S or DIR_W )) = ( DIR_S or DIR_W ) ) then
ASTAR_CheckNeighbour( parent, x - 1, y + 1, 14 )
end if
if( ( flag and ( DIR_N or DIR_E )) = ( DIR_N or DIR_E ) ) then
ASTAR_CheckNeighbour( parent, x + 1, y - 1, 14 )
end if
if( ( flag and ( DIR_S or DIR_E )) = ( DIR_S or DIR_E ) ) then
ASTAR_CheckNeighbour( parent, x + 1, y + 1, 14 )
end if
function = 0
end function
''
sub ASTAR_Compute()
dim c as CELL ptr
'' Clear the A* calculations
for i as integer = 0 to CELL_COUNT - 1
Map(i).parent = NULL
Map(i).state = STATE_NONE
Map(i).f = 0
Map(i).g = 0
Map(i).h = 0
next
'' Set the starting CELL as the only one in the open set
c = StartCell
c->State = STATE_OPEN
do
c = ASTAR_GetLowestF()
if( c = NULL ) then
'' No OPEN cells, just quit
exit do
elseif( c = EndCell ) then
'' Success
exit do
end if
'' Add the current cell to the closed list
c->state = STATE_CLOSED
'' Add and compute neighbours
ASTAR_CheckNeighbours( c, c->x, c->y )
loop
end sub
'' ------------------------------------------------------------------
'' MAIN
'' ------------------------------------------------------------------
dim page as integer = 0
dim as integer mx,my,mz,mb,oldmb,xx,yy
CellClearAll()
'' Initialize the starting conditions
CellSetSolid( 5, 2, TRUE )
CellSetSolid( 5, 3, TRUE )
CellSetSolid( 5, 4, TRUE )
CellSetStart( 3, 3 )
CellSetEnd( 7, 3 )
screenres SCREEN_W, SCREEN_H, 32, 2
screenset page, 1-page
page = 1-page
fnt = CreateNumberFont()
do
'' Check for input
oldmb = mb
GetMouse mx,my,mz,mb
if( mx >= 0 and my >= 0 ) then
xx = mx \ CELL_SIZE_W
yy = my \ CELL_SIZE_H
xx = iif( xx < 0, 0, iif( xx >= CELL_W, CELL_W - 1, xx ))
yy = iif( yy < 0, 0, iif( yy >= CELL_H, CELL_H - 1, yy ))
if( ( mb and 1 ) <> 0 and ( oldmb and 1 ) = 0 ) then
CellSetStart( xx, yy )
end if
if( ( mb and 2 ) <> 0 and ( oldmb and 2 ) = 0 ) then
CellSetEnd( xx, yy )
end if
if( ( mb and 4 ) <> 0 and ( oldmb and 4 ) = 0 ) then
CellToggleSolid( xx, yy )
end if
end if
if( multikey( fb.sc_escape ) ) then
exit do
end if
'' Do the A* computation
ASTAR_Compute()
'' Render the output
cls
DrawMap()
DrawPath()
screenset page, 1-page
page = 1-page
sleep 50,1
loop
ImageDestroy( fnt )