Luxophia

LUX.FMX.ScatterPlotFrame.pas
605 строк · 17.5 Кб
Перенос по словам
1
unit LUX.FMX.ScatterPlotFrame;
2

3
interface //#################################################################### ■
4

5
uses
6
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
7
  FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls, FMX.Objects,
8
  LUX, LUX.D2, LUX.FMX;
9

10
type //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【型】
11

12
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TScaleLine
13

14
     TScaleLine = record
15
     private
16
     public
17
       Scale :Single;
18
       Thick :Single;
19
       Color :TAlphacolor;
20
       /////
21
       constructor Create( const Scale_,Thick_:Single; const Color_:TAlphacolor );
22
     end;
23

24
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TScatterPlotFrame
25

26
     TScatterPlotFrame = class(TFrame)
27
     private
28
     protected
29
        
30
       _Margin    :Single;
31
       _Area      :TRectF;
32
       _MinX      :Single;
33
       _MaxX      :Single;
34
       _MinY      :Single;
35
       _MaxY      :Single;
36
       _BackColor :TAlphaColor;
37
       _AreaColor :TAlphaColor;
38
       _Plots     :TArray<TSingle2D>;
39
       _PlotsN    :Integer;
40
       _PlotSize  :Single;
41
       _PlotColor :TAlphaColor;
42
       _Focus     :Integer;
43
       _Hover     :Integer;
44
       _ScaleX    :TArray<TScaleLine>;
45
       _ScaleY    :TArray<TScaleLine>;
46
       _ScaleN    :Integer;
47
       _FontColor :TAlphaColor;
48
       ///// アクセス
49
       procedure SetMargin( const Margin_:Single ); virtual;
50
       procedure SetMinX( const MinX_:Single ); virtual;
51
       procedure SetMaxX( const MaxX_:Single ); virtual;
52
       procedure SetMinY( const MinY_:Single ); virtual;
53
       procedure SetMaxY( const MaxY_:Single ); virtual;
54
       procedure SetBackColor( const BackColor_:TAlphaColor ); virtual;
55
       procedure SetAreaColor( const AreaColor_:TAlphaColor ); virtual;
56
       function GetPlot( const I_:Integer ) :TSingle2D; virtual;
57
       procedure SetPlot( const I_:Integer; const Plot_:TSingle2D ); virtual;
58
       procedure SetPlotsN( const PlotsN_:Integer ); virtual;
59
       procedure SetPlotSize( const PlotSize_:Single ); virtual;
60
       procedure SetPlotColor( const PlotColor_:TAlphaColor ); virtual;
61
       procedure SetFocus( const Focus_:Integer ); virtual;
62
       procedure SetHover( const Hover_:Integer ); virtual;
63
       function GetScaleX( const I_:Integer ) :TScaleLine; virtual;
64
       procedure SetScaleX( const I_:Integer; const ScaleX_:TScaleLine ); virtual;
65
       function GetScaleY( const I_:Integer ) :TScaleLine; virtual;
66
       procedure SetScaleY( const I_:Integer; const ScaleY_:TScaleLine ); virtual;
67
       procedure SetScaleN( const ScaleN_:Integer ); virtual;
68
       procedure SetFontColor( const FontColor_:TAlphaColor ); virtual;
69
       ///// メソッド
70
       procedure MouseDown( Button_:TMouseButton; Shift_:TShiftState; X_,Y_:Single ); override;
71
       procedure MouseMove( Shift_:TShiftState; X_,Y_:Single); override;
72
       procedure MouseUp( Button_:TMouseButton; Shift_:TShiftState; X_,Y_:Single ); override;
73
       procedure Paint; override;
74
       procedure Resize; override;
75
       function ScrToPos( const S_:TPointF ) :TSingle2D;
76
       function PosToScr( const P_:TSingle2D ) :TPointF;
77
       procedure DrawPlots;
78
       procedure DrawAxis;
79
       procedure DrawScaleX( const Interval_:Single );
80
       procedure DrawScaleY( const Interval_:Single );
81
       procedure DrawValuesX( const Interval_:Single; const Digits_:Integer );
82
       procedure DrawValuesY( const Interval_:Single; const Digits_:Integer );
83
       ///// プロパティ
84
       property Hover :Integer read _Hover write SetHover;
85
     public
86
        
87
       constructor Create( AOwner_:TComponent ); override;
88
       destructor Destroy; override;
