← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to lcl/chart.pp

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lcl/chart.pp
1
 
{  $Id: chart.pp 26150 2010-06-16 09:55:25Z mattias $  }
2
 
{
3
 
 /***************************************************************************
4
 
                               chart.pp
5
 
                               --------
6
 
                 Component Library Extended Controls
7
 
 
8
 
 ***************************************************************************/
9
 
 
10
 
 *****************************************************************************
11
 
 *                                                                           *
12
 
 *  This file is part of the Lazarus Component Library (LCL)                 *
13
 
 *                                                                           *
14
 
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,    *
15
 
 *  for details about the copyright.                                         *
16
 
 *                                                                           *
17
 
 *  This program is distributed in the hope that it will be useful,          *
18
 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of           *
19
 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                     *
20
 
 *                                                                           *
21
 
 *****************************************************************************
22
 
 
23
 
  This unit is deprecated, because there is something better:
24
 
  package TAChartLazarusPkg.
25
 
 
26
 
  Author: Michael Van Canneyt
27
 
}
28
 
unit Chart;
29
 
 
30
 
{$MODE ObjFPC}{$H+}
31
 
 
32
 
interface
33
 
 
34
 
uses
35
 
  Types, SysUtils, Classes, LCLProc, LCLIntf, LCLType, Controls, ExtCtrls, Graphics,
36
 
  Dialogs;
37
 
 
38
 
type
39
 
 
40
 
  TPosLabel=(plLeft, plCenter, plRight);
41
 
  TCustomBarChart = class;
42
 
  { TBar }
43
 
 
44
 
  TBar = class(TCollectionItem)
45
 
  private
46
 
    FColor: TColor;
47
 
    FSName: String;
48
 
    FValue: integer;
49
 
    procedure SetColor(const AValue: TColor);
50
 
    procedure SetSName(const AValue: String);
51
 
    procedure SetValue(const AValue: integer);
52
 
    procedure UpdateBarChart;
53
 
  protected
54
 
    function GetDisplayName: string; override;
55
 
  published
56
 
    property SName: String read FSName write SetSName;
57
 
    property Value: integer read FValue write SetValue;
58
 
    property Color: TColor read FColor write SetColor;
59
 
  end;
60
 
 
61
 
  { TBarChartItems }
62
 
 
63
 
  TBarChartItems = class(TCollection)
64
 
  private
65
 
    FBarChart: TCustomBarChart;
66
 
  protected
67
 
    function GetOwner: TPersistent; override;
68
 
  public
69
 
    constructor Create(BarChart: TCustomBarChart);
70
 
  end;
71
 
  
72
 
  { TCustomBarChart }
73
 
 
74
 
  TCustomBarChart = class(TPanel)
75
 
  private
76
 
    FUpdateCount: Integer;
77
 
    FBars: TCollection;
78
 
    FDepth: byte;
79
 
    FLabelPosition:TPosLabel;
80
 
    FIsPainting: Boolean;
81
 
    function GetBars: TCollection;
82
 
    function NormalizeScaleUnits(OldScale: Integer): Integer;
83
 
    procedure SetBars(const AValue: TCollection);
84
 
    procedure SetDepth(const AValue: byte);
85
 
    procedure SetLabelPosition(const AValue: TPosLabel);
86
 
  protected
87
 
    procedure Paint; override;
88
 
    class function GetControlClassDefaultSize: TSize; override;
89
 
    function RealGetText: TCaption; override;
90
 
  public
91
 
    constructor Create(AOwner: TComponent); override;
92
 
    destructor Destroy; override;
93
 
    procedure Clear;
94
 
    function AddBar(const SName: string; Value: integer; AColor: TColor): TBar;
95
 
    function GetBar(SId: integer): TBar;
96
 
    function BarCount: Integer;
97
 
    procedure BeginUpdate;
98
 
    procedure EndUpdate;
99
 
    procedure UpdateBarChart;
100
 
  published
101
 
    property Bars: TCollection read GetBars write SetBars;
