[Resolvido] MetaBalls

[Sérgio_BR 0]

Alô, galera!!!!

 

Encontrei este código...testei e funcionou...não sei se interessa prá alguém...mas l´´a vai:

 

unit MetaBalls;

 

interface

 

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ExtCtrls;

 

type

TForm1 = class(TForm)

Timer1: TTimer;

procedure Timer1Timer(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure FormShow(Sender: TObject);

private

{ Private declarations }

public

procedure SetupMetaBallSystem;

procedure DrawMetaBalls;

{ Public declarations }

end;

TMetaBall = class

private

{ Private declarations }

FX, FY: Integer;

FDx, FDy: Integer;

FRadius: Integer;

public

{ Public declarations }

constructor Create;

destructor Destroy; override;

procedure SetRadius(Radius: Integer);

procedure SetPos(x, y: Integer);

procedure SetDeltaXY(dx, dy: Integer);

procedure Update;

function GetIntensity(x, y: Integer): Double;

function PointIsInside(x, y: Integer): Boolean;

function GetBoundingRect: TRect;

end;

 

TMetaBallSystem = class

private

{ Private declarations }

FThreshold: Double;

FBlockRes: Integer;

FCurrentIntensity: Double;

FCurrentCount: Integer;

FMetaBallList: array of TMetaBall;

public

{ Public declarations }

constructor Create;

destructor Destroy; override;

procedure SetThreshold(Threshold: Double);

procedure SetBlockRes(BlockRes: Integer);

procedure AddMetaBall(x, y, Radius, dx, dy: Integer);

procedure Update;

function GetBlockRes: Integer;

function Count: Integer;

function GetMetaBallBoundingRect(Index: Integer): TRect;

function GetIntensity: Double;

function PointIsInside(x, y: Integer): Boolean;

procedure Clear;

property CurrentCount: Integer read FCurrentCount write FCurrentCount;

end;

 

var

Form1: TForm1;

MetaBitmap: TBitmap;

UsedBitmap: TBitmap;

MetaBallSystem: TMetaBallSystem;

IntensityTable: array[0..255] of Double;

 

implementation

 

{$R *.dfm}

 

procedure TForm1.Timer1Timer(Sender: TObject);

begin

DrawMetaBalls;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

var

i: Integer;

begin

Timer1 := TTimer.Create(nil);

Timer1.OnTimer := Timer1Timer;

Timer1.Interval := 50;

for i := 0 to 255 do

IntensityTable := (Cos(i * PI / 255) + 1) / 2;

MetaBitmap := TBitmap.Create;

MetaBitmap.Width := ClientWidth;

MetaBitmap.Height := ClientHeight;

MetaBitmap.PixelFormat := pf15Bit;

UsedBitmap := TBitmap.Create;

UsedBitmap.Width := ClientWidth;

UsedBitmap.Height := ClientHeight;

UsedBitmap.PixelFormat := pf8Bit;

MetaBallSystem := TMetaBallSystem.Create;

SetupMetaBallSystem;

 

end;

 

procedure TForm1.FormDestroy(Sender: TObject);

begin

Timer1.Enabled := False;

MetaBallSystem.Clear;

FreeAndNil(UsedBitmap);

FreeAndNil(MetaBitmap);

FreeAndNil(MetaBallSystem);

FreeAndNil(Timer1);

end;

procedure TForm1.SetupMetaBallSystem;

var

i: Integer;

x, y, r, dx, dy: Integer;

begin

Randomize;

MetaBallSystem.Clear;

MetaBallSystem.SetThreshold(0.4);

for i := 1 to 5 do

begin

x := Random(ClientWidth);

y := Random(ClientHeight);

r := (Random(50) + 50);

x := x + Ord((x - r) < 0) * r;

y := y + Ord((y - r) < 0) * r;

x := x - Ord((x + r) >= ClientWidth) * r;

y := y - Ord((y + r) >= ClientHeight) * r;

dx := Random(11) - 5;

dy := Random(11) - 5;

MetaBallSystem.AddMetaBall(x, y, r, dx, dy);

end;

end;

constructor TMetaBall.Create;

begin

inherited Create;

FDx := 0;

FDy := 0;

end;

 

destructor TMetaBall.Destroy;

begin

inherited Destroy;

end;

 

procedure TMetaBall.SetRadius(Radius: Integer);

begin

FRadius := Radius;

end;

 

procedure TMetaBall.SetPos(x, y: Integer);

begin

FX := x;

FY := y;

end;

 

procedure TMetaBall.SetDeltaXY(dx, dy: Integer);

begin

FDx := dx;

FDy := dy;

end;

 

procedure TMetaBall.Update;

var

r: TRect;

begin

Inc(FX, FDx);

Inc(FY, FDy);

r := GetBoundingRect;

if (r.Left < 0) then

begin

Inc(FX, 0 - r.Left);

FDx := -FDx;

end;

if (r.Bottom < 0) then

begin

Inc(FY, 0 - r.Bottom);

FDy := -FDy;

end;

if (r.Right >= Form1.ClientWidth) then

begin

Dec(FX, r.Right - Form1.ClientWidth);

FDx := -FDx;

end;

if (r.Top >= Form1.ClientHeight) then

begin

Dec(FY, r.Top - Form1.ClientHeight);

FDy := -FDy;

end;

end;

 

function TMetaBall.GetBoundingRect: TRect;

begin

Result := Rect(FX - FRadius, FY + FRadius, FX + FRadius, FY - FRadius);

end;

 

function TMetaBall.GetIntensity(x, y: Integer): Double;

var

d: Integer;

begin

Result := 0;

d := Trunc(Sqrt((FX - x) * (FX - x) + (FY - y) * (FY - y)) * 255 / FRadius);

if (d > 255) then

Exit;

Result := IntensityTable[d];

end;

 

function TMetaBall.PointIsInside(x, y: Integer): Boolean;

var

xxyy: Integer;

begin

xxyy := (FX - x) * (FX - x) + (FY - y) * (FY - y);

Result := (FRadius <> 0) and (xxyy <= (FRadius * FRadius));

end;

 

constructor TMetaBallSystem.Create;

begin

SetLength(FMetaBallList, 0);

end;

 

destructor TMetaBallSystem.Destroy;

var

i: Integer;

begin

for i := 0 to High(FMetaBallList) do

if (FMetaBallList <> nil) then

FreeAndNil(FMetaBallList);

SetLength(FMetaBallList, 0);

end;

 

procedure TMetaBallSystem.Update;

var

i: Integer;

begin

for i := 0 to High(FMetaBallList) do

if (FMetaBallList <> nil) then

FMetaBallList.Update;

end;

 

procedure TMetaBallSystem.SetThreshold(Threshold: Double);

begin

FThreshold := Threshold;

end;

 

procedure TMetaBallSystem.SetBlockRes(BlockRes: Integer);

var

Size: Double;

begin

Size := ln(BlockRes) / ln(2);

if (Frac(Size) > 0) then

FBlockRes := 1 shl Trunc(Size + 1)

else

FBlockRes := 1 shl Trunc(Size);

end;

 

function TMetaBallSystem.GetBlockRes: Integer;

begin

Result := FBlockRes;

end;

 

procedure TMetaBallSystem.AddMetaBall(x, y, Radius, dx, dy: Integer);

begin

SetLength(FMetaBallList, High(FMetaBallList) + 2);

FMetaBallList[High(FMetaBallList)] := TMetaBall.Create;

FMetaBallList[High(FMetaBallList)].FX := x;

FMetaBallList[High(FMetaBallList)].FY := y;

FMetaBallList[High(FMetaBallList)].FDx := dx;

FMetaBallList[High(FMetaBallList)].FDy := dy;

FMetaBallList[High(FMetaBallList)].FRadius := Radius;

end;

 

function TMetaBallSystem.Count: Integer;

begin

Result := High(FMetaBallList) + 1;

end;

 

function TMetaBallSystem.GetMetaBallBoundingRect(Index: Integer): TRect;

begin

Result := Rect(-1, -1, -1, -1);

if (Index < 0) or (Index > High(FMetaBallList)) then

Exit;

Result := FMetaBallList[index].GetBoundingRect;

end;

 

function TMetaBallSystem.PointIsInside(x, y: Integer): Boolean;

var

i: Integer;

r: Double;

c: Integer;

begin

r := 0;

c := 0;

for i := 0 to High(FMetaBallList) do

begin

if (FMetaBallList.PointIsInside(x, y)) then

begin

r := r + FMetaBallList.GetIntensity(x, y);

Inc©;

end;

end;

FCurrentCount := c;

FCurrentIntensity := r;

Result := (FCurrentIntensity >= FThreshold);

end;

 

function TMetaBallSystem.GetIntensity: Double;

begin

Result := FCurrentIntensity;

end;

 

procedure TMetaBallSystem.Clear;

var

i: Integer;

begin

for i := 0 to High(FMetaBallList) do

if (FMetaBallList <> nil) then

FreeAndNil(FMetaBallList);

SetLength(FMetaBallList, 0);

end;

 

procedure TForm1.DrawMetaBalls;

type

PRGBTriple = ^TRGBTriple;

TRGBTriple = array[word] of record

b, g, r: Byte;

end;

var

x, y, i: Integer;

Pixel: PWordArray;

UsedPixel: PByteArray;

r: TRect;

c: Byte;

begin

MetaBitmap.Width := ClientWidth;

MetaBitmap.Height := ClientHeight;

MetaBitmap.PixelFormat := pf15Bit;

MetaBitmap.Canvas.Brush.Color := RGB(0, 0, 0);

MetaBitmap.Canvas.Pen.Color := RGB(0, 255, 0);

MetaBitmap.Canvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));