89
       ///// プロパティ
90
       property Margin                     :Single      read   _Margin    write SetMargin   ;
91
       property Area                       :TRectF      read   _Area                        ;
92
       property MinX                       :Single      read   _MinX      write SetMinX     ;
93
       property MaxX                       :Single      read   _MaxX      write SetMaxX     ;
94
       property MinY                       :Single      read   _MinY      write SetMinY     ;
95
       property MaxY                       :Single      read   _MaxY      write SetMaxY     ;
96
       property BackColor                  :TAlphaColor read   _BackColor write SetBackColor;
97
       property AreaColor                  :TAlphaColor read   _AreaColor write SetAreaColor;
98
       property Plots[ const I_:Integer ]  :TSingle2D   read GetPlot      write SetPlot     ; default;
99
       property PlotsN                     :Integer     read   _PlotsN    write SetPlotsN   ;
100
       property PlotSize                   :Single      read   _PlotSize  write SetPlotSize ;
101
       property PlotColor                  :TAlphaColor read   _PlotColor write SetPlotColor;
102
       property Focus                      :Integer     read   _Focus     write SetFocus    ;
103
       property ScaleX[ const I_:Integer ] :TScaleLine  read GetScaleX    write SetScaleX   ;
104
       property ScaleY[ const I_:Integer ] :TScaleLine  read GetScaleY    write SetScaleY   ;
105
       property ScaleN                     :Integer     read   _ScaleN    write SetScaleN   ;
106
       property FontColor                  :TAlphaColor read   _FontColor write SetFontColor;
107
       ///// メソッド
108
       function FindNearPlot( const Scr_:TPointF ) :Integer; overload;
109
       function FindNearPlot( const Pos_:TSingle2D ) :Integer; overload;
110
     end;
111

112
implementation //############################################################### ■
113

114
{$R *.fmx}
115

116
uses System.Math;
117

118
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【型】
119

120
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【クラス】
121

122
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TScaleLine
123

124
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
125

126
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
127

128
constructor TScaleLine.Create( const Scale_,Thick_:Single; const Color_:TAlphacolor );
129
begin
130
     Scale := Scale_;
131
     Thick := Thick_;
132
     Color := Color_;
133
end;
134

135
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TScatterPlotFrame
136

137
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
138

139
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
140

141
/////////////////////////////////////////////////////////////////////// アクセス
142

143
procedure TScatterPlotFrame.SetMargin( const Margin_:Single );
144
begin
145
     _Margin := Margin_;  Repaint;
146
end;
147

148
procedure TScatterPlotFrame.SetMinX( const MinX_:Single );
149
begin
150
     _MinX := MinX_;  Repaint;
151
end;
152

153
procedure TScatterPlotFrame.SetMaxX( const MaxX_:Single );
154
begin
155
     _MaxX := MaxX_;  Repaint;
156
end;
157

158
procedure TScatterPlotFrame.SetMinY( const MinY_:Single );
159
begin
160
     _MinY := MinY_;  Repaint;
161
end;
162

163
procedure TScatterPlotFrame.SetMaxY( const MaxY_:Single );
164
begin
165
     _MaxY := MaxY_;  Repaint;
166
end;
167

168
//------------------------------------------------------------------------------
169

170
procedure TScatterPlotFrame.SetBackColor( const BackColor_:TAlphaColor );
171
begin
172
     _BackColor := BackColor_;  Repaint;
173
end;
174

175
procedure TScatterPlotFrame.SetAreaColor( const AreaColor_:TAlphaColor );
176
begin
177
     _AreaColor := AreaColor_;  Repaint;
178
end;
179

180
//------------------------------------------------------------------------------
181

182
function TScatterPlotFrame.GetPlot( const I_:Integer ) :TSingle2D;
183
begin
184
     Result := _Plots[ I_ ];
185
end;
186

187
procedure TScatterPlotFrame.SetPlot( const I_:Integer; const Plot_:TSingle2D );
188
begin
189
     _Plots[ I_ ] := Plot_;
190
end;
191

192
procedure TScatterPlotFrame.SetPlotsN( const PlotsN_:Integer );
193
begin
194
     _PlotsN := PlotsN_;
195

196
     SetLength( _Plots, _PlotsN );
197
end;
198

199
procedure TScatterPlotFrame.SetPlotSize( const PlotSize_:Single );
200
begin
201
     _PlotSize := PlotSize_;  Repaint;
