Kirjautuminen

Haku

Tehtävät

Keskustelu: Koodit: VB6: Pomppivat planeetat

Sivun loppuun

setä [18.01.2004 18:10:07]

#

Pomppivat planeetat ja vähän lukion fysiikkaa. Päivitetty 1.4.2004. Ohjelmassa lasketaan 2...6 planeetan kiertoradat ja liike näytetään 2D-animaationa sprite-tekniikkaa käyttäen. Kappaleiden liike perustuu painovoimaan, joka on verrannollinen massojen tuloon ja kääntäen verrannollinen etäisyyden neliöön. Tässä animaatiossa havaitaan selvästi, kuinka toinen planeetta voi lingota toisen huomattavasti korkeammalle radalle tai painovoiman ulottumattomiin. Tällä periaatteellahan käytetään esim. Marsia linkoamaan luotain kauemmaksi.
Laskennassa summataan enimmillään 5 voimavektoria. Summauksessa ei käytetä trigonometrisiä funktioita vaan yhdenmuotoisten kolmioiden suhteita. Näin laskenta nopeutuu.
Lomakkeella on Spritejä varten PictureBoxit picP(5), picM(5), picV(5) ja picZ (puskuri). Ohjetekstiä varten on tekstikehys lblO. Tämä näkyy käynnistyksen jälkeen sekä pysäytystilassa painamalla F1.
Liike käynnistyy painamalla SPACE.
Vihreä pallo on selvästi muita isompi ja emoplaneetta jota muut kiertävät. Reunapomput aiheuttavat pallojen törmäilyä eikä liikkeet vastaa enää planeettojen liikkeitä. Pallot noudattavat hyvin tarkasti fysiikan lakeja myös pompuissa. Voit säätää kimmoisuutta, Asettaa reunapomput päälle/pois ja vaihtaa keskinäisten vetovoimien tilalle painovoiman, jolloin pallot pomppivat kuin kumipallot. Mukana on myös ääniefektit. Tarvittavat äänitiedostot MCI-ohjaimen ja koko ohjelman voit ladata osoitteesta: http://personal.inet.fi/atk/korant/download.htm

'Pomppivat planeetat Antero Korteila 1.4.2004 ver. 4
'Pallot liikkuvat kuten aurinkokunnan planeetat noudattaen tarkasti
'Newtonin lakeja myös pompuissa. (2-ulotteisena !)

Option Explicit

Dim N As Integer    'planeettojen lukumäärä -1 (oletus 2)
Dim Q As Byte       'tila
Dim b(5) As Integer 'spriten leveys
Dim r(5) As Single  'säteet
Dim r1(5) As Single  'planeettojen säteet
Dim r2(5) As Single  'pallojen säteet
Dim r0 As Single    'säde
Dim xx(5) As Double 'x-koord.
Dim ex(5) As Double 'ed. x-koord.
Dim yy(5) As Double 'y-koord.
Dim ey(5) As Double 'ed. y-koord.
Dim vx(5) As Double 'vaakanopeus
Dim vy(5) As Double 'pystynopeus
Dim m(5) As Double  'massat
Dim e(5, 5) As Double 'etäisyydet
Dim cP(5) As Long   'värit
Dim cv(5) As Long   'värit nopeuden säädössä
Dim xe(5) As Single, ye(5) As Single 'spriten edellinen x ja y
Dim be(5) As Single 'spriten edellinen leveys
Dim f(5, 5) As Double 'voima
Dim fe(5, 5) As Double 'edellinen voima
Dim dx(5, 5) As Double 'etäisyyden x-komp.
Dim dy(5, 5) As Double 'etäisyyden y-komp.
Dim I As Integer, J As Integer, k As Integer
Dim MI As Integer, ek As Single, ra As Single
Dim z As Long, x0 As Single, y0 As Single
Dim kk As Single, nk As Integer, ns As Integer

'BitBlt-funktion määrittely
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long


