Kirjautuminen

Haku

Tehtävät

Keskustelu: Projektit: QBKuva - piirto-ohjelma

Sivun loppuun

Sami [21.04.2003 11:20:16]

#

Yksinkertainen piirto-ohjelma QBasiciin.
Hiiriajurit otin toisesta täällä esiintyneestä koodivinkistä, mutta muuten olen tehnyt tämän täysin itse.
Ohjelman voi imuroida exenä osoitteesta www.geocities.com/samimaki/imuroi/qbkuva.zip

' Yksinkertainen piirto-ohjelma QBasiciin
' Koodi on toisinaan melko huonosti luettavaa, mutta pääosin se johtuu siitä,
' että muuten hiiri (ja etenkin sen alle piirtäminen) bugittaisi liikaa.
' Nyt se ei bugita muuten, kuin vilkkumalla piirrettäessä.
' Ohjelman on tehnyt Sami, käyttäen apuna valmiita hiiriajureita

DECLARE SUB GetEdkuva ()
DECLARE SUB PiirraHiiri ()
DECLARE SUB tallenna ()
DECLARE FUNCTION AlustaHiiri! (napit%)
DECLARE FUNCTION LueHiiri! ()
DECLARE SUB NaytaHiiri ()
DECLARE SUB RajaaHiiri (xp%, xs%, yp%, ys%)
ON ERROR RESUME NEXT
CLS

TYPE RegType
   ax AS INTEGER
   bx AS INTEGER
   cx AS INTEGER
   dx AS INTEGER
   BP AS INTEGER
   SI AS INTEGER
   DI AS INTEGER
   FLAGS AS INTEGER
END TYPE

DIM SHARED o AS RegType
DIM SHARED i AS RegType
DIM SHARED nappi AS INTEGER
DIM SHARED onkohiirta AS INTEGER
DIM SHARED x AS INTEGER
DIM SHARED y AS INTEGER
DIM SHARED vari AS INTEGER
DIM SHARED edx AS INTEGER
DIM SHARED edy AS INTEGER
DIM SHARED edkuva(10, 16) AS INTEGER

SCREEN 12
GetEdkuva
edx = 320
edy = 240

a = AlustaHiiri(napit%)
IF onkohiirta <> -1 THEN GOSUB virhe
RajaaHiiri 0, 639, 0, 479 'rajataan hiiren alue näytön kokoiseksi

FOR a = 0 TO 15
  LINE (a * 40, 0)-((a + 1) * 40, 39), a, BF
NEXT a
vari = 15
LINE (0, 0)-(639, 5), vari, BF


DO
  NaytaHiiri 'näytetään hiiri
  a = LueHiiri 'tutkitaan hiiren sijainti ja nappien tilat
  IF y <= 40 AND nappi = 1 THEN   ' Jos nappia painetaan ja hiiri on värivalintojen päällä
    PUT (edx, edy), edkuva, PSET  ' Hiiren nuoli peittoon
    vari = POINT(x, y)   ' Piirtovärin vaihto
    LINE (0, 0)-(639, 5), vari, BF
    GetEdkuva
    PiirraHiiri

    edx = x
    edy = y
  END IF

  IF y > 40 AND nappi = 1 THEN   ' Jos hiiri on piirtoalueella
    PUT (edx, edy), edkuva, PSET ' Hiiri peittoon
    LINE (INT(x / 10) * 10, INT(y / 10) * 10)-(INT(x / 10) * 10 + 9, INT(y / 10) * 10 + 9), vari, BF  ' Piirretään piste (10*10 kokoinen)
    GetEdkuva
    PiirraHiiri  ' Hiiren kuva takaisin näkyviin

    edx = x
    edy = y
  END IF

  IF nappi = 2 THEN  ' Jos painetaan nappia 2, otetaan piirtoväriksi nuolen alla oleva väri
    PUT (edx, edy), edkuva, PSET  ' Hiiren nuoli peittoon
    vari = POINT(x, y)   ' Piirtovärin vaihto
    LINE (0, 0)-(639, 5), vari, BF
    GetEdkuva
    PiirraHiiri

    edx = x
    edy = y
  END IF


  SELECT CASE INKEY$
    CASE "T", "t", "S", "s"  ' Kaikki nämä tallentavat kuvan "kuva.bas":iin
    tallenna

    CASE CHR$(27)  ' Lopettaa ILMAN VARMISTUSTA
    END
  END SELECT
