Draw antialiased circles

Problem/Question/Abstract:

How to draw antialiased circles

Answer:

This demo program shows how to draw circles with configurable antialiasing. The DrawCircle and DrawDisk routines are optimized quite well but do not claim to be the fastest solution :) It is a floating point precision implementation. Further optimisation would be possible if an integer approach was chosen (but that would also loose functionality).

unit DrawCirclesMain;

interface

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

type
  TForm1 = class(TForm)
    btnDrawCircle: TButton;
    edBitmapWidth: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    edBitmapHeight: TEdit;
    Label3: TLabel;
    edCenterX: TEdit;
    Label4: TLabel;
    edCenterY: TEdit;
    Label5: TLabel;
    edRadius: TEdit;
    Label6: TLabel;
    edFeather: TEdit;
    cpbColor: TColorPickerButton;
    Label7: TLabel;
    cpbBackgr: TColorPickerButton;
    Label8: TLabel;
    rbDrawCircle: TRadioButton;
    rbDrawDisk: TRadioButton;
    Label9: TLabel;
    edLineWidth: TEdit;
    ScrollBox1: TScrollBox;
    imMain: TImage;
    btnExportBitmap: TButton;
    procedure btnDrawCircleClick(Sender: TObject);
    procedure btnExportBitmapClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

  {Draw a circle on Bitmap - see comments in implementation}
procedure DrawCircle(Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather:
  single);

{Draw a disk on Bitmap - see comments in implementation}
procedure DrawDisk(Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: single);

implementation

{$R *.DFM}

procedure DrawDisk(Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: single);

{Draw a disk on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap, and parts outside the disk will get palette index 0, parts inside will get palette index 255, and in the antialiased area (feather), the pixels will get values in between.

Parameters:

Bitmap:
The bitmap to draw on

CenterX, CenterY:
The center of the disk (float precision). Note that [0, 0] would be the center of the first pixel. To draw in the exact middle of a 100x100 bitmap,  use CenterX = 49.5 and CenterY = 49.5

Radius:
The radius of the drawn disk in pixels (float precision)

Feather:
The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2' become 255. Using a value of 0 will yield a bilevel
image.

Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl}

var
  x, y: integer;
  LX, RX, LY, RY: integer;
  Fact: integer;
  RPF2, RMF2: single;
  P: PByteArray;
  SqY, SqDist: single;
  sqX: array of single;
begin
  {Determine some helpful values (singles)}
  RPF2 := sqr(Radius + Feather / 2);
  RMF2 := sqr(Radius - Feather / 2);
  {Determine bounds:}
  LX := Max(floor(CenterX - RPF2), 0);
  RX := Min(ceil(CenterX + RPF2), Bitmap.Width - 1);
  LY := Max(floor(CenterY - RPF2), 0);
  RY := Min(ceil(CenterY + RPF2), Bitmap.Height - 1);
  {Optimization run: find squares of X first}
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x - LX] := sqr(x - CenterX);
  {Loop through Y values}
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    {Loop through X values}
    for x := LX to RX do
    begin
      {Determine squared distance from center for this pixel}
      SqDist := SqY + SqX[x - LX];
      {Inside inner circle? Most often...}
      if sqdist < RMF2 then
      begin
        {Inside the inner circle.. just give the scanline the new color}
        P[x] := 255
      end
      else
      begin
        {Inside outer circle?}
        if sqdist < RPF2 then
        begin
          {We are inbetween the inner and outer bound, now mix the color}
          Fact := round(((Radius - sqrt(sqdist)) * 2 / Feather) * 127.5 + 127.5);
          P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
        end
        else
        begin
          P[x] := 0;
        end;
      end;
    end;
  end;
end;

procedure DrawCircle(Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather:
  single);

{Draw a circle on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap, and parts outside the circle will get palette index 0, parts inside will get palette index 255, and in the antialiased area (feather), the pixels will get values inbetween.

Parameters:

Bitmap:
The bitmap to draw on

CenterX, CenterY:
The center of the circle (float precision). Note that [0, 0] would be the center of the first pixel. To draw in the exact middle of a 100x100 bitmap, use CenterX = 49.5 and CenterY = 49.5

Radius:
The radius of the drawn circle in pixels (float precision)

LineWidth:
The line width of the drawn circle in pixels (float precision)

Feather:
The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2' become 255. Using a value of 0 will yield a bilevel image. Note that Feather must be equal or smaller than LineWidth (or it will be adjusted internally)

Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl}

var
  x, y: integer;
  LX, RX, LY, RY: integer;
  Fact: integer;
  ROPF2, ROMF2, RIPF2, RIMF2: single;
  OutRad, InRad: single;
  P: PByteArray;
  SqY, SqDist: single;
  sqX: array of single;
