home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 16 / CD_ASCQ_16_0994.iso / news / 572 / upkpcx.pas < prev   
Pascal/Delphi Source File  |  1992-11-19  |  6KB  |  201 lines
  1. (*  Unité Pk PCX
  2.  
  3.     modeaff = 1     256  couleurs
  4.     modeaff = 2     16   couleurs
  5.     modeaff = 3     2    couleurs
  6. *)
  7.  
  8. unit upkpcx;
  9.  
  10. interface
  11.  
  12. uses dos,graph,crt;
  13.  
  14. type type_entete=record
  15.                  manu,vers,compr,prof      :byte;
  16.                  x1,y1,x2,y2,x0,y0         :word;
  17.                  pal                       :array[0..47]of byte;
  18.                  res,plan                  :byte;
  19.                  bpl,pinfo,xecr,yecr       :word;
  20.                  blanc                     :array[0..53]of byte;
  21.                end;
  22.   var       pcx_info    : type_entete;
  23.             pcx_pal     : array[0..767]of byte;
  24.   function  pcx_ouvre(nom:string):integer;
  25.   procedure pcx_affiche(gx,gy, x,y,xx,yy:integer);
  26.   procedure pcx_palette;
  27.   procedure pcx_ferme;
  28.  
  29.  
  30. implementation
  31.  
  32.  
  33. var  pcx_buff            : array[0..32770] of byte;
  34.      pcx_mode            : integer;
  35.      lapal               : longint;
  36.      taille,ibuff        : word;
  37.      f                   : file;
  38.      nomfichier          : string;
  39.      modeaff            : integer;
  40.      b                  : byte;
  41.      i                  : integer;
  42.      car                : char;
  43.  
  44. function itoa(n:longint;p:integer):string;
  45. var t:string;
  46. begin
  47.   str(n:p, t); itoa:=t;
  48. end;
  49.  
  50. procedure erreur(msg:string);
  51. begin
  52.   restorecrtmode;
  53.   writeln('***ERREUR***');
  54.   writeln(msg);
  55.   writeln;
  56.   halt(1);
  57. end;
  58.  
  59. procedure pcx_bloc;
  60. begin
  61.   blockread(f,pcx_buff,32768,taille);
  62.   ibuff:=0;
  63. end;
  64.  
  65. function pcx_ouvre(nom:string):integer;
  66. begin
  67.   {$i-}
  68.   assign(f,nom); reset(f,1); if ioresult<>0 then halt(1);
  69.   {$i+}
  70.   blockread(f,pcx_info,128);
  71.   modeaff:=0;
  72.   if pcx_info.plan=1 then if pcx_info.prof=8 then modeaff:=1
  73.                                              else modeaff:=3;
  74.   if pcx_info.plan=4 then modeaff:=2;
  75.   case modeaff of
  76.     2: move(pcx_info.pal, pcx_pal, 16*3);
  77.     1: begin
  78.          seek(f,filesize(f)-769);  { palette suffixée }
  79.          blockread(f,b,1);
  80.          if b=12 then blockread(f,pcx_pal,768);
  81.        end;
  82.   end;
  83.   for i:=0 to 767 do pcx_pal[i]:=pcx_pal[i]shr 2;     { sur 6 bits }
  84.   pcx_ouvre:=modeaff;
  85. end;
  86.  
  87. procedure pcx_affiche(gx,gy, x,y,xx,yy:integer);
  88. var n                : byte;
  89.     i                : integer;
  90.     cx,cy,rep,xy     : word;            { x,y, xx,yy : rect à visu }
  91.     video, maxy      : word;
  92.     leplan           : word;
  93.     lesplans         : array[0..3]of byte;
  94.     maxx,octetecran  : integer;
  95.     mx,my            : integer;
  96.  
  97.   procedure vgaplan(n:integer);
  98.   begin
  99.     port[$3c4]:=2; port[$3c5]:=n;
  100.   end;
  101.  
  102.   procedure pcx_aff(n:integer);
  103.   begin
  104.     if (y<=cy)and(cy<=yy)and(x<=cx)and(cx<=xx)then
  105.       if modeaff=1 then
  106.         putpixel(gx+cx,gy+cy,n)
  107.       else
  108.         mem[$a000:(gy+cy)*octetecran+cx+gx]:=n;
  109.     inc(cx);
  110.     if cx>=maxx then
  111.       case modeaff of
  112.         1 : begin cx:=0; inc(cy); if cy>yy then cy:=maxy; end;
  113.         3 : begin cx:=0; inc(cy); if cy>yy then cy:=maxy; end;
  114.         2 : begin cx:=0; inc(leplan);
  115.               if leplan=4 then begin
  116.                 leplan:=0; inc(cy); if cy>=yy then cy:=maxy; end;
  117.               vgaplan(lesplans[leplan]);
  118.             end;
  119.       end; {case modeaff}
  120.   end;
  121.  
  122. begin
  123.   if xx<0 then xx:=pcx_info.x2-pcx_info.x1+1;
  124.   if yy<0 then yy:=pcx_info.y2-pcx_info.y1+1;
  125.   mx:=getmaxx; my:=getmaxy;
  126.   if gx+x>=mx then erreur('X Début sort de l''écran !');
  127.   if gy+y>=my then erreur('Y Début sort de l''écran !');
  128.   if gx+xx>mx then xx:=mx-gx;           { fin sort de l'écran }
  129.   if gy+yy>my then yy:=my-gy;
  130.   if gx+x<0   then x:=-gx;              { début pas encore dans l'écran }
  131.   if gx+y<0   then y:=-gy;
  132.   if (modeaff=2)or(modeaff=3) then begin
  133.     gx:=gx div 8; x:=x div 8; xx:=xx div 8;          { x: octet en octet }
  134.   end;
  135.   cy:=0; cx:=0; maxy:=pcx_info.y2-pcx_info.y1+1;
  136.   lesplans[0]:= 1; lesplans[1]:= 2; lesplans[2]:= 4; lesplans[3]:= 8;
  137.   leplan:=0;
  138.   case modeaff of
  139.    3:begin
  140.        vgaplan(1+2+4+8);
  141.        maxx:=pcx_info.bpl;
  142.        octetecran:=(getmaxx+1)div 8;     { 800*600->100  640*480->80 }
  143.      end;
  144.    2:begin
  145.        vgaplan(lesplans[leplan]);
  146.        maxx:=pcx_info.bpl;
  147.        octetecran:=(getmaxx+1)div 8;
  148.      end;
  149.    1:begin
  150.        maxx:=pcx_info.x2-pcx_info.x1+1;  { largeur image }
  151.        if (maxx mod 2)=1 then erreur('La largeur doit être un nombre PAIR !');
  152.        octetecran:=getmaxx+1;            {320 640 800 1024}
  153.      end;
  154.   end;
  155.   seek(f,128);
  156.   pcx_bloc;
  157.   {-----------------------------------------------début décodage----------}
  158.   while cy < maxy do begin
  159.     if taille<=0 then pcx_bloc;
  160.     n:=pcx_buff[ibuff]; inc(ibuff); dec(taille);
  161.     if (n and $c0)=$c0 then begin
  162.       rep:= n and $3f;
  163.       if taille<=0 then pcx_bloc;
  164.       n:=pcx_buff[ibuff]; inc(ibuff); dec(taille);
  165.       for i:=1 to rep do pcx_aff(n);
  166.     end else pcx_aff(n);
  167.   end;
  168.   {-----------------------------------------------fin   décodage----------}
  169.   vgaplan(1+2+4+8);
  170. end;
  171.  
  172. procedure pcx_palette;
  173. var i,n       :integer;
  174.     b         :byte;
  175.     regs      :registers;
  176. begin
  177.   case modeaff of
  178.     2:
  179.     for i:=0 to 15 do begin
  180.       setpalette(i,i);
  181.       setrgbpalette(i,pcx_pal[i*3],pcx_pal[i*3+1],pcx_pal[i*3+2])
  182.     end;
  183.     1:begin
  184.       regs.ah := $10;              regs.al := $12;
  185.       regs.es := seg(pcx_pal);     regs.dx := ofs(pcx_pal);
  186.       regs.bx := 0;                regs.cx := $100;
  187.       intr($10, regs)
  188.     end;
  189.   end;      { case of }
  190. end;
  191.  
  192. procedure pcx_ferme;
  193. begin
  194.   close(f);
  195. end;
  196.  
  197. begin
  198. end.
  199.  
  200.  
  201.