(* PCX.PAS -- create .PCX files
** Copyright (c) 1995,1996 Jochen Metzinger
**
** This program is free software; you can redistribute it and/or modify
** it under the terms of the GNU General Public License as published by
** the Free Software Foundation; either version 2, or (at your option)
** any later version.
**
** This program is distributed in the hope that it will be useful,
** but WITHOUT ANY WARRANTY; without even the implied warranty of
** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
** GNU General Public License for more details.
**
** You should have received a copy of the GNU General Public License
** along with this program; if not, write to the Free Software
** Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

UNIT PCX;

INTERFACE

USES Crt,
 global, graphic;

CONST
 PCX_BUFFER_SIZE = 8*512;

PROCEDURE pcx_open(filename: STRING; p: ColorPal; width: WORD);
(* open file *)
PROCEDURE pcx_close;
(* close file *)
PROCEDURE pcx_image(VAR BitMap);
(* add image to pcx file (has to be from VGAHi) *)

IMPLEMENTATION

TYPE
 PCX_HEADER = RECORD
  id, ver, comp, bits: BYTE;
  x1, y1, x2, y2, ax, ay: INTEGER;
  pal: ARRAY [0..47] OF BYTE;
  __r1: BYTE;
  ebene: BYTE;
  bz, pal2: INTEGER;
  __r2: ARRAY [0..57] OF BYTE;
 END; (* PCX_HEADER *)

 PCX_BUFFER =
   ARRAY [0..PCX_BUFFER_SIZE] OF BYTE;

 BitMapType = RECORD
  width, height: WORD;
  data: ARRAY [0..$FFF0] OF BYTE; (* (height+1) times line <H,R,G,B> *)
 END;

VAR
 header: PCX_HEADER;
 pcx_file: FILE;
 LineWidth: WORD;
 BufPtr: ^PCX_BUFFER;
 BufLen: WORD;

PROCEDURE pcx_open(filename: STRING; p: ColorPal; width: WORD);
BEGIN
 IF width = 0 THEN G_FATAL('no width for pcx file');
 WITH header DO BEGIN
  id := 10; ver := 2; comp := 1; bits := 1;
  x1 := 0; y1 := 0; x2 := width-1; y2 := -1; ax := 0; ay := 0;
  GetColorPalette(p, pal);
  __r1 := 0;
  ebene := 4; bz := (width+7) DIV 8;
  pal2 := 1;
  FillChar(__r2, SizeOf(__r2), 0);
  LineWidth := ebene * bz;
 END; (* with *)
 filename := AddExt(filename,'.PCX');
 (*$I-*)
 Assign(pcx_file, filename);
 ReWrite(pcx_file,1);
 IF IOResult <> 0 THEN G_FATAL('unable to create file '+filename);
 (*$I+*)
 New(BufPtr);
 BufLen := SizeOf(header);
 Move(header, BufPtr^[0], BufLen);
END; (* pcx_open *)

PROCEDURE pcx_flush;
 VAR res: WORD;
BEGIN
 IF BufLen = 0 THEN EXIT;
 BlockWrite(pcx_file, BufPtr^[0], BufLen, res);
 IF res <> BufLen THEN G_FATAL('WRITE ERROR');
 BufLen := 0;
END; (* pcx_flush *)

PROCEDURE pcx_byte(b: BYTE);
BEGIN
 IF BufLen >= PCX_BUFFER_SIZE THEN pcx_flush;
 BufPtr^[BufLen] := b;
 INC(BufLen);
END; (* pcx_byte *)

PROCEDURE pcx_close;
BEGIN
 IF BufPtr = NIL THEN
  G_FATAL('pcx_image: file not open');
 pcx_flush;
 Seek(pcx_file,0);
 BlockWrite(pcx_file, header, SizeOf(header));
 Close(pcx_file);
 Dispose(BufPtr);
 BufPtr := NIL;
END; (* pcx_close *)

PROCEDURE pcx_image(VAR BitMap);
 VAR bm: BitMapType ABSOLUTE BitMap;
  y: INTEGER;
  cnt, dat: BYTE;
  (* counter/value for AddLine *)

 PROCEDURE AddLine(VAR l);
  VAR ln: ARRAY [0..$FFF0] OF BYTE ABSOLUTE l;
   i: INTEGER;
 BEGIN
  FOR i := 0 TO header.bz-1 DO
   IF cnt = 0 THEN
    BEGIN (* empty *)
     cnt := 1;
     dat := ln[i];
    END
   ELSE IF dat = ln[i] THEN
    BEGIN (* repeat *)
     IF cnt >= 63 THEN
      BEGIN
       pcx_byte($FF);
       pcx_byte(dat);
       DEC(cnt,63);
      END; (* if *)
     INC(cnt)
    END
   ELSE (* dat <> ln[i] *)
    BEGIN (* new bytes *)
     IF (cnt > 1) OR (dat >= $C0) THEN
      pcx_byte($C0+cnt);
     pcx_byte(dat);
     cnt := 1;
     dat := ln[i];
    END; (* else *)
 END; (* AddLine *)

BEGIN (* pcx_image *)
 IF BufPtr = NIL THEN
  G_FATAL('pcx_image: file not open');
 IF bm.width <> header.x2 THEN
  G_FATAL('pcx_image: wrong widths');
 FOR y := 0 TO bm.height DO BEGIN
  cnt := 0;
  AddLine(bm.data[header.bz*(4*y+3)]); (* 2^0 blue *)
  AddLine(bm.data[header.bz*(4*y+2)]); (* 2^1 green *)
  AddLine(bm.data[header.bz*(4*y+1)]); (* 2^2 red *)
  AddLine(bm.data[header.bz*(4*y+0)]); (* 2^3 intensity *)
  IF (cnt > 1) OR (dat >= $C0) THEN
   pcx_byte($C0+cnt);
  pcx_byte(dat);
  INC(header.y2);
 END; (* for *)
END; (* pcx_image *)

BEGIN
 BufPtr := NIL;
 BufLen := 0;
END. (* PCX *)