Koodit: QB: Animoidut kirjaimet

'Animoidut kirjaimet
'------------------------------
'
'Tämä ohjelma luo halutusta tekstistä animaation,
'jossa pisteet muodostavat animaation kirjaimet
'ja liikkuvat aina uusille paikoille.
'
'Fontti on hieman muunneltu Windowsin Courier.
'
'Copyright Antti Laaksonen 2002
'www.ohjelmointiputka.net

DECLARE SUB PiirraPisteet (pisteet() AS ANY)
DECLARE FUNCTION DecBin$ (L AS INTEGER)

TYPE TYPEXY
  x AS SINGLE
  y AS SINGLE
END TYPE

'animoitava teksti
teksti$ = "OHJELMOINTIPUTKA"
'tekstin väri
tvari% = 15
'yhden kirjainanimaation vaiheet
'mitä suurempi, sen hitaampi animaatio
vaiheet% = 10

'taulukot
DIM kirjaimet(25, 60) AS TYPEXY
DIM pituudet(25) AS INTEGER
DIM mkirjaimet(LEN(teksti$), 60) AS TYPEXY
DIM pisteet(60) AS TYPEXY

'näyttötila 13, 60x60-ikkuna
SCREEN 13
WINDOW SCREEN (0, 0)-(60, 60)

PRINT "Ladataan..."

'ladataan kirjaimet taulukkoon
FOR s = 0 TO 25
  x = 0
  kirji = 0
  FOR i = 1 TO 8
    bin$ = ""
    FOR j = 1 TO 2
      READ t$
      t$ = "&H" + t$
      bin$ = bin$ + RIGHT$("0000000" + DecBin(VAL(t$)), 8)
    NEXT
    x = x + 1
    FOR j = 1 TO 14
      vari% = VAL(MID$(bin$, j, 1))
      IF vari% = 1 THEN
        kirji = kirji + 1
        kirjaimet(s, kirji).x = x
        kirjaimet(s, kirji).y = j
      END IF
    NEXT
  NEXT
  READ pituudet(s)
  pituudet(s) = pituudet(s) - 16
NEXT

'kaikki pisteet keskelle
FOR i = 1 TO 60
  pisteet(i).x = 4
  pisteet(i).y = 8
NEXT

'teksti isoksi
teksti$ = UCASE$(teksti$)

'lasketaan pisteiden liikeradat animaatiossa
FOR h = 1 TO LEN(teksti$)
  me% = ASC(MID$(teksti$, h, 1)) - 65
  FOR i = 1 TO 60
    pvx! = pisteet(i).x
    pvy! = pisteet(i).y
    IF i <= pituudet(me%) THEN
      pisteet(i).x = kirjaimet(me%, i).x
      pisteet(i).y = kirjaimet(me%, i).y
    ELSE
      k% = INT(RND * pituudet(me%)) + 1
      pisteet(i).x = kirjaimet(me%, k%).x
      pisteet(i).y = kirjaimet(me%, k%).y
    END IF
    mkirjaimet(h, i).x = (pisteet(i).x - pvx!) / vaiheet%
    mkirjaimet(h, i).y = (pisteet(i).y - pvy!) / vaiheet%
  NEXT
NEXT

'tyhjennetään näyttö ja määritetään pisteiden väri
CLS
COLOR tvari%

'kaikki pisteet keskelle: animaatio alkaa
FOR i = 1 TO 60
  pisteet(i).x = 4
  pisteet(i).y = 8
NEXT
PiirraPisteet pisteet()


'käydään jokainen merkki läpi
FOR h = 1 TO LEN(teksti$)
  'käydään jokainen vaihe läpi
  FOR j = 1 TO vaiheet%
    'käydään jokainen piste läpi
    FOR i = 1 TO 60
      pisteet(i).x = pisteet(i).x + mkirjaimet(h, i).x
      pisteet(i).y = pisteet(i).y + mkirjaimet(h, i).y
      PiirraPisteet pisteet()
    NEXT
    'pieni viive
    WAIT &H3DA, 8
  NEXT
  '1/2-sekunnin tauko kirjainten välille
  a! = TIMER
  DO WHILE a! + .5 > TIMER: LOOP
NEXT

