Code-Beispiel

Simu_Electricity von Zamaster

Lizenz:	Erster Autor:	Letzte Bearbeitung:
k. A.	ytwinky	01.04.2012

ScreenShot von Simu_Electricity
Simu_Electricity ist ein Programm von Zamaster aus dem englischen Forum, das ich im April d.J. gesehen habe.
Wegen der Änderungen in FreeBASIC habe ich das Option Explicit zum Kommentar gemacht und eine Deklaration von
Integer nach UInteger geändert(s. Kommentar im Quelltext). Das Programm besteht aus 3 Teilen, die alle vorhanden sein müssen:
1. Die Include-Datei "Particle2.Bi":

'Option Explicit commented due to changes in fb by ytwinky

#Include "fbgfx.bi"



Dim Shared As String  ErrorRet

Dim Shared As Integer MaxParticles

MaxParticles = 1000



Type VLook

    As Double  dist

    As Integer ang

End Type



Type PCommon

    As Double  x , y   ,_   'x,y

               vx, vy  ,_   'velocity

               jx, jy  ,_   'jitter

               hx, hy  ,_   'half jitter

               dx, dy  ,_   'dampen

               tx, ty  ,_   'trend

               ax, ay  ,_   'trend add

               ag, rs  ,_   'angle and rotation speed

               rd, sz  ,_   'rotation damp and size

               sv, sc       'sz modifier and cap

    As Integer lf, tp  ,_   'life and type

               c1, c2  ,_   'colors for tp=1

               cs, sp       'particle cross for generic, Use sprite

End Type





Redim Shared As PCommon Particles(1 To MaxParticles)

Dim Shared As Double i, x, y

Const PI    As Double = Atn(1)*4

Const TWOPI As Double = PI*2

Const Rad   As Double = PI/180



#define SplitR(col1) (col1 Shr 16)

#define SplitG(col1) ((col1 Shr 8) And &HFF)

#define SplitB(col1) (col1 And &HFF)

#define RGBF(RR,GG,BB) (((RR)Shl 16) Or ((GG)Shl 8) Or (BB))

#define GTS() +





Function AdditiveMix(colr1 As Integer, rr As Integer, gg As Integer, bb As Integer) As Integer

    Dim As Integer r,g,b

    r = SplitR(colr1) GTS() rr

    g = SplitG(colr1) GTS() gg

    b = SplitB(colr1) GTS() bb

    If r > 255 Then r = 255

    If g > 255 Then g = 255

    If b > 255 Then b = 255

    Return RGBF(r,g,b)

End Function







Sub GradCircle(xpos As Double, ypos As Double, radius As Double, color1 As Integer, color2 As Integer, crs As Integer)

    Dim As Integer cx, cy, cr, c1, c2

    cx = xpos: cy = ypos: cr = radius: c1 = color1: c2 = color2

    Dim As Integer x, y, r, px, py

    Dim As Integer rr__xx_yy

    Dim As Double TR, TG, TB, RR, GG, BB

    Dim As Integer SR, SG, SB

    Dim As Uinteger c

    RR = SplitR(c2): GG = SplitG(c2): BB = SplitB(c2)

    TR = (SplitR(c1)-RR)/cr

    TG = (SplitG(c1)-GG)/cr

    TB = (SplitB(c1)-BB)/cr





    For y = 0 To cr - 1

        r = y

        rr__xx_yy = r



        For x = 0 To cr - 1



            rr__xx_yy -= x + x - 1



            If rr__xx_yy <= 0 Then

                r += 1

                rr__xx_yy += r + r

            End If



            If r >= cr Then Exit For



            SR = RR + TR*r

            SG = GG + TG*r

            SB = BB + TB*r





            'REPLACE LATER With pixel mix



            px = cx-x: py = cy-y

            Pset (px, py), AdditiveMix(Point(px,py), SR, SG, SB)

            px = cx+x+crs: py = cy-y

            Pset (px, py), AdditiveMix(Point(px,py), SR, SG, SB)



            px = cx-x: py = cy+y+crs

            Pset (px, py), AdditiveMix(Point(px,py), SR, SG, SB)

            px = cx+x+crs: py = cy+y+crs

            Pset (px, py), AdditiveMix(Point(px,py), SR, SG, SB)



        Next x

    Next y



End Sub





Sub ProcessParticles()

    Dim Cpar As Integer

    For Cpar = 1 To MaxParticles

        If Particles(Cpar).lf > 0 Then

            With Particles(Cpar)

                .x  = .x + .tx + .vx + (Rnd *.jx -.hx)

                .y  = .y + .ty + .vy + (Rnd *.jy -.hy)

                .vx *= .dx

                .vy *= .dy

                .tx += .ax

                .ty += .ay

                If .tp <> 4 Then

                    If (.tp = 1 Or .tp = 2) Then

                        .ag += .rs

                        .rs *= .rd

                        If .ag > 360 Then

                            .ag -= 360

                        Elseif .ag < 0 Then

                            .ag += 360

                        Endif

                    Endif

                    If (.tp = 1 Or .tp = 3) Then

                        .sz += .sv

                        If .sz < 0 Then

                            .sz = 0

                            .lf = 1

                        Elseif .sz > .sc Then

                            .sz = .sc

                        Endif

                    Endif

                Endif

                .lf -= 1

            End With

        Endif

    Next Cpar

End Sub







