Keskustelu: Koodit: VB6: Avaruussimulaatio

Private Sub Form_Load()
On Error Resume Next
Dim i As Integer

'Luodaan sini- ja kosinitaulukot
rad = Atn(1) * 4 / 180
Dim SinM(359) As Single
Dim CosM(359) As Single
For i = 0 To 359
  SinM(i) = Sin(i * rad)
  CosM(i) = Cos(i * rad)
Next i

Dim Dot(1 To 30000) As Vertex   'Tähtien absoluuttiset 3D-koordinaatit
Dim Rot(1 To 30000) As Vertex   'Tähtien pyöritetyt 3D-koordinaatit
Dim Scr(1 To 30000) As Matrix   'Lopulliset 2D-koordinaatit näytöllä

Dim StarInt As Long  'Tähtien kirkkaus (saa muuttaa)
StarInt = 1000000

'Kysytään tähtien määrät
Dim PlAr As String, PlA As Long
PlAr = InputBox("Montako tähteä/planeettaa?" + Chr(13) + "(1-30000)" + Chr(13) + Chr(13) + "(2000MHz koneelle hyvä lienee 5000, eli hidas on)", "Avaruushärpäke")
'PlAr = "5000"
PlA = Int(Val(PlAr))
If PlA < 1 Then PlA = 1
If PlA > 30000 Then PlA = 30000

'Alkuasetuksia...
StartUp = True
DoEvents
Randomize Timer

'Sijoitetaan tähdet avaruuteen
For i = 1 To PlA
  Dot(i).X = -5000 + Int(Rnd * 10001)
  Dot(i).Y = -5000 + Int(Rnd * 10001)
  Dot(i).Z = Int(Rnd * 10001)
Next i

'Lisää alkuasetuksia...
Form1.AutoRedraw = True
Form1.ScaleMode = 3
Cam.X = 0: Cam.Y = 0: Cam.Z = 0
AdjustScreen
Scan = 1
DoEvents


Do
Frame = Frame + 1     'FPS-laskuria varten
aa = 0                'Nollataan näppäinpainallus
DoEvents
Line (0, 0)-(ScrW, ScrH), 0, BF   'Tausta mustaksi
su = (Speed / 100 + 1)            'Hyperajoviivojen pituus

'Projektoidaan tähdet 2D-tasoon
Dim rx As Single, ry As Single, rz As Single
Dim sx As Single, sy As Single
For i = 1 To PlA
  'Suhteelliset koordinaatit
  rx = Dot(i).X - Cam.X
  ry = Dot(i).Y - Cam.Y
  rz = Dot(i).Z - Cam.Z

  'Pyörittäminen kameran kulmien mukaan
  Rot(i).X = CosM(Cam.XA) * rx + SinM(Cam.XA) * rz
  Rot(i).Z = CosM(Cam.XA) * CosM(Cam.YA) * rz - SinM(Cam.XA) * CosM(Cam.YA) * rx + SinM(Cam.YA) * ry
  Rot(i).Y = CosM(Cam.YA) * ry - SinM(Cam.YA) * CosM(Cam.XA) * rz - SinM(Cam.YA) * -SinM(Cam.XA) * rx

  'Perspektiivikorjaus
    rz = Rot(i).Z
  If rz > 0 Then
     sx = Rot(i).X * CScale / rz + CenterX
     sy = Rot(i).Y * CScale / rz + CenterY
   If Scan = i Then
    Circle (sx, sy), 3, 255  'Näytetään kohdeplaneetta
    Circle (sx, sy), 4, 255  'jos se on tämä
    Circle (sx, sy), 5, 255
   End If
    If Hyper = 0 Then   'Jos normaalitila, piirretään tähdet
      Circle (sx, sy), Form1.Width / 5 / rz, RGB(StarInt / rz, StarInt / rz, StarInt / rz)
    Else                'Jos hyperajo, piirretään viivat
      Line (sx, sy)-((sx - CenterX) * su + CenterX, (sy - CenterY) * su + CenterY), QBColor(15)
    End If
  End If
