Keskustelu: Koodit: QB: Veden Kiertokulku

Screen 13
'$DYNAMIC   ' Tarvitaan että taulukoita voi alustaa uudelleen
            ' REDIM funktiolla
DefInt A-Z  ' Tämä nopeuttaa toimintaa...

Type kohta
  x As Integer
  y As Integer
  s As Integer
End Type

'pisaroita alussa
Max = 1000

'montako pisaraa lisäytyy
lisays = 100
'montako kierrosta ennen lisäystä
kierroksia = 100
'jos haluat vesisateen, laita sade=1, jos et laita sade=0
sade = 0

' -> Jos haluat vesisateen, laita vaikka lisays=30 ja kierroksia=50 ja sade=1

'pisarataulukko
Dim vesi(1 To Max) As kohta
Dim temp(1 To Max) As kohta

'pisaroiden alkukohdat
Randomize Timer
vkohta = 0
For i = 1 To Max
  vesi(i).x = 8 + Int(Rnd * 3) + 1
  vkohta = vkohta - 0.1 'mitä pienempi, sen vuolaampi
  vesi(i).y = vkohta
Next
counteri = 0


'maaston piirtäminen
pii = 4 * Atn(1)
Line (5, 50)-(100, 70)
Line (101, 80)-(81, 100)
Line (101, 80)-(141, 120)
Line (70, 100)-(70, 120)
Line (90, 100)-(90, 120)
Line (70, 120)-(90, 120)
Circle (135, 140), 10
Circle (135, 140), 14, 15, pii, 2 * pii - pii / 1.5
Line (135, 140)-(135, 130), 0
Line (135, 140)-(120, 140), 0
Line (136, 130)-(170, 100)
PSet (70, 114), 0
Line (50, 130)-(100, 150)
Circle (110, 100), 118, , pii, 2 * pii

Do
  For i = 1 To Max
    'vanha pisara pois
    PSet (vesi(i).x, vesi(i).y), 0
    vx = vesi(i).x: vy = vesi(i).y
    If Point(vesi(i).x, vesi(i).y + 1) <= 0 Then
      vesi(i).y = vesi(i).y + 1 'jos alhaalla on tyhjää
    Else
      'vasemman ja oikean puolen tilan laskeminen
      av% = 0: ao% = 0
      For j = vesi(i).y To 320
        If Point(vesi(i).x - 1, j) <= 0 Then
          av% = av% + 1
        Else
          Exit For
        End If
      Next
      For j = vesi(i).y To 320
        If Point(vesi(i).x + 1, j) <= 0 Then
          ao% = ao% + 1
        Else
          Exit For
        End If
      Next
      If av% = 0 And ao% = 0 Then
        'pisara ei pääse liikkumaan
      ElseIf av% >= 1 And ao% = 0 Then
        vesi(i).x = vesi(i).x - 1 'oikealle ei pääse: siis vasemmalle
      ElseIf ao% >= 1 And av% = 0 Then
        vesi(i).x = vesi(i).x + 1 'vasemmalle ei pääse: siis oikealle
      Else 'molemmat suunnat mahdollisia
        If vesi(i).s = 0 Then 'vesi on tulossa ylhäältä, suunta arvotaan
          vesi(i).x = vesi(i).x + (-1 + Int(Rnd * 3))
        ElseIf vesi(i).s = 1 Then 'vesi on tulossa oikealta: siis vasemmalle
          vesi(i).x = vesi(i).x - 1
        ElseIf vesi(i).s = 2 Then 'vesi on tulossa vasemmalta: siis oikealle
          vesi(i).x = vesi(i).x + 1
        End If
      End If
    End If
    'uuden suunnan laskeminen
    If vy <> vesi(i).x Then vesi(i).s = 0
    If vx < vesi(i).x Then vesi(i).s = 2
    If vx > vesi(i).x Then vesi(i).s = 1
    'uuden pisaran piirtäminen
    PSet (vesi(i).x, vesi(i).y), 1
  Next
  If counteri = kierroksia Then
        counteri = 0
        ReDim temp(1 To Max) As kohta
        For i = 1 To Max
                temp(i).x = vesi(i).x
                temp(i).y = vesi(i).y
        Next i
        oldmax = Max
        Max = Max + lisays
        vkohta = 0
        ReDim vesi(1 To Max) As kohta
        For i = 1 To oldmax
                vesi(i).x = temp(i).x
                vesi(i).y = temp(i).y
        Next i
        For i = (oldmax - 1) To Max
                If sade = 1 Then
                        vesi(i).x = Int(Rnd * 200)
                Else
                        vesi(i).x = 8 + Int(Rnd * 3) + 1
                End If
                vkohta = vkohta - 0.1 'mitä pienempi, sen vuolaampi
                vesi(i).y = vkohta
        Next
  Else
        counteri = counteri + 1
  End If
Loop While INKEY$ <> Chr$(27)