2D Metaballs

[~Ar-S~]

Here is a great code From Shadoko (french PB Forum)
Note : Disable Debugger before launching

EnJoY   

Code: [Select]

; demo 2d metaballs - pf shadoko -2016

EnableExplicit

Procedure.l ColorBlend(c1.l, c2.l, m.f)
    Protected r.w,g.w,b.w,a.w
    r=  Red(c1) + (Red(c2)     - Red(c1)) * m
    g=Green(c1) + (Green(c2) - Green(c1)) * m
    b= Blue(c1) + (Blue(c2) -   Blue(c1)) * m
    a=Alpha(c1) + (Alpha(c2) - Alpha(c1)) * m
    ProcedureReturn  RGBA(r,g,b,a)
EndProcedure

Procedure.l HSLToRGB(hue, saturation, lightness, alpha=0)
    Protected.f h=hue *6/256
    Protected.f s=saturation/255
    Protected.f l=lightness/255
    Protected.f c,x,r_,v_,b_,m
    c=(1-Abs(2*l-1))*s
    x=c*(1-Abs(Mod(h, 2) -1))
    Select Int(h)
        Case 0:r_=c:v_=x
        Case 1:r_=x:v_=c
        Case 2:v_=c:b_=x
        Case 3:v_=x:b_=c
        Case 4:r_=x:b_=c
        Case 5:r_=c:b_=x
    EndSelect
    m=l-c/2
    Protected r,v,b
    r=Int((r_+m)*255)
    v=Int((v_+m)*255)
    b=Int((b_+m)*255)
    ProcedureReturn RGBA(r,v,b,alpha)
EndProcedure

Procedure.l cola(col,a=$ff)
    ProcedureReturn col|(a<<24)
EndProcedure

