Keskustelu: Koodit: VB6: Metapallojen paluu

Option Explicit

Private Const BI_RGB As Long = 0&
Private Const CBM_CREATEDIB As Long = &H2
Private Const CBM_INIT As Long = &H4
Private Const DIB_RGB_COLORS As Long = 0&
Private Const PI As Double = 3.14159265358979

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO_256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type

Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type METABALL
    Pos As POINTAPI
    Rad As Integer
    Mass As Integer
    Vel As POINTAPI
    X As Byte
    Y As Byte
End Type

Dim Balls() As METABALL
Dim BF() As Double

Dim STab(359) As Double
Dim CTab(359) As Double

Dim BMP_Info As BITMAPINFO_256, BMP_Buffer() As Byte
Dim Compat_DC As Long, hDIB As Long, Screen_hDC As Long
Dim RealWidth As Integer, RealHeight As Integer

Dim mX As Integer, mY As Integer
Dim Quit As Boolean

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hDC As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_256, ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Sub Init_Palette(ByRef Paletti() As Byte)
    Dim A As Long, B As Long, C As Long
    ' luo mustavalkopaletti
    For A = 4 To 1020 Step 4
        B = A \ 4
        C = B * 1.2
        If C > 255 Then C = 255
        Paletti(A) = C
        Paletti(A + 1) = B
        Paletti(A + 2) = B
    Next A