102
 
    property Depth: byte read FDepth write SetDepth;
103
 
    property LabelPosition: TPosLabel read FLabelPosition write SetLabelPosition;
104
 
  end;
105
 
  
106
 
  
107
 
  { TBarChart
108
 
    Deprecated!
109
 
    Use package TAChartLazarusPkg instead. It has a compatible and better component.}
110
 
  
111
 
  TBarChart = class(TCustomBarChart)
112
 
  published
113
 
    property Align;
114
 
    property Alignment;
115
 
    property Anchors;
116
 
    property AutoSize;
117
 
    property BorderSpacing;
118
 
    property BevelInner;
119
 
    property BevelOuter;
120
 
    property BevelWidth;
121
 
    property BorderWidth;
122
 
    property BorderStyle;
123
 
    property Caption;
124
 
    property ClientHeight;
125
 
    property ClientWidth;
126
 
    property Color;
127
 
    property Constraints;
128
 
    property DragMode;
129
 
    property Enabled;
130
 
    property Font;
131
 
    property FullRepaint;
132
 
    property ParentColor;
133
 
    property ParentFont;
134
 
    property ParentShowHint;
135
 
    property PopupMenu;
136
 
    property ShowHint;
137
 
    property TabOrder;
138
 
    property TabStop;
139
 
    property Visible;
140
 
    property OnClick;
141
 
    property OnDblClick;
142
 
    property OnDragDrop;
143
 
    property OnDragOver;
144
 
    property OnEndDrag;
145
 
    property OnEnter;
146
 
    property OnExit;
147
 
    property OnMouseDown;
148
 
    property OnMouseMove;
149
 
    property OnMouseUp;
150
 
    property OnResize;
151
 
    property OnStartDrag;
152
 
  end deprecated; // use package TAChartLazarusPkg instead. It has a compatible and better component.
153
 
 
154
 
 
155
 
procedure Register;
156
 
 
157
 
implementation
158
 
 
159
 
procedure Register;
160
 
begin
161
 
  {$WARNINGS off}
162
 
  RegisterComponents('Misc',[TBarChart]);
163
 
  {$WARNINGS on}
164
 
end;
165
 
 
166
 
constructor TCustomBarChart.Create(AOwner: TComponent);
167
 
begin
168
 
  inherited Create(AOwner);
169
 
  FBars:=TBarChartItems.Create(Self);
170
 
  FDepth:=5;
171
 
  FLabelPosition:=plLeft;
172
 
  with GetControlClassDefaultSize do
173
 
    SetInitialBounds(0, 0, CX, CY);
174
 
end;
175
 
 
176
 
destructor TCustomBarChart.Destroy;
177
 
begin
178
 
  FBars.Destroy;
179
 
  inherited Destroy;
180
 
end;
181
 
 
182
 
function TCustomBarChart.AddBar(const SName: string; Value: Integer;
183
 
  AColor: TColor): TBar;
184
 
begin
185
 
  BeginUpdate;
186
 
  Try
187
 
    result:=TBar(FBars.Add);
188
 
    result.FsName:=SName;
189
 
    result.FValue:=Value;
190
 
    result.FColor:=AColor;
191
 
  finally
192
 
    EndUpdate;
193
 
  end;
194
 
end;
195
 
 
196
 
function TCustomBarChart.GetBar(SId: integer): TBar;
197
 
begin
198
 
  result:=TBar(FBars.FindItemID(SId));
199
 
end;
200
 
 
201
 
function TCustomBarChart.NormalizeScaleUnits(OldScale: Integer): Integer;
202
 
 
203
 
Var
204
 
  T: Integer;
205
 
 
206
 
begin
207
 
  Result:=OldScale;
208
 
  if Result<2 then
209
 
    Result:=2
210
 
  else if Result<=5 then
211
 
    Result:=5
212
 
  else if Result<=10 then
213
 
    Result:=10
214
 
  else
215
 
    begin
216
 
    T:=StrToInt(IntToStr(Result)[1])+1;
