pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

jvcllaz: Add Jan's simulation components (JvJansSim), incl JvSimScope demo.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6242 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-03-13 15:25:01 +00:00
parent 67811dddf6
commit 888b7fd2cd
28 changed files with 4674 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
components/jvcllaz/run/JvCtrls/JvMovableBevel.pas
View File

@ -26,7 +26,6 @@ Known Issues:
unit JvMovableBevel;
{$mode objfpc}{$H+}
//{$I jvcl.inc}
interface
@ -41,9 +40,6 @@ type
tdRightToLeft, tdTopLeftToBottomRight, tdTopRightToBottomLeft,
tdBottomLeftToTopRight, tdBottomRightToTopLeft);
// {$IFDEF RTL230_UP}
// [ComponentPlatformsAttribute(pidWin32 or pidWin64)]
// {$ENDIF RTL230_UP}
TJvMovableBevel = class(TBevel) //TJvExBevel)
private
FStartX: Integer;
@ -69,8 +65,6 @@ type
X, Y: Integer); override;
procedure MouseEnter; override;
procedure MouseLeave; override;
// procedure MouseEnter(Control: TControl); override;
// procedure MouseLeave(Control: TControl); override;
public
constructor Create(AOwner: TComponent); override;
published

203
components/jvcllaz/run/JvJans/JvSimIndicator.pas Normal file
View File

@ -0,0 +1,203 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvSimIndicator.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvSimIndicator;
{$mode objfpc}{$H+}
interface
uses
LCLIntf,
SysUtils, Classes, Graphics, Controls, ExtCtrls,
JvComponent, JvJVCLUtils;
type
TJvSimIndicator = class(TJvGraphicControl)
private
FValue: Integer;
FMaximum: Integer;
FMinimum: Integer;
FBarColor: TColor;
FBackColor: TColor;
FMargins: TJvRect;
procedure SetBarColor(const Value: TColor);
procedure SetMaximum(const Value: Integer);
procedure SetMinimum(const Value: Integer);
procedure SetValue(const Value: Integer);
procedure SetBackColor(const Value: TColor);
procedure SetMargins(const Value: TJvRect);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
published
property Value: Integer read FValue write SetValue;
property Minimum: Integer read FMinimum write SetMinimum default 0;
property Maximum: Integer read FMaximum write SetMaximum default 100;
property BarColor: TColor read FBarColor write SetBarColor default clLime;
property BackColor: TColor read FBackColor write SetBackColor default clSilver;
property Width default 25;
property Height default 100;
property Margins: TJvRect read FMargins write SetMargins;
property Align;
property Anchors;
property ParentShowHint;
property ShowHint;
property Visible;
// property OnCanResize; --- wp removed
property OnClick;
property OnConstrainedResize;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
end;
implementation
constructor TJvSimIndicator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 25;
Height := 100;
FMinimum := 0;
FMaximum := 100;
FValue := 50;
FBarColor := clLime;
FBackColor := clSilver;
FMargins := TJvRect.Create;
end;
destructor TJvSimIndicator.Destroy;
begin
FMargins.Free;
inherited Destroy;
end;
procedure TJvSimIndicator.Paint;
const
NumberOfBars = 20;
var
R, Ri: TRect;
I, n: Integer;
h, dh: Integer;
begin
R := ClientRect;
Canvas.Brush.Color := clSilver;
Canvas.FillRect(R);
Frame3D(Canvas, R, clBtnHighlight, clBtnShadow, 1);
Dec(R.Top, Margins.Top);
Dec(R.Left, Margins.Left);
Dec(R.Bottom, Margins.Bottom);
Dec(R.Right, Margins.Right);
Frame3D(Canvas, R, clBtnShadow, clBtnHighlight, 1);
Canvas.Brush.Color := FBackColor;
InflateRect(R, -1, -1);
Canvas.FillRect(R);
Dec(R.Right);
h := R.Bottom - R.Top;
dh := h div NumberOfBars;
n := Round(NumberOfBars * (FValue - FMinimum)/(FMaximum - FMinimum));
Canvas.Brush.Color := FBarColor;
Ri := Classes.Rect(R.Left + 1, R.Bottom - dh + 1, R.Right - 1, R.Bottom);
for I := 1 to n do
begin
Canvas.FillRect(Ri);
Dec(Ri.Top, dh);
Dec(Ri.Bottom, dh);
end;
end;
procedure TJvSimIndicator.SetBackColor(const Value: TColor);
begin
if FBackColor <> Value then
begin
FBackColor := Value;
Invalidate;
end;
end;
procedure TJvSimIndicator.SetBarColor(const Value: TColor);
begin
if FBarColor <> Value then
begin
FBarColor := Value;
Invalidate;
end;
end;
procedure TJvSimIndicator.SetMaximum(const Value: Integer);
begin
if FMaximum <> Value then
begin
FMaximum := Value;
Invalidate;
end;
end;
procedure TJvSimIndicator.SetMinimum(const Value: Integer);
begin
if FMinimum <> Value then
begin
FMinimum := Value;
Invalidate;
end;
end;
procedure TJvSimIndicator.SetValue(const Value: Integer);
begin
if FValue <> Value then
begin
FValue := Value;
Invalidate;
end;
end;
procedure TJvSimIndicator.SetMargins(const Value: TJvRect);
begin
FMargins.Assign(Value);
Invalidate;
end;
end.

