Rainbow: Delphi Version

{*****************************************************************************
*                                                                            *
*  Rainbow.dpr                                                               *
*  RainbowU.pas                                                              *
*                                                                            *
*  This program demonstrates color palette cycling.                          *
*                                                                            *
*****************************************************************************}
unit RainbowU;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, ExtCtrls, FGWin;
type
  TForm1 = class(TForm)
    Timer1: TTimer;
    procedure AppOnActivate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  end;
var
  Form1: TForm1;
implementation
{$R *.DFM}
var
  dc    : hDC;
  hPal  : hPalette;
  hVB   : integer;
  cxClient, cyClient : integer;
  Start : integer;
  RGBvalues : array [0..2*24*3-1] of byte;    { two sets of 24 RGB triplets }
{*****************************************************************************
*                                                                            *
*  FillColorPalette()                                                        *
*                                                                            *
*  Set up the colors for the application's logical palette in the RGBvalues  *
*  array. The logical palette will contain 24 non-system colors (indices 10  *
*  to 33) defining the initial RGB values for the colors being cycled.       *
*                                                                            *
*  Note that we store two identical sets of 24 RGB triplets in RGBvalues. We *
*  can then perform color cycling without having to worry about wrapping to  *
*  the start of the array because the index pointing to the starting RGB     *
*  triplet never extends beyond the first set of 24 RGB triplets.            *
*                                                                            *
*****************************************************************************}
procedure FillColorPalette;
const
  Colors : array [1..24*3] of byte = (
    182,182,255, 198,182,255, 218,182,255, 234,182,255, 255,182,255,
    255,182,234, 255,182,218, 255,182,198, 255,182,182, 255,198,182,
    255,218,182, 255,234,182, 255,255,182, 234,255,182, 218,255,182,
    198,255,182, 182,255,182, 182,255,198, 182,255,218, 182,255,234,
    182,255,255, 182,234,255, 182,218,255, 182,198,255);
begin
   { set up two identical sets of the 24 colors in the RGBvalues array }
   Move(Colors,RGBvalues,24*3);
   Move(Colors,RGBvalues[24*3],24*3);
end;
{****************************************************************************}
procedure TForm1.AppOnActivate(Sender: TObject);
begin
  fg_realize(hPal);
  Invalidate;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
  fg_realize(hPal);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
  Color, xLen, yLen : integer;
begin
  { create the logical palette }
  dc := GetDC(Form1.Handle);
  fg_setdc(dc);
  FillColorPalette;
  hPal := fg_logpal(10,24,RGBvalues);
  fg_realize(hPal);
  { create a 640x480 virtual buffer }
  fg_vbinit;
  hVB := fg_vballoc(640,480);
  fg_vbopen(hVB);
  fg_vbcolors;
  { construct a crude image of a rainbow }
  fg_setcolor(255);
  fg_fillpage;
  fg_setclip(0,639,0,300);
  fg_move(320,300);
  xLen := 240;
  yLen := 120;
  for Color := 10 to 33 do
  begin
    fg_setcolor(Color);
    fg_ellipsef(xLen,yLen);
    dec(xLen,4);
    dec(yLen,3);
  end;
  fg_setcolor(255);
  fg_ellipsef(xLen,yLen);
  fg_setclip(0,639,0,479);
  { starting index into the array of color values }
  Start := 0;
  { start the 50ms timer }
  Timer1.Interval := 50;
  Timer1.Enabled  := True;
  Application.OnActivate := AppOnActivate;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
  fg_vbscale(0,fg_getmaxx,0,fg_getmaxy,0,cxClient-1,0,cyClient-1);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
  cxClient := ClientWidth;
  cyClient := ClientHeight;
  Invalidate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  fg_vbclose;
  fg_vbfree(hVB);
  fg_vbfin;
  DeleteObject(hPal);
  ReleaseDC(Form1.Handle,dc);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if (GetActiveWindow = Form1.Handle) then
  begin
    Start := (Start + 3) mod 72;
    fg_setdacs(10,24,RGBvalues[Start]);
    if (fg_colors > 8) then
      fg_vbscale(0,fg_getmaxx,0,fg_getmaxy,0,cxClient-1,0,cyClient-1);
  end;
end;
end.