UsedBitmap.Width := ClientWidth;

UsedBitmap.Height := ClientHeight;

UsedBitmap.PixelFormat := pf8Bit;

for y := 0 to ClientHeight - 1 do

begin

UsedPixel := UsedBitmap.ScanLine[y];

for x := 0 to ClientWidth - 1 do

UsedPixel[x] := 0;

end;

for i := 0 to MetaBallSystem.Count - 1 do

begin

r := MetaBallSystem.GetMetaBallBoundingRect(i);

if (r.Left < 0) then

r.Left := 0;

if (r.Bottom < 0) then

r.Bottom := 0;

if (r.Right >= ClientWidth) then

r.Right := ClientWidth - 1;

if (r.Top >= ClientHeight) then

r.Top := ClientHeight - 1;

for y := r.Bottom to r.Top do

begin

Pixel := MetaBitmap.ScanLine[y];

UsedPixel := UsedBitmap.ScanLine[y];

for x := r.Left to r.Right do

begin

if (UsedPixel[x] = 0) then

begin

if (MetaBallSystem.PointIsInside(x, y)) then

begin

c := Trunc(31 * MetaBallSystem.GetIntensity);

if (c > 31) then

c := 31;

Pixel[x] := (c shl 5);

UsedPixel[x] := 1;

end;

end;

end;

end;

end;

Canvas.Draw(0, 0, MetaBitmap);

MetaBallSystem.Update;

end;

procedure TForm1.FormShow(Sender: TObject);

begin

Timer1.Enabled := True;

end;

 

end.