home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / pcx / teglpcx / pcxgraph.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-10-21  |  6.5 KB  |  227 lines

  1. {-----------------------------------------------------------------------------}
  2. {               TEGL Windows ToolKit II                  }
  3. {          Copyright (C) 1990, 1991 TEGL Systems Corporation              }
  4. {                All Rights Reserved.                  }
  5. {-----------------------------------------------------------------------------}
  6.  
  7. {$I switches.inc}
  8. {$IFDEF TEGLOVR}
  9. {$O+}
  10. {$F+}
  11. {$ENDIF}
  12.  
  13.  
  14. unit PCXGraph;
  15.  
  16. INTERFACE
  17.  
  18. uses dos,
  19.      errorlog,
  20.      fastgrph,            {for ActiveTEGLMode}
  21.      tgraph,            {for palette type}
  22.      virtmem;
  23.  
  24. TYPE
  25.       pcxheader  =  record
  26.               manufacturer : byte;
  27.               version       : byte;
  28.               encoding       : byte;
  29.               bitsperpixel : byte;
  30.               xmin,ymin    : integer;
  31.               xmax,ymax    : integer;
  32.               HDPI,VDPI    : integer;
  33.               colormap       : array[0..47] of byte;
  34.               reserved       : byte;
  35.               NPlanes       : byte;
  36.               bytesperline : integer;
  37.               paletteinfo  : integer;
  38.               HscreenSize  : word;
  39.               VscreenSize  : word;
  40.               filler       : array[0..53] of byte;
  41.            end;
  42.  
  43. function  FileExists(filename:pathstr) : boolean;
  44.  
  45. procedure SetPCXBWMap(r,g,b,i : byte);
  46.  
  47. procedure QuickShowPCXFile(pcxfilename:pathstr; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  48. procedure DisplayPCXFile(pcxbuff:pointer; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  49.  
  50. function  LoadPCXFiletoVirtual(pcxfilename:pathstr) : virtualptr;
  51. procedure DisplayVirtualPCXFile(pcxbuff:virtualptr; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  52.  
  53. procedure listPCXHeaderInfo(pcxhead:pcxheader);
  54. procedure GetPcxHeader(pcxfilename:pathstr; var pcxhead:pcxheader);
  55.  
  56. IMPLEMENTATION
  57.  
  58. const
  59.    rgbpcxmap : array[0..3] of byte = ($ff,$ff,$ff,$ff);
  60.  
  61. {$F+}
  62. procedure egapcx4plane(pcxbuff:pointer; baseoffset,maxlines,maxwidth:word); external;
  63. procedure egapcx1plane(pcxbuff:pointer; baseoffset,maxlines,maxwidth:word); external;
  64. {$L pcxega.obj}
  65. {$F-}
  66. {$I-}
  67.  
  68. function FileExists(filename:pathstr) : boolean;
  69.    var tstfile     : file;
  70.        retcode     : word;
  71.    begin
  72.       assign(tstfile,filename);
  73.       reset(tstfile,1);
  74.       Retcode := IOresult;
  75.       close(tstfile);
  76.  
  77.       FileExists := retcode=0;
  78.    end;
  79.  
  80. function LoadPCXFiletoVirtual(pcxfilename:pathstr) : virtualptr;
  81.    var pcxfile     : file;
  82.        pcxbuff     : virtualptr;
  83.        retcode     : integer;
  84.        pcxsize     : longint;
  85.        blkbuff     : pointer;
  86.        bytesread : word;
  87.        p     : pathstr;
  88.        d     : dirstr;
  89.        n     : namestr;
  90.        e     : extstr;
  91.    begin
  92. {     fsplit(pcxfilename,d,n,e); }
  93. {     pcxfilename := n+e;
  94.       pcxfilename := fsearch(pcxfilename,getenv('PATH')); }
  95.  
  96.       Retcode := IOresult;
  97.       assign(pcxfile,pcxfilename);
  98.       reset(pcxfile,1);
  99.  
  100.       Retcode := IOresult;
  101.       if retcode<>0 then
  102.      aborterror('Unable to find and load PCX File: '+pcxfilename,retcode);
  103.  
  104.       pcxsize := filesize(pcxfile);
  105.       vpgetmem(pcxbuff,pcxsize);
  106.  
  107.       vpaccess(pcxbuff,blkbuff);
  108.  
  109.       repeat
  110.      blockread(pcxfile,blkbuff^,$8000,bytesread);
  111.      blkbuff := lineartopointer(linear(blkbuff)+bytesread);
  112.       until bytesread=0;
  113.       close(pcxfile);
  114.  
  115.       vpunuse(pcxbuff);
  116.       LoadPCXFiletoVirtual := pcxbuff;
  117.    end;
  118.  
  119. procedure DisplayPCXFile(pcxbuff:pointer; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  120.    var pal     : palettetype;
  121.        i,j     : word;
  122.        color     : byte;
  123.        mask     : byte;
  124.        pcxcode     : byte;
  125.    begin
  126.       if pcxheader(pcxbuff^).bitsperpixel<>1 then
  127.      exit;
  128.  
  129.       case pcxheader(pcxbuff^).NPlanes of
  130.      1 : egapcx1plane(pcxbuff,baseoffset,maxlines,maxwidth);
  131.      4 : begin
  132. {        if palettechange and
  133.            (pcxheader(pcxbuff^).version <> 3) then }
  134.         if palettechange then
  135.            begin
  136.               for i:= 0 to 15 do
  137.              begin
  138.                 color:= 0;
  139.                 for j:= 0 to 2 do
  140.                    begin
  141.                 { Get primary color value }
  142.                  pcxcode:= pcxheader(pcxbuff^).colormap[i*3+j];
  143.                  case (pcxcode div $40) of
  144.                    0: mask:= $00;    { 000000 }
  145.                    1: mask:= $20;    { 100000 }
  146.                    2: mask:= $04;    { 000100 }
  147.                    3: mask:= $24;    { 100100 }
  148.                  end;
  149.                  color:= color or (mask shr j);   { Define two bits }
  150.                    end;
  151.                 pal.colors[i]:= color;
  152.              end;
  153.               pal.size:= 16;
  154.  
  155.               setallpalette(pal);
  156.            end;
  157.  
  158.         egapcx4plane(pcxbuff,baseoffset,maxlines,maxwidth);
  159.          end;
  160.       end;
  161.    end;
  162.  
  163. procedure DisplayVirtualPCXFile(pcxbuff:virtualptr; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  164.    begin
  165.       vpuse(pcxbuff);
  166.       DisplayPCXFile(pcxbuff^.memoryptr,palettechange,baseoffset,maxlines,maxwidth);
  167.       vpunuse(pcxbuff);
  168.    end;
  169.  
  170. procedure QuickShowPCXFile(pcxfilename:pathstr; palettechange:boolean; baseoffset,maxlines,maxwidth:word);
  171.    var pcxbuff     : virtualptr;
  172.    begin
  173.       pcxbuff := loadPCXFiletoVirtual(pcxfilename);
  174.       displayVirtualPCXFile(pcxbuff,palettechange,baseoffset,maxlines,maxwidth);
  175.       vpfreemem(pcxbuff);
  176.    end;
  177.  
  178. procedure SetPCXBWMap(r,g,b,i : byte);
  179.    begin
  180.       rgbpcxmap[0] := b;
  181.       rgbpcxmap[1] := g;
  182.       rgbpcxmap[2] := r;
  183.       rgbpcxmap[3] := i;
  184.    end;
  185.  
  186. procedure GetPcxHeader(pcxfilename:pathstr; var pcxhead:pcxheader);
  187.    var pcxfile : file;
  188.        retcode : integer;
  189.    begin
  190.       assign(pcxfile,pcxfilename);
  191.       reset(pcxfile,1);
  192.  
  193.       Retcode := IOresult;
  194.       if retcode<>0 then
  195.      aborterror('Unable to find and load PCX Header: '+pcxfilename,retcode);
  196.  
  197.       blockread(pcxfile,pcxhead,sizeof(pcxheader));
  198.       close(pcxfile);
  199.    end;
  200.  
  201. procedure listPCXHeaderInfo(pcxhead:pcxheader);
  202.    var i : integer;
  203.    begin
  204.       writeln('manufacturer : ',hexbyte(pcxhead.manufacturer));
  205.       writeln('version      : ',hexbyte(pcxhead.version));
  206.       writeln('encoding     : ',hexbyte(pcxhead.encoding));
  207.       writeln('bitsperpixel : ',hexbyte(pcxhead.bitsperpixel));
  208.       writeln('xmin,ymin    : ',pcxhead.xmin,',',pcxhead.ymin);
  209.       writeln('xmax,ymax    : ',pcxhead.xmax,',',pcxhead.ymax);
  210.       writeln('HDPI,VDPI    : ',pcxhead.HDPI,',',pcxhead.VDPI);
  211.  
  212.       write('colormap     : ');
  213.       for i:=0 to 16 do
  214.      write(pcxhead.colormap[i],' ');
  215.       writeln;
  216.  
  217.       writeln('reserved     : ',hexbyte(pcxhead.reserved));
  218.       writeln('NPlanes      : ',hexbyte(pcxhead.NPlanes));
  219.       writeln('bytesperline : ',hex(pcxhead.bytesperline));
  220.       writeln('paletteinfo  : ',hex(pcxhead.paletteinfo));
  221.       writeln('HscreenSize  : ',hex(pcxhead.HscreenSize));
  222.       writeln('VscreenSize  : ',hex(pcxhead.VscreenSize));
  223.    end;
  224.  
  225.  
  226. end.
  227.