'ohjeteksti
Private Sub Form_Load()
  lblO = "NÄPPÄINKOMENNOT" + vbCrLf + _
  vbCrLf + "ENTER = askel tai hidastettu ajo" + _
  vbCrLf + "SPACE = käynnistys / pysäytys" + _
  vbCrLf + "End = lopetus" + _
  vbCrLf + "S = kiihdytä, s = hidasta sinistä" + _
  vbCrLf + "P = kiihdytä, p = hidasta punaista" + _
  vbCrLf + "C = ratojen putsaus" + vbCrLf + "R = reunapomput päälle / pois" + _
  vbCrLf + "Q = painovoima / vetovoimat" + _
  vbCrLf + "K/k = kimmoisuus +/- (0,1...0,99)" + _
  vbCrLf + "n = uusi aloitus, keskusplaneetan koko vaihtelee" + _
  vbCrLf + "Nuolinäpp. keskustan siirto valittuun suuntaan" + _
  vbCrLf + "Numeroilla 1...5 kiertävien planeettojen määrä" + _
  vbCrLf + "Pysäytystilassa voit muuttaa planeetan" + _
  vbCrLf + "sijaintia, kokoa tai nopeutta seuraavasti:" + _
  vbCrLf + "Valitse planeetta Numpadistä numerolla 0...5" + _
  vbCrLf + "Hiiren vasemmalla paikka ja koko," + _
  vbCrLf + "oikealla nopeus ja suunta," + _
  vbCrLf + "    (ympyrän säde osoittaa nopeutta," + _
  vbCrLf + "     jolla rata on ympyrä)"

  N = 5

  'värit
  cP(2) = &HE0        'ratojen värit
  cP(1) = &HE00000
  cP(0) = &HA000&
  cP(3) = &HA0A0&: cP(4) = &HFF00E0: cP(5) = &HB0B000
  cv(2) = &HFF        'nopeusvektorin väri
  cv(1) = &HFF0000
  cv(3) = &HFFFF&: cv(4) = &HFF00FF: cv(5) = &HFFFF00

  Randomize
  r(2) = 12: r(1) = 10: r(0) = 45 + 20 * Rnd 'säteet
  r(3) = 14: r(4) = 12: r(5) = 16
  r2(2) = 32: r2(1) = 20  'säteet
  r2(3) = 28: r2(4) = 42: r2(5) = 36
  ra = 45 / Atn(1) 'radiaanit asteiksi
  kk = 0.85        'kimmokerroin
End Sub

'lähtötilanne
Private Sub Form_Resize()
  Static tila As Boolean
  If tila Then tila = False: Exit Sub
  If WindowState = 1 Then tila = True: Exit Sub
  Dim b As Single
  Dim x As Single, y As Single
  x0 = Me.ScaleWidth * 0.5        'keskipiste
  y0 = Me.ScaleHeight * 0.5
  xx(1) = x0 * 0.8
  xx(2) = x0 * 1.4                'x-koordinaatit
  xx(3) = x0 * 0.4
  xx(4) = x0 * 1.75
  xx(5) = x0 * 0.1

  For I = 0 To 5
    yy(I) = y0                    'y-koordinaatit
    m(I) = r(I) ^ 3               'massa = r^3
    pallo I
  Next
  'pallojen painopiste keskelle
  emo

  picZ.Width = Me.ScaleWidth    'puskurin koko ja paikka
  picZ.Height = Me.ScaleHeight
  picZ.Top = picZ.Height
  'taustalle hiusviivat
  viivat

  For I = 0 To N                  'pallojen blittaus
    If I > 0 Then nopeus I
    'If I = 2 Or I = 4 Then vy(I) = -vy(I)
    x = xx(I) - r(I): y = yy(I) - r(I)
    b = 2 * r(I) + 1
    'otetaan kuva talteen
    z = BitBlt(picV(I).hDC, 0, 0, b, b, picZ.hDC, x, y, vbSrcCopy)
    xe(I) = x: ye(I) = y: be(I) = b
  Next
  DoEvents
  blit
  lblO.Visible = True
  Q = 8