LOOP


virhe:  ' Jos hiirtä ei löydy
PRINT "Hiirtä ei löytynyt!"
END
RESUME


hiiri:  ' Hiiren kuva, 99 on läpinäkyvää
DATA 00,00,99,99,99,99,99,99,99,99
DATA 00,15,00,99,99,99,99,99,99,99
DATA 00,15,15,00,99,99,99,99,99,99
DATA 00,15,15,15,00,99,99,99,99,99
DATA 00,15,15,15,15,00,99,99,99,99
DATA 00,15,15,15,15,15,00,99,99,99
DATA 00,15,15,15,15,15,15,00,99,99
DATA 00,15,15,15,15,15,15,15,00,99
DATA 00,15,15,15,15,15,15,15,15,00
DATA 00,15,15,15,15,15,00,00,00,00
DATA 00,15,15,00,15,15,00,99,99,99
DATA 00,15,00,99,00,15,15,00,99,99
DATA 00,00,99,99,00,15,15,00,99,99
DATA 99,99,99,99,99,00,15,15,00,99
DATA 99,99,99,99,99,00,15,15,00,99
DATA 99,99,99,99,99,99,00,00,00,99

FUNCTION AlustaHiiri (napit%)
  i.ax = 0

  CALL INTERRUPT(&H33, i, o)

  onkohiirta = o.ax
  napit% = o.bx
END FUNCTION

SUB GetEdkuva
IF x <= 629 AND y <= 463 THEN
  GET (x, y)-(x + 9, y + 15), edkuva
ELSEIF x > 629 AND y <= 463 THEN
  GET (x, y)-(639, y + 15), edkuva
ELSEIF x <= 629 AND y > 463 THEN
  GET (x, y)-(x + 9, 479), edkuva
ELSEIF x > 629 AND y > 463 THEN
  GET (x, y)-(639, 479), edkuva
END IF
END SUB

FUNCTION LueHiiri
  i.ax = 3
  CALL INTERRUPT(&H33, i, o)
  nappi = o.bx
  x = o.cx
  y = o.dx
END FUNCTION

SUB NaytaHiiri
  IF edx <> x OR edy <> y THEN    ' Estää vilkkumista
    PUT (edx, edy), edkuva, PSET

    GetEdkuva
    PiirraHiiri  ' Hiiren kuva takaisin näkyviin

    edx = x
    edy = y
  END IF
END SUB

SUB PiirraHiiri
RESTORE hiiri
FOR b = 0 TO 15
  FOR a = 0 TO 9
    READ piste
    IF piste <> 99 THEN PSET (x + a, y + b), piste
  NEXT
NEXT
END SUB

SUB RajaaHiiri (xp%, xs%, yp%, ys%)
  i.ax = 7
  i.cx = xp%
  i.dx = xs%
  CALL INTERRUPT(&H33, i, o)
  i.ax = 8
  i.cx = yp%
  i.dx = ys%
  CALL INTERRUPT(&H33, i, o)
END SUB

SUB tallenna
PUT (edx, edy), edkuva, PSET  ' Peitetään nuoli, ettei se vaikuttaisi tallennuksessa

OPEN "kuva.bas" FOR OUTPUT AS #1
PRINT #1, "SCREEN 12"               ' Kirjoitetaan tiedostoon valmiiksi koodi, jolla kuvaa voi katsoa
PRINT #1, "FOR y = 0 TO 43"
PRINT #1, "  FOR x = 0 TO 63"
PRINT #1, "    READ piste"
PRINT #1, "    PSET (x,y), piste"
PRINT #1, "  NEXT x"
PRINT #1, "NEXT y"
PRINT #1, ""

