unit FrmMain;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Buttons, Inifiles, Globals, mk_avi, Worms, ComCtrls;

type

  TFormBalls = class(TForm)
    Timer1: TTimer;
    PanelBalls: TPanel;
    PaintBox: TPaintBox;
    BitBtnExit: TBitBtn;
    BitBtnReset: TBitBtn;
    LabelFrameCounter: TLabel;
    SpeedButtonRecord: TSpeedButton;
    PanelMain: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    TrackBarBallCount: TTrackBar;
    TrackBarSpeedRange: TTrackBar;
    TrackBarGravity: TTrackBar;
    TrackBarHeat: TTrackBar;
    TrackBarDamping: TTrackBar;
    TrackBarGravConst: TTrackBar;
    TrackBarSizeRange: TTrackBar;
    procedure PaintBoxPaint(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure BitBtnExitClick(Sender: TObject);
    procedure BitBtnResetClick(Sender: TObject);
    procedure SpeedButtonRecordClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure TrackBarBallCountChange(Sender: TObject);
    procedure TrackBarSpeedRangeChange(Sender: TObject);
    procedure TrackBarSizeRangeChange(Sender: TObject);
    procedure TrackBarGravityChange(Sender: TObject);
    procedure TrackBarHeatChange(Sender: TObject);
    procedure TrackBarDampingChange(Sender: TObject);
    procedure TrackBarGravConstChange(Sender: TObject);
  private
    FWorm         : TWorm;
    FFirstTime    : Boolean;
    FBitmaps      : TBitmapList;
    FFrameCounter : Integer;
    FRecording    : Boolean;
    FBallCount    : Integer;
    FSpeedRange   : Real;
    FSizeRange    : Integer;
    FGravity      : Real;
    FHeat         : Real;
    FDamping      : Real;
    FGravConst    : Real;
  private
    procedure   SetRecording ( aValue: Boolean );
    procedure   SetBallCount ( aValue : Integer);
    procedure   SetSpeedRange( aValue : Real   );
    procedure   SetSizeRange ( aValue : Integer);
    procedure   SetGravity   ( aValue : Real   );
    procedure   SetHeat      ( aValue : Real   );
    procedure   SetDamping   ( aValue : Real   );
    procedure   SetGravConst ( aValue : Real   );
  private
    procedure   SaveIni;
    procedure   LoadIni;
    procedure   ClearMovie;
    procedure   Reset;
    procedure   SaveMovie;
    procedure   DoPaintBalls( aCanvas: TCanvas);
    procedure   InitBalls;
    procedure   InvalidateBalls;
    procedure   CalcForces;
    function    MakeBitmap: TBitmap;
  private
    property    Recording: Boolean    read FRecording  write SetRecording;
    property    BallCount  : Integer  read FBallCount  write SetBallCount;
    property    SpeedRange : Real     read FSpeedRange write SetSpeedRange;
    property    SizeRange  : Integer  read FSizeRange  write SetSizeRange;
    property    Gravity    : Real     read FGravity    write SetGravity;
    property    Heat       : Real     read FHeat       write SetHeat;
    property    Damping    : Real     read FDamping    write SetDamping;
    property    GravConst  : Real     read FGravConst  write SetGravConst;
  end;

var

  FormBalls: TFormBalls;

implementation


{$R *.DFM}


// User area


const

  Depth   = 510;

  CColors = 12;

  Colors : array[ 0 .. CColors - 1] of TColor = (
    $008000FF,
    $00FF8080,
    $00ffffff,
    $00555555,
    clYellow,
    clFuchsia,
    clBlue,
    clLime,
    clRed,
    clWhite,
    clGreen,
    clMaroon
  );

type

  TRealPoint = record
    X : Real;
    Y : Real;
    Z : Real;
  end;

  TRealBox = record
    Point1 : TRealPoint;
    Point2 : TRealPoint;
  end;

  function RealPoint( anX, anY, anZ: Real): TRealPoint;
  begin
    with Result
    do begin
      X := anX;
      Y := anY;
      Z := anZ;
    end;
  end;

  function RealBox( aPoint1, aPoint2: TRealPoint): TRealBox;
  begin
    with Result
    do begin
      Point1 := aPoint1;
      Point2 := aPoint2;
    end;
  end;

  function AddRealPoints( A, B: TRealPoint): TRealPoint;
  begin
    Result.X := A.X + B.X;
    Result.Y := A.Y + B.Y;
    Result.Z := A.Z + B.Z;
  end;

  function RealPointZero: TRealPoint;
  begin
    Result.X := 0;
    Result.Y := 0;
    Result.Z := 0;
  end;


  function ScaleColor( aColor: TColor; aDepth, aMaxDepth: Real): TColor;
  var
    R, G, B : Byte;
    S       : Real;
  begin
    S := ( aMaxDepth - aDepth / 1.2) / aMaxDepth;
    if S < 0
    then S := 0
    else if S > 1
    then S := 1;
    R := Round( S * GetRValue( aColor));
    G := Round( S * GetGValue( aColor));
    B := Round( S * GetBValue( aColor));
    Result := RGB( R, G, B);
  end;


type

  TBall = class( TObject)
  private
    FColor    : Integer;
    FEdge     : Integer;
    FSize     : Integer;
    FMass     : Real;
    FPosition : TRealPoint;
    FSpeed    : TRealPoint;
    FForce    : TRealPoint;
    FAccel    : TRealPoint;
  public
    constructor Create( aPosition, aSpeed: TRealPoint; aColor, anEdge, aSize: Integer);
    procedure   PaintIt( aCanvas: TCanvas);
    procedure   Calculate( aBox: TRealBox; aDamping, aHeat, aGravity: Real);
    function    ForceDueTo( aBall: TBall): TRealPoint;
  end;


    constructor TBall.Create( aPosition, aSpeed: TRealPoint; aColor, anEdge, aSize: Integer);
    begin
      inherited Create;
      FColor    := aColor;
      FEdge     := anEdge;
      FSize     := aSize;
      FMass     := FSize * FSize * FSize;
      FPosition := aPosition;
      FSpeed    := aSpeed;
    end;

    procedure   TBall.PaintIt( aCanvas: TCanvas);
    var
      aRect : TRect;
      bRect : TRect;
    begin
      with aCanvas
      do begin
        bRect := aCanvas.ClipRect;
        with FPosition
        do aRect := Rect( Round( X - FSize), Round( Y - FSize), Round( X + FSize), Round( Y + FSize));
        if IntersectRect( aRect, aRect, bRect)
        then begin
          Pen  .Width := 1;
          Pen  .Color := ScaleColor( Colors[ FEdge ], FPosition.Z, Depth);
          Brush.Color := ScaleColor( Colors[ FColor], FPosition.Z, Depth);
          with FPosition
          do Ellipse( aRect);
        End;
      end;
    end;

    procedure   TBall.Calculate( aBox: TRealBox; aDamping, aHeat, aGravity: Real);
    var
      H : Real;
    begin
      with FPosition
      do begin
        FPosition.X := FPosition.X + FSpeed.X;
        FPosition.Y := FPosition.Y + FSpeed.Y;
        FPosition.Z := FPosition.Z + FSpeed.Z;

        with aBox
        do begin
          if FPosition.X < aBox.Point1.X
          then begin
            FPosition.X := 2 * Point1.X - FPosition.X;
            FSpeed   .X := - FSpeed.X;
          end
          else if X >= Point2.X
          then begin
            X        := 2 * Point2.X - X;
            FSpeed.X := - FSpeed.X;
          end;

          if Y < Point1.Y
          then begin
            Y        := 2 * Point1.Y - Y;
            FSpeed.Y := - FSpeed.Y;
          end
          else if Y >= Point2.Y
          then begin
            Y        := 2 * Point2.Y - Y;
            FSpeed.Y := - FSpeed.Y;
          end;

          if Z < Point1.Z
          then begin
            Z        := 2 * Point1.Z - Z;
            FSpeed.Z := - FSpeed.Z;
          end
          else if Z >= Point2.Z
          then begin
            Z        := 2 * Point2.Z - Z;
            FSpeed.Z := - FSpeed.Z;
          end;

          H := aHeat * 256 / FMass;
          FSpeed.X := ( 1 - aDamping) * ( FSpeed.X + FAccel.X / 100            ) + H - 2 * H * Random;
          FSpeed.Y := ( 1 - aDamping) * ( FSpeed.Y + FAccel.Y / 100 + aGravity ) + H - 2 * H * Random;
          FSpeed.Z := ( 1 - aDamping) * ( FSpeed.Z + FAccel.Z / 100            ) + H - 2 * H * Random;
        end;
      end;
    end;

    function    TBall.ForceDueTo( aBall: TBall): TRealPoint;
    var
      dx, dy, dz : Real;
      F          : Real;
      len        : Real;
    begin
      If Assigned( aBall)
      then begin
        dx  := FPosition.X - aBall.FPosition.X;
        dy  := FPosition.Y - aBall.FPosition.Y;
        dz  := FPosition.Z - aBall.FPosition.Z;
        F   := FormBalls.GravConst * FMass * aBall.FMass;
        len := Sqrt( dx * dx + dy * dy + dz * dz);
        if len < 1
        then Len := 0.01;
        F := F / len;

        if FColor = aBall.FColor
        then begin
          Result := RealPointZero; // No force
          Result.X := - dx * F;
          Result.Y := - dy * F;
          Result.Z := - dz * F;
        end
        // Else If Odd( Abs( FColor - aBall.FColor))
        else if Abs( FColor - aBall.FColor) < 7
        then begin
          Result.X := - dx * F; // Attractive force
          Result.Y := - dy * F;
          Result.Z := - dz * F;
        end
        else begin
          Result.X := + dx * F; // Repulsive force
          Result.Y := + dy * F;
          Result.Z := + dz * F;
        end;
      end;
    end;


Var

  BallsStorage: array of TBall;


  function CompareItems( I, J: Integer): Integer;
  begin
    if BallsStorage[ I].FPosition.Z < BallsStorage[ J].FPosition.Z
    then Result := +1
    else if BallsStorage[ I].FPosition.Z > BallsStorage[ J].FPosition.Z
    then Result := -1
    else Result :=  0;
  end;

  procedure ExchangeItems( I, J: Integer);
  var
    aBall: TBall;
  begin
    aBall := BallsStorage[ I];
    BallsStorage[ I] := BallsStorage[ J];
    BallsStorage[ J] := aBall;
  end;

  procedure SortBalls( aCount: Integer);
  begin
    QuickSort( 0, aCount - 1, CompareItems, ExchangeItems);
  end;


//  private

    procedure   TFormBalls.SetRecording( aValue: Boolean);
    const
      Txt: array[ Boolean] of string = (
        'Record',
        'Stop'
      );
    begin
      if aValue <> FRecording
      then begin
        FRecording := aValue;
        with SpeedButtonRecord
        do begin
          Down    := aValue;
          Caption := Txt[ aValue];
          case aValue of
            False : begin
                Font.Color := clRed;
                SaveMovie;
              end;
            True  : begin
                Font.Color := clWindowText;
                ClearMovie;
              end;
          end;
        end;
      end;
    end;

    procedure   TFormBalls.SetBallCount( aValue : Integer);
    begin
      if aValue <> FBallCount
      then begin
        FBallCount := aValue;
        TrackBarBallCount.Position := FBallCount;
      end;
    end;

    procedure   TFormBalls.SetSpeedRange( aValue : Real);
    begin
      if aValue <> FSpeedRange
      then begin
        FSpeedRange := aValue;
        TrackBarSpeedRange.Position := Round( FSpeedRange * 10);
      end;
    end;

    procedure   TFormBalls.SetSizeRange( aValue : Integer);
    begin
      if aValue <> FSizeRange
      then begin
        FSizeRange := aValue;
        TrackBarSizeRange.Position := FSizeRange;
      End;
    end;

    procedure   TFormBalls.SetGravity( aValue : Real);
    begin
      if aValue <> FGravity
      then begin
        FGravity := aValue;
        TrackBarGravity.Position := Round( FGravity * 1000);
      end;
    end;

    procedure   TFormBalls.SetHeat( aValue : Real);
    begin
      if aValue <> FHeat
      then begin
        FHeat := aValue;
        TrackBarHeat.Position := Round( FHeat * 10);
      end;
    end;

    procedure   TFormBalls.SetDamping( aValue : Real);
    begin
      if aValue <> FDamping
      then begin
        FDamping := aValue;
        TrackBarDamping.Position := Round( FDamping * 100);
      end;
    end;

    procedure   TFormBalls.SetGravConst( aValue : Real);
    begin
      if aValue <> FGravity
      then Begin
        FGravConst := aValue;
        TrackBarGravConst.Position := Round( FGravConst * 10000);
      end;
    end;


//  Private


const

  sSettings = 'Settings';

    procedure   TFormBalls.SaveIni;
    begin
      with TIniFile.Create( IniFileName)
      do
        try
          WriteInteger( sSettings, 'BallCount' , TrackBarBallCount .Position);
          WriteInteger( sSettings, 'SpeedRange', TrackBarSpeedRange.Position);
          WriteInteger( sSettings, 'SizeRange' , TrackBarSizeRange .Position);
          WriteInteger( sSettings, 'Gravity'   , TrackBarGravity   .Position);
          WriteInteger( sSettings, 'Heat'      , TrackBarHeat      .Position);
          WriteInteger( sSettings, 'Damping'   , TrackBarDamping   .Position);
          WriteInteger( sSettings, 'GravConst' , TrackBarGravConst .Position);
        finally
          UpdateFile;
          Free;
        end;
    end;

    procedure   TFormBalls.LoadIni;
    begin
      with TIniFile.Create( IniFileName)
      do
        try
          TrackBarBallCount .Position := ReadInteger( sSettings, 'BallCount' , TrackBarBallCount .Position);
          TrackBarSpeedRange.Position := ReadInteger( sSettings, 'SpeedRange', TrackBarSpeedRange.Position);
          TrackBarSizeRange .Position := ReadInteger( sSettings, 'SizeRange' , TrackBarSizeRange .Position);
          TrackBarGravity   .Position := ReadInteger( sSettings, 'Gravity'   , TrackBarGravity   .Position);
          TrackBarHeat      .Position := ReadInteger( sSettings, 'Heat'      , TrackBarHeat      .Position);
          TrackBarDamping   .Position := ReadInteger( sSettings, 'Damping'   , TrackBarDamping   .Position);
          TrackBarGravConst .Position := ReadInteger( sSettings, 'GravConst' , TrackBarGravConst .Position);
        finally
          Free;
        end;
    end;

    procedure   TFormBalls.ClearMovie;
    begin
      if Assigned( FBitmaps)
      then FBitmaps.Clear;
    end;

    procedure   TFormBalls.Reset;
    begin
      FFrameCounter := 0;
      FFirstTime := True;
    end;

    procedure   TFormBalls.SaveMovie;
    begin
      if Assigned( FBitmaps) and ( FBitmaps.Count > 0)
      then begin
        CreateAvi( MakeFileName([ ApplicationPath, 'tmp.avi']), FBitmaps, 18, 1);
        ClearMovie;
      end;
    end;

    procedure   TFormBalls.DoPaintBalls( aCanvas: TCanvas);
    var
      i : Integer;
    begin
      if not FFirstTime
      then begin
        // FWorm.PaintOn( aCanvas);
        // {
        SortBalls( Length( BallsStorage));
        for i := 0 to Length( BallsStorage) - 1
        do BallsStorage[ i].PaintIt( aCanvas);
        // }
      end;
    end;

    procedure   TFormBalls.InitBalls;
    var
      i : Integer;
    begin
      for i := 0 to Length( BallsStorage) - 1
      do
        if Assigned( BallsStorage[ i])
        then FreeAndNil( BallsStorage[ i]);
      SetLength( BallsStorage, BallCount);
      for i := 0 to Length( BallsStorage) - 1
      do
        BallsStorage[ i] := TBall.Create(
          RealPoint(
            Width  * Random,
            Height * Random,
            Depth  * Random
          ),
          RealPoint(
            SpeedRange - 2 * SpeedRange * Random,
            SpeedRange - 2 * SpeedRange * Random,
            SpeedRange - 2 * SpeedRange * Random
          ),
          Random( CColors),
          Random( CColors),
          1 + Random( SizeRange)
          // 1 + 4 * Random( SizeRange Div 4 + 1)
        );
    end;

    procedure   TFormBalls.InvalidateBalls;
    var
      i     : Integer;
      aBall : TBall;
      aRect : TRect;
      bRect : TRect;
      aBox  : TRealBox;
    begin
      if not FFirstTime
      then begin
        aRect := PanelBalls.ClientRect;
        aBox  := RealBox( RealPoint( 0, 0, 0), RealPoint( aRect.Right, aRect.Bottom, Depth));
        CalcForces;
        for i := 0 to Length( BallsStorage) - 1
        do begin
          aBall := BallsStorage[ i];
          with aBall, FPosition
          do bRect := Rect(  Round( X - FSize - 1), Round( Y - FSize - 1), Round( X + FSize + 1), Round( Y + FSize + 1));
          InvalidateRect( PanelBalls.Handle, @ bRect, True);

          BallsStorage[ i].Calculate( aBox, Damping, Heat, Gravity);

          with aBall, FPosition
          do bRect := Rect(  Round( X - FSize), Round( Y - FSize), Round( X + FSize), Round( Y + FSize));
          InvalidateRect( PanelBalls.Handle, @ bRect, True);
        end;
      end;
      {
      if FFrameCounter mod 1 = 0
      then begin
        FWorm.Mutate;
        PaintBox.Invalidate;
      end;
      }
      Inc( FFrameCounter);
    end;

    procedure   TFormBalls.CalcForces;
    var
      i : Integer;
      j : Integer;
    begin
      for i := 0 to Length( BallsStorage) - 1
      do
        with BallsStorage[ i ]
        do begin
          FForce := RealPointZero;
          for j := 0 to Length( BallsStorage) - 1
          do
            if i <> j
            then FForce := AddRealPoints( FForce, BallsStorage[ i].ForceDueTo( BallsStorage[ j]));
          FAccel.X := FForce.X / FMass;
          FAccel.Y := FForce.Y / FMass;
          FAccel.Z := FForce.Z / FMass;
        end;
    end;


    function    TFormBalls.MakeBitmap: TBitmap;
    begin
      Result := TBitmap.Create;
      with Result
      do begin
        PixelFormat := pf8bit;
        Width       := PaintBox.Width;
        Height      := PaintBox.Height;
        Result.Canvas.CopyRect( Rect( 0, 0, Width, Height), PaintBox.Canvas, PaintBox.ClientRect);
      end;
    end;



// Delphi area



procedure TFormBalls.PaintBoxPaint(Sender: TObject);
begin
  DoPaintBalls(( Sender As TPaintBox).Canvas);
  if recording
  then FBitmaps.AddBitmap( MakeBitmap);
end;

procedure TFormBalls.Timer1Timer(Sender: TObject);
begin
  If FFirstTime
  Then Begin
    FFirstTime := False;
    InitBalls;
    FWorm.FillRandom;
    Timer1.Interval := 55;
  End;
  InvalidateBalls;
  LabelFrameCounter.Caption := IntToStr( FBitmaps.Count);
end;

procedure TFormBalls.FormCreate(Sender: TObject);
begin
  FRecording   := True; Recording := False;
  FFirstTime   := True;
  FBitmaps     := TBitmapList.Create;
  // WindowState := wsMaximized;
  PanelBalls.DoubleBuffered := True;
  Randomize;
  FWorm := TWorm.Create;
end;

procedure TFormBalls.FormDestroy(Sender: TObject);
Var
  i : Integer;
begin
  For i := 0 To Length( BallsStorage) - 1 Do
    FreeAndNil( BallsStorage[ i]);
  FBitmaps.Free;
  FWorm.Free;
end;

procedure TFormBalls.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  // Close;
  // WindowState := wsNormal;
end;

procedure TFormBalls.FormShow(Sender: TObject);
begin
  with FWorm
  do begin
    Transparent         := True;
    Width               := PaintBox.Width;
    Height              := PaintBox.Height;
    Clearance           := 10;
    BorderColor         := clBlack;
    BackColor           := PaintBox.Color;
    PenColor            := clGray;
    DrawLines           := True;
    DotSize             := 25;
    LineSize            := 3;
    Clearance           := DotSize + 10;
    MutationRange       := 5;
    MutationProbability := 50;
    Size                := 3;
  end;
  BallCount  := 63;
  SpeedRange := 0.1;
  SizeRange  := 8;
  Gravity    := 0.000;
  Heat       := 0.001;
  Damping    := 0.050;
  GravConst  := 0.020;
  LoadIni;
  Timer1.Enabled := True;
  // ShowCursor( False);
end;

procedure TFormBalls.FormHide(Sender: TObject);
begin
  Timer1.Enabled := False;
  FFirstTime := True;
  // ShowCursor( True);
end;

procedure TFormBalls.BitBtnExitClick(Sender: TObject);
begin
  if Recording
  then SaveMovie;
  Close;
end;

procedure TFormBalls.BitBtnResetClick(Sender: TObject);
begin
  Reset;
end;

procedure TFormBalls.SpeedButtonRecordClick(Sender: TObject);
begin
  Recording := SpeedButtonRecord.Down;
end;

procedure TFormBalls.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SaveIni;
end;

procedure TFormBalls.TrackBarBallCountChange(Sender: TObject);
begin
  BallCount := TrackBarBallCount.Position;
end;

procedure TFormBalls.TrackBarSpeedRangeChange(Sender: TObject);
begin
  SpeedRange := TrackBarSpeedRange.Position / 10;
end;

procedure TFormBalls.TrackBarSizeRangeChange(Sender: TObject);
begin
  SizeRange := TrackBarSizeRange.Position;
end;

procedure TFormBalls.TrackBarGravityChange(Sender: TObject);
begin
  Gravity := TrackBarGravity.Position / 1000;
end;

procedure TFormBalls.TrackBarHeatChange(Sender: TObject);
begin
  Heat := TrackBarHeat.Position / 10;
end;

procedure TFormBalls.TrackBarDampingChange(Sender: TObject);
begin
  Damping := TrackBarDamping.Position / 100;
end;

procedure TFormBalls.TrackBarGravConstChange(Sender: TObject);
begin
  GravConst := TrackBarGravConst.Position / 10000;
end;

end.