End Sub
'näppäinohjaukset
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Dim b As Single
  Dim x As Single, y As Single
  Dim dx As Integer, dy As Integer
  Select Case KeyCode
  Case vbKeyEnd
    End                 'lopetus

  Case vbKeyF1
    lblO.Visible = True  'ohje näkyviin

  Case vbKeyReturn
    Q = Q + 1 - (Q And 1)    'startti
    If (Q And 8) = 0 Then
      For I = 0 To N
        vx(I) = 0.5 * (Rnd - 0.5)
        vy(I) = -0.5 * Rnd + 0.2
      Next
    End If
    liike
    tausta

  Case vbKeySpace
    Q = Q + 1 - 2 * (Q And 1): liike  'stop / run
    Timer1.Enabled = -(Q And 1)
    lblO.Visible = False

  Case vbKeyR
    Q = Q + 16 - 2 * (Q And 16)  'reunapomppu päälle / pois
    'eli B:n viides bitti 1 tai 0

  Case vbKeyQ         'keskinäiset vetovoimat / painovoima
    If (Q And 8) Then 'vetovoimat pois, painovoima tilalle
      Q = Q - 8
      Q = Q + 16 - (Q And 16)         'reunapomppu päälle
      For k = 1 To 5
        r1(k) = r(k)
        r(k) = r2(k)
        m(k) = r(k) ^ 3
        pallo k
        x = xx(k) - r(k): y = yy(k) - r(k)
        b = 2 * r(k) + 1
        'otetaan kuva talteen
        z = BitBlt(picV(k).hDC, 0, 0, b, b, picZ.hDC, x, y, vbSrcCopy)
        xe(k) = x: ye(k) = y: be(k) = b
      Next
      picZ.Picture = LoadPicture("") 'tyhjätään tausta
      tausta
    Else
      For k = 1 To 5
        r2(k) = r(k)
        r(k) = r1(k)
        m(k) = r(k) ^ 3
        pallo k
        x = xx(k) - r(k): y = yy(k) - r(k)
        b = 2 * r(k) + 1
        'otetaan kuva talteen
        z = BitBlt(picV(k).hDC, 0, 0, b, b, picZ.hDC, x, y, vbSrcCopy)
        xe(k) = x: ye(k) = y: be(k) = b
      Next
      Q = Q + 8
      tausta
    End If

  Case vbKeyP, vbKeyS
    I = 2: If KeyCode = vbKeyS Then I = 1
    If Shift = 1 Then
      vx(0) = vx(0) - m(I) * vx(I) * 0.02 / m(0) 'liikemäärän tasaus
      vy(0) = vy(0) - m(I) * vy(I) * 0.02 / m(0)
      vx(I) = vx(I) * 1.02  ' kiihdytys
      vy(I) = vy(I) * 1.02
    Else
      vx(0) = vx(0) + m(I) * vx(I) * 0.02 / m(0) 'liikemäärän tasaus
      vy(0) = vy(0) + m(I) * vy(I) * 0.02 / m(0)
      vx(I) = vx(I) * 0.98  ' hidastus
      vy(I) = vy(I) * 0.98
    End If

  Case vbKeyC
    tausta                  'kiertoratojen putsaus

  Case vbKeyK
    If Shift = 1 Then       'kimmokerroin
      kk = kk * 1.01: If kk > 0.99 Then kk = 0.99
    Else
      kk = kk * 0.99: If kk < 0.1 Then kk = 0.1
    End If
    ns = 1: nk = 200

  Case vbKeyN
    r(0) = 45 + 20 * Rnd
    m(0) = r(0) ^ 3
    Form_Resize

  Case vbKey1 To vbKey5
    For I = N To KeyCode - 48
      pallo I
      nopeus I
    Next
    N = KeyCode - 48

  Case vbKeyNumpad0 To vbKeyNumpad5
    I = KeyCode - 96
    If Q And 1 Then

    Else
      If (Q And 4) = 0 Then Q = Q + 4
    End If
  Case vbKeyLeft
    dx = 5 * (x0 > 0)       'keskustan siirto vasemmalle
    GoSub siirto
  Case vbKeyRight
    dx = -5 * (x0 < Me.ScaleWidth)  'siirto oikealle
    GoSub siirto
  Case vbKeyUp
    dy = 5 * (y0 > 0)               'siirto ylös
    GoSub siirto
  Case vbKeyDown
    dy = -5 * (y0 < Me.ScaleHeight) 'siirto alas
    GoSub siirto
  End Select
  Exit Sub
siirto:
  x0 = x0 + dx: y0 = y0 + dy
  For I = 0 To N
    xx(I) = xx(I) + dx
    yy(I) = yy(I) + dy
  Next
  viivat
  tausta
End Sub

'hiiriohjaukset
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  If (Q And 1) Or (Q And 4) = 0 Then Exit Sub 'jos liikkeellä, ei sallita
  If Button = 1 Then
    xx(I) = x: yy(I) = y  'vihreä hiirikohdistimeen
    lblN = Str(Int(Sqr((x - x0) ^ 2 + (y - y0) ^ 2) * 3 + 0.5) / 100) + " cm"
    lblN.Left = x: lblN.Top = y - lblN.Height
    lblN.Visible = True
    r0 = r(I)
    If (Q And 8) Then
      If I > 0 Then               'emopallon paikka niin,
        emo                       'että painopiste on keskellä
      End If
      viivat
    End If
    blit
  ElseIf Button = 2 And I > 0 Then
    asnop    'apuviiva ja ympyrä
  End If
End Sub

'planeetan säteen tai nopeuden säätö
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Static ex As Single, ey As Single
  Dim xu As Single, yu As Single
  If (Q And 1) = 1 Or (Q And 4) = 0 Then Exit Sub

  If Button = 1 Then          'säteen säätö
    'säde vähintään 3 (vihreällä 10)
    If r(I) + (x - xx(I)) / 4 < 3 - 8 * (I = 0) Then Exit Sub
    r(I) = r0 + (x - xx(I)) / 4
    m(I) = r(I) ^ 3
    If Q And 8 Then emo
    xu = xx(I) - r(I): yu = yy(I) - r(I)
    'palautetaan taustat
    z = BitBlt(picZ.hDC, xe(I), ye(I), be(I), be(I), picV(I).hDC, 0, 0, vbSrcCopy)
    pallo I
    'otetaan kuvat talteen
    z = BitBlt(picV(I).hDC, 0, 0, b(I), b(I), picZ.hDC, xu, yu, vbSrcCopy)
    xe(I) = xu: ye(I) = yu: be(I) = b(I)
    blit

  ElseIf Button = 2 Then      'nopeuden säätö
    If DrawMode = 7 Then
      Line (xx(I), yy(I))-(ex, ey), cv(I)
    Else
      DrawMode = 7
    End If
    Line (xx(I), yy(I))-(x, y), cv(I)
    ex = x: ey = y
  End If