Macro copyimagetosprite(im,sp)
    CreateSprite(sp,ImageWidth(im),ImageHeight(im),#PB_Sprite_AlphaBlending)
    StartDrawing(SpriteOutput(sp))
    DrawingMode(#PB_2DDrawing_AllChannels)
    DrawAlphaImage(ImageID(im),0,0)
    StopDrawing()
EndMacro

Procedure min(a,b)
    If a<b:ProcedureReturn a:Else:ProcedureReturn b:EndIf
EndProcedure

Procedure max(a,b)
    If a>b:ProcedureReturn a:Else:ProcedureReturn b:EndIf
EndProcedure

;====================================================================================
Structure sballe
    x.f
    y.f
    dx.f
    dy.f
EndStructure

Global nb=15    ; nombre de balle
Global relief   ; relief (granulosité)
Global dangle.f ; vitesse rotation lumiere
Global di=500   ; largeur image
Global dj=400   ; hauteur image
Global zoom=2   ; zoom
#delais=60*3    ; delais entre changement couleur/relief (en 60eme de seconde)
#delta=64-1     ; largeur balle (+zone d'influence)
#lim=#delta/2

Global Dim b.sballe(nb)
Global Dim reflet.l(255,255)
Global Dim balle.l(#delta*2+1,#delta*2+1)
Global Dim conv.l(32767)
Global Dim angle.w(2047)
Global Dim couleur.l(2)
Global Dim acouleur.l(2)
Global Dim rnd.f(31)

InitSprite()
InitMouse()
InitKeyboard()

Procedure couleurMAJ(v.f)
    Macro lum(x,y,r,nc,a=$ff)
        c=colorblend(acouleur(nc),couleur(nc),v)
        ResetGradientColors()
        GradientColor(0.0,cola(c,a))
        GradientColor(0.2,cola(c,a*0.5))
        GradientColor(1.0,cola(c,0))
        CircularGradient(x,y,r)
        Circle(x,y,r)
    EndMacro
    Static angle.f=1:angle+dangle
    Protected i,r,l,x,y,c,agx.f,agy.f
    StartDrawing(ImageOutput(0))
    DrawingMode(#PB_2DDrawing_AllChannels)
    Box(0,0,256,256,0)
    DrawingMode(#PB_2DDrawing_Gradient|#PB_2DDrawing_AlphaBlend )
    lum(128,128,200,0)
    For i=0 To 15
        agx=angle*rnd(i+0)
        agy=angle*rnd(i+16)
        x=128+80*Sin(agx)
        y=128+80*Sin(agy)
        lum(x,y,40,i % 2+1)
    Next
    CopyMemory(DrawingBuffer(),@ reflet(0,0),256*256*4)
    StopDrawing()
EndProcedure

Procedure initparam()
    Protected i,j
    Protected.f v,d,x,y
    dangle=Random(1)*0.02
    relief=Random(2)*6
    #taille=10:#dmax=#delta/#taille
    For i=0 To #delta*2-1:For j=0 To #delta*2-1
            x=(i-#delta)/#taille
            y=(j-#delta)/#taille
            d=Sqr(1.0+x*x+y*y)
            If d<#dmax:v=0.05*Pow(#dmax*#dmax-d*d,3)+Random(relief):Else:v=0:EndIf
            balle(i,j)=v
    Next:Next
   
    For i=0 To 2:acouleur(i)=couleur(i):couleur(i)=HSLToRGB(Random($ff),$ff,63+128*Bool(i)):Next
       
    For i=0 To ArraySize(conv()):v=200.0*Log(i-1000):If v<0:v=0:EndIf:conv(i)=v:Next
   
    For i=-1024 To 1023:angle(i+1024)=ATan2(1,i/50)*256/#PI+128:Next   
   
EndProcedure

Procedure RenderFrame()
    Static cpt:cpt+1:If cpt=#delais:cpt=0:initparam():EndIf
    Protected Dim bmp.l(dj-1,di-1)
    Protected Dim t.w(di-1,dj-1)
    Protected i,j,k,x,y,t00,rx,ry
    ExamineKeyboard()
    couleurMAJ(cpt/#delais)
    For k=0 To nb
        With b(k)
            \x+\dx:If \x<#lim Or \x>di-#lim:\dx=-\dx:EndIf
            \y+\dy:If \y<#lim Or \y>dj-#lim:\dy=-\dy:EndIf
            For j=max(\y-#delta,0) To min(dj-1,\y+#delta)
                For i=max(\x-#delta,0) To min(di-1,\x+#delta)
                    x=i-\x+#delta
                    y=j-\y+#delta
                    t(i,j)+balle(x,y)
                Next
            Next
        EndWith
    Next
   
    For j=0 To dj-1
        For i=0 To di-1
            t(i,j)=conv(t(i,j))
        Next
    Next
   
    For j=0 To dj-2
        For i=0 To di-2
            t00=t(i,j)
            If t00
                rx=angle(t(i+1,j)-t00+1024)
                ry=angle(t(i,j+1)-t00+1024)
                bmp(j,i)=reflet(ry,rx)
            EndIf
        Next
    Next
    StartDrawing(SpriteOutput(0))
    CopyMemory(@bmp(0,0),DrawingBuffer(),di*dj*4)
    StopDrawing()
   
    DisplaySprite(10,0,0)
    DisplayTransparentSprite(0,0,0)
    If KeyboardReleased(#PB_Key_Escape):End:EndIf
EndProcedure

Procedure init()
    Protected i,j,x,y,r,c
   
    OpenWindow(0,0,0,di* zoom,dj* zoom,"",#PB_Window_BorderLess|#PB_Window_ScreenCentered)
    OpenWindowedScreen(WindowID(0),0,0,di,dj,1,0,0)
    CreateSprite(0,di,dj,#PB_Sprite_AlphaBlending)
    CreateImage(0,256,256,32,#PB_Image_Transparent)
    CreateImage(1,di,dj,32,#PB_Image_Transparent)
   
    ; image de fond
    StartVectorDrawing(ImageVectorOutput(1))
    VectorSourceColor(cola(Random($ffffff)))
    FillVectorOutput()
    For i=0 To di Step 20
        For j=0 To dj Step 20
            x=i+Random(20)
            y=j+Random(20)
            r=5+Random(30)
            c=Random($ffffff)
            VectorSourceCircularGradient(x, y, r)
            VectorSourceGradientColor(cola(c,128),0.0)
            VectorSourceGradientColor(cola(c,64),0.8)
            VectorSourceGradientColor(cola(c,0 ),1.0)     
            AddPathCircle(x,y,r)
            FillPath()
        Next
    Next   
    StopVectorDrawing()
    copyimagetosprite(1,10)
   
    ; position et vitesse initial des balles
    For i=0 To nb:b(i)\x=Random(di-#lim*2,#lim):b(i)\y=Random(dj-#lim*2,#lim):b(i)\dx=(Random(1000)-500)/500:b(i)\dy=(Random(1000)-500)/500:Next
   
    ; coef mouvement des lumieres
    For i=0 To 31:rnd(i)=(Random(2000)-1000)/1000:Next

    initparam()
   
    Repeat:WindowEvent():RenderFrame():FlipBuffers(): ForEver
EndProcedure

init()

[Omnikam]

Wow that is beautiful, thanks

[inc.]

run very slow here.

debugger is disabled.

specs:
PureBasic 5.60
windows 7
24gb ram
Geforce gtx 950
6 Cores at 3.8 Ghz