Koodit: VB6: Metapallot

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Const SRCCOPY = &HCC0020
Const THRESOLD As Double = 0.2 ' Pistä tähän arvo väliltä 0 - 1
Const VARI As Byte = 3 ' 0 = sininen; 1 = vihreä; 2 = punainen; 3 = valkoinen
Private Type pointf
    x As Integer
    y As Integer
End Type
Private Type metaball
    pos As pointf
    rad As Integer
    mass As Integer
    vel As pointf
End Type

Dim Balls(2) As metaball
Dim bf(300, 300) As Double

Dim Phi As Double
Dim STab(360) As Double
Dim CTab(360) As Double
Const pii = 3.14159265358979


Private Sub Form_Activate()
On Error Resume Next
    Dim x, y, i, j As Integer
    Dim v As pointf
    Do
        Phi = Phi + 5
        If Phi > 360 Then Phi = 0
        ' liikutellaan palloja
        Balls(0).pos.x = STab(Phi) * 90 + 150 + CTab(Phi) * 70
        Balls(0).pos.y = CTab(Phi) * 10 + 150 + STab(Phi) * 70
        Balls(1).pos.x = CTab(Phi) * 30 + 150 + CTab(Phi) * 70
        Balls(1).pos.y = CTab(Phi) * 60 + 150 + STab(Phi) * 70
        Balls(2).pos.x = CTab(Phi) * 50 + 150 + CTab(Phi) * 70
        Balls(2).pos.y = STab(Phi) * 50 + 150 + STab(Phi) * 70
        ' tyhjennetään, jos tätä ei tehtäisi kaikki jäisi näyttöön
        ' kaikki THRESOLDia himmeämmät värit jäisivät näyttöön
        b.Cls
        For i = 0 To UBound(Balls)
            Dim xi, xa, yi, ya
            ' hidashan tämä on, mutta mielestäni VB koodiksi TOSI nopea
            ' Lasketaan vain pallon ympäriltä
            xi = Balls(i).pos.x - Balls(i).rad * 1.5
            If xi < 0 Then xi = 0
            xa = Balls(i).pos.x + Balls(i).rad * 1.5
            If xa > 300 Then xa = 300

            yi = Balls(i).pos.y - Balls(i).rad * 1.5
            If yi < 0 Then yi = 0
            ya = Balls(i).pos.y + Balls(i).rad * 1.5
            If ya > 300 Then ya = 300

            For x = xi To xa
                For y = yi To ya
                    ' Saadaan kaavasta y = 1 / x^2 (sähkökentän vaikutusalue).
                    ' Nippelitietoa tämä on, mutta tästä kaavasta saadaan
                    ' muodostettua kappale, jonka tilavuus on äärellinen,
                    ' mutta pinta-ala ääretön(kiepauta tämän funktion kuvaaja x-akselin ympäri)

                    ' kaava muutetaan muotoon:
                    ' säde / ((sijaintix - ruutux)^2 + (sijaintiy - ruutuy)^2)
                    bf(x, y) = bf(x, y) + Balls(i).rad / ((Balls(i).pos.x - x) * (Balls(i).pos.x - x) + _
                    (Balls(i).pos.y - y) * (Balls(i).pos.y - y))
                    If i = UBound(Balls) Then
                        ' Viimeinen pallo -> bf ei enää muutu
                        ' jotta ei ylittäisi yhtä -> ei virhettä väristä
                        If bf(x, y) > 1 Then bf(x, y) = 1
                        ' Rajoitetaan tummin väri
                        ' Piirretään vain jos kirkkaus on suurempi kuin THRESOLD.
                        ' Tämä on loistava optimointi(Keksin sattumalta), sillä Graphics:in Clear metodi
                        ' on PALJON nopeampi kuin jokaisen pikselin asettaminen yksitellen.
                        If bf(x, y) > THRESOLD Then
                            Dim a As Integer
                            a = bf(x, y) * 255
                            Select Case VARI
                                Case 0
                                    SetPixel b.hdc, x, y, RGB(0, 0, a)
                                Case 1
                                    SetPixel b.hdc, x, y, RGB(0, a, 0)
                                Case 2
                                    SetPixel b.hdc, x, y, RGB(a, 0, 0)
                                Case 3
                                    SetPixel b.hdc, x, y, RGB(a, a, a)
                            End Select
                        End If
                        'nollataan, koska arvoa ei enää tarvita
                        bf(x, y) = 0
                    End If
                Next
            Next
        Next
        DoEvents
    Loop
End Sub

Private Sub Form_Load()

    Dim x As Integer, y As Integer, i As Integer
    Randomize
    b.AutoRedraw = True
    b.Move 0, 0, Width, Height
    b.BackColor = 0
    ' kosini ja sini taulukot etukäteen...
    For i = 0 To 360
        ' i / 360 = rad / 2pi |kerrotaan ristiin
        ' i*2pi = 360rad |:360
        ' i*2pi/360 = rad
        STab(i) = Sin(i * 2 * pii / 360)
        CTab(i) = Cos(i * 2 * pii / 360)
    Next
    ' alustetaan pallot
    For i = 0 To UBound(Balls)
        Balls(i).rad = Int(Rnd() * 100) + 100
        Balls(i).mass = Int(Rnd() * 20) + 10
    Next


End Sub

Private Sub Form_Unload(Cancel As Integer)

    End

End Sub