Keskustelu: Koodit: VB6: Keskeneräinen 3d-moottori

Antti Laaksonen [15.05.2002 18:50:19]

Tässäpä on keskeneräinen 3d-moottori Visual Basicilla, jota oli alunperin tarkoitus aluksi käyttää Oppia ikä kaikki -pelin alkudemoon. Ohjelma on VB-sovitus eräästä Internetistä löytämästäni QBasic-pohjaisesta 3d-kuutio-ohjelmasta, ja se näkyy koodin sekavuutena. Muutenkin ohjelma on varsin keskeneräinen ja jo koodin ymmärtäminen käy työstä. Vaan todistaahan se, että pelkällä WinApillakin voi kyhäillä jonkunlaisen 3d-moottorin.

Ohjelman pitäisi toimia suoraan ilman mitään kontrolleja, kunhan luodaan Formi ja Moduuli, ja niihin sijoitetaan allaolevat koodit.

Formille

Private Sub Form_Activate()
    Form_Click
End Sub

Private Sub Form_Click()
    Static paikat(3) As POINTAPI

    PI = 4 * Atn(1)

    For i = 0 To 359
      s!(i) = Sin(i * (PI / 180))
      c!(i) = Cos(i * (PI / 180))
    Next

    LisaaSK -31.35, -23.15, 0, 31.35, 23.15, 0, RGB(128, 128, 128)
    LisaaSK 14.95, -23.15, 0, 31.35, 6.85, 0, RGB(0, 128, 0)
    LisaaSS -31.35, -23.15, 0, -16.95, 21.85, -20, RGB(192, 192, 192)
    LisaaSS -16.95, -23.15, 0, -1.95, -8.15, -20, RGB(192, 192, 192)
    LisaaSS -1.95, -23.15, 0, 13.05, 6.85, -20, RGB(192, 192, 192)
    LisaaSK -31.35 + 19.6, -23.15 + 14.9, 0, -31.35 + 19.6 + 5.6, -23.15 + 14.9, -5, RGB(33, 97, 161)
    LisaaSS -31.35 + 15.5, -23.15 + 40.2, 0, -31.35 + 15.5 + 1.08, -23.15 + 40.2 + 3.8, -1, RGB(161, 161, 161)
    LisaaSS -31.35 + 15.4, -23.15 + 15.5, 0, -31.35 + 15.4 + 0.7, -23.15 + 15.5 + 0.9, -2, RGB(64, 128, 0)
    LisaaSS -31.35 + 28.9, -23.15 + 15.5, 0, -31.35 + 28.9 + 0.7, -23.15 + 15.5 + 0.9, -2, RGB(64, 128, 0)

    LisaaSS -31.35 + 15.3, -23.15 + 19.3, 0, -31.35 + 15.3 + 0.75, -23.15 + 19.3 + 3, -1, RGB(128, 64, 0)
    LisaaSS -31.35 + 15.3, -23.15 + 19.3 + 3.4, 0, -31.35 + 15.3 + 0.75, -23.15 + 19.3 + 3 + 3.4, -1, RGB(128, 64, 0)
    LisaaSS -31.35 + 15.3, -23.15 + 19.3 + 6.8, 0, -31.35 + 15.3 + 0.75, -23.15 + 19.3 + 3 + 6.8, -1, RGB(128, 64, 0)
    LisaaSS -31.35 + 15.3 + 13.6, -23.15 + 19.3, 0, -31.35 + 15.3 + 0.75 + 13.6, -23.15 + 19.3 + 3, -1, RGB(128, 64, 0)
    LisaaSS -31.35 + 15.3 + 13.6, -23.15 + 19.3 + 3.4, 0, -31.35 + 15.3 + 0.75 + 13.6, -23.15 + 19.3 + 3 + 3.4, -1, RGB(128, 64, 0)
    LisaaSS -31.35 + 15.3 + 13.6, -23.15 + 19.3 + 6.8, 0, -31.35 + 15.3 + 0.75 + 13.6, -23.15 + 19.3 + 3 + 6.8, -1, RGB(128, 64, 0)

    LisaaSK -31.35 + 30.6, -23.15 + 30.05, -2, -31.35 + 30.6 + 0.8, -23.15 + 30.05 + 0.8, -2, RGB(194, 194, 0)
    LisaaSK -31.35 + 30.6 + 8.8, -23.15 + 30.05, -2, -31.35 + 30.6 + 0.8 + 8.8, -23.15 + 30.05 + 0.8, -2, RGB(194, 194, 0)

    lisaasku -31.5 + 14.75, -23.15 + 35.55, -2, -31.5 + 14.75, -23.15 + 35.55 + 2.7, -4, RGB(33, 97, 161)

    xcenter = 180: ycenter = 180: zcenter = 80
    theta = 90: phi = 125
    thetarot = 2: phirot = 0
    xmuutos = 0: ymuutos = 0: zmuutos = 0
    Do
        If pois Then GoTo loppu
        GoSub Piirrakuva
    Loop