End Sub
Private Sub Form_Activate()
    Static HereAlready As Boolean
    Dim tmpC As Double, tmpS As Double, tmpX As Long, tmpY As Long
    Dim iX As Long, iY As Long, aX As Long, aY As Long
    Dim X As Single, Y As Single, XX As Long, YX As Long, A As Long
    Dim Phi As Integer
    ' estetään tehokaasti ajamasta tätä moninkertaisena
    If HereAlready Then Exit Sub
    HereAlready = True
    ' nyt sitten tämä varsinainen luuppi
    Do Until Quit
        ' kasvata Phi-arvoa ja pidä se 360 alapuolella silleen viisaasti
        Phi = (Phi + 1) Mod 360
        ' seuraa hiiren sijaintia
        Balls(0).Pos.X = Balls(0).Pos.X + CLng(CSng(mX - Balls(0).Pos.X) / 10)
        Balls(0).Pos.Y = Balls(0).Pos.Y + CLng(CSng(mY - Balls(0).Pos.Y) / 10)
        ' optimointia
        tmpC = (RealWidth \ 2) + (CTab(Phi) * (RealWidth \ 4))
        tmpS = (RealHeight \ 2) + (STab(Phi) * (RealHeight \ 4))
        For A = 1 To UBound(Balls)
            ' liikutellaan palloa tämmöisen hienon kaavan mukaan
            Select Case A Mod 4
                Case 0
                    Balls(A).Pos.X = CLng(STab(Phi) * CDbl(Balls(A).X) + tmpC)
                    Balls(A).Pos.Y = CLng(CTab(Phi) * CDbl(Balls(A).Y) + tmpS)
                Case 1
                    Balls(A).Pos.X = CLng(CTab(Phi) * CDbl(Balls(A).X) + tmpC)
                    Balls(A).Pos.Y = CLng(CTab(Phi) * CDbl(Balls(A).Y) + tmpS)
                Case 2
                    Balls(A).Pos.X = CLng(CTab(Phi) * CDbl(Balls(A).X) + tmpC)
                    Balls(A).Pos.Y = CLng(STab(Phi) * CDbl(Balls(A).Y) + tmpS)
                Case 3
                    Balls(A).Pos.X = CLng(STab(Phi) * CDbl(Balls(A).X) + tmpC)
                    Balls(A).Pos.Y = CLng(STab(Phi) * CDbl(Balls(A).Y) + tmpS)
            End Select
        Next A
        For A = 0 To UBound(Balls) - 1
            tmpX = Balls(A).Rad * 1.5
            ' laske piirtoalue
            iX = Balls(A).Pos.X - tmpX
            If iX < 0 Then iX = 0
            aX = Balls(A).Pos.X + tmpX
            If aX > (RealWidth - 1) Then aX = RealWidth - 1
            iY = Balls(A).Pos.Y - tmpX
            If iY < 0 Then iY = 0
            aY = Balls(A).Pos.Y + tmpX
            If aY > (RealHeight - 1) Then aY = RealHeight - 1
            ' piirrä piirtoalueelle
            YX = iY * RealWidth
            For Y = iY To aY
                For X = iX To aX
                    XX = YX + X
                    tmpX = (Balls(A).Pos.X - X)
                    tmpY = (Balls(A).Pos.Y - Y)
                    If tmpX <> 0 Or tmpY <> 0 Then
                        BF(XX) = BF(XX) + Balls(A).Rad / CSng(tmpX * tmpX + tmpY * tmpY)
                    Else
                        BF(XX) = 1
                    End If
                Next X
                ' pieni optimointikikka, ei tarvitse tehdä niin paljon kertolaskua
                YX = YX + RealWidth
            Next Y
        Next A
        tmpX = Balls(A).Rad * 1.5
        ' laske piirtoalue
        iX = Balls(A).Pos.X - tmpX
        If iX < 0 Then iX = 0
        aX = Balls(A).Pos.X + tmpX
        If aX > (RealWidth - 1) Then aX = RealWidth - 1
        iY = Balls(A).Pos.Y - tmpX
        If iY < 0 Then iY = 0
        aY = Balls(A).Pos.Y + tmpX
        If aY > (RealHeight - 1) Then aY = RealHeight - 1
        ' piirrä piirtoalueelle
        YX = iY * RealWidth
        For Y = iY To aY
            For X = iX To aX
                XX = YX + X
                tmpX = (Balls(A).Pos.X - X)
                tmpY = (Balls(A).Pos.Y - Y)
                If tmpX <> 0 Or tmpY <> 0 Then
                    BF(XX) = BF(XX) + Balls(A).Rad / CSng(tmpX * tmpX + tmpY * tmpY)
                Else
                    BF(XX) = 1
                End If
            Next X
            ' pieni optimointikikka, ei tarvitse tehdä niin paljon kertolaskua
            YX = YX + RealWidth
        Next Y
        ' sitten itse piirtoalue ja nollaustemput
        YX = 0
        For Y = 0 To RealHeight - 1
            For X = 0 To RealWidth - 1
                XX = YX + X
                If BF(XX) > 1 Then BF(XX) = 1
                BMP_Buffer(XX) = CByte((BF(XX) * 255))
                BF(XX) = 0
            Next X
            ' pieni optimointikikka, ei tarvitse tehdä niin paljon kertolaskua
            YX = YX + RealWidth
        Next Y


        ' piirrä vain jos ohjelmaa ei ole lopetettu...
        If Not Quit Then
            ' luo bittikartta
            hDIB = CreateDIBitmap(Screen_hDC, BMP_Info.bmiHeader, CBM_INIT Or CBM_CREATEDIB, BMP_Buffer(0), BMP_Info, DIB_RGB_COLORS)

            ' linkitä bittikartta luomaamme Device Contextiin
            SelectObject Compat_DC, hDIB

            ' kopioi lopputulos näkyville
            StretchBlt hDC, 0, 0, ScaleWidth, ScaleHeight, Compat_DC, 0, ScaleHeight - 1, ScaleWidth, -ScaleHeight, vbSrcCopy

            ' tuhoa luomamme bittikartta
            DeleteObject hDIB

            ' päivitä näkymä
            'Refresh
            ' ja sitten ettei jää ohjelma ihan lukkoon
            DoEvents
        End If
    Loop
    ' ja nyt tämän voi jo pistää toimimaan toistamiseen
    HereAlready = False
