;FastPixelFill ;Written by Thomas A. Stevenson (wargamer) ;tstevenson@freeze.com ;2/16/01 ;Blitzbasic 1.42, 1.43 ;This is a super fast floodfill routine that ;utilizes WritePixelFast and a list of active points ;to quickly fill any kind of blank area (color 0,0,0) ;inside or outside a boundry of any non blank color ; In the 1.43 version its gotten really slow if debug is on ;Send me a email if you find it useful ;but feel free to use it or modify it in any manner Const scrnw = 800 Const scrnh = 600 Global white Global currentP,LastP,MaxP=5000,ActiveP,MaxA Dim PList(1) Dim dirX(8),dirY(8) diry(1)=-1 dirx(2)= 1 dirY(3)= 1 dirx(4)=-1 ;main *************************************************** Graphics scrnw, scrnh SetBuffer FrontBuffer() ;move the mouse offscreen to keep from getting overwritten MoveMouse scrnw+100, scrnh+100 ;Draw a hexagon with fractal sides xHand=DrawLumb(400,300,200,20,60) ;Flood the inside on screen OnScreenfloodFill(xHand,100,100) WaitKey ;flood the outside on screen OnScreenfloodFill(xHand,2,2) WaitKey ;flood the inside off screen Pcolor=255 Shl 16+ 10 Shl 8 + 10 floodFill(xHand,100,100,Pcolor) WaitKey ;flood the outside off screen Pcolor=10 Shl 16+ 255 Shl 8 + 10 floodFill(xHand,10,10,Pcolor) WaitKey End ;Functions ************************************************ Function OnScreenfloodFill(source,x,y) SetBuffer FrontBuffer() Cls DrawBlock source, 0,0 t0=MilliSecs() Dim PList(maxP) Pcolor=100 Shl 16+ 100 Shl 8 + 100 currentP=0 LastP=0 Plist(LastP)=y Shl 16 + x LockBuffer WritePixelFast x,y,PColor Repeat Until NextPoint(Pcolor,scrnW,ScrnH)=0 UnlockBuffer t1=MilliSecs() Color 255,255,255 Text 700,0,"Time "+Str$(t1-t0) ;Text 700,20,"MaxA "+Str$(maxA) End Function Function floodFill(source,x,y,Pcolor) t0=MilliSecs() w=ImageWidth(source) h=ImageHeight(source) SBuffer=ImageBuffer(source) SetBuffer Sbuffer Dim PList(maxP) currentP=0 LastP=0 Plist(LastP)=y Shl 16 + x LockBuffer WritePixelFast x,y,PColor Repeat Until NextPoint(Pcolor,w,h)=0 UnlockBuffer t1=MilliSecs() SetBuffer FrontBuffer() Cls DrawBlock source,0,0 Color 255,255,255 Text 700,0,"Time "+Str$(t1-t0) End Function Function NextPoint(PColor,w,h) ;pull a point off the list of active points ActiveP=ActiveP-1 x0=PList(currentP) And 65535 Y0=PList(currentP) Shr 16 ;check the four adjacent pixels For i=1 To 4 x=x0+dirX(i) y=y0+dirY(i) If x<0 ElseIf y<0 ElseIf x>W ElseIf y>H ElseIf ReadPixelFast(x,y)=0 Then ; if blank, color and add to active list WritePixelFast x,y,PColor LastP=LastP+1 ActiveP=ActiveP+1 If LastP>maxP Then LastP=0 ;wrap around if at end Plist(LastP)=y Shl 16 + x ;add pixel list EndIf Next ;If ActiveP>maxA Then maxA=ActiveP ;for debugging ;set current point to next on list currentP=currentP+1 If currentP>MaxP Then currentP = 0 ;if at end wrap around Return ActiveP ;we're done when there's no more active points End Function Function fracture(x0,y0,x2,y2,H, Power#, counter) ;Recursive routine for roughing up a line If counter<1 Line x0,y0,x2,y2 Else x1=(x0+x2)/2+H*Rnd(-1,1) y1=(y0+y2)/2+H*Rnd(-1,1) H=H^(power) fracture (x0,y0,x1,y1,H,Power,counter-1) fracture (x1,y1,x2,y2,H,Power,counter-1) EndIf End Function Function DrawLumb(cx,cy,r,m,ang) Color 255,255,255 For i=1 To 6 x1=cx+r*Sin((i-1)*ang) y1=cy+r*Cos((i-1)*ang) x2=cx+r*Sin(i*ang) y2=cy+r*Cos(I*ang) amp=r/5 fracture(x1,y1,x2,y2,amp,0.8,5) Next ;saved it as an image xhand=CreateImage(2*r+2*m,2*r+2*m) GrabImage xhand,cx-r-m,cy-r-m Return xhand End Function