Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/gif/tpgif/scr2gifu.pas

Pascal/Delphi Source File | 1992-03-09 | 15.4 KB | 442 lines

UNIT SCR2GIFU;

(* *************************************************************************
   Turbo 5.0 unit to send any screen to a gif file. Includes the
   LZW compression routines in CMPRSS.INC.  User need only call
   the function 'ScreenToGif(FileName: String):Integer;' and provide a valid
   file name.  Detecting the screen dimensions, color map, etc is all
   automatically handled.  Example usage:

   Program Sample;
   Uses SCR2GIFU,GRAPH;
   Var
     GifCompressError: Integer;
   Begin
     OpenGraphics;                  {your procedure to open a graphics mode}
     DrawGraphics;                  {your procedure to draw graphics}
     GifCompressError:=ScreenToGif('TEST.GIF');
     CloseGraphics;                 {your procedure to exit graphics mode}
     ClrScr;
     If GifCompressError=0
       Then Writeln('GIF save successful.')
       Else
         If GifCompressError=-2
           Then Writeln('Not enough memory available.')  {needs about 25k}
           Else Writeln('GIF save unsuccessful.');       {other problem}
     Readln;                        {pause for <RETURN>}
   End.

   If you are planning to write your own graphics driver (or unit to
   replace GRAPH.TPU), you may want to know that this SCR2GIFU unit uses
   the following from the GRAPH.TPU:

         Const
           Maxcolors=15;
         Type
           PaletteType=Record
             Size: Byte;
             Colors:Array[0..maxcolors] of shortint;
           End;

         Function GetMaxColor:Word;
         Procedure GetPalette(Palette:PaletteType);
         Function GetGraphMode:Integer;
         Function GetMaxY: Integer;
         Function GetMaxX: Integer;
         Function GetPixel(X,Y: Integer):Word;

   This unit does not work for the IBM8451 driver modes because I have no
   idea how to get the palette values in this mode.  This unit
   does not work for the EGAMonoHi mode only because
   GetMaxColor returns 3 (4 colors) in this two color mode (should
   return 1).  I have tested this unit using SVGA 256 color modes with a
   substituted super vga GRAPH unit and it works great.

   Written by Rob Crockett [76167,1561] April 1992.  The include file
   CMPRSS.INC written by Bob Berry [76555,167] 1988.

   ********************************************************************** *)



INTERFACE

  Uses DOS ,GRAPH;

  Function ScreenToGif(FileName: String):Integer;