End Sub

'nopeuden laskenta tai asetus
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If (Q And 1) Or (Q And 4) = 0 Then Exit Sub
  If Button = 1 Then
    m(I) = r(I) ^ 3
    If Q And 8 Then
      For I = 0 To N
        nopeus I     'lasketaan ympyrärataa vastaava nopeus
      Next
      viivat
      tausta
    End If
    blit
  ElseIf Button = 2 And I > 0 Then
    vx(I) = (x - xx(I)) / 5000
    vy(I) = (y - yy(I)) / 5000
    If Q And 8 Then nopeus 0
    DrawMode = 13
    picZ.Cls
    blit
  End If
  Q = Q - 4
End Sub
Sub liike()
  Dim ax(5) As Double, ay(5) As Double  'kiihtyvyydet
  Dim a0 As Double, a1 As Double        'apumuuttujat
  Dim v As Double, fn As String         'nopeus
  Dim xk As Single, yk As Single
  Dim ak As Single, sk As Single
  For k = 1 To 100
    voimat
    'etäisyydet
    For I = 0 To N - 1
      For J = I + 1 To N
        e(I, J) = Sqr(e(I, J))
        If e(I, J) < r(I) + r(J) Then 'kosketus
          pomppu
        End If
      Next
      ax(I) = 0: ay(I) = 0
    Next
    ax(I) = 0: ay(I) = 0

    If 8 And Q Then         'vetovoimat
      For I = 0 To N - 1
        For J = I + 1 To N
          a0 = f(I, J) / e(I, J): a1 = a0 * dx(I, J)
          ax(I) = ax(I) - a1: ax(J) = ax(J) + a1
          a1 = a0 * dy(I, J)
          ay(I) = ay(I) - a1: ay(J) = ay(J) + a1
        Next
      Next
    Else                    'painovoima
      For I = 0 To N
        ay(I) = 0.00001 * m(I)
      Next
    End If
    For I = 0 To N
      ax(I) = ax(I) / m(I)
      ay(I) = ay(I) / m(I)
      vx(I) = vx(I) + ax(I)
      vy(I) = vy(I) + ay(I)
      ex(I) = xx(I)
      xx(I) = ex(I) + vx(I) - ax(I) / 2
      ey(I) = yy(I)
      yy(I) = ey(I) + vy(I) - ay(I) / 2
      If Q And 16 Then                    'pomput reunoista
        If xx(I) < r(I) Then
          fn = "LAP11.WAV"
          If vx(I) > -0.05 / (2 + (Q And 8)) Then
            GoTo ohi
          ElseIf vx(I) > -0.2 / (2 + (Q And 8)) Then
            Mid(fn, 4, 1) = "5"
          ElseIf vx(I) > -0.5 / (2 + (Q And 8)) Then
            Mid(fn, 4, 1) = "3"
          End If
          MMC(I).filename = fn
          MMC(I).Command = "Open"
          MMC(I).Wait = False
          MMC(I).Command = "Sound"
ohi:      sk = Sqr(kk)
          xx(I) = 2 * r(I) - xx(I)
          vx(I) = -vx(I) * sk: vy(I) = vy(I) * sk

        ElseIf xx(I) > ScaleWidth - r(I) Then
          fn = "LAP14.WAV"
          If vx(I) < 0.02 / (2 + (Q And 8)) Then
            GoTo ohi0
          ElseIf vx(I) < 0.2 / (2 + (Q And 8)) Then
            Mid(fn, 4, 1) = "5"
          ElseIf vx(I) < 0.5 / (2 + (Q And 8)) Then
            Mid(fn, 4, 1) = "3"
          End If
          MMC(I).filename = fn
          MMC(I).Command = "Open"
          MMC(I).Wait = False
          MMC(I).Command = "Sound"
ohi0:     sk = Sqr(kk)
          xx(I) = 2 * (ScaleWidth - r(I)) - xx(I)
          vx(I) = -vx(I) * sk: vy(I) = vy(I) * sk
        End If

        If yy(I) < r(I) Then
          sk = Sqr(kk)
          yy(I) = 2 * r(I) - yy(I)
          vy(I) = -vy(I) * sk: vx(I) = vx(I) * sk
          Select Case Abs(vy(I))
          Case Is > 1 / (2 + (Q And 8))
            MMC(I).filename = "LAP1.WAV"
          Case Is > 0.5 / (2 + (Q And 8))
            MMC(I).filename = "LAP2.WAV"
          Case Is > 0.2 / (2 + (Q And 8))
            MMC(I).filename = "LAP3.WAV"
          Case Is > 0.1 / (2 + (Q And 8))
            MMC(I).filename = "LAP4.WAV"
          Case Is > 0.02 / (2 + (Q And 8))
            MMC(I).filename = "LAP5.WAV"
          Case Else
            GoTo ohi1
          End Select
          MMC(I).Command = "Open"
          MMC(I).Wait = False
          MMC(I).Command = "Sound"

