Unit Unit1;
// Original Delphi code from Eric Grange : https://www.delphitools.info/2011/03/24/kudos-to-the-firefox-4-tracemonkey-team/
{$mode objfpc}{$H+}
{.$codealign 16} // ---> unit1.pas(4,2) Error: Illegal alignment directive
{$Align 16}
Interface
Uses
Classes, Sysutils, Windows, Fileutil, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
math;
Type
{ Tform1 }
Tform1 = Class(Tform)
Button1 : Tbutton;
Checkbox1 : Tcheckbox;
Image1 : Timage;
Label1 : Tlabel;
Panel1 : Tpanel;
Panel2 : Tpanel;
Shape1 : Tshape;
Procedure Button1click(Sender : Tobject);
Procedure Checkbox1click(Sender : Tobject);
Procedure Formcreate(Sender : Tobject);
Procedure Image1mousedown(Sender : Tobject; Button : Tmousebutton; Shift : Tshiftstate; X, Y : Integer);
Procedure Image1mousemove(Sender : Tobject; Shift : Tshiftstate; X, Y : Integer);
Procedure Image1mouseup(Sender : Tobject; Button : Tmousebutton; Shift : Tshiftstate; X, Y : Integer);
Private
Public
FBitmap : TBitmap;
FScanLines : array of PInteger;
iterLimit : Integer;
qmin, qmax, pmin, pmax : Double;
controlColors : array of TColor;
colors : array of TColor;
mbX, mbY : Integer;
procedure ResetMandel;
procedure ResetControlColors;
procedure ComputeColors;
procedure ComputeMandel;
procedure ComputeMandelDelphi;
procedure ComputeMandelSSE;
procedure DrawPixel(x, y, c : Integer);
End;
Var
Form1 : Tform1;
Implementation
{$R *.lfm}
const
MAX_COLORS = 512;
Procedure Tform1.Formcreate(Sender : Tobject);
begin
(* FBitmap:=TBitmap.Create;
FBitmap.PixelFormat:=pf32bit;
FBitmap.SetSize(Image1.Width, Image1.Height);
SetLength(FScanLines, FBitmap.Height);
for i:=0 to FBitmap.Height-1 do
FScanLines[i]:=PInteger(FBitmap.RawImage.GetLineStart(i)); *)
ResetMandel;
ResetControlColors;
ComputeColors;
//Label1.Caption:='Double Size : '+InttoStr(SizeOf(Double)); //give 8 so 8x8bits = 64bits
// ComputeMandel;
End;
Procedure Tform1.Button1click(Sender : Tobject);
Begin
ResetMandel;
ComputeMandel;
End;
Procedure Tform1.Checkbox1click(Sender : Tobject);
Begin
ComputeMandel;
End;
Procedure Tform1.Image1mousedown(Sender : Tobject; Button : Tmousebutton; Shift : Tshiftstate; X, Y : Integer);
Begin
mbX:=X;
mbY:=Y;
End;
Procedure Tform1.Image1mousemove(Sender : Tobject; Shift : Tshiftstate; X, Y : Integer);
var
s : Integer;
begin
if ssLeft in Shift then begin
s := Max(X-mbX, Y-mbY);
if s>0 then begin
Shape1.SetBounds(mbX+Image1.Left, mbY+Image1.Top, s, s);
Shape1.Visible:=True;
end;
end;
End;
Procedure Tform1.Image1mouseup(Sender : Tobject; Button : Tmousebutton; Shift : Tshiftstate; X, Y : Integer);
var
s : Integer;
pw, qw : Double;
begin
Shape1.Visible:=False;
s:=Max(X-mbX, Y-mbY);
if (s>3) then
begin
X := mbX + s;
Y := mbY + s;
pw := pmax - pmin;
pmin := pmin + mbX * pw / FBitmap.Width;
pmax := pmax - (FBitmap.Width - X) * pw / FBitmap.Width;
qw := qmax - qmin;
qmin := qmin + (FBitmap.Height - Y) * qw / FBitmap.Height;
qmax := qmax - mbY * qw / FBitmap.Height;
ComputeMandel;
end;
End;
procedure TForm1.ResetMandel;
begin
iterLimit := 100;
qmin := -1.5;
qmax := 1.5;
pmin := -2.25;
pmax := 0.75;
end;
// ResetControlColors
//
procedure TForm1.ResetControlColors;
begin
SetLength(controlColors, 5);
controlColors[0] := RGBToColor($20, $00, $00);
controlColors[1] := RGBToColor($ff, $ff, $ff);
controlColors[2] := RGBToColor($A0, $00, $00);
controlColors[3] := RGBToColor($FF, $ff, $40);
controlColors[4] := RGBToColor($FF, $20, $20);
end;
// ComputeMandel
//
procedure TForm1.ComputeMandel;
var
start, stop, freq : Int64;
i:Integer;
begin
// We must reset FBitmap to take change in Image1
if Assigned(FBitmap) then FreeAndNil(FBitmap);
FBitmap:=TBitmap.Create;
FBitmap.PixelFormat:=pf32bit;
FBitmap.SetSize(Image1.Width, Image1.Height);
SetLength(FScanLines, FBitmap.Height);
for i:=0 to FBitmap.Height-1 do
FScanLines[i]:=PInteger(FBitmap.RawImage.GetLineStart(i));
Start:=0; Stop:=0; freq:=1;
QueryPerformanceCounter(start);
FBitmap.BeginUpdate();
if CheckBox1.Checked then ComputeMandelSSE
else ComputeMandelDelphi;
FBitmap.EndUpdate();
QueryPerformanceCounter(stop);
QueryPerformanceFrequency(freq);
Image1.Picture.Bitmap := FBitmap;
Label1.Caption:='Generate in '+Format('%.1f milliseconds', [(stop-start)/freq*1000]);
end;
// ComputeMandelDelphi
//
procedure TForm1.ComputeMandelDelphi;
const
kmax = 256;
var
xstep, ystep : Double;
x, y, r : Double;
sx, sy, k : Integer;
p, q, x0, y0 : Double;
begin
xstep := (pmax - pmin) / FBitmap.Width;
ystep := (qmax - qmin) / FBitmap.Height;
for sx := 0 to FBitmap.Width-1 do begin
for sy := 0 to FBitmap.Height-1 do begin
p := pmin + xstep * sx;
q := qmax - ystep * sy;
k := 0;
x0 := 0;
y0 := 0;
repeat
x := x0 * x0 - y0 * y0 + p;
y := 2 * x0 * y0 + q;
x0 := x;
y0 := y;
r := x * x + y * y;
Inc(k);
until ((r > iterLimit) or (k >= kmax));
if k >= kmax then
k := 0;
DrawPixel(sx, sy, k);
end;
end;
end;
// From https://github.com/UltraStar-Deluxe/USDX/blob/master/src/base/UCommon.pas
type
// stores the unaligned pointer of data allocated by GetAlignedMem()
PMemAlignHeader = ^TMemAlignHeader;
TMemAlignHeader = pointer;
(**
* Use this function to assure that allocated memory is aligned on a specific
* byte boundary.
* Alignment must be a power of 2.
*
* Important: Memory allocated with GetAlignedMem() MUST be freed with
* FreeAlignedMem(), FreeMem() will cause a segmentation fault.
*
* Hint: If you do not need dynamic memory, consider to allocate memory
* statically and use the {$ALIGN x} compiler directive. Note that delphi
* supports an alignment "x" of up to 8 bytes only whereas FPC supports
* alignments on 16 and 32 byte boundaries too.
*)
{$WARNINGS OFF}
function GetAlignedMem(Size: cardinal; Alignment: integer): pointer;
var
OrigPtr: pointer;
const
MIN_ALIGNMENT = 16;
begin
// Delphi and FPC (tested with 2.2.0) align memory blocks allocated with
// GetMem() at least on 8 byte boundaries. Delphi uses a minimal alignment
// of either 8 or 16 bytes depending on the size of the requested block
// (see System.GetMinimumBlockAlignment). As we do not want to change the
// boundary for the worse, we align at least on MIN_ALIGN.
if (Alignment < MIN_ALIGNMENT) then
Alignment := MIN_ALIGNMENT;
// allocate unaligned memory
GetMem(OrigPtr, SizeOf(TMemAlignHeader) + Size + Alignment);
if (OrigPtr = nil) then
begin
Result := nil;
Exit;
end;
// reserve space for the header
Result := pointer(PtrUInt(OrigPtr) + SizeOf(TMemAlignHeader));
// align memory
Result := pointer(PtrUInt(Result) + Alignment - PtrUInt(Result) mod Alignment);
// set header with info on old pointer for FreeMem
PMemAlignHeader(PtrUInt(Result) - SizeOf(TMemAlignHeader))^ := OrigPtr;
end;
{$WARNINGS ON}
{$WARNINGS OFF}
procedure FreeAlignedMem(P: pointer);
begin
if (P <> nil) then
FreeMem(PMemAlignHeader(PtrUInt(P) - SizeOf(TMemAlignHeader))^);
end;
{$WARNINGS ON}
// ComputeMandelSSE
//
procedure TForm1.ComputeMandelSSE;
const
kmax = 256;
//c2 : Double = 2.0; //By using this const a SIGSEV is throw at : movsd xmm4, c2 / mulsd xmm1,c2
var
xstep, ystep : Double;
r : Double;
sx, sy, k : Integer;
p, q, x0, y0 : Double;
c2 : Double;
_p, _q, _x0, _y0, _c2,_r : PDouble;
AlignedDoubleSize : Cardinal;
begin
c2 := 2.0;
// AlignedDoubleSize := 2*Sizeof(Double); //128bits
// _p := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _q := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _x0 := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _y0 := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _r := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _c2 := PDouble(GetAlignedMem(AlignedDoubleSize,16));
// _c2^:= c2; inc(_c2); _x0^:=c2;
xstep := (pmax - pmin) / FBitmap.Width;
ystep := (qmax - qmin) / FBitmap.Height;
for sx := 0 to FBitmap.Width-1 do
begin
for sy := 0 to FBitmap.Height-1 do
begin
p := pmin + xstep * sx;
q := qmax - ystep * sy;
k := 0;
x0 := 0;
y0 := 0;
// _p^:= p; inc(_p); _p^:=p;
// _q^:= p; inc(_q); _q^:=p;
// _x0^:= p; inc(_x0); _x0^:=p;
// _y0^:= p; inc(_y0); _y0^:=p;
asm
movsd xmm0, _x0;
movsd xmm1, _y0;
// movsd xmm4, c2
end;
repeat
asm
// x := x0 * x0 - y0 * y0 + p;
movsd xmm2, xmm0
mulsd xmm2, xmm2
movsd xmm3, xmm1
mulsd xmm3, xmm3
subsd xmm2, xmm3
movsd xmm4, p
addsd xmm2, xmm4 //p
// y := 2 * x0 * y0 + q;
// y0 :=y
mulsd xmm1, xmm0
movsd xmm4, c2
mulsd xmm1, xmm4
movsd xmm4, q
addsd xmm1, xmm4
// x0 := x
movsd xmm0, xmm2
// r := x * x + y * y;
mulsd xmm2, xmm2
movsd xmm3, xmm1
mulsd xmm3, xmm1
addsd xmm2, xmm3
movsd r, xmm2
end;
Inc(k);
until ((r > iterLimit) or (k >= kmax));
if k >= kmax then k := 0;
DrawPixel(sx, sy, k);
end;
end;
// FreeAlignedMem(_p);
// FreeAlignedMem(_q);
// FreeAlignedMem(_x0);
// FreeAlignedMem(_y0);
// FreeAlignedMem(_r);
// FreeAlignedMem(_c2);
end;
// ComputeColors
//
procedure TForm1.ComputeColors;
var
i, k : Integer;
rstep, bstep, gstep : Double;
begin
SetLength(colors, MAX_COLORS);
colors[0] := RGB(0, 0, 0);
for i:=0 to High(controlColors) do begin
rstep := (GetRValue(controlColors[i + 1]) - GetRValue(controlColors[i])) / 63;
gstep := (GetGValue(controlColors[i + 1]) - GetGValue(controlColors[i])) / 63;
bstep := (GetBValue(controlColors[i + 1]) - GetBValue(controlColors[i])) / 63;
for k:=0 to 63 do
colors[k + (i * 64) + 1] := RGB(Round(GetRValue(controlColors[i]) + rstep * k),
Round(GetGValue(controlColors[i]) + gstep * k),
Round(GetBValue(controlColors[i]) + bstep * k));
end;
for i := 257 to MAX_COLORS-1 do
colors[i] := colors[i - 256];
end;
// DrawPixel
//
procedure TForm1.DrawPixel(x, y, c : Integer); inline;
begin
PInteger(FScanLines[y]+(x))^:= colors[c];
end;
End.