* renamecommit fix casing

fcl/image/ellipses.pp

@@ -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.