ohi1:   ElseIf yy(I) > ScaleHeight - r(I) Then
          sk = Sqr(kk): If Abs(vy(I)) < 0.002 Then sk = 1 - kk / 5000
          yy(I) = 2 * (ScaleHeight - r(I)) - yy(I)
          vy(I) = -vy(I) * sk: vx(I) = vx(I) * sk
          Select Case Abs(vy(I))
          Case Is > 1 / (2 + (Q And 8))
            MMC(I).filename = "LAP1.WAV"
          Case Is > 0.5 / (2 + (Q And 8))
            MMC(I).filename = "LAP2.WAV"
          Case Is > 0.2 / (2 + (Q And 8))
            MMC(I).filename = "LAP3.WAV"
          Case Is > 0.1 / (2 + (Q And 8))
            MMC(I).filename = "LAP4.WAV"
          Case Is > 0.05 / (2 + (Q And 8))
            MMC(I).filename = "LAP5.WAV"
          Case Is < 0.01
            yy(I) = ScaleHeight - r(I)
            If Abs(vy(I)) < 0.002 Then vy(I) = 0
            GoTo ohi2
          End Select
          MMC(I).Command = "Open"
          MMC(I).Wait = False
          MMC(I).Command = "Sound"
ohi2:
        End If
      End If
    Next
  Next
  blit
  CurrentY = 0
  Select Case ns
  Case 1
    CurrentX = ScaleWidth - 100
    Print "k = "; Format(kk, "0.###")
    nk = nk - 1: If nk = 0 Then ns = 0
  End Select
  If (8 And Q) = 0 Then Exit Sub
  For I = 1 To N
    If e(0, I) > ScaleWidth * 0.5 Then
      CurrentX = ScaleWidth - 100
      xk = xx(I) - ScaleWidth / 2
      yk = yy(I) - ScaleHeight / 2
      ek = Sqr(xk * xk + yk * yk) / 34
      If xk = 0 Then ak = 90 Else ak = Atn(-yk / xk) * ra
      If xk < 0 Then ak = ak + 180
      Print I; "  "; Format(ek, "###.0"); "  "; Format(ak, "###°")
    End If
  Next
End Sub


Sub voimat()
  For I = 0 To N - 1
    For J = I + 1 To N
      dx(I, J) = xx(I) + vx(I) / 2 - xx(J) - vx(J) / 2 'vaaka- ja pystyetäisyydet
      dy(I, J) = yy(I) + vy(I) / 2 - yy(J) - vy(J) / 2
      e(I, J) = dx(I, J) * dx(I, J) + dy(I, J) * dy(I, J) 'etäisyyden neliöt
      f(I, J) = m(I) * m(J) / e(I, J) / 1000000 'vetovoimat
    Next
  Next
  'nopeuden puolisko parantaa laskentatarkkuutta
  'vakio määrätty kokeellisesti
End Sub
'emopallon paikka siten, että yhteinen painopiste on keskellä
Sub emo()
  xx(0) = (x0 - xx(1)) * m(1)
  yy(0) = (y0 - yy(1)) * m(1)
  For J = 2 To N
    xx(0) = xx(0) + (x0 - xx(J)) * m(J)
    yy(0) = yy(0) + (y0 - yy(J)) * m(J)
  Next
  xx(0) = xx(0) / m(0) + x0
  yy(0) = yy(0) / m(0) + y0
End Sub

'nopeuden asettelu
Sub asnop()
  'piirretään ympyrärataa vastaava nopeus viivana ja ympyränä
  Line (xx(I), yy(I))-Step(5000 * vx(I), 5000 * vy(I))
  Circle (xx(I), yy(I)), 5000 * Sqr(vx(I) * vx(I) + vy(I) * vy(I))
End Sub

'boxien koko ja pallon piirto
Sub pallo(I As Integer)
  Dim d As Single, rd As Single
  Dim xd As Single, cc As Long
  Dim g(2) As Long, c(2) As Byte
  cc = cP(I)
  For J = 0 To 2
    g(J) = 255 And cc
    cc = (cc - g(J)) \ 256
    g(J) = g(J) * 0.7
  Next
  b(I) = 2 * r(I) + 1
  picP(I).Width = b(I)
  picP(I).Height = b(I)
  picP(I).Cls
  picM(I).Width = b(I)
  picM(I).Height = b(I)
  picM(I).Cls
  picV(I).Width = b(I)
  picV(I).Height = b(I)
  picV(I).Cls
  For d = 0 To 250 Step 0.6 + 50 / r(I) 'piirretään täytetty pallo,
    rd = r(I) * (250 - d) / 251       'jonka täyttö vaalenee asteittain
    xd = 0.6 * r(I) + 0.4 * rd        'ja antaa 3D-vaikutelman
    For J = 0 To 2
      c(J) = g(J) + (255 - g(J)) * d / 255
    Next
    picP(I).Circle (xd, xd), rd, RGB(c(0), c(1), c(2))
    If d = 0 Then picM(I).Circle (xd, xd), rd 'piirretään maski
  Next
