A ‘MetaBalls’ Demo

Answer

I’ve been tinkering around with MetaBalls and have made a demo program. To use it just create a new project, save the form as MetaBallsForm and replace the form code with the code below.

unit MetaBallsForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Timer1: TTimer;
procedure SetupMetaBallSystem;
procedure DrawMetaBalls;
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.FormCreate(Sender: TObject);
var
i: Integer;
begin
Timer1 := TTimer.Create(nil);
Timer1.OnTimer := Timer1Timer;
Timer1.Interval := 50;
for i := 0 to 255 do
IntensityTable[i] := (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[i] <> nil) then
FreeAndNil(FMetaBallList[i]);
SetLength(FMetaBallList, 0);
end;

procedure TMetaBallSystem.Update;
var
i: Integer;
begin
for i := 0 to High(FMetaBallList) do
if (FMetaBallList[i] <> nil) then
FMetaBallList[i].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[i].PointIsInside(x, y)) then
begin
r := r + FMetaBallList[i].GetIntensity(x, y);
Inc(c);
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[i] <> nil) then
FreeAndNil(FMetaBallList[i]);
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.Timer1Timer(Sender: TObject);
begin
DrawMetaBalls;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled := True;
end;

end.