Make Occupied Map From 2 Colour image
This example computes map of 'occupied' rects from the 2 colour image. The Image is expected to be either black (rgb=0 ) or pure white (rgb=$ffffff). The user can draw circles with the mouse to fill the frame in. The occupied Map is drawn behind it in GREEN and RED blocks in real time.
[pbcode]
TileSize=10
Screen=NewIMage(800,600,2)
Dim Map(810/TileSize, (610/TileSize))
Mr=10
Do
setcursor 0,0
mx=mousex()
my=mousey()
mz=mousemovez()
if mz
Mr=cliprange(mr+mz,10,100)
endif
rendertoimage screen
if LeftMouseButton()
circle mx,my,mr,true
Endif
if Spacekey()
Cls 0
endif
rendertoscreen
; Scan the screen and build a map of it
MapImage(Screen,tilesize)
; draw the map as shade boxes
DrawMapArray(0,0,TileSize)
; draw the screen over it
drawimage screen,0,0,true
; draw the users render circle
circle mx,my,mr,true
; controls
print "Mouse To Draw"
print "Space to reset"
Sync
loop
Psub DrawMapArray(Xbase,Ybase,TileSize)
lockbuffer
For ylp=0 to GetArrayElements(Map(),2)-1
Ypos=Ybase+ylp*TileSize
Ypos2=Ypos+TileSize
For xlp=0 to GetArrayElements(Map(),1)-1
if Map(xlp,ylp)
Col=$660000
else
Col=$6600
endif
Xpos=xlp*tileSize
shadebox Xpos,Ypos,Xpos+TileSize,Ypos2,col,0,0,0
next
next
unlockbuffer
EndPsub
Psub MapImage(image,tilesize)
rendertoimage Image
ClearArray Map(),0
Width =GetImageWidth(image)
Height=GetImageHeight(image)
Width2=Width-1
lockbuffer
ThisRgb=Point(0,0)
For ylp=0 to Height-1
Row=Ylp/TIleSize
Xpos=0
repeat
ThisRGb=Fastpoint(Xpos,ylp)
RunSize=PixelRunLength(Xpos,ylp, 1, 0, ThisRGB)
Xpos2=Xpos+RunSize
if ThisRGB
For Xlp=Xpos/TileSize to Xpos2/TileSize
Map(Xlp,Row)=1
next
endif
Xpos+=RunSize
until Xpos=>Width2
; next
next
unlockbuffer
rendertoscreen
EndPsub
[/pbcode]
Nice code!
Make Occupied Map From 2 Colour image - Map Version
This is variant of the routine above, the only difference being in this version, it that it uses PlayBASIC maps to render the grid and map, rather than doing it manually. Moving to maps removes most of the brute force stuff from the runtime and moves the work into the command set giving a better performance. This version can map on one a 1 to 1 ratio in real time.
[pbcode]
TileSize=5
Screen=NewIMage(800,600,2)
global Map =NewMap(10)
global Level =NewLevel(Map,810/TileSize,610/TileSize)
Make_Map_Files(Screen,TileSize)
Mr=10
Do
setcursor 0,0
mx=mousex()
my=mousey()
mz=mousemovez()
if mz
Mr=cliprange(mr+mz,10,100)
endif
rendertoimage screen
if LeftMouseButton()
circle mx,my,mr,true
Endif
if Spacekey()
Cls 0
endif
rendertoscreen
; Scan the screen and build a map of it
MapImage(Screen,tilesize)
; draw the map as shade boxes
drawmap Map,level,0,0
; draw the screen over it
drawimage screen,0,0,true
; draw the users render circle
circle mx,my,mr,true
; controls
print "Mouse To Draw"
print "Space to reset"
Sync
loop
Psub Make_Map_Files(Screen,TileSize)
CreateMapGfx Map,TileSize,TIleSize,5,0,2
rendertoimage screen
ShadeBox 0,0,TileSize,TileSize,$ff00,0,0,0
GetMapBLK Map,0,0,0
ShadeBox 0,0,TileSize,TIleSize,$ff0000,0,0,0
GetMapBLK Map,1,0,0
LevelSolid Map,Level
filllevel Map,level,0,0,100,100,0
cls 0
rendertoscreen
EndPsub
Psub MapImage(image,tilesize)
rendertoimage Image
ClearLevel Map,Level,0
Width =GetImageWidth(image)
Height=GetImageHeight(image)
Width2=Width-1
lockbuffer
ThisRgb=Point(0,0)
For ylp=0 to Height-1
Row=Ylp/TIleSize
Xpos=0
repeat
ThisRGb=Fastpoint(Xpos,ylp)
RunSize=PixelRunLength(Xpos,ylp, 1, 0, ThisRGB)
Xpos2=Xpos+RunSize
if ThisRGB
FillLevel Map,Level,Xpos/TileSize,Row,Xpos2/TileSize,Row,1
endif
Xpos=Xpos2
until Xpos=>Width2
next
unlockbuffer
rendertoscreen
EndPsub
[/pbcode]