202
end;
203

204
procedure TScatterPlotFrame.SetPlotColor( const PlotColor_:TAlphaColor );
205
begin
206
     _PlotColor := PlotColor_;  Repaint;
207
end;
208

209
//------------------------------------------------------------------------------
210

211
procedure TScatterPlotFrame.SetFocus( const Focus_:Integer );
212
begin
213
     _Focus := Focus_;  Repaint;
214
end;
215

216
procedure TScatterPlotFrame.SetHover( const Hover_:Integer );
217
begin
218
     _Hover := Hover_;  Repaint;
219
end;
220

221
//------------------------------------------------------------------------------
222

223
function TScatterPlotFrame.GetScaleX( const I_:Integer ) :TScaleLine;
224
begin
225
     Result := _ScaleX[ I_ ];
226
end;
227

228
procedure TScatterPlotFrame.SetScaleX( const I_:Integer; const ScaleX_:TScaleLine );
229
begin
230
     _ScaleX[ I_ ] := ScaleX_;  Repaint;
231
end;
232

233
function TScatterPlotFrame.GetScaleY( const I_:Integer ) :TScaleLine;
234
begin
235
     Result := _ScaleY[ I_ ];
236
end;
237

238
procedure TScatterPlotFrame.SetScaleY( const I_:Integer; const ScaleY_:TScaleLine );
239
begin
240
     _ScaleY[ I_ ] := ScaleY_;  Repaint;
241
end;
242

243
procedure TScatterPlotFrame.SetScaleN( const ScaleN_:Integer );
244
begin
245
     _ScaleN := ScaleN_;
246

247
     SetLength( _ScaleX, _ScaleN );
248
     SetLength( _ScaleY, _ScaleN );
249

250
     Repaint;
251
end;
252

253
//------------------------------------------------------------------------------
254

255
procedure TScatterPlotFrame.SetFontColor( const FontColor_:TAlphaColor );
256
begin
257
     _FontColor := FontColor_;  Repaint;
258
end;
259

260
/////////////////////////////////////////////////////////////////////// メソッド
261

262
procedure TScatterPlotFrame.MouseDown( Button_:TMouseButton; Shift_:TShiftState; X_,Y_:Single );
263
begin
264
     inherited;
265

266
     Focus := FindNearPlot( TPointF.Create( X_, Y_ ) );
267
end;
268

269
procedure TScatterPlotFrame.MouseMove( Shift_:TShiftState; X_,Y_:Single );
270
begin
271
     inherited;
272

273
     Hover := FindNearPlot( TPointF.Create( X_, Y_ ) );
274
end;
275

276
procedure TScatterPlotFrame.MouseUp( Button_:TMouseButton; Shift_:TShiftState; X_,Y_:Single );
277
begin
278
     inherited;
279

280
end;
281

282
//------------------------------------------------------------------------------
283

284
procedure TScatterPlotFrame.Paint;
285
var
286
   I :Integer;
287
begin
288
     inherited;
289

290
     with Canvas do
291
     begin
292
          Stroke.Kind := TBrushKind.Solid;
293
          Fill  .Kind := TBrushKind.Solid;
294

295
          //////////
296

297
          Clear( _BackColor );
298

299
          //////////
300

301
          Fill.Color := _AreaColor;
302

303
          FillRect( _Area, 0, 0, [], 1 );
304

305
          //////////
306

307
          for I := _ScaleN-1 downto 0 do
308
          begin
309
               with _ScaleX[ I ] do
310
               begin
311
                    Stroke.Thickness := Thick;
312
                    Stroke.Color     := Color;
313

314
                    DrawScaleX( Scale );
315
               end;
316

317
               with _ScaleY[ I ] do
318
               begin
319
                    Stroke.Thickness := Thick;
320
                    Stroke.Color     := Color;
321

322
                    DrawScaleY( Scale );
323
               end;
324
          end;
325

326
          //////////
327

328
          with Stroke do
329
          begin
330
               Thickness := 2.0;
331
               Color     := TAlphaColors.White;
332
          end;
333

334
          DrawAxis;
335

336
          //////////
337

338
          Font.Size := 15;
339

340
          Fill.Color := _FontColor;
341

342
          DrawValuesX( _ScaleX[0].Scale, 1 );
343
          DrawValuesY( _ScaleY[0].Scale, 1 );
344

345
          //////////
346

347
          with Stroke do
348
          begin