End Sub

'pallojen kosketuksessa täysin kimmoinen pomppu
Sub pomppu()
Dim k As Double, p As Double, s As Double 'apumuuttujia
Dim lm As Double, le As Double  'liikemäärä, liike-energia
Dim lm1 As Double, lm2 As Double
Dim d As Double, xd As Double, yd As Double 'etäisyys ja sen x- ja y-komp.
Dim v1 As Double, v2 As Double  'kohtausnopeus
Dim s1 As Double, s2 As Double  'sivuttaisnopeus (ei muutu)
  'etäisyys ja sen vaaka- ja pystykomponentit
  d = e(I, J): xd = xx(J) - xx(I): yd = yy(J) - yy(I)
  v1 = (vx(I) * xd + vy(I) * yd) / d  'kohtisuorat nopeudet
  v2 = (vx(J) * xd + vy(J) * yd) / d
  s1 = (vx(I) * yd - vy(I) * xd) / d  'sivuttaisnopeudet (eivät muutu)
  s2 = (vx(J) * yd - vy(J) * xd) / d
  Select Case Abs(v1 - v2)
  Case Is > 1 / (2 + (Q And 8))
    MMC(I).filename = "POP1.WAV"
  Case Is > 0.7 / (2 + (Q And 8))
    MMC(I).filename = "POP2.WAV"
  Case Is > 0.5 / (2 + (Q And 8))
    MMC(I).filename = "POP3.WAV"
  Case Is > 0.2 / (2 + (Q And 8))
    MMC(I).filename = "POP4.WAV"
  Case Is > 0.1 / (2 + (Q And 8))
    MMC(I).filename = "POP5.WAV"
  Case Else
    GoTo ohi
  End Select
  MMC(I).Command = "Open"
  MMC(I).Wait = False
  MMC(I).Command = "Sound"
ohi:  lm1 = v1 * m(I): lm2 = v2 * m(J)
  lm = lm1 + lm2                      'liikemäärä
  le = (v1 * lm1 + v2 * lm2) * kk     'liike-energia
  k = m(I) + m(J)
  p = lm / k: s = (lm * lm - le * m(J)) / m(I) / k
  On Error Resume Next
  lm2 = Sqr(Abs(p * p - s))             'toisen asteen yhtälön ratkaisu
  v1 = p - lm2: v2 = (lm - v1 * m(I)) / m(J)
  v1 = v1 / (1 + v1 * v1): v2 = v2 / (1 + v2 * v2) 'vaimennus
  vx(I) = (v1 * xd + s1 * yd) / d     'törmäyksen jälkeiset nopeudet
  vx(J) = (v2 * xd + s2 * yd) / d
  vy(I) = (v1 * yd - s1 * xd) / d
  vy(J) = (v2 * yd - s2 * xd) / d
End Sub

'spritet
Sub blit()
  Dim d As Single, rd As Single
  Dim xd As Single, yd As Single, c(5) As Byte
  Dim z As Long, b(5) As Single
  Dim x(5) As Single, y(5) As Single
  Dim I As Integer

  For I = 0 To N
    x(I) = xx(I) - r(I): y(I) = yy(I) - r(I)
    b(I) = 2 * r(I) + 1
    'palautetaan taustat
    z = BitBlt(picZ.hDC, xe(I), ye(I), be(I), be(I), picV(I).hDC, 0, 0, vbSrcCopy)
  Next

  'plotataan keskipisteet
  For I = 0 To N
    picZ.PSet (xx(I), yy(I)), cP(I)
  Next

  For I = 0 To N
    'otetaan kuvat talteen
    z = BitBlt(picV(I).hDC, 0, 0, b(I), b(I), picZ.hDC, x(I), y(I), vbSrcCopy)
  Next

  For I = 0 To N
    'piirretään spritet
    z = BitBlt(picZ.hDC, x(I), y(I), b(I), b(I), picM(I).hDC, 0, 0, vbSrcAnd)
    z = BitBlt(picZ.hDC, x(I), y(I), b(I), b(I), picP(I).hDC, 0, 0, vbSrcInvert)
    xe(I) = x(I): ye(I) = y(I)
  Next
  'kuva puskurista formille
  z = BitBlt(Me.hDC, 0, 0, picZ.Width, picZ.Height, picZ.hDC, 0, 0, vbSrcCopy)
End Sub

'taustan putsaus
Sub tausta()
  picZ.Cls
  For I = 0 To N
    picV(I).Cls
    'otetaan kuvat talteen
    z = BitBlt(picV(I).hDC, 0, 0, be(I), be(I), picZ.hDC, xe(I), ye(I), vbSrcCopy)
  Next
End Sub


