Draw 32 Bit Sphere

uses Types, SysUtils

type
	TBMPinfos  = record
  	Sc0,
    BpL,
    BpP,
    Wth,
    Hht: Integer;
end;

//

function GetBMPinfos(const BMP: TBitmap; var BMPinfos : TBMPinfos): Boolean;
	begin
  Result := true;
  if Assigned(BMP) then begin
    with BMPinfos, BMP do begin
      Wth   := Width;
  	  Hht   := Height;
      if (Wth=0) or (Hht=0) then begin
        ShowMessage('The BitMap has dimension equal to zero!');
        Result := false;
        Exit;
      end;
      case BMP.PixelFormat of
        pf24bit : BpP := 3;
        pf32bit	: BpP := 4;
        else  begin
                ShowMessage('Bitmap format is not supported !');
                Result := false;
                Exit;
      end;    end;
  	  BpL := (((Wth * BpP shl 3) + 31) and -31) shr 3;
      Sc0 := Integer(ScanLine[0]);
      if Sc0-Integer(ScanLine[1])<0 then begin
        ShowMessage('Top-Down DIB not supported !'#13#10'(Bottom-Up DIB only)');
    	  Result := false;
    	  Exit;
      end;
    end;  end
  else begin
    ShowMessage('Bitmap is not assigned !');
    Result := false;
  end;
end;

procedure TForm1.Reset;
  begin
  with image1.Picture.Bitmap.Canvas do FillRect(ClipRect);
  Button1.Caption := 'Gradient on Canvas'   + #13#10 + 'Click to perf''';
  Button1.Tag := 9999999;
  Button2.Caption := 'Degraded in memory' + #13#10 + 'Click to perf''';
  Button2.Tag := 9999999;
end;


procedure TForm1.FormCreate(Sender: TObject);
	begin
  DoubleBuffered  := true;
  Width           := 393;
  Height          := 450;
  Image1.Align    := alClient;
	with Image1.Picture.Bitmap do begin
  	Width         := Image1.Width;
  	Height        := Image1.Height;
    PixelFormat   := pf24bit;
	end;
  Reset;
end;


procedure TForm1.FormResize(Sender: TObject);
  begin
  with Image1 do begin
    Picture.Bitmap.Width  := Width;
    Picture.Bitmap.Height := Height;
  end;
  Reset;
end;

procedure DrawAndresCircle(Canv: TCanvas; Cx,Cy,R,Col: Integer); overload;
	var     X, Y, D : Integer;
          Wth,Hht : Integer;
  begin
  if R<= 0 then Exit;
  with Canv.ClipRect do begin
    Wth := Right  - Left;
    Hht := Bottom - Top ;
  end;
	X   := 0;
	Y   := R;
	D   := R-1;
  while Y >= X do begin

  {
    Canv.Pixels[Cx+X, Cy+Y] := Col;
    Canv.Pixels[Cx+Y, Cy+X] := Col;
    Canv.Pixels[Cx-X, Cy+Y] := Col;
    Canv.Pixels[Cx-Y, Cy+X] := Col;
    Canv.Pixels[Cx+X, Cy-Y] := Col;
    Canv.Pixels[Cx+Y, Cy-X] := Col;
    Canv.Pixels[Cx-X, Cy-Y] := Col;
    Canv.Pixels[Cx-Y, Cy-X] := Col;
  }

    if (Cx+X>=0) and (Cy+Y>=0) and (Cx+X<Wth) and (Cy+Y<Hht) then SetPixelV(Canv.Handle,Cx+X,Cy+Y,Col);
    if (Cx+Y>=0) and (Cy+X>=0) and (Cx+Y<Wth) and (Cy+X<Hht) then SetPixelV(Canv.Handle,Cx+Y,Cy+X,Col);
    if (Cx-X>=0) and (Cy+Y>=0) and (Cx-X<Wth) and (Cy+Y<Hht) then SetPixelV(Canv.Handle,Cx-X,Cy+Y,Col);
    if (Cx-Y>=0) and (Cy+X>=0) and (Cx-Y<Wth) and (Cy+X<Hht) then SetPixelV(Canv.Handle,Cx-Y,Cy+X,Col);
    if (Cx+X>=0) and (Cy-Y>=0) and (Cx+X<Wth) and (Cy-Y<Hht) then SetPixelV(Canv.Handle,Cx+X,Cy-Y,Col);
    if (Cx+Y>=0) and (Cy-X>=0) and (Cx+Y<Wth) and (Cy-X<Hht) then SetPixelV(Canv.Handle,Cx+Y,Cy-X,Col);
    if (Cx-X>=0) and (Cy-Y>=0) and (Cx-X<Wth) and (Cy-Y<Hht) then SetPixelV(Canv.Handle,Cx-X,Cy-Y,Col);
    if (Cx-Y>=0) and (Cy-X>=0) and (Cx-Y<Wth) and (Cy-X<Hht) then SetPixelV(Canv.Handle,Cx-Y,Cy-X,Col);

    if D >= X+X then begin
       D := D-X-X-1;
       Inc(X);       end
    else  if D <= R+R-Y-Y then begin
             D := D+Y+Y-1;
             Dec(Y);           end
          else begin
             D := D+Y+Y-X-X-2;
             Dec(Y);
             Inc(X);
    end;
  end;
end;

procedure DrawAndresCircle(Bmp: TBMPinfos; Cx,Cy,R: Integer; Col: TRGBTriple); overload;
	var     X, Y, D : Integer;
  begin
  if R<=0 then Exit;
	X := 0;
	Y := R;
	D := R-1;
  with Bmp do begin
    while Y >= X do begin
      if (Cx+X>=0) and (Cy+Y>=0) and (Cx+X<Wth) and (Cy+Y<Hht) then pRGBTriple(Sc0 - (Cy+Y)*BpL + (Cx+X)*BpP)^ := Col;
      if (Cx+Y>=0) and (Cy+X>=0) and (Cx+Y<Wth) and (Cy+X<Hht) then pRGBTriple(Sc0 - (Cy+X)*BpL + (Cx+Y)*BpP)^ := Col;
      if (Cx-X>=0) and (Cy+Y>=0) and (Cx-X<Wth) and (Cy+Y<Hht) then pRGBTriple(Sc0 - (Cy+Y)*BpL + (Cx-X)*BpP)^ := Col;
      if (Cx-Y>=0) and (Cy+X>=0) and (Cx-Y<Wth) and (Cy+X<Hht) then pRGBTriple(Sc0 - (Cy+X)*BpL + (Cx-Y)*BpP)^ := Col;
      if (Cx+X>=0) and (Cy-Y>=0) and (Cx+X<Wth) and (Cy-Y<Hht) then pRGBTriple(Sc0 - (Cy-Y)*BpL + (Cx+X)*BpP)^ := Col;
      if (Cx+Y>=0) and (Cy-X>=0) and (Cx+Y<Wth) and (Cy-X<Hht) then pRGBTriple(Sc0 - (Cy-X)*BpL + (Cx+Y)*BpP)^ := Col;
      if (Cx-X>=0) and (Cy-Y>=0) and (Cx-X<Wth) and (Cy-Y<Hht) then pRGBTriple(Sc0 - (Cy-Y)*BpL + (Cx-X)*BpP)^ := Col;
      if (Cx-Y>=0) and (Cy-X>=0) and (Cx-Y<Wth) and (Cy-X<Hht) then pRGBTriple(Sc0 - (Cy-X)*BpL + (Cx-Y)*BpP)^ := Col;

      if D >= X+X then begin
         D := D-X-X-1;
         Inc(X);       end
      else  if D <= R+R-Y-Y then begin
               D := D+Y+Y-1;
               Dec(Y);           end
            else begin
               D := D+Y+Y-X-X-2;
               Dec(Y);
               Inc(X);
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
  var     Btn           : TButton absolute Sender;
          Gris, R       : Integer;
          Col           : TColor;
          Start,Elapsed : Int64;
          Times         : Integer;
          PtO           : TPoint;
  begin
  with image1.Picture.Bitmap.Canvas do FillRect(ClipRect);
  PtO := CenterPoint(Image1.BoundsRect);
  image1.Picture.Bitmap.Canvas.TextOut(1, Image1.Height-40, 'Blocking treatment that can last several seconds.');
  image1.Picture.Bitmap.Canvas.TextOut(1, Image1.Height-20, 'WAIT !');
  image1.Refresh;
  Start := GetTickCount;
  for Times := 1 to StrToInt(Edit1.Text) do begin
    Gris := 256;
    for R := 1 to Round(Sqrt(Image1.Width*Image1.Width + Image1.Height*Image1.Height)) do begin
      Dec(Gris);
      Col := RGB(Gris,Gris,Gris);
      DrawAndresCircle(Image1.Picture.Bitmap.Canvas, PtO.X, PtO.Y, R, Col);
    end;
  end;
  Elapsed := GetTickCount-Start;
  if Btn.Tag>Elapsed then begin
    Btn.Tag     := Elapsed;
    Btn.Caption := 'Gradient on Canvas' + #13#10 + Format('Temps mini :  %.0n ms',[Elapsed/1]);
  end;
  Image1.Refresh;
end;


procedure TForm1.Button2Click(Sender: TObject);
  var     Btn           : TButton absolute Sender;
          Gris,R        : Integer;
          Col           : TRGBTriple;
          Start,Elapsed : Int64;
          Times         : Integer;
          PtO           : TPoint;
          Bmp           : TBMPinfos;
  begin
  if not GetBMPinfos(Image1.Picture.Bitmap, Bmp) then Exit;
  with image1.Picture.Bitmap.Canvas do FillRect(ClipRect);
  image1.Refresh;
  Start := GetTickCount;
  for Times := 1 to StrToInt(Edit1.Text) do begin
    PtO := CenterPoint(Image1.BoundsRect);
    Gris := 256;
    for R := 1 to Round(Sqrt(Bmp.Wth*Bmp.Wth + Bmp.Wth*Bmp.Hht)) do begin
      Dec(Gris);
      with Col do begin
  	    rgbtRed   := Gris;
        rgbtGreen := Gris;
        rgbtBlue  := Gris;
      end;
      DrawAndresCircle(Bmp, PtO.X, PtO.Y, R, Col);
    end;
  end;
  Elapsed := GetTickCount-Start;
  if Btn.Tag>Elapsed then begin
    Btn.Tag     := Elapsed;
    Btn.Caption := 'Degraded in memory' + #13#10 + Format('Temps mini :  %.0n ms',[Elapsed/1]);
  end;
  Image1.Refresh;
end;


procedure TForm1.Button3Click(Sender: TObject);
  var     Btn : TButton absolute Sender;
  begin
  Reset;
  with Btn do begin
    if Tag = 24 then begin
      Tag := 32;
      Image1.Picture.Bitmap.PixelFormat := pf32bit;
      Caption := 'PixelFormat: 32 bits';  end
    else begin
      Tag := 24;
      Image1.Picture.Bitmap.PixelFormat := pf24bit;
      Caption := 'PixelFormat: 24 bits';
    end;
  end;
end;


procedure TForm1.UpDown1Changing(Sender: TObject; var AllowChange: Boolean);
  begin
  Reset;
end;