home *** CD-ROM | disk | FTP | other *** search
/ Intermedia 1998 January / inter1_98.iso / www / rozi / PCX_W.ZIP / PCX_W.PAS next >
Pascal/Delphi Source File  |  1997-01-21  |  9KB  |  254 lines
  1. {$R-}
  2. unit PCX_W;
  3. interface
  4. type Str80 = string [80];
  5. procedure Write_PCX  (Name:Str80);
  6. implementation
  7. uses Graph;
  8. procedure Write_PCX (Name:Str80);
  9. const
  10.      RED1   = 0;
  11.      GREEN1 = 1;
  12.      BLUE1  = 2;
  13. type
  14.     ArrayPal   = array [0..15, RED1..BLUE1] of byte;
  15. const
  16.      MAX_WIDTH  = 4000;    { arbitrary - maximum width (in bytes) of
  17.                              a PCX image }
  18.      INTENSTART =   $5;
  19.      BLUESTART  =  $55;
  20.      GREENSTART =  $A5;
  21.      REDSTART   =  $F5;
  22.  
  23. type
  24.     Pcx_Header = record
  25.         Manufacturer: byte;     { Always 10 for PCX file }
  26.         Version: byte;          { 2 - old PCX - no palette (not used
  27.                                       anymore),
  28.                                   3 - no palette,
  29.                                   4 - Microsoft Windows - no palette
  30.                                       (only in old files, new Windows
  31.                                       version uses 3),
  32.                                   5 - with palette }
  33.         Encoding: byte;         { 1 is PCX, it is possible that we may
  34.                                   add additional encoding methods in the
  35.                                   future }
  36.         Bits_per_pixel: byte;   { Number of bits to represent a pixel
  37.                                   (per plane) - 1, 2, 4, or 8 }
  38.         Xmin: integer;          { Image window dimensions (inclusive) }
  39.         Ymin: integer;          { Xmin, Ymin are usually zero (not always)}
  40.         Xmax: integer;
  41.         Ymax: integer;
  42.         Hdpi: integer;          { Resolution of image (dots per inch) }
  43.         Vdpi: integer;          { Set to scanner resolution - 300 is
  44.                                   default }
  45.         ColorMap: ArrayPal;
  46.                                 { RGB palette data (16 colors or less)
  47.                                   256 color palette is appended to end
  48.                                   of file }
  49.         Reserved: byte;         { (used to contain video mode)
  50.                                   now it is ignored - just set to zero }
  51.         Nplanes: byte;          { Number of planes }
  52.         Bytes_per_line_per_plane: integer;   { Number of bytes to
  53.                                                allocate for a scanline
  54.                                                plane. MUST be an an EVEN
  55.                                                number! Do NOT calculate
  56.                                                from Xmax-Xmin! }
  57.         PaletteInfo: integer;   { 1 = black & white or color image,
  58.                                   2 = grayscale image - ignored in PB4,
  59.                                       PB4+ palette must also be set to
  60.                                       shades of gray! }
  61.         HscreenSize: integer;   { added for PC Paintbrush IV Plus
  62.                                   ver 1.0,  }
  63.         VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)}
  64.                                 { I know it is tempting to use these
  65.                                   fields to determine what video mode
  66.                                   should be used to display the image
  67.                                   - but it is NOT recommended since the
  68.                                   fields will probably just contain
  69.                                   garbage. It is better to have the
  70.                                   user install for the graphics mode he
  71.                                   wants to use... }
  72.         Filler: array [74..127] of byte;     { Just set to zeros }
  73.     end;
  74.     Array80    = array [1..80]        of byte;
  75.     ArrayLnImg = array [1..326]       of byte; { 6 extra bytes at
  76.      beginng of line that BGI uses for size info}
  77.     Line_Array = array [0..MAX_WIDTH] of byte;
  78.     ArrayLnPCX = array [1..4]         of Array80;
  79. var
  80.    PCXName   : File;
  81.    Header    : Pcx_Header;                 { PCX file header }
  82.    ImgLn     : ArrayLnImg;
  83.    PCXLn     : ArrayLnPCX;
  84.    RedLn,
  85.    BlueLn,
  86.    GreenLn,
  87.    IntenLn   : Array80;
  88.    Img       : pointer;
  89. procedure BuildHeader;
  90. const
  91.      PALETTEMAP: ArrayPal=
  92.                  {  R    G    B                    }
  93.                 (($00, $00, $00),  {  black        }
  94.                  ($00, $00, $AA),  {  blue         }
  95.                  ($00, $AA, $00),  {  green        }
  96.                  ($00, $AA, $AA),  {  cyan         }
  97.                  ($AA, $00, $00),  {  red          }
  98.                  ($AA, $00, $AA),  {  magenta      }
  99.                  ($AA, $55, $00),  {  brown        }
  100.                  ($AA, $AA, $AA),  {  lightgray    }
  101.                  ($55, $55, $55),  {  darkgray     }
  102.                  ($55, $55, $FF),  {  lightblue    }
  103.                  ($55, $FF, $55),  {  lightgreen   }
  104.                  ($55, $FF, $FF),  {  lightcyan    }
  105.                  ($FF, $55, $55),  {  lightred     }
  106.                  ($FF, $55, $FF),  {  lightmagenta }
  107.                  ($FF, $FF, $55),  {  yellow       }
  108.                  ($FF, $FF, $FF) );{  white        }
  109. var
  110.    i : word;
  111. begin
  112.      with Header do
  113.           begin
  114.                Manufacturer  := 10;
  115.                Version  := 5;
  116.                Encoding := 1;
  117.                Bits_per_pixel := 1;
  118.                Xmin := 0;
  119.                Ymin := 0;
  120.                Xmax := 639;
  121.                Ymax := 479;
  122.                Hdpi := 640;
  123.                Vdpi := 480;
  124.                ColorMap := PALETTEMAP;
  125.                Reserved := 0;
  126.                Nplanes  := 4; { Red, Green, Blue, Intensity }
  127.                Bytes_per_line_per_plane := 80;
  128.                PaletteInfo := 1;
  129.                HscreenSize := 0;
  130.                VscreenSize := 0;
  131.                for i := 74 to 127 do
  132.                    Filler [i] := 0;
  133.           end;
  134. end;
  135. procedure GetBGIPlane (Start:word; var Plane:Array80);
  136.  
  137. var
  138.    i : word;
  139.  
  140. begin
  141.      for i:= 1 to Header.Bytes_per_line_per_plane do
  142.          Plane [i] := ImgLn [Start +i -1]
  143. end;
  144. procedure BuildPCXPlane (Start:word; Plane:Array80);
  145.  
  146. var
  147.    i : word;
  148.  
  149. begin
  150.      for i := 1 to Header.Bytes_per_line_per_plane do
  151.          PCXLn [Start] [i] := Plane [i];
  152. end;
  153. procedure EncPCXLine (PlaneLine : word); { Encode a PCX line }
  154.  
  155. var
  156.    This,
  157.    Last,
  158.    RunCount : byte;
  159.    i,
  160.    j        : word;
  161.   procedure EncPut (Byt, Cnt :byte);
  162.  
  163.   const
  164.        COMPRESS_NUM = $C0;  { this is the upper two bits that
  165.                               indicate a count }
  166.   var
  167.      Holder : byte;
  168.   begin
  169.   {$I-}
  170.        if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) then
  171.           blockwrite (PCXName, Byt,1)          { single occurance }
  172.        else
  173.            begin
  174.                 Holder := (COMPRESS_NUM or Cnt);
  175.                 blockwrite (PCXName, Holder, 1); { number of times the
  176.                                                    following color
  177.                                                    occurs }
  178.                 blockwrite (PCXName, Byt, 1);
  179.            end;
  180.   {$I+}
  181.   end;
  182. begin
  183.      i := 1;         { used in PCXLn }
  184.      RunCount := 1;
  185.      Last := PCXLn [PlaneLine][i];
  186.      for j := 1 to Header.Bytes_per_line_per_plane -1 do
  187.          begin
  188.               inc (i);
  189.               This := PCXLn [PlaneLine][i];
  190.               if This = Last then
  191.                  begin
  192.                       inc (RunCount);
  193.                       if RunCount = 63 then   { reached PCX run length
  194.                                                 limited max yet? }
  195.                          begin
  196.                               EncPut (Last, RunCount);
  197.                               RunCount := 0;
  198.                          end;
  199.                  end
  200.               else
  201.                   begin
  202.                        if RunCount >= 1 then
  203.                           Encput (Last, RunCount);
  204.                        Last := This;
  205.                        RunCount := 1;
  206.                   end;
  207.          end;
  208.      if RunCount >= 1 then  { any left over ? }
  209.         Encput (Last, RunCount);
  210. end;
  211. const
  212.      XMAX = 639;
  213.      YMAX = 479;
  214.  
  215. var
  216.    i, j, Size : word;
  217.  
  218. begin
  219.      BuildHeader;
  220.      assign     (PCXName,Name);
  221. {$I-}
  222.      rewrite    (PCXName,1);
  223.      blockwrite (PCXName,Header,sizeof (Header));
  224.      {good place for file error handler!}
  225. {$I+}
  226.      setviewport (0,0,XMAX,YMAX, ClipOn);
  227.      Size := imagesize (0,0,XMAX,0); { size of a single row }
  228.      getmem (Img,Size);
  229.  
  230.      for i := 0 to YMAX do
  231.          begin
  232.               getimage (0,i,XMAX,i,Img^);  { Grab 1 line from the
  233.                                              screen store in Img
  234.                                              buffer  }
  235.               move (Img^,ImgLn,Size {326});
  236.               GetBGIPlane (INTENSTART, IntenLn);
  237.               GetBGIPlane (BLUESTART,  BlueLn );
  238.               GetBGIPlane (GREENSTART, GreenLn);
  239.               GetBGIPlane (REDSTART,   RedLn  );
  240.               BuildPCXPlane (1, RedLn  );
  241.               BuildPCXPlane (2, GreenLn);
  242.               BuildPCXPlane (3, BlueLn );
  243.               BuildPCXPlane (4, IntenLn); { 320 bytes/line
  244.                                             uncompressed }
  245.               for j := 1 to Header.NPlanes do
  246.  
  247.                   EncPCXLine (j);
  248.          end;
  249.      freemem (Img,Size);           (* Release the memory        *)
  250. {$I-}
  251.      close (PCXName);              (* Save the Image            *)
  252. {$I+}
  253. end;
  254. end.