FillArea-functio

[Jonhu]

Tuli tehty tälläne pieni paluu coolbasicin pariin..

Tässä nyt yksinkertainen rekursiolla toimiva saman värisen alueen täyttö functio. Soveltuu hyvin joidenkin pienien alueiden uudelleen maalaamiseen...

Code: Select all

////////////////////////////////////////////////
//  AreaFill 0.1    Made by Jonhu    23.12.09 //
////////////////////////////////////////////////

imgx = 0
imgy = 0

Const width  = 200
Const height = 200

Dim ColorTable(width, height)

img = Makeimage2()

Repeat

    If MouseHit(1) Then
        If ( MouseX()<=imgx + ImageWidth(img) And MouseX() >= 0 And MouseY()<=imgy+ImageHeight(img) And MouseY()>=0 ) Then
            FormatColorTable()
            MarkArea( img, MouseX(), MouseY() )
            img = FillArea( img, cbred )
        EndIf
    EndIf
   
    DrawImage img,0,0
    DrawScreen
   
Forever

Function FillArea( img, r=200,g=0,b=0)
    Color r,g,b
    DrawToImage img
    For y=0 To ImageHeight(img)
        For x=0 To ImageWidth(img)
            If ColorTable(x,y)=1 Then Dot x,y
        Next x
    Next y
    DrawToScreen
    Return img
EndFunction

Function MarkArea( img, fillpointx, fillpointy, Distance_=0, r1=0,g1=0,b1=0) // by Jonhu
   
    If colortable(fillpointx, fillpointy) = 1 Then Return False // väri jo merkattu --> palataan
    If (fillpointx >= ImageWidth(img) Or fillpointx<=0 Or fillpointy <=0 Or fillpointy >= ImageHeight(img)) Then Return False // menossa kuvan ulkopuolelle --> palataan
   
    PickImageColor img, fillpointx, fillpointy
   
    If Distance_ = 0 Then  r1 = getRGB(RED) : g1 = getRGB(GREEN) : b1 = getRGB(BLUE)  // merkataan muutettavaväri jos mennään ekaa kierrosta
    If ( getRGB(RED)<>r1 Or getRGB(GREEN)<>g1 Or getRGB(BLUE)<>b1 ) Then Return False // Jos erivärinen kuin alkuperäinen pikseli --> palataan takaisin
    colortable(fillpointx, fillpointy) = 1 

    For a=-1 To 1 Step 2 // a saa arvot -1 ja +1
        MarkArea( img, fillpointx,  fillpointy+a, distance_ + 1, r1,g1,b1)
        MarkArea( img, fillpointx+a,  fillpointy, distance_ + 1, r1,g1,b1)
    Next a

EndFunction

Function Makeimage2()
    img = MakeImage(width,height)
    DrawToImage img
        Box 10,10,190,190,0
        Line 10,30,200,160
        Color cbgreen
        Line 100,3,100,200
        Circle 50,50,100,0
        Color cbblue
        Circle 30,120,14
        Line 0,200,200,20
    DrawToScreen
    Return img
EndFunction

Function FormatColorTable( nro = 0 )
    For x=0 To width
        For y=0 To height
            ColorTable( x, y ) = nro
        Next y
    Next x
EndFunction

[Viltzu]

Ihan toimiva ja näppärä, mutta melko hidas ainakin itselläni. Mutta saisikohan siitä edes nopeampaa.
Ja functio -> funktio

[otto90x]

Kokeilin josko lisänopeutta saavutettaisiin käyttämällä pikselikomentoja dotin sijasta. Enemmän nopeutta saisi piirtämällä suurempia alueita kerralla ja mahdollisesti myös kuvan kaikkien pikseleiden arvot voisi taulukoida jolloin samaa tietoa ei tarvitsisi useaan kertaan hakea.

Code: Select all

Global AreaTableWidth,AreaTableHeight,AreaTableMinX,AreaTableMaxX,AreaTableMinY,AreaTableMaxY

Dim ColorTable(AreaTableWidth,AreaTableHeight)  As Byte

img = MakeImage(200,200)
DrawToImage img
    Box 10,10,190,190,0
    Line 10,30,200,160
    Color cbgreen
    Line 100,3,100,200
    Circle 50,50,100,0
    Color cbblue
    Circle 30,120,14
    Line 0,200,200,20
DrawToScreen

Repeat

    If MouseHit(1) Then
        FormatAreaTables(img)
        MarkArea( img, MouseX(), MouseY() )
        img = FillArea( img, 255)
    ElseIf MouseHit(2) Then
        FormatAreaTables(img)
        MarkArea( img, MouseX(), MouseY() )
        img = FillArea(img)
       
    EndIf
   
   
    DrawImage img,0,0
   
    'Box AreaTableMinX,AreaTableMinY,AreaTableMaxX-AreaTableMinX,AreaTableMaxY-AreaTableMinY,0
    DrawScreen
   
Forever