217
 
    repeat
218
 
      Result:=Result div 10;
219
 
      T:=T*10;
220
 
    until Result<10;
221
 
    Result:=T;
222
 
    end;
223
 
end;
224
 
 
225
 
function TCustomBarChart.GetBars: TCollection;
226
 
begin
227
 
  Result:=FBars;
228
 
end;
229
 
 
230
 
procedure TCustomBarChart.SetBars(const AValue: TCollection);
231
 
begin
232
 
  FBars.Assign(AValue);
233
 
end;
234
 
 
235
 
procedure TCustomBarChart.SetDepth(const AValue: byte);
236
 
begin
237
 
  if FDepth=AValue then exit;
238
 
  FDepth:=AValue;
239
 
  UpdateBarChart;
240
 
end;
241
 
 
242
 
procedure TCustomBarChart.SetLabelPosition(const AValue: TPosLabel);
243
 
begin
244
 
  if FLabelPosition=AValue then exit;
245
 
  FLabelPosition:=AValue;
246
 
  UpdateBarChart;
247
 
end;
248
 
 
249
 
procedure TCustomBarChart.Paint;
250
 
 
251
 
var
252
 
  i,k,j,h,w,h1,HMax,VMax: integer;
253
 
  bx,by:integer;
254
 
  NScaleLines : Integer;
255
 
  ScaleUnits  : Integer;
256
 
  PixelPerUnit: Double;
257
 
  BC          : Double;
258
 
  RBC         : Integer;
259
 
  BL   : Integer;
260
 
  m,z: integer;
261
 
  ts : TBar;
262
 
  s  : string;
263
 
  rc : TRect;
264
 
 
265
 
  procedure ScaleLine(dk: integer; const s: string);
266
 
 
267
 
  begin
268
 
    Canvas.MoveTo(hmax+dk+FDepth,h1);
269
 
    Canvas.LineTo(hmax+dk+FDepth,h1+h);
270
 
    Canvas.LineTo(hmax+dk,h1+FDepth+h);
271
 
    Canvas.LineTo(hmax+dk,h1+FDepth+h+2);
272
 
    Canvas.TextOut(HMax+dk-j,m,s);
273
 
  end;
274
 
 
275
 
begin
276
 
  FIsPainting := true;
277
 
  try
278
 
    inherited Paint;
279
 
  finally
280
 
    FIsPainting := false;
281
 
  end;
282
 
  bx:=GetSystemMetrics(SM_CXEDGE);
283
 
  by:=GetSystemMetrics(SM_CYEDGE);
284
 
  hmax:=10;
285
 
  vmax:=0;
286
 
  for i:=0 to FBars.Count-1 do
287
 
    begin
288
 
    ts:=TBar(FBars.Items[i]);
289
 
    k:=Canvas.TextWidth(ts.FsName);
290
 
    if k>hmax then
291
 
      Hmax:=k;
292
 
    if ts.FValue>vmax then
293
 
      vmax:=ts.FValue;
294
 
    end;
295
 
  HMax:=HMax+10;
296
 
  h1:=RoundToInt(1.5*Canvas.TextHeight('W'));
297
 
  h:=Height-2*h1-Fdepth;
298
 
  w:=Width-hmax-2*FDepth;
299
 
  Canvas.Pen.Color:=clBlack;
300
 
  Canvas.Pen.Width:=1;
301
 
  Canvas.Pen.Style:=psSolid;
302
 
  Canvas.Brush.Color:=clYellow;
303
 
  Canvas.Brush.Style:=bsSolid;
304
 
  Canvas.Polygon([Point(HMax,h1+FDepth),Point(HMax,h1+FDepth+h),Point(HMax+FDepth,h1+h),Point(HMax+FDepth,h1)]);
305
 
  Canvas.Brush.Color:=clWhite;
306
 
  Canvas.Polygon([Point(HMax,h1+FDepth+h),Point(HMax+w,h1+FDepth+h),Point(HMax+w+FDepth,h1+h),Point(HMax+FDepth,h1+h)]);
