program fadescreen;

{
 FADECODE.PAS -- Written by Scott F. Earnest (scott@whiplash.res.cmu.edu)
                 Copyright 1995, 1996

 This is proto-code.  It's not setup to do exactly what you need, but
 everything you need is included.

 No screen drawing code is provided.  You can add that yourself.  If you
 need a good ANSI displayer, I have a unit for TP7 I can provide which I
 wrote (sorry, the code is NOT free).

 If something doesn't work as expected or bugs are found, contact author
 at scott@whiplash.res.cmu.edu.

 All code original by author.  Excerpts from my own COLORS.PAS source and
 yet unreleased SlikView source.
}

{$N+,E+}

uses
  crt;

type
  TColr = record
    r, g, b : byte;
  end;

type
  {for VGA color control}
  TEGA_pal = array[0..15] of TColr;

type
  {for floating-point based fade routines}
  TRColr = record
    r, g, b : real;
  end;
  TRPal = array[0..15] of TRColr;
  PRPal = ^TRPal;

const
  {VGA fader variable lookup table}
  RrGgBb_Table : array[0..15] of byte =
    (0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);

var
  fadepal, defpal, ctl : TRPal;         {work palettes for fade effects     }

function sgn (num : longint) : shortint;

begin
  if num<0 then sgn := -1
  else if num>0 then sgn := 1
  else sgn := 0;
end;

procedure setcolr (idx : byte; var colr : TColr);

begin
  port[$3c8] := idx;
  port[$3c9] := colr.r;
  port[$3c9] := colr.g;
  port[$3c9] := colr.b;
end;

procedure getcolr (idx : byte; var colr : TColr);

begin
  port[$3c7] := idx;
  colr.r := port[$3c9];
  colr.g := port[$3c9];
  colr.b := port[$3c9];
end;

procedure setrcolr (idx : byte; var colr : TRColr);

var
  x : byte;
  tmp : TColr;

begin
  with tmp do
    begin
      r := round(colr.r);
      g := round(colr.g);
      b := round(colr.b);
    end;
  setcolr (idx,tmp);
end;

procedure getrcolr (idx : byte; var entry : TRColr);

var
  tmp : TColr;

begin
  getcolr (idx,tmp);
  with entry do
    begin
      r := tmp.r;
      g := tmp.g;
      b := tmp.b;
    end;
end;

procedure calcctl (steps : byte; var src, dest : TRPal);

var
  x : byte;

begin
  for x := 0 to 15 do
    with ctl[x] do
      begin
        r := (dest[x].r-src[x].r)/steps;
        g := (dest[x].g-src[x].g)/steps;
        b := (dest[x].b-src[x].b)/steps;
      end;
end;

procedure fadetocolor;

var
  s, x : byte;

begin
  {assumes fadepal is already (63,63,63)...(63,63,63).}
  calcctl (32,fadepal,defpal);
  for s := 0 to 31 do
    begin
      for x := 0 to 15 do
        begin
          with fadepal[x] do
            begin
              r := r+ctl[x].r;
              g := g+ctl[x].g;
              b := b+ctl[x].b;
            end;
          setrcolr (RrGgBb_table[x],fadepal[x]);
        end;
      delay (25);
    end;
end;

procedure savepalette (var pal : TRPal);

var
  x : byte;

begin
  for x := 0 to 15 do
    getrcolr (RrGgBb_Table[x],pal[x]);
end;

procedure whitescreen;

var
  x : byte;

begin
  for x := 0 to 15 do
    with fadepal[x] do
      begin
        r := 63.0;
        g := 63.0;
        b := 63.0;
      end;
end;

begin
  clrscr;
  savepalette (defpal);
  whitescreen;
  {draw your screen here}
  fadetocolor;
  readkey;
end.
{
Scott F. Earnest           | We now return you to our regularly scheduled
scott@whiplash.res.cmu.edu | chaos and mayhem. . . .
}