home *** CD-ROM | disk | FTP | other *** search
- (* ------------------------------------------------------ *)
- (* PCXTOOLS.PAS *)
- (* ------------------------------------------------------ *)
- {$R-,S-,I-,V-,B-,N-,D-}
- UNIT PCXTools;
-
- INTERFACE USES Dos;
-
- CONST
- ActivePage : WORD = 0;
-
- VAR
- Xmin, Xmax, Ymin, Ymax : WORD;
-
- FUNCTION BGItoPCX(gd, gm : INTEGER;
- name : STRING) : INTEGER;
-
- TYPE
- PlaneType = ARRAY[0..767] OF BYTE;
- plane = ^Planetype;
- ScanLine = ARRAY[0..3] OF plane;
-
- VAR
- z : ScanLine;
-
- TYPE
- PCX_HEADER = RECORD
- Creator : BYTE; { Immer 10 für ZSoft }
- Version : BYTE; { PCX-Version: }
- { 0 = Version 2.5 o. Palette }
- { 2 = Version 2.8 m. Palette }
- { oder Version 3.0 o. Pal.}
- { 3 = Version 2.8/3.0 o. Pal.}
- { 5 = Version 3.0 mit Pal. }
- Encoding : BYTE;
- { 1 = Run-Length-Encoded }
- Bits : BYTE; { Pixel pro Bit }
- { für CGA 320x200 2 Bits, }
- xmin, ymin,
- xmax, ymax : INTEGER;
- Hres, VRes : INTEGER;
- Palette : ARRAY[0..15, 0..2] OF BYTE;
- VMode : BYTE; { Reserviert }
- Planes : BYTE; { Farbebenen }
- BytePerLine: INTEGER; { Bytes/Scanzeile }
- PaletteInfo: INTEGER;
- { 1 = Farbe/Schwarz-Weiß }
- { 2 = Grauwerte }
- dummy : ARRAY[0..57] OF BYTE;
- END;
-
- PROCEDURE SetReadPlane(Nr : BYTE);
- PROCEDURE SetWritePlane(Nr : BYTE);
- PROCEDURE SetEgaReg(Nr, wert : BYTE);
- FUNCTION GetPCXHeader(VAR PCXH : PCX_Header;
- name : STRING) : INTEGER;
- FUNCTION WritePCXHeader(VAR PCXH : PCX_Header;
- name : STRING) : INTEGER;
- FUNCTION GetPcxByte(VAR F : FILE) : BYTE;
- FUNCTION writePCXByte(VAR F : FILE; wert, count : BYTE)
- : INTEGER;
- FUNCTION WritePCXLine(VAR F : FILE;
- VAR buf : plane;
- count : BYTE) : INTEGER;
- PROCEDURE DefPCXPalette(VAR PCXH : PCX_Header;
- ColType : BYTE);
-
- IMPLEMENTATION
-
- CONST
- HercBase = $B000;
- EgaBase = $A000;
- CgaBase = $B800;
- BLOCKSIZE : WORD = 512;
- PCXDefaultPalette : ARRAY[0..15, 0..2] OF BYTE =
- ((0, 0, 0), (0, 0, 170), (0, 170, 0), (0, 170, 170),
- (170, 0, 0), (170, 0, 170), (170, 170, 0),
- (170, 170, 170),
- (85, 85, 85), (85, 85, 255), (85, 255, 85),
- (85, 255, 255),
- (255, 85, 85), (255, 85, 255), (255, 255, 85),
- (255, 255, 255));
- VAR
- PCXbuf : ARRAY[1..512] OF BYTE;
- I, J : WORD;
- SPtr : POINTER;
- PCXH : PCX_Header;
-
- PROCEDURE SetReadPlane(Nr : BYTE);
- BEGIN
- Port[$3CE] := 4;
- Port[$3CF] := Nr;
- END;
-
- PROCEDURE SetWritePlane(Nr : BYTE);
- BEGIN
- Port[$3C4] := 2;
- Port[$3C5] := 1 SHL Nr;
- END;
-
- PROCEDURE SetEgaReg(Nr, wert : BYTE);
- BEGIN
- Port[$3CE] := Nr;
- Port[$3CF] := wert;
- END;
-
- FUNCTION GetPCXHeader(VAR PCXH : PCX_Header;
- name : STRING) : INTEGER;
- VAR
- F : FILE;
- BEGIN
- FillChar(PCXH, 128, 0);
- Assign(F, name);
- Reset(F, 1);
- DOSError := IOResult;
- IF DOSError <> 0 THEN BEGIN
- GetPCXHeader := DOSError;
- Exit;
- END;
- BlockRead(F, PCXH, 128);
- DOSError := IOResult;
- IF DOSError <> 0 THEN BEGIN
- GetPCXHeader := DOSError;
- Close(F);
- Exit;
- END;
- Close(F);
- GetPCXHeader := IOResult;
- IF (PCXH.version > 5) OR (PCXH.encoding > 1) THEN
- GetPCXHeader := -1;
- END;
-
- FUNCTION WritePCXHeader(VAR PCXH : PCX_Header;
- name : STRING) : INTEGER;
- VAR
- F : FILE;
- BEGIN
- Assign(F, name);
- Rewrite(F, 1);
- DOSError := IOResult;
- IF DOSError <> 0 THEN BEGIN
- WritePCXHeader := DOSError;
- Exit;
- END;
- BlockWrite(F, PCXH, 128);
- DOSError := IOResult;
- IF DOSError <> 0 THEN BEGIN
- WritePCXHeader := DOSError;
- Close(F);
- IF IOResult <> 0 THEN Exit;
- END;
- Close(F);
- WritePCXHeader := IOResult;
- END;
-
- FUNCTION GetPcxByte(VAR F : FILE) : BYTE;
- CONST
- count : BYTE = 0;
- wert : BYTE = 0;
- p : WORD = 512;
- endfile : BOOLEAN = FALSE;
- VAR
- temp : BYTE;
-
- PROCEDURE Read_Block;
- VAR
- result : WORD;
- BEGIN
- IF EOF(F) THEN
- endfile := TRUE
- ELSE BEGIN
- BlockRead(F, pcxbuf, BlockSize, result);
- IF result < BlockSize THEN BlockSize := result;
- p := 1;
- END;
- END;
-
- FUNCTION get_byte : BYTE;
- BEGIN
- IF Endfile THEN
- get_byte := 0
- ELSE BEGIN
- IF p = BlockSize THEN
- Read_Block
- ELSE
- Inc(p);
- get_byte := pcxbuf[p];
- END;
- END;
-
- BEGIN
- IF count > 0 THEN BEGIN
- Dec(count);
- GetPcxByte := wert;
- Exit;
- END;
- temp := Get_byte;
- IF temp AND $C0 = $C0 THEN BEGIN
- count := temp AND $3F-1;
- wert := Get_Byte;
- END ELSE BEGIN
- count := 0;
- wert := temp;
- END;
- GetPCXByte := wert;
- END;
-
- FUNCTION writePCXByte(VAR F : FILE;
- wert, count : BYTE) : INTEGER;
- CONST
- total : LongInt = 0;
- BEGIN
- IF (count = 1) AND ($C0 <> $C0 AND wert) THEN BEGIN
- BlockWrite(F, wert, 1);
- WritePCXByte := IOResult;
- total := total + 1;
- END ELSE BEGIN
- count := $C0 OR count;
- BlockWrite(F, count, 1);
- WritePCXByte := IOResult;
- BlockWrite(F, wert, 1);
- WritePCXByte := IOResult;
- total := total + 2;
- END;
- END;
-
- FUNCTION WritePCXLine(VAR F : FILE;
- VAR buf : plane;
- count : BYTE) : INTEGER;
- VAR
- this, last : BYTE;
- cptr, RunCount : BYTE;
- BEGIN
- WritePCXLine := 0;
- last := buf^[0];
- RunCount := 1;
- FOR cptr := 1 TO count-1 DO BEGIN
- IF buf^[cptr] = last THEN BEGIN
- Inc(RunCount);
- IF RunCount = 63 THEN BEGIN
- DOSError := WritePCXByte(F, last, RunCount);
- IF DOSError <> 0 THEN BEGIN
- WritePCXLine := DOSError;
- Exit;
- END;
- RunCount := 0;
- END;
- END ELSE BEGIN
- DOSError := WritePCXByte(F, last, RunCount);
- IF DOSError <> 0 THEN BEGIN
- WritePCXLine := DOSError;
- Exit;
- END;
- last := buf^[cptr];
- RunCount := 1;
- END;
- END;
- IF RunCount > 0 THEN BEGIN
- DOSError := WritePCXByte(F, last, RunCount);
- IF DOSError <> 0 THEN WritePCXLine := DOSError;
- END;
- END;
-
- PROCEDURE DefPCXPalette(VAR PCXH : PCX_Header;
- ColTYPE : BYTE);
- VAR
- I, J : INTEGER;
- BEGIN
- CASE ColType OF
- 0 : BEGIN
- FillChar(PCXH.Palette, 48, 255);
- FillChar(PCXH.Palette, 3, 0);
- END;
- 1 : FOR I := 0 TO 15 DO BEGIN
- IF Odd(I) THEN
- FOR J := 0 TO 2 DO
- PCXH.Palette[I, J] := 240
- ELSE
- FOR J := 0 TO 2 DO
- PCXH.Palette[I, J] := 0;
- END;
- 2 : Move(PCXDefaultPalette, PCXH.Palette, 48);
- END;
- END;
-
- FUNCTION BGItoPCX(gd, gm : INTEGER;
- name : STRING) : INTEGER;
- VAR
- F : FILE;
- Page : INTEGER;
-
- PROCEDURE ErrorCheck;
- BEGIN
- IF DOSError <> 0 THEN BEGIN
- BGItoPCX := DOSError;
- Exit;
- END;
- END;
-
- PROCEDURE ReOpenFile;
- BEGIN
- Assign(F, name);
- Reset(f,1);
- DOSError := IOResult;
- ErrorCheck;
- Seek(F, 128);
- DOSError := IOResult;
- ErrorCheck;
- END;
-
- BEGIN
- FillChar(PCXH, 128, 0);
- PCXH.creator := 10;
- PCXH.version := 3;
- PCXH.encoding := 1;
- PCXH.bits := 1;
- PCXH.xmin := Xmin;
- PCXH.ymin := Ymin;
- PCXH.xmax := XMax;
- PCXH.ymax := YMax;
- PCXH.HRes := 75;
- PCXH.VRes := 75;
- PCXH.PaletteInfo := 1;
- CASE gd OF
- 3,4,5,9:
- BEGIN
- CASE gm OF
- 0 : BEGIN
- PCXH.Planes := 4;
- PCXH.BytePerLine := 80;
- DefPCXPalette(PCXH, 2);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- FOR I := 0 TO 199 DO BEGIN
- SPTR := Ptr(EgaBase +
- $400 * ActivePage, I*80);
- FOR Page := 0 TO 3 DO BEGIN
- SetReadPlane(Page);
- Move(SPtr^, Z[0]^, 80);
- DOSError := WritePCXLine(F, Z[0], 80);
- ErrorCheck;
- END;
- END;
- END;
- 1 : BEGIN
- PCXH.Planes := 4;
- PCXH.BytePerLine := 80;
- DefPCXPalette(PCXH, 2);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- FOR I := 0 TO 349 DO BEGIN
- SPTR := Ptr(EgaBase +
- $800 * ActivePage, I*80);
- FOR Page := 0 TO 3 DO BEGIN
- SetReadPlane(Page);
- Move(SPtr^, Z[0]^, 80);
- DOSError := WritePCXLine(F, Z[0], 80);
- ErrorCheck;
- END;
- END;
- END;
- 2 : BEGIN
- PCXH.Planes := 4;
- PCXH.BytePerLine := 80;
- DefPCXPalette(PCXH, 2);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- FOR I := 0 TO 479 DO BEGIN
- SPTR := Ptr(EgaBase +
- $960 * ActivePage, I*80);
- FOR Page := 0 TO 3 DO BEGIN
- SetReadPlane(Page);
- Move(SPtr^, Z[0]^, 80);
- DOSError := WritePCXLine(F, Z[0], 80);
- ErrorCheck;
- END;
- END;
- END;
- 3 : BEGIN
- PCXH.Planes := 1;
- PCXH.BytePerLine := 80;
- PCXH.Version := 2;
- DefPCXPalette(PCXH, 0);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- SetReadPlane(0);
- FOR I := 0 TO 349 DO BEGIN
- SPTR := Ptr(EgaBase +
- $800 * ActivePage, I*80);
- Move(SPtr^, Z[0]^, 80);
- BlockWrite(F, Z[0]^, 80);
- DOSError := WritePCXLine(F, Z[0], 80);
- ErrorCheck;
- END;
- END;
- END;
- END;
- 7 : BEGIN { CASE gd OF 7 }
- PCXH.Planes := 1;
- PCXH.BytePerLine := 90;
- PCXH.Version := 2;
- DefPCXPalette(PCXH, 0);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- FOR I := 0 TO 347 DO BEGIN
- SPtr := Ptr(HercBase, WORD((I AND 3) SHL 13
- + 90*(I SHR 2)));
- Move(SPtr^, Z[0]^, 90);
- DOSError := WritePCXLine(F, Z[0], 90);
- ErrorCheck;
- END;
- END;
-
- 1,2 : BEGIN { CASE gd OF 1, 2 }
- PCXH.Planes := 1;
- PCXH.Bits := 2;
- PCXH.BytePerLine := 80;
- IF (gd = 2) AND (gm = 3) THEN BEGIN
- J := 479;
- PCXH.Bits := 1;
- END ELSE J := 199;
- IF gm = 4 THEN PCXH.Bits := 1;
- PCXH.Version := 5;
- DefPCXPalette(PCXH, 1);
- DOSError := WritePCXHeader(PCXH, name);
- ErrorCheck;
- ReOpenFile;
- FOR I := 0 TO J DO BEGIN
- SPtr := Ptr(CgaBase, WORD((I AND 1)
- SHL 13 + 80*(I SHR 1)));
- Move(SPtr^, Z[0]^, 80);
- DOSError := WritePCXLine(F, Z[0], 80);
- ErrorCheck;
- END;
- END;
-
- END;
- Close(F);
- IF IOResult <> 0 THEN;
- END;
-
- BEGIN
- GetMem(z[0], 90);
- { ein Plane für CGA/EGA/VGA/Hercules: max 90 Bytes }
- END.
- (* ------------------------------------------------------ *)
- (* Ende von PCXTOOLS.PAS *)
-