begin
  {Determine some helpful values (singles)}
  OutRad := Radius + LineWidth / 2;
  InRad := Radius - LineWidth / 2;
  ROPF2 := sqr(OutRad + Feather / 2);
  ROMF2 := sqr(OutRad - Feather / 2);
  RIPF2 := sqr(InRad + Feather / 2);
  RIMF2 := sqr(InRad - Feather / 2);
  {Determine bounds:}
  LX := Max(floor(CenterX - ROPF2), 0);
  RX := Min(ceil(CenterX + ROPF2), Bitmap.Width - 1);
  LY := Max(floor(CenterY - ROPF2), 0);
  RY := Min(ceil(CenterY + ROPF2), Bitmap.Height - 1);
  {Checks}
  if Feather > LineWidth then
    Feather := LineWidth;
  {Optimization run: find squares of X first}
  SetLength(SqX, RX - LX + 1);
  for x := LX to RX do
    SqX[x - LX] := sqr(x - CenterX);
  {Loop through Y values}
  for y := LY to RY do
  begin
    P := Bitmap.Scanline[y];
    SqY := Sqr(y - CenterY);
    {Loop through X values}
    for x := LX to RX do
    begin
      {Determine squared distance from center for this pixel}
      SqDist := SqY + SqX[x - LX];
      {Now first check if we're completely inside (most often)}
      if SqDist < RIMF2 then
      begin
        {We're on the disk inside everything}
        P[x] := 0;
      end
      else
      begin
        {Completely outside?}
        if SqDist < ROPF2 then
        begin
          {Inside outer line - feather?}
          if SqDist < ROMF2 then
          begin
            {Check if we're in inside feather area}
            if SqDist < RIPF2 then
            begin
              {We are in the feather area of inner line, now mix the color}
              Fact := round(((sqrt(sqdist) - InRad) * 2 / Feather) * 127.5 + 127.5);
              P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
            end
            else
            begin
              {On the line}
              P[x] := 255;
            end;
          end
          else
          begin
            {We are in the feather area of outer line, now mix the color}
            Fact := round(((OutRad - sqrt(sqdist)) * 2 / Feather) * 127.5 + 127.5);
            P[x] := Max(0, Min(Fact, 255)); {just in case limit to [0, 255]}
          end;
        end
        else
        begin
          {Outside everything}
          P[x] := 0;
        end;
      end;
    end;
  end;
end;

procedure TForm1.btnDrawCircleClick(Sender: TObject);
{Create a 256-color bitmap and call the DrawCircle procedure}
var
  i, y: integer;
  ABitmap: TBitmap;
  pal: PLogPalette;
  hpal: HPALETTE;
  ColRGB, BgrRGB: integer;
  ACenterX, ACenterY,
    ARadius, AFeather,
    ALineWidth: single;
begin
  ABitmap := TBitmap.Create;
  try
    {8 bits per pixel}
    ABitmap.PixelFormat := pf8bit;
    {Set width and height}
    ABitmap.Width := StrToInt(edBitmapWidth.Text);
    ABitmap.Height := StrToInt(edBitmapHeight.Text);
    {Create a gradient palette between foreground and background color}
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    try
      pal.palVersion := $300;
      pal.palNumEntries := 256;
      ColRGB := ColorToRGB(cpbColor.SelectionColor);
      BgrRGB := ColorToRGB(cpbBackgr.SelectionColor);
      for i := 0 to 255 do
      begin
        pal.palPalEntry[i].peRed := round(i / 255 * (ColRGB and $FF) + (255 - i) / 255
          * (BgrRGB and $FF));
        pal.palPalEntry[i].peGreen := round(i / 255 * (ColRGB shr 8 and $FF) +
          (255 - i) / 255 * (BgrRGB shr 8 and $FF));
        pal.palPalEntry[i].peBlue := round(i / 255 * (ColRGB shr 16 and $FF) +
          (255 - i) / 255 * (BgrRGB shr 16 and $FF));
      end;
      hpal := CreatePalette(pal^);
      if hpal <> 0 then
        ABitmap.Palette := hpal;
    finally
      FreeMem(pal);
    end;
    {Fill bitmap with background color}
    for y := 0 to ABitmap.Height - 1 do
      FillChar(ABitmap.Scanline[y]^, ABitmap.Width, 0);
    {Get data from form}
    ACenterX := StrToFloat(edCenterX.Text);
    ACenterY := StrToFloat(edCenterY.Text);
    ARadius := StrToFloat(edRadius.Text);
    ALineWidth := StrToFloat(edLineWidth.Text);
    AFeather := StrToFloat(edFeather.Text);
    {Draw the circle}
    if rbDrawCircle.Checked then
      DrawCircle(ABitmap, ACenterX, ACenterY, ARadius, ALineWidth, AFeather)
    else
      DrawDisk(ABitmap, ACenterX, ACenterY, ARadius, AFeather);
    {Assign to image}
    imMain.Picture.Bitmap.Assign(ABitmap);
    btnExportBitmap.Enabled := True;
  finally
    ABitmap.Free;
  end;
end;

procedure TForm1.btnExportBitmapClick(Sender: TObject);
begin
  with TSaveDialog.Create(nil) do
  begin
    try
      Title := 'Export bitmap';
      Filter := 'Bitmap files (*.bmp)|*.bmp';
      if Execute then
        imMain.Picture.Bitmap.SaveToFile(FileName);
    finally
      Free;
    end;
  end;
end;

end.