[Back to SCREEN SWAG index] [Back to Main SWAG index] [Original]

    {
    Here is some fade code.   It works in graphics mode as well as text mode. I
    have tested it in 80x25 color text mode and 320 x 200 x 256 color graphics
    mode (Standard VGA)   The Fade unit is followed by example test program that
    shows fading in text mode.   If anyone wants a example for fading in graphics
    mode, E-MAIL me.   The only thing I ask you for using this code is that you
    E-MAIL me to tell me what you are using it in.   (Well, maybe you could give
    me a little credit in the documentation of your program) I didn't write the
    SetPalette and GetPalette routines so I don't know what the commented out
    CLIs and STIs are for.
    My E-MAIL address is ericbrodsky@pslc.psl.wisc.edu
    {------------------------------------------------------------------------}
    {$R-} {Range checking off (Helps the fade speed)}
    {$G+} {286 instructions must be enabled}
    unit Fade;

        interface

     type
         TColor =
      record
          R, G, B: byte;
      end;
         TPalette = array [0..255] of TColor;
         Proc = procedure; {Passed to fade procedures}

     procedure SetPalette(Pal: TPalette; First, Last: word);
     procedure GetPalette(var Pal: TPalette; First, Last: word);
     procedure BlackenPalette(First, Last: word);
       {Blackens all colors from First to Last.   Make sure you have the}
       {palette saved in a variable.}
     procedure FadeIn(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
    pointer);
       {AProc is called each palette step}
     procedure FadeOut(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
    pointer);
       {AProc is called each palette step}

        implementation

     procedure SetPalette(Pal: TPalette; First, Last: word); assembler;
         asm
      MOV   DX, 03DAh
           @Rt:
      IN    AL, DX       { wait for no retrace                 }
      TEST  AL, 8        { this bit is high during a retrace   }
      JZ    @Rt          { so loop until it goes high          }

      MOV   CX, [Last]   { CX = last colour to set             }
      MOV   AX, [First]  { AX = first colour to set            }
      SUB   CX, AX
      INC   CX           { CX = number of colours to set       }
      MOV   DX, 03C8h    { Palette Address register            }
      {CLI}
      OUT   DX, AL       { set starting register               }
      INC   DX           { Palette Data register               }
      PUSH  DS
      LDS   SI, [Pal]    { DS:SI -> palette                    }
      ADD   SI, AX
      ADD   SI, AX
      ADD   SI, AX       { DS:SI -> first entry to set         }
      MOV   AX, CX       { triple the value in CX              }
      ADD   CX, AX
      ADD   CX, AX       { CX = total number of bytes to write }
      REP   OUTSB        { write palette                       }
      {STI}
      POP   DS
         end;

     procedure GetPalette(var Pal: TPalette; First, Last: word); assembler;
         asm
        MOV   CX, [Last]     { CX = last colour                    }
        MOV   AX, [First]    { AX = starting colour                }
        SUB   CX, AX
        INC   CX             { CX = number of colours              }
        MOV   DX, 03C7h      { Palette Address register            }
        {CLI}
        OUT   DX, AL         { set starting register               }
        INC   DX
        INC   DX             { DX = Palette Data register          }
        LES   DI, [Pal]      { ES:DI -> palette                    }
        ADD   DI, AX
        ADD   DI, AX
        ADD   DI, AX         { ES:DI -> first entry to read        }
        MOV   AX, CX         { triple the value in CX              }
        ADD   CX, AX
        ADD   CX, AX         { CX = total number of bytes to read  }
        REP   INSB           { Read  palette                       }
        {STI}
         end;

     procedure BlackenPalette(First, Last: word);
         var
      Pal: TPalette;
      i: word;
         begin
      for i := First to Last do
          begin
       Pal[i].R := 0; Pal[i].G := 0; Pal[i].B := 0;
          end;
      SetPalette(Pal, First, Last);
         end;

     procedure FadeIn(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
    pointer);
         var
      i, j    : Byte;
      TempPal : TPalette;
         begin
      for i := 0 to Speed do
          begin
       for j := First to Last do
           begin
        TempPal[j].R := Pal[j].R * i div Speed;
        TempPal[j].G := Pal[j].G * i div Speed;
        TempPal[j].B := Pal[j].B * i div Speed;
           end;
       Setpalette(TempPal, First, Last);
       if (AProc <> nil) then Proc(AProc);
          end;
         end;

     procedure FadeOut(Pal: TPalette; First, Last: Word; Speed: byte; AProc:
    pointer);
         var
      i, j    : Byte;
      TempPal : TPalette;
         begin
      TempPal := Pal;
      for i := Speed downto 0 do
          begin
       for j := First to Last do
           begin
        TempPal[j].R := Pal[j].R * i div Speed;
        TempPal[j].G := Pal[j].G * i div Speed;
        TempPal[j].B := Pal[j].B * i div Speed;
           end;
       Setpalette(TempPal, First, Last);
       if (AProc <> nil) then Proc(AProc);
          end;
         end;
        end.

    {---------------------------------------------------------------------}

    program FadeTest;
        uses
     CRT,
     Fade;
        const
     FadeSpeed1 = 64;

     FadeSpeed2 = 64;
        var
     Pal : TPalette;
     i : longint;
        procedure aProcedure; far;
          {This procedure will be called every fade step}
     begin
         Inc(i);
         writeln('Test 2 of Ethan Brodsky''s fade routines:   Fade Step #',
                        i);
     end;
        begin
     GetPalette(Pal, 0, 255);

     {Test part 1}
     BlackenPalette(0, 255);
     writeln('Test 1 of Ethan Brodsky''s fade routines');
     FadeIn(Pal, 0, 255, FadeSpeed1, nil);
     FadeOut(Pal, 0, 255, FadeSpeed1, nil);
     FadeIn(Pal, 0, 255, FadeSpeed1, nil);

     writeln('Press any key to continue . . .');
     repeat until KeyPressed;

     {Test part 2}
     i := 0;
     FadeOut(Pal, 0, 255, FadeSpeed2, @aProcedure);
     i := 0;
     FadeIn(Pal,  0, 255, FadeSpeed2, @aProcedure);
        end.

[Back to SCREEN SWAG index] [Back to Main SWAG index] [Original]