2801
components/jvcllaz/run/JvJans/JvSimLogic.pas Normal file
View File

File diff suppressed because it is too large Load Diff

352
components/jvcllaz/run/JvJans/JvSimPID.pas Normal file
View File

@ -0,0 +1,352 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvSimPID.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvSimPID;
{$mode objfpc}{$H+}
interface
uses
LCLIntf,
SysUtils, Classes, Graphics, Controls,
JvComponent;
type
TJvSymFunc = (sfPid, sfAdd, sfCompare, sfRamp, sfMul);
TJvSimPID = class(TJvGraphicControl)
private
FMV: Extended;
FMVColor: TColor;
FSP: Extended;
FSPColor: TColor;
FCV: Extended;
FCVColor: TColor;
FKD: Extended;
FKP: Extended;
FKI: Extended;
FI: Extended;
FD: Extended;
FDirect: Boolean;
FManual: Boolean;
FSource: TJvSimPID;
FActive: Boolean;
FSymFunc: TJvSymFunc;
procedure SetMV(Value: Extended);
procedure SetMVColor(Value: TColor);
procedure SetSP(const Value: Extended);
procedure SetSPColor(const Value: TColor);
procedure SetCV(const Value: Extended);
procedure SetCVColor(const Value: TColor);
procedure SetKD(const Value: Extended);
procedure SetKI(const Value: Extended);
procedure SetKP(const Value: Extended);
procedure CalcOut;
procedure SetDirect(const Value: Boolean);
procedure SetManual(const Value: Boolean);
procedure SetSource(const Value: TJvSimPID);
procedure SetActive(const Value: Boolean);
procedure SetSymFunc(const Value: TJvSymFunc);
protected
procedure Paint; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
procedure Execute;
published
property SymFunc: TJvSymFunc read FSymFunc write SetSymFunc;
property Source: TJvSimPID read FSource write SetSource;
property MV: Extended read FMV write SetMV;
property MVColor: TColor read FMVColor write SetMVColor default clRed;
property SP: Extended read FSP write SetSP;
property SPColor: TColor read FSPColor write SetSPColor default clLime;
property CV: Extended read FCV write SetCV;
property CVColor: TColor read FCVColor write SetCVColor default clYellow;
property KP: Extended read FKP write SetKP;
property KI: Extended read FKI write SetKI;
property KD: Extended read FKD write SetKD;
property Direct: Boolean read FDirect write SetDirect default False;
property Manual: Boolean read FManual write SetManual default False;
property Active: Boolean read FActive write SetActive default False;
property Align;
property Anchors;
property Color default clWhite;
property Height default 100;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Width default 20;
property Visible;
// property OnCanResize; // wp: removed
property OnClick;
property OnConstrainedResize;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
end;
implementation
uses
JvJVCLUtils;
constructor TJvSimPID.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clWhite;
MVColor := clRed;
SPColor := clLime;
CVColor := clYellow;
Direct := False;
Manual := False;
Active := False;
FMV := 50;
FSP := 50;
FCV := 50;
FKP := 0.5;
FKI := 0;
FKD := 0;
Width := 20;
Height := 100;
end;
procedure TJvSimPID.SetMV(Value: Extended);
var
MVOld: Extended;
begin
MVOld := FMV;
if Value <> FMV then
begin
if Value > 100 then
MV := 100
else
if Value < 0 then
MV := 0
else
FMV := Value;
end;
FI := FI + KI * (FMV - FSP);
if FI > 50 then
FI := 50;
if FI < -50 then
FI := -50;
FD := KD * (FMV - MVOld);
if FD > 50 then
FD := 50;
if FD < -50 then
FD := -50;
CalcOut;
end;
procedure TJvSimPID.SetMVColor(Value: TColor);
begin
if Value <> FMVColor then
begin
FMVColor := Value;
Invalidate;
end;
end;
procedure TJvSimPID.Paint;
procedure DrawValue(Left, Right: Integer; Value: Extended; AColor: TColor);
var
DrawRect: TRect;
begin
DrawRect.Left := Left;
DrawRect.Right := Right;
DrawRect.Top := DrawRect.Top + Round((100 - Value) *
(DrawRect.Bottom - DrawRect.Top) / 100);
DrawRect.Bottom := DrawRect.Bottom;
Canvas.Brush.Color := AColor;
Canvas.FillRect(DrawRect);
Canvas.Brush.Color := Color;
DrawRect.Bottom := DrawRect.Top;
DrawRect.Top := DrawRect.Top;
Canvas.FillRect(DrawRect);
end;
var
bw: Integer;
DrawRect: TRect;
begin
DrawRect := ClientRect;
Canvas.Pen.Color := clGray;
Canvas.Pen.Width := 1;
Canvas.Rectangle(DrawRect.Left, DrawRect.Top, DrawRect.Right, DrawRect.Bottom);
InflateRect(DrawRect, -1, -1);
bw := (DrawRect.Right - DrawRect.Left) div 3;
// first draw the Measured Value
DrawValue(DrawRect.Left + bw, DrawRect.Right - bw, SP, SPColor);
// and now the SetPoint
DrawValue(DrawRect.Left, DrawRect.Left + bw, MV, MVColor);
// draw the Corrective Value (CV)
DrawValue(DrawRect.Right - bw, DrawRect.Right, CV, CVColor);
end;
procedure TJvSimPID.SetSP(const Value: Extended);
begin
if Value <> FSP then
begin
if Value > 100 then
FSP := 100
else
if Value < 0 then
FSP := 0
else
FSP := Value;
CalcOut;
end;
end;
procedure TJvSimPID.SetSPColor(const Value: TColor);
begin
if Value <> FSPColor then
begin
FSPColor := Value;
Invalidate;
end;
end;
procedure TJvSimPID.SetCV(const Value: Extended);
begin
if Value <> FCV then
begin
if Value > 100 then
FCV := 100
else
if Value < 0 then
FCV := 0
else
FCV := Value;
end;
Invalidate;
end;
procedure TJvSimPID.SetCVColor(const Value: TColor);
begin
if Value <> FCVColor then
begin
FCVColor := Value;
Invalidate;
end;
end;
procedure TJvSimPID.SetKD(const Value: Extended);
begin
FKD := Value;
end;
procedure TJvSimPID.SetKI(const Value: Extended);
begin
FKI := Value;
if FKI = 0 then
FI := 0;
end;
procedure TJvSimPID.SetKP(const Value: Extended);
begin
FKP := Value;
end;
procedure TJvSimPID.CalcOut;
var
Output: Extended;
begin
if not Manual then
begin
if Direct then
Output := 50 + KP * (MV - SP) + FI + FD
else
Output := 50 - (KP * (MV - SP) + FI + FD);
SetCV(Output);
end;
end;
procedure TJvSimPID.SetDirect(const Value: Boolean);
begin
FDirect := Value;
end;
procedure TJvSimPID.SetManual(const Value: Boolean);
begin
FManual := Value;
end;
procedure TJvSimPID.SetSource(const Value: TJvSimPID);
begin
ReplaceComponentReference(Self, Value, TComponent(FSource));
end;
procedure TJvSimPID.Execute;
var
Value: Extended;
begin
if Active then
if Assigned(FSource) then
begin
Value := Source.CV;
SetMV(Value);
end;
end;
procedure TJvSimPID.SetActive(const Value: Boolean);
begin
FActive := Value;
end;
procedure TJvSimPID.SetSymFunc(const Value: TJvSymFunc);
begin
FSymFunc := Value;
end;
procedure TJvSimPID.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (AComponent = Source) and (Operation = opRemove) then
Source := nil;
end;
end.

