home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 05 / praxis / pcxtools.pas next >
Pascal/Delphi Source File  |  1990-02-13  |  13KB  |  454 lines
  1. (* ------------------------------------------------------ *)
  2. (*                   PCXTOOLS.PAS                         *)
  3. (* ------------------------------------------------------ *)
  4. {$R-,S-,I-,V-,B-,N-,D-}
  5. UNIT PCXTools;
  6.  
  7. INTERFACE USES Dos;
  8.  
  9. CONST
  10.   ActivePage : WORD = 0;
  11.  
  12. VAR
  13.   Xmin, Xmax, Ymin, Ymax : WORD;
  14.  
  15. FUNCTION BGItoPCX(gd, gm : INTEGER;
  16.                   name   : STRING) : INTEGER;
  17.  
  18. TYPE
  19.   PlaneType = ARRAY[0..767] OF BYTE;
  20.   plane     = ^Planetype;
  21.   ScanLine  = ARRAY[0..3] OF plane;
  22.  
  23. VAR
  24.   z : ScanLine;
  25.  
  26. TYPE
  27.   PCX_HEADER = RECORD
  28.                  Creator    : BYTE; { Immer 10 für ZSoft   }
  29.                  Version    : BYTE; { PCX-Version:         }
  30.                              { 0 = Version 2.5 o. Palette  }
  31.                              { 2 = Version 2.8 m. Palette  }
  32.                              {     oder Version 3.0 o. Pal.}
  33.                              { 3 = Version 2.8/3.0  o. Pal.}
  34.                              { 5 = Version 3.0 mit Pal.    }
  35.                  Encoding   : BYTE;
  36.                              { 1 = Run-Length-Encoded      }
  37.                  Bits       : BYTE; { Pixel pro Bit        }
  38.                              { für CGA 320x200 2 Bits,     }
  39.                  xmin, ymin,
  40.                  xmax, ymax : INTEGER;
  41.                  Hres, VRes : INTEGER;
  42.                  Palette    : ARRAY[0..15, 0..2] OF BYTE;
  43.                  VMode      : BYTE;     { Reserviert       }
  44.                  Planes     : BYTE;     { Farbebenen       }
  45.                  BytePerLine: INTEGER;  { Bytes/Scanzeile  }
  46.                  PaletteInfo: INTEGER;
  47.                                  { 1 = Farbe/Schwarz-Weiß  }
  48.                                  { 2 = Grauwerte           }
  49.                  dummy      : ARRAY[0..57] OF BYTE;
  50.                END;
  51.  
  52.   PROCEDURE SetReadPlane(Nr : BYTE);
  53.   PROCEDURE SetWritePlane(Nr : BYTE);
  54.   PROCEDURE SetEgaReg(Nr, wert : BYTE);
  55.   FUNCTION  GetPCXHeader(VAR PCXH : PCX_Header;
  56.                              name : STRING) : INTEGER;
  57.   FUNCTION  WritePCXHeader(VAR PCXH : PCX_Header;
  58.                                name : STRING) : INTEGER;
  59.   FUNCTION  GetPcxByte(VAR F : FILE) : BYTE;
  60.   FUNCTION  writePCXByte(VAR F : FILE; wert, count : BYTE)
  61.                                                   : INTEGER;
  62.   FUNCTION  WritePCXLine(VAR F     : FILE;
  63.                          VAR buf   : plane;
  64.                              count : BYTE) : INTEGER;
  65.   PROCEDURE DefPCXPalette(VAR PCXH : PCX_Header;
  66.                               ColType : BYTE);
  67.  
  68. IMPLEMENTATION
  69.  
  70. CONST
  71.   HercBase = $B000;
  72.   EgaBase  = $A000;
  73.   CgaBase  = $B800;
  74.   BLOCKSIZE  : WORD = 512;
  75.   PCXDefaultPalette : ARRAY[0..15, 0..2] OF BYTE =
  76.         ((0, 0, 0), (0, 0, 170), (0, 170, 0), (0, 170, 170),
  77.         (170, 0, 0), (170, 0, 170), (170, 170, 0),
  78.         (170, 170, 170),
  79.         (85, 85, 85), (85, 85, 255), (85, 255, 85),
  80.         (85, 255, 255),
  81.         (255, 85, 85), (255, 85, 255), (255, 255, 85),
  82.         (255, 255, 255));
  83. VAR
  84.   PCXbuf : ARRAY[1..512] OF BYTE;
  85.   I, J   : WORD;
  86.   SPtr   : POINTER;
  87.   PCXH   : PCX_Header;
  88.  
  89.   PROCEDURE SetReadPlane(Nr : BYTE);
  90.   BEGIN
  91.     Port[$3CE] := 4;
  92.     Port[$3CF] := Nr;
  93.   END;
  94.  
  95.   PROCEDURE SetWritePlane(Nr : BYTE);
  96.   BEGIN
  97.     Port[$3C4] := 2;
  98.     Port[$3C5] := 1 SHL Nr;
  99.   END;
  100.  
  101.   PROCEDURE SetEgaReg(Nr, wert : BYTE);
  102.   BEGIN
  103.     Port[$3CE] := Nr;
  104.     Port[$3CF] := wert;
  105.   END;
  106.  
  107.   FUNCTION GetPCXHeader(VAR PCXH : PCX_Header;
  108.                             name : STRING) : INTEGER;
  109.   VAR
  110.     F : FILE;
  111.   BEGIN
  112.     FillChar(PCXH, 128, 0);
  113.     Assign(F, name);
  114.     Reset(F, 1);
  115.     DOSError := IOResult;
  116.     IF DOSError <> 0 THEN BEGIN
  117.       GetPCXHeader := DOSError;
  118.       Exit;
  119.     END;
  120.     BlockRead(F, PCXH, 128);
  121.     DOSError := IOResult;
  122.     IF DOSError <> 0 THEN BEGIN
  123.       GetPCXHeader := DOSError;
  124.       Close(F);
  125.       Exit;
  126.     END;
  127.     Close(F);
  128.     GetPCXHeader := IOResult;
  129.     IF (PCXH.version > 5) OR (PCXH.encoding > 1) THEN
  130.       GetPCXHeader := -1;
  131.   END;
  132.  
  133.   FUNCTION WritePCXHeader(VAR PCXH : PCX_Header;
  134.                               name : STRING) : INTEGER;
  135.   VAR
  136.     F : FILE;
  137.   BEGIN
  138.     Assign(F, name);
  139.     Rewrite(F, 1);
  140.     DOSError := IOResult;
  141.     IF DOSError <> 0 THEN BEGIN
  142.       WritePCXHeader := DOSError;
  143.       Exit;
  144.     END;
  145.     BlockWrite(F, PCXH, 128);
  146.     DOSError := IOResult;
  147.     IF DOSError <> 0 THEN BEGIN
  148.       WritePCXHeader := DOSError;
  149.       Close(F);
  150.       IF IOResult <> 0 THEN Exit;
  151.     END;
  152.     Close(F);
  153.     WritePCXHeader := IOResult;
  154.   END;
  155.  
  156.   FUNCTION GetPcxByte(VAR F : FILE) : BYTE;
  157.   CONST
  158.     count   : BYTE = 0;
  159.     wert    : BYTE = 0;
  160.     p       : WORD = 512;
  161.     endfile : BOOLEAN = FALSE;
  162.   VAR
  163.     temp    : BYTE;
  164.  
  165.     PROCEDURE Read_Block;
  166.     VAR
  167.       result : WORD;
  168.     BEGIN
  169.       IF EOF(F) THEN
  170.         endfile := TRUE
  171.       ELSE BEGIN
  172.         BlockRead(F, pcxbuf, BlockSize, result);
  173.         IF result < BlockSize THEN BlockSize := result;
  174.         p := 1;
  175.       END;
  176.     END;
  177.  
  178.     FUNCTION get_byte : BYTE;
  179.     BEGIN
  180.       IF Endfile THEN
  181.         get_byte := 0
  182.       ELSE BEGIN
  183.         IF p = BlockSize THEN
  184.           Read_Block
  185.         ELSE
  186.           Inc(p);
  187.         get_byte := pcxbuf[p];
  188.       END;
  189.     END;
  190.  
  191.   BEGIN
  192.     IF count > 0 THEN BEGIN
  193.       Dec(count);
  194.       GetPcxByte := wert;
  195.       Exit;
  196.     END;
  197.     temp := Get_byte;
  198.     IF temp AND $C0 = $C0 THEN BEGIN
  199.       count := temp AND $3F-1;
  200.       wert  := Get_Byte;
  201.     END ELSE BEGIN
  202.       count := 0;
  203.       wert  := temp;
  204.     END;
  205.     GetPCXByte := wert;
  206.   END;
  207.  
  208.   FUNCTION writePCXByte(VAR F : FILE;
  209.                             wert, count : BYTE) : INTEGER;
  210.   CONST
  211.     total : LongInt = 0;
  212.   BEGIN
  213.     IF (count = 1) AND ($C0 <> $C0 AND wert) THEN BEGIN
  214.       BlockWrite(F, wert, 1);
  215.       WritePCXByte := IOResult;
  216.       total := total + 1;
  217.     END ELSE BEGIN
  218.       count := $C0 OR count;
  219.       BlockWrite(F, count, 1);
  220.       WritePCXByte := IOResult;
  221.       BlockWrite(F, wert, 1);
  222.       WritePCXByte := IOResult;
  223.       total := total + 2;
  224.     END;
  225.   END;
  226.  
  227.   FUNCTION WritePCXLine(VAR F     : FILE;
  228.                         VAR buf   : plane;
  229.                             count : BYTE) : INTEGER;
  230.   VAR
  231.     this, last     : BYTE;
  232.     cptr, RunCount : BYTE;
  233.   BEGIN
  234.     WritePCXLine := 0;
  235.     last         := buf^[0];
  236.     RunCount     := 1;
  237.     FOR cptr := 1 TO count-1 DO BEGIN
  238.       IF buf^[cptr] = last THEN BEGIN
  239.         Inc(RunCount);
  240.         IF RunCount = 63 THEN BEGIN
  241.           DOSError := WritePCXByte(F, last, RunCount);
  242.           IF DOSError <> 0 THEN BEGIN
  243.             WritePCXLine := DOSError;
  244.             Exit;
  245.           END;
  246.           RunCount := 0;
  247.         END;
  248.       END ELSE BEGIN
  249.         DOSError := WritePCXByte(F, last, RunCount);
  250.         IF DOSError <> 0 THEN BEGIN
  251.           WritePCXLine := DOSError;
  252.           Exit;
  253.         END;
  254.         last := buf^[cptr];
  255.         RunCount := 1;
  256.       END;
  257.     END;
  258.     IF RunCount > 0 THEN BEGIN
  259.       DOSError := WritePCXByte(F, last, RunCount);
  260.       IF DOSError <> 0 THEN WritePCXLine := DOSError;
  261.     END;
  262.   END;
  263.  
  264.   PROCEDURE DefPCXPalette(VAR PCXH : PCX_Header;
  265.                               ColTYPE : BYTE);
  266.   VAR
  267.     I, J : INTEGER;
  268.   BEGIN
  269.     CASE ColType OF
  270.       0 : BEGIN
  271.             FillChar(PCXH.Palette, 48, 255);
  272.             FillChar(PCXH.Palette,  3, 0);
  273.           END;
  274.       1 : FOR I := 0 TO 15 DO BEGIN
  275.             IF Odd(I) THEN
  276.               FOR J := 0 TO 2 DO
  277.                 PCXH.Palette[I, J] := 240
  278.             ELSE
  279.               FOR J := 0 TO 2 DO
  280.                 PCXH.Palette[I, J] := 0;
  281.           END;
  282.       2 : Move(PCXDefaultPalette, PCXH.Palette, 48);
  283.     END;
  284.   END;
  285.  
  286.   FUNCTION BGItoPCX(gd, gm : INTEGER;
  287.                     name : STRING) : INTEGER;
  288.   VAR
  289.     F    : FILE;
  290.     Page : INTEGER;
  291.  
  292.     PROCEDURE ErrorCheck;
  293.     BEGIN
  294.       IF DOSError <> 0 THEN BEGIN
  295.         BGItoPCX := DOSError;
  296.         Exit;
  297.       END;
  298.     END;
  299.  
  300.     PROCEDURE ReOpenFile;
  301.     BEGIN
  302.       Assign(F, name);
  303.       Reset(f,1);
  304.       DOSError := IOResult;
  305.       ErrorCheck;
  306.       Seek(F, 128);
  307.       DOSError := IOResult;
  308.       ErrorCheck;
  309.     END;
  310.  
  311.   BEGIN
  312.     FillChar(PCXH, 128, 0);
  313.     PCXH.creator     := 10;
  314.     PCXH.version     := 3;
  315.     PCXH.encoding    := 1;
  316.     PCXH.bits        := 1;
  317.     PCXH.xmin        := Xmin;
  318.     PCXH.ymin        := Ymin;
  319.     PCXH.xmax        := XMax;
  320.     PCXH.ymax        := YMax;
  321.     PCXH.HRes        := 75;
  322.     PCXH.VRes        := 75;
  323.     PCXH.PaletteInfo := 1;
  324.     CASE gd OF
  325.       3,4,5,9:
  326.         BEGIN
  327.           CASE gm OF
  328.             0 : BEGIN
  329.                   PCXH.Planes := 4;
  330.                   PCXH.BytePerLine := 80;
  331.                   DefPCXPalette(PCXH, 2);
  332.                   DOSError := WritePCXHeader(PCXH, name);
  333.                   ErrorCheck;
  334.                   ReOpenFile;
  335.                   FOR I := 0 TO 199 DO BEGIN
  336.                     SPTR := Ptr(EgaBase +
  337.                                 $400 * ActivePage, I*80);
  338.                     FOR Page := 0 TO 3 DO BEGIN
  339.                       SetReadPlane(Page);
  340.                       Move(SPtr^, Z[0]^, 80);
  341.                       DOSError := WritePCXLine(F, Z[0], 80);
  342.                       ErrorCheck;
  343.                     END;
  344.                   END;
  345.                 END;
  346.             1 : BEGIN
  347.                   PCXH.Planes := 4;
  348.                   PCXH.BytePerLine := 80;
  349.                   DefPCXPalette(PCXH, 2);
  350.                   DOSError := WritePCXHeader(PCXH, name);
  351.                   ErrorCheck;
  352.                   ReOpenFile;
  353.                   FOR I := 0 TO 349 DO BEGIN
  354.                     SPTR := Ptr(EgaBase +
  355.                                 $800 * ActivePage, I*80);
  356.                     FOR Page := 0 TO 3 DO BEGIN
  357.                       SetReadPlane(Page);
  358.                       Move(SPtr^, Z[0]^, 80);
  359.                       DOSError := WritePCXLine(F, Z[0], 80);
  360.                       ErrorCheck;
  361.                     END;
  362.                   END;
  363.                 END;
  364.             2 : BEGIN
  365.                   PCXH.Planes := 4;
  366.                   PCXH.BytePerLine := 80;
  367.                   DefPCXPalette(PCXH, 2);
  368.                   DOSError := WritePCXHeader(PCXH, name);
  369.                   ErrorCheck;
  370.                   ReOpenFile;
  371.                   FOR I := 0 TO 479 DO BEGIN
  372.                     SPTR := Ptr(EgaBase +
  373.                                 $960 * ActivePage, I*80);
  374.                     FOR Page := 0 TO 3 DO BEGIN
  375.                       SetReadPlane(Page);
  376.                       Move(SPtr^, Z[0]^, 80);
  377.                       DOSError := WritePCXLine(F, Z[0], 80);
  378.                       ErrorCheck;
  379.                     END;
  380.                   END;
  381.                 END;
  382.             3 : BEGIN
  383.                   PCXH.Planes := 1;
  384.                   PCXH.BytePerLine := 80;
  385.                   PCXH.Version := 2;
  386.                   DefPCXPalette(PCXH, 0);
  387.                   DOSError := WritePCXHeader(PCXH, name);
  388.                   ErrorCheck;
  389.                   ReOpenFile;
  390.                   SetReadPlane(0);
  391.                   FOR I := 0 TO 349 DO BEGIN
  392.                     SPTR := Ptr(EgaBase +
  393.                                 $800 * ActivePage, I*80);
  394.                     Move(SPtr^, Z[0]^, 80);
  395.                     BlockWrite(F, Z[0]^, 80);
  396.                     DOSError := WritePCXLine(F, Z[0], 80);
  397.                     ErrorCheck;
  398.                   END;
  399.                 END;
  400.               END;
  401.             END;
  402.        7 :  BEGIN  { CASE gd OF 7 }
  403.               PCXH.Planes := 1;
  404.               PCXH.BytePerLine := 90;
  405.               PCXH.Version := 2;
  406.               DefPCXPalette(PCXH, 0);
  407.               DOSError := WritePCXHeader(PCXH, name);
  408.               ErrorCheck;
  409.               ReOpenFile;
  410.               FOR I := 0 TO 347 DO BEGIN
  411.                 SPtr := Ptr(HercBase, WORD((I AND 3) SHL 13
  412.                                            + 90*(I SHR 2)));
  413.                 Move(SPtr^, Z[0]^, 90);
  414.                 DOSError := WritePCXLine(F, Z[0], 90);
  415.                 ErrorCheck;
  416.               END;
  417.             END;
  418.  
  419.      1,2 :  BEGIN  { CASE gd OF 1, 2 }
  420.               PCXH.Planes      := 1;
  421.               PCXH.Bits        := 2;
  422.               PCXH.BytePerLine := 80;
  423.               IF (gd = 2) AND (gm = 3) THEN BEGIN
  424.                 J := 479;
  425.                 PCXH.Bits := 1;
  426.               END ELSE J := 199;
  427.             IF gm = 4 THEN PCXH.Bits := 1;
  428.             PCXH.Version := 5;
  429.             DefPCXPalette(PCXH, 1);
  430.             DOSError := WritePCXHeader(PCXH, name);
  431.             ErrorCheck;
  432.             ReOpenFile;
  433.             FOR I := 0 TO J DO BEGIN
  434.               SPtr := Ptr(CgaBase, WORD((I AND 1)
  435.                       SHL 13 + 80*(I SHR 1)));
  436.               Move(SPtr^, Z[0]^, 80);
  437.               DOSError := WritePCXLine(F, Z[0], 80);
  438.               ErrorCheck;
  439.             END;
  440.        END;
  441.  
  442.     END;
  443.     Close(F);
  444.     IF IOResult <> 0 THEN;
  445.   END;
  446.  
  447. BEGIN
  448.   GetMem(z[0], 90);
  449.   { ein Plane für CGA/EGA/VGA/Hercules: max 90 Bytes }
  450. END.
  451. (* ------------------------------------------------------ *)
  452. (*                Ende von PCXTOOLS.PAS                   *)
  453.  
  454.