Next i

 'Näppäinohjailua...
 If aa = 56 Then Speed = Speed + 1
 If aa = 53 Then Speed = Speed - 1
 If aa = 54 Then Turn = Turn - 1
 If aa = 52 Then Turn = Turn + 1
 If aa = 57 Then Turn2 = Turn2 - 1
 If aa = 51 Then Turn2 = Turn2 + 1

 If aa = 43 Then Scan = Scan + 1
 If aa = 45 Then Scan = Scan - 1

 If aa <> 0 Then Cam.TA = 0

 If aa = 13 Then      'Hyperajo
  If Hyper <> -2 Then
    Hyper = Hyper - 1
    If Hyper = -1 Then Speed = 0
  End If
 End If

 If Hyper = -1 Then      'Hyperajon ohjausta
  Speed = Speed * 1.1 + 1
 End If
 If Hyper = -2 Then
  Speed = Speed / 1.2
  If Speed < 0.5 Then Speed = 0: Hyper = 0
 End If

 If aa = 32 Then     'Kohdistus käyntiin...
 Turn = 0
 Turn2 = 0
 Cam.TA = -1
  Cam.XAT = Kulma(Cam.X - Dot(Scan).X, Cam.Z - Dot(Scan).Z)
  At = 90 - Kulma(Sqr((Cam.X - Dot(Scan).X) ^ 2 + (Cam.Z - Dot(Scan).Z) ^ 2), Cam.Y - Dot(Scan).Y)
  If At = -270 Then At = 90
  If At < -180 Then At = At + 540
  If Cam.X - Dot(Scan).X <> 0 And Cam.Z - Dot(Scan).Z > 0 Then At = 540 - At
  If At > 360 Then At = At - 360
  Cam.YAT = At
 End If

 If Cam.TA Then         'Ja sitten kohdistetaan...
  If Abs(Cam.XA - Cam.XAT) > 0 Then
    If Cam.XA <= Cam.XAT Then
      vd = Cam.XAT - Cam.XA
      od = Cam.XA + 360 - Cam.XAT
    Else
      vd = Cam.XAT + 360 - Cam.XA
      od = Cam.XA - Cam.XAT
    End If
     If vd >= od Then Cam.XA = Cam.XA - 1 Else Cam.XA = Cam.XA + 1
  End If
  If Abs(Cam.YA - Cam.YAT) > 0 Then
    If Cam.YA <= Cam.YAT Then
      vd = Cam.YAT - Cam.YA
      od = Cam.YA + 360 - Cam.YAT
    Else
      vd = Cam.YAT + 360 - Cam.YA
      od = Cam.YA - Cam.YAT
    End If
     If vd >= od Then Cam.YA = Cam.YA - 1 Else Cam.YA = Cam.YA + 1
  End If
 End If

  'Liikutetaan kameraa
  Cam.Z = Cam.Z + CosM(Cam.XA) * CosM(Cam.YA) * Speed
  Cam.X = Cam.X - SinM(Cam.XA) * CosM(Cam.YA) * Speed
  Cam.Y = Cam.Y + SinM(Cam.YA) * Speed

  'Pyöritetään kameraa
  Cam.XA = Cam.XA + Turn
  Cam.YA = Cam.YA + Turn2

  'Pysytään rajojen sisällä
  If Cam.XA < 0 Then Cam.XA = Cam.XA + 360
  If Cam.XA >= 360 Then Cam.XA = Cam.XA - 360
  If Cam.YA < 0 Then Cam.YA = Cam.YA + 360
  If Cam.YA >= 360 Then Cam.YA = Cam.YA - 360

'EVVK :)
If StartUp = True Then
  Form1.Show
StartUp = False
End If

Loop Until aa = 27   'Escistä pois
End   'Yritä arvata

End Sub

Sub Timer1_Timer()   'Laskeen FPS
  Form1.Caption = "FPS: " + Str(Frame) + "/s"
  Frame = 0
End Sub

Sub AdjustScreen()    'Säädetään leveyden, keskipisteet, skaala yms.
  ScrW = Form1.Width / 15
  ScrH = Form1.Height / 15
  CenterX = ScrW / 2
  CenterY = ScrH / 2
  CScale = Form1.Width / 15
End Sub

Function Kulma(a As Single, b As Single)
Dim k As Single, l As Integer
Dim Y As Single, Y2 As Single
'Kulmanlaskemisfunktio
'En millään onnistunut saamaan siitä tämän epäselvempää :)

If a <> 0 And b <> 0 Then
  k = Atn(b / a) / rad
    l = 180
  If Y < Y2 Then l = 0
  If Y = Y2 Then l = 0
    k = k + l
  If k > 0 Then
    k = k + 90
    If k > 180 And k < 270 Then k = k - 180
  Else
    k = k + 270
  End If
Else
  If a = 0 And b < 0 Then k = 180
  If b = 0 And a > 0 Then k = 270
  If a = 0 And b > 0 Then k = 0
  If b = 0 And a < 0 Then k = 90
End If

If k > 180 Then k = k - 360
Kulma = k + 180

End Function

Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  MouseRotate = True    'Hiiripyöritys käyntiin...
  LMX = X: LMY = Y
End Sub

Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If MouseRotate Then            'Jos käynnissä niin pyöritetään...
  Cam.XA = Cam.XA + (LMX - X)
  Cam.YA = Cam.YA - (LMY - Y)
  LMX = X: LMY = Y
  Cam.TA = 0
End If
End Sub

Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  MouseRotate = False      'Hiiripyöritys seis
End Sub

Private Sub Form_Resize()  'Automaaginen koonmuutosikkunakuvasuhdesäätöhärpätys
  If Form1.WindowState = 0 Then Form1.Height = Form1.Width / 4 * 3
  AdjustScreen
End Sub

Private Sub Form_Unload(Cancel As Integer)
  End    'Nyt se on leikin loppu!
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
  aa = KeyAscii   'Luetaan näppäin ja pistetään muistiin
End Sub

'3D-moottorin tietotyypit

Type Vertex       '3D-avaruusverteksi
  X As Single
  Y As Single
  Z As Single
End Type

Type Camera       'Kamera
  X As Single
  Y As Single
  Z As Single
  XA As Integer
  YA As Integer
  XAT As Integer
  YAT As Integer
  TA As Integer
End Type

Type Matrix       '2D-matriisi
  X As Long
  Y As Long
End Type