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

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.

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