1 unit gouraud_main; 2 3 {$mode objfpc}{$H+} 4 5 interface 6 7 uses 8 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls, 9 StdCtrls, ComCtrls, BGRABitmap, BGRABitmapTypes, LMessages; 10 11 type 12 13 { TForm1 } 14 15 TForm1 = class(TForm) 16 Label1: TLabel; 17 Panel1: TPanel; 18 TrackBar1: TTrackBar; 19 procedure FormCreate(Sender: TObject); 20 procedure FormMouseDown(Sender: TObject; Button: TMouseButton; 21 Shift: TShiftState; X, Y: Integer); 22 procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); 23 procedure FormMouseUp(Sender: TObject; Button: TMouseButton; 24 Shift: TShiftState; X, Y: Integer); 25 { private declarations } 26 procedure FormPaint(Sender: TObject); 27 procedure TrackBar1Change(Sender: TObject); 28 procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND; 29 public 30 { public declarations } 31 MovingPointIndex: Integer; 32 MovingOrigin: TPointF; 33 pts: array[0..2] of TPointF; 34 end; 35 36 var 37 Form1: TForm1; 38 39 implementation 40 41 {$R *.lfm} 42 43 uses BGRAPolygon; 44 45 procedure NicePoint(bmp: TBGRABitmap; x, y: single); 46 begin 47 bmp.EllipseAntialias(x,y,4,4,BGRA(0,0,0,192),1); 48 bmp.EllipseAntialias(x,y,3,3,BGRA(255,255,255,192),1); 49 bmp.EllipseAntialias(x,y,2,2,BGRA(0,0,0,192),1); 50 end; 51 52 { TForm1 } 53 54 procedure TForm1.FormPaint(Sender: TObject); 55 var bmp: TBGRABitmap; 56 tx,ty,i: Integer; 57 c: TPointF; 58 multi: TBGRAMultishapeFiller; 59 opacity: byte; 60 begin 61 tx := ClientWidth; 62 ty := Panel1.Top; 63 64 bmp := TBGRABitmap.Create(tx,ty,BGRAWhite); 65 66 opacity := TrackBar1.Position; 67 c := (pts[0]+pts[1]+pts[2])*(1/3); 68 multi := TBGRAMultishapeFiller.Create; 69 multi.AddQuadLinearColor(pts[0],c,pts[2],pts[2]+(pts[0]-c), 70 BGRA(0,0,255,opacity),BGRA(255,255,255,opacity),BGRA(255,0,0,opacity),BGRA(0,0,0,opacity)); 71 multi.AddQuadLinearColor(pts[0],c,pts[1],pts[1]+(pts[0]-c), 72 BGRA(0,0,255,opacity),BGRA(255,255,255,opacity),BGRA(0,255,0,opacity),BGRA(0,0,0,opacity)); 73 multi.AddQuadLinearColor(pts[2],c,pts[1],pts[1]+(pts[2]-c), 74 BGRA(255,0,0,opacity),BGRA(255,255,255,opacity),BGRA(0,255,0,opacity),BGRA(0,0,0,opacity)); 75 multi.Draw(bmp); 76 multi.free; 77 78 for i := 0 to 2 do 79 NicePoint(bmp,pts[i].x,pts[i].y); 80 bmp.Draw(Canvas,0,0); 81 82 bmp.free; 83 end; 84 85 procedure TForm1.TrackBar1Change(Sender: TObject); 86 begin 87 Invalidate; 88 end; 89 90 procedure TForm1.WMEraseBkgnd(var Message: TLMEraseBkgnd); 91 begin 92 // 93 end; 94 95 procedure TForm1.FormCreate(Sender: TObject); 96 begin 97 pts[0] := PointF(150,10); 98 pts[1] := PointF(370,140); 99 pts[2] := PointF(50,260); 100 MovingPointIndex := -1; 101 end; 102 103 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 104 Shift: TShiftState; X, Y: Integer); 105 var maxDist,dist: single; 106 mousePos,vect: TPointF; 107 i: Integer; 108 begin 109 if Button <> mbLeft then exit; 110 111 //select point to move 112 MovingPointIndex := -1; 113 maxDist := 10; 114 mousePos := PointF(X,Y); 115 MovingOrigin := mousePos; 116 117 for i := 0 to high(pts) do 118 begin 119 vect := pts[i] - mousePos; 120 dist := sqrt(vect*vect); 121 if dist < maxDist then 122 begin 123 maxDist := dist; 124 MovingPointIndex := i; 125 end; 126 end; 127 end; 128 129 procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, 130 Y: Integer); 131 var 132 mousePos: TPointF; 133 i: Integer; 134 begin 135 if ssLeft in Shift then 136 begin 137 mousePos := PointF(X,Y); 138 if MovingPointIndex <> -1 then 139 pts[MovingPointIndex].Offset(mousePos-MovingOrigin) else 140 begin 141 for i := 0 to high(pts) do 142 pts[i].Offset(mousePos-MovingOrigin); 143 end; 144 Invalidate; 145 MovingOrigin := mousePos; 146 end; 147 end; 148 149 procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton; 150 Shift: TShiftState; X, Y: Integer); 151 begin 152 if Button = mbLeft then MovingPointIndex := -1; 153 end; 154 155 end. 156 157