FOR b = 40 TO 479 STEP 10  ' Ohjelmassa on 10*10 ruutuja, joten pitää käyttää STEP 10
  PRINT #1, "DATA ";
  FOR a = 0 TO 639 STEP 10
    IF POINT(a, b) < 10 THEN PRINT #1, "0";  ' Jos tallennettavan pisteen väri on alle 10, siihen eteen lisätään 0, jotta joka rivistä tulisi yhtä pitkiä
    PRINT #1, LTRIM$(STR$(POINT(a, b)));     ' Itse pisteen värin kirjoittaminen
    IF a < 630 THEN  ' Viimeiseksi merkiksi ei laiteta pilkkua
      PRINT #1, ",";
    ELSE
      PRINT #1, ""
    END IF
  NEXT a
NEXT b
CLOSE #1

GET (x, y)-(x + 9, y + 15), edkuva
RESTORE hiiri     ' Sitten palautetaan hiiren kuva takaisin
FOR b = 0 TO 15
  FOR a = 0 TO 9
    READ piste
    IF piste <> 99 THEN PSET (x + a, y + b), piste
  NEXT
NEXT

edx = x
edy = y

END SUB

snakari [21.04.2003 16:47:48]

#

kannattaako tänne nyt kokonaista ohjelmaa pastettaa?

Grey [21.04.2003 17:30:33]

#

Tuo hiiriosuus vaikuttaa tuossa kiintoisalta. Varsinkin se että esim. osoittimen saa itse määritettyä. Joskin, en saanut sitä itse kunnolla toimimaan. Tuli tuhat ja yksi virheilmoitusta, kun koetin saada laitettua sen omaan projektiini sellaisena kuin olisin sen halunnut :-P

-Grey-

Sami [21.04.2003 18:51:10]

#

Grey --> Kai muistit käynnistää sen /L parametrilla?
Ja siinä on aika monta osaa, mitkä vaikuttavat hiiren toimintaan.

snakari --> Miksi ei? Tämähän on vielä suhteellisen pieni ohjelma, en minä(kään) alkaisi tänne mitään kymmentä kilotavua suurempaa täysin valmista ohjelmaa lähettelemään. (jos tekisin sen, se tapahtuisi luultavasti omilla sivuillani)

Grey [21.04.2003 19:42:07]

#

Kyllä minä /L - parametrin tunnen. En minä niin höhlä sentään ole ^__^

-Grey-

Sami [21.04.2003 20:10:18]

#

Grey --> Mistä sitä koskaan tietää... ;)
Otin siitä pois itse piirto ohjelman, mutta jätin hiiriajurit. Esimerkiksi tein hiiren keskustasta läpinäkyvän.

DECLARE SUB GetEdkuva ()
DECLARE SUB PiirraHiiri ()
DECLARE FUNCTION AlustaHiiri! (napit%)
DECLARE FUNCTION LueHiiri! ()
DECLARE SUB NaytaHiiri ()
DECLARE SUB RajaaHiiri (xp%, xs%, yp%, ys%)
ON ERROR RESUME NEXT
CLS

TYPE RegType
   ax AS INTEGER
   bx AS INTEGER
   cx AS INTEGER
   dx AS INTEGER
   BP AS INTEGER
   SI AS INTEGER
   DI AS INTEGER
   FLAGS AS INTEGER
END TYPE

DIM SHARED o AS RegType
DIM SHARED i AS RegType
DIM SHARED nappi AS INTEGER
DIM SHARED onkohiirta AS INTEGER
DIM SHARED x AS INTEGER
DIM SHARED y AS INTEGER
DIM SHARED vari AS INTEGER
DIM SHARED edx AS INTEGER
DIM SHARED edy AS INTEGER
DIM SHARED edkuva(10, 16) AS INTEGER

SCREEN 12
RANDOMIZE TIMER

FOR a = 1 TO 20  ' Piirretään jotain epämääräisiä laatikoita taustalle
  LINE (RND * 640, RND * 480)-(RND * 640, RND * 480), RND * 16, BF
NEXT a

edx = 320
edy = 240

a = AlustaHiiri(napit%)
IF onkohiirta <> -1 THEN GOSUB virhe
RajaaHiiri 0, 639, 0, 479 'rajataan hiiren alue näytön kokoiseksi

DO
  NaytaHiiri 'näytetään hiiri
  a = LueHiiri 'tutkitaan hiiren sijainti ja nappien tilat
  LOCATE 1, 1
