home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / spezial / 19 / snap / loadpcx.pas next >
Encoding:
Pascal/Delphi Source File  |  1990-08-01  |  9.2 KB  |  339 lines
  1. (* ------------------------------------------------------ *)
  2. (*                    LoadPCX.PAS                         *)
  3. (*                    Unit LoadPCX                        *)
  4. (*                 Turbo Pascal ab 5.0                    *)
  5. (*       (c) 1990 Gerald Arend, G. Huber & TOOLBOX        *)
  6. (* ------------------------------------------------------ *)
  7. {$R-,S-,I-,V-,B-,N-,D-,L-}
  8.  
  9. UNIT LoadPCX;
  10.  
  11. INTERFACE
  12.  
  13. USES Graph, Crt;
  14.  
  15. TYPE
  16.   PCXHeader = RECORD
  17.                  Creator    : BYTE; { Immer 10 für ZSoft   }
  18.                  Version    : BYTE; { PCX-Version:         }
  19.                              { 0 = Version 2.5 o. Palette  }
  20.                              { 2 = Version 2.8 m. Palette  }
  21.                              {     oder Version 3.0 o. Pal.}
  22.                              { 3 = Version 2.8/3.0  o. Pal.}
  23.                              { 5 = Version 3.0 mit Pal.    }
  24.                  Encoding   : BYTE;
  25.                              { 1 = Run-Length-Encoded      }
  26.                  Bits       : BYTE; { Pixel pro Bit        }
  27.                  xmin, ymin,
  28.                  xmax, ymax : INTEGER;
  29.                  Hres, VRes : INTEGER;
  30.                  Palette    : ARRAY[0..15, 0..2] OF BYTE;
  31.                  VMode      : BYTE;     { Reserviert       }
  32.                  Planes     : BYTE;     { Farbebenen       }
  33.                  BytePerLine: INTEGER;  { Bytes/Scanzeile  }
  34.                  PaletteInfo: INTEGER;
  35.                                  { 1 = Farbe/Schwarz-Weiß  }
  36.                                  { 2 = Grauwerte           }
  37.                  Dummy      : ARRAY[0..57] OF BYTE;
  38.                END;
  39.  
  40. VAR
  41.   gd, gm: INTEGER;
  42.   Header: PCXHeader;
  43.   Screen: BYTE;
  44.   FileName: STRING;
  45. CONST
  46.   PCXError: BOOLEAN = FALSE;        { Fehler-Flag }
  47.   EGAOnly: BOOLEAN = FALSE;         { EGA explizit setzen }
  48.   ClearScreen: BOOLEAN = TRUE;      { Soll Screen gelöscht werden? }
  49.  
  50. { Daten des Headers einlesen }
  51. PROCEDURE ReadPCXHeader(DateiName: STRING; VAR Header: PCXHeader);
  52.  
  53. { Palette aus PCX-File setzen - nur EGA und VGA }
  54. PROCEDURE SetPCXPalette(VAR Header: PCXHeader);
  55.  
  56. { Bit-Plane für Schreiboperationen setzen }
  57. PROCEDURE SetWritePlane(Nr : BYTE);
  58.  
  59. { PCX-Datei entschlüsseln und Screen aufbauen }
  60. PROCEDURE PCX2Screen(DateiName: STRING; VAR Header: PCXHeader);
  61.  
  62. { Startet die BGI-Grafik }
  63. PROCEDURE InitGrafik(XRes, YRes: INTEGER);
  64.  
  65. { PCX-Datei laden und anzeigen }
  66. PROCEDURE LoadPCXScreen(DateiName: STRING);
  67.  
  68. IMPLEMENTATION
  69.  
  70. PROCEDURE ReadPCXHeader(DateiName: STRING; VAR Header: PCXHeader);
  71. VAR
  72.   Datei: FILE OF PCXHeader;
  73. BEGIN
  74. {$I-}
  75.   Assign(Datei, DateiName);
  76.   Reset(Datei);
  77.   IF IOResult <> 0 THEN
  78.   BEGIN
  79.     WriteLn(^G, 'Die PCX-Datei ', DateiName, ' kann nicht gelesen werden!');
  80.     PCXError:=TRUE;
  81.     Exit;
  82.   END;
  83.   Read(Datei, Header);
  84.   Close(Datei);
  85. {$I+}
  86. END;
  87.  
  88. PROCEDURE SetPCXPalette(VAR Header: PCXHeader);
  89. VAR
  90.   Color, i, j: BYTE;
  91. CONST
  92.   Colors: ARRAY[0..2, 0..3] OF BYTE =
  93.           ((0,32,4,36),(0,16,2,18),(0,8,1,9));
  94. BEGIN
  95.   IF gd IN [EGA, EGA64, VGA] THEN
  96.     FOR i:=0 TO 15 DO
  97.     BEGIN
  98.       IF (gd=EGA) OR EGAOnly THEN   { EGA-Palette setzen }
  99.       BEGIN
  100.         Color:=0;
  101.         FOR j:=0 TO 2 DO
  102.         BEGIN
  103.           CASE Header.Palette[i, j] OF
  104.             0..63:    Color:=Color OR Colors[j, 0];
  105.             64..130:  Color:=Color OR Colors[j, 1];
  106.             131..191: Color:=Color OR Colors[j, 2];
  107.             192..255: Color:=Color OR Colors[j, 3];
  108.           END;
  109.         END;
  110.         SetPalette(i, Color);
  111.       END
  112.       ELSE                         { VGA-Palette setzen }
  113.       BEGIN
  114.         SetPalette(i, i);
  115.         WITH Header DO
  116.           SetRGBPalette(i, Palette[i, 0] SHR 2, Palette[i, 1] SHR 2,
  117.                         Palette[i, 2] SHR 2);
  118.       END;
  119.     END;
  120. END;
  121.  
  122. PROCEDURE SetWritePlane(Nr : BYTE);
  123. BEGIN
  124.   Port[$3C4] := 2;
  125.   Port[$3C5] := 1 SHL Nr;
  126. END;
  127.  
  128. PROCEDURE PCX2Screen(DateiName: STRING; VAR Header: PCXHeader);
  129. TYPE               { PCX-Datei entschlüsseln und Bild aufbauen }
  130.   PlaneType = ARRAY[0..767] OF BYTE;
  131. CONST
  132.   PufferSize = 8192;
  133.   BlockSize: WORD = PufferSize;
  134. VAR
  135.   PCXBuf: ARRAY[1..PufferSize] OF BYTE;
  136.   Plane: ARRAY[0..3] OF PlaneType;
  137.   PlaneNr: BYTE;
  138.   Datei: FILE;
  139.   x, y: INTEGER;
  140.   Count, n, j: BYTE;
  141.   P: Pointer;
  142.   Posi: WORD;
  143.  
  144.   FUNCTION GetPCXByte: BYTE;     { Nächstes Byte aus PCX-Datei lesen }
  145.   CONST
  146.     Count: BYTE = 0;
  147.     Wert: BYTE = 0;
  148.     P: WORD = PufferSize;
  149.     EndOfFile: BOOLEAN = FALSE;
  150.   VAR
  151.     Temp: BYTE;
  152.  
  153.     PROCEDURE Read_Block;
  154.     VAR
  155.       Result: WORD;
  156.     BEGIN
  157.       IF EoF(Datei) THEN
  158.         EndOfFile := TRUE
  159.       ELSE BEGIN
  160.         BlockRead(Datei, PCXBuf, BlockSize, Result);
  161.         IF Result<BlockSize THEN
  162.           BlockSize := Result;
  163.         P:=1;
  164.       END;
  165.     END;
  166.  
  167.     FUNCTION Get_Byte: BYTE;    { Byte aus Datei holen }
  168.     BEGIN
  169.       IF EndOfFile THEN
  170.         Get_Byte := 0
  171.       ELSE
  172.       BEGIN
  173.         IF P=BlockSize THEN   { wenn Puffer leer -> neu lesen }
  174.           Read_Block
  175.         ELSE
  176.           Inc(P);
  177.         Get_Byte:=PCXBuf[P];
  178.       END;
  179.     END;
  180.  
  181.   BEGIN
  182.     IF Count>0 THEN
  183.     BEGIN               { alten Wert erneut übergeben }
  184.       Dec(Count);
  185.       GetPCXByte:=Wert;
  186.       Exit;
  187.     END;
  188.     Temp := Get_Byte;
  189.     IF Temp AND $C0 = $C0 THEN      { Runtime-Encoding }
  190.     BEGIN
  191.       Count:=Temp AND $3F-1;
  192.       Wert:=Get_Byte;
  193.     END
  194.     ELSE
  195.     BEGIN
  196.       Count:=0;
  197.       Wert:=Temp;
  198.     END;
  199.     GetPCXByte:=Wert;
  200.   END;
  201.  
  202.   PROCEDURE BuildPlane(Nr: BYTE);   { Bit-Plane aufbauen }
  203.   VAR
  204.     Wert, Count: BYTE;
  205.     n: WORD;
  206.   BEGIN
  207.     FOR n:=0 TO Header.BytePerLine-1 DO
  208.       Plane[Nr][n]:=GetPCXByte;
  209.   END;
  210.  
  211. BEGIN
  212.   Assign(Datei, DateiName);
  213.   Reset(Datei, 1);
  214.   Seek(Datei, 128);
  215.  
  216.   FOR y := 0 TO Header.ymax-Header.ymin DO BEGIN
  217.     FOR PlaneNr := 0 TO Header.Planes-1 DO
  218.       BuildPlane(PlaneNr);
  219.     CASE Screen OF
  220.       0 : BEGIN     { alle Planes anzeigen: EGA/VGA }
  221.             {$R-}
  222.             P:=Ptr($A000, y*80);
  223.             {$R+}
  224.             FOR j := 0 TO Header.Planes-1 DO BEGIN
  225.               SetWritePlane(j);
  226.               Move(Plane[j], P^, 80);
  227.             END;
  228.           END;
  229.       1 : BEGIN   { nur das erste Plane wird geschrieben: CGA }
  230.             P := Ptr($B000, WORD((y AND 3) SHL 13 + 90 *
  231.                                               (y SHR 2)));
  232.             Move(Plane[0], P^, 90);
  233.           END;
  234.       2 : BEGIN   { nur das erste Plane wird geschrieben: HGC }
  235.             P := Ptr($B800, WORD((y AND 1) SHL 13 + 80 *
  236.                                               (y SHR 1)));
  237.             Move(Plane[0], P^, 80);
  238.           END;
  239.     END;
  240.   END;
  241.   Close(Datei);
  242.   PutPixel(0, 0, GetPixel(0, 0));  { nötig für BGI-Treiber }
  243. END;
  244.  
  245. PROCEDURE InitGrafik(XRes, YRes: INTEGER);   { BGI starten }
  246. VAR
  247.   Karte: INTEGER;
  248.   Fehler: BOOLEAN;
  249. BEGIN
  250.   Fehler:=FALSE;
  251.   Karte:=Detect;
  252.   DetectGraph(Karte, gm);
  253.   CASE XRes OF
  254.     640: CASE YRes OF
  255.            200: BEGIN
  256.                   Fehler:=(Karte=HercMono);
  257.                   Case Karte OF
  258.                     CGA,
  259.                     MCGA,
  260.                     EGAMono:BEGIN
  261.                               Screen:=1;
  262.                               gd:=CGA;
  263.                               gm:=CGAHi;
  264.                             END;
  265.                     EGA,
  266.                     EGA64:  BEGIN
  267.                               Screen:=0;
  268.                               gd:=Karte;
  269.                               gm:=EGALo;
  270.                             END;
  271.                     VGA:    BEGIN
  272.                               Screen:=0;
  273.                               gd:=Karte;
  274.                               gm:=VGALo;
  275.                             END;
  276.                   END;
  277.                 END;
  278.            350: BEGIN
  279.                   Fehler:=NOT (Karte IN [EGA, EGAMono, VGA]);
  280.                   Screen:=0;
  281.                   gd:=Karte;
  282.                   IF gd=VGA THEN
  283.                     gm:=VGAMed
  284.                   ELSE
  285.                     gm:=EGAHi;
  286.                 END;
  287.            480: BEGIN
  288.                   Fehler:=NOT (Karte IN [VGA, MCGA]);
  289.                   Screen:=0;
  290.                   gd:=VGA;
  291.                   gm:=VGAHi;
  292.                 END;
  293.          END;
  294.     320: BEGIN
  295.            Fehler:=(Karte=HercMono);
  296.            Screen:=2;
  297.            gd:=CGA;
  298.            gm:=CGAC0;
  299.          END;
  300.     720: BEGIN
  301.            Fehler:=(Karte<>HercMono);
  302.            Screen:=1;
  303.            gd:=HercMono;
  304.            gm:=HercMonoHi;
  305.          END;
  306.   END;
  307.   IF Fehler THEN
  308.   BEGIN
  309.     WriteLn(^G, 'Benötigte Grafikkarte nicht vorhanden!');
  310.     PCXError:=TRUE;
  311.     Exit;
  312.   END;
  313.   InitGraph(gd, gm, '');
  314.   IF GraphResult<>0 THEN
  315.   BEGIN
  316.     WriteLn(^G, 'Fehler beim Initialisieren des Grafikpakets!');
  317.     PCXError:=TRUE;
  318.     Exit;
  319.   END;
  320. END;
  321.  
  322. PROCEDURE LoadPCXScreen(DateiName: STRING);    { PCX-Bild laden }
  323. BEGIN
  324.   ReadPCXHeader(DateiName, Header);
  325.   IF PCXError THEN
  326.     Exit;
  327.   WITH Header DO
  328.     InitGrafik(Hres, VRes);
  329.   IF PCXError THEN
  330.     Exit;
  331.   SetPCXPalette(Header);
  332.   PCX2Screen(DateiName, Header);
  333. END;
  334.  
  335. BEGIN
  336. END.
  337. (* ------------------------------------------------------ *)
  338. (*                Ende von LOADPCX.PAS                    *)
  339.