123
components/jvcllaz/run/JvJans/JvSimPIDLinker.pas Normal file
View File

@ -0,0 +1,123 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvSimPIDlinker.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvSimPIDLinker;
{$mode objfpc}{$H+}
interface
uses
Classes,
JvSimPID;
type
TPIDS = array of TJvSimPID;
TJvSimPIDLinker = class(TComponent)
private
FPIDS: TPIDS;
function GetPID(const Index: Integer): TJvSimPID;
procedure SetPID(const Index: Integer; const Value: TJvSimPID);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
procedure InitPids;
public
procedure Execute;
constructor Create(AOwner: TComponent); override;
published
property In1: TJvSimPID index 0 read GetPID write SetPID;
property Out1: TJvSimPID index 1 read GetPID write SetPID;
property In2: TJvSimPID index 2 read GetPID write SetPID;
property Out2: TJvSimPID index 3 read GetPID write SetPID;
property In3: TJvSimPID index 4 read GetPID write SetPID;
property Out3: TJvSimPID index 5 read GetPID write SetPID;
property In4: TJvSimPID index 6 read GetPID write SetPID;
property Out4: TJvSimPID index 7 read GetPID write SetPID;
property In5: TJvSimPID index 8 read GetPID write SetPID;
property Out5: TJvSimPID index 9 read GetPID write SetPID;
property In6: TJvSimPID index 10 read GetPID write SetPID;
property Out6: TJvSimPID index 11 read GetPID write SetPID;
property In7: TJvSimPID index 12 read GetPID write SetPID;
property Out7: TJvSimPID index 13 read GetPID write SetPID;
property In8: TJvSimPID index 14 read GetPID write SetPID;
property Out8: TJvSimPID index 15 read GetPID write SetPID;
end;
implementation
constructor TJvSimPIDLinker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitPids;
end;
procedure TJvSimPIDLinker.Execute;
var
I: Integer;
begin
for I := 0 to Length(FPIDS) - 2 do
if (FPIDS[I] <> nil) and (FPIDS[I + 1] <> nil) then
FPIDS[I].MV := FPIDS[I + 1].CV;
end;
function TJvSimPIDLinker.GetPID(const Index: Integer): TJvSimPID;
begin
Result := FPIDS[Index];
end;
procedure TJvSimPIDLinker.InitPids;
const
cCount = 16;
var
I: Integer;
begin
SetLength(FPIDS, cCount);
for I := 0 to cCount - 1 do
FPIDS[I] := nil;
end;
procedure TJvSimPIDLinker.Notification(AComponent: TComponent;
Operation: TOperation);
var
I: Integer;
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
for I := 0 to Length(FPIDS) - 1 do
if FPIDS[I] = AComponent then
FPIDS[I] := nil;
end;
procedure TJvSimPIDLinker.SetPID(const Index: Integer;
const Value: TJvSimPID);
begin
FPIDS[Index] := Value;
end;
end.

860
components/jvcllaz/run/JvJans/JvSimScope.pas Normal file
View File

@ -0,0 +1,860 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvSimScope.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Description:
TJvSimScope Properties:
Active Starts/Stops scope
Color Backgroundcolor
GridColor Grid mask color
HorizontalGridSize Size of horiontal grid mask in logical units
VerticalGridSize Size of vertical grid mask in logical units
Interval Scroll speed in 1/100's seconds
LineColor Scope dataline color
Position Dataline value
BaseColor Color of BaseLine
BaseLine BaseLine value
TJvSimScope Methods:
Clear Clears the control and redraws grid
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvSimScope;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls;
const
JvScopeDefaultCapacity = 128;
JvMinimumScopeWidth = 20;
JvMinimumScopeHeight = 20;
type
TJvSimScope = class;
TJvScopeLineUnit = (jluPercent, jluAbsolute);
TValues = array of Integer;
TJvScopeLineValues = class
private
FValues: TValues;
FCount: Integer;
FZeroIndex: Integer;
procedure SetCapacity(const Value: Integer);
function GetCapacity: Integer;
function GetItem(Index: Integer): Integer;
public
procedure Assign(Source: TJvScopeLineValues);
procedure Add(Value: Integer);
procedure Clear;
property Capacity: Integer read GetCapacity write SetCapacity;
property Count: Integer read FCount;
property Items[Index: Integer]: Integer read GetItem; default;
end;
TJvScopeLine = class(TCollectionItem)
private
FPosition: Integer;
FColor: TColor;
FName: string;
FPositionUnit: TJvScopeLineUnit;
FValues: TJvScopeLineValues;
protected
function GetDisplayName: string; override;
public
constructor Create(ACollection: Classes.TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Clear;
property Values: TJvScopeLineValues read FValues;
published
property Name: string read FName write FName;
property Color: TColor read FColor write FColor default clLime;
property Position: Integer read FPosition write FPosition default 50;
property PositionUnit: TJvScopeLineUnit read FPositionUnit write FPositionUnit default jluPercent;
end;
TJvScopeLines = class(TOwnedCollection)
private
function GetItem(Index: Integer): TJvScopeLine;
procedure SetItem(Index: Integer; const Value: TJvScopeLine);
protected
function GetOwner: TJvSimScope; reintroduce;
procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); override;
public
constructor Create(AOwner: TJvSimScope);
procedure Assign(Source: TPersistent); override;
procedure ClearValues;
function Add: TJvScopeLine;
function IndexOfName(const AName: string): Integer;
property Lines[Index: Integer]: TJvScopeLine read GetItem write SetItem; default;
end;
TJvSimScopeDisplayUnit = (jduPixels, jduLogical);
TJvSimScope = class(TGraphicControl)
private
FAllowed: Boolean;
FOnUpdate: TNotifyEvent;
FDrawBuffer: TBitmap;
FDrawTimer: TTimer;
FActive: Boolean;
FBaseColor: TColor;
FGridColor: TColor;
FBaseLine: Integer;
FInterval: Integer;
FLines: TJvScopeLines;
FHorizontalGridSize: Integer;
FVerticalGridSize: Integer;
FDisplayUnits: TJvSimScopeDisplayUnit;
FMaximum: Integer;
FMinimum: Integer;
FBaseLineUnit: TJvScopeLineUnit;
FTotalTimeSteps: Integer;
FUpdateTimeSteps: Integer;
procedure SetActive(Value: Boolean);
procedure SetGridSize(Value: Integer);
procedure SetBaseLine(Value: Integer);
procedure SetInterval(Value: Integer);
procedure SetLines(const Value: TJvScopeLines);
procedure UpdateDisplay(ClearFirst: Boolean);
procedure SetHorizontalGridSize(const Value: Integer);
procedure SetVerticalGridSize(const Value: Integer);
function GetGridSize: Integer;
procedure SetDisplayUnits(const Value: TJvSimScopeDisplayUnit);
procedure SetMaximum(const Value: Integer);
procedure SetMinimum(const Value: Integer);
procedure UpdateComputedValues;
procedure SetBaseLineUnit(const Value: TJvScopeLineUnit);
procedure SetTotalTimeSteps(const Value: Integer);
procedure SetUpdateTimeSteps(const Value: Integer);
protected
FCalcBase: Integer;
FStepPixelWidth: Double;
FCounter: Double;
procedure DrawTimerTimer(Sender: TObject);
function GetLinePixelPosition(Line: TJvScopeLine; Position: Integer): Integer;
procedure Loaded; override;
public
procedure Paint; override;
constructor Create(AOwner: TComponent); override;
procedure UpdateScope;
destructor Destroy; override;
procedure Clear;
procedure ClearValues;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property Active: Boolean read FActive write SetActive;
property BaseColor: TColor read FBaseColor write FBaseColor default clRed;
property BaseLine: Integer read FBaseLine write SetBaseLine default 50;
property BaseLineUnit: TJvScopeLineUnit read FBaseLineUnit write SetBaseLineUnit default jluPercent;
property Color default clBlack;
property DisplayUnits: TJvSimScopeDisplayUnit read FDisplayUnits write SetDisplayUnits default jduPixels;
property GridColor: TColor read FGridColor write FGridColor default clGreen;
property GridSize: Integer read GetGridSize write SetGridSize stored False default 16;
property HorizontalGridSize: Integer read FHorizontalGridSize write SetHorizontalGridSize default 16;
property Height default 120;
property Interval: Integer read FInterval write SetInterval default 50;
property Lines: TJvScopeLines read FLines write SetLines;
property Minimum: Integer read FMinimum write SetMinimum;
property Maximum: Integer read FMaximum write SetMaximum default 120;
property TotalTimeSteps: Integer read FTotalTimeSteps write SetTotalTimeSteps default 208;
property UpdateTimeSteps: Integer read FUpdateTimeSteps write SetUpdateTimeSteps default 2;
property VerticalGridSize: Integer read FVerticalGridSize write SetVerticalGridSize default 16;
property Width default 208;
property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
property Align;
property Anchors;
property ParentShowHint;
property ShowHint;
property Visible;
// property OnCanResize; -- wp: removed
property OnClick;
property OnConstrainedResize;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDock;
property OnStartDrag;
end;
implementation
uses
Math;
//=== { TJvScopeLineValues } =================================================
procedure TJvScopeLineValues.Add(Value: Integer);
begin
Assert(Assigned(Self));
if Length(FValues)=Count then // auto-growby JvScopeDefaultCapacity
SetCapacity( GetCapacity+JvScopeDefaultCapacity);
if Count < Capacity then
begin
FValues[FCount] := Value;
Inc(FCount);
end
else
begin
FValues[FZeroIndex] := Value;
FZeroIndex := (FZeroIndex + 1) mod FCount;
end;
end;
procedure TJvScopeLineValues.Assign(Source: TJvScopeLineValues);
var
I: Integer;
begin
if (not Assigned(Source)) then
raise Exception.Create('TJvScopeLineValues.Assign:Source not assigned');
FCount := Source.FCount;
FZeroIndex := Source.FZeroIndex;
Capacity := Source.Capacity;
for I := 0 to Source.Capacity - 1 do
FValues[I] := Source.FValues[I];
end;
procedure TJvScopeLineValues.Clear;
begin
FCount := 0;
FZeroIndex := 0;
// Always need to have two values in the queue
Add(0);
Add(0);
end;
function TJvScopeLineValues.GetCapacity: Integer;
begin
if Assigned(FValues) then
Result := Length(FValues)
else
Result := 0;
end;
function TJvScopeLineValues.GetItem(Index: Integer): Integer;
begin
if FCount = 0 then
Result := FValues[0]
else
Result := FValues[(Index + FZeroIndex) mod FCount];
end;
procedure TJvScopeLineValues.SetCapacity(const Value: Integer);
begin
if Value <> Capacity then
begin
SetLength(FValues, Value);
end;
end;
//=== { TJvScopeLine } =======================================================
procedure TJvScopeLine.Clear;
begin
FValues.Clear;
end;
constructor TJvScopeLine.Create(ACollection: Classes.TCollection);
begin
// MUST be created before, inherited create will call Notify...
FValues := TJvScopeLineValues.Create;
inherited Create(ACollection);
FPosition := 50;
FColor := clLime;
end;
destructor TJvScopeLine.Destroy;
begin
FValues.Free;
inherited Destroy;
end;
procedure TJvScopeLine.Assign(Source: TPersistent);
begin
if Source is TJvScopeLine then
begin
Name := TJvScopeLine(Source).Name;
Color := TJvScopeLine(Source).Color;
Position := TJvScopeLine(Source).Position;
FValues.Assign(TJvScopeLine(Source).FValues);
end
else
inherited Assign(Source);
end;
function TJvScopeLine.GetDisplayName: string;
begin
if Name = '' then
Result := inherited GetDisplayName
else
Result := Name;
end;
//=== { TJvScopeLines } ======================================================
procedure TJvScopeLines.ClearValues;
var
I: Integer;
begin
for I := 0 to Count - 1 do
begin
Lines[I].Clear;
end;
end;
constructor TJvScopeLines.Create(AOwner: TJvSimScope);
begin
inherited Create(AOwner, TJvScopeLine);
end;
function TJvScopeLines.Add: TJvScopeLine;
begin
Result := TJvScopeLine(inherited Add);
end;
procedure TJvScopeLines.Assign(Source: TPersistent);
var
I: Integer;
begin
if Source is TJvScopeLines then
begin
Clear;
for I := 0 to TJvScopeLines(Source).Count - 1 do
Add.Assign(TJvScopeLines(Source)[I]);
end
else
inherited Assign(Source);
end;
function TJvScopeLines.GetItem(Index: Integer): TJvScopeLine;
begin
Result := TJvScopeLine(inherited Items[Index]);
end;
function TJvScopeLines.GetOwner: TJvSimScope;
begin
Result := inherited GetOwner as TJvSimScope;
end;
function TJvScopeLines.IndexOfName(const AName: string): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to Count - 1 do
if AnsiSameStr(Lines[Result].Name, AName) then
begin
Result := I;
Break;
end;
end;
procedure TJvScopeLines.Notify(Item: TCollectionItem;
Action: TCollectionNotification);
begin
inherited Notify(Item, Action);
if Action = cnAdded then
begin
TJvScopeLine(Item).FValues.Capacity := GetOwner.TotalTimeSteps;
end;
end;
procedure TJvScopeLines.SetItem(Index: Integer; const Value: TJvScopeLine);
begin
inherited Items[Index] := Value;
end;
//=== { TJvSimScope } ========================================================
procedure TJvSimScope.ClearValues;
begin
FLines.ClearValues;
end;
constructor TJvSimScope.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAllowed := False;
FDrawBuffer := TBitmap.Create;
FDrawBuffer.Canvas.Brush.Style := bsSolid;
FDrawBuffer.Canvas.Pen.Width := 1;
FDrawBuffer.Canvas.Pen.Style := psSolid;
FDrawTimer := TTimer.Create(Self);
FDrawTimer.Enabled := False;
FDrawTimer.OnTimer := @DrawTimerTimer;
FDrawTimer.Interval := 500;
FDisplayUnits := jduPixels;
FUpdateTimeSteps := 2;
Height := 120; { property default }
Width := 208; { property default }
Color := clBlack;
FGridColor := clGreen;
FBaseColor := clRed;
BaseLine := 50;
GridSize := 16;
FLines := TJvScopeLines.Create(Self);
Interval := 50;
FCounter := 1;
ControlStyle := [csFramed, csOpaque];
FAllowed := True;
end;
destructor TJvSimScope.Destroy;
begin
FDrawTimer.Free;
FDrawBuffer.Free;
FLines.Free;
inherited Destroy;
end;
procedure TJvSimScope.DrawTimerTimer(Sender: TObject);
begin
UpdateScope;
end;
function TJvSimScope.GetGridSize: Integer;
begin
Result := -1;
if HorizontalGridSize = VerticalGridSize then
Result := HorizontalGridSize;
end;
function TJvSimScope.GetLinePixelPosition(Line: TJvScopeLine;
Position: Integer): Integer;
begin
Result := 0;
case Line.PositionUnit of
jluPercent:
Result := Height - Round(Height * Position / 100);
jluAbsolute:
Result := Height - Round(Height * (Position - Minimum) / (Maximum - Minimum));
end;
end;
procedure TJvSimScope.Loaded;
begin
inherited Loaded;
// To force having enough values in the scope.
ClearValues;
FAllowed := True;
end;
procedure TJvSimScope.Clear;
var
A: Double;
I: Integer;
J: Integer;
Position: Double;
begin
if not FAllowed then
Exit;
UpdateComputedValues;
with FDrawBuffer.Canvas do
begin
Brush.Color := Color;
Pen.Style := psClear;
Rectangle(0, 0, Width + 1, Height + 1);
Pen.Style := psSolid;
Pen.Color := GridColor;
Pen.Width := 1;
{ Vertical lines }
A := Width;
while A > 0 do
begin
MoveTo(Round(A - 1), 0);
LineTo(Round(A - 1), Height);
A := A - VerticalGridSize * FStepPixelWidth;
end;
{ Horizontal lines - below BaseLine }
A := FCalcBase;
while A < Height do
begin
A := A + HorizontalGridSize * Height / (Maximum - Minimum);
MoveTo(0, Round(A));
LineTo(Width, Round(A));
end;
{ Horizontal lines - above BaseLine }
A := FCalcBase;
while A > 0 do
begin
A := A - HorizontalGridSize * Height / (Maximum - Minimum);
MoveTo(0, Round(A));
LineTo(Width, Round(A));
end;
{ BaseLine }
Pen.Color := BaseColor;
MoveTo(0, FCalcBase);
LineTo(Width, FCalcBase);
// Redraw old values to keep history of values
for I := 0 to FLines.Count - 1 do
begin
Pen.Color := FLines[I].Color;
if FLines[I].FValues.Count > 0 then
begin
Position := (TotalTimeSteps - FLines[I].FValues.Count) * FStepPixelWidth;
MoveTo(Round(Position), GetLinePixelPosition(FLines[I], FLines[I].FValues[0]));
J := UpdateTimeSteps - 1;
while J < FLines[I].FValues.Count - 1 do
begin
Position := Position + UpdateTimeSteps * FStepPixelWidth;
LineTo(Round(Position), GetLinePixelPosition(FLines[I], FLines[I].FValues[J]));
Inc(J, UpdateTimeSteps);
end;
end
else
begin
FLines[I].FValues.Clear;
end;
end;
FCounter := 1;
end;
end;
procedure TJvSimScope.SetBaseLine(Value: Integer);
begin
FBaseLine := Value;
UpdateComputedValues;
UpdateDisplay(True);
end;
procedure TJvSimScope.SetBaseLineUnit(const Value: TJvScopeLineUnit);
begin
if FBaseLineUnit <> Value then
begin
FBaseLineUnit := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetInterval(Value: Integer);
begin
if FInterval <> Value then
begin
FDrawTimer.Enabled := False;
UpdateComputedValues;
FDrawTimer.Interval := Value * 10;
FInterval := Value;
FDrawTimer.Enabled := FActive;
end;
end;
procedure TJvSimScope.SetGridSize(Value: Integer);
begin
if ((Value <> FHorizontalGridSize) or (Value <> FVerticalGridSize)) and (Value > 0) then
begin
FHorizontalGridSize := Value;
FVerticalGridSize := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetHorizontalGridSize(const Value: Integer);
begin
if (FHorizontalGridSize <> Value) and (Value > 0) then
begin
FHorizontalGridSize := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetActive(Value: Boolean);
begin
if FActive <> Value then
begin
UpdateComputedValues;
FDrawTimer.Interval := Interval * 10;
FDrawTimer.Enabled := Value;
FActive := Value;
end;
end;
{ All drawings is performed on in the FDrawBuffer to speed up
proceedings and eliminate flicker. The Paint procedure merely
copies the contents of the FDrawBuffer. }
procedure TJvSimScope.UpdateScope;
var
A: Double;
I: Integer;
Dest, Src: TRect;
UpdateWidth: Integer;
J: Integer;
PosMinusOne: Double;
PosMinusTwo: Double;
begin
with FDrawBuffer.Canvas do
begin
Pen.Color := FGridColor;
UpdateWidth := Round(UpdateTimeSteps * FStepPixelWidth);
Dest.Top := 0;
Dest.Left := 0;
Dest.Right := Round(Width - UpdateWidth);
Dest.Bottom := Height;
Src.Top := 0;
Src.Left := Round(UpdateTimeSteps * FStepPixelWidth);
Src.Right := Width;
Src.Bottom := Height;
{ Copy bitmap leftwards }
CopyRect(Dest, FDrawBuffer.Canvas, Src);
{ Draw new area }
Pen.Color := Color;
Brush.Color := Color;
BRush.Style := bsSolid;
Dest.Top := 0;
Dest.Left := Width - UpdateWidth;
Dest.Right := Width;
Dest.Bottom := Height;
FilLRect(Dest);
(* Pen.Width := UpdateWidth;
MoveTo(Width - Round(UpdateWidth / 2), 0);
LineTo(Width - Round(UpdateWidth / 2), Height); *)
Pen.Color := GridColor;
Pen.Width := 1;
{ Draw vertical line if needed }
if FCounter >= Round(VerticalGridSize * FStepPixelWidth / UpdateWidth) then
begin
MoveTo(Width - 1, 0);
LineTo(Width - 1, Height);
FCounter := 0;
end;
FCounter := FCounter + 1;
{ Horizontal lines - below BaseLine }
A := FCalcBase;
while A < Height do
begin
A := A + HorizontalGridSize * Height / (Maximum - Minimum);
MoveTo(Width - UpdateWidth, Round(A));
LineTo(Width, Round(A));
end;
{ Horizontal lines - above BaseLine }
A := FCalcBase;
while A > 0 do
begin
A := A - HorizontalGridSize * Height / (Maximum - Minimum);
MoveTo(Width - UpdateWidth, Round(A));
LineTo(Width, Round(A));
end;
{ BaseLine }
Pen.Color := BaseColor;
MoveTo(Width - UpdateWidth, FCalcBase);
LineTo(Width, FCalcBase);
{ Draw position for lines}
for I := 0 to FLines.Count - 1 do
begin
Pen.Color := FLines[I].Color;
A := GetLinePixelPosition(FLines[I], FLines[I].Position);
PosMinusOne := GetLinePixelPosition(FLines[I], FLines[I].FValues[FLines[I].FValues.Count - 1 * UpdateTimeSteps]);
PosMinusTwo := GetLinePixelPosition(FLines[I], FLines[I].FValues[FLines[I].FValues.Count - 2 * UpdateTimeSteps]);
MoveTo(Width - UpdateWidth * 2, Round(PosMinusTwo));
LineTo(Width - UpdateWidth, Round(PosMinusOne));
LineTo(Width - 0, Round(A));
for J := 0 to UpdateTimeSteps - 1 do
FLines[I].FValues.Add(FLines[I].Position);
end;
end;
Repaint;
if Assigned(FOnUpdate) then
FOnUpdate(Self);
end;
{ Called by timer to show updates }
procedure TJvSimScope.Paint;
var
Rect: TRect;
begin
// inherited Paint;
FDrawBuffer.Height := Height;
FDrawBuffer.Width := Width;
Rect.Top := 0;
Rect.Left := 0;
Rect.Right := Width;
Rect.Bottom := Height;
Canvas.CopyRect(Rect, FDrawBuffer.Canvas, Rect);
FAllowed := True;
end;
{ Recalulate control after move and/or resize }
procedure TJvSimScope.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
{ BUGFIX/Workaround:JAN 2009 - ACCESS VIOLATIONS AND ODD BEHAVIOUR - SIZE/WIDTH BEING ZAPPED TO ZERO.}
if AWidth < JvMinimumScopeWidth then
AWidth := JvMinimumScopeWidth;
if AHeight < JvMinimumScopeHeight then
AHeight := JvMinimumScopeHeight;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
FDrawBuffer.Height := Height;
FDrawBuffer.Width := Width;
if DisplayUnits = jduPixels then
begin
FMinimum := 0;
FMaximum := AHeight;
FTotalTimeSteps := AWidth;
end;
Clear;
end;
procedure TJvSimScope.UpdateComputedValues;
begin
case FBaseLineUnit of
jluPercent:
FCalcBase := Height - Round(Height * FBaseLine / 100);
jluAbsolute:
FCalcBase := Height - Round(Height * (FBaseLine - Minimum) / (Maximum - Minimum));
end;
FStepPixelWidth := Width / TotalTimeSteps;
if FUpdateTimeSteps * FStepPixelWidth < 2 then
UpdateTimeSteps := 2;
end;
procedure TJvSimScope.SetDisplayUnits(const Value: TJvSimScopeDisplayUnit);
begin
if FDisplayUnits <> Value then
begin
FDisplayUnits := Value;
if FDisplayUnits = jduPixels then
begin
FMinimum := 0;
FMaximum := Height;
end;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetLines(const Value: TJvScopeLines);
begin
FLines.Assign(Value);
Clear;
end;
procedure TJvSimScope.SetMaximum(const Value: Integer);
begin
if (FDisplayUnits <> jduPixels) and (FMaximum <> Value) then
begin
FMaximum := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetMinimum(const Value: Integer);
begin
if (FDisplayUnits <> jduPixels) and (FMinimum <> Value) then
begin
FMinimum := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetTotalTimeSteps(const Value: Integer);
begin
if (FDisplayUnits <> jduPixels) and (FTotalTimeSteps <> Value) then
begin
FTotalTimeSteps := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.SetUpdateTimeSteps(const Value: Integer);
begin
if (FUpdateTimeSteps <> Value) and (Value > 0) then
begin
FUpdateTimeSteps := Value;
end;
end;
procedure TJvSimScope.SetVerticalGridSize(const Value: Integer);
begin
if (FVerticalGridSize <> Value) and (Value > 0) then
begin
FVerticalGridSize := Value;
UpdateDisplay(True);
end;
end;
procedure TJvSimScope.UpdateDisplay(ClearFirst: Boolean);
begin
if Parent <> nil then
begin
if ClearFirst then
Clear;
Repaint;
end;
end;
end.