LOOP WHILE INKEY$ = ""
END

virhe:  ' Jos hiirtä ei löydy
PRINT "Hiirtä ei löytynyt!"
END
RESUME


hiiri:  ' Hiiren kuva, 99 on läpinäkyvää
DATA 00,00,99,99,99,99,99,99,99,99
DATA 00,15,00,99,99,99,99,99,99,99
DATA 00,15,15,00,99,99,99,99,99,99
DATA 00,15,99,15,00,99,99,99,99,99
DATA 00,15,99,99,15,00,99,99,99,99
DATA 00,15,99,99,99,15,00,99,99,99
DATA 00,15,99,99,99,99,15,00,99,99
DATA 00,15,99,99,99,99,99,15,00,99
DATA 00,15,99,99,99,15,15,15,15,00
DATA 00,15,99,15,15,15,00,00,00,00
DATA 00,15,15,00,15,15,00,99,99,99
DATA 00,15,00,99,00,15,15,00,99,99
DATA 00,00,99,99,00,15,15,00,99,99
DATA 99,99,99,99,99,00,15,15,00,99
DATA 99,99,99,99,99,00,15,15,00,99
DATA 99,99,99,99,99,99,00,00,00,99

FUNCTION AlustaHiiri (napit%)
  i.ax = 0

  CALL INTERRUPT(&H33, i, o)

  onkohiirta = o.ax
  napit% = o.bx
END FUNCTION

SUB GetEdkuva
IF x <= 629 AND y <= 463 THEN
  GET (x, y)-(x + 9, y + 15), edkuva
ELSEIF x > 629 AND y <= 463 THEN
  GET (x, y)-(639, y + 15), edkuva
ELSEIF x <= 629 AND y > 463 THEN
  GET (x, y)-(x + 9, 479), edkuva
ELSEIF x > 629 AND y > 463 THEN
  GET (x, y)-(639, 479), edkuva
END IF
END SUB

FUNCTION LueHiiri
  i.ax = 3
  CALL INTERRUPT(&H33, i, o)
  nappi = o.bx
  x = o.cx
  y = o.dx
END FUNCTION

SUB NaytaHiiri
  IF edx <> x OR edy <> y THEN    ' Estää vilkkumista
    PUT (edx, edy), edkuva, PSET

    GetEdkuva
    PiirraHiiri  ' Hiiren kuva takaisin näkyviin

    edx = x
    edy = y
  END IF
END SUB

SUB PiirraHiiri
RESTORE hiiri
FOR b = 0 TO 15
  FOR a = 0 TO 9
    READ piste
    IF piste <> 99 THEN PSET (x + a, y + b), piste
  NEXT
NEXT
END SUB

SUB RajaaHiiri (xp%, xs%, yp%, ys%)
  i.ax = 7
  i.cx = xp%
  i.dx = xs%
  CALL INTERRUPT(&H33, i, o)
  i.ax = 8
  i.cx = yp%
  i.dx = ys%
  CALL INTERRUPT(&H33, i, o)
END SUB

anomizer [21.04.2003 22:21:10]

#

toimiva ja hyvä
Tostahan vois tehä oikein hienon...

Dj Wolf [22.04.2003 10:11:41]

#

Mielenkiintoista, itsekin olen tehnyt joskus aikaisemmin samanlaisen, eikä siinäkään piirtäminen onnistunut muuten kuin pistämällä hiiren kursori vilkkumaan.
Ilmeisesti kaksoispuskuria tms. käyttämällä moisesta ongelmasta pääsisi eroon, mutta kun edelleen niiden DIM-taulukoiden koko on rajoitettu :(.

HtH [22.04.2003 21:36:37]

#

Ihan hyvä muuten, mutta käytännössä tuolla ei oikein mitään tee :)

HtH [22.04.2003 21:41:28]

#

ohops, onhan tuossa sittenkin tallennus ja avaus mahdollisuudet, my fault. :)

Sami [22.04.2003 21:51:42]

#

Tallennusmahdollisuus siinä on ollut alusta alkaen, mutta latausta en ainakaan vielä ole tehnyt siihen...

Sivun alkuun

Vastaus

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

Tietoa sivustosta