OK, you forced me to do it....
Here is the code that includes re-generating the topleft portion 20x20 of heatmap for Trees....
Code: Select all
const TILEW = 5
const TILEH = 5
const SCRW = 1280 '100 * TILEW
const SCRH = 600 '100 * TILEH
const Red as ulong = rgb(255,0,0)
const Green as ulong = rgb(0,255,0)
const Blue as ulong = rgb(0,0,255)
const Yellow as ulong = rgb(255,255,0)
const Black as ulong = rgb(0,0,0)
const White as ulong = rgb(255,255,255)
const Gray as ulong = rgb(200,200,200)
const Trees as integer = 1
const IronOre as integer = 2
const BerryBushes as integer = 3
const Mushrooms as integer = 4
dim shared as integer map(100,100,5)
''''''' Map variable explanation
' 0 = object at location (9 = Blocker)
' 5 = quantity of object
'
' the following are for cheap, fast pathfinding routine - heat/influence/flow map
'
' 1 = distance to nearest tree object (#1)
' 2 = distance to nearest iron ore object (#2)
' 3 = distance to nearest Berry Bush Object (#3)
' 4 = distance to nearest Mushroom Object (#4)
dim shared as integer DirInfo(7,2) ' for movement & pathfinding
' directions 0-7
' 7 0 1
' 6 x 2
' 5 4 3
'
' info 0-2: 0 = xAdj, 1 = yAdj, 2 = movecost
data 0,-1,10
data 1,-1,14
data 1,0,10
data 1,1,14
data 0,1,10
data -1,1,14
data -1,0,10
data -1,-1,14
for i as integer = 0 to 7
for j as integer = 0 to 2
read DirInfo(i,j)
next j
next i
dim shared as integer frontier(9000,2)
' frontier for pathfinding (#, cost=0 x=1 y=2 )????????
dim shared as integer frontpointer
' some subroutines....
declare function FrontierAdd(ByVal frontX as integer, ByVal frontY as integer, ByVal frontCost as integer, byval ot as integer) as integer
function FrontierAdd(ByVal frontX as integer, ByVal frontY as integer, ByVal frontCost as integer, byval ot as integer) as integer
' this function uses and alters the shared variables: frontier(9000,2) & frontpointer
' ... add it to the end then bubble sort it down...
dim as integer bub, frontHere
frontpointer = frontpointer + 1
frontHere = frontpointer
frontier(frontpointer,0) = frontCost
frontier(frontpointer,1) = frontX
frontier(frontpointer,2) = frontY
if frontpointer > 1 then
bub = frontpointer
do
if frontier(bub,0) > frontier(bub-1,0) then
swap frontier(bub,0) , frontier(bub-1,0)
swap frontier(bub,1) , frontier(bub-1,1)
swap frontier(bub,2) , frontier(bub-1,2)
frontHere = bub - 1
else
bub = 2 ' early exit
end if
bub = bub - 1
loop until bub < 2
end if
return frontHere
end function
declare function FrontierDel(ByVal thisOne as integer) as integer
function FrontierDel(ByVal thisOne as integer) as integer
select case thisOne
case is < frontpointer
for i as integer = thisOne to (frontpointer-1)
frontier(i,0) = frontier(i+1,0)
frontier(i,1) = frontier(i+1,1)
frontier(i,2) = frontier(i+1,2)
next i
frontpointer = frontpointer - 1
case is = frontpointer
frontpointer = frontpointer - 1
end select
return thisOne
end function
declare sub PutBlocker(ByVal cnt as integer)
sub PutBlocker(ByVal cnt as integer)
dim as integer x, y
for i as integer = 1 to cnt
x = rnd * 92 + 4 : y = rnd * 92 + 4
while map(x,y,0) > 0
x = rnd * 92 + 4 : y = rnd * 92 + 4
wend
map(x,y,5) = 1 : map(x,y,0) = 9 ' put 1 blocker there
' plot it on map - not needed....
line(x*TILEW,y*TILEH)- step(TILEW-2,TILEH-2),rgb(0,0,0),BF
next i
' force an actual walls around middle...
for x = 40 to 60
map(x,40,5) = 1 : map(x,40,0) = 9 ' put 1 blocker there
map(x,60,5) = 1 : map(x,60,0) = 9 ' put 1 blocker there
line(x*TILEW,40*TILEH)- step(TILEW-2,TILEH-2),rgb(0,0,0),BF
line(x*TILEW,60*TILEH)- step(TILEW-2,TILEH-2),rgb(0,0,0),BF
next x
end sub
declare sub PutMapPF(ByVal ot as integer, ByVal cnt as integer)
sub PutMapPF(ByVal ot as integer, ByVal cnt as integer)
dim as integer x, y
for i as integer = 1 to cnt
x = rnd * 92 + 4 : y = rnd * 92 + 4
while map(x,y,0) > 0
x = rnd * 92 + 4 : y = rnd * 92 + 4
wend
map(x,y,5) = 1 : map(x,y,0) = ot ' put 1 object(ot) there
map(X,Y,ot) = 0 ' zero out the distance for that object
' 'add it to the 'frontier' for pathfinding
FrontierAdd(x,y,0, ot)
' plot it on map
line(x*TILEW,y*TILEH)- step(TILEW-2,TILEH-2),rgb(255,255,255),BF
next i
end sub
declare sub MakeHeatMap(ByVal ot as integer)
sub MakeHeatMap(ByVal ot as integer)
' a basic Djistra's Floodfill routine, not optimized at all...
dim as integer x,y,i,j,cost,costDir,costNew, oldPoint
dim as integer x1, y1, c1, clrADJ, clrNew
do
oldPoint = frontpointer
x = frontier(frontpointer,1)
y = frontier(frontpointer,2)
cost = frontier(frontpointer,0)
' remove point from frontier
FrontierDel(oldPoint) 'remove current point from frontier
' error check
' if cost <> map(x,y,ot) then 'ERROR
' beep
' sleep
' end
' end if
' check all 8 directions, if cost to move there is less then their current cost then
' change their cost and add to frontier
for direct as integer = 0 to 7
i = x+DirInfo(direct,0) 'x Adj
j = y+DirInfo(direct,1) 'y Adj
if ((i > 0) and (i < 101)) and ((j > 0) and (j < 101)) then
if (map(i,j,0)<>9) then
costDir = DirInfo(direct,2) ' movecost
costNew = cost + costDir
if map(i,j,ot) > costNew then
if map(i,j,ot)= 999 then
FrontierAdd(i,j,costNew,ot)
end if
map(i,j,ot) = costNew
'plot it
x1 = i*TILEW
y1 = j*TILEH
c1 = rgb(200,200,200) ' degfault grey background
clrNew = 255 - (costNew/1)
if clrNew < 0 then clrNew = 0
select case ot
case 1 ' 1 = distance to nearest tree object (#1)
c1 = rgb(0,clrNew,0)
case 2 ' 2 = distance to nearest iron ore object (#2)
c1 = rgb(clrNew,0,0)
case 3 ' 3 = distance to nearest Berry Bush Object (#3)
c1 = rgb(0,0,clrNew)
case 4 ' 4 = distance to nearest Mushroom Object (#4)
c1 = rgb(clrNew,clrNew,0)
end select
line(x1,y1)- step(TILEW-2,TILEH-2),c1,BF
end if
end if
end if
next direct
loop until frontpointer = 0
end sub
' MAIN
screenres SCRW,SCRH,32
cls
dim as integer x1, y1, c1
' draw grid
for i as integer = 1 to 100
x1 = i*TILEW
for j as integer = 1 to 100
y1 = j*TILEH
c1 = rgb(200,200,200)
select case map(i,j,0)
case 1
c1 = rgb(0,255,0)
case 2
c1 = rgb(255,0,0)
case 3
c1 = rgb(0,0,255)
case 4
c1 = rgb(255,255,0)
end select
line(x1,y1)- step(TILEW-2,TILEH-2),c1,BF
next j
next i
randomize
' fill map with random objects, and init pathfinding heatmaps for each object
' initialize map distances for pathfinding....
for i as integer = 0 to 100
for j as integer = 0 to 100
map(i,j,0) = 0
map(i,j,1) = 999
map(i,j,2) = 999
map(i,j,3) = 999
map(i,j,4) = 999
next j
next i
' Put in some blocking tiles
PutBlocker(100) ' Blocker Tiles
PutMapPF(1,40) ' Trees
MakeHeatMap(1)
locate 3,70 : Print "Heatmap for all 40 Trees"
locate 5,70 : Print "Hit <anykey> to continue"
sleep
' for Tourist Trap
'
' Clear out the topleft region 20x20 except put all those trees into the frontier
for x as integer = 1 to 20
for y as integer = 1 to 20
' clear Tree heatmap
map(x,y,1) = 999
if map(x,y,0) = 1 then 'OOPS! Tree there!
map(x,y,1) = 0
FrontierAdd(x,y,0,1)
end if
next y
next x
makeHeatMap(1)
locate 3,70 : Print "Remade HeatMap for top left 20x20 region"
locate 5,70 : Print "Hit <anykey> to continue"
sleep
PutMapPF(2,5) ' Iron Ore
MakeHeatMap(2)
locate 3,70 : Print "Heatmap for all 5 Iron Ores"
locate 5,70 : Print "Hit <anykey> to continue"
sleep
PutMapPF(3,10) ' Berry Bushes
MakeHeatMap(3)
locate 3,70 : Print "Heatmap for all 10 Berry Bushes"
locate 5,70 : Print "Hit <anykey> to continue"
sleep
PutMapPF(4,5) ' Mushrooms
MakeHeatMap(4)
locate 3,70 : Print "Heatmap for all 5 Mushrooms"
locate 5,70 : Print "Hit <anykey> to continue"
sleep
'draw map
for i as integer = 1 to 100
x1 = i*TILEW
for j as integer = 1 to 100
y1 = j*TILEH
c1 = rgb(50,50,50)
select case map(i,j,0)
case 1
c1 = rgb(0,255,0)
case 2
c1 = rgb(255,0,0)
case 3
c1 = rgb(0,0,255)
case 4
c1 = rgb(255,255,0)
case 9
c1 = rgb(0,0,0)
end select
line(x1,y1)- step(TILEW-2,TILEH-2),c1,BF
next j
next i
sleep