Keskustelu: Koodit: QB: Gravitaation simulointia

DEFINT A-Z
'DROP - by Sqwiik
'  Pudottaa pikseleitä.
'  Kaunis efekti (hidastuu tosin, jos paljon tavaraa...)
'  Pudottaa kerätyt pisteet kohti gravitaation keskustaa --
'  pisteet jäävät kiertämään sitä.
'  Kyseessä EI ole realistinen gravitaatio...
'  Yllättävää kyllä tässäkin tapahtuu ellipsiratojen muodostumista
'  täysin spontaanisti. Outoa.
'  Toimivuus testattu 386:sella. Muille täytyykin jo vähän hidastaa...

'maksimi määrä pisteille
CONST max.pixeli = 3000
'Seuraavat ovat efekteihin
CONST YMGRAV = .2, XMGRAV = .2
'YM=vertikaalinen gravitaatio, XM poikittainen.
'Missä on gravitaation keskus?
CONST GRAVX = 160, GRAVY = 100

'varataan muisti
DIM pisteenvari(0 TO max.pixeli) AS INTEGER  'pisteiden väri
DIM pisteenxy(0 TO max.pixeli, 1 TO 2) AS SINGLE   'pisteiden sijainti
DIM pisteengrav(0 TO max.pixeli, 1 TO 2) AS SINGLE   'pisteiden gravitaatio (ym+xm)

SCREEN 13

'piirretään pisteitä jotka tippuvat 'aukkoon'
FOR a = 0 TO 1000
  PSET (INT(RND * 320), INT(RND * 200)), INT(RND * 16) + 1
NEXT

'Annetaan aikaa katsella kaikkia pisteitä...
DO: LOOP UNTIL INKEY$ <> ""

'Haetaan data pisteisiin
c = 0
FOR x = 0 TO 319
FOR y = 0 TO 199
  IF POINT(x, y) <> 0 THEN
    pisteenvari(c) = POINT(x, y)
    pisteenxy(c, 1) = x
    pisteenxy(c, 2) = y
    pisteengrav(c, 1) = -2 + RND * 4  'satunnainen alkuvauhti
    pisteengrav(c, 2) = -1 + RND * 2
    c = c + 1
    IF c = max.pixeli THEN EXIT FOR
  END IF
NEXT y
  IF c = max.pixeli THEN EXIT FOR
NEXT x
  'Nyt: c=liikutettavien pisteiden määrä.
  'joten eiköhän aleta, TULTA!
  DO
    CIRCLE (GRAVX, GRAVY), 2, 2 'gravitaation keskipiste (selvyyden vuoksi)
    FOR a = 0 TO c
      'Piste piiloon...
      PSET (pisteenxy(a, 1), pisteenxy(a, 2)), 0
      'Liikutetaan
      pisteenxy(a, 1) = pisteenxy(a, 1) + pisteengrav(a, 1)
      pisteenxy(a, 2) = pisteenxy(a, 2) + pisteengrav(a, 2)
      'ja sitten... lasketaan uusi gravitaatio!
      'Tämä ON karkeaa...
      IF pisteenxy(a, 1) < GRAVX THEN 'liikaa vasemmalla
        pisteengrav(a, 1) = pisteengrav(a, 1) + XMGRAV
        IF pisteenxy(a, 2) < GRAVY THEN
          pisteengrav(a, 2) = pisteengrav(a, 2) + YMGRAV
        ELSE
          pisteengrav(a, 2) = pisteengrav(a, 2) - YMGRAV
        END IF
      ELSE
        pisteengrav(a, 1) = pisteengrav(a, 1) - XMGRAV
        IF pisteenxy(a, 2) < GRAVY THEN
          pisteengrav(a, 2) = pisteengrav(a, 2) + YMGRAV
        ELSE
          pisteengrav(a, 2) = pisteengrav(a, 2) - YMGRAV
        END IF
      END IF
      'Ja uudelleen näkyviin
      PSET (pisteenxy(a, 1), pisteenxy(a, 2)), pisteenvari(a)
    NEXT a
  LOOP UNTIL INKEY$ <> ""