'dataa, joka sisältää kirjainten A-Z pisteet
DATA 00, 73, 23, F3, 2F, 93, 3C, 83, 3C, 83, 0F, 93, 03, F3, 00, 73,  58
DATA 20, 13, 3F, F3, 3F, F3, 22, 13, 22, 13, 22, 13, 3F, F3, 1D, E3,  64
DATA 0F, C3, 1F, E3, 30, 33, 20, 13, 20, 13, 30, 13, 3C, 33, 3C, 23,  52
DATA 20, 13, 3F, F3, 3F, F3, 20, 13, 20, 13, 30, 33, 1F, E3, 0F, C3,  60
DATA 20, 13, 3F, F3, 3F, F3, 22, 13, 27, 13, 27, 13, 30, 33, 30, 33,  59
DATA 20, 13, 3F, F3, 3F, F3, 22, 13, 27, 13, 27, 03, 30, 03, 30, 03,  54
DATA 0F, C3, 1F, E3, 30, 33, 20, 13, 21, 13, 31, 13, 3D, F3, 3D, E3,  60
DATA 3F, F3, 3F, F3, 22, 13, 02, 03, 02, 03, 22, 13, 3F, F3, 3F, F3,  64
DATA 00, 03, 20, 13, 20, 13, 3F, F3, 3F, F3, 20, 13, 20, 13, 00, 03,  44
DATA 00, 63, 00, 73, 00, 13, 20, 13, 20, 13, 3F, F3, 3F, E3, 20, 03,  46
DATA 20, 13, 3F, F3, 3F, F3, 23, 13, 2F, 83, 3C, C3, 30, 73, 20, 33,  62
DATA 20, 13, 3F, F3, 3F, F3, 20, 13, 20, 13, 00, 13, 00, 33, 00, 33,  47
DATA 3F, F3, 3F, F3, 0F, 13, 03, C3, 03, C3, 0F, 13, 3F, F3, 3F, F3,  74
DATA 3F, F3, 3F, F3, 0E, 13, 07, 13, 21, C3, 20, E3, 3F, F3, 3F, F3,  72
DATA 0F, C3, 1F, E3, 30, 33, 20, 13, 20, 13, 30, 33, 1F, E3, 0F, C3,  56
DATA 20, 13, 3F, F3, 3F, F3, 21, 13, 21, 13, 21, 03, 3F, 03, 1E, 03,  56
DATA 0F, C3, 1F, E7, 30, 37, 20, 1F, 20, 1B, 30, 3F, 1F, E7, 0F, C7,  65
DATA 20, 13, 3F, F3, 3F, F3, 21, 13, 21, 83, 21, C3, 3F, 73, 1E, 33,  63
DATA 1C, 73, 3E, 73, 22, 33, 22, 13, 23, 13, 31, 13, 39, F3, 38, E3,  59
DATA 30, 03, 20, 13, 20, 13, 3F, F3, 3F, F3, 20, 13, 20, 13, 30, 03,  48
DATA 3F, E3, 3F, E3, 20, 33, 00, 13, 00, 13, 20, 33, 3F, E3, 3F, E3,  60
DATA 38, 03, 3F, 03, 27, C3, 00, F3, 00, F3, 27, C3, 3F, 03, 38, 03,  54
DATA 3F, 83, 23, F3, 03, F3, 0F, 83, 0F, 83, 03, F3, 23, F3, 3F, 83,  66
DATA 30, 33, 38, 73, 2C, D3, 07, 83, 07, 83, 2C, D3, 38, 73, 30, 33,  56
DATA 30, 03, 3C, 13, 2E, 13, 03, F3, 03, F3, 2E, 13, 3C, 13, 30, 03,  52
DATA 30, 33, 30, 73, 20, D3, 23, 93, 27, 13, 2C, 13, 38, 33, 30, 33,  52

'Funktio, joka muuttaa desimaaliluvun binääriluvuksi.
'Otettu vanhasta arkistosta: sekava ja kommentoimaton.
FUNCTION DecBin$ (L AS INTEGER)
  uusi$ = ""
  u = L
  DO
    ul = u \ 2
    jj = u MOD 2
    u = ul
    uusi$ = MID$(STR$(jj), 2) + uusi$
    IF u = 0 THEN EXIT DO
  LOOP
  DecBin$ = uusi$
END FUNCTION

'Aliohjelma, joka piirtää kaikki 60
'pistettä oikeille paikoilleen
SUB PiirraPisteet (pisteet() AS TYPEXY)
  'tyhjennetään piirtokohta
  LINE (0, 0)-(8, 16), 0, BF
  'käydään jokainen piste läpi
  FOR i = 1 TO 60
    PSET (pisteet(i).x, pisteet(i).y)
  NEXT
END SUB