babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
lasarus_compotents/bgrabitmap/test/bgralape/basic_geometry_functions.inc

299 lines
12 KiB
PHP
Raw Blame History

procedure MyFillRect{$i lape.proc}
begin
target.FillRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PBGRAPixel(Params^[4])^,TDrawMode(PInt32(Params^[5])^));
end;
procedure MyRectangle{$i lape.proc}
begin
target.Rectangle(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PBGRAPixel(Params^[4])^,TDrawMode(PInt32(Params^[5])^));
end;
procedure MyRectangleWithFill{$i lape.proc}
begin
target.Rectangle(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PBGRAPixel(Params^[4])^,PBGRAPixel(Params^[5])^,TDrawMode(PInt32(Params^[6])^));
end;
function GetSortedRect(x1,y1,x2,y2: integer): TRect;
begin
if x1 > x2 then
begin
result.left := x2;
result.right := x1;
end else
begin
result.left := x1;
result.right := x2;
end;
if y1 > y2 then
begin
result.top := y2;
result.bottom := y1;
end else
begin
result.top := y1;
result.bottom := y2;
end;
end;
procedure MyFillRoundRect{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[7])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[8])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
target.FillRoundRectAntialias(Left-0.5,top-0.5,right-0.5,bottom-0.5,PSingle(Params^[4])^,PSingle(Params^[5])^,PBGRAPixel(Params^[6])^,[]);
target.LinearAntialiasing:= false;
end
else
target.FillRoundRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,round(PSingle(Params^[4])^*2),round(PSingle(Params^[5])^*2),PBGRAPixel(Params^[6])^,dm);
end;
procedure MyRoundRect{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[7])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[8])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
if (right>left) and (bottom>top) then
target.RoundRectAntialias(Left,top,right-1,bottom-1,PSingle(Params^[4])^,PSingle(Params^[5])^,PBGRAPixel(Params^[6])^,1,[]);
target.LinearAntialiasing:= false;
end
else
target.RoundRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,round(PSingle(Params^[4])^*2),round(PSingle(Params^[5])^*2),PBGRAPixel(Params^[6])^,dm);
end;
procedure MyRoundRectWithFill{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[8])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[9])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
if (right>left) and (bottom>top) then
target.RoundRectAntialias(Left,top,right-1,bottom-1,PSingle(Params^[4])^,PSingle(Params^[5])^,PBGRAPixel(Params^[6])^,1,PBGRAPixel(Params^[7])^,[]);
target.LinearAntialiasing:= false;
end
else
target.RoundRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,round(PSingle(Params^[4])^*2),round(PSingle(Params^[5])^*2),PBGRAPixel(Params^[6])^,PBGRAPixel(Params^[7])^,dm);
end;
procedure MyFillEllipseInRect{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[5])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[6])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
target.FillEllipseAntialias((Left+right)*0.5-0.5,(top+bottom)*0.5-0.5,(right-left)*0.5,(bottom-top)*0.5,PBGRAPixel(Params^[4])^);
target.LinearAntialiasing:= false;
end
else
target.FillEllipseInRect(rect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^),PBGRAPixel(Params^[4])^,dm);
end;
procedure MyEllipseInRect{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[5])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[6])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
if (right>left) and (bottom>top) then
target.EllipseAntialias((Left+right)*0.5-0.5,(top+bottom)*0.5-0.5,(right-left-1)*0.5,(bottom-top-1)*0.5,PBGRAPixel(Params^[4])^,1);
target.LinearAntialiasing:= false;
end
else
target.EllipseInRect(rect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^),PBGRAPixel(Params^[4])^,dm);
end;
procedure MyEllipseInRectWithFill{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[6])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[7])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
with GetSortedRect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^) do
if (right>left) and (bottom>top) then
target.EllipseAntialias((Left+right)*0.5-0.5,(top+bottom)*0.5-0.5,(right-left-1)*0.5,(bottom-top-1)*0.5,PBGRAPixel(Params^[4])^,1,PBGRAPixel(Params^[5])^);
target.LinearAntialiasing:= false;
end
else
target.EllipseInRect(rect(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^),PBGRAPixel(Params^[4])^,PBGRAPixel(Params^[5])^,dm);
end;
procedure MyDrawLine{$i lape.proc}
var dm: TDrawMode;
begin
dm := TDrawMode(PInt32(Params^[5])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[6])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
target.DrawLineAntialias(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PBGRAPixel(Params^[4])^,true);
target.LinearAntialiasing:= false;
end
else
target.DrawLine(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PBGRAPixel(Params^[4])^,true,dm);
end;
procedure MyEraseLine{$i lape.proc}
begin
if PLongBool(Params^[5])^ then
target.EraseLineAntialias(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PByte(Params^[4])^,true)
else
target.EraseLine(PInt32(Params^[0])^,PInt32(Params^[1])^,PInt32(Params^[2])^,PInt32(Params^[3])^,PByte(Params^[4])^,true);
end;
procedure MyDrawPolyLine{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
dm: TDrawMode;
begin
pts := Params^[0];
dm := TDrawMode(PInt32(Params^[2])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[3])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
target.DrawPolyLineAntialias(pts^,PBGRAPixel(Params^[1])^,true);
target.LinearAntialiasing:= false;
end
else
target.DrawPolyLine(pts^,PBGRAPixel(Params^[1])^,true,dm);
end;
procedure MyErasePolyLine{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
begin
pts := Params^[0];
if PLongBool(Params^[2])^ then
target.ErasePolyLineAntialias(pts^,PByte(Params^[1])^,true)
else
target.ErasePolyLine(pts^,PByte(Params^[1])^,true);
end;
procedure MyErasePolygonOutline{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
begin
pts := Params^[0];
if PLongBool(Params^[2])^ then
target.ErasePolygonOutlineAntialias(pts^,PByte(Params^[1])^)
else
target.ErasePolygonOutline(pts^,PByte(Params^[1])^);
end;
procedure MyDrawPolygon{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
dm: TDrawMode;
begin
pts := Params^[0];
dm := TDrawMode(PInt32(Params^[2])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[3])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
target.DrawPolygonAntialias(pts^,PBGRAPixel(Params^[1])^);
target.LinearAntialiasing:= false;
end
else
target.DrawPolygon(pts^,PBGRAPixel(Params^[1])^,dm);
end;
procedure MyFillPoly{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
ptsF: ArrayOfTPointF;
dm: TDrawMode;
i: integer;
begin
pts := Params^[0];
setlength(ptsF, length(pts^));
for i := 0 to high(pts^) do
with pts^[i] do
ptsF[i] := PointF(x,y);
dm := TDrawMode(PInt32(Params^[2])^);
if (dm in[dmDrawWithTransparency,dmLinearBlend]) and PLongBool(Params^[3])^ then
begin
target.LinearAntialiasing:= (dm=dmLinearBlend);
target.FillPolyAntialias(ptsF,PBGRAPixel(Params^[1])^);
target.LinearAntialiasing:= false;
end
else
target.FillPoly(ptsF,PBGRAPixel(Params^[1])^,dm);
end;
procedure MyErasePoly{$i lape.proc}
type
ArrayOfTPoint = array of TPoint;
PArrayOfTPoint = ^ArrayOfTPoint;
var
pts: PArrayOfTPoint;
ptsF: ArrayOfTPointF;
i: integer;
begin
pts := Params^[0];
setlength(ptsF, length(pts^));
for i := 0 to high(pts^) do
with pts^[i] do
ptsF[i] := PointF(x,y);
if PLongBool(Params^[2])^ then
target.ErasePolyAntialias(ptsF,PByte(Params^[1])^)
else
target.ErasePoly(ptsF,PByte(Params^[1])^);
end;
procedure RegisterBasicGeometryFunctions(Compiler: TLapeCompiler);
begin
Compiler.addGlobalFunc('procedure _FillRect(left, top, right, bottom: Int32; c: TBGRAPixel; ADrawMode: Int32);', @MyFillRect);
Compiler.addGlobalFunc('procedure _Rectangle(left, top, right, bottom: Int32; c: TBGRAPixel; ADrawMode: Int32);', @MyRectangle);
Compiler.addGlobalFunc('procedure _RectangleWithFill(left, top, right, bottom: Int32; c,fillcolor: TBGRAPixel; ADrawMode: Int32); overload;', @MyRectangleWithFill);
Compiler.addGlobalFunc('procedure _FillRoundRect(left, top, right, bottom: Int32; rx,ry: single; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyFillRoundRect);
Compiler.addGlobalFunc('procedure _RoundRect(left, top, right, bottom: Int32; rx,ry: single; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyRoundRect);
Compiler.addGlobalFunc('procedure _RoundRectWithFill(left, top, right, bottom: Int32; rx,ry: single; c,fillcolor: TBGRAPixel; ADrawMode: Int32; AA: LongBool); overload;', @MyRoundRectWithFill);
Compiler.addGlobalFunc('procedure _FillEllipseInRect(left, top, right, bottom: Int32; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyFillEllipseInRect);
Compiler.addGlobalFunc('procedure _EllipseInRect(left, top, right, bottom: Int32; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyEllipseInRect);
Compiler.addGlobalFunc('procedure _EllipseInRectWithFill(left, top, right, bottom: Int32; c,fillcolor: TBGRAPixel; ADrawMode: Int32; AA: LongBool); overload;', @MyEllipseInRectWithFill);
Compiler.addGlobalFunc('procedure _DrawLine(x1,y1,x2,y2: Int32; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyDrawLine);
Compiler.addGlobalFunc('procedure _EraseLine(x1,y1,x2,y2: Int32; alpha: byte; AA: LongBool);', @MyEraseLine);
Compiler.addGlobalFunc('procedure _DrawPolyLine(const points: array of TPoint; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyDrawPolyLine);
Compiler.addGlobalFunc('procedure _ErasePolyLine(const points: array of TPoint; alpha: byte; AA: LongBool);', @MyErasePolyLine);
Compiler.addGlobalFunc('procedure _DrawPolygon(const points: array of TPoint; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyDrawPolygon);
Compiler.addGlobalFunc('procedure _ErasePolygonOutline(const points: array of TPoint; alpha: byte; AA: LongBool);', @MyErasePolygonOutline);
Compiler.addGlobalFunc('procedure _FillPoly(const points: array of TPoint; c: TBGRAPixel; ADrawMode: Int32; AA: LongBool);', @MyFillPoly);
Compiler.addGlobalFunc('procedure _ErasePoly(const points: array of TPoint; alpha: byte; AA: LongBool);', @MyErasePoly);
end;
Reference in New Issue View Git Blame Copy Permalink