× Aktuálně z oboru

SHIELD Experience Upgrade 7 – méně hledání a více zábavy [ clanek/2018052902-shield-experience-upgrade-7-mene-hledani-a-vice-zabavy/ ]
Celá zprávička [ clanek/2018052902-shield-experience-upgrade-7-mene-hledani-a-vice-zabavy/ ]

Práce s grafikou 640x480@16bit v Pascalu. (4/4)

[ http://programujte.com/profil/20356-lukas-karas/ ]Google [ ?rel=author ]       [ http://programujte.com/profil/20356-jan-metelka/ ]Google [ ?rel=author ]       12. 2. 2006       14 914×

Popis grafické unity pro práci v grafickém módu 111h, (640x480x16bit) využívající virtuální obrazovku v XMS paměti. Obsahuje procedury pro práci s XMS, kreslení základních geometrických tvarů, grafický OutText a načítání obrázků ze souborů PCX (256barev).
Část 4. Načítání 256 barevných PCX obrázků a použití 2 barevných PCX obrázků jako textový font.

Tak tady je poslední část seriálu o grafické unitě gr16b. Jak načíst a zobrazit obrázek PCX s 256 barvami. Nebyl by problém načítat obrázky s více barvami, nebo třeba i BMP, zatím jsem ale neměl čas to napsat a s 256 barevnými PCXkama jsem si zatím vystačil.

(Zdroj: 1000 File Formats)

Grafický formát PCX:

  • Hlavička je dlouhá 128b. (Obsahuje informace o rozlišení, počtu barev…)
  • Potom následují obrazová data pakovaná RLE komprimací,
  • kontrolní byt (12) a nakonec paleta barev (u 256 barevných PCX).

    Hlavička PCX:

    Definoval jsem záznam TPCXheader, který stačí naplnit prvními 128 byty souboru, a pak jen číst informace.

    
         TPCXheader = record
           Manufacturer : byte;     {konstanta, vzdy $A0 }
           Version : byte;          {cislo verze }
                                    { 2 = pouziva maximalne 16 barev (obsahuje paletu)}
                                    { 3 = stejne jako predchozi (bez palety barev)}
                                    { 4,5 = 256 24 bitovych barev }
           Encoding : byte;         { 1 = pouziva RLE komprimaci}
           BitsPerPixel : byte;     { bitu na pixel (pocet barev)}
                                    { standartne - 1, 2, 4, 8}
           Window : record          { souradnice obrazu (netusim k cemu to je)}
                      Xmin, Ymin, Xmax, Ymax : integer;
                    end;
           HDpi : integer;          {pixelu na palec (horizontal DPI) - vetsinou 300}
           VDpi : integer;
           Colormap : array[0..47] of byte; {mapa barev pri pouziti 16 barev (16*3=48)}
           Reserved : byte;         {vzdy 0}
           NPlanes : byte;          {pocet rovin (co?)}
           BytesPerLine : integer;  {Number of bytes to allocate for a scanline
                                     plane.  MUST be an EVEN number.  Do NOT
                                     calculate from Xmax-Xmin.}
           PaletteInfo : integer;   {How to interpret palette- 1 = Color/BW,
                                     2 = Grayscale (ignored in PB IV/ IV +)}
           HscreenSize : integer;   {Horizontal screen size in pixels. New field
                                     found only in PB IV/IV Plus}
           VscreenSize : integer;   {Vertical screen size in pixels. New field
                                     found only in PB IV/IV Plus}
           Filler : array[0..53] of byte;   {Blank to fill out 128 byte header.
                                     Set all bytes to 0 }
         end;
    

    Jediné co potřebujeme z hlavičky získat je počet barev (jestli je 256) a rozlišení.

    
    {var hlavicka: TPCXheader;}
    
    blockread(soubor, hlavicka, sizeOf(hlavicka) );
    
      if (hlavicka.Manufacturer<>10) or (hlavicka.Version<>5) or
         (hlavicka.Encoding<>1) or (hlavicka.BitsPerPixel<>8)then begin
            {pokud neni splnena jedna z podminek není to PCX s 256 barvami}
          nactiPCX:=2;
          exit;
      end;
    
      obrazek.X:=(hlavicka.window.xmax-hlavicka.window.xmin)+1; { xove rozliseni }
      obrazek.Y:=(hlavicka.window.ymax-hlavicka.window.ymin)+1; { yove rozliseni }
    

    Obrazová data PCX (RLE komprimace):

    Po načtení bajtu X se zjistí, zda dva nejvyšší bity mají hodnotu jedna. Pokud ano, 6 nižších bitů bajtu X má význam počtu opakování a bajt následující za bajtem X obsahuje hodnotu, která se má opakovat. Nejsou-li dva nejvyšší bity jedničkové, X obsahuje přímo nekomprimovanou hodnotu. Toto vše se opakuje, dokud je počet zpracovaných pixelů menší než obrazek.X* obrazek.Y.

    Paleta Barev:

    Mezi obrazovými daty a paletou barev se nachází kontrolní byt který mívá hodnotu 12. Paleta obsahuje vždy 3 barevné složky (RGB) pro každou z 256 barev. Paletu lze jednoduše načíst tak, že do dvojrozměrného pole pal = array [0..255, 1..3] of byte; načtete posledních 768 bytů souboru. (256*3=768)

    V unitě gr16b se nejdříve nahraje hlavička a zjistí se zda se jedná o správný formát. Poté se nahraje paleta barev s jejíž pomocí se nakonec dekódovaná obrazová data převádějí na 16bitové pixely vkládané do bloku v XMS.

    
    function nactiPCX(cesta:string;var obrazek:Tobrazek):byte;
    {Podporovany jsou PCX 256 barev}
    {vraci 0 pri uspechu, jinak:
           1 - nenalezl soubor
           2 - nepodporovany format
           3 - nevejde se do pameti
           4 - chyba pri dekodovani (asi poskozeny soubor)
           5 - neni nainstalovan ovladac XMS
    }
    type Tpal  = array [0..255, 1..3] of byte;
    var hlavicka:TPCXheader;
        palPCX:Tpal;
        soubor:file;
    
        data:byte;
        index,velikostObr:longint;
        skupina:byte;
        barva:word;
        volnaPamet:word;
        potrebnaPamet:longint;
        barvaAdr:longint;
    Begin
      assign(soubor, cesta);
      {$I-} {jen pro jistotu}
      reset(soubor,1); {data budeme prenaset po jednom byte}
      {$I+}
      if IOresult <> 0 then begin
          nactiPCX:=1;
          exit;
      end;
      {Pokud jsme jeste tady, tak byl soubor nalezen :o) }
      obrazek.cesta:=cesta;
      blockread(soubor, hlavicka, sizeOf(hlavicka) );
    
      if (hlavicka.Manufacturer<>10) or (hlavicka.Version<>5) or
         (hlavicka.Encoding<>1) or (hlavicka.BitsPerPixel<>8)then begin
          nactiPCX:=2;
          exit;
      end;
    
      obrazek.bitsPerPixel:=hlavicka.BitsPerPixel;
      obrazek.X:=(hlavicka.window.xmax-hlavicka.window.xmin)+1;
      obrazek.Y:=(hlavicka.window.ymax-hlavicka.window.ymin)+1;
    
      {***********************************************************************}
      {mame informace o souboru, jdeme na to}
      if detekujXms<>0 then begin
          nactiPCX:=5;
          exit;
      end;
    
      getSizeXMS(barva,volnaPamet);
      velikostObr := obrazek.X;
      velikostObr := velikostObr * obrazek.Y;
      potrebnaPamet := velikostObr * 2;
      potrebnaPamet := (potrebnaPamet div 1024)+1;
      if volnaPamet  < potrebnaPamet then Begin
          nactiPCX:=3;
          exit;
      end;
      obrazek.handle:=alokujXMS(potrebnaPamet);
    
      barvaAdr:=seg(barva);
      barvaAdr:=barvaAdr shl 16;
      barvaAdr:=barvaAdr or ofs(barva);
    
      {mame alokovanou pamet, jdeme rozebrat soubor...}
    
      {...nacitame paletu...}
      seek(soubor, FileSize(soubor) - (768+1));
      blockread(soubor, data, 1);
      {nyni kontrola jestli jsme u palety souboru PCX}
      if data <> 12 then begin
          uvolniObrazek(obrazek);
          nactiPCX:=4;
          exit;
      end
      else blockread(soubor, palPCX, 768);
      { takhle jsme nacetli celou paletu PCX souboru do promenne palPCX }
      {...a ted uz konecne ten obrazek...}
    
      skupina:=0; {obsahuje delku rady stejnych pixelu}
      index:=1;   {obsahuje nasi pozici v obrazku}
    
      seek(soubor, 128);
      {preskocili jsme hlavicku ktera ma 128 bytu. (uz jsme ji nacetli)}
      repeat
        blockread(soubor, data, 1);
        {kdyz jsou data>=$C0 (dekadicky 192 = 1100 0000 - horni dva bity jsou
        nastaveny), pak se v dolnich 4 bitech naleza delka skupinky pixelu
        stejne barvy a nasledujici byte souboru je barva techto pixelu}
        if data >= 192 then
          begin
            skupina:=data and 63;
            {63 = 0000 1111b ve "skupina" zbudou jen dolni 4 bity=delka skupinky}
            blockread(soubor, data, 1);  {prectu barvu}
            repeat
              barva:=getColor(palPCX[data,1],palPCX[data,2],palPCX[data,3]);
    
              defPresunu.velikost  := 2;
              defPresunu.zdRukojet := 0;
              defPresunu.zdOffset  := barvaAdr;
              defPresunu.clRukojet := obrazek.handle;
              defPresunu.clOffset  := (index-1) * 2;
              {krmit XMS po 2 bytech je asi pomale, pokud ale nenacitate
               fotku o 1600x1200, tak to s tou rychlosti celkem jde }
    
              presunXms( defPresunu );
    
              index:=index + 1;
              dec(skupina);
            until skupina = 0;
          end
        else
          begin
              barva:=getColor(palPCX[data,1],palPCX[data,2],palPCX[data,3]);
    
              defPresunu.velikost  := 2;
              defPresunu.zdRukojet := 0;
              defPresunu.zdOffset  := barvaAdr;
              defPresunu.clRukojet := obrazek.handle;
              defPresunu.clOffset  := (index-1) * 2;
              {krmit XMS po 2 bytech je asi pomale, pokud ale nenacitate
               fotku o 1600x1200, tak to s tou rychlosti celkem jde }
    
              presunXms( defPresunu );
    
            index:=index + 1;
          end;
    
      until index > velikostObr; {dokud nemame nacteny cely obrazek...}
      close(soubor);
      nactiPCX:=0;
    end;
    

    Kopírovat data do XMS po 2 bytech není zrovna nejrychlejší, pokud načítáme ale jen několik obrázků na začátku programu, tak se to dá snést. Veškeré informace o obrázku máme uloženy v záznamu Tobrazek.

    
         Tobrazek=record
           cesta:string;       {co je to za obrazek}
           X,Y:word;           {rozliseni}
           bitsPerPixel:byte;  {barevna hloubka (originalu - v pameti
                                je vzdy 16bit, aby se rychlejc vykresloval)}
           handle:word;        {rukojet bloku v XMS kde je obrazek dekodovan}
         end;
    

    Když již máme obrázek převedený do 16bit. grafiky a umístěný v XMS, je velice snadné jej přenést do virtuální obrazovky. Nejdříve si musíme do virtuální obrazovky zkopírovat zrcadlenou část v bufferu, vypočítat jaký výřez obrázku budeme kopírovat a pak už ho jen řádek po řádku zkopírovat.

    
    procedure zobrazObrazek(x,y:integer;obrazek:Tobrazek);
    {vykresli obrazek do virtualni obrazovky na zadane souradnice}
    var Yobrazovky,Xobrazovky,Yobrazku,Xobrazku,sirka:longint;
    Begin
      if (obrazek.x=0) or (obrazek.y=0) or (obrazek.handle=0) or (x>639) or (y>479)then begin
         exit;
      end;
        { nejdrive si presunu prave upravovany bank (buffer) do xms}
        defPresunu.velikost  := 32768;
        defPresunu.zdRukojet := 0;
        defPresunu.zdOffset  := BufferAdr;
        defPresunu.clRukojet := handle;
        defPresunu.clOffset  := zrcadlenaCast shl 15;
    
        presunXms( defPresunu );
    
    
      {...a ted presunu obrazek...}
      Yobrazovky:=y; {od jakeho radku obrazovky budeme obrazek vykreslovat}
      if Yobrazovky<0 then Yobrazovky:=0;
      Yobrazku:=0;
      if y<0 then Yobrazku:=y * -1;
    
      Xobrazovky:=X; {od jakeho radku obrazovky budeme obrazek vykreslovat}
      if Xobrazovky<0 then Xobrazovky:=0;
      Xobrazku:=0;
      if X<0 then Xobrazku:=X * -1;
    
      sirka := obrazek.x - Xobrazku;
      if sirka > 640 then sirka:=640 - Xobrazovky;
      if (sirka+Xobrazovky)>640 then sirka:=640-Xobrazovky;
    
      if sirka<0 then exit;
    
      while (Yobrazovky<480) and (Yobrazku < obrazek.y) do begin
         defPresunu.velikost  := sirka*2;
         defPresunu.zdRukojet := obrazek.handle;
         defPresunu.zdOffset  := (Yobrazku*obrazek.x*2)+(Xobrazku*2);
         defPresunu.clRukojet := handle;
         defPresunu.clOffset  := (Yobrazovky*640*2)+(Xobrazovky*2);
    
         presunXms( defPresunu );
         Yobrazovky:=Yobrazovky+1;
         Yobrazku:=Yobrazku+1;
    
      end;
    
      {dame zpet zmeneny buffer...}
        defPresunu.velikost  := 32768;
        defPresunu.zdRukojet := handle;
        defPresunu.zdOffset  := zrcadlenaCast shl 15;
        defPresunu.clRukojet := 0;
        defPresunu.clOffset  := BufferAdr;
    
        presunXms( defPresunu );
    end;
    

    Před koncem programu musíme paměť alokovanou všemi obrázky uvolnit.

    
    procedure uvolniObrazek(obrazek:Tobrazek);
    {uvolni pamet vyuzivanou obrazkem. (Stane se nepouzitelnym)}
    Begin
      uvolniXMS(obrazek.handle);
      obrazek.cesta:=';
      obrazek.X:=0;
      obrazek.Y:=0;
      obrazek.bitsPerPixel:=0;
    end;
    

    Grafický OutText:

    Nikde jsem nenašel popis formátu nějakého standardního fontu (fon či ttf), proto jsem si vytvořil proceduru, která načte font z dvojbarevného souboru PCX. Myšlenka je poměrně jednoduchá, jedná se o obrázek široký 1-8 pixelů, vysoký 256-4096 pixelů a výškou beze zbytku dělitelnou 256. Každé písmeno je pak stejně široké jako obrázek s fontem a výšku vypočítáme z výšky obrázku div 256. Jednotlivá písmena jsou tedy přímo v obrázku na předem daných pozicích. Procedura pro načítání tohoto fontu je následující:

    
    function nahrajFont(cesta:string;var font:font):byte;
    {pokud vrati 0, je vse v poradku a font obsahuje zadany font...}
    {1-soubor s fontem nebyl nalezen}
    {2-nepodporovany format pcx (musi byt cernobily)}
    {3-nespravna velikost obrazku}
        function prevrat(Byt:byte):byte;
        var vratit:byte;
        Begin
            vratit:=0;
            if byt and 1   = 1   then vratit:=vratit or 128;
            if byt and 2   = 2   then vratit:=vratit or 64;
            if byt and 4   = 4   then vratit:=vratit or 32;
            if byt and 8   = 8   then vratit:=vratit or 16;
            if byt and 16  = 16  then vratit:=vratit or 8;
            if byt and 32  = 32  then vratit:=vratit or 4;
            if byt and 64  = 64  then vratit:=vratit or 2;
            if byt and 128 = 128 then vratit:=vratit or 1;
            prevrat:=vratit;
        end;
    var
      soubor:file;
      Omax:word;
      sirka, vyska: word;
      hlavicka:TPCXheader;
    
      radek,znak:byte;
      data:byte;
      bit:byte;
      pix:byte;
      index:word;
      skupina:byte;
    
    begin
      {zkontrolujem jestli existuje soubor....}
      assign(soubor, cesta);
      {$I-} {jen pro jistotu}
      reset(soubor,1); {data budeme prenaset po jednom byte}
      {$I+}
      if IOresult <> 0 then begin
          nahrajFont:=1;
          exit;
      end;
      {Pokud jsme tady, tak byl soubor nalezen :o) }
    
      {...zkontrolujeme jestli obrazek pcx obsahuje font...}
      blockread(soubor, hlavicka, sizeOf(hlavicka) );
      if (hlavicka.Manufacturer<>10) and (hlavicka.Version<>5) and
         (hlavicka.Encoding<>1) and (hlavicka.BitsPerPixel<>1) then
         begin
          nahrajFont:=2;
          exit;
      end;
    
      {zkontrolujeme, jestli ma obrazek spravne rozmery}
      {sirka 1-8px AND vyska 256-4096 AND vyska mod 256 = 0}
      vyska:=(hlavicka.window.ymax-hlavicka.window.ymin)+1;
      sirka:=(hlavicka.window.xmax-hlavicka.window.xmin)+1;
      if ( (sirka<1)   or (sirka>8) or
           (vyska<256) or (vyska>4096) or
           (vyska mod 256 <> 0)) then Begin
           nahrajFont:=3;
           exit;
      end;
      {mame soubor s fontem!!!!}
      Omax:=vyska;
      Omax:=Omax*sirka; {vypocteme kolik pixelu ma obrazek}
      font.sirka:=sirka;
      font.vyska:=vyska div 256; {ulozime rozmery jednoho znaku fontu}
    
      {jdem dekodovat soubor...}
      seek(soubor, 128);  {preskocili jsme hlavicku ktera ma 128 bytu.
                          (uz jsme ji totiz nacetli...)}
      skupina:=0; {obsahuje delku rady stejnych pixelu}
      index:=1;   {obsahuje nasi pozici v obrazku}
      znak:=0;    {obsahuje cislo znaku, ktery je prave nacitan}
      radek:=0;   {obsahuje cislo radku ve znaku, ktery je prave nacitan}
      repeat
        blockread(soubor, data, 1);
        {kdyz jsou data>=$C0 (dekadicky 192 = 1100 0000 - horni dva bity jsou
        nastaveny), pak se v dolnich 4 bitech naleza delka skupinky pixelu
        stejne barvy a nasledujici byte souboru je barva techto pixelu}
        if data >= 192 then
          begin
            skupina:=data and 63;
            {63 = 0000 1111b ve "skupina" zbudou jen dolni 4 bity=delka skupinky}
            blockread(soubor, data, 1);  {prectu barvu}
            repeat
    
              {Pracujeme s obr se dvema barvama.}
              {diky vnitrni architekture procesoru 80X86(?) a vyssich jsou
              nejvyznamejsi byty vpravo, coz znamena ze bity jsou psane pozpatku :-o}
              {(obracene nez to chape clovek - z prava doleva)}
              font.znak[znak,radek]:=prevrat(data);
              inc(radek);
              if (radek=font.vyska) then Begin radek:=0; inc(znak); end;
              inc(index,font.sirka);
    
              dec(skupina);
            until skupina = 0;
          end
        else
          begin
    
              {Pracujeme s obr se dvema barvama.}
              font.znak[znak,radek]:=prevrat(data);
              inc(radek);
              if (radek=font.vyska) then Begin radek:=0; inc(znak); end;
              inc(index,font.sirka);
    
          end;
      until index > Omax; {o max je X*Y obrazku...}
      {nema cenu nacitat nejakou paletu (stejne tam zadna neni:)...
      barvu 1 dame bilou a 2 cernou...}
      nahrajfont:=0;
      close(soubor);
    end;
    

    Celý font poté máme načten do záznamu font.

    
         font=record
           vyska,sirka:word;
           znak:array[0..255,0..15] of byte;
         end;

    Psaní tímto fontem do virtuální obrazovky je pak velice jednoduché.

    
    procedure pis(x,y:word;text:string;font:font;barva:word);
    { vypise text zadanym fontem do virtualni obrazovky }
        function zjistiBit(Byt:byte;bit:byte):byte;
        {vraci bit v byte na pozici bit}
        {trosku kostrbate vysvetleni, jestli to nechapes, tak to prostuduj...}
        Begin
           bit:=1 shl bit;  {pokud je 0 dek=> 1 bin ; 1 dek=> 10 bin ; 2 dek=> 11 bin...}
           {   00000010      }
           if byt and bit = bit then zjistiBit:=1
           else zjistiBit:=0;
        end;
    var vertikalni,horizontalni,pozice:byte;
    Begin
       pozice:=0;
       repeat
           inc(pozice);
           vertikalni:=0;
           repeat
              horizontalni:=0;
              repeat
    
                 if zjistiBit(font.znak[  Ord(text[pozice])  ,vertikalni],horizontalni)=0 then
                      Pixel(x+(pozice*font.sirka)+horizontalni,y+vertikalni ,barva);
    
                 inc(horizontalni);
              until horizontalni=font.sirka;
              inc(vertikalni);
           until vertikalni=font.vyska;
       until pozice=Length(text);
    end;
    

    V přiloženém ZIPu naleznete kompletní zdrojový kód unity, dva grafické fonty a pár demo programů využívajících unitu gr16b. (Neručím za spisovnost a gramatickou správnost komentářů přiložených programů. :-) Dále bych vás chtěl upozornit že přiložené programy jsou pouze demonstrativním použitím popisované unity a že nenesu žádnou zodpovědnost za škody způsobené jejich používáním! (Ve Win XP nejsou občas přerušení grafiky emulována správně.)

    I když jsem se snažil co nejvíce, je možné, v programech se vyskytují nějaké chyby. Pokud nějakou chybu najdete, tak mě prosím kontaktujte. Kdyby jste se chtěli o nějaké části (i přiložených programů) dozvědět více, nebo měli nějaké připomínky a návrhy na zlepšení, tak mi napište.

  • e-mail: lukas.karas@centrum.cz
  • ICQ: 249 268 809

    Pokud Vám tato unita k něčemu bude, můžete ji používat pro své NEKOMERČNÍ programy, volně ji šířit a upravovat. (Pokud ovšem vždy do zdrojového kódu uvedete jméno a kontakt na jejího původního autora!) Pokud vytvoříte nový font, nebo unitu upravíte (vylepšíte), pošlete mi prosím tento soubor na můj e-mail. Velice děkuji!

    Někdy časem možná připíšu proceduru na otevírání BMP a procedury pro načítaní nějakých standardních fontů....

    Zdroje:

    Způsob načítání obrázků PCX jsem našel v popisu formátu PCX v programu 1000 file format, Bresenhamův algoritmus v článku "Grafický režim VGA 320x200x256 (MCGA)" od Petra Kučery na pcsvet.cz, ovládání XMS a myši jsem vyčetl ze Sysmana a adresování grafické paměti při vyšších VESA módech jsem se naučil z článku "Zobrazováni 24 bit. BMP" od Petra Kučery na www.pcsvet.cz.

    Zdrojové texty a programy ke stáhnutí:

    zde [ storage/gr16b12.rar ]


  • Článek stažen z webu Programujte.com [ http://programujte.com/clanek/2006012504-prace-s-grafikou-640x480-16bit-v-pascalu-4-4/ ].