home *** CD-ROM | disk | FTP | other *** search
/ Intermedia 1998 January / inter1_98.iso / www / rozi / PCX_1.ZIP / SHOW_PCX.PAS next >
Pascal/Delphi Source File  |  1997-01-12  |  17KB  |  544 lines
  1. {$R-}    {Range checking off}
  2. {$B-}    {Boolean complete evaluation off}
  3. {$S-}    {Stack checking off}
  4. {$I+}    {I/O checking on}
  5. {$N-}    {No numeric coprocessor}
  6. program show_pcx;
  7. uses
  8.   Crt, Dos;
  9. const
  10.    MAX_WIDTH = 4000;    { arbitrary - maximum width (in bytes) of a PCX image }
  11.    COMPRESS_NUM = $C0;  { this is the upper two bits that indicate a count }
  12.    MAX_BLOCK = 4096;
  13.  
  14.    RED = 0;
  15.    GREEN = 1;
  16.    BLUE = 2;
  17.  
  18.    CGA4 = $04;          { video modes }
  19.    CGA2 = $06;
  20.    EGA  = $10;
  21.    VGA  = $12;
  22.    MCGA = $13;
  23.  
  24. type
  25.    str80 = string [80];
  26.    file_buffer = array [0..127] of byte;
  27.    block_array = array [0..MAX_BLOCK] of byte;
  28.    pal_array = array [0..255, RED..BLUE] of byte;
  29.    ega_array = array [0..16] of byte;
  30.    line_array = array [0..MAX_WIDTH] of byte;
  31.  
  32.    pcx_header = record
  33.         Manufacturer: byte;     { Always 10 for PCX file }
  34.  
  35.         Version: byte;          { 2 - old PCX - no palette (not used anymore),
  36.                                   3 - no palette,
  37.                                   4 - Microsoft Windows - no palette (only in
  38.                                       old files, new Windows version uses 3),
  39.                                   5 - with palette }
  40.  
  41.         Encoding: byte;         { 1 is PCX, it is possible that we may add
  42.                                   additional encoding methods in the future }
  43.  
  44.         Bits_per_pixel: byte;   { Number of bits to represent a pixel
  45.                                   (per plane) - 1, 2, 4, or 8 }
  46.  
  47.         Xmin: integer;          { Image window dimensions (inclusive) }
  48.         Ymin: integer;          { Xmin, Ymin are usually zero (not always) }
  49.         Xmax: integer;
  50.         Ymax: integer;
  51.  
  52.         Hdpi: integer;          { Resolution of image (dots per inch) }
  53.         Vdpi: integer;          { Set to scanner resolution - 300 is default }
  54.  
  55.         ColorMap: array [0..15, RED..BLUE] of byte;
  56.                                 { RGB palette data (16 colors or less)
  57.                                   256 color palette is appended to end of file }
  58.  
  59.         Reserved: byte;         { (used to contain video mode)
  60.                                   now it is ignored - just set to zero }
  61.  
  62.         Nplanes: byte;          { Number of planes }
  63.  
  64.         Bytes_per_line_per_plane: integer;   { Number of bytes to allocate
  65.                                                for a scanline plane.
  66.                                                MUST be an an EVEN number!
  67.                                                Do NOT calculate from Xmax-Xmin! }
  68.  
  69.         PaletteInfo: integer;   { 1 = black & white or color image,
  70.                                   2 = grayscale image - ignored in PB4, PB4+
  71.                                   palette must also be set to shades of gray! }
  72.  
  73.         HscreenSize: integer;   { added for PC Paintbrush IV Plus ver 1.0,  }
  74.         VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)     }
  75.         Filler: array [74..127] of byte;     { Just set to zeros }
  76.         end;
  77.  
  78. var
  79.    Name: str80;                        { Name of PCX file to load }
  80.    ImageName: str80;                   { Name of PCX file - used by ReadError }
  81.    BlockFile: file;                    { file for reading block data }
  82.    BlockData: block_array;             { 4k data buffer }
  83.  
  84.    Header: pcx_header;                 { PCX file header }
  85.    Palette256: pal_array;              { place to put 256 color palette }
  86.    PaletteEGA: ega_array;              { place to put 17 EGA palette values }
  87.    PCXline: line_array;                { place to put uncompressed data }
  88.  
  89.    Ymax: integer;                      { maximum Y value on screen }
  90.    NextByte: integer;                  { index into file buffer in ReadByte }
  91.    Index: integer;                     { PCXline index - where to put Data }
  92.    Data: byte;                         { PCX compressed data byte }
  93.  
  94.    PictureMode: integer;               { Graphics mode number }
  95.    Reg: Registers;                     { Register set - used for int 10 calls }
  96. { ================================= Error ================================== }
  97. procedure Error (s: str80 );
  98. { Print out the error message and wait, then halt }
  99. var c: char;
  100.     i: integer;
  101.  
  102. begin
  103. TextMode (C80);
  104. writeln ('ERROR');
  105. writeln (s);
  106. halt;
  107. end;   { Error }
  108. procedure ReadError (msg: integer);
  109. begin
  110. if IOresult <> 0 then
  111.    case msg of
  112.    1: Error ('Can''t open file - ' + ImageName);
  113.    2: Error ('Error closing file - ' + ImageName + ' - disk may be full');
  114.    3: Error ('Error reading file - ' + ImageName);
  115.  
  116.    else
  117.       Error ('Error doing file I/O - ' + ImageName);
  118.    end;   { case }
  119. end;   { ReadError }
  120. procedure VideoMode (n: integer);
  121. begin
  122. Reg.ah := $00;
  123. Reg.al := n;                         { mode number }
  124. intr ($10, Reg);                     { call interrupt }
  125. end;  { VideoMode }
  126. procedure EGApalette (n, R, G, B: integer);
  127. var i: integer;
  128.  
  129. begin
  130. R := R shr 6;                        { R, G, and B are now 0..3 }
  131. G := G shr 6;
  132. B := B shr 6;
  133. i := (R shl 4) + (G shl 2) + B;
  134.  
  135. Reg.ah := $10;
  136. Reg.al := 0;                         { set individual palette register }
  137. Reg.bh := i;                         { value }
  138. Reg.bl := n;                         { palette register number }
  139. intr ($10, Reg);                     { call interrupt }
  140. end;  { EGApalette }
  141. procedure VGApalette (n, R, G, B: integer);
  142. begin
  143. R := R shr 2;                        { R, G, and B are now 0..63 }
  144. G := G shr 2;
  145. B := B shr 2;
  146.  
  147. Reg.ah := $10;                       { Set Palette Call }
  148. Reg.al := $0;                        { set individual palette register }
  149. Reg.bl := n;                         { palette register number 0..15, 0..255 }
  150. Reg.bh := n;                         { palette register value }
  151. intr ($10, Reg);                     { call interrupt }
  152.  
  153. Reg.ah := $10;                       { Set DAC Call }
  154. Reg.al := $10;                       { set individual DAC register }
  155. Reg.bx := n;                         { DAC register number 0..15, 0..255 }
  156. Reg.dh := R;                         { red value 0..63 }
  157. Reg.ch := G;                         { green value 0..63 }
  158. Reg.cl := B;                         { blue value 0..63 }
  159. intr ($10, Reg);                     { call interrupt }
  160. end;  { VGApalette }
  161. procedure EGA16palette;
  162. var
  163.    i, r, g, b: integer;
  164.  
  165. begin
  166. for i := 0 to 15 do
  167.    begin
  168.    r := Header.ColorMap [i, RED]   shr 6;       { r, g, and b are now 0..3 }
  169.    g := Header.ColorMap [i, GREEN] shr 6;
  170.    b := Header.ColorMap [i, BLUE]  shr 6;
  171.    PaletteEGA [i] := (r shl 4) + (g shl 2) + b;
  172.    end;
  173. PaletteEGA [16] := 0;                { border color }
  174.  
  175. Reg.ah := $10;                       { Set Palette Call }
  176. Reg.al := $02;                       { set a block of palette registers }
  177. Reg.dx := ofs (PaletteEGA);          { offset of block }
  178. Reg.es := seg (PaletteEGA);          { segment of block }
  179. intr ($10, Reg);                     { call interrupt }
  180.  
  181. end;  { EGA16palette }
  182. procedure VGA16palette;
  183. var
  184.    i: integer;
  185.  
  186. begin
  187. for i := 0 to 15 do
  188.    PaletteEGA [i] := i;
  189. PaletteEGA [16] := 0;                { border color }
  190.  
  191. Reg.ah := $10;                       { Set Palette Call }
  192. Reg.al := $02;                       { set a block of palette registers }
  193. Reg.dx := ofs (PaletteEGA);          { offset of block }
  194. Reg.es := seg (PaletteEGA);          { segment of block }
  195. intr ($10, Reg);                     { call interrupt }
  196.  
  197. for i := 0 to 15 do
  198.    begin                                          { R, G, and B must be 0..63 }
  199.    Palette256 [i, RED]   := Header.ColorMap [i, RED]   shr 2;
  200.    Palette256 [i, GREEN] := Header.ColorMap [i, GREEN] shr 2;
  201.    Palette256 [i, BLUE]  := Header.ColorMap [i, BLUE]  shr 2;
  202.    end;
  203.  
  204. Reg.ah := $10;                       { Set DAC Call }
  205. Reg.al := $12;                       { set a block of DAC registers }
  206. Reg.bx := 0;                         { first DAC register number }
  207. Reg.cx := 255;                       { number of registers to update }
  208. Reg.dx := ofs (Palette256);          { offset of block }
  209. Reg.es := seg (Palette256);          { segment of block }
  210. intr ($10, Reg);                     { call interrupt }
  211.  
  212. end;  { VGA16palette }
  213. procedure EntireVGApalette;
  214. var
  215.    i: integer;
  216.  
  217. begin
  218. for i := 0 to 255 do
  219.    begin                                          { R, G, and B must be 0..63 }
  220.    Palette256 [i, RED]   := Palette256 [i, RED]   shr 2;
  221.    Palette256 [i, GREEN] := Palette256 [i, GREEN] shr 2;
  222.    Palette256 [i, BLUE]  := Palette256 [i, BLUE]  shr 2;
  223.    end;
  224.  
  225. Reg.ah := $10;                       { Set DAC Call }
  226. Reg.al := $12;                       { set a block of DAC registers }
  227. Reg.bx := 0;                         { first DAC register number }
  228. Reg.cx := 255;                       { number of registers to update }
  229. Reg.dx := ofs (Palette256);          { offset of block }
  230. Reg.es := seg (Palette256);          { segment of block }
  231. intr ($10, Reg);                     { call interrupt }
  232.  
  233. end;  { EntireVGApalette }
  234. procedure SetPalette;
  235. var i: integer;
  236.  
  237. begin
  238. if PictureMode = MCGA then
  239.    EntireVGApalette
  240. else if PictureMode = VGA then
  241.    VGA16palette
  242. else
  243.    EGA16palette;
  244. end;  { SetPalette }
  245. procedure ShowCGA (Y: integer);
  246. var
  247.    i, j, l, m, t: integer;
  248.    Yoffset: integer;
  249.    CGAScreen: array [0..32000] of byte absolute $B800:$0000;
  250.  
  251. begin
  252. i := 8 div Header.Bits_per_pixel;        { i is pixels per byte }
  253.  
  254. if (i = 8) then                          { 1 bit per pixel }
  255.    j := 7
  256. else                                     { 2 bits per pixel }
  257.    j := 3;
  258.  
  259. t := (Header.Xmax - Header.Xmin + 1);    { width in pixels }
  260. m := t and j;                            { left over bits }
  261.  
  262. l := (t + j) div i;                      { compute number of bytes to display }
  263. if l > 80 then
  264.    begin
  265.    l := 80;                              { don't overrun screen width }
  266.    m := 0;
  267.    end;
  268.  
  269. if (m <> 0) then                         { we need to mask unseen pixels }
  270.    begin
  271.    m := $FF shl (8 - (m * Header.Bits_per_pixel));   { m = mask }
  272.    t := l - 1;
  273.    PCXline [t] := PCXline [t] and m;     { mask off unseen pixels }
  274.    end;
  275.  
  276. Yoffset := 8192 * (Y and 1);
  277. Move (PCXline [0], CGAScreen [((Y shr 1) * 80) + Yoffset], l);
  278.  
  279. end;   { ShowCGA }
  280. procedure ShowEGA (Y: integer);
  281. var
  282.    i, j, l, m, t: integer;
  283.    EGAplane: integer;
  284.    EGAscreen: array [0..32000] of byte absolute $A000:$0000;
  285.  
  286. begin
  287. EGAplane := $0100;                       { the first plane to update }
  288. PortW [$3CE] := $0005;                   { use write mode 0 }
  289. t := (Header.Xmax - Header.Xmin + 1);    { width in pixels }
  290. m := t and 7;                            { left over bits }
  291.  
  292. l := (t + 7) shr 3;                      { compute number of bytes to display }
  293. if (l >= 80) then
  294.    begin
  295.    l := 80;                              { don't overrun screen width }
  296.    m := 0;
  297.    end;
  298.  
  299. if (m <> 0) then
  300.    m := $FF shl (8 - m)                  { m = mask for unseen pixels }
  301. else
  302.    m := $FF;
  303.  
  304. for i := 0 to Header.Nplanes-1 do
  305.    begin
  306.    j := i * Header.Bytes_per_line_per_plane;
  307.    t := j + l - 1;
  308.    PCXline [t] := PCXline [t] and m;           { mask off unseen pixels }
  309.  
  310.    PortW [$3C4] := EGAplane + 2;               { set plane number }
  311.    Move (PCXline [j], EGAscreen [Y * 80], l);
  312.    EGAplane := EGAplane shl 1;
  313.    end;
  314.  
  315. PortW [$3C4] := $0F02;                         { default plane mask }
  316. end;   { ShowEGA }
  317. procedure ShowMCGA (Y: integer);
  318. var
  319.    l: integer;
  320.    MCGAscreen: array [0..64000] of byte absolute $A000:$0000;
  321.  
  322. begin
  323. l := Header.XMax - Header.Xmin;            { compute number of bytes to display }
  324. if l > 320 then
  325.    l := 320;                               { don't overrun screen width }
  326.  
  327. Move (PCXline [0], MCGAScreen [Y * 320], l);
  328.  
  329. end;   { ShowMCGA }
  330. procedure Read256palette;
  331. var
  332.    i: integer;
  333.    b: byte;
  334.  
  335. begin
  336. seek (BlockFile, FileSize (BlockFile) - 769);
  337. BlockRead (BlockFile, b, 1);           { read indicator byte }
  338. ReadError (3);
  339.  
  340. if b <> 12 then                        { no palette here... }
  341.    exit;
  342.  
  343. BlockRead (BlockFile, Palette256, 3*256);
  344. ReadError (3);
  345.  
  346. seek (BlockFile, 128);                 { go back to start of PCX data }
  347.  
  348. end;  { Read256palette }
  349. procedure ReadHeader;
  350. label WrongFormat;
  351.  
  352. begin
  353. {$I-}
  354. BlockRead (BlockFile, Header, 128);         { read 128 byte PCX header }
  355. ReadError (3);
  356.                                             if (Header.Manufacturer <> 10) or (Header.Encoding <> 1) then
  357.    begin
  358.    close (BlockFile);
  359.    Error ('This is not a valid PCX image file.');
  360.    end;
  361.  
  362. if (Header.Nplanes = 4) and (Header.Bits_per_pixel = 1) then
  363.    begin
  364.    if (Header.Ymax - Header.Ymin) <= 349 then
  365.       begin
  366.       PictureMode := EGA;
  367.       Ymax := 349;
  368.       end
  369.    else
  370.       begin
  371.       PictureMode := VGA;
  372.       Ymax := 479;
  373.       end;
  374.    end
  375. else if (Header.Nplanes = 1) then
  376.    begin
  377.    Ymax := 199;
  378.  
  379.    if (Header.Bits_per_pixel = 1) then
  380.       PictureMode := CGA2
  381.    else if (Header.Bits_per_pixel = 2) then
  382.       PictureMode := CGA4
  383.    else if (Header.Bits_per_pixel = 8) then
  384.       begin
  385.       PictureMode := MCGA;
  386.       if Header.Version = 5 then
  387.          Read256palette;
  388.       end
  389.    else
  390.       goto WrongFormat;
  391.    end
  392. else
  393.    begin
  394. WrongFormat:
  395.    close (BlockFile);
  396.    Error ('PCX file is in wrong format - It must be a CGA, EGA, VGA, or MCGA image');
  397.    end;
  398.  
  399. Index := 0;
  400. NextByte := MAX_BLOCK;          { indicates no data read in yet... }
  401.  
  402. end;  { ReadHeader }
  403. procedure ReadByte;
  404. var
  405.    NumBlocksRead: integer;
  406.  
  407. begin
  408. if NextByte = MAX_BLOCK then
  409.    begin
  410.    BlockRead (BlockFile, BlockData, MAX_BLOCK, NumBlocksRead);
  411.    NextByte := 0;
  412.    end;
  413.  
  414. data := BlockData [NextByte];
  415. inc (NextByte);                         { NextByte++; }
  416. end;  { ReadByte }
  417. procedure Read_PCX_Line;
  418. var
  419.    count: integer;
  420.    bytes_per_line: integer;
  421.  
  422. begin
  423. {$I-}
  424.  
  425. bytes_per_line := Header.Bytes_per_line_per_plane * Header.Nplanes;
  426.  
  427.                           { bring in any data that wrapped from previous line }
  428.                           { usually none  -  this is just to be safe          }
  429. if Index <> 0 then
  430.    FillChar (PCXline [0], Index, data);    { fills a contiguous block of data }
  431.  
  432. while (Index < bytes_per_line) do          { read 1 line of data (all planes) }
  433.    begin
  434.    ReadByte;
  435.  
  436.    if (data and $C0) = compress_num then
  437.       begin
  438.       count := data and $3F;
  439.       ReadByte;
  440.       FillChar (PCXline [Index], count, data);  { fills a contiguous block }
  441.       inc (Index, count);                       { Index += count; }
  442.       end
  443.    else
  444.       begin
  445.       PCXline [Index] := data;
  446.       inc (Index);                              { Index++; }
  447.       end;
  448.    end;
  449.  
  450. ReadError (3);
  451.  
  452. Index := Index - bytes_per_line;
  453.  
  454. {$I+}
  455. end;  { Read_PCX_Line }
  456. procedure Read_PCX (name: str80);
  457. var
  458.    k, kmax: integer;
  459.  
  460. begin
  461. {$I-}
  462. ImageName := name;                     { used by ReadError }
  463.  
  464. assign (BlockFile, name);
  465. reset (BlockFile, 1);                  { use 1 byte blocks }
  466. ReadError (1);
  467.  
  468. ReadHeader;                            { read the PCX header }
  469. VideoMode (PictureMode);               { switch to graphics mode }
  470. if Header.Version = 5 then
  471.    SetPalette;                         { set the screen palette, if available }
  472. kmax := Header.Ymin + Ymax;
  473. if Header.Ymax < kmax then        { don't show more than the screen can display }
  474.    kmax := Header.ymax;
  475.  
  476. if (PictureMode = EGA) or (PictureMode = VGA) then
  477.    begin
  478.    for k := Header.Ymin to kmax do          { each loop is separate for speed }
  479.       begin
  480.       Read_PCX_Line;
  481.       ShowEGA (k);
  482.       end;
  483.    end
  484. else if (PictureMode = MCGA) then
  485.    begin
  486.    for k := Header.Ymin to kmax do
  487.       begin
  488.       Read_PCX_Line;
  489.       ShowMCGA (k);
  490.       end;
  491.    end
  492. else                                         { it's a CGA picture }
  493.    begin
  494.    for k := Header.Ymin to kmax do
  495.       begin
  496.       Read_PCX_Line;
  497.       ShowCGA (k);
  498.       end;
  499.     end;
  500.  
  501. close (BlockFile);
  502. ReadError (2);
  503. {$I+}
  504. end;  { Read_PCX }
  505. procedure display_pcx (name: str80);
  506. var
  507.    c: char;
  508.  
  509. begin
  510. Read_PCX (name);              { read and display the file }
  511.  
  512. while (not KeyPressed) do     { wait for any key to be pressed }
  513.    { nothing };
  514.  
  515. c := ReadKey;                 { now get rid of the key that was pressed }
  516. if c = #0 then                { handle function keys }
  517.    c := ReadKey;
  518.  
  519. end;   { display_pcx }
  520.  
  521. begin
  522. ClrScr;
  523.  
  524. if (ParamCount = 0) then           { no DOS command line parameters }
  525.    begin
  526.    writeln ('The image must be a 2 or 4 color CGA, 16 color EGA or VGA,');
  527.    writeln ('or a 256 color MCGA picture');
  528.    writeln;
  529.  
  530.    write ('Enter name of picture file to display: ');
  531.    readln (name);
  532.    writeln;
  533.    end
  534. else
  535.    Name := ParamStr (1);           { get filename from DOS command line }
  536.  
  537. if (Pos ('.', Name) = 0) then      { make sure the filename has PCX extension }
  538.    Name := Concat (Name, '.pcx');
  539.  
  540. display_pcx (Name);
  541.  
  542. TextMode (co80);                   { back to text mode }
  543.  
  544. end.