Piirrakuva:
        theta = (theta + thetarot) Mod 360
        phi = (phi + phirot) Mod 360
        xcenter = xcenter + xmuutos
        ycenter = ycenter + ymuutos
        zcenter = zcenter + zmuutos
      For i = 0 To numlines
       oldX(i, 0) = scrx(i, 0): oldY(i, 0) = scrY(i, 0)
        oldX(i, 1) = scrx(i, 1): oldY(i, 1) = scrY(i, 1)

        lr(i, 0).x = -lO(i, 0).x * s!(theta) + lO(i, 0).y * c!(theta)
        lr(i, 0).y = -lO(i, 0).x * c!(theta) * s!(phi) - lO(i, 0).y * s!(theta) * s!(phi) - lO(i, 0).z * c!(phi) + lO(i, 0).p
        lr(i, 0).z = -lO(i, 0).x * c!(theta) * c!(phi) - lO(i, 0).y * s!(theta) * c!(phi) + lO(i, 0).z * s!(phi)
        lr(i, 1).x = -lO(i, 1).x * s!(theta) + lO(i, 1).y * c!(theta)
        lr(i, 1).y = -lO(i, 1).x * c!(theta) * s!(phi) - lO(i, 1).y * s!(theta) * s!(phi) - lO(i, 1).z * c!(phi) + lO(i, 1).p
        lr(i, 1).z = -lO(i, 1).x * c!(theta) * c!(phi) - lO(i, 1).y * s!(theta) * c!(phi) + lO(i, 1).z * s!(phi)

        If (lr(i, 0).z + zcenter) <> 0 Then
          scrx(i, 0) = 256 * (lr(i, 0).x / (lr(i, 0).z + zcenter)) + xcenter
          scrY(i, 0) = 256 * (lr(i, 0).y / (lr(i, 0).z + zcenter)) + ycenter
        End If

        If (lr(i, 1).z + zcenter) <> 0 Then
          scrx(i, 1) = 256 * (lr(i, 1).x / (lr(i, 1).z + zcenter)) + xcenter
          scrY(i, 1) = 256 * (lr(i, 1).y / (lr(i, 1).z + zcenter)) + ycenter
        End If

      Next
      a = Timer
        DoEvents

      Cls

        ReDim upaikat(numlines / 4) As Integer
        upi% = 0
        For i = 1 To numlines Step 4
            upi% = upi% + 1
            upaikat(upi%) = i
        Next

        For i = 1 To numlines / 4
            For j = 1 To numlines / 4 - 1
                If IsoinZ(upaikat(j)) <= IsoinZ(upaikat(j + 1)) Then
                    upaikat(0) = upaikat(j + 1)
                    upaikat(j + 1) = upaikat(j)
                    upaikat(j) = upaikat(0)
                End If
            Next
        Next


      For j = 1 To numlines / 4
            i = upaikat(j)
            paikat(0).x = scrx(i, 0)
            paikat(0).y = scrY(i, 0)
            paikat(1).x = scrx(i + 1, 0)
            paikat(1).y = scrY(i + 1, 0)
            paikat(2).x = scrx(i + 2, 0)
            paikat(2).y = scrY(i + 2, 0)
            paikat(3).x = scrx(i + 3, 0)
            paikat(3).y = scrY(i + 3, 0)

            hBrush = CreateSolidBrush(lO(i, 0).c)
            hObj = SelectObject(Me.hdc, hBrush)

            d = Polygon(hdc, paikat(0), 4)

            d = DeleteObject(hObj)
      Next
Return
loppu:
Unload Me
End Sub

Moduuliin

Public Type POINTAPI
        x As Long
        y As Long
End Type

Public Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Type pnt
  x As Single
  y As Single
  z As Single
  p As Integer
  c As Long
End Type

Public numlines As Integer
Public lO(1000, 1) As pnt
Public lr(1000, 1) As pnt

Public scrx(1000, 1)
Public scrY(1000, 1)
Public oldX(1000, 1)
Public oldY(1000, 1)
Public s!(359)
Public c!(359)

Function IsoinZ(u As Integer)
    iso = lr(u, 0).z
    If lr(u + 1, 0).z > iso Then iso = lr(u + 1, 0).z
    If lr(u + 2, 0).z > iso Then iso = lr(u + 2, 0).z
    If lr(u + 3, 0).z > iso Then iso = lr(u + 3, 0).z
    IsoinZ = iso