'ympyrärataa vastaava nopeus
Sub nopeus(I As Integer)
  Dim v As Single, e As Single 'lähtönopeus ja -etäisyys
  Dim dx As Single, dy As Single 'etäisyyden x- ja y-komp.
  If I > 0 Then
    dx = xx(I) - xx(0)
    dy = yy(I) - yy(0)
    e = Sqr(dx ^ 2 + dy ^ 2)
    v = Sqr(m(0) / e / (1 + m(I) / m(0))) / 1000
    vx(I) = -dy * v / e: vy(I) = dx * v / e
  End If
  'vihreän pallon nopeus, jolla kokonaisliikemäärä = 0
  'jolloin systeemin painopiste pysyy paikallaan
  vx(0) = 0: vy(0) = 0
  For J = 1 To N
    vx(0) = vx(0) - vx(J) * m(J)
    vy(0) = vy(0) - vy(J) * m(J)
  Next
  vx(0) = vx(0) / m(0): vy(0) = vy(0) / m(0)
End Sub

'piirretään ristikko pysyväksi
Sub viivat()
  picZ.Picture = LoadPicture("")
  picZ.Line (x0, 0)-(x0, picZ.Height), &H808080
  picZ.Line (0, y0)-(picZ.Width, y0), &H808080
  For J = 1 To N
    picZ.Circle (x0, y0), Sqr((x0 - xx(J)) ^ 2 + (y0 - yy(J)) ^ 2), &H808080
  Next
  picZ.Picture = picZ.Image
End Sub

Private Sub Form_Unload(Cancel As Integer)
  End
End Sub

Private Sub Timer1_Timer()
  liike
End Sub

T.M. [18.01.2004 19:29:21]

#

Selkeää koodia, mutta EXEä kaipaillaan :)

KimmoKM [18.01.2004 20:06:08]

#

Kuulostaa hienolta. Hienoa koodia. Mutta onko EXEä?

ZcMander [18.01.2004 20:40:55]

#

Hieno! Ei voi muuta sanoa. Nuo "pallot" muuten sekoaa vähän ajan päästä.

setä [18.01.2004 21:11:36]

#

Onko Ohjelmointiputkassa paikkaa noille exeille ??

setä [19.01.2004 14:38:27]

#

Muutin hiukan lähtöarvoja ja asetuksia. nyt pitäisi toimia VB5:llä ja VB6:lla ainakin.

killerfox [19.01.2004 15:17:09]

#

Hyvin toimii. Aika hyvää jälkeä tulee, kun sitä isointa planeettaa lähtee liikkuttamaan.

setä [20.01.2004 10:57:09]

#

No ny voi exet imuttaa osoitteesta:
http://personal.inet.fi/atk/korant/download.htm

setä [20.01.2004 11:19:12]

#

Tuo exe on huomattavasti nopeampi ja muutinkin vihreän pallukan pienemmäksi, joka hidastaa vauhtia.

T.M. [21.01.2004 00:17:20]

#

Lisää palloja! :D
Ainut joka oli outoo, oli se että pallot nopeutuu mitä isomman pallon ympärillä ne pyörii.
Miten tohon sais lisää palloja? 20 palloo olis kiva :)

setä [21.01.2004 08:32:41]

#

Kolmella pallolla on laskettava jokaiselle voimavaikutus kahteen muuhun, neljällä vastaavasti kolmeen muuhun jne. Pallojen määrän kasvaessa tarvittava laskentateho kasvaa jyrkästi.
Kiertonopeus noudattaa Newtonin lakeja, ja nehän ovat edelleen voimassa erittäin suurella tarkkuudella. Jos vihreän pallon läpimitta kaksinkertaistuu, sen massa kasvaa 8-kertaiseksi ja kiertonopeuden neliö 8-kertaiseksi eli nopeus lähes kolmin kertaiseksi.

T.M. [22.01.2004 02:52:57]

#

Mutta eihän planeetatkaan liiku auringon ympärillä nopeammin mitä lähempänä ne ovat? :P
Ainakaan niin nopeasti kuin tuossa ohjelmassa :D

Aika hassu tuo ohjelma oli silti, ihan kuin leikkisi magneeteilla :)

setä [23.01.2004 16:45:50]

#

Kyllä ne vaan liikkuvat. Katso jostain tietokirjasta, mikä on esim. Marsin vuosi tai Venuksen vuosi. Pallojen välillä vaikuttaa vetovoima (painovoima). Tässä animaatiossa kierrosajat ovat vaan sekunnin suuruusluokkaa vuoden sijasta. Tokko kukaan viitsisi vahdata vuositolkulla pallon liikettä. Muuttamalla pallojen etäisyyksiä ja kokoa saa lukemattomia eri versioita liikeradoista. Animaatio osoittaa selvästi sen, miksi planeettojen radat "elävät" eli muuttuvat jatkuvasti toistensa vetovoiman vaikutuksesta.

T.M. [25.01.2004 23:35:48]

#

Marsin ja Venuksen vuosien pituus erothan johtuvat siitä, että niillä on lyhyempi kiertorata? :P

