Keskustelu: Koodit: VB.NET: Metapallot

Public Class frmBalls
    Inherits System.Windows.Forms.Form

    Const THRESOLD As Double = 0.2 ' Pistä tähän arvo väliltä 0 - 1
    Const VARI As Byte = 0 ' 0 = sininen; 1 = vihreä; 2 = punainen; 3 = valkoinen

    Structure MetaBall
        Dim pos As PointF
        Dim rad As Integer
        Dim mass As Integer
        Dim vel As PointF
    End Structure

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

    Dim b As Bitmap
    Dim g As Graphics

    Dim Phi As Double
    Dim STab(360) As Double
    Dim CTab(360) As Double

#Region " Windows Form Designer generated code "

    Public Sub New()
        MyBase.New()

        'This call is required by the Windows Form Designer.
        InitializeComponent()

        'Add any initialization after the InitializeComponent() call

    End Sub

    'Form overrides dispose to clean up the component list.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    'Required by the Windows Form Designer
    Private components As System.ComponentModel.IContainer

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.
    'Do not modify it using the code editor.
    Friend WithEvents picSurface As System.Windows.Forms.PictureBox
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Me.picSurface = New System.Windows.Forms.PictureBox
        Me.SuspendLayout()
        '
        'picSurface
        '
        Me.picSurface.Location = New System.Drawing.Point(0, 0)
        Me.picSurface.Name = "picSurface"
        Me.picSurface.Size = New System.Drawing.Size(304, 304)
        Me.picSurface.TabIndex = 0
        Me.picSurface.TabStop = False
        '
        'frmBalls
        '
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13)
        Me.ClientSize = New System.Drawing.Size(304, 302)
        Me.Controls.Add(Me.picSurface)
        Me.Name = "frmBalls"
        Me.Text = "Metaballs"
        Me.ResumeLayout(False)

    End Sub

#End Region

    Private Sub frmBalls_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Dim x, y, i As Integer
        Randomize()
        ' 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) = Math.Sin(i * 2 * Math.PI / 360)
            CTab(i) = Math.Cos(i * 2 * Math.PI / 360)
        Next
        ' alustetaan pallot
        For i = 0 To Balls.Length - 1
            Balls(i).rad = Int(Rnd() * 100) + 100
            Balls(i).mass = Int(Rnd() * 20) + 10
        Next
        b = New Bitmap(picSurface.Width, picSurface.Height)
        g = Graphics.FromImage(b)
        picSurface.BackgroundImage = b
    End Sub

    Private Sub frmBalls_Activated(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Activated
        Dim x, y, i, j As Integer
        Dim v As PointF
        Do
            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
            g.Clear(Color.Black)
            For i = 0 To Balls.Length - 1
                ' hidashan tämä on, mutta mielestäni VB koodiksi TOSI nopea
                ' Lasketaan vain pallon ympäriltä
                Dim xi, xa, yi, ya As Integer
                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) += 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 = Balls.Length - 1 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 = bf(x, y) * 255
                                Select Case VARI
                                    Case 0
                                        b.SetPixel(x, y, Color.FromArgb(0, 0, a))
                                    Case 1
                                        b.SetPixel(x, y, Color.FromArgb(0, a, 0))
                                    Case 2
                                        b.SetPixel(x, y, Color.FromArgb(a, 0, 0))
                                    Case 3
                                        b.SetPixel(x, y, Color.FromArgb(a, a, a))
                                End Select
                            End If
                            'nollataan, koska arvoa ei enää tarvita
                            bf(x, y) = 0
                        End If
                    Next
                Next
            Next
            picSurface.BackgroundImage = b
            picSurface.Refresh()
            Application.DoEvents()
        Loop
    End Sub

    Private Sub frmBalls_Closed(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Closed
        ' Jotta ei kävisi niin kuin aiemmassa Raytracing ohjelmassani ;)
        End
    End Sub
End Class