Sub Generate(amount As Integer, life As Integer, x As Double, y As Double, jx As Double, jy As Double, tx As Double, ty As Double, blast As Double, dx As Double, dy As Double, ax As Double, ay As Double, sz As Double, sv As Double, sr As Double, cs As Integer)

    Dim As Integer i, ang

    Dim As Double bmul

    For i = 1 To MaxParticles

        If Particles(i).lf = 0 Then

            With Particles(i)

                .lf = life

                .x = x

                .y = y

                ang = Int(Rnd*360)

                bmul = Rnd*blast

                .vx = Cos(ang*Rad) * bmul

                .vy = Sin(ang*Rad) * bmul

                .jx = jx*2

                .jy = jy*2

                .hx = jx

                .hy = jy

                .dx = dx

                .dy = dy

                .tx = tx

                .ty = ty

                .ax = ax

                .ay = ay

                .sz = sz + (sr * Rnd)

                .sv = sv

                .sc = 100

                .tp = 3

                .cs = cs

            End With

            amount -= 1

        Endif

        If amount = 0 Then Exit For

    Next i

End Sub

2. Das Hauptprogramm "Simu_Electricity.Bas":

'Option Explicit commented due to changes in fb by ytwinky

'Zap! By Zamaster...

'

'- Just a short simple demo of two cool effects!

'





#Include "Particle2.bi"



Function Adder(ByVal src As UInteger, ByVal dest As UInteger) As UInteger

    Dim as uinteger r1,g1,b1

    Dim as uinteger r2,g2,b2

    Dim as uinteger r3,g3,b3,col

    r1 = src SHR 16

    g1 = (src SHR 8) AND &HFF

    b1 = src AND &HFF

    r2 = dest SHR 16

    g2 = (dest SHR 8) AND &HFF

    b2 = dest AND &HFF

    r3 = r1 + r2: If r3 > 255 Then r3 = 255

    g3 = g1 + g2: If g3 > 255 Then g3 = 255

    b3 = b1 + b2: If b3 > 255 Then b3 = 255

    col = b3 OR (g3 SHL 8) OR (r3 SHL 16)

    Return col

End Function



Type OPair

    as integer x,y

End Type



Sub CardFrac(x1 as integer, y1 as integer, x2 as integer, y2 as integer, col as integer,rand as integer)

    Dim as integer RX, FX, RY, FY

    Dim as integer RXC, FXC, RYC, FYC

    Dim as integer l,b,ln

    RX = x2 - x1: If RX = 0 Then RX = 1

    RXC = SGN(RX): FXC = -RXC: FX = ABS(RX)+rand: RX = FX SHL 1 -rand

    RY = y2 - y1: IF RY = 0 Then RY = 1

    RYC = SGN(RY): FYC = -RYC: FY = ABS(RY)+rand: RY = FY SHL 1 -rand

    ln = RX+FX+RY+FY

    Dim as OPair CList(1 to ln)

    For l = 1 to RX

        CList(l).x = RXC

        Clist(l).y = 0

    Next l

    b+=RX

    For l = b+1 to b+FX

        CList(l).x = FXC

        Clist(l).y = 0

    Next l

    b+=FX

    For l = b+1 to b+RY

        CList(l).x = 0

        Clist(l).y = RYC

    Next l

    b+=RY

    For l = b+1 to b+FY

        CList(l).x = 0

        Clist(l).y = FYC

    Next l

    For l = 1 to ln SHL 1

        Swap CList(INT(RND * ln)+1),CList(INT(RND * ln)+1)

    Next l

    Dim as integer px,py

    px = x1: py = y1

    For l = 1 to ln

        Pset (px,py),Adder(col, POINT(px,py))

        px += CList(l).x

        py += CList(l).y

    Next l

End Sub



Screenres 640,480,32,2

screenset 1,0

Dim as uinteger ptr BDrop

BDrop = ImageCreate(640,480)

Bload "Backdrop.bmp",BDrop



Dim as uinteger col, ii 'mit uinteger gibts keine Compiler-Warnungen(Original: Integer)..

Do

    cls

    Put (0,0), BDrop, PSET

    If Int(Rnd * 3) = 1 Then

        col = RGB(0, 128, 255)

        Generate 5, 50,168,280,0,0,0,0,5,0.95,0.95,0,0.2, 5, -.1, 0,0

        Generate 5, 50,536,152,0,0,0,0,5,0.95,0.95,0,0.2, 5, -.1, 0,0

        Circle (168,280),10, RGB(255,0,255),,,,F

        Circle (536,152),10, RGB(255,0,255),,,,F

    Else

        col = RGB(0, 0, 64)

    Endif



    screenlock

    CardFrac 168,280,536,152,col,500

    ProcessParticles()

    For ii = 1 To MaxParticles

        If Particles(ii).lf > 0 Then

            With Particles(ii)

               GradCircle .x, .y, .sz, RGB(128,0,0),RGB(128,128,0), .cs

            End With

        Endif

    Next ii

    screenunlock





    Flip

Loop until inkey$ <> ""

end

3. Das Hintergrundbild BackDrop.Bmp
Das Bild muß aber noch vom Jpg-Format in das Bmp-Format konvertiert werden (z.B. mit MS Paint oder IrfanView).
Diese 3 Dateien kommen in ein Verzeichnis, in dem sie mit dem FreeBASIC-Compiler übersetzt werden können.
Viel Spaß damit..
Gruß
ytwinky

Zusätzliche Informationen und Funktionen

Das Code-Beispiel wurde am 20.08.2007 von ytwinky angelegt.
Die aktuellste Version wurde am 01.04.2012 von Sebastian gespeichert.

Bearbeiten

Versionen