307
 
  Canvas.Brush.Color:=Color;
308
 
  Canvas.Rectangle(hmax+Fdepth,h1,hmax+w+FDepth,h1+h+1);
309
 
  Canvas.Pen.Width:=3;
310
 
  Canvas.MoveTo(hmax,h1+FDepth);
311
 
  Canvas.LineTo(hmax,h1+FDepth+h);
312
 
  Canvas.LineTo(hmax+w,h1+FDepth+h);
313
 
  Canvas.TextOut(bx,by,Caption);
314
 
  j:=Canvas.TextWidth(IntTostr(VMax));
315
 
  if VMax=0 then
316
 
     begin
317
 
     PixelPerUnit:=1;
318
 
     NscaleLines:=1;
319
 
     end
320
 
   else
321
 
     begin
322
 
     PixelPerUnit:=double(w-j-6) / VMax;
323
 
     NScaleLines:=(w-j-6) div (2*j);
324
 
     end;
325
 
  if NScaleLines=0 then
326
 
    ScaleUnits:=Vmax +1
327
 
  else
328
 
    ScaleUnits:=(Vmax div NScaleLines) +1;
329
 
  ScaleUnits:=NormalizeScaleUnits(ScaleUnits);
330
 
  if ScaleUnits=0 then
331
 
    NScaleLines:=1
332
 
  else
333
 
    NScaleLines:=VMax div ScaleUnits;
334
 
  Canvas.Pen.Color:=clGray;
335
 
  Canvas.Pen.Style:=psDot;
336
 
  Canvas.Pen.Width:=1;
337
 
  j:=j div 2;
338
 
  m:=h1+FDepth+h+2;
339
 
  if VMax=0 then
340
 
    begin
341
 
    k:=w div 2;
342
 
    ScaleLine(k,'0');
343
 
    end
344
 
  else
345
 
    Canvas.TextOut(HMax-j,m,'0');
346
 
  for k:=1 to NScaleLines do
347
 
    ScaleLine(RoundToInt(ScaleUnits*PixelPerUnit*k),IntToStr(k*ScaleUnits));
348
 
  If FBars.Count=0 then
349
 
    BC:=0
350
 
  else
351
 
    BC:=double(h) / (2*(FBars.Count+1));
352
 
  RBC:=RoundToInt(BC);
353
 
  z:=h1+FDepth+h;
354
 
  Canvas.Pen.Style:=psSolid;
355
 
  for i:=0 to FBars.Count-1 do
356
 
    begin
357
 
    ts:=TBar(FBars.Items[i]);
358
 
    z:=h1+FDepth+h-Round(2*(I+1)*BC);
359
 
    Canvas.Brush.Color:=ts.FColor;
360
 
    m:=ts.FValue;
361
 
    BL:=RoundToInt(m*PixelPerUnit);
362
 
    Canvas.Rectangle(hmax+1,z-1,hmax+BL+1,z+RBC-1);
363
 
    Canvas.Polygon([Point(hmax,z),Point(hmax+BL,z),Point(hmax+BL+FDepth,z-FDepth),Point(hmax+FDepth,z-FDepth)]);
364
 
    Canvas.Polygon([Point(hmax+BL,z),Point(hmax+BL,z+RBC-1),Point(hmax+BL+FDepth,z+RBC-1-FDepth),Point(hmax+BL+FDepth,z-FDepth)]);
365
 
    s:=IntToStr(m);
366
 
    w:=z+(RBC-FDepth) div 2;
367
 
    Canvas.MoveTo(Hmax+BL+Fdepth div 2,w);
368
 
    Canvas.LineTo(Hmax+BL+Fdepth+5-bx,w);
369
 
    Canvas.Brush.Color:=clYellow;
370
 
    with rc do
371
 
      begin
372
 
      left:=hmax+BL+FDepth+5-bx;
373
 
      right:=left+Canvas.TextWidth(s)+2*bx;
