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

    Program Fade;         { Fades to Black, Clears the screen and restores palet }

    Uses Crt, DOS;

    Const SizeOfPal = 255;    { Size of palette to be altered...255 works in all}
          UpLim     = Sizeofpal + 1; { <256 cols modes. }

    Type Pal = Record
                 Red, Green, Blue : Byte; { Red, Green and Blue Colour Registers }
               End;
      FullPal = Record
                  Data : Array [0..SizeOfPal] Of Pal;
                End;                          { This is basically a full palette }

    Procedure GetPalette (Var Hello : Fullpal);    { Returns the current Palette }
      { uses BIOS }
    Var Regs: Registers;
    Begin
      With Regs Do
      Begin
        AX := $1017;      { Get Block Of Color Registers }
        BX := 0;          { First Colour register to be changed is 0 - black }
        CX := Uplim;      { Change <UpLim> registers }
        ES := Seg (Hello);{ Segment address of Hello }
        DX := Ofs (Hello);{ Offset address of Hello -> DX }
      End;
      Intr ($10, Regs);   { Call video interrupt (get palette -> Hello) } End; {GetPalette }
    Procedure WritePalette (Var Hello : Fullpal);
        { Writes to screen passed palette }
    Var Regs: Registers;
    Begin
      With Regs Do
      Begin
        ES := Seg (Hello);
        AX := $1012; { Write block of color registers }
        BX := 0;     { Everything else is basically the same as GetPallette }
        CX := Uplim;
        DX := Ofs (Hello);
      End;
      Intr ($10, Regs);
    End; { WritePalette }

    Procedure Sync;
    Var CRTC : Word;
    Begin
      CRTC := Memw [$40:$63];  { get CRTC address }
      If CRTC <> 0 Then        { in case no video controller/fn not supported }
      Begin
        CRTC := CRTC + 6; { set address to register including retrace signal. }
        Repeat Until (port [crtc] And 8) = 0;
        Repeat Until (port [crtc] And 8) = 8;
      End;
    End;

    Var
      Saved, Nyar  : Fullpal;
      C, Q         : Byte;
      Cls          : String;
      Regs         : Registers;

    Begin
      GetPalette (Saved);
      Move (Saved, Nyar, SizeOf (Fullpal) );

      For Q := 63 Downto 1 Do Begin
        For C := 0 To SizeOfPal Do Begin
          With Nyar. Data [c] Do Begin
            Dec (Red);    If Red   > 63 Then Red   := 0;
            Dec (Green);  If Green > 63 Then Green := 0;
            Dec (Blue);   If Blue  > 63 Then Blue  := 0;
          End; { With Nyar.Data[c] }
        End; { For C := 0 To SizeOfPal }
        Sync;
        WritePalette (Nyar);
      End; { For Q:=63 DownTo 1 }

      Cls := '`[40m';

      With Regs do
        Begin
        AH := $40;        { Write to DOS File Handle }
        BX := 1;          { Standard Output }
        CX := 5;          { 5 bytes }
        DS := Seg(Cls);   { Segment of CLS }
        DX := ofs(Cls);   { Offset of CLS[1] }
        End;
      MSDos(Regs);
      TextAttr := TextAttr And 15;
      ClrScr;
      With Regs do
        Begin
        AX := $1001;
        BH := 0;
        End;
      Intr($10,Regs);
      Writepalette (Saved);
    End.

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