mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 01:29:29 +02:00
+ implementation of ellipses (drawing, filling, pattern drawing)
This commit is contained in:
luk
parent
a3636fc097
commit
306853a62e
704
fcl/image/Ellipses.pp
Normal file
704
fcl/image/Ellipses.pp
Normal file
@ -0,0 +1,704 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Drawing of ellipses and arcs, and filling ellipses and pies.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}
|
||||
unit Ellipses;
|
||||
|
||||
interface
|
||||
|
||||
uses classes, FPImage, FPCanvas;
|
||||
|
||||
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
|
||||
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
|
||||
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
|
||||
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
|
||||
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
|
||||
procedure FillEllipseHashHorizontal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseHashVertical (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseHashDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseHashBackDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseHashDiagCross (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseHashCross (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
procedure FillEllipseImage (Canv:TFPCustomCanvas; const Bounds:TRect; const Image:TFPCustomImage);
|
||||
procedure FillEllipseImageRel (Canv:TFPCustomCanvas; const Bounds:TRect; const Image:TFPCustomImage);
|
||||
|
||||
type
|
||||
|
||||
PEllipseInfoData = ^TEllipseInfoData;
|
||||
TEllipseInfoData = record
|
||||
x, ytopmax, ytopmin, ybotmax, ybotmin : integer;
|
||||
OnlyTop : boolean;
|
||||
end;
|
||||
|
||||
TEllipseInfo = class
|
||||
private
|
||||
fcx, fcy, frx,fry,
|
||||
fa1, fa2, frot : real;
|
||||
fx1,fy1, fx2,fy2 : integer;
|
||||
InfoList : TList;
|
||||
procedure FreeList;
|
||||
procedure ClearList;
|
||||
function FindXIndex (x:integer) : integer;
|
||||
procedure PrepareCalculation (var np:integer; var delta:real);
|
||||
function NewInfoRec (anX:integer) : PEllipseInfoData;
|
||||
procedure CalculateCircular (const b:TRect; var x,y,rx,ry:real);
|
||||
public
|
||||
constructor create;
|
||||
destructor destroy; override;
|
||||
function GetInfoForX (x:integer; var ytopmax,ytopmin,ybotmax,ybotmin:integer):boolean;
|
||||
function GetInfoForX (x:integer; var Info:PEllipseInfoData):boolean;
|
||||
procedure GatherEllipseInfo (const bounds:TRect);
|
||||
procedure GatherArcInfo (const bounds:TRect; alpha1,alpha2:real);
|
||||
property cx : real read fcx; // center point
|
||||
property cy : real read fcy;
|
||||
property rhor : real read frx; // radius
|
||||
property rver : real read fry;
|
||||
{ only usable when created with GatherArcInfo }
|
||||
property a1 : real read fa1; // angle 1 and point on ellipse
|
||||
property x1 : integer read fx1;
|
||||
property y1 : integer read fy1;
|
||||
property a2 : real read fa2; // angle 2 and point on ellipse
|
||||
property x2 : integer read fx2;
|
||||
property y2 : integer read fy2;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TEllipseInfo.Create;
|
||||
begin
|
||||
inherited;
|
||||
InfoList := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TEllipseInfo.Destroy;
|
||||
begin
|
||||
FreeList;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.ClearList;
|
||||
var r : integer;
|
||||
d : PEllipseInfoData;
|
||||
begin
|
||||
if assigned (InfoList) then
|
||||
begin
|
||||
for r := 0 to infolist.count-1 do
|
||||
begin
|
||||
d := PEllipseInfoData(InfoList[r]);
|
||||
dispose (d);
|
||||
end;
|
||||
InfoList.clear;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.FreeList;
|
||||
begin
|
||||
if assigned (InfoList) then
|
||||
begin
|
||||
ClearList;
|
||||
InfoList.Free;
|
||||
InfoList := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TEllipseInfo.GetInfoForX (x:integer; var ytopmax,ytopmin,ybotmax,ybotmin:integer):boolean;
|
||||
var r : PEllipseInfoData;
|
||||
begin
|
||||
result := GetInfoForX (x, r);
|
||||
if assigned(r) then
|
||||
begin
|
||||
ytopmax := ytopmax;
|
||||
ytopmin := ytopmin;
|
||||
ybotmax := ybotmax;
|
||||
ybotmin := ybotmin;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TEllipseInfo.FindXIndex (x : integer) : integer;
|
||||
begin
|
||||
result := InfoList.Count;
|
||||
repeat
|
||||
dec (result);
|
||||
until (result < 0) or (x = PEllipseInfoData(InfoList[result])^.x);
|
||||
end;
|
||||
|
||||
function TEllipseInfo.GetInfoForX (x:integer; var Info:PEllipseInfoData):boolean;
|
||||
var r : integer;
|
||||
begin
|
||||
r := FindXIndex (x);
|
||||
result := (r >= 0);
|
||||
if result then
|
||||
Info := PEllipseInfoData(InfoList[r])
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.PrepareCalculation (var np:integer; var delta:real);
|
||||
begin
|
||||
np := round(1.5708 * sqrt(sqr(frx)+sqr(fry)) );
|
||||
// number of pixel in quarter circel to calculate without gaps in drawing
|
||||
delta := pi / (2 * np);
|
||||
end;
|
||||
|
||||
function TEllipseInfo.NewInfoRec (anX:integer) : PEllipseInfoData;
|
||||
begin
|
||||
new (result);
|
||||
result^.x := anX;
|
||||
infolist.Add (result);
|
||||
with result^ do
|
||||
begin
|
||||
ytopmax := -1;
|
||||
ytopmin := maxint;
|
||||
ybotmax := -1;
|
||||
ybotmin := maxint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.CalculateCircular (const b:TRect; var x,y,rx,ry:real);
|
||||
begin
|
||||
with b do
|
||||
begin
|
||||
x := (right+left) / 2;
|
||||
y := (top+bottom) / 2;
|
||||
rx := abs(right-left) / 2;
|
||||
ry := abs(bottom-top) / 2;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.GatherEllipseInfo (const bounds:TRect);
|
||||
var infoP, infoM : PEllipseInfoData;
|
||||
halfnumber,
|
||||
r, NumberPixels, xtemp,yt,yb : integer;
|
||||
pPy, pMy, x,y, rx,ry, xd,yd,ra, rdelta : real;
|
||||
begin
|
||||
ClearList;
|
||||
CalculateCircular (bounds, x,y,rx,ry);
|
||||
with bounds do
|
||||
fcx := x;
|
||||
fcy := y;
|
||||
frx := rx;
|
||||
fry := ry;
|
||||
if (rx < 0.5) and (ry < 0.5) then
|
||||
with NewInfoRec (round(x))^ do
|
||||
begin
|
||||
ytopmax := round(y);
|
||||
ytopmin := ytopmax;
|
||||
ybotmax := ytopmax;
|
||||
ybotmin := ytopmax;
|
||||
end
|
||||
else
|
||||
begin
|
||||
PrepareCalculation (NumberPixels, rdelta);
|
||||
halfnumber := NumberPixels div 2;
|
||||
pPy := maxint;
|
||||
pMy := maxint;
|
||||
ra := 0;
|
||||
infoP := NewInfoRec (round(x + rx));
|
||||
infoM := NewInfoRec (round(x - rx));
|
||||
for r := 0 to NumberPixels do
|
||||
begin
|
||||
xd := rx * cos(ra);
|
||||
yd := ry * sin(ra);
|
||||
// take all 4 quarters
|
||||
yt := round(y - yd);
|
||||
yb := round(y + yd);
|
||||
xtemp := round (x + xd);
|
||||
// quarter 1 and 4 at the same x line
|
||||
if infoP^.x <> xtemp then // has correct record ?
|
||||
begin
|
||||
with infoP^ do // ensure single width
|
||||
begin
|
||||
if r < halfnumber then
|
||||
begin
|
||||
if ytopmin = yt then
|
||||
begin
|
||||
inc (ytopmin);
|
||||
dec (ybotmax);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (ytopmax = pPy) and (ytopmax <> ytopmin) then
|
||||
begin
|
||||
dec (ytopmax);
|
||||
inc (ybotmin);
|
||||
end;
|
||||
end;
|
||||
pPy := ytopmin;
|
||||
end;
|
||||
if not GetInfoForX (xtemp, infoP) then // record exists already ?
|
||||
infoP := NewInfoRec (xtemp); // create a new recod
|
||||
end;
|
||||
// lower y is top, min is lowest
|
||||
with InfoP^ do
|
||||
begin
|
||||
if yt < ytopmin then
|
||||
ytopmin := yt;
|
||||
if yb < ybotmin then
|
||||
ybotmin := yb;
|
||||
if yt > ytopmax then
|
||||
ytopmax := yt;
|
||||
if yb > ybotmax then
|
||||
ybotmax := yb;
|
||||
end;
|
||||
// quarter 2 and 3 on the same x line
|
||||
xtemp := round(x - xd);
|
||||
if infoM^.x <> xtemp then // has correct record ?
|
||||
begin
|
||||
with infoM^ do // ensure single width
|
||||
begin
|
||||
if r < halfnumber then
|
||||
begin
|
||||
if ytopmin = yt then
|
||||
begin
|
||||
inc (ytopmin);
|
||||
dec (ybotmax);
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
if (ytopmax = pMy) and (ytopmax <> ytopmin) then
|
||||
begin
|
||||
dec (ytopmax);
|
||||
inc (ybotmin);
|
||||
end;
|
||||
end;
|
||||
pMy := ytopmin;
|
||||
end;
|
||||
if not GetInfoForX (xtemp, infoM) then // record exists already ?
|
||||
infoM := NewInfoRec (xtemp); // create a new recod
|
||||
end;
|
||||
// lower y is top, min is lowest
|
||||
with InfoM^ do
|
||||
begin
|
||||
if yt < ytopmin then
|
||||
ytopmin := yt;
|
||||
if yb < ybotmin then
|
||||
ybotmin := yb;
|
||||
if yt > ytopmax then
|
||||
ytopmax := yt;
|
||||
if yb > ybotmax then
|
||||
ybotmax := yb;
|
||||
end;
|
||||
ra := ra + rdelta;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TEllipseInfo.GatherArcInfo (const bounds:TRect; alpha1,alpha2:real);
|
||||
var stAngle,endAngle:real;
|
||||
|
||||
procedure CheckAngles;
|
||||
begin
|
||||
if a1 < a2 then
|
||||
begin
|
||||
stAngle := a1;
|
||||
endAngle := a2;
|
||||
end
|
||||
else
|
||||
begin
|
||||
stAngle := a2;
|
||||
endAngle := a1;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
end;
|
||||
|
||||
{ The drawing routines }
|
||||
|
||||
type
|
||||
TPutPixelProc = procedure (Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
|
||||
TLinePoints = array[0..PatternBitCount-1] of boolean;
|
||||
PLinePoints = ^TLinePoints;
|
||||
|
||||
procedure PatternToPoints (const APattern:TPenPattern; LinePoints:PLinePoints);
|
||||
var r : integer;
|
||||
i : longword;
|
||||
begin
|
||||
i := 1;
|
||||
for r := PatternBitCount-1 downto 1 do
|
||||
begin
|
||||
LinePoints^[r] := (APattern and i) <> 0;
|
||||
i := i shl 1;
|
||||
end;
|
||||
LinePoints^[0] := (APattern and i) <> 0;
|
||||
end;
|
||||
|
||||
procedure PutPixelCopy(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
|
||||
begin
|
||||
with Canv do
|
||||
Colors[x,y] := color;
|
||||
end;
|
||||
|
||||
procedure PutPixelXor(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
|
||||
begin
|
||||
with Canv do
|
||||
Colors[x,y] := Colors[x,y] xor color;
|
||||
end;
|
||||
|
||||
procedure PutPixelOr(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
|
||||
begin
|
||||
with Canv do
|
||||
Colors[x,y] := Colors[x,y] or color;
|
||||
end;
|
||||
|
||||
procedure PutPixelAnd(Canv:TFPCustomCanvas; x,y:integer; color:TFPColor);
|
||||
begin
|
||||
with Canv do
|
||||
Colors[x,y] := Colors[x,y] and color;
|
||||
end;
|
||||
|
||||
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
MyPutPix : TPutPixelProc;
|
||||
begin
|
||||
with canv.pen do
|
||||
case mode of
|
||||
pmAnd : MyPutPix := @PutPixelAnd;
|
||||
pmOr : MyPutPix := @PutPixelOr;
|
||||
pmXor : MyPutPix := @PutPixelXor;
|
||||
else MyPutPix := @PutPixelCopy;
|
||||
end;
|
||||
info := TEllipseInfo.Create;
|
||||
with Canv, info do
|
||||
try
|
||||
GatherEllipseInfo (bounds);
|
||||
for r := 0 to InfoList.count-1 do
|
||||
with PEllipseInfoData(InfoList[r])^ do
|
||||
begin
|
||||
for y := ytopmin to ytopmax do
|
||||
MyPutPix (Canv, x,y, c);
|
||||
for y := ybotmin to ybotmax do
|
||||
MyPutPix (Canv, x,y, c);
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DrawSolidEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Width:integer; c:TFPColor);
|
||||
var infoOut, infoIn : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
MyPutPix : TPutPixelProc;
|
||||
begin
|
||||
with canv.pen do
|
||||
case mode of
|
||||
pmAnd : MyPutPix := @PutPixelAnd;
|
||||
pmOr : MyPutPix := @PutPixelOr;
|
||||
pmXor : MyPutPix := @PutPixelXor;
|
||||
else MyPutPix := @PutPixelCopy;
|
||||
end;
|
||||
infoIn := TEllipseInfo.Create;
|
||||
infoOut := TEllipseInfo.Create;
|
||||
dec (width);
|
||||
try
|
||||
infoOut.GatherEllipseInfo(bounds);
|
||||
with bounds do
|
||||
infoIn.GatherEllipseInfo (Rect(left+width,top+width,right-width,bottom-width));
|
||||
with Canv do
|
||||
for r := 0 to infoOut.infolist.count-1 do
|
||||
with PEllipseInfoData (infoOut.infolist[r])^ do
|
||||
begin
|
||||
if infoIn.GetInfoForX (x, id) then
|
||||
begin
|
||||
for y := ytopmin to id^.ytopmax do
|
||||
MyPutPix (canv, x,y, c);
|
||||
for y := id^.ybotmin to ybotmax do
|
||||
MyPutPix (canv, x,y, c);
|
||||
end
|
||||
else
|
||||
begin // no inner circle found: draw all points between top and bottom
|
||||
for y := ytopmin to ybotmax do
|
||||
MyPutPix (canv, x,y, c);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
infoOut.Free;
|
||||
infoIn.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DrawPatternEllipse (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TPenPattern; c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
xx, y : integer;
|
||||
LinePoints : TLinePoints;
|
||||
MyPutPix : TPutPixelProc;
|
||||
id : PEllipseInfoData;
|
||||
CountDown, CountUp, half : integer;
|
||||
begin
|
||||
with canv.pen do
|
||||
case mode of
|
||||
pmAnd : MyPutPix := @PutPixelAnd;
|
||||
pmOr : MyPutPix := @PutPixelOr;
|
||||
pmXor : MyPutPix := @PutPixelXor;
|
||||
else MyPutPix := @PutPixelCopy;
|
||||
end;
|
||||
PatternToPoints (pattern, @LinePoints);
|
||||
info := TEllipseInfo.Create;
|
||||
with Canv, info do
|
||||
try
|
||||
GatherEllipseInfo (bounds);
|
||||
CountUp := 0;
|
||||
CountDown := PatternBitCount - 1;
|
||||
half := round (cx);
|
||||
for xx := bounds.left to half do
|
||||
if GetInfoForX (xx, id) then
|
||||
begin
|
||||
with id^ do
|
||||
begin
|
||||
for y := ytopmax downto ytopmin do
|
||||
begin
|
||||
if LinePoints[CountUp mod PatternBitCount] then
|
||||
MyPutPix (Canv, xx,y, c);
|
||||
inc (CountUp);
|
||||
end;
|
||||
for y := ybotmin to ybotmax do
|
||||
begin
|
||||
if LinePoints[PatternBitCount - (CountDown mod PatternBitCount) - 1] then
|
||||
MyPutPix (Canv, xx,y, c);
|
||||
inc (CountDown);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
for xx := half+1 to bounds.right do
|
||||
if GetInfoForX (xx, id) then
|
||||
begin
|
||||
with id^ do
|
||||
begin
|
||||
for y := ytopmin to ytopmax do
|
||||
begin
|
||||
if LinePoints[CountUp mod PatternBitCount] then
|
||||
MyPutPix (Canv, xx,y, c);
|
||||
inc (CountUp);
|
||||
end;
|
||||
for y := ybotmax downto ybotmin do
|
||||
begin
|
||||
if LinePoints[Patternbitcount - (CountDown mod PatternBitCount) - 1] then
|
||||
MyPutPix (Canv, xx,y, c);
|
||||
inc (CountDown);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseColor (Canv:TFPCustomCanvas; const Bounds:TRect; c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
with Canv do
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
for y := ytopmin to ybotmax do
|
||||
colors[x,y] := c;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipsePattern (Canv:TFPCustomCanvas; const Bounds:TRect; Pattern:TBrushPattern; c:TFPColor);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashHorizontal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
for y := ytopmin to ybotmax do
|
||||
if (y mod width) = 0 then
|
||||
canv.colors[x,y] := c;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashVertical (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
if (x mod width) = 0 then
|
||||
for y := ytopmin to ybotmax do
|
||||
canv.colors[x,y] := c;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
w : integer;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
begin
|
||||
w := width - 1 - (x mod width);
|
||||
for y := ytopmin to ybotmax do
|
||||
if (y mod width) = w then
|
||||
canv.colors[x,y] := c;
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashBackDiagonal (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
w : integer;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
begin
|
||||
w := (x mod width);
|
||||
for y := ytopmin to ybotmax do
|
||||
if (y mod width) = w then
|
||||
canv.colors[x,y] := c;
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashDiagCross (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
wy,w1,w2 : integer;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
begin
|
||||
w1 := (x mod width);
|
||||
w2 := width - 1 - (x mod width);
|
||||
for y := ytopmin to ybotmax do
|
||||
begin
|
||||
wy := y mod width;
|
||||
if (wy = w1) or (wy = w2) then
|
||||
canv.colors[x,y] := c;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseHashCross (Canv:TFPCustomCanvas; const Bounds:TRect; width:integer; const c:TFPColor);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
if (x mod width) = 0 then
|
||||
for y := ytopmin to ybotmax do
|
||||
canv.colors[x,y] := c
|
||||
else
|
||||
for y := ytopmin to ybotmax do
|
||||
if (y mod width) = 0 then
|
||||
canv.colors[x,y] := c;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseImage (Canv:TFPCustomCanvas; const Bounds:TRect; const Image:TFPCustomImage);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
w : integer;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
info.GatherEllipseInfo(bounds);
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
begin
|
||||
w := (x mod image.width);
|
||||
for y := ytopmin to ybotmax do
|
||||
canv.colors[x,y] := Image.colors[w, (y mod image.height)];
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure FillEllipseImageRel (Canv:TFPCustomCanvas; const Bounds:TRect; const Image:TFPCustomImage);
|
||||
var info : TEllipseInfo;
|
||||
r, y : integer;
|
||||
id : PEllipseInfoData;
|
||||
xo,yo, xi,yi : integer;
|
||||
begin
|
||||
info := TEllipseInfo.Create;
|
||||
try
|
||||
with info do
|
||||
begin
|
||||
GatherEllipseInfo(bounds);
|
||||
xo := round(cx) - (image.width div 2);
|
||||
yo := round(cy) - (image.height div 2);
|
||||
end;
|
||||
for r := 0 to info.infolist.count-1 do
|
||||
with PEllipseInfoData (info.infolist[r])^ do
|
||||
begin
|
||||
xi := (x - xo) mod image.width;
|
||||
if xi < 0 then
|
||||
inc (xi, image.width);
|
||||
for y := ytopmin to ybotmax do
|
||||
begin
|
||||
yi := (y - yo) mod image.height;
|
||||
if yi < 0 then
|
||||
inc (yi, image.height);
|
||||
canv.colors[x,y] := Image.colors[xi, yi];
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
info.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@ -3,8 +3,7 @@ program Drawing;
|
||||
|
||||
uses classes, sysutils,
|
||||
FPImage, FPCanvas, FPImgCanv,
|
||||
FPWritePNG, FPReadPNG,
|
||||
ftfont;
|
||||
FPWritePNG, FPReadPNG;
|
||||
|
||||
const
|
||||
MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
|
||||
@ -14,10 +13,8 @@ var canvas : TFPcustomCAnvas;
|
||||
ci, image : TFPCustomImage;
|
||||
writer : TFPCustomImageWriter;
|
||||
reader : TFPCustomImageReader;
|
||||
ff : string;
|
||||
afont : TFreeTypeFont;
|
||||
begin
|
||||
image := TFPMemoryImage.Create (16,16);
|
||||
image := TFPMemoryImage.Create (100,100);
|
||||
ci := TFPMemoryImage.Create (20,20);
|
||||
Canvas := TFPImageCanvas.Create (image);
|
||||
Writer := TFPWriterPNG.Create;
|
||||
@ -25,89 +22,54 @@ begin
|
||||
with TFPWriterPNG(Writer) do
|
||||
begin
|
||||
indexed := false;
|
||||
wordsized := true;
|
||||
wordsized := false;
|
||||
UseAlpha := false;
|
||||
GrayScale := false;
|
||||
end;
|
||||
try
|
||||
if paramcount > 0 then
|
||||
ff := paramstr(1)
|
||||
else
|
||||
ff := 'arial';
|
||||
ci.LoadFromFile ('test.png', reader);
|
||||
with Canvas as TFPImageCanvas do
|
||||
begin
|
||||
height := 30;
|
||||
width := 60;
|
||||
with brush do
|
||||
begin
|
||||
color := colBlue;
|
||||
style := bsSolid;
|
||||
end;
|
||||
rectangle(0,0, 20,29);
|
||||
with pen do
|
||||
begin
|
||||
color := colLtGray;
|
||||
end;
|
||||
Line (0,18, 59,18);
|
||||
afont := TFreeTypeFont.Create;
|
||||
with afont do
|
||||
begin
|
||||
name := ff;
|
||||
fontindex := 0;
|
||||
size := 12;
|
||||
color := colWhite;
|
||||
AntiAliased := True;
|
||||
resolution := 96;
|
||||
end;
|
||||
font := afont;
|
||||
writeln ('Outputting texts');
|
||||
// TextOut (20,30, 'Font: '+font.name);
|
||||
font.color := colLtGray;
|
||||
//TextOut (40,80, 'Meer van dit, veel meer...');
|
||||
writeln (Gettextwidth('correct?'));
|
||||
writeln (Gettextheight('correct?'));
|
||||
TextOut (5,17, 'correct?');
|
||||
with colors[6,7] do
|
||||
writeln ('color 6,7 = ',red,',',green,',',blue);
|
||||
aFont.antialiased := False;
|
||||
afont.angle := -0.523598;
|
||||
font.color := colLtGray;
|
||||
//TextOut (40,100, 'Meer van dit, veel meer...');
|
||||
font.color := colRed;
|
||||
font.size := 24;
|
||||
aFont.Angle := PI / 2.4;
|
||||
font.color := colGreen;
|
||||
//TextOut (100,240, 'HOERA !');
|
||||
font.size := 26;
|
||||
aFont.Angle := aFont.Angle + (pi / 90);
|
||||
font.color := colBlue;
|
||||
//TextOut (250,240, 'HOERA !');
|
||||
font.size := 28;
|
||||
aFont.Angle := aFont.Angle + (pi / 90);
|
||||
font.color := colRed;
|
||||
//TextOut (400,240, 'HOERA !');
|
||||
writeln ('Text written');
|
||||
{ brush.color := colYellow;
|
||||
brush.Style := bsSolid;
|
||||
rectangle (60,0, 130,40);
|
||||
|
||||
pen.color := colSilver;
|
||||
pen.mode := pmCopy;
|
||||
pen.style := psSolid;
|
||||
pen.width := 1;
|
||||
brush.color := MyColor;
|
||||
pen.color := colBlue;
|
||||
Rectangle (0,160, 120,200);
|
||||
pen.color := colred;
|
||||
with pen.color do
|
||||
red := red div 4;
|
||||
Ellipse (10,10, 90,90);
|
||||
|
||||
brush.style := bsDiagCross;
|
||||
brush.color := colGreen;
|
||||
pen.style := psDashDot;
|
||||
pen.color := colred;
|
||||
HashWidth := 10;
|
||||
Ellipse (10,10, 90,90);
|
||||
|
||||
with pen.color do
|
||||
begin
|
||||
red := red div 2;
|
||||
green := red div 4;
|
||||
blue := green;
|
||||
end;
|
||||
pen.style := psSolid;
|
||||
RelativeBrushImage := true;
|
||||
brush.image := ci;
|
||||
brush.style := bsimage;
|
||||
with brush.color do
|
||||
green := green div 2;
|
||||
Ellipse (11,11, 89,89);
|
||||
|
||||
brush.style := bsSolid;
|
||||
brush.color := MyColor;
|
||||
pen.style := psSolid;
|
||||
pen.width := 3;
|
||||
pen.color := colSilver;
|
||||
Rectangle (150,50, 250,150);
|
||||
ellipse (30,35, 70,65);
|
||||
|
||||
pen.width := 1;
|
||||
pen.color := colCyan;
|
||||
ellipseC (50,50, 1,1);
|
||||
|
||||
writeln ('Saving to inspect !');
|
||||
} end;
|
||||
end;
|
||||
image.SaveToFile ('DrawTest.png', writer);
|
||||
finally
|
||||
Canvas.Free;
|
||||
|
||||
@ -438,11 +438,15 @@ begin
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Ellipse (left,top,right,bottom:integer);
|
||||
var b : TRect;
|
||||
begin
|
||||
Ellipse (Rect(left,top,right,bottom));
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.EllipseC (x,y:integer; rx,ry:longword);
|
||||
begin
|
||||
Ellipse (Rect(x-rx,y-ry,x+rx,y+ry));
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Rectangle (left,top,right,bottom:integer);
|
||||
begin
|
||||
Rectangle (Rect(left,top,right,bottom));
|
||||
|
||||
@ -219,6 +219,7 @@ type
|
||||
// using pen and brush
|
||||
procedure Ellipse (Const Bounds:TRect);
|
||||
procedure Ellipse (left,top,right,bottom:integer);
|
||||
procedure EllipseC (x,y:integer; rx,ry:longword);
|
||||
procedure Polygon (Const points:array of TPoint);
|
||||
procedure Polyline (Const points:array of TPoint);
|
||||
procedure Rectangle (Const Bounds:TRect);
|
||||
|
||||
@ -18,7 +18,7 @@ unit FPPixlCanv;
|
||||
|
||||
interface
|
||||
|
||||
uses classes, FPImage, FPCanvas, PixTools;
|
||||
uses classes, FPImage, FPCanvas, PixTools, ellipses;
|
||||
|
||||
type
|
||||
|
||||
@ -223,23 +223,41 @@ begin
|
||||
end;
|
||||
|
||||
procedure TFPPixelCanvas.DoEllipseFill (const Bounds:TRect);
|
||||
begin //TODO
|
||||
begin
|
||||
case Brush.style of
|
||||
bsSolid : FillEllipseColor (self, Bounds, brush.color);
|
||||
bsPattern : FillEllipsePattern (self, Bounds, brush.pattern, brush.color);
|
||||
bsImage :
|
||||
if assigned (brush.image) then
|
||||
if FRelativeBI then
|
||||
FillEllipseImageRel (self, Bounds, brush.image)
|
||||
else
|
||||
FillEllipseImage (self, Bounds, brush.image)
|
||||
else
|
||||
raise PixelCanvasException.Create (sErrNoImage);
|
||||
bsDiagonal : FillEllipseHashDiagonal (self, Bounds, FHashWidth, brush.color);
|
||||
bsFDiagonal : FillEllipseHashBackDiagonal (self, Bounds, FHashWidth, brush.color);
|
||||
bsCross : FillEllipseHashCross (self, Bounds, FHashWidth, brush.color);
|
||||
bsDiagCross : FillEllipseHashDiagCross (self, Bounds, FHashWidth, brush.color);
|
||||
bsHorizontal : FillEllipseHashHorizontal (self, Bounds, FHashWidth, brush.color);
|
||||
bsVertical : FillEllipseHashVertical (self, Bounds, FHashWidth, brush.color);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPPixelCanvas.DoEllipse (const Bounds:TRect);
|
||||
var
|
||||
Cx,Cy,Rx,Ry,phi:Integer;
|
||||
begin //TODO: how to find center points and radius from bounds ?
|
||||
with Bounds do
|
||||
begin
|
||||
Cx:=(Right+Left) shr 2;
|
||||
Cy:=(Bottom+Top) shr 2;
|
||||
Rx:=Abs(Right-Left) shr 2;
|
||||
Ry:=Abs(Bottom-Top) shr 2;
|
||||
begin
|
||||
with pen do
|
||||
case style of
|
||||
psSolid :
|
||||
if pen.width > 1 then
|
||||
DrawSolidEllipse (self, Bounds, width, color)
|
||||
else
|
||||
DrawSolidEllipse (self, Bounds, color);
|
||||
psPattern:
|
||||
DrawPatternEllipse (self, Bounds, pattern, color);
|
||||
psDash, psDot, psDashDot, psDashDotDot :
|
||||
DrawPatternEllipse (self, Bounds, PenPatterns[Style], color);
|
||||
end;
|
||||
MoveTo(Cx+Rx,Cy);
|
||||
for phi:=1 to 360 do
|
||||
LineTo(Cx+Round(Rx*Cos(phi*Pi/180)),Cy+Round(Ry*Sin(phi*Pi/180)));
|
||||
end;
|
||||
|
||||
procedure TFPPixelCanvas.DoPolygonFill (const points:array of TPoint);
|
||||
|
||||
@ -61,7 +61,7 @@ procedure FillFloodImageRel (Canv:TFPCustomCanvas; x,y :integer; const Image:TFP
|
||||
|
||||
implementation
|
||||
|
||||
uses clipping;
|
||||
uses clipping, ellipses;
|
||||
|
||||
procedure FillRectangleColor (Canv:TFPCustomCanvas; x1,y1, x2,y2:integer);
|
||||
begin
|
||||
@ -981,7 +981,7 @@ end;
|
||||
|
||||
procedure SetFloodHashDiag(Canv:TFPCustomCanvas; x,y:integer; data:pointer);
|
||||
var r : PFloodHashRec;
|
||||
w : 0..PatternBitCount-1;
|
||||
w : integer;
|
||||
begin
|
||||
r := PFloodHashRec(data);
|
||||
w := r^.width;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user