End Sub
Private Sub Form_Load()
    Dim tmpDouble As Double
    Dim A As Integer
    Dim Paletti(1023) As Byte

    On Error Resume Next
    Debug.Print 1 \ 0
    If Err.Number Then Err.Clear: MsgBox "Käännä ohjelma ensin (ja muista törkätä jok'ikinen optimointi päälle!)": Quit = True: Exit Sub
    On Error GoTo 0

    ' jotta toimii varmasti oikein...
    ScaleMode = vbPixels

    ' aseta kooksi neljännes ruudun koosta
    Width = Screen.Width \ 4
    Height = Screen.Height \ 4

    ' muistissa tavujen leveysmäärän tulee olla aina jaollinen neljällä
    ' siksi tarvitsemme sen verran ylimääräisiä turhia tavuja myös 256-värin bittikartassa - jokaisella rivillä
    If ScaleWidth Mod 4 Then
        RealWidth = ScaleWidth + 4 - ScaleWidth Mod 4
    Else
        RealWidth = ScaleWidth
    End If
    RealHeight = ScaleHeight

    ' varaa muisti bittikarttaa varten
    ReDim BMP_Buffer(CLng(RealWidth) * CLng(RealHeight) - 1)

    ' mikä lie, en välitä kun olen optimoimassa tätä koodia
    ReDim BF(CLng(RealWidth) * CLng(RealHeight) - 1)
    tmpDouble = PI / 360
    For A = 0 To 359
        STab(A) = Sin((A + A) * tmpDouble)
        CTab(A) = Cos((A + A) * tmpDouble)
    Next

    ' alusta mustavalkopaletti
    Init_Palette Paletti

    ' kopioi paletti bittikartan tietoihin
    CopyMemory ByVal VarPtr(BMP_Info.bmiColors(0)), ByVal VarPtr(Paletti(0)), 1024

    ' alusta bittikartan tiedot
    With BMP_Info.bmiHeader
        .biSize = Len(BMP_Info.bmiHeader)
        .biWidth = ScaleWidth                   ' leveys pikseleinä
        .biHeight = ScaleHeight                 ' korkeus pikseleinä
        .biPlanes = 1                           ' yhden värin kerros
        .biBitCount = 8                         ' 8 bittiä pikseliä kohden
        .biCompression = BI_RGB                 ' ei pakkausta, tavanomista RGB:tä
        .biSizeImage = 0                        ' tarpeeton kun ei ole pakkausta
        .biXPelsPerMeter = 0                    ' ei tarvita
        .biYPelsPerMeter = 0                    ' ei tarvita
        .biClrUsed = 256                        ' kuvan käyttämien värien määrä väritaulukossa (0 = kaikki)
        .biClrImportant = 256                   ' tärkeiden värien määrä (ts. paletin värit, 0 = kaikki värit)
    End With

    ' tarvitsemme jonkin Device Contextin bittikarttaa varten, joten luo ruudun kanssa yhteensopiva
    Screen_hDC = GetDC(0)

    ' luo formin kanssa yhteensopiva Device Context
    Compat_DC = CreateCompatibleDC(hDC)

    ' alustetaan sitten ne pallotkin
    Randomize
    ' tee 5 - 10 palloa
    ReDim Balls(Int(Rnd * 6) + 5)
    ' alusta pallot
    For A = 0 To UBound(Balls)
        Balls(A).Rad = Int(Rnd * 210) + 90
        Balls(A).Mass = Int(Rnd * 290) + 10
        Balls(A).X = (Int(Rnd * 10) + 1) * 10
        Balls(A).Y = (Int(Rnd * 10) + 1) * 10
    Next
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    mX = CInt(X)
    mY = CInt(Y)
End Sub
Private Sub Form_Unload(Cancel As Integer)
    ' merkkaa että olemme valmiita lopettamaan
    Quit = True

    ' vapauta tai tuhoa kaikki käytetyt elementit
    ReleaseDC 0, Screen_hDC     ' vapauta ruudun Device Context
    DeleteDC Compat_DC          ' tuhoa yhteensopiva Device Context
    Erase BMP_Buffer            ' tyhjennä byte array muistista
    Erase BF                    ' tyhjennä poikaystävä muistista
End Sub