Keskustelu: Koodit: QB: Bittikartan purku suoraan GET-kuvaan (screen 7)

'Tarvittavat typet
TYPE BMPFILE
  TYYPPI AS STRING * 2
  KOKO AS LONG
  VARATTU1 AS INTEGER
  VARATTU2 AS INTEGER
  OFFBITIT AS LONG
END TYPE

TYPE BMPINFO
  KOKO AS LONG
  leveys AS LONG
  korkeus AS LONG
  PLANET AS INTEGER
  BITIT AS INTEGER
  PAKKAUS AS LONG
  KUVANKOKO AS LONG
  XPELSMETRI AS LONG
  YPELSMETRI AS LONG
  VARIMAARA AS LONG
  VARIINFO AS LONG
END TYPE
'värin lataukseen
TYPE rgbpikseli
  colorb AS STRING * 1
  colorg AS STRING * 1
  colorr AS STRING * 1
  varattu AS STRING * 1
END TYPE
'$DYNAMIC 'pitää olla, jotta voidaan varata muistia (muussa tapauksessa
'Laita kommenttimerkki redim-kohtiin, ja varaa itse riittävästi muistia
'taulukoille.


'ExtractBitmap - palataulukko, tied. nimi, kuva
SUB extractbitmap (kuva() AS INTEGER, FILU AS STRING, palakuva() AS INTEGER)

'' BMP-KUVAN LATAUSKOODI BY ANTTI LAAKSONEN, SOVELLETTU
'' GET-KUVAMUODON YMMÄRTÄMÄÄN MUOTOON BY SQWIIK ALIAS TARMO KORPELA.
'' !!!   KIROTTU OLKOON SCREEN 7   !!!

'' HTTP://WWW.OHJELMOINTIPUTKA.NET - KAIKILLE KAIKKEA

DIM TIEDOSTO AS BMPFILE, info AS BMPINFO, vari AS rgbpikseli
DIM a AS INTEGER, leveys AS INTEGER, pikseli AS STRING, LOPPU AS LONG, ii AS LONG
DIM aa AS INTEGER, getleveys AS INTEGER, bb AS INTEGER, cc AS INTEGER
DIM viimeinentila AS INTEGER
DIM tulos AS INTEGER, tulos2 AS LONG, maxintlast AS LONG, merkki AS STRING * 1

CONST maxint = &HFFFF 'intin max. arvo
maxintlast = 32768 'posit. &H10000

  a = FREEFILE
  OPEN FILU FOR BINARY AS #a
    'Aloitetaan sitten ....
    GET #a, , TIEDOSTO
    GET #a, , info
    IF TIEDOSTO.TYYPPI <> "BM" THEN EXIT SUB 'MUOTO PIELESSÄ
    IF info.BITIT <> 4 THEN EXIT SUB 'VÄRIMÄÄRÄ PIELESSÄ
    IF info.PAKKAUS <> 0& THEN EXIT SUB 'TUNTEMATON PAKKAUS TÄLLE VÄRIMÄÄRÄLLE
    OUT &H3C8, 0 'MUOKATAAN PALETTIA KUVAN MUKAAN
    FOR c = 1 TO 16
      GET #a, , vari
      OUT &H3C9, ASC(vari.colorr) \ 4
      OUT &H3C9, ASC(vari.colorg) \ 4
      OUT &H3C9, ASC(vari.colorb) \ 4
    NEXT c
    'PALETTI VAIHDETTU. SIIRRYTÄÄN SIIS KUVADATAAN, JA PAKATAAN SE GET:N YMMÄRTÄMÄÄN MUOTOON
    leveys = INT(info.leveys / 2 + .5) 'YHDEN RIVIN DATAN PITUUS TAVUINA TIEDOSTOSSA
    getleveys = (INT((info.leveys - 1) / 8) + 1) * 2'MONTAKO INTEGRIÄ VAATII YKSI KUVAN RIVI

    'kuvalle tilaa
    viimeinentila = 2 + (getleveys * info.korkeus) 'lasketaan, paljonko tarvitaan
    REDIM kuva(1 TO viimeinentila) AS INTEGER 'Muistin varastointi
    REDIM palakuva(1 TO 2 + (getleveys * info.leveys)) AS INTEGER 'yksittäisen palan vaatima muisti - oletetaan, että palat ovat neliöitä!
    kuva(1) = info.leveys: kuva(2) = info.korkeus 'talletetaan koko
    pikseli = SPACE$(leveys) '1 Rivin pituus tavuina...
    GET #a, , pikseli
    LOPPU = info.korkeus * leveys'KOKO DATAN PITUUS TAVUINA
    bb = 0 'silmukkamuuttuja
    cc = 0 'pitääkö vaihtaa inttiä rivissä?

    FOR ii = 1 TO info.korkeus 'HAETAAN KAIKKI PIKSELIT
      haettu = &H1 'mitä piks. haetaan
      FOR ww = 0 TO 3 'montako pikseliä / intti eli neljä, tarkistetaan mitkä päällä

        tulos2 = &H0 'nollataan

        FOR bb = 1 TO leveys'käydään läpi kaikki kuvapisteet rivillä

          'ensin neljä ylintä
          IF ((ASC(MID$(pikseli, bb, 1)) \ 16) AND haettu) <> 0 THEN 'löytyi haettu bitti
            tulos2 = (tulos2 * 2) + 1
          ELSE
            tulos2 = (tulos2 * 2)
          END IF

          'sitten tavun 4 alinta
          IF (ASC(MID$(pikseli, bb, 1)) AND haettu) <> 0 THEN 'löytyi haettu bitti
            tulos2 = (tulos2 * 2) + 1
          ELSE 'ei päällä
            tulos2 = (tulos2 * 2)
          END IF

          'tulos kasvaa sitä mukaa, kun bittejä kerääntyy
          'luettu 16 bittiä?
          IF bb MOD 8 = 0 THEN  'vaihdetaan inttiä
            'sekoitetaan tulos vastaamaan pakkausta. tavut vaihtavat paikkaa...! KIROUS SCREEN 7:lle!
            merkki = CHR$((tulos2 AND &HFF00) \ 256)'ylempi talteen
            tulos2 = tulos2 AND &HFF'pyyhitään ylempi
            tulos2 = tulos2 * 256 'siirretään alemmat ylemmäs
            tulos2 = tulos2 + ASC(merkki)
            IF (tulos2 AND maxintlast) <> 0 THEN 'argh... viimeisen bitin muuttuminen 1:ksi kääntää
                                                 'integrin sekaisin. Joten muokataan :)
              tulos = &H8000 '1000 0000 0000 0000 (bitteinä)
              tulos2 = tulos2 AND (&HFFFF - maxintlast) 'eka bitti 0:ksi
              tulos = tulos2
              tulos = tulos OR &H8000 'ja toimii
            ELSE
              tulos = (tulos2 AND maxint)
            END IF
            cc = cc + 1
            kuva(2 + cc) = tulos
            tulos2 = 0 'nollataan tulos
          END IF
        NEXT bb'rivi luettu haetun suhteen.
        haettu = haettu * 2 '&H2, &H4, &H8
      NEXT ww 'seuraava rivi
      GET #a, , pikseli 'uusi jono
    NEXT ii
  CLOSE #a
  'Sitten vielä flipataan ylösalaisin, kirottu olkoon bitmap-pakkaus...
  tulos = INT((info.korkeus - 1) / 2) 'puolikorkeus
  FOR bb = 0 TO tulos'ja kopsataan rivit
    ii = viimeinentila - ((bb + 1) * getleveys)'viimeisen rivin eka integer
    FOR cc = 1 TO getleveys
      aa = kuva(2 + (bb * getleveys) + cc) 'ylempi
      kuva(2 + (bb * getleveys) + cc) = kuva(ii + cc)
      kuva(ii + cc) = aa
    NEXT cc
  NEXT bb
  'Kaikki on valmista! Kuva on kokonaan muistissa!
END SUB

'DrawPalette - koordinaatit(x,y), kuvan id ja source + minne kopsataan.

SUB DrawPalette (x AS INTEGER, y AS INTEGER, id AS INTEGER, kuva() AS INTEGER, setti() AS INTEGER)
'kuva = source, setti = mihin ladotaan (varattu etukäteen extract:ssa, toivottavasti)
'Muutama välimuuttuja
DIM k AS INTEGER, a AS INTEGER, B AS INTEGER, c AS INTEGER
  k = (INT((kuva(1) - 1) / 8) + 1) * 2 'montako integeriä / rivi
  setti(1) = kuva(1): setti(2) = kuva(1) 'oletus että ovat neliöitä
  'rivi mistä aletaan
  a = id * setti(2) * k
  IF (id + 1) * kuva(1) > kuva(2) THEN EXIT SUB'ei ole mokomaa palaa setissä
  FOR B = 0 TO setti(2) - 1'ja kopsataan rivit
    FOR c = 1 TO k
      setti(2 + (B * k) + c) = kuva(2 + (B * k) + c + a)
    NEXT
  NEXT
END SUB