End Function

Sub LisaaPyramidi(ax, ay, az, lx, ly, lz, yx, yy, yz, c)
  LisaaSK ax, ay, az, lx, ly, lz, c

  lisaaviiva ax, ay, az, yx, yy, yz, c
  lisaaviiva ax, ly, lz, yx, yy, yz, c
  lisaaviiva lx, ly, lz, yx, yy, yz, c
  lisaaviiva lx, ax, az, yx, yy, yz, c
End Sub

Sub LisaaSK(ax, ay, az, lx, ly, lz, c)
    lisaaviiva ax, ay, az, lx, ay, az, c
    lisaaviiva lx, ay, az, lx, ly, lz, c
    lisaaviiva lx, ly, lz, ax, ly, lz, c
    lisaaviiva ax, ly, lz, ax, ay, az, c
End Sub

Sub lisaasku(ax, ay, az, lx, ly, lz, c)
  lisaaviiva ax, ay, az, ax, ly, az, c
  lisaaviiva ax, ly, az, ax, ly, lz, c
  lisaaviiva ax, ly, lz, ax, ay, lz, c
  lisaaviiva ax, ay, lz, ax, ay, az, c
End Sub

Sub LisaaSS(ax, ay, az, lx, ly, lz, c)

  LisaaSK ax, ay, az, lx, ay, lz, c
  LisaaSK ax, ly, lz, lx, ly, az, c
  LisaaSK ax, ay, lz, lx, ly, lz, c
  LisaaSK ax, ay, az, lx, ly, az, c
  lisaasku ax, ay, az, ax, ly, lz, c
  lisaasku lx, ay, lz, lx, ly, az, c

End Sub

Sub lisaaviiva(ax, ay, az, lx, ly, lz, c)
  numlines = numlines + 1
  lO(numlines, 0).x = ax
  lO(numlines, 0).y = ay
  lO(numlines, 0).z = az
  lO(numlines, 0).p = 1
  lO(numlines, 0).c = c
  lO(numlines, 1).x = lx
  lO(numlines, 1).y = ly
  lO(numlines, 1).z = lz
  lO(numlines, 1).p = 1
End Sub

(nimetön) [21.05.2002 20:45:00]

Sää oot hyvä! Ite en tajua 3Dtä ollenkaan...

Hanc [09.06.2002 11:49:17]

Sääli vain että WinApi on hias!

Rykker [22.06.2002 11:08:23]

jos toi välkkyy teillä helvetisti niinku mulla, niin kannattaa vaihtaa formin AutoRedraw = True ja DoEvents kohdan jälkeen: me.redraw

Hyvä koodinpätkä =) täytyypäs kokeilla tohon texturemappausta =D

Gwaur [11.07.2002 17:40:26]

Mulla tää valittaa että joka rivissä olis virhe, siis ihan jokasessa. Onkohan versionumerolla vaikutusta tähän kun mulla on 3.0 PRO?

Jaakko [01.10.2002 21:22:10]

laadukasta työtä. ei voi muuta sanoo jos tommosta laatuu vetää vb:llä

Lord Juha [16.10.2002 15:41:15]

Hmm taidan virittää tohon hiirellä ohjattavan kameran...

(nimetön) [04.11.2002 16:14:15]

ihan hirveää paskaa

Heikki [19.10.2003 10:50:17]

Mulla riitti että laitoin formin autoredrawin trueksi ja lakkasi välkkymästä.

Jos laitoin tuon me.redraw:in niin tuli erroria.

killerfox [20.01.2004 20:43:08]

Ei sitä me.redraw:ia enää tarvi, kun on pistetty autoredraw. Nopeutta ja kulmaa pystyy ainakin osittain säätämään muuttamalla "PI = 4 * Atn(1)" kertointa. Nelonen muutetaan halutuksi luvuksi.

DaZip [25.01.2004 16:18:29]

Ei härregyyd! Kyllä mainiolta näyttää!

mamaze [06.03.2004 11:06:48]

hyvä alku moottorille mutta kannattaisi tehdä loppuun asti se

Fisher [16.04.2004 22:20:58]

alku? tuohan on tosihyvä kuva!

Puhveli [18.06.2004 18:01:07]

kaunista jälkeä tosiaan. kateellinen olen
edit: ja jos redraw ei toimi niin laittakaa refresh, se on versionumerosta kiinni kumpi niistä kelpaa

Gwaur [19.09.2004 01:05:15]

Nyt kun mulla on VB6 niin hyvin toimii =)

moptim [26.07.2006 07:49:58]

tosi upea

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Kilpailu