Program for displays pcx file in pascal

Delphi & Pascal (česká wiki)
Přejít na: navigace, hledání
Category: Source in Pascal

Program: Pcx.pas
File exe: Pcx.exe
Example: Presov.pcx

It displays PCX file of 16 colours. In spite of my attempt to make it as simple as possible and to give it a proper detailed description, I must admit it looks awful. However, you can make use of some required routines.
{ PCX.PAS                   Copyright (c) TrSek alias Zdeno Sekerak }
{ Prehliadac PCX suborov. Buhuzial iba 16 farebnych.                }
{                                                                   }
{ Datum:11.10.1996                             http://www.trsek.com }
 
{ chybove hodnoty vratene programom Show_PCX
   0 - O.K.
   1 - Nemoze otvorit subor
   2 - Nemoze alokovat pamat
   3 - spatny typ PCX suboru
}
 
program show_pcx;
uses crt,dos,graph;
 
{ struktura uvodnej hlavicky standartneho PCX formatu }
 
const BUFF=2048;                         { pre buffrov‚ ‡Ątanie }
 
type PCXHeader = record
      creator : byte;                    { Inform cia o tom, ‘e ide o sŁbor          }
                                         { vo form te PCX 10(0A) pre ZSoft           }
 
      version : byte;                    { ozna‡uje ‡Ąslo verzie PCX form tu (1 byte)}
                                         { M“‘e nadobŁdaŸ hodnoty:                   }
                                         { 0 - verzia 2.5                            }
                                         { 2 - verzia 2.8 s farebnou paletou         }
                                         { 3 - verzia 2.8 bez palety                 }
                                         { 5 - verzia 3.0 s paletou 256*3            }
 
      enconding : byte;                  { ozna‡uje pou‘itŁ met˘du k˘dovania (1 byte)}
                                         { 1 - "PCX Run-length" k˘dovanie            }
 
      bits : byte;                       { ur‡uje po‡et  bitov potrebn˜ch k  ulo‘eniu}
                                         { pixelu v jednej obrazovej rovine (1 byte) }
                                         { 1 - pre EGA, VGA, Hercules                }
                                         { 2 - pre CGA, VGA s 256 farbami            }
 
      xmin,ymin,xmax,ymax : integer;     { rozmery Œav˜ horn˜ roh, prav˜ doln˜       }
      VRes,Hres : integer;               { horizont lna resp.  vertik lna rozlĄ¨iteŒnosŸ }
      palette : array[0..15,0..2] of byte; {inform cia o palete (48 (16 x 3) bytov)  }
      VMode : byte;                      { rezervovan˜ byte (1 byte)                 }
 
      planes : byte;                     { po‡et bitov˜ch rovĄn obr zku              }
                                         { 4 - pre EGA, VGA                          }
                                         { 1 - pre CGA, Hercules                     }
 
      BytesPerLine : integer;            { po‡et bytov  na riadok  obr zku v  jednej }
                                         { bitovej rovine                            }
 
      PaletteInfo : integer;             { inform cia o tom,  ako interpretovaŸ      }
                                         { paletu farieb                             }
                                         { 1 - obr zok je farebn˜ alebo monochromatick˜}
                                         { 2 - stupne ¨edej                          }
 
      dummy : array[0..57] of byte;      { 58 voŒn˜ch bytov (doplnenie do 128)       }
                                         { Mo‘no pou‘iŸ na prenos inform ciĄ         }
                                         { vo vlastnej aplik cie.                    }
    end;
 
  textbuf=array[1..BUFF] of byte;
 
var gm,gd,i:integer;
    value:byte;
    count:integer;
    err:byte;
    tmp:byte;
    VgaBase:pointer;
    fPCXdata:file;
    buffer:^textbuf;
    LokCount:Longint;
    PCX:PCXHeader;
 
{ funkcie na ovladanie registrov EGA/VGA karty }
procedure SetVgaWritePlane(number:byte);
begin
 Port[$3C4]:=2;
 Port[$3C5]:=1 shl number;
end;
 
procedure SetVgaReg(a:byte; b:byte);
begin
 Port[$3CE]:=a;
 Port[$3CF]:=b;
end;
 
 
{ nacitanie a dekodovanie obrazovych dat metodou Run-Lenght }
function GetPCXByte:byte;
var error:word;
    tmp:byte;
begin
   if (count > 0) then
      begin
       dec(count);
       GetPCXByte:=value;
       exit;
      end;
 
   if (LokCount>BUFF) then begin
       BlockRead(fPCXdata,Buffer^,BUFF,error);
       LokCount:=1;
      end;
   tmp:=Buffer^[LokCount];
   Inc(LokCount);
 
   if ((tmp and $C0) = $C0) then
      begin
       count := (tmp and $3F) -1;
       if (LokCount>BUFF) then begin
           BlockRead(fPCXdata,Buffer^,BUFF,error);
           LokCount:=1;
          end;
       value:=Buffer^[LokCount];
       Inc(LokCount);
      end
     else
      begin
       count := 0;
       value := tmp;
      end;
 
 GetPCXByte:=value;
end;
 
function set_pcx(name:string):byte;
var 
    f:file of PCXHeader;           { pre na‡Ątanie hlavi‡ky }
    po:byte;
begin
 VgaBase:=Ptr($A000,$0);
 
 Assign(f,name);
 {$I-}
 reset(f);
 {$I+}
 if (IOResult<>0) then
     begin
      set_pcx:=1;               { nemoze otvorit subor }
      exit;
     end;
 
 read(f,PCX);
 close(f);
 
 { zmena palety }
 for i:=0 to 15 do begin
   po:=0;
   if (PCX.palette[i,0]>63) then
      if (PCX.palette[i,0]<128) then po:= po or 32
	 else if (PCX.palette[i,0]<192) then po:= po or 4
                 else po:= po or 36;
 
   if (PCX.palette[i,1]>63) then
      if (PCX.palette[i,1]<128) then po:= po or 16
         else if (PCX.palette[i,1]<192) then po:= po or 2
                 else po:= po or 18;
 
   if (PCX.palette[i,2]>63) then
      if (PCX.palette[i,2]<128) then po:= po or 8
         else if(PCX.palette[i,2]<192) then po:= po or 1
              else po:= po or 9;
 
   setpalette(i,po);
  end;
 
end;
 
function show(name:string ; xova,yova : integer ) : byte;
type BufPerLine=array[0..128] of byte;
var p,b,i:integer;
    ptr_:pointer;                  { ukazuje do obrazovkovej pam„te }
    CopyBytes:integer;             { pocet bytov na riadok }
    MaxScanLines:integer;          { pocet riadkov na obrazok }
    pl:array[0..3] of ^BufPerLine; { bufer pre jednotlive skanovacie riadky }
 
begin
 xova:=round(xova/8);
 { priprava udajov }
 for i:=0 to PCX.planes-1 do begin
     if PCX.BytesPerLine > MaxAvail then
        begin
         show:=2;
         exit;
        end;
     GetMem(pl[i],PCX.BytesPerLine);
    end;
 
 for p:=0 to 3 do
    for i:=0 to 128 do pl[p]^[i]:=0;
 
 if BUFF > MaxAvail then
    begin
     show:=2;
     exit;
    end;
 
 GetMem(buffer,SizeOf(textbuf));
 
 CopyBytes := Trunc(getmaxx / 8);
 
 if (CopyBytes > PCX.BytesPerLine) then
    CopyBytes := PCX.BytesPerLine;
 
 MaxScanLines := PCX.ymax - PCX.ymin;
 if (MaxScanLines > (getmaxy+1)) then
    MaxScanLines := getmaxy;
 
 SetVgaReg(5,0);
 SetVgaReg(1,0);
 LokCount:=BUFF+1;
 
 Assign(fPCXdata,name);
 reset(fPCXdata,1);
 seek(fPCXdata,128);         { posun na zaciatok dat }
 
 { nacitavanie obrazku }
  for i:=yova to MaxScanLines-1+yova do begin
      for p:=0 to PCX.planes-1 do
          for b:=0 to PCX.BytesPerLine-1 do
              pl[p]^[b] := GetPCXByte;
 
      ptr_:=PTR(SEG(VgaBase^),i*80+xova);
 
      { vykreslenie obr zku, presuvom do obr. pam„te }
      for p:=0 to PCX.planes-1 do begin
          SetVgaWritePlane(p);
          move(pl[p]^,ptr_^,CopyBytes);
         end;
  end;
 
 { Niekedy to padalo
 SetVgaWritePlane($F);}
 
 { uvolnenie naalokovanej pamate }
 for i:=PCX.planes-1 downto 0 do
     FreeMem(pl[i],PCX.BytesPerLine);
 
 close(fPCXdata);
 show:=0;
end;
 
begin
 Writeln('Prehliadac 16farebnych PCX                              Software by TrSek');
 if(ParamCount<1) then begin
    WriteLn('Ako parameter zadaj meno PCX suboru.');
    halt(1);
   end;
 detectgraph(gm,gd);
 initgraph(gm,gd,'');
 cleardevice;
 count:=0;
 set_pcx(paramstr(1));
 err:=show(paramstr(1),20,20);
 repeat until keypressed;
 closegraph;
end.