MainUnit.pas 10 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390
  1. unit MainUnit;
  2. (* ***** BEGIN LICENSE BLOCK *****
  3. * Version: MPL 1.1 or LGPL 2.1 with linking exception
  4. *
  5. * The contents of this file are subject to the Mozilla Public License Version
  6. * 1.1 (the "License"); you may not use this file except in compliance with
  7. * the License. You may obtain a copy of the License at
  8. * http://www.mozilla.org/MPL/
  9. *
  10. * Software distributed under the License is distributed on an "AS IS" basis,
  11. * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  12. * for the specific language governing rights and limitations under the
  13. * License.
  14. *
  15. * Alternatively, the contents of this file may be used under the terms of the
  16. * Free Pascal modified version of the GNU Lesser General Public License
  17. * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
  18. * of this license are applicable instead of those above.
  19. * Please see the file LICENSE.txt for additional information concerning this
  20. * license.
  21. *
  22. * The Original Code is Curves Example (based on VPR example)
  23. *
  24. * The Initial Developer of the Original Code is
  25. * Mattias Andersson <[email protected]>
  26. *
  27. * Portions created by the Initial Developer are Copyright (C) 2000-2005
  28. * the Initial Developer. All Rights Reserved.
  29. *
  30. * ***** END LICENSE BLOCK ***** *)
  31. interface
  32. {$include GR32.inc}
  33. uses
  34. {$IFDEF FPC} LCLIntf, LResources, Buttons, {$ENDIF}
  35. Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
  36. ExtCtrls,
  37. GR32,
  38. GR32_Image,
  39. GR32_Polygons,
  40. GR32_Transforms,
  41. GR32_Paths,
  42. GR32_Brushes;
  43. type
  44. // Draws a single dot at each vertex
  45. TDotBrush = class(TCustomBrush)
  46. strict private
  47. FColor: TColor32;
  48. private
  49. procedure SetColor(const Value: TColor32);
  50. protected
  51. procedure RenderPolyPolygon(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  52. const ClipRect: TFloatRect; Transformation: TTransformation); override;
  53. public
  54. constructor Create(BrushCollection: TBrushCollection); override;
  55. property Color: TColor32 read FColor write SetColor;
  56. end;
  57. type
  58. // Draws a circle, using the nested brushes, at each vertex
  59. TCircleBrush = class(TNestedBrush)
  60. strict private
  61. FRadius: TFloat;
  62. private
  63. procedure SetRadius(const Value: TFloat);
  64. protected
  65. public
  66. constructor Create(BrushCollection: TBrushCollection); override;
  67. procedure PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  68. const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean); override;
  69. procedure PolyPolygonMixedFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  70. const ClipRect: TFloatRect; Transformation: TTransformation; Closed: TBooleanArray); override;
  71. property Radius: TFloat read FRadius write SetRadius;
  72. end;
  73. type
  74. TMainForm = class(TForm)
  75. Paintbox: TPaintBox32;
  76. Panel1: TPanel;
  77. BtnDrawCurve: TButton;
  78. CbxUpdate: TCheckBox;
  79. procedure BtnDrawCurveClick(Sender: TObject);
  80. procedure CbxUpdateClick(Sender: TObject);
  81. procedure ApplicationIdleHandler(Sender: TObject; var Done: Boolean);
  82. procedure PaintboxClick(Sender: TObject);
  83. procedure PaintboxPaintBuffer(Sender: TObject);
  84. private
  85. FCanvas32: TCanvas32;
  86. FCurveBrushes: TNestedBrush;
  87. FPointsBrushes: TNestedBrush;
  88. FBrushFill: TSolidBrush;
  89. FBrushDash: TDashedBrush;
  90. FBrushDot: TDotBrush;
  91. FBrushCircle: TCircleBrush;
  92. public
  93. constructor Create(AOwner: TComponent); override;
  94. destructor Destroy; override;
  95. end;
  96. var
  97. MainForm: TMainForm;
  98. implementation
  99. {$R *.dfm}
  100. uses
  101. Math,
  102. Types,
  103. GR32_Math,
  104. GR32_Geometry,
  105. GR32_VectorUtils,
  106. GR32_Resamplers,
  107. GR32_LowLevel;
  108. constructor TDotBrush.Create(BrushCollection: TBrushCollection);
  109. begin
  110. inherited;
  111. FColor := clWhite32;
  112. end;
  113. procedure TDotBrush.RenderPolyPolygon(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  114. const ClipRect: TFloatRect; Transformation: TTransformation);
  115. var
  116. i, j: integer;
  117. Bitmap: TCustomBitmap32;
  118. begin
  119. Bitmap := (Renderer as TPolygonRenderer32).Bitmap;
  120. for i := 0 to High(Points) do
  121. for j := 0 to High(Points[i]) do
  122. Bitmap.PixelFS[Points[i, j].X, Points[i, j].Y] := FColor;
  123. end;
  124. procedure TDotBrush.SetColor(const Value: TColor32);
  125. begin
  126. if (FColor = Value) then
  127. exit;
  128. FColor := Value;
  129. Changed;
  130. end;
  131. constructor TCircleBrush.Create(BrushCollection: TBrushCollection);
  132. begin
  133. inherited;
  134. FRadius := 2.0;
  135. end;
  136. procedure TCircleBrush.PolyPolygonFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  137. const ClipRect: TFloatRect; Transformation: TTransformation; Closed: Boolean);
  138. var
  139. CirclePoints: TArrayOfArrayOfFloatPoint;
  140. Center, LastCenter, Delta: TFloatPoint;
  141. i, j, k: integer;
  142. begin
  143. LastCenter := FloatPoint(0, 0);
  144. SetLength(CirclePoints, 1);
  145. CirclePoints[0] := Circle(LastCenter, FRadius);
  146. for i := 0 to High(Points) do
  147. for j := 0 to High(Points[i]) do
  148. begin
  149. Center := Points[i, j];
  150. Delta := Center - LastCenter;
  151. LastCenter := Center;
  152. // Translate circle to new center in-place
  153. for k := 0 to High(CirclePoints[0]) do
  154. CirclePoints[0, k] := CirclePoints[0, k] + Delta;
  155. inherited PolyPolygonFS(Renderer, CirclePoints, ClipRect, Transformation, True);
  156. end;
  157. end;
  158. procedure TCircleBrush.PolyPolygonMixedFS(Renderer: TCustomPolygonRenderer; const Points: TArrayOfArrayOfFloatPoint;
  159. const ClipRect: TFloatRect; Transformation: TTransformation; Closed: TBooleanArray);
  160. begin
  161. PolyPolygonFS(Renderer, Points, ClipRect, Transformation, True);
  162. end;
  163. procedure TCircleBrush.SetRadius(const Value: TFloat);
  164. begin
  165. if (FRadius = Value) then
  166. exit;
  167. FRadius := Value;
  168. Changed;
  169. end;
  170. function MakeCurve(const Points: TArrayOfFloatPoint; Kernel: TCustomKernel;
  171. Closed: Boolean): TArrayOfFloatPoint;
  172. const
  173. TOLERANCE: TFloat = 20.0;
  174. THRESHOLD: TFloat = 0.5;
  175. var
  176. I, H, R: Integer;
  177. Filter: TFilterMethod;
  178. WrapProc: TWrapProc;
  179. procedure AddPoint(const P: TFloatPoint);
  180. var
  181. L: Integer;
  182. begin
  183. L := Length(Result);
  184. SetLength(Result, L + 1);
  185. Result[L] := P;
  186. end;
  187. function GetPoint(I: Integer; t: TFloat = 0.0): TFloatPoint;
  188. var
  189. f, Index: Integer;
  190. W: TFloat;
  191. begin
  192. Result.X := 0; Result.Y := 0;
  193. for f := -R to R do
  194. begin
  195. Index := WrapProc(I - f, H);
  196. W := Filter(f + t);
  197. Result.X := Result.X + W * Points[Index].X;
  198. Result.Y := Result.Y + W * Points[Index].Y;
  199. end;
  200. end;
  201. procedure Recurse(I: Integer; const P1, P2: TFloatPoint; const t1, t2: TFloat);
  202. var
  203. Temp: TFloat;
  204. P: TFloatPoint;
  205. begin
  206. AddPoint(P1);
  207. Temp := (t1 + t2) * 0.5;
  208. P := GetPoint(I, Temp);
  209. if (Abs(CrossProduct(FloatPoint(P1.X - P.X, P1.Y - P.Y),
  210. FloatPoint(P.X - P2.X, P.Y - P2.Y))) > TOLERANCE) or (t2 - t1 >= THRESHOLD) then
  211. begin
  212. Recurse(I, P1, P, t1, Temp);
  213. Recurse(I, P, P2, Temp, t2);
  214. end else
  215. AddPoint(P);
  216. end;
  217. const
  218. WRAP_PROC: array[Boolean] of TWrapProc = (Clamp, Wrap);
  219. begin
  220. SetLength(Result, 0);
  221. WrapProc := Wrap_PROC[Closed];
  222. Filter := Kernel.Filter;
  223. R := Ceil(Kernel.GetWidth);
  224. H := High(Points);
  225. for I := 0 to H - 1 do
  226. Recurse(I, GetPoint(I), GetPoint(I + 1), 0, 1);
  227. if Closed then
  228. Recurse(H, GetPoint(H), GetPoint(0), 0, 1)
  229. else
  230. AddPoint(GetPoint(H));
  231. end;
  232. constructor TMainForm.Create(AOwner: TComponent);
  233. var
  234. BrushCircleFill: TSolidBrush;
  235. BrushCircleStroke: TStrokeBrush;
  236. begin
  237. inherited;
  238. FCanvas32 := TCanvas32.Create(Paintbox.Buffer);
  239. FCurveBrushes := TNestedBrush(FCanvas32.Brushes.Add(TNestedBrush));
  240. FPointsBrushes := TNestedBrush(FCanvas32.Brushes.Add(TNestedBrush));
  241. FBrushFill := TSolidBrush(FCurveBrushes.Brushes.Add(TSolidBrush));
  242. FBrushFill.FillColor := clIndianRed32;
  243. FBrushFill.FillMode := pfEvenOdd;
  244. FBrushDash := TDashedBrush(FCurveBrushes.Brushes.Add(TDashedBrush));
  245. FBrushDash.FillColor := clWhite32;
  246. FBrushDash.StrokeWidth := 6;
  247. FBrushDash.DashArray := [10, 5];
  248. FBrushDash.Visible := False;
  249. FBrushDot := TDotBrush(FCurveBrushes.Brushes.Add(TDotBrush));
  250. FBrushDot.Color := clLime32;
  251. FBrushCircle := TCircleBrush(FPointsBrushes.Brushes.Add(TCircleBrush));
  252. FBrushCircle.Radius := 4;
  253. BrushCircleFill := TSolidBrush(FBrushCircle.Brushes.Add(TSolidBrush));
  254. BrushCircleFill.FillColor := clBlue32;
  255. BrushCircleStroke := TStrokeBrush(FBrushCircle.Brushes.Add(TStrokeBrush));
  256. BrushCircleStroke.FillColor := clWhite32;
  257. BrushCircleStroke.StrokeWidth := 1.5;
  258. {$ifndef FPC}
  259. Paintbox.Margins.SetBounds(8,8,8,8);
  260. Paintbox.AlignWithMargins := True;
  261. {$endif}
  262. end;
  263. destructor TMainForm.Destroy;
  264. begin
  265. FCanvas32.Free;
  266. inherited;
  267. end;
  268. procedure TMainForm.PaintboxClick(Sender: TObject);
  269. begin
  270. FBrushDash.Visible := not FBrushDash.Visible;
  271. Paintbox.ForceFullInvalidate;
  272. end;
  273. procedure TMainForm.BtnDrawCurveClick(Sender: TObject);
  274. begin
  275. Paintbox.ForceFullInvalidate;
  276. end;
  277. procedure TMainForm.PaintboxPaintBuffer(Sender: TObject);
  278. var
  279. Points, Curve: TArrayOfFloatPoint;
  280. I: Integer;
  281. K: TCustomKernel;
  282. begin
  283. Paintbox.Buffer.Clear($FF333333);
  284. SetLength(Points, 8);
  285. // Create a set of random data points
  286. for I := 0 to High(Points) do
  287. Points[I] := FloatPoint(Random(Paintbox.Buffer.Width), Random(Paintbox.Buffer.Height));
  288. // Create interpolation kernel
  289. // We previously used TGaussianKernel here but after that kernel was fixed
  290. // it no longer gives us the curve we would like; A curve that intersects
  291. // the control points.
  292. K := THammingKernel.Create;
  293. try
  294. // Subdivide recursively and interpolate
  295. Curve := MakeCurve(Points, K, True);
  296. finally
  297. K.Free;
  298. end;
  299. // Draw result polygon
  300. FCanvas32.BeginUpdate;
  301. try
  302. FCurveBrushes.Visible := True;
  303. FPointsBrushes.Visible := False;
  304. FCanvas32.Polygon(Curve);
  305. finally
  306. FCanvas32.EndUpdate;
  307. end;
  308. // Draw control points
  309. FCanvas32.BeginUpdate;
  310. try
  311. FCurveBrushes.Visible := False;
  312. FPointsBrushes.Visible := True;
  313. FCanvas32.Polygon(Points);
  314. finally
  315. FCanvas32.EndUpdate;
  316. end;
  317. end;
  318. procedure TMainForm.ApplicationIdleHandler(Sender: TObject; var Done: Boolean);
  319. begin
  320. Paintbox.ForceFullInvalidate;
  321. end;
  322. procedure TMainForm.CbxUpdateClick(Sender: TObject);
  323. begin
  324. if CbxUpdate.Checked then
  325. Application.OnIdle := ApplicationIdleHandler
  326. else
  327. Application.OnIdle := nil;
  328. end;
  329. end.