349
               Thickness := 2;
350
               Color     := TAlphaColors.Lime;
351
          end;
352

353
          DrawPlots;
354
     end;
355
end;
356

357
procedure TScatterPlotFrame.Resize;
358
begin
359
     inherited;
360

361
     _Area := TRectF.Create( _Margin, _Margin, Width-_Margin, Height-_Margin );
362
end;
363

364
//------------------------------------------------------------------------------
365

366
function TScatterPlotFrame.ScrToPos( const S_:TPointF ) :TSingle2D;
367
begin
368
     Result.X := ( _MaxX - _MinX ) * ( S_.X - _Area.Left ) / _Area.Width  + _MinX;
369
     Result.Y := ( _MinY - _MaxY ) * ( S_.Y - _Area.Top  ) / _Area.Height + _MaxY;
370
end;
371

372
function TScatterPlotFrame.PosToScr( const P_:TSingle2D ) :TPointF;
373
begin
374
     Result.X := ( P_.X - _MinX ) / ( _MaxX - _MinX ) * _Area.Width  + _Area.Left;
375
     Result.Y := ( P_.Y - _MaxY ) / ( _MinY - _MaxY ) * _Area.Height + _Area.Top ;
376
end;
377

378
//------------------------------------------------------------------------------
379

380
procedure TScatterPlotFrame.DrawPlots;
381
var
382
   I :Integer;
383
   P :TPointF;
384
begin
385
     with Canvas do
386
     begin
387
          for I := 0 to High( _Plots ) do
388
          begin
389
               P := PosToScr( _Plots[ I ] );
390

391
               if I = _Hover then
392
               begin
393
                    DrawCircle( P, 2 * _PlotSize );
394
               end;
395

396
               if I = _Focus then
397
               begin
398
                    Fill.Color := TAlphaColors.Red;
399

400
                    FillCircle( P, _PlotSize );
401
               end
402
               else
403
               begin
404
                    Fill.Color := _PlotColor;
405

406
                    FillCircle( P, _PlotSize );
407
               end;
408
          end;
409
     end;
410
end;
411

412
//------------------------------------------------------------------------------
413

414
procedure TScatterPlotFrame.DrawAxis;
415
begin
416
     with Canvas do
417
     begin
418
          DrawLine( PosToScr( TSingle2D.Create( 0, _MinY ) ),
419
                    PosToScr( TSingle2D.Create( 0, _MaxY ) ), 1 );
420

421
          DrawLine( PosToScr( TSingle2D.Create( _MinX, 0 ) ),
422
                    PosToScr( TSingle2D.Create( _MaxX, 0 ) ), 1 );
423
     end;
424
end;
425

426
//------------------------------------------------------------------------------
427

428
procedure TScatterPlotFrame.DrawScaleX( const Interval_ :Single );
429
var
430
   X0, X1, X :Integer;
431
   P0, P1 :TSingle2D;
432
begin
433
     X0 := Ceil( _MinX / Interval_ );  X1 := Floor( _MaxX / Interval_ );
434

435
     with Canvas do
436
     begin
437
          P0.Y := _MinY;  P1.Y := _MaxY;
438
          for X := X0 to X1 do
439
          begin
440
               P0.X := Interval_ * X;  P1.X := P0.X;
441

442
               DrawLine( PosToScr( P0 ), PosToScr( P1 ), 1 );
443
          end;
444
     end;
445
end;
446

447
procedure TScatterPlotFrame.DrawScaleY( const Interval_ :Single );
448
var
449
   Y0, Y1, Y :Integer;
450
   P0, P1 :TSingle2D;
451
begin
452
     Y0 := Ceil( _MinY / Interval_ );  Y1 := Floor( _MaxY / Interval_ );
453

454
     with Canvas do
455
     begin
456
          P0.X := _MinX;  P1.X := _MaxX;
457
          for Y := Y0 to Y1 do
458
          begin
459
               P0.Y := Interval_ * Y;  P1.Y := P0.Y;
460

461
               DrawLine( PosToScr( P0 ), PosToScr( P1 ), 1 );
462
          end;
463
     end;
464
end;
465

466
//------------------------------------------------------------------------------
467

468
procedure TScatterPlotFrame.DrawValuesX( const Interval_ :Single; const Digits_:Integer );
469
var
470
   X0, X1, X :Integer;
471
   P :TSingle2D;
472
   S :TPointF;
473
   T :String;
474
begin
475
     X0 := Ceil( _MinX / Interval_ );  X1 := Floor( _MaxX / Interval_ );
476

477
     with Canvas do
478
     begin
479
          P.Y := _MinY;
480
          for X := X0 to X1 do
481
          begin
482
               P.X := Interval_ * X;
483

484
               T := FloatToStrF( P.X, TFloatFormat.ffFixed, 7, Digits_ );
485

486
               S := PosToScr( P );
487

488
               with S do Y := Y - 0.37*Font.Size + Font.Size/2;
489

490
               DrawText( T, S, TTextAlign.Center, TTextAlign.Leading );
491
          end;
492
     end;
493
end;
494

495
procedure TScatterPlotFrame.DrawValuesY( const Interval_ :Single; const Digits_:Integer );
496
var
497
   Y0, Y1, Y :Integer;
498
   P :TSingle2D;
499
   S :TPointF;
500
   T :String;
501
begin
502
     Y0 := Ceil( _MinY / Interval_ );  Y1 := Floor( _MaxY / Interval_ );
503

504
     with Canvas do
505
     begin
506
          P.X := _MinX;
507
          for Y := Y0 to Y1 do
508
          begin
509
               P.Y := Interval_ * Y;
510

511
               T := FloatToStrF( P.Y, TFloatFormat.ffFixed, 7, Digits_ );
512

513
               S := PosToScr( P );
514

515
               with S do X := X - Font.Size/2;
516

517
               DrawText( T, S, TTextAlign.Trailing, TTextAlign.Center );
518
          end;
519
     end;
520
end;
521

522
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
523

524
constructor TScatterPlotFrame.Create( AOwner_:TComponent );
525
begin
526
     inherited;
527

528
     _Margin    := 50;
529

530
     _Area      := TRectF.Create( _Margin, _Margin, Width-_Margin, Height-_Margin );
531

532
     _MinX      := -10;
533
     _MaxX      := +10;
534
     _MinY      := -10;
535
     _MaxY      := +10;
536

537
     _BackColor := TAlphaColors.Dimgray;
538
     _AreaColor := TAlphaColors.Black;
539

540
     _Plots     := [];
541
     _PlotsN    := 0;
542
     _PlotSize  := 3;
543
     _PlotColor := TAlphaColors.Yellow;
544

545
     _Focus     := -1;
546
     _Hover     := -1;
547

548
      ScaleN    := 3;
549

550
      ScaleX[0] := TScaleLine.Create( 1.0, 1.00, $FFC0C0C0 );
551
      ScaleX[1] := TScaleLine.Create( 0.5, 0.75, $FF808080 );
552
      ScaleX[2] := TScaleLine.Create( 0.1, 0.50, $FF404040 );
553

554
      ScaleY[0] := TScaleLine.Create( 1.0, 1.00, $FFC0C0C0 );
555
      ScaleY[1] := TScaleLine.Create( 0.5, 0.75, $FF808080 );
556
      ScaleY[2] := TScaleLine.Create( 0.1, 0.50, $FF404040 );
557

558
     _FontColor := TAlphaColors.White;
559
end;
560

561
destructor TScatterPlotFrame.Destroy;
562
begin
563

564
     inherited;
565
end;
566

567
/////////////////////////////////////////////////////////////////////// メソッド
568

569
function TScatterPlotFrame.FindNearPlot( const Scr_:TPointF ) :Integer;
570
var
571
   MinD, D :Single;
572
   I :Integer;
573
begin
574
     Result := -1;  MinD := 4 * _PlotSize;
575

576
     for I := 0 to PlotsN-1 do
577
     begin
578
          D := Scr_.Distance( PosToScr( Plots[ I ] ) );
579

580
          if D < MinD then
581
          begin
582
               Result := I;  MinD := D;
583
          end;
584
     end;
585
end;
586

587
function TScatterPlotFrame.FindNearPlot( const Pos_:TSingle2D ) :Integer;
588
var
589
   MinD, D :Single;
590
   I :Integer;
591
begin
592
     Result := -1;  MinD := 0.1;
593

594
     for I := 0 to PlotsN-1 do
595
     begin
596
          D := Pos_.DistanTo( Plots[ I ] );
597

598
          if D < MinD then
599
          begin
600
               Result := I;  MinD := D;
601
          end;
602
     end;
603
end;
604

605
end. //######################################################################### ■
606
Luxophia

Использование cookies
