A 'MetaBalls' Demo

Problem/Question/Abstract:

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.