Author Topic: 2D Metaballs  (Read 814 times)

0 Members and 1 Guest are viewing this topic.

~Ar-S~

• C= 64
• Posts: 47
• Karma: 26
• Demo RuleZ
2D Metaballs
« on: April 06, 2017 »
Here is a great code From Shadoko (french PB Forum)
Note : Disable Debugger before launching

EnJoY

Code: [Select]
`; demo 2d metaballs - pf shadoko -2016EnableExplicitProcedure.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)EndProcedureProcedure.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)EndProcedureProcedure.l cola(col,a=\$ff)    ProcedureReturn col|(a<<24)EndProcedureMacro 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()EndMacroProcedure min(a,b)    If a<b:ProcedureReturn a:Else:ProcedureReturn b:EndIfEndProcedureProcedure max(a,b)    If a>b:ProcedureReturn a:Else:ProcedureReturn b:EndIfEndProcedure;====================================================================================Structure sballe    x.f    y.f    dx.f    dy.fEndStructureGlobal nb=15    ; nombre de balleGlobal relief   ; relief (granulosité)Global dangle.f ; vitesse rotation lumiereGlobal di=500   ; largeur imageGlobal dj=400   ; hauteur imageGlobal 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/2Global 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()EndProcedureProcedure 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      EndProcedureProcedure 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:EndIfEndProcedureProcedure 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(): ForEverEndProcedureinit()`
~ Ar-S ~

Omnikam

• Atari ST
• Posts: 101
• Karma: 4
Re: 2D Metaballs
« Reply #1 on: April 08, 2017 »
Wow that is beautiful, thanks

inc.

• Contact me @ skype: a5recordings
• Amiga 1200
• Posts: 261
• Karma: 19
• I SPEAK ENGLISH & GERMAN as good as i can :D
Re: 2D Metaballs
« Reply #2 on: April 09, 2017 »
run very slow here.

debugger is disabled.

specs:
PureBasic 5.60
windows 7
24gb ram
Geforce gtx 950
6 Cores at 3.8 Ghz
currently coding in PureBasic: GLSL Shader Maker & Editor Tool for further Demo coding usage