Hmm... toi uus versio ei toiminut :( Tulee joku runtime error '9'

T.M. [26.01.2004 00:06:48]

#

No jopas, nyt toimii! Tosi hieno on :-o
Eräs pikkuseikka vain, että toi hidastaa windowsin toimintoja, eli wintoosa reagoi näppäimistön paineluihin ym muutaman sekunnin viivelllä :P
Olis kiva saada tohon monta monta monta palloa lisää :)
ja sitten noi piirtobugit pois ym.
Tosi hieno :O

setä [26.01.2004 09:37:26]

#

Painovoimahan on kääntäen verrannollinen etäisyyteen eli ~1/r². Nopeus, jolla planeetta pysyy ympyräradalla eli keskipakovoima kumoaa painovoiman (keskeiskiihtyvyys = painovoiman kiihtyvyys) saadaan kaavasta voima ~v²/r. Tästä seuraa, että nopeus v ~ 1/sqr(r) siis kääntäen verrannollinen etäisyyden neliöjuureen. Jos kiertoradan säde nelinkertaistuu, nopeus putoaa puoleen ja kiertoaika 1/8-osaan. Näin tosiaan tuossa animaatiosa käy. Ratojen laskenta perustuu pelkästään pallojen välisiin voimavaikutuksiin, jotka ovat verrannollisia massojen tuloon ja kääntäen verrannollisia etäisyyden neliöön. Voimat antavat palloille tietyn kiihtyvyyden, sen perusteella lasketaan nopeus ja edelleen nopeuden perusteella paikka. Tuossa laskennassa tarvitaan vähän geometriaakin.
Piirtobugit johtuvat tuosta sprite-tekniikasta. Kun pläjäytetään useampi sprite peräkkäin, ei läpinäkyvyys olekkaan joka tilanteessa läpinäkyvä. Tämä on ensimmäinen kerta, kun spritejä käytän ja paljon tuli yllättävää vastaan. Antti teki tuon spriteoppaan ja ehkä tietäisi syyn piirtobugeihin.
Pallojahan voi kyllä lisätä rajatta mutta wintoosa hidastuu silloin tosi pahasti. Mulla mylly jauhaa näillä kolmellakin 100% teholla kun planeetat pyörii. Ajastimella voisi aikaa järjestyä muihin hommiin mutta silloin piirto taas hidastuu. Tää oli nyt vähän pitkä juttu, mutta ihan kiva että aihe kiinnostaa. Itse olen juuri kiinnostunut mallintamaan erilaisia fysiikan ja mekaniikan ilmiöitä VB:llä. Muita kieliä kun en osaa.

setä [26.01.2004 10:25:40]

#

Siis ekarivillä piti olla kääntäen verrannollinen etäisyyden neliöön kuten kaavassakin on

setä [26.01.2004 12:36:07]

#

No voi hemmetti kun mä bugailen eikä noita kommentteja voi muokata. Tottakai tossa piti olla, että kierrosaika kasvaa 8-kertaiseksi

setä [26.01.2004 14:27:24]

#

Tässä näköjään nyt vaan itselleni vastailen. Spriten piirto toimii nyt virheettömästi. Asiat piti vaan tehdä oikeassa järjestyksessä. Päivitän koodivinkkeihin myös korjatun version. Samalla meni koko hoito hitaammaksi. Myös tuo virheellinen exe. Eli koneen nopeus vaihtelee älyttömästi. Outoa.

T.M. [26.01.2004 23:39:41]

#

Tossa sun tiedoston latausosoitteessa on jotain pahasti vialla, piti painaa sitä latausta n. 5 kertaa kunnes se tuli koneelle :|

T.M. [26.01.2004 23:44:00]

#

HMM... nyt on jossain pahasti vialla, nimittäin tuo on nyt todella hidas :(

setä [27.01.2004 09:33:58]

#

Joo, jotain outoa on. Nihkeästi pyörii alussa ja prossukäyttöä lähes 60%. Kun poistan Nortonin Securityn käytöstäja Quick Timen kuvakkeen niin Plan.exeä voi pyörittää jouhevasti neljäkin kappaletta ja prossun käyttöaste on noin 10%. Siis yksi ohjelma vie vain noin pari % prossun tehoa.

Fisher [24.03.2004 16:15:26]

#

ei toimi... miten nuo pictureboxit? (2)-kohtaa ei voi laittaa nimeksi.

Fisher [25.03.2004 15:32:58]

#

Näyttää kuvan Windowsin tilarivistä

setä [03.04.2004 13:47:25]

#

... miten nuo pictureboxit? (2)-kohtaa ei voi laittaa nimeksi.
Suluissa on suurin indeksi. Nyt indeksointi on 0...5 eli 6 kpl kutakin. Ohjaimen nimi ilman indeksiä!

ErroR++ [06.04.2011 16:03:29]

#

Ei toiminu. Tuli Error list:in mukaan 102 virhettä. En tiedä...

Sivun alkuun

Vastaus

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

Tietoa sivustosta