Function FillArea( img, r=0,g=0,b=0,pixel=0)
    If Not pixel Then pixel = b + (g Shl 8) + (r Shl  16) + (255 Shl 24)
    If pixel Then
        Lock Image(img) 
            For y=AreaTableMinY To AreaTableMaxY
                For x=AreaTableMinX To AreaTableMaxX
                    If ColorTable(x,y)=1 Then PutPixel2 x,y,pixel,Image(img)
                Next x
            Next y
        Unlock Image(img)
    EndIf
    Return img
EndFunction

Function MarkArea( img, fillpointx, fillpointy, Distance_=0, r=0,g=0,b=0,pixel=0)

    If colortable(fillpointx, fillpointy) = 1 Then Return False
    If (fillpointx >= AreaTableWidth Or fillpointx<=0 Or fillpointy <=0 Or fillpointy >= AreaTableHeight) Then Return False
   
    If Not pixel Then pixel = b + (g Shl 8) + (r Shl  16) + (255 Shl 24)
   
    Lock Image(img) 
        pixel2 = GetPixel2 (fillpointx, fillpointy,Image(img))
    Unlock Image(img)
   
    If Distance_ = 0 Then
        pixel = pixel2
        AreaTableMinX = fillpointx
        AreaTableMaxX = fillpointx
        AreaTableMinY = fillpointy
        AreaTableMaxY = fillpointy
    EndIf
   
    If pixel <> pixel2 Then Return False
       
    colortable(fillpointx, fillpointy) = 1
   
    AreaTableMinX = Min(AreaTableMinX,fillpointx)
    AreaTableMaxX = Max(AreaTableMaxX,fillpointx)
    AreaTableMinY = Min(AreaTableMinY,fillpointy)
    AreaTableMaxY = Max(AreaTableMaxY,fillpointy)

    For a=-1 To 1 Step 2 // a saa arvot -1 ja +1
        If Not colortable(fillpointx, fillpointy+a) Then MarkArea( img, fillpointx,  fillpointy+a, distance_ + 1, 0,0,0,pixel)
        If Not colortable(fillpointx+a, fillpointy) Then MarkArea( img, fillpointx+a,  fillpointy, distance_ + 1, 0,0,0,pixel)
    Next a
   
EndFunction

Function FormatAreaTables( img )
    If img Then
       
        AreaTableWidth = ImageWidth(img)
        AreaTableHeight = ImageHeight(img)
       
        ReDim ColorTable(AreaTableWidth,AreaTableHeight)  As Byte
       
        For x=0 To width
            For y=0 To height
                ColorTable( x, y ) = 0
            Next y
        Next x
    Else
        AreaTableWidth = 0
        AreaTableHeight = 0
    EndIf
EndFunction

EDIT: CBSDK:ssa oli näköjään tähän huomattavasti näppärämpi funktio.

Code: Select all

Global dr,dg,db
Global fr,fg,fb
Function Paint(x#,y#,start=1)
    If start = True Then
        dr = getRGB(RED): dg = getRGB(GREEN): db = getRGB(BLUE)
        PickColor x,y
        fr = getRGB(RED): fg = getRGB(GREEN): fb = getRGB(BLUE)        
    EndIf
    PickColor x,y    
    If getRGB(RED) = fr And getRGB(GREEN) = fg And getRGB(BLUE) = fb Then
        Color dr,dg,db
        Dot x,y
        Paint(x-1,y,0)
        Paint(x,y-1,0)
        Paint(x+1,y,0)
        Paint(x,y+1,0)        
    EndIf
End Function

josta muokkasin pikselikomentoversion

Code: Select all

Global dpixel, fpixel


 img = MakeImage(200,200)
    DrawToImage img
        Box 10,10,190,190,0
        Line 10,30,200,160
        Color cbgreen
        Line 100,3,100,200
        Circle 50,50,100,0
        Color cbblue
        Circle 30,120,14
        Line 0,200,200,20
    DrawToScreen

Repeat

    If MouseHit(1) Then
        Color cbred
        Paint(MouseX(),MouseY(),Image(img),1)
    ElseIf MouseHit(2) Then
        Color cbblack
        Paint(MouseX(),MouseY(),Image(img),1)
       
    EndIf
   
   
    DrawImage img,0,0
    
    DrawScreen
   
Forever

Function Paint(x,y,source,start=1)
    //source = Image(img) Or Screen()
    If start = True Then
        dr = getRGB(RED): dg = getRGB(GREEN): db = getRGB(BLUE)
        dpixel = db + (dg Shl 8) + (dr Shl  16) + (255 Shl 24)
        Lock source
            fpixel = GetPixel2 (x,y,source)
            locked = 1
        fr = getRGB(RED): fg = getRGB(GREEN): fb = getRGB(BLUE)        
    EndIf
    If Not locked Then Lock source
        pixel = GetPixel2 (x,y,source)
    
    If pixel = fpixel Then
            PutPixel2 x,y,dpixel,source
        Unlock source
        Paint(x-1,y,source,0)
        Paint(x,y-1,source,0)
        Paint(x+1,y,source,0)
        Paint(x,y+1,source,0)        
    EndIf
    Unlock source
End Function