This is a substantial update from yesterday's article Creating a Fractal Art Application: Drawing the Sierpinski Triangle.
What's new? Here are the new features:
1. A new menu item with a shortcut to set random colors:
// Random Colors:
function GetRandomColor: TColor;
begin
Result := Winapi.Windows.RGB(Random(256), Random(256), Random(256));
end;
type
TRGB = record
R, G, B: Byte;
end;
THSV = record
H, S, V: Double;
end;
function RGBToHSV(Color: TColor): THSV;
var
R, G, B: Byte;
MinVal, MaxVal, Delta: Double;
begin
// Extract the RGB components from the TColor value
Color := ColorToRGB(Color);
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
// Find the minimum and maximum values among R, G, and B
MinVal := Min(Min(R, G), B);
MaxVal := Max(Max(R, G), B);
// Value (V) is the maximum of R, G, and B divided by 255
Result.V := MaxVal / 255;
Delta := MaxVal - MinVal;
// Saturation (S) is zero if the maximum value is zero, otherwise it's Delta divided by the maximum value
if MaxVal = 0 then
Result.S := 0
else
Result.S := Delta / MaxVal;
// If Delta is zero, then the color is a shade of gray and the hue is undefined (set to 0)
if Delta = 0 then
Result.H := 0
else
begin
// Calculate the Hue (H)
if R = MaxVal then
Result.H := (G - B) / Delta
else if G = MaxVal then
Result.H := 2 + (B - R) / Delta
else
Result.H := 4 + (R - G) / Delta;
// Convert the Hue to degrees
Result.H := Result.H * 60;
if Result.H < 0 then
Result.H := Result.H + 360;
end;
end;
function HSVToRGB(HSV: THSV): TColor;
var
R, G, B: Byte;
i: Integer;
f, p, q, t: Double;
begin
if HSV.S = 0 then
begin
// If Saturation is zero, the color is a shade of gray
R := Round(HSV.V * 255);
G := R;
B := R;
end
else
begin
// Calculate the sector of the color wheel (0 to 5)
HSV.H := HSV.H / 60;
i := Floor(HSV.H);
f := HSV.H - i; // Fractional part of the sector
p := HSV.V * (1 - HSV.S);
q := HSV.V * (1 - HSV.S * f);
t := HSV.V * (1 - HSV.S * (1 - f));
// Assign the RGB values based on the sector
case i of
0:
begin
R := Round(HSV.V * 255);
G := Round(t * 255);
B := Round(p * 255);
end;
1:
begin
R := Round(q * 255);
G := Round(HSV.V * 255);
B := Round(p * 255);
end;
2:
begin
R := Round(p * 255);
G := Round(HSV.V * 255);
B := Round(t * 255);
end;
3:
begin
R := Round(p * 255);
G := Round(q * 255);
B := Round(HSV.V * 255);
end;
4:
begin
R := Round(t * 255);
G := Round(p * 255);
B := Round(HSV.V * 255);
end;
else
begin
R := Round(HSV.V * 255);
G := Round(p * 255);
B := Round(q * 255);
end;
end;
end;
// Combine the RGB components into a TColor value
Result := RGB(R, G, B);
end;
function GetContrastingColor(Color: TColor): TColor;
var
HSV: THSV;
begin
// Convert the given color from RGB to HSV
HSV := RGBToHSV(Color);
// Adjust the Hue by 180 degrees to get the complementary color
HSV.H := HSV.H + 180;
if HSV.H > 360 then
HSV.H := HSV.H - 360;
// Convert the adjusted HSV color back to RGB
Result := HSVToRGB(HSV);
end;
procedure TForm1.mSetRandomColorsClick(Sender: TObject);
var
RandomColor, ContrastingColor: TColor;
begin
// Generate a random color
RandomColor := GetRandomColor;
// Get the contrasting color for the generated random color
ContrastingColor := GetContrastingColor(RandomColor);
// Set the new random foreground and background colors
FForegroundColor := RandomColor;
FBackgroundColor := ContrastingColor;
// Redraw the triangle with the new colors
UpdateBuffer;
end;
2. New menu items with a shortcut to decrease or increase the recursion depth:
procedure TForm1.mRecursionDepthDecClick(Sender: TObject);
begin
if FRecursionDepth > 1 then
begin
// Decrease the recursion depth:
Dec(FRecursionDepth);
UpdateBuffer;
end;
end;
procedure TForm1.mRecursionDepthIncClick(Sender: TObject);
begin
if FRecursionDepth < 8 then
begin
// Increase the recursion depth:
Inc(FRecursionDepth);
UpdateBuffer;
end;
end;
3. A new menu item to copy the Sierpinski Triangle image to the clipboard:
// Clipboard:
procedure TForm1.SaveToClipboard;
var
Bitmap: TBitmap;
PNG: TPngImage;
MemStream: TMemoryStream;
HMem: THandle;
P: Pointer;
ClipFormat: TClipFormat;
begin
// Open the clipboard for exclusive access
Clipboard.Open;
try
// Copy the bitmap to the clipboard
Bitmap := TBitmap.Create;
try
Bitmap.Assign(FBuffer);
Clipboard.Assign(Bitmap);
finally
Bitmap.Free;
end;
// Create a PNG image from the buffer
PNG := TPngImage.Create;
try
PNG.Assign(FBuffer);
// Save the PNG to a memory stream
MemStream := TMemoryStream.Create;
try
PNG.SaveToStream(MemStream);
MemStream.Position := 0;
// Allocate global memory for the PNG data
HMem := GlobalAlloc(GMEM_MOVEABLE, MemStream.Size);
if HMem = 0 then
RaiseLastOSError;
try
P := GlobalLock(HMem);
if P = nil then
RaiseLastOSError;
try
MemStream.ReadBuffer(P^, MemStream.Size);
finally
GlobalUnlock(HMem);
end;
// Register the PNG clipboard format
ClipFormat := RegisterClipboardFormat('PNG');
if ClipFormat = 0 then
RaiseLastOSError;
// Set the PNG data to the clipboard
SetClipboardData(ClipFormat, HMem);
except
GlobalFree(HMem);
raise;
end;
finally
MemStream.Free;
end;
finally
PNG.Free;
end;
finally
Clipboard.Close;
end;
end;
procedure TForm1.mCopyClick(Sender: TObject);
begin
SaveToClipboard;
end;
No comments:
Post a Comment