Mega Code Archive
Gradientfillquadrilateral
<![CDATA[
unit quaddraw;
//Kristian Whittick, September 2000
//as a much-appreciated favour for Richard Ebbs, EMIS
//Fill Random Quadrilateral Shape With Colour Gradient
//This is less of a simple task than it might first appear to be
//the QuadrilateralGradFill routine needs to take account of
//quadrilateral shapes that possibly 'cross-over' (so that they
//look like two end-to-end triangles) and the 'colour gradient'
//code needs to take account of possible rounding errors, etc
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls;
type
TMainForm = class(TForm)
Image: TImage;
NewShapeButton: TBitBtn;
ExitButton: TButton;
procedure NewShapeButtonClick(Sender: TObject);
procedure ExitButtonClick(Sender: TObject);
private
{private declarations}
public
{public declarations}
procedure QuadrilateralGradFill(thisCanvas : TCanvas;
StartColor,
EndColor : TColor;
pts : array of Tpoint);
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.NewShapeButtonClick(Sender: TObject);
var
p1 : Tpoint;
p2 : Tpoint;
p3 : Tpoint;
p4 : Tpoint;
begin
p1.x := Random(400);
p2.x := Random(400);
p3.x := Random(400);
p4.x := Random(400);
p1.y := Random(400);
p2.y := Random(400);
p3.y := Random(400);
p4.y := Random(400);
QuadrilateralGradFill(self.Canvas, clRed, clBlue, [p1, p2, p3, p4]);
end;
//////////////////////////////////////////////////////////////
procedure TMainForm.QuadrilateralGradFill(thisCanvas : TCanvas;
StartColor,
EndColor : TColor;
pts : array of Tpoint);
type
Edge = record
X : Integer;
s : Boolean;
end;
var
Ct : Integer;
cty: Integer;
Miny : Integer;
Maxy : Integer;
Minyidx : Integer;
Maxyidx : Integer;
leftX : Edge;
rightX : Edge;
FourX : array[0..3] of Edge;
Colchange : single;
NewRed, NewGreen, NewBlue: Byte;
StartRed, StartGreen, StartBlue: Byte;
DiffRed, DiffGreen, DiffBlue : Integer;
function FindXintersect(Pt1, pt2 : Tpoint; height : Integer) : Edge;
begin
result.s := FALSE;
if pt1.y = pt2.y then
exit;
if (height > pt1.y) and (height > pt2.y) then
exit;
if (height < pt1.y) and (height < pt2.y) then
exit;
result.x := round((pt2.x - pt1.x) * (height - pt1.y) / (pt2.y - pt1.y) + pt1.x);
result.s := True;
end;
begin
//if less than three sides exit...
//find Min and Max in 'y' direction
for Ct := 0 to 3 do
begin
if Ct = 0 then
begin
Miny := pts[ct].Y;
Maxy := pts[ct].Y;
end
else
begin
if pts[ct].y > Maxy then
Maxy := pts[ct].Y
else
if pts[ct].y < Miny then
Miny := pts[ct].Y
end;
end;
//there is nothing to do if the top and bottom are the same...
if miny >= maxy then exit;
DiffRed := GetRValue(EndColor) - GetRValue(StartColor);
DiffGreen := GetGValue(EndColor) - GetGValue(StartColor);
DiffBlue := GetBValue(EndColor) - GetBValue(StartColor);
for cty := miny to maxy do
begin
FourX[0] := FindXintersect(pts[0], pts[1], Cty);
FourX[1] := FindXintersect(pts[1], pts[2], Cty);
FourX[2] := FindXintersect(pts[2], pts[3], Cty);
FourX[3] := FindXintersect(pts[3], pts[0], Cty);
leftX.s := FALSE;
rightX.s := FALSE;
for Ct := 0 to 3 do
if FourX[ct].s then
begin
if not leftX.s then
begin
leftX.x := FourX[ct].x;
leftX.s := TRUE;
end
else
if FourX[ct].x < leftX.x then
begin
leftX.x := FourX[ct].x;
leftX.s := TRUE;
end;
if not rightX.s then
begin
rightX.x := FourX[ct].x;
rightX.s := TRUE;
end
else
if FourX[ct].x > rightX.x then
begin
rightX.x := FourX[ct].x;
rightX.s := TRUE;
end;
end;
if leftX.s and rightX.s then
begin
Colchange := (cty - miny) / (maxy - miny);
NewRed := Round(DiffRed * Colchange) + GetRValue(StartColor);
NewGreen := Round(DiffGreen * Colchange) + GetGValue(StartColor);
NewBlue := Round(DiffBlue * Colchange) + GetBValue(StartColor);
ThisCanvas.Pen.Color := RGB(NewRed, NewGreen, NewBlue);
ThisCanvas.MoveTo(leftX.x, cty);
ThisCanvas.LineTo(rightX.x, cty);
end;
end;
end;
/////////////////////////////////////////////////////
procedure TMainForm.ExitButtonClick(Sender: TObject);
begin
Close;
end;
//////
end.
]]>