IMPLEMENTATION
  Type
    ByteFile = File of Byte;

  Var
    Signature    : Array[0..5] of Byte;            {GIF signature}
    SDescriptor  : Array[1..7] of byte;            {screen descriptor}
    ColorMap     : Array[0..2,0..255] of byte;     {RGB color map}
    IDescriptor  : Array[1..10] of byte;           {image descriptor}
    GifFile      : ByteFile;                       {output file}
    Debugger     : Boolean;
    X,Y          : Integer;
    GifTerminator: Byte;                           {';' GIF terminator}

  {$I CMPRSS.INC}     {Include Bob Berry's LZW GIF compression routines}

  Procedure OpenGifFile(FileName:String;Var GifFile: ByteFile);
     Begin
       Assign(GifFile,FileName);
       ReWrite(GifFile);
     End;

  Procedure CloseGifFile(Var GifFile: ByteFile);
     Begin
       Close(GifFile);
     End;

  Procedure SaveDescriptor(Var GifFile:ByteFile);
     Var
       I,J                 :Integer;
       Pixel,MaxColor      :Byte;
     Begin
       For I:=0 to 5 do Write(GifFile,Signature[I]);
       For I:=1 to 7 do Write(Giffile,SDescriptor[I]);
       For J:=0 to GetMaxColor {MaxColor} do
         For I:=0 to 2 do Write(GifFile,ColorMap[I,J]);
       For I:=1 to 10 do Write(GifFile,IDescriptor[I]);
     End;

  Procedure GetAllRGBPalette(ColorNum:Integer; Var RedNum,GreenNum,BlueNum: Byte);
       {Procedure to return the color componant values of each color number.
        Uses the TP 'GetPalette' procedure.  Each componant normalized to
        a 0..255 range, eg (0,0,0) is black, (255,255,255) is white.

        TP 'GetPalette' returns a color with the following bit plane coding
        when in 640x350 or 640x480 EGA/VGA modes:
             bit   76543210
             gives 00rgbRGB
       ..where small letters mean low intensity and large letters mean high.
       In the lower resolution EGA/VGA modes, the 'GetPalette' returns a byte
       with the following coding:
             bit   76543210
             gives 000I0RGB
       ...where the I is the intensity bit.

       Palette values for the 4 color modes are internal to this procedure.

       This procedure does not work for the IBM8451 driver modes.  I have no
       idea where the palette values would be stored in this mode.  This
       procedure does not work for the EGAMonoHi mode only because
       GetMaxColor returns 3 (4 colors) in this two color mode (should
       return 1).

       Since virgin TP does not support 256 color modes, I have included an
       EGA/VGA BIOS routine to return the DAC palette values, should you be
       inclined to experiment with SVGA.}

    Type
      {PaletteType=Record      ...turbo preset type...
          Size: Byte;
          Colors: Array[0..maxcolors] of ShortInt;
        End;       }
      CGAColors = Array[0..11] of byte;

    Const                     {the four CGA palettes}
      C0:CGAColors = (  0,  0,  0, 85,255, 85,255, 85, 85,255,255, 85);
      C1:CGAColors = (  0,  0,  0, 85,255,255,255, 85,255,255,255,255);
      C2:CGAColors = (  0,  0,  0,  0,170,  0,170,  0,  0,170, 85,  0);
      C3:CGAColors = (  0,  0,  0,  0,170,170,170,  0,170,170,170,170);

    Var
      Palette:PaletteType;
      ColorValue: ShortInt;
      ColorIndex: Integer;
      Regs: Registers;
      CGAPalette: CGAColors;

    Begin
      Case GetMaxColor of
        1: Begin                                     {2 color}
             Case ColorNum of
               0: Begin RedNum:=0; GreenNum:=0; BlueNum:=0; End;
               1: Begin RedNum:=255; GreenNum:=255; BlueNum:=255;  End;
             End;
           End;
        3: Begin                                     {4 color}
             Case GetGraphMode of
               0: CGAPalette:=C0;
               1: CGAPalette:=C1;
               2: CGAPalette:=C2;
               3: CGAPalette:=C3;
             End;
             RedNum:=  CGAPalette[ColorNum*3+0];
             GreenNum:=CGAPalette[ColorNum*3+1];
             BlueNum:= CGAPalette[ColorNum*3+2];
           End;
       15: Begin                                     {16 color modes}
             GetPalette(Palette);
             If (GetMaxY<349)
               Then                 {EGA palette byte code: 765I3RGB}
                 Begin
                   ColorValue:=Palette.Colors[ColorNum] SHR 4;
                   If Odd(ColorValue)
                     Then
                       Begin
                         RedNum:=1; GreenNum:=1; BlueNum:=1;
                       End
                     Else
                       Begin
                         RedNum:=0; GreenNum:=0; BlueNum:=0;
                       End;
                 End
               Else                 {VGA palette byte code: 76rgbRGB}
                 Begin
                   ColorValue:=Palette.Colors[ColorNum] SHR 3;
                   If Odd(ColorValue) then BlueNum:=1 else BlueNum:=0;
                   ColorValue:=ColorValue shr 1;
                   If Odd(ColorValue) then GreenNum:=1 else GreenNum:=0;
                   ColorValue:=ColorValue shr 1;
                   If Odd(ColorValue) then RedNum:=1 else RedNum:=0;
                 End;

             ColorValue:=Palette.Colors[ColorNum];
             If Odd(ColorValue) then BlueNum:=BlueNum+2;
             ColorValue:=ColorValue shr 1;
             If Odd(ColorValue) then GreenNum:=GreenNum+2;
             ColorValue:=ColorValue shr 1;
             If Odd(ColorValue) then RedNum:=RedNum+2;

             RedNum:=RedNum*85;        {85=255/3...brings 0-3value to}
             GreenNum:=GreenNum*85;    {0-255 range}
             BlueNum:=BlueNum*85;
           End;
      255: Begin                        {256 Colors}
             Regs.AH:=$10;              {Read contents of multiple DAC registers}
             Regs.AL:=$15;
             Regs.BX:=ColorNum;         {The DAC color register of interest}
             Intr($10,Regs);
             RedNum:=Regs.DH*4;         {DAC is 18 bit, 6 bits each R,G,and B}
             GreenNum:=Regs.CH*4;       {thus DAC.R ranges 0-63}
             BlueNum:=Regs.CL*4;        {so multiply by 4 to range 0-255}
           End;   { 255}
     End;  {case GetMaxColor of}
  End;    {getRGBPalette}

  Procedure SetGifDescriptor;
    {sets the gif signature 'Signature[0..5]', screen
     descriptor array 'SDescriptor[1..7]', and global color
     map as follows:
       Signature = GIF87a as six bytes
       Screen Descriptor as seven bytes:

             bits
         7 6 5 4 3 2 1 0  Byte #
        +---------------+
        |               |  1
        +-Screen Width -+      Raster width in pixels (LSB first)
        |               |  2
        +---------------+
        |               |  3
        +-Screen Height-+      Raster height in pixels (LSB first)
        |               |  4
        +-+-----+-+-----+      M = 1, Global color map follows Descriptor
        |M|  cr |0|pixel|  5   cr+1 = # bits of color resolution
        +-+-----+-+-----+      pixel+1 = # bits/pixel in image (bit 3 of word 5 reserved)
        |   background  |  6   background=Color index of screen background
        +---------------+          (color is defined from the Global color
        |0 0 0 0 0 0 0 0|  7        map or default map if none specified)
        +---------------+

       Global Color Map has 3*GetMaxColor bytes.

    }

    Const
      X = 1;
      Y = 1;
      X1 = 40;
      Y1 = 1;
      GIF87a: Array[0..5] of Byte = (71,73,70,56,55,97);


    Var
      I,J                       :Integer;
      CR,Pixel                  :Byte;
      Regs: Registers;
    Begin
      {*** SCREEN DESCRIPTOR ******************************}

      {Signature}
      For I:=0 to 5 do
        Signature[I]:=GIF87a[I];

      {Screen Width}
      SDescriptor[1]:=(GetMaxX+1) Mod 256;
      SDescriptor[2]:=(GetMaxX+1) Div 256;

      {Screen Height}
      SDescriptor[3]:=(GetMaxY+1) Mod 256;
      SDescriptor[4]:=(GetMaxY+1) Div 256;


      SDescriptor[5]:=0;

      {M=1}
      SDescriptor[5]:=SDescriptor[5] OR 128; {1000000}

      {CR+1=bits color resolution}
      CR:=1;
      Case GetMaxColor of    {CR+1=color resolution=bits per RGB color componant}
         1: CR:=0;
         3: CR:=0;
        15: CR:=1;
       255: CR:=7;
      End;
      SDescriptor[5]:=SDescriptor[5] OR (CR shl 4);

      {Pixel+1=bits per pixel in image}
      Pixel:=3;
      Case GetMaxColor of
         1: Pixel:=0;
         3: Pixel:=1;
        15: Pixel:=3;
       255: pixel:=7;
      End;
      SDescriptor[5]:=SDescriptor[5] OR Pixel;

      {Background color}
      SDescriptor[6]:=0;         {set as black}

      {Reserved}
      SDescriptor[7]:=0;


      {****** Global Color Map *********************}

      For I:=0 to GetMaxColor do
         GetAllRGBPalette(I,ColorMap[0,I],ColorMap[1,I],ColorMap[2,I]);

      {*** IMAGE DESCRIPTOR *****************************}

      {ImageSepChar ',' }
      IDescriptor[1]:=Ord(',');

      {Image Left}
      IDescriptor[2]:=0 mod 256;
      IDescriptor[3]:=0 div 256;

      {Image Top}
      IDescriptor[4]:=0 mod 256;
      IDescriptor[5]:=0 div 256;

      {Image Width}
      IDescriptor[6]:=(GetMaxX+1) mod 256;
      IDescriptor[7]:=(GetMaxX+1) div 256;

      {Image Height}
      IDescriptor[8]:=(GetMaxY+1) mod 256;
      IDescriptor[9]:=(GetMaxY+1) div 256;

      {ImageSpecByte}
        IDescriptor[10]:=0;
      {M=1 local color map follows, use 'pixel'}
      {M=0 use global color map, ignore 'pixel'}
        {IDescriptor[10]:=IDescriptor[10] OR 128;} {10000000}
      {I=0 formatted in sequential order}
      {I=1 formatted in interlaced order}
        {IDescriptor[10]:=IDescriptor[10] OR 64;}  {01000000}
      {Pixel+1=bits per pixel for this image}
        Case GetMaxColor of
          1: Pixel:=0;
          3: Pixel:=1;
         15: Pixel:=3;
        255: pixel:=7;
        End;
        IDescriptor[10]:=IDescriptor[10] OR Pixel;
    End;

    Function GetByte:Integer;
      {Called by the LZW compression routines, GetByte produces
       a byte representing the color value of a pixel on the screen.
       The byte is packaged as the low byte of a word (integer).
       GetByte uses the global variables X and Y to keep track of
       its position on the screen.}

      Begin
        If X<GetMaxX
          Then
            Begin
              X:=X+1;
              GetByte:=GetPixel(X,Y);
            End
          Else
            Begin
              If Y<GetMaxY
                Then
                  Begin
                    Y:=Y+1;
                    X:=0;
                    GetByte:=GetPixel(X,Y);
                  End
                Else
                  Begin
                    GetByte:=(-1);
                  End;
            End;
      End;

  Procedure PutByte(B:Integer);
    {Called by the LZW compression routines, PutByte sends a byte
     of data to the forming GIF file.  The first byte sent by the LZW
     compression routings is the 'Minimum Code Size', next byte is
     the block size, then the bytes forming the data block, the next
     block size byte, next block data bytes, etc.  The byte is accepted
     from the compression routines as the low byte of an integer.}

    Var
      ByteNum: Byte;
    Begin
      ByteNum:=Lo(B);
      Write(GifFile,ByteNum);
    End;

Function GetMinCodeSize: Byte;
    {Produces the minimum number of bits required to represent
     the actual pixel value (the color number).  This would be the same
     as the bits per pixel except that because of algorithmic constraints
     of the LZW compression routines, black and white images with a
     bits-per-pixel of 1 have a minimum code size of 2.  Thus the
     mincodesize can be from 2 (black and white) to 8 (256 colors).}
  Var
    Code: Byte;
  Begin
    Case GetMaxColor of
       1: Code:=2;
       3: Code:=2;
      15: Code:=4;
     255: Code:=8;
    End;
    GetMinCodeSize:=Code;
  End;

  Function ScreenToGif(FileName: String):Integer;
    {Master function to create a GIF file 'FileName' from the graphics screen.
     Returns ScreenToGif=0 if no errors, ScreenToGif<>0 if some error
     encountered.}
    Var
      GifResult,I                   :Integer;
      {global var  X,Y : Integer}
    Begin
      GifTerminator:=$3B;                   {';'}
      X:=-1;                                {set (X,Y) for screen location...}
      Y:=0;                                 {...used in GetByte function.}
      OpenGifFile(FileName,GifFile);        {open the file for output}
      SetGifDescriptor;                     {set up GIF file info header}
      SaveDescriptor(GifFile);              {send info header to GIF file}
      GifResult:= CompressGif(GetMinCodeSize);  {send screen data to GIF file}
      Write(GifFile,GifTerminator);         {send ';' to end GIF mode}
      CloseGifFile(GifFile);                {close the file}
      ScreenToGif:=GifResult;               {pass along error codes}
    End;

END.