home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 2 / ctrom_ii_b.zip / ctrom_ii_b / C!T / C!T10_93 / PCX / PCX.PAS < prev   
Pascal/Delphi Source File  |  1993-08-09  |  13KB  |  353 lines
  1. program PCX_Viewer;
  2. { Turbo Pascal versie 6.0 of hoger
  3.   Auteur: Th.M. Hupkens }
  4.  
  5. uses Crt, Graph, Dos, All_In;
  6.  
  7. { Als u All_In aanroept, dan kunt u het pad naar de BGI-drivers vervangen
  8.   door een dummy pad. U heeft de BGI-drivers dan verder niet meer nodig.
  9.   All_In linkt alleen de benodigde drivers in: ATT, HERC, CGA, EGAVGA }
  10.  
  11. {$R- Geen controle op arraygrenzen e.d }
  12. {$I- Geen controle op Invoer/Uitvoer}
  13. {$S- Geen controle op stack overschreiding }
  14.  
  15. const BufferLengte = $FFFE;
  16. { BufferLengte bepaalt hoeveel bytes in één keer worden ingelezen.
  17.   De maximaal toegestane waarde is $FFFE. }
  18.  
  19. type PcxType = Object
  20.         Kenmerk, Versie: byte;
  21.         Gecomprimeerd: boolean;
  22.         BitsPerPixel: byte;
  23.         Raam: Record Links, Boven, Rechts, Onder: word End;
  24.         HorResolutie, VerResolutie: word;
  25.         Kleuren: array[0..15] of Record Rood, Groen, Blauw: byte End;
  26.         Reserve: byte;
  27.         AantalVlakken: byte;
  28.         AantalBytesPerLijn: word;
  29.         PaletInformatie: word;
  30.         ReserveArray: array[1..58] of byte;
  31.         procedure ToonHeaderInfo;
  32.         procedure LaatZien;
  33.         procedure Zet16Kleuren;
  34.         End;
  35.      ArByte = array[0..$FFFE] of byte;
  36.  
  37. const Mode13: boolean = false; Klaar: boolean = false;
  38.  
  39. var Herhaal, Teller, j, m, x, y, MaxX, MaxY, Vlak: word;
  40.     VGAScherm: array[0..199, 0..319] of byte absolute $A000:0;
  41.     PCX: PCXType;
  42.     GraphDriver, GraphMode: integer;
  43.     Buffer, Lijn: ^ArByte;
  44.     Bestand: string;
  45.     Palet: PaletteType;
  46.     PCX_Bestand: File;
  47.  
  48. Procedure SetVideoMode(VideoMode: byte);
  49. var Regs: Registers;
  50. Begin
  51.   Regs.AX := VideoMode;
  52.   Intr($10, Regs)
  53. End;
  54.  
  55. Procedure LeesBuffer;
  56. var BufSize: word;
  57. Begin
  58.   Klaar := Klaar or EOF(PCX_Bestand);
  59.   BlockRead(PCX_Bestand, Buffer^, SizeOf(Buffer^), BufSize)
  60. End;
  61.  
  62. Procedure Lees256Kleuren;
  63. { Leest het kleurenstaartje van het PCX-Bestand en stelt deze kleuren
  64.   vervolgens in.
  65.   De procedure SetRGBPalette uit de unit graph kan niet gebruikt worden,
  66.   omdat deze alleen werkt als het beeldscherm via InitGraph in
  67.   grafische mode is gezet. Sommige VGA's wachten bij elke verandering van
  68.   het palet op een verticale terugslag. Dit kost veel te veel tijd,
  69.   daarom worden hier in één keer het hele palet gezet. }
  70. var Registers: Dos.Registers;
  71.     Kleuren256: array[0..255] of Record Rood, Groen, Blauw: byte End;
  72.     PaletNr, ID: byte;
  73.  
  74. Begin
  75.   Seek(PCX_Bestand, FileSize(PCX_Bestand) - 769); { Zoek positie van ID }
  76.   ID := 0;
  77.   BlockRead(PCX_Bestand, ID, 1); { Lees alleen ID in }
  78.   If ID = 12 then With Registers do Begin
  79.      BlockRead(PCX_Bestand, Kleuren256, 768);
  80.      For PaletNr := 0 to 255 do With Kleuren256[PaletNr] do Begin
  81.          Rood := Rood shr 2; Groen := Groen shr 2; Blauw := Blauw shr 2
  82.      End;
  83.      AX := $1012;
  84.      BX := 0;   { Begin bij register nummer 0 }
  85.      CX := 256; { Lees alle 256 kleurenregisters in }
  86.      ES := Seg(Kleuren256);
  87.      DX := Ofs(Kleuren256);
  88.      Intr($10, Registers)
  89.      End;
  90.   Seek(PCX_Bestand, SizeOf(PCX))  { Zet positie bestand weer achter de header }
  91. End;
  92.  
  93. Procedure LeesPCXHeader(Naam: string);
  94. Begin
  95.   If Pos('.', Naam) = 0 then Naam := Naam + '.PCX';
  96.   Assign(PCX_Bestand, Naam);
  97.   Reset(PCX_Bestand, 1); { Open bestand en kies recordgrootte 1 }
  98.   IF IOResult <> 0 then Begin
  99.      WriteLn('Bestand niet gevonden. Druk op Enter.');
  100.      ReadLn; Halt End;
  101.   BlockRead(PCX_Bestand, PCX, SizeOf(PCX))
  102. End;
  103.  
  104. Procedure Increment;
  105. Begin
  106.   If Teller < BufferLengte then Inc(Teller)
  107.   else Begin
  108.     Teller := 0;
  109.     LeesBuffer
  110.   End
  111. End;
  112.  
  113. Procedure PCXType.ToonHeaderInfo;
  114. var AantalKleuren: LongInt;
  115. Begin
  116.   ClrScr;
  117.   If Kenmerk <> $0A then Begin
  118.      WriteLn('Geen PCX-formaat'); Close(PCX_Bestand); ReadLn; Halt End;
  119.   Case Versie of
  120.   0: Write('Versie 2.5');
  121.   2: Write('Versie 2.8 met palet');
  122.   3: Write('Versie 2.8 zonder palet');
  123.   5: Write('Versie 3.0')
  124.   else Write('Onbekende versie') End;
  125.   WriteLn;
  126.   With Raam do Begin
  127.        WriteLn('Raam links-boven: (', Links, ', ', Boven, ')');
  128.        WriteLn('Raam rechts-onder: (', Rechts, ', ', Onder, ')');
  129.        Dec(Rechts, Links);
  130.        Dec(Onder, Boven) End;
  131.   WriteLn('Aantal vlakken: ', AantalVlakken);
  132.   WriteLn('Aantal bits per beeldpunt: ', BitsPerPixel);
  133.   WriteLn('Aantal bytes per lijn: ', AantalBytesPerLijn);
  134.   AantalKleuren := LongInt(1) shl (AantalVlakken * BitsPerPixel);
  135.   WriteLn('Aantal kleuren: ', AantalKleuren);
  136.   If AantalVlakken = 3 then Begin
  137.      WriteLn('Dit is een 24-bits bestand.');
  138.     If GraphDriver = VGA then
  139.        WriteLn('Het wordt in 16 grijstinten weergegeven.')
  140.     else Begin
  141.          WriteLn('Het kan niet op uw scherm worden weergegeven.');
  142.          Halt End End;
  143.   If AantalKleuren = 16 then
  144.      For j := 0 to 15 do With Kleuren[j] do Begin
  145.          Write(Rood shr 2: 5, Groen shr 2: 5, Blauw shr 2: 5);
  146.          WriteLn(' EGA_palet: ', (Rood shr 7) shl 2
  147.                   + (Groen shr 7) shl 1 + (Blauw shr 7)
  148.                   + ((Rood shr 6) and 1) shl 5
  149.                   + ((Groen shr 6) and 1) shl 4
  150.                   + ((Blauw shr 6) and 1) shl 3: 5) End
  151. End;
  152.  
  153. Procedure PCXType.Zet16Kleuren;
  154. Begin
  155.   If GraphDriver = EGA then
  156.      For j := 0 to 15 do With Kleuren[j] do
  157.          SetPalette(j, (Rood shr 7) shl 2 + (Groen shr 7) shl 1
  158.                        + (Blauw shr 7) + ((Rood shr 6) and 1) shl 5
  159.                        + ((Groen shr 6) and 1) shl 4
  160.                        + ((Blauw shr 6) and 1) shl 3)
  161.   else If GraphDriver = VGA then Begin
  162.           GetPalette(Palet);
  163.           For j := 0 to 15 do With Palet, Kleuren[j] do
  164.               SetRGBPalette(Colors[j], Rood shr 2,
  165.                                        Groen shr 2, Blauw shr 2)
  166.           End;
  167. End;
  168.  
  169. Procedure PCXType.LaatZien;
  170. Begin
  171.   With Raam do Begin
  172.     If (GraphDriver = VGA) and (AantalVlakken = 1)
  173.        and (BitsPerPixel = 8) then Begin
  174.           { Kies videomode 13 hex (320 x 200, 256 kleuren): }
  175.           SetVideoMode($13);
  176.           Mode13 := true;
  177.           MaxX := 319; MaxY := 199;
  178.           Lees256Kleuren End
  179.     else Begin
  180.       If (BitsPerPixel = 2) or ((AantalVlakken = 2) and (Onder < 200)) then
  181.          If GraphDriver <> HercMono then Begin
  182.             GraphDriver := CGA; GraphMode := CGAC1 End;
  183.       If (GraphDriver = VGA) and (AantalVlakken = 4)
  184.          and (Rechts = 639) and (Onder <= 349) then GraphMode := VGAMed;
  185.          { Waarschijnlijk EGAMode, niet met zekerheid vast te stellen.
  186.            Als het getoonde plaatjes uitgerekt is in de hoogte,
  187.            maak hier dan <tijdelijk> van: GraphMode := VGAHi }
  188. {
  189.   Als u NIET All_In gebruikt dan moet in de volgende opdracht het op uw
  190.   computer van toepassing zijnde pad naar de BGI-drivers staan!
  191. }
  192.       InitGraph(GraphDriver, GraphMode, ' '{'C:\TP7\BGI'});
  193.       MaxX := GetMaxX; MaxY := GetMaxY
  194.       End;
  195.  
  196.     If Rechts < MaxX then MaxX := Rechts;
  197.     If Onder < MaxY then MaxY := Onder
  198.   End; { With Raam do... }
  199.   x := 0; y := 0;
  200.   Teller := 0;
  201.   LeesBuffer;
  202.   Case AantalVlakken of
  203.   1: Case BitsPerPixel of
  204.      1: { Monochroom }
  205.         While not (Klaar or KeyPressed) do Begin
  206.           If Buffer^[Teller] and $C0 = $C0 then Begin
  207.              Herhaal := Buffer^[Teller] - $C0;
  208.              Increment End
  209.           else Herhaal := 1;
  210.           For m := 1 to Herhaal do
  211.               For j := 7 downto 0 do Begin
  212.                   If 1 shl j and Buffer^[Teller] <> 0 then
  213.                      If x <= MaxX then PutPixel(x, y, White);
  214.                   Inc(x) End;
  215.           If x shr 3 >= AantalBytesPerLijn then Begin
  216.              x := 0; Inc(y);
  217.              If y > MaxY then Klaar := true End;
  218.           Increment
  219.           End;
  220.         { Einde Monochroom }
  221.      2: { CGA 4 kleuren }
  222.         While not (Klaar or KeyPressed) do Begin
  223.               If Buffer^[Teller] and $C0 = $C0 then Begin
  224.                  Herhaal := Buffer^[Teller] - $C0;
  225.                  Increment End
  226.               else Herhaal := 1;
  227.               For m := 1 to Herhaal do Begin
  228.                   For j := 0 to 3 do
  229.                       PutPixel(x shl 2 + j, y, Buffer^[Teller] shr (2 * (3 - j)) and 3);
  230.                   Inc(x);
  231.                   If x >= AantalBytesPerLijn then Begin
  232.                      x := 0;
  233.                      Inc(y);
  234.                      If y > MaxY then Klaar := true End
  235.                   End; { For m := 1 to Herhaal ... }
  236.                   Increment
  237.               End; { While not Klaar ... }
  238.               { Einde CGA 4-kleuren (1 vlak) }
  239.      4: { 16 Kleuren: N.b. Geen documentatie over gevonden ! }
  240.         Begin
  241.           Zet16Kleuren;
  242.           While not (Klaar or KeyPressed) do Begin
  243.               If Buffer^[Teller] and $C0 = $C0 then Begin
  244.                  Herhaal := Buffer^[Teller] - $C0;
  245.                  Increment End
  246.               else Herhaal := 1;
  247.               For m := 1 to Herhaal do Begin
  248.                   PutPixel(x shl 1, y, Buffer^[Teller] shr 4);
  249.                   PutPixel(x shl 1 + 1, y, Buffer^[Teller] and 15);
  250.                   Inc(x);
  251.                   If x >= AantalBytesPerLijn then Begin
  252.                      x := 0;
  253.                      Inc(y);
  254.                      If y > MaxY then Klaar := true End
  255.                   End; { For m := 1 to Herhaal ... }
  256.                   Increment
  257.               End { While not Klaar ... }
  258.           End;
  259.           { Einde 16 kleuren (1 vlak ) }
  260.      8: { 256 kleuren }
  261.         While not (Klaar or KeyPressed) do Begin
  262.               If Buffer^[Teller] and $C0 = $C0 then Begin
  263.                  Herhaal := Buffer^[Teller] - $C0;
  264.                  Increment End
  265.               else Herhaal := 1;
  266.               For m := 1 to Herhaal do Begin
  267.                   If x <= MaxX then
  268.                      If Mode13 then VGAScherm[y, x] := Buffer^[Teller]
  269.                      else PutPixel(x, y, Buffer^[Teller]);
  270.                   Inc(x) End; { For m := 1 to Herhaal }
  271.               If x >= AantalBytesPerLijn then Begin
  272.                  x := 0; Inc(y);
  273.                  If y > MaxY then Klaar := true End;
  274.               Increment
  275.               End { While not Klaar }
  276.         { Einde 256 kleuren }
  277.      End; { Case BitsPerPixel }
  278.   3: Begin { GraphDriver moet VGA zijn, maar dat is al eerder gecontroleerd! }
  279.        GetPalette(Palet);
  280.        For j := 0 to 15 do With Palet do
  281.            SetRGBPalette(Colors[j], 2 + j shl 2, 2 + j shl 2, 2 + j shl 2);
  282.        Vlak := 0;
  283.        GetMem(Lijn, AantalBytesPerLijn);
  284.        FillChar(Lijn^, AantalBytesPerLijn, 0);
  285.        repeat
  286.          If Buffer^[Teller] and $C0 = $C0 then Begin
  287.             Herhaal := Buffer^[Teller] - $C0;
  288.             Increment End
  289.          else Herhaal := 1;
  290.          For m := 1 to Herhaal do Begin
  291.              If Vlak = 1 then Inc(Lijn^[x], Buffer^[Teller] shr 1)
  292.              else Inc(Lijn^[x], Buffer^[Teller] shr 2);
  293.              Inc(x);
  294.              If x >= AantalBytesPerLijn then Begin
  295.                 x := 0; Inc(Vlak);
  296.                 If Vlak = AantalVlakken then Begin
  297.                    Vlak := 0;
  298.                    For j := 0 to MaxX do PutPixel(j, y, Lijn^[j] shr 4);
  299.                    FillChar(Lijn^, AantalBytesPerLijn, 0);
  300.                    Inc(y); If y > MaxY then Klaar := true End
  301.                  End
  302.                End;
  303.            Increment
  304.        until Klaar or KeyPressed
  305.      End;
  306.   2,
  307.   4: Begin
  308.        If AantalVlakken = 4 then Zet16Kleuren;
  309.        Vlak := 0;
  310.        GetMem(Lijn, MaxX + 1);
  311.        FillChar(Lijn^, MaxX + 1, 0);
  312.        repeat
  313.          If Buffer^[Teller] and $C0 = $C0 then Begin
  314.             Herhaal := Buffer^[Teller] - $C0;
  315.             Increment End
  316.          else Herhaal := 1;
  317.          For m := 1 to Herhaal do Begin
  318.              For j := 7 downto 0 do Begin
  319.                  If 1 shl j and Buffer^[Teller] > 0 then
  320.                     If x <= MaxX then Inc(Lijn^[x], 1 shl Vlak);
  321.                  Inc(x) End;
  322.              If x >= AantalBytesPerLijn shl 3 then Begin
  323.                 x := 0; Inc(Vlak);
  324.                 If Vlak = AantalVlakken then Begin
  325.                    Vlak := 0;
  326.                    For j := 0 to MaxX do PutPixel(j, y, Lijn^[j]);
  327.                    FillChar(Lijn^, MaxX + 1, 0);
  328.                    Inc(y); If y > MaxY then Klaar := true End
  329.                End
  330.              End;
  331.          Increment
  332.      until Klaar or KeyPressed;
  333.      End
  334.   End (* Case AantalVlakken of *)
  335. End;
  336.  
  337. Begin
  338.   If ParamCount = 0 then Begin
  339.      Write('Geef naam van PCX bestand: ');
  340.      ReadLn(Bestand) End
  341.   else Bestand := ParamStr(1);
  342.   DetectGraph(GraphDriver, GraphMode);
  343.   LeesPCXHeader(Bestand);
  344.   PCX.ToonHeaderInfo;
  345.   ReadLn;
  346.   GetMem(Buffer, BufferLengte);
  347.   PCX.LaatZien;
  348.   Write(#7); { Klein belletje }
  349.   ReadLn;
  350.   If Mode13 then TextMode(LastMode)
  351.   else CloseGraph;
  352.   Close(PCX_Bestand)
  353. End.