374
 
      top:=w-Canvas.TextHeight(s) div 2-by;
375
 
      bottom:=w+Canvas.TextHeight(s) div 2+by;
376
 
      end;
377
 
    Canvas.Rectangle(rc);
378
 
    //debugln('TCustomBarChart.Paint A ',dbgs(rc),' s="',s,'"');
379
 
    Canvas.TextOut(rc.Left+bx,rc.Top+by,s);
380
 
    Canvas.Font.Color:=Font.Color;
381
 
    case FLabelPosition of
382
 
      plLeft: Canvas.TextOut(bx,z,ts.FSName);
383
 
      plCenter: Canvas.TextOut(HMax+((BL-Canvas.TextWidth(ts.FSName)) div 2),z,ts.FSName);
384
 
      plRight: Canvas.TextOut(HMax+BL-Canvas.TextWidth(ts.FSName)-bx,z,ts.FSName);
385
 
    end;
386
 
    end;
387
 
  Canvas.Pen.Style:=psSolid;
388
 
end;
389
 
 
390
 
function TCustomBarChart.RealGetText: TCaption;
391
 
begin
392
 
  if FIsPainting then
393
 
    Result := ''
394
 
  else
395
 
    Result := inherited RealGetText;
396
 
end;
397
 
 
398
 
class function TCustomBarChart.GetControlClassDefaultSize: TSize;
399
 
begin
400
 
  Result.CX := 150;
401
 
  Result.CY := 120;
402
 
end;
403
 
 
404
 
procedure TCustomBarChart.Clear;
405
 
begin
406
 
  FBars.Clear;
407
 
end;
408
 
 
409
 
procedure TCustomBarChart.BeginUpdate;
410
 
begin
411
 
  Inc(FUpdateCount);
412
 
end;
413
 
 
414
 
procedure TCustomBarChart.EndUpdate;
415
 
begin
416
 
  if FUpdateCount=0 then
417
 
    raise Exception.Create('TCustomBarChart.EndUpdate');
418
 
  Dec(FUpdateCount);
419
 
  If FUpdateCount=0 then
420
 
    Invalidate;
421
 
end;
422
 
 
423
 
procedure TCustomBarChart.UpdateBarChart;
424
 
begin
425
 
  if FUpdateCount = 0 then
426
 
    Invalidate;
427
 
end;
428
 
 
429
 
function TCustomBarChart.BarCount: Integer;
430
 
begin
431
 
  Result:=FBars.Count;
432
 
end;
433
 
 
434
 
{ TBar }
435
 
 
436
 
procedure TBar.SetColor(const AValue: TColor);
437
 
begin
438
 
  if FColor=AValue then exit;
439
 
  FColor:=AValue;
440
 
  UpdateBarChart;
441
 
end;
442
 
 
443
 
procedure TBar.SetSName(const AValue: String);
444
 
begin
445
 
  if FSName=AValue then exit;
446
 
  FSName:=AValue;
447
 
  UpdateBarChart;
448
 
end;
449
 
 
450
 
procedure TBar.SetValue(const AValue: integer);
451
 
begin
452
 
  if FValue=AValue then exit;
453
 
  FValue:=AValue;
454
 
  UpdateBarChart;
455
 
end;
456
 
 
457
 
procedure TBar.UpdateBarChart;
458
 
begin
459
 
  (Collection as TBarChartItems).FBarChart.UpdateBarChart;
460
 
end;
461
 
 
462
 
function TBar.GetDisplayName: string;
463
 
begin
464
 
  Result:=FSName;
465
 
end;
466
 
 
467
 
{ TBarChartItems }
468
 
 
469
 
function TBarChartItems.GetOwner: TPersistent;
470
 
begin
471
 
  Result := FBarChart;
472
 
end;
473
 
 
474
 
constructor TBarChartItems.Create(BarChart: TCustomBarChart);
475
 
begin
476
 
  inherited Create(TBar);
477
 
  FBarChart:=BarChart;
478
 
end;
479
 
 
480
 
end.