paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 20:19:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* renamed t ellipses.pp

Browse Source
This commit is contained in:
marco 2003-10-27 10:33:20 +00:00
parent b1be5b535f
commit 182da2f650
1 changed files with 0 additions and 704 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

704
fcl/image/Ellipses.pp
View File

@ -1,704 +0,0 @@
{
$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.