unit VisCtl2D;
interface
uses
Windows, Messages, SysUtils, Types, UITypes, Classes, Graphics, Controls,
Forms, Direct2D, D2D1, ExtCtrls, Generics.Defaults, Generics.Collections,
Dialogs, Menus, ASObjects, ASNum, SVG, DoublePoint, VisCtl;
type
TSVGExportOptions = record
Width: Single;
Height: Single;
LengthUnit: string;
Stretch: Boolean;
Title: string;
Description: string;
Language: string;
procedure SetDimensionsFromText(const AWidth, AHeight: string);
procedure Validate;
function SpecificSize: Boolean;
function SpecificWidth: Boolean;
function SpecificHeight: Boolean;
function AutomaticSize: Boolean;
function AutomaticWidth: Boolean;
function AutomaticHeight: Boolean;
function AutomaticAspectRatio: Boolean;
function SpecificAspectRatio: Boolean;
end;
const
DefaultSVGExportOptions: TSVGExportOptions = ();
type
EVisCtlException = class(Exception);
{$SCOPEDENUMS ON}
TCartesianAxis = (X, Y);
{$SCOPEDENUMS OFF}
TAnchorPoint =
(
apTopLeft, apTop, apTopRight,
apLeft, apCenter, apRight,
apBottomLeft, apBottom, apBottomRight
);
TLinearAlignment = (laNegative, laMiddle, laPositive);
TAnchorPointHelper = record helper for TAnchorPoint
strict private const
PointNames: array[TAnchorPoint] of string =
(
'top-left', 'top', 'top-right',
'left', 'center', 'right',
'bottom-left', 'bottom', 'bottom-right'
);
public
function H: TLinearAlignment; inline;
function V: TLinearAlignment; inline;
function ToString: string;
class function FromString(const S: string): TAnchorPoint; static;
end;
procedure AlignRect(var ARect: TRect; AAnchorPoint: TAnchorPoint); overload;
procedure AlignRect(var ARect: TRectD; AAnchorPoint: TAnchorPoint); overload;
type
TSVGBuilder_VisCtl2D = class;
TDrawable = class;
TDrawableOptionsFrm = class(TForm)
protected
FInitialized: Boolean;
FDrawable: TDrawable;
FOnChange: TNotifyEvent;
procedure Initialize; virtual;
procedure UpdateDrawable; virtual;
property Initialized: Boolean read FInitialized;
procedure DrawableDestroyed(Sender: TObject);
public
constructor Create(AOwner: TComponent; ADrawable: TDrawable); reintroduce; virtual;
procedure Reassign(ADrawable: TDrawable);
property Drawable: TDrawable read FDrawable;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TDrawableOptionsFrmClass = class of TDrawableOptionsFrm;
TLineEndMarker = (lemNone, lemLineArrow, lemSolidArrow, lemSemiArrow, lemDisk,
lemSquare, lemSquare2, lemLine, lemBroken);
TLineEndMarkerHelper = record helper for TLineEndMarker
strict private
const MarkerNames: array[TLineEndMarker] of string =
('none', 'line arrow', 'triangle', 'semiarrow', 'disk', 'square',
'square 2', 'bar', 'broken');
public
function IsFilled: Boolean;
function ToString: string;
class function FromString(const S: string): TLineEndMarker; static;
end;
TVisCtl2D = class;
TView2D = class;
TDrawable = class(TVisObj)
strict private
class var FInstances: TDictionary<TGUID, TDrawable>;
class var FModalLevel: Integer;
class constructor ClassCreate;
class destructor ClassDestroy;
class procedure InstanceListChanged(Sender: TObject; const Item: TGUID;
Action: TCollectionNotification);
procedure SetVisible(const Value: Boolean);
public
class function TryGetDrawableByGUID(const AGUID: TGUID;
out ADrawable: TDrawable): Boolean; static;
class property ModalLevel: Integer read FModalLevel;
class property Instances: TDictionary<TGUID, TDrawable> read FInstances;
class function GetRealm: string; override; final;
protected
FVisible: Boolean;
FCtl: TVisCtl2D;
FView: TView2D;
FVertFlag: Boolean;
FBehindAxes: Boolean;
FOnChange: TNotifyEvent;
FOptionsFrmClass: TDrawableOptionsFrmClass;
private
procedure Draw; virtual;
procedure DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D); virtual;
procedure DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D); virtual;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); virtual;
procedure DrawTo(ASVG: TSVGBuilder_VisCtl2D);
procedure FreeDeviceResources; virtual;
protected
function Canvas: TDirect2DCanvas; inline;
function CanvasRect: TRect; inline;
procedure DrawLine(const A, B: TPointD);
procedure DrawLineSp(const A, B: TPointD); inline;
procedure DrawRect(const ARect: TRectD); overload; inline;
procedure DrawRect(const ARect: TRectD; const ARotAngle: Double); overload;
procedure DrawRectSp(const ARect: TRectD); overload; inline;
procedure DrawRectSp(const ARect: TRectD; const ARotAngle: Double); overload; inline;
procedure DrawEllipse(const R: TRectD); inline;
procedure DrawEllipseSp(const R: TRectD); inline;
procedure DrawDisk(const P: TPointD; const R: Double); inline;
procedure DrawDiskSp(const P: TPointD; const R: Double); inline;
procedure DrawDiskSpPx(const P: TPointD; const R: Double); inline;
procedure DrawLineEndMarker(AMarker: TLineEndMarker; AFilled: Boolean;
const P: TPointD; const ASizeX, ASizeY, AAngle: Double);
procedure DrawLineEndMarkerSp(AMarker: TLineEndMarker; AFilled: Boolean;
const P: TPointD; const ASizeX, ASizeY, AAngle: Double); inline;
procedure TextOut(const X, Y: Double; const Text: string);
procedure Changed; overload; inline;
procedure Changed(Sender: TObject); overload; inline;
function Direction(const Angle: Double): TPointD;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); virtual;
destructor Destroy; override;
function amin(ALim: Boolean = False): Double; virtual;
function amax(ALim: Boolean = False): Double; virtual;
function aspan(ALim: Boolean = False): Double; inline;
function AxP(const A, B: Double): TPointD; virtual;
function AxPScr(const A, B: Double): TPointD; inline;
function AxisScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; virtual;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; virtual;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; virtual;
function AxisSvgPoint(AViewBox: TViewBox; const A: Double;
const D: Double = 0.0; const D2: Double = 0.0): TPointD; virtual;
function SizePrimary(const S: TSize): Integer; virtual;
function SizeSecondary(const S: TSize): Integer; virtual;
procedure ShowOptionsForm(AParent: TCustomForm = nil); override;
procedure Configure(ASettings: TAlgosimStructure); virtual;
function CreateReference: TAlgosimReference; virtual;
property BehindAxes: Boolean read FBehindAxes;
property Control: TVisCtl2D read FCtl;
property Visible: Boolean read FVisible write SetVisible;
property OptionsFormClass: TDrawableOptionsFrmClass read FOptionsFrmClass write FOptionsFrmClass;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TView2D = class(TDrawable)
strict private
const
TranslationAnimationDurationSec = 0.5;
TranslationAnimationFramerateFPS = 30;
TranslationAnimationFrameCount =
Round(TranslationAnimationDurationSec * TranslationAnimationFramerateFPS);
TAFC = TranslationAnimationFrameCount;
const
_xmin = 0;
_xmax = 1;
_ymin = 2;
_ymax = 3;
type
TBoundsArray = array[0..3] of Double;
const
DefBoundsArray: TBoundsArray = (-10, 10, -10, 10);
var
FBounds: TBoundsArray;
FTranslationTimer: TTimer;
FZoomTranslationTimer: TTimer;
FTranslationAnimationBegin: TDateTime;
FTranslationAnimationEnd: TDateTime;
FTranslationAnimation: array[0..TAFC - 1] of TPointD;
FZoomTranslationAnimation: array[0..TAFC - 1] of TRectD;
function GetBound(const Index: Integer): Double; inline;
procedure SetBound(const Index: Integer; const Value: Double);
function GetCenter: TPointD;
procedure SetCenter(const Value: TPointD);
procedure TranslationTimerTimer(Sender: TObject);
procedure ZoomTranslationTimerTimer(Sender: TObject);
public
constructor Create(ACtl: TVisCtl2D); reintroduce;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
destructor Destroy; override;
function XSpan: Double; inline;
function YSpan: Double; inline;
function Area: Double; inline;
function TopLeft: TPointD; inline;
function BottomRight: TPointD; inline;
function ScaleX(const X: Double): Double; inline;
function ScaleY(const Y: Double): Double; inline;
function Scale(const P: TPointD): TPointD; inline;
procedure AnimateTo(const ACenterPoint: TPointD; AMoveCursor: Boolean = False); overload;
procedure AnimateTo(const ACorner1, ACorner2: TPointD); overload;
procedure Normalize(AFlexibleAxis: TCartesianAxis);
published
property XMin: Double index _xmin read GetBound write SetBound nodefault;
property XMax: Double index _xmax read GetBound write SetBound nodefault;
property YMin: Double index _ymin read GetBound write SetBound nodefault;
property YMax: Double index _ymax read GetBound write SetBound nodefault;
property CenterPoint: TPointD read GetCenter write SetCenter;
function MaxDistFromZero: Double;
function MinDistFromZero: Double;
procedure SetX(const AFrom, ATo: Double);
procedure SetY(const AFrom, ATo: Double);
procedure &Set(const AXFrom, AXTo, AYFrom, AYTo: Double; APreferAxes: Boolean = False);
end;
TTickSide = (tsBoth, tsNegative, tsPositive);
TAxis = class(TDrawable)
strict private
FAutomatic: Boolean;
FAxisPosition: Double;
FVisible: Boolean;
FColor: TColor;
FWidth: Integer;
FMin, FMax: Double;
FTickDistance: Double;
FTickLength: Integer;
FTickWidth: Integer;
FTickColor: TColor;
FTickSide: TTickSide;
FTicksVisible: Boolean;
FNumberDistance: Double;
FNumberUnitValue: Double;
FNumberUnitSymbol: string;
FNumberFormat: string;
FNumberFont: TFont;
FNumbersVisible: Boolean;
FText: string;
FTextOffset: Integer;
FTextFont: TFont;
procedure SetAutomatic(const Value: Boolean);
procedure SetPosition(const Value: Double);
procedure SetColor(const Value: TColor);
procedure SetMin(const Value: Double);
procedure SetMax(const Value: Double);
procedure SetNumberDistance(const Value: Double);
procedure SetNumberFont(const Value: TFont);
procedure SetNumberFormat(const Value: string);
procedure SetNumberUnitSymbol(const Value: string);
procedure SetNumberUnitValue(const Value: Double);
procedure SetNumbersVisible(const Value: Boolean);
procedure SetTickDistance(const Value: Double);
procedure SetTickLength(const Value: Integer);
procedure SetTickWidth(const Value: Integer);
procedure SetTickColor(const Value: TColor);
procedure SetTickSide(const Value: TTickSide);
procedure SetTicksVisible(const Value: Boolean);
procedure SetWidth(const Value: Integer);
procedure SetVisible(const Value: Boolean);
procedure SetText(const Value: string);
procedure SetTextOffset(const Value: Integer);
procedure SetTextFont(const Value: TFont);
strict private const
DefaultAutomatic = True;
DefaultColor = clBlack;
DefaultNumberDistance = 1.0;
DefaultNumberFormat = '';
DefaultNumberUnitSymbol = '';
DefaultNumberUnitValue = 0.0;
DefaultNumbersVisible = True;
DefaultWidth = 2;
DefaultTickDistance = 1.0;
DefaultTickLength = 4;
DefaultTickWidth = 2;
DefaultTickColor = clBlack;
DefaultTickSide = tsBoth;
DefaultTicksVisible = True;
DefaultVisible = True;
DefaultTextOffset = 10;
private
procedure Draw; override;
procedure DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D); override;
procedure DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D); override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
strict protected
FNumberWidth: Integer;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function Limited: Boolean; inline;
function AxSpan: Double; inline;
published
property Automatic: Boolean read FAutomatic write SetAutomatic default DefaultAutomatic;
property Color: TColor read FColor write SetColor default DefaultColor;
property AxMin: Double read FMin write SetMin;
property AxMax: Double read FMax write SetMax;
property NumberDistance: Double read FNumberDistance write SetNumberDistance nodefault;
property NumberFont: TFont read FNumberFont write SetNumberFont;
property NumberFormat: string read FNumberFormat write SetNumberFormat;
property NumberUnitSymbol: string read FNumberUnitSymbol write SetNumberUnitSymbol;
property NumberUnitValue: Double read FNumberUnitValue write SetNumberUnitValue;
property NumbersVisible: Boolean read FNumbersVisible write SetNumbersVisible default DefaultNumbersVisible;
property Position: Double read FAxisPosition write SetPosition;
property Width: Integer read FWidth write SetWidth default DefaultWidth;
property Text: string read FText write SetText;
property TextOffset: Integer read FTextOffset write SetTextOffset default DefaultTextOffset;
property TextFont: TFont read FTextFont write SetTextFont;
property TickDistance: Double read FTickDistance write SetTickDistance nodefault;
property TickLength: Integer read FTickLength write SetTickLength default DefaultTickLength;
property TickWidth: Integer read FTickWidth write SetTickWidth default DefaultTickWidth;
property TickColor: TColor read FTickColor write SetTickColor default DefaultTickColor;
property TickSide: TTickSide read FTickSide write SetTickSide default DefaultTickSide;
property TicksVisible: Boolean read FTicksVisible write SetTicksVisible default DefaultTicksVisible;
property Visible: Boolean read FVisible write SetVisible default DefaultVisible;
end;
THorizontalAxis = class(TAxis)
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function AxisScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function AxisSvgPoint(AViewBox: TViewBox; const A: Double;
const D: Double = 0.0; const D2: Double = 0.0): TPointD; override;
function SizePrimary(const S: TSize): Integer; override;
function SizeSecondary(const S: TSize): Integer; override;
end;
TVerticalAxis = class(TAxis)
strict private
FRotateAxisText: Boolean;
procedure SetRotateAxisText(const Value: Boolean);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function AxP(const A, B: Double): TPointD; override;
function AxisScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function AxisSvgPoint(AViewBox: TViewBox; const A: Double;
const D: Double = 0.0; const D2: Double = 0.0): TPointD; override;
function SizePrimary(const S: TSize): Integer; override;
function SizeSecondary(const S: TSize): Integer; override;
published
property RotateAxisText: Boolean read FRotateAxisText write SetRotateAxisText;
end;
TAxes = class(TDrawable)
strict private
FX: THorizontalAxis;
FY: TVerticalAxis;
procedure SetX(const Value: THorizontalAxis);
procedure SetY(const Value: TVerticalAxis);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function CreateReference: TAlgosimReference; override;
published
property X: THorizontalAxis read FX write SetX;
property Y: TVerticalAxis read FY write SetY;
end;
TGridLineFamily = class(TDrawable)
strict private
FMin, FMax: Double;
FBegin, FEnd: Double;
FDistance: Double;
FVisible: Boolean;
FWidth: Integer;
FColor: TColor;
FPenStyle: TPenStyle;
procedure SetMin(const Value: Double);
procedure SetMax(const Value: Double);
procedure SetBegin(const Value: Double);
procedure SetEnd(const Value: Double);
procedure SetDistance(const Value: Double);
procedure SetColor(const Value: TColor);
procedure SetPenStyle(const Value: TPenStyle);
procedure SetWidth(const Value: Integer);
procedure SetVisible(const Value: Boolean);
strict private const
DefaultVisible = False;
DefaultWidth = 1;
DefaultColor = clBlack;
DefaultPenStyle = psSolid;
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
procedure Assign(Source: TPersistent); override;
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function Limited: Boolean; inline;
function LineLimited: Boolean; inline;
published
property Distance: Double read FDistance write SetDistance nodefault;
property AxMin: Double read FMin write SetMin;
property AxMax: Double read FMax write SetMax;
property LineBegin: Double read FBegin write SetBegin;
property LineEnd: Double read FEnd write SetEnd;
property Visible: Boolean read FVisible write SetVisible default DefaultVisible;
property Width: Integer read FWidth write SetWidth default DefaultWidth;
property Color: TColor read FColor write SetColor default DefaultColor;
property PenStyle: TPenStyle read FPenStyle write SetPenStyle default DefaultPenStyle;
end;
THorizontalGridLineFamily = class(TGridLineFamily)
public
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function AxisScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function SizePrimary(const S: TSize): Integer; override;
function SizeSecondary(const S: TSize): Integer; override;
function AxP(const A: Double; const B: Double): TPointD; override;
end;
TVerticalGridLineFamily = class(TGridLineFamily)
public
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function AxisScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function SizePrimary(const S: TSize): Integer; override;
function SizeSecondary(const S: TSize): Integer; override;
end;
TRadialGridLineFamily = class(TGridLineFamily)
public
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function FirstScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function LastScrPoint(const A: Double; D: Integer = 0; D2: Integer = 0): TPointD; override;
function AxP(const A: Double; const B: Double): TPointD; override;
end;
TCircularGridLineFamily = class(TGridLineFamily)
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
function amin(ALim: Boolean = False): Double; override;
function amax(ALim: Boolean = False): Double; override;
function AxP(const A: Double; const B: Double): TPointD; override;
end;
TGridLineFamilies = class(TDrawable)
strict private
FHorizontalPrimary, FHorizontalSecondary: THorizontalGridLineFamily;
FVerticalPrimary, FVerticalSecondary: TVerticalGridLineFamily;
FRadialPrimary, FRadialSecondary: TRadialGridLineFamily;
FCircular: TCircularGridLineFamily;
procedure SetHorizontalPrimary(const Value: THorizontalGridLineFamily);
procedure SetHorizontalSecondary(const Value: THorizontalGridLineFamily);
procedure SetVerticalPrimary(const Value: TVerticalGridLineFamily);
procedure SetVerticalSecondary(const Value: TVerticalGridLineFamily);
procedure SetRadialPrimary(const Value: TRadialGridLineFamily);
procedure SetRadialSecondary(const Value: TRadialGridLineFamily);
procedure SetCircular(const Value: TCircularGridLineFamily);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function CreateReference: TAlgosimReference; override;
published
property HorizontalPrimary: THorizontalGridLineFamily read FHorizontalPrimary write SetHorizontalPrimary;
property HorizontalSecondary: THorizontalGridLineFamily read FHorizontalSecondary write SetHorizontalSecondary;
property VerticalPrimary: TVerticalGridLineFamily read FVerticalPrimary write SetVerticalPrimary;
property VerticalSecondary: TVerticalGridLineFamily read FVerticalSecondary write SetVerticalSecondary;
property RadialPrimary: TRadialGridLineFamily read FRadialPrimary write SetRadialPrimary;
property RadialSecondary: TRadialGridLineFamily read FRadialSecondary write SetRadialSecondary;
property Circular: TCircularGridLineFamily read FCircular write SetCircular;
end;
TDiagram = class(TDrawable)
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
function CreateReference: TAlgosimReference; override;
end;
TDrawableList = class(TDrawable)
strict private
FList: TObjectList<TDrawable>;
function GetItem(Index: Integer): TDrawable;
procedure SetItem(Index: Integer; const Value: TDrawable);
function GetItemCount: Integer;
procedure ObjsNotify(Sender: TObject; const Item: TDrawable;
Action: TCollectionNotification);
private
procedure Draw; overload; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); overload; override;
procedure Draw(BottomLayer: Boolean); reintroduce; overload;
procedure DrawTo(ASVG: TSVGBuilder_VisCtl2D; BottomLayer: Boolean); overload;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure MoveUp(ADrawable: TDrawable);
procedure MoveDown(ADrawable: TDrawable);
property List: TObjectList<TDrawable> read FList;
property Items[Index: Integer]: TDrawable read GetItem write SetItem; default;
property ItemCount: Integer read GetItemCount;
end;
TVisCtl2D = class(TVisCtl)
public const
CMD_SETTINGS = 10;
CMD_CENTERATORIGIN = 11;
CMD_NORMALIZEADJUSTHOR = 12;
CMD_NORMALIZEADJUSTVERT = 13;
CMD_TOGGLEAUTONORMALIZE = 14;
CMD_SAVESVG = 15;
CMD_COPYBMP = 16;
CMD_NORMALIZE = CMD_NORMALIZEADJUSTHOR;
strict private
FCanvas: TDirect2DCanvas;
FDiagram: TDiagram;
FView: TView2D;
xmin, xmax, ymin, ymax: Double;
FAxes: TAxes;
FGridLines: TGridLineFamilies;
FObjs: TDrawableList;
FInvFS: TFormatSettings;
FPrevMousePos: TPoint;
FZoomCorner,
FZoomCorner2: TPoint;
FZoomRect: Boolean;
FZoomRectBrush: ID2D1SolidColorBrush;
FMenu: TPopupMenu;
FAutoNormalize: Boolean;
FMnuAutoNormalize: TMenuItem;
FCustomMenuItems: TList<TMenuItem>;
FOnBeforeContextPopup: TNotifyEvent;
FBackgroundPaintLevel: Integer;
FInvalidationTimer: TTimer;
procedure ViewChanged(Sender: TObject);
procedure ObjChanged(Sender: TObject);
function xspan: Double; inline;
function yspan: Double; inline;
procedure SetView(const Value: TView2D);
procedure SetAxes(const Value: TAxes);
procedure SetGridLines(const Value: TGridLineFamilies);
procedure DrawZoomRect;
procedure CreateDeviceResources;
procedure FreeDeviceResources;
function GetObjectCount: Integer;
function GetObject(Index: Integer): TDrawable;
procedure CreateLineEndMarkers;
procedure CreateContextMenu;
procedure MenuCommand(Sender: TObject);
procedure SetAutoNormalize(const Value: Boolean);
procedure MenuPopup(Sender: TObject);
procedure CustomizeMenu(AMenu: TMenu);
procedure InvalidationTimerTimer(Sender: TObject);
private
type
TFilledBool = type Boolean;
TStartBool = type Boolean;
var
FLineEndMarkers: array[TLineEndMarker] of ID2D1PathGeometry;
FSVGMarkers: array[TLineEndMarker] of array[TFilledBool] of array[TStartBool] of TTag;
class function P(const X, Y: Double): TPointD; static; inline;
class function Q(const X, Y: Double): TPointD; static; inline;
function UnboundXMin(const APoint: TD2D1Point2F): TD2D1Point2F;
function UnboundXMax(const APoint: TD2D1Point2F): TD2D1Point2F;
function UnboundYMin(const APoint: TD2D1Point2F): TD2D1Point2F;
function UnboundYMax(const APoint: TD2D1Point2F): TD2D1Point2F;
function UnboundIdentity(const APoint: TD2D1Point2F): TD2D1Point2F; inline;
function Scr(const X, Y: Double): TPointD; inline;
protected
procedure CreateWnd; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMDisplayChange(var Message: TWMDisplayChange); message WM_DISPLAYCHANGE;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
procedure Paint; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
override;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
override;
procedure DblClick; override;
function SpaceToViewbox(const AViewBox: TViewBox;
const ASpaceCoords: TPointD; DX: Integer = 0; DY: Integer = 0): TPointD;
procedure KeyPress(var Key: Char); override;
strict private
const SVGFDCCTL_Title = 101;
const SVGFDCCTL_Descr = 102;
const SVGFDCCTL_Width = 103;
const SVGFDCCTL_Height = 104;
const SVGFDCCTL_Stretch = 105;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LowPriorityInvalidate;
procedure ExecCommand(ACommand: Integer);
property Canvas: TDirect2DCanvas read FCanvas;
function CanvasToSpace(const ACanvasCoords: TPointD): TPointD;
function SpaceToCanvas(const ASpaceCoords: TPointD; DX: Integer = 0;
DY: Integer = 0): TPointD; overload;
function SpaceToCanvas(const ASpaceCoords: TPointD;
const DX, DY: Double): TPointD; overload;
function SpaceToCanvas(const ASpaceCoords: TRectD;
AFlipped: Boolean = False): TRectD; overload;
function SpaceToCanvas(const X, Y: Double; DX: Integer = 0; DY:
Integer = 0): TPointD; overload;
function TrySpaceToD2d1(const ASpaceCoords: TPointD;
out AD2d1Point: TD2D1Point2F): Boolean;
function CanvasRect: TRect;
function PixelsToDips(const APoint: TPoint): TPointD; overload;
function PixelsToDips(const ARect: TRect): TRectD; overload;
function DipsToPixels(const APoint: TPointD): TPoint; overload;
function DipsToPixels(const ARect: TRectD): TRect; overload;
property ObjectMgr: TDrawableList read FObjs;
procedure Translate(const DX, DY: Double);
procedure ZoomX(const A: Double);
procedure ZoomY(const A: Double);
procedure Zoom(const Factor: Double);
procedure ZoomIn;
procedure ZoomOut;
property InvFS: TFormatSettings read FInvFS;
property Diagram: TDiagram read FDiagram;
procedure AddObject(AObject: TDrawable);
property ObjectCount: Integer read GetObjectCount;
property Objects[Index: Integer]: TDrawable read GetObject;
procedure RemoveObject(AObject: TDrawable);
procedure ClearDiagram;
procedure AddMenuItem(AMenuItem: TMenuItem);
procedure AddMenuItems(AMenu: TMenuItem);
procedure RemoveMenuItem(AMenuItem: TMenuItem);
procedure BeginBackgroundPaint;
procedure EndBackgroundPaint;
function AsSVG(const ASVGExportOptions: TSVGExportOptions): string;
procedure SaveAsSVG(const AFileName: string;
const ASVGExportOptions: TSVGExportOptions); overload;
procedure SaveAsSVG; overload;
procedure SaveAsSVGFileDialogExecute(Sender: TObject);
procedure SaveAsSVGFileDialogOKClick(Sender: TObject; var CanClose: Boolean);
procedure CopyToClipboard;
published
property Anchors;
property Align;
property AlignWithMargins;
property AutoNormalize: Boolean read FAutoNormalize write SetAutoNormalize;
property Axes: TAxes read FAxes write SetAxes;
property Color;
property Cursor;
property Enabled;
property Font;
property GridLines: TGridLineFamilies read FGridLines write SetGridLines;
property TabStop default True;
property View: TView2D read FView write SetView;
property Visible;
property OnBeforeContextPopup: TNotifyEvent read FOnBeforeContextPopup write FOnBeforeContextPopup;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
end;
TElementStylePart = (espColor, espOpacity, espBorderColor, espBorderWidth,
espDisplacement);
TElementStyleParts = set of TElementStylePart;
TElementStyle = class(TDrawable)
strict private
FColor: TColor;
FOpacity: Byte;
FBorderColor: TColor;
FBorderWidth: Integer;
FDisplacement: Double;
FElementStyleParts: TElementStyleParts;
procedure SetBorderColor(const Value: TColor);
procedure SetBorderWidth(const Value: Integer);
procedure SetColor(const Value: TColor);
procedure SetOpacity(const Value: Byte);
procedure SetDisplacement(const Value: Double);
function GetOpacityFraction: Double;
procedure SetOpacityFraction(const Value: Double);
strict private const
DefaultColor = clNavy;
DefaultOpacity = 255;
DefaultBorderColor = clBlack;
DefaultBorderWidth = 1;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Color: TColor read FColor write SetColor default DefaultColor;
property Opacity: Byte read FOpacity write SetOpacity default DefaultOpacity;
property OpacityFraction: Double read GetOpacityFraction write SetOpacityFraction;
property BorderColor: TColor read FBorderColor write SetBorderColor default DefaultBorderColor;
property BorderWidth: Integer read FBorderWidth write SetBorderWidth default DefaultBorderWidth;
property Displacement: Double read FDisplacement write SetDisplacement;
property Parts: TElementStyleParts read FElementStyleParts write FElementStyleParts;
end;
TCategoryElement = class(TDrawable)
strict private
FLabel: string;
FValue: Double;
FStyle: TElementStyle;
procedure SetLabel(const Value: string);
procedure SetStyle(const Value: TElementStyle);
procedure SetValue(const Value: Double);
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property &Label: string read FLabel write SetLabel;
property Value: Double read FValue write SetValue;
property Style: TElementStyle read FStyle write SetStyle;
end;
TCategoryElements = class(TObjectList<TCategoryElement>)
function MaxValue: Double;
function Sum: Double;
function RelativeValues: TArray<Double>;
end;
TCategoryChart = class(TDrawable)
strict protected
FCategories: TCategoryElements;
FShowLegend: Boolean;
FLegendStyle: TElementStyle;
FLegendFont: TFont;
FChartTypeName: string;
FLabelFont: TFont;
FLabelVisible,
FValueLabelVisible: Boolean;
FValueFont: TFont;
FValueFormat: string;
FValueLabelPosition: Double;
FLabelPosition: Double;
FDetailsOptionsFrmClass: TDrawableOptionsFrmClass;
function GetLabelFont: TFont;
procedure SetLabelFont(const Value: TFont);
function GetValueFont: TFont;
procedure SetValueFont(const Value: TFont);
procedure SetValueLabelPosition(const Value: Double);
procedure SetValueFormat(const Value: string);
procedure CategoriesNotify(Sender: TObject; const Item: TCategoryElement;
Action: TCollectionNotification);
procedure SetCategories(const Value: TCategoryElements);
procedure SetShowLegend(const Value: Boolean);
procedure SetLegendStyle(const Value: TElementStyle);
function GetLegendFont: TFont;
procedure SetLegendFont(const Value: TFont);
procedure SetLabelVisible(const Value: Boolean);
procedure SetValueLabelVisible(const Value: Boolean);
procedure SetLabelPosition(const Value: Double);
private
procedure Draw; override;
procedure DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D); override;
procedure DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D); override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
function AddCategory(const ALabel: string; const AValue: Double): TCategoryElement; virtual;
procedure Clear;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function CreateReference: TAlgosimReference; override;
property Categories: TCategoryElements read FCategories write SetCategories;
property ShowLegend: Boolean read FShowLegend write SetShowLegend;
property LegendStyle: TElementStyle read FLegendStyle write SetLegendStyle;
property LegendFont: TFont read GetLegendFont write SetLegendFont;
property ChartTypeName: string read FChartTypeName;
property LabelVisible: Boolean read FLabelVisible write SetLabelVisible;
property LabelPosition: Double read FLabelPosition write SetLabelPosition;
property LabelFont: TFont read GetLabelFont write SetLabelFont;
property ValueLabelVisible: Boolean read FValueLabelVisible write SetValueLabelVisible;
property ValueLabelPosition: Double read FValueLabelPosition write SetValueLabelPosition;
property ValueFont: TFont read GetValueFont write SetValueFont;
property ValueFormat: string read FValueFormat write SetValueFormat;
property DetailsOptionsFormClass: TDrawableOptionsFrmClass read FDetailsOptionsFrmClass;
end;
TBarChart_Bar = TCategoryElement;
TBarChart = class(TCategoryChart)
strict private
FBarOffset: Double;
FBarWidth: Double;
FBarSpacing: Double;
procedure SetBarOffset(const Value: Double);
procedure SetBarSpacing(const Value: Double);
procedure SetBarWidth(const Value: Double);
procedure DrawBar(ABar: TCategoryElement; AIndex: Integer; const AOffset: Double);
procedure DrawBarTo(ASVG: TSVGBuilder_VisCtl2D; ABar: TCategoryElement; AIndex: Integer;
const AOffset: Double);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function AddBar(const ALabel: string; const AValue: Double): TCategoryElement;
property Bars: TCategoryElements read FCategories write SetCategories;
property BarOffset: Double read FBarOffset write SetBarOffset;
property BarWidth: Double read FBarWidth write SetBarWidth;
property BarSpacing: Double read FBarSpacing write SetBarSpacing;
end;
THistogram = class(TDrawable)
strict private
FStyle: TElementStyle;
FData: TArray<Double>;
FBinWidth: Double;
FBinValues: TArray<Int64>;
FMinDataValue,
FMaxDataValue,
FDataSpan: Double;
FStartAt: Double;
FActualStartAt: Double;
procedure SetStyle(const Value: TElementStyle);
procedure SetData(const Value: TArray<Double>);
procedure SetBinWidth(const Value: Double);
procedure SetStartAt(const Value: Double);
function GetDataLength: Integer; inline;
function GetBinIndex(const Value: Double): Integer;
function GetMaxBinValue: Int64;
procedure RecomputeStartAt;
procedure Recompute;
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Style: TElementStyle read FStyle write SetStyle;
property Data: TArray<Double> read FData write SetData;
property BinWidth: Double read FBinWidth write SetBinWidth;
property StartAt: Double read FStartAt write SetStartAt;
property MinDataValue: Double read FMinDataValue;
property MaxDataValue: Double read FMaxDataValue;
property DataValueSpan: Double read FDataSpan;
property DataLength: Integer read GetDataLength;
property MaxBinValue: Int64 read GetMaxBinValue;
end;
TXYPlot = class(TDrawable)
strict protected
FStyle: TElementStyle;
FData: TArray<TPointD>;
FPointSize: Integer;
FPoints: Boolean;
FLines: Boolean;
FArea: Boolean;
procedure SetStyle(const Value: TElementStyle);
procedure SetData(const Value: TArray<TPointD>);
procedure SetPointSize(const Value: Integer);
procedure SetPoints(const Value: Boolean);
procedure SetLines(const Value: Boolean);
procedure SetArea(const Value: Boolean);
const
DefaultPointSize = 2;
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Style: TElementStyle read FStyle write SetStyle;
property Data: TArray<TPointD> read FData write SetData;
property PointSize: Integer read FPointSize write SetPointSize default DefaultPointSize;
property Points: Boolean read FPoints write SetPoints default True;
property Lines: Boolean read FLines write SetLines default False;
property Area: Boolean read FArea write SetArea default False;
end;
TPieChart_Slice = TCategoryElement;
TPieChart = class(TCategoryChart)
strict private
FOrigin: TPointD;
FRadius: Double;
FStartAngle: Double;
procedure SetStartAngle(const Value: Double);
procedure SetOrigin(const Value: TPointD);
procedure SetRadius(const Value: Double);
procedure DrawSlice(ASlice: TCategoryElement; const AFraction: Double;
AIndex: Integer; const AOffset: Double);
procedure DrawSliceTo(ASVG: TSVGBuilder_VisCtl2D; ASlice: TCategoryElement;
const AFraction: Double; AIndex: Integer; const AOffset: Double);
procedure DrawSliceLabels(ASlice: TCategoryElement; const AFraction: Double;
AIndex: Integer; const AOffset: Double);
procedure DrawSliceLabelsTo(ASVG: TSVGBuilder_VisCtl2D; ASlice: TCategoryElement;
const AFraction: Double; AIndex: Integer; const AOffset: Double);
const
DefaultLabelPosition = 0.8;
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
function AddCategory(const ALabel: string; const AValue: Double): TCategoryElement; override;
function AddSlice(const ALabel: string; const AValue: Double): TCategoryElement;
property Slices: TCategoryElements read FCategories write SetCategories;
property StartAngle: Double read FStartAngle write SetStartAngle;
property Origin: TPointD read FOrigin write SetOrigin;
property Radius: Double read FRadius write SetRadius nodefault;
end;
TPixmap = class(TDrawable)
strict private
FBitmap: TBitmap;
FD2D1Bitmap: ID2D1Bitmap;
FRect: TRectD;
FStyle: TElementStyle;
procedure SetBitmap(const Value: TBitmap);
procedure SetRect(const Value: TRectD);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
procedure FreeDeviceResources; override;
procedure SetStyle(const Value: TElementStyle);
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
destructor Destroy; override;
property Bitmap: TBitmap write SetBitmap;
property Rect: TRectD read FRect write SetRect;
property Style: TElementStyle read FStyle write SetStyle;
end;
THeatmap = class(TPixmap)
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
end;
TVectorField = class(TDrawable)
strict private
type
TVectorFieldElement = record
Position: TPointD;
Vector: TVectorD;
constructor Create(const APosition: TPointD; const AVector: TVectorD);
end;
var
FArrow: ID2D1PathGeometry;
FVectors: TList<TVectorFieldElement>;
FMatrices: TList<TD2D1Matrix3x2F>;
FMaxMag: Double;
FUseMag: Boolean;
FStyle: TElementStyle;
FArrowScale: Double;
procedure SetUseMag(const Value: Boolean);
procedure CreateArrow;
procedure CreateMatrices;
procedure SetStyle(const Value: TElementStyle);
procedure SetArrowScale(const Value: Double);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
procedure BeginAddVector; inline;
procedure AddVector(const APosition: TPointD; const AVector: TVectorD);
procedure EndAddVector; inline;
procedure Clear;
property UseMagnitude: Boolean read FUseMag write SetUseMag default True;
property Style: TElementStyle read FStyle write SetStyle;
property ArrowScale: Double read FArrowScale write SetArrowScale;
end;
TGeometry = class(TDrawable)
strict private
FStyle: TElementStyle;
procedure SetStyle(const Value: TElementStyle);
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Style: TElementStyle read FStyle write SetStyle;
end;
TLine = class;
TLineEndMarkerDrawable = class(TDrawable)
strict private
FLineEndMarker: TLineEndMarker;
FFilled: Boolean;
FPoint: TPointD;
FAngle: Double;
FSizeX, FSizeY: Double;
FWidth: Integer;
FColor: TColor;
FLineColor: Boolean;
FLine: TLine;
procedure SetLineEndMarker(const Value: TLineEndMarker);
procedure SetFilled(const Value: Boolean);
procedure SetPoint(const Value: TPointD);
procedure SetAngle(const Value: Double);
procedure SetSizeX(const Value: Double);
procedure SetSizeY(const Value: Double);
procedure SetSize(const Value: Double);
procedure SetColor(const Value: TColor);
procedure SetLineColor(const Value: Boolean);
procedure SetWidth(const Value: Integer);
procedure AdaptToLine;
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
function LineDelta: Double;
function GetSVGID(ASVG: TSVGBuilder_VisCtl2D): string;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
property Line: TLine read FLine write FLine;
procedure Assign(Source: TPersistent); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Kind: TLineEndMarker read FLineEndMarker write SetLineEndMarker;
property Filled: Boolean read FFilled write SetFilled;
property Point: TPointD read FPoint write SetPoint;
property Angle: Double read FAngle write SetAngle;
property SizeX: Double read FSizeX write SetSizeX;
property SizeY: Double read FSizeY write SetSizeY;
property Size: Double read FSizeX write SetSize;
property Width: Integer read FWidth write SetWidth;
property Color: TColor read FColor write SetColor;
property LineColor: Boolean read FLineColor write SetLineColor;
end;
TLine = class(TGeometry)
strict private
FStart, FEnd: TPointD;
procedure SetEnd(const Value: TPointD);
procedure SetStart(const Value: TPointD);
procedure SetEndMarker(const Value: TLineEndMarkerDrawable);
procedure SetStartMarker(const Value: TLineEndMarkerDrawable);
procedure AdjustLineToMarkers(out AStart, AEnd: TPointD);
private
FStartMarker, FEndMarker: TLineEndMarkerDrawable;
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
function CreateReference: TAlgosimReference; override;
property Start: TPointD read FStart write SetStart;
property &End: TPointD read FEnd write SetEnd;
property StartMarker: TLineEndMarkerDrawable read FStartMarker write SetStartMarker;
property EndMarker: TLineEndMarkerDrawable read FEndMarker write SetEndMarker;
function DX: Double; inline;
function DY: Double; inline;
end;
TRectangle = class(TGeometry)
strict private
FRect: TRectD;
FRotAngle: Double;
procedure SetRect(const Value: TRectD);
procedure SetRotAngle(const Value: Double);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Rect: TRectD read FRect write SetRect;
property Angle: Double read FRotAngle write SetRotAngle;
end;
TCircle = class(TGeometry)
strict private
FCenter: TPointD;
FRadius: Double;
procedure SetCenter(const Value: TPointD);
procedure SetRadius(const Value: Double);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Center: TPointD read FCenter write SetCenter;
property Radius: Double read FRadius write SetRadius;
end;
TPolygon = class(TGeometry)
strict private
FPoints: TArray<TPointD>;
procedure SetPoints(const Value: TArray<TPointD>);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
property Points: TArray<TPointD> read FPoints write SetPoints;
procedure Configure(ASettings: TAlgosimStructure); override;
end;
TText = class(TGeometry)
strict private
FText: string;
FFont: TFont;
FBoxed: Boolean;
FPosition: TPointD;
FWidth,
FHeight: Double;
FUseRect: Boolean;
FAnchorPoint: TAnchorPoint;
FZoomText: Boolean;
FZoomRect: Boolean;
FAlign: TAlignment;
FVertAlign: TVerticalAlignment;
FPadding: Integer;
procedure SetText(const Value: string);
procedure SetFont(const Value: TFont);
procedure SetBoxed(const Value: Boolean);
procedure SetPosition(const Value: TPointD);
procedure SetWidth(const Value: Double);
procedure SetHeight(const Value: Double);
procedure SetUseRect(const Value: Boolean);
procedure SetAnchorPoint(const Value: TAnchorPoint);
procedure SetZoomText(const Value: Boolean);
procedure SetZoomRect(const Value: Boolean);
procedure SetAlign(const Value: TAlignment);
procedure SetVertAlign(const Value: TVerticalAlignment);
procedure SetPadding(const Value: Integer);
function GetTextAnchorPoint: TAnchorPoint;
procedure SetTextAnchorPoint(const Value: TAnchorPoint);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
destructor Destroy; override;
procedure Configure(ASettings: TAlgosimStructure); override;
property Text: string read FText write SetText;
property Font: TFont read FFont write SetFont;
property Boxed: Boolean read FBoxed write SetBoxed;
property Position: TPointD read FPosition write SetPosition;
property Width: Double read FWidth write SetWidth;
property Height: Double read FHeight write SetHeight;
property UseRect: Boolean read FUseRect write SetUseRect;
property AnchorPoint: TAnchorPoint read FAnchorPoint write SetAnchorPoint;
property ZoomText: Boolean read FZoomText write SetZoomText;
property ZoomRect: Boolean read FZoomRect write SetZoomRect;
property Align: TAlignment read FAlign write SetAlign;
property VertAlign: TVerticalAlignment read FVertAlign write SetVertAlign;
property Padding: Integer read FPadding write SetPadding;
property TextAnchorPoint: TAnchorPoint read GetTextAnchorPoint write SetTextAnchorPoint;
end;
TSlice = record
t, a, b: Double;
constructor Create(const t, a, b: Double);
end;
TRegion = class(TXYPlot)
strict private
FAxis: TCartesianAxis;
FUnboundedMin, FUnboundedMax: Boolean;
FSliceData: TArray<TSlice>;
FValidateRegion: Boolean;
procedure SetAxis(const Value: TCartesianAxis);
procedure SetSliceData(const Value: TArray<TSlice>);
procedure SetUnboundedMax(const Value: Boolean);
procedure SetUnboundedMin(const Value: Boolean);
procedure SetValidateRegion(const Value: Boolean);
private
procedure Draw; override;
procedure DrawToContent(ASVG: TSVGBuilder_VisCtl2D); override;
public
constructor Create(ACtl: TVisCtl2D; AView: TView2D); override;
property Axis: TCartesianAxis read FAxis write SetAxis;
property UnboundedMin: Boolean read FUnboundedMin write SetUnboundedMin;
property UnboundedMax: Boolean read FUnboundedMax write SetUnboundedMax;
property SliceData: TArray<TSlice> read FSliceData write SetSliceData;
property ValidateRegion: Boolean read FValidateRegion write SetValidateRegion;
end;
TSVGBuilder_VisCtl2D = class(TSVGBuilder)
private type
TMarkerDef = packed record
const
SizeUnit = 0.0001;
var
Shape: TLineEndMarker;
Filled: TVisCtl2D.TFilledBool;
Start: Boolean;
Width, Height: Integer ;
LineWidth: Integer;
Color: TColor;
function GetName: string;
end;
TMarkerData = record
Name: string;
Marker: TTag;
end;
TMarkerDict = TDictionary<TMarkerDef, TMarkerData>;
var
FMarkerDict: TMarkerDict;
function GetMarkerName(ACtl: TVisCtl2D; const AMarkerDef: TMarkerDef;
const ALineDelta: Double): string;
public
constructor Create(AAbstract: Boolean = False); override;
destructor Destroy; override;
end;
procedure Register;
implementation
uses
Clipbrd, Math, StrUtils, Character, DateUtils, GenHelpers, AScolors,
Vis2D_ViewSettings, Vis2D_AxisSettings, Vis2D_GridSettings,
Vis2D_GridFamiliesSettings, Vis2D_ElementSettings, Vis2D_CategorySettings,
Vis2D_CategoryChartSettings, Vis2D_PieChartSettings, Vis2D_BarChartSettings,
Vis2D_HistogramSettings, Vis2D_XYPlotSettings, Vis2D_VectorFieldSettings,
Vis2D_AxesSettings, Vis2D_TextSettings, Vis2D_LineSettings,
Vis2D_LineEndSettings, VisCtlOptions, Vis2D_ObjMgr, ComObj, ActiveX, DxgiFormat,
Winapi.Wincodec, IOUtils, NetEncoding, ShlObj;
procedure Register;
begin
RegisterComponents('Rejbrand 2020', [TVisCtl2D]);
end;
const
LEM_CONST = 19.0 / 4;
function ASOToR2Array(Obj: TAlgosimObject): TArray<TPointD>;
procedure Inv;
begin
raise Exception.Create('Invalid 2D point list.');
end;
var
L: TList<TPointD>;
i: Integer;
begin
L := TList<TPointD>.Create;
try
if Obj is TAlgosimArray then
begin
for i := 1 to Obj.ElementCount do
if Obj.Elements[i].ValueCount = 2 then
begin
var v := Obj.Elements[i].AsRealVector;
if v.Dimension = 2 then
L.Add(TPointD.Create(v[0], v[1]))
else
Inv;
end
else
Inv;
end
else if Obj is TAlgosimMatrix then
begin
var M := Obj.AsRealMatrix;
if M.Size.Cols <> 2 then
Inv;
for i := 0 to M.Size.Rows - 1 do
L.Add(TPointD.Create(M[i, 0], M[i, 1]));
end
else
Inv;
Result := L.ToArray;
finally
L.Free;
end;
end;
function AlignmentFromString(const S: string): TAlignment;
type
T = TAlignment;
const
Names: array[T] of string
= ('left', 'right', 'center');
var
Idx: Integer;
begin
Idx := IndexStr(S, Names);
if InRange(Idx, Ord(Low(T)), Ord(High(T))) then
Result := T(Idx)
else
raise Exception.CreateFmt('Invalid alignment: "%s".', [S]);
end;
function VerticalAlignmentFromString(const S: string): TVerticalAlignment;
type
T = TVerticalAlignment;
const
Names: array[T] of string
= ('top', 'bottom', 'center');
var
Idx: Integer;
begin
Idx := IndexStr(S, Names);
if InRange(Idx, Ord(Low(T)), Ord(High(T))) then
Result := T(Idx)
else
raise Exception.CreateFmt('Invalid alignment: "%s".', [S]);
end;
class function TAnchorPointHelper.FromString(const S: string): TAnchorPoint;
begin
for var ap := Low(TAnchorPoint) to High(TAnchorPoint) do
if ap.ToString = S then
Exit(ap);
raise Exception.Create('Invalid anchor point.');
end;
function TAnchorPointHelper.H: TLinearAlignment;
begin
case Self of
apTopLeft,
apLeft,
apBottomLeft:
Result := laNegative;
apTop,
apCenter,
apBottom:
Result := laMiddle;
apTopRight,
apRight,
apBottomRight:
Result := laPositive;
else
raise Exception.Create('Invalid anchor point.');
end;
end;
function TAnchorPointHelper.ToString: string;
begin
if InRange(Ord(Self), Ord(Low(TAnchorPoint)), Ord(High(TAnchorPoint))) then
Result := PointNames[Self]
else
Result := '';
end;
function TAnchorPointHelper.V: TLinearAlignment;
begin
case Self of
apTopLeft,
apTop,
apTopRight:
Result := laNegative;
apLeft,
apCenter,
apRight:
Result := laMiddle;
apBottomLeft,
apBottom,
apBottomRight:
Result := laPositive;
else
raise Exception.Create('Invalid anchor point.');
end;
end;
procedure AlignRect(var ARect: TRect; AAnchorPoint: TAnchorPoint);
begin
ARect.Offset(
-Ord(AAnchorPoint.H) * ARect.Width div 2,
-Ord(AAnchorPoint.V) * ARect.Height div 2
);
end;
procedure AlignRect(var ARect: TRectD; AAnchorPoint: TAnchorPoint);
begin
ARect.Offset(
-Ord(AAnchorPoint.H) * ARect.Width / 2,
-Ord(AAnchorPoint.V) * ARect.Height / 2
);
end;
const
D2d1Origin: TD2DPoint2f = (x: 0.0; y: 0.0);
function rmod2(const x, y: TASR): TASR; inline;
begin
Result := x - TASI(Trunc(x / y)) * y;
end;
procedure TVisCtl2D.AddMenuItem(AMenuItem: TMenuItem);
begin
if FCustomMenuItems = nil then
Exit;
if AMenuItem = nil then
Exit;
FCustomMenuItems.Add(AMenuItem);
end;
procedure TVisCtl2D.AddMenuItems(AMenu: TMenuItem);
var
i: Integer;
begin
if FCustomMenuItems = nil then
Exit;
if AMenu = nil then
Exit;
for i := 0 to AMenu.Count - 1 do
AddMenuItem(AMenu[i]);
end;
procedure TVisCtl2D.AddObject(AObject: TDrawable);
begin
if Assigned(FObjs) and Assigned(FObjs.List) and Assigned(AObject) then
begin
FObjs.List.Add(AObject);
AObject.OnChange := ObjChanged;
end;
end;
function TVisCtl2D.AsSVG(const ASVGExportOptions: TSVGExportOptions): string;
var
SVG: TSVGBuilder_VisCtl2D;
begin
ASVGExportOptions.Validate;
if ((ClientWidth = 0) or (ClientHeight = 0)) and ASVGExportOptions.AutomaticAspectRatio then
raise ESVGException.Create('Client area has no aspect ratio.');
SVG := TSVGBuilder_VisCtl2D.Create;
try
SVG.DefineNamespace('asd', 'http://www.rejbrand.org/2021/algosim-diagram');
if ASVGExportOptions.SpecificSize then
begin
SVG.Width := ASVGExportOptions.Width.ToString(InvFS) + ASVGExportOptions.LengthUnit;
SVG.Height := ASVGExportOptions.Height.ToString(InvFS) + ASVGExportOptions.LengthUnit;
SVG.Stretch := ASVGExportOptions.Stretch;
end
else if ASVGExportOptions.AutomaticSize then
begin
SVG.Width := ClientWidth.ToString + 'px';
SVG.Height := ClientHeight.ToString + 'px';
end
else if ASVGExportOptions.AutomaticWidth then
begin
SVG.Height := ASVGExportOptions.Height.ToString(InvFS) + ASVGExportOptions.LengthUnit;
SVG.Width := (ClientWidth / ClientHeight * ASVGExportOptions.Height).ToString(InvFS) + ASVGExportOptions.LengthUnit;
end
else if ASVGExportOptions.AutomaticHeight then
begin
SVG.Width := ASVGExportOptions.Width.ToString(InvFS) + ASVGExportOptions.LengthUnit;
SVG.Height := (ClientHeight / ClientWidth * ASVGExportOptions.Width).ToString(InvFS) + ASVGExportOptions.LengthUnit;
end
else
raise ESVGException.Create('SVG dimension error.');
SVG.Title := ASVGExportOptions.Title;
SVG.Description := ASVGExportOptions.Description;
SVG.ViewBox := TViewBox.Create(0.0, 0.0, ClientWidth, ClientHeight);
SVG.Style(
CSS.RuleSet('polyline', ['fill: none'])
.RuleSet('polygon', ['fill-rule: evenodd'])
.RuleSet('.X-axis .axis-labels text.neg', ['transform: translate(-0.5ch)'])
).Append;
SVG.Tag('asd:view')
.Attrib('asd:xmin', FView.XMin)
.Attrib('asd:xmax', FView.XMax)
.Attrib('asd:ymin', FView.YMin)
.Attrib('asd:ymax', FView.YMax)
.Append;
FObjs.DrawTo(SVG, True);
GridLines.DrawTo(SVG);
Axes.DrawTo(SVG);
FObjs.DrawTo(SVG, False);
Result := SVG.AsXML;
finally
SVG.Free;
end;
end;
procedure TVisCtl2D.BeginBackgroundPaint;
begin
Inc(FBackgroundPaintLevel);
end;
procedure TVisCtl2D.CreateDeviceResources;
begin
FreeDeviceResources;
FCanvas := TDirect2DCanvas.Create(Handle);
FCanvas.RenderTarget.CreateSolidColorBrush(D2D1ColorF(clHighlight, 0.5), nil, FZoomRectBrush);
end;
procedure TVisCtl2D.CreateLineEndMarkers;
var
Sink: ID2D1GeometrySink;
type
TGeometryDescription = record
PointCount: Integer;
BeginMode: TD2D1FigureBegin;
EndMode: TD2D1_FigureEnd;
Points: array[0..7] of TD2D1Point2F;
end;
const
{$J+}
MarkersScaled: Boolean = False;
pts: array[TLineEndMarker] of TGeometryDescription =
(
(
PointCount: 0
),
(
PointCount: 3;
BeginMode: D2D1_FIGURE_BEGIN_HOLLOW;
EndMode: D2D1_FIGURE_END_OPEN;
Points:
(
(x: -0.75; y: -1),
(x: 0; y: 0),
(x: 0.75; y: -1),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 3;
BeginMode: D2D1_FIGURE_BEGIN_FILLED;
EndMode: D2D1_FIGURE_END_CLOSED;
Points:
(
(x: -Sqrt2/2; y: -Sqrt2),
(x: 0; y: 0),
(x: Sqrt2/2; y: -Sqrt2),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 4;
BeginMode: D2D1_FIGURE_BEGIN_FILLED;
EndMode: D2D1_FIGURE_END_CLOSED;
Points:
(
(x: -Sqrt2/2; y: -Sqrt2),
(x: 0; y: 0),
(x: Sqrt2/2; y: -Sqrt2),
(x: 0; y: -Sqrt2/2),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 0
),
(
PointCount: 4;
BeginMode: D2D1_FIGURE_BEGIN_FILLED;
EndMode: D2D1_FIGURE_END_CLOSED;
Points:
(
(x: -InvSqrt2; y: 0),
(x: 0; y: InvSqrt2),
(x: InvSqrt2; y: 0),
(x: 0; y: -InvSqrt2),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 4;
BeginMode: D2D1_FIGURE_BEGIN_FILLED;
EndMode: D2D1_FIGURE_END_CLOSED;
Points:
(
(x: -0.5; y: -0.5),
(x: -0.5; y: 0.5),
(x: 0.5; y: 0.5),
(x: 0.5; y: -0.5),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 2;
BeginMode: D2D1_FIGURE_BEGIN_HOLLOW;
EndMode: D2D1_FIGURE_END_OPEN;
Points:
(
(x: -0.5; y: 0),
(x: 0.5; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
),
(
PointCount: 5;
BeginMode: D2D1_FIGURE_BEGIN_HOLLOW;
EndMode: D2D1_FIGURE_END_OPEN;
Points:
(
(x: 0; y: 0),
(x: -0.5; y: 0.25),
(x: 0.5; y: 0.5),
(x: 0; y: 0.75),
(x: 0; y: 1.25),
(x: 0; y: 0),
(x: 0; y: 0),
(x: 0; y: 0)
)
)
);
{$J-}
var
t: TLineEndMarker;
i: Integer;
const
F = LEM_CONST;
function GetPoints(ALEM: TLineEndMarker; AStart: Boolean = False): TArray<TPointD>;
begin
SetLength(Result, pts[ALEM].PointCount);
for var i := 0 to High(Result) do
begin
Result[i].X := +pts[ALEM].Points[i].y;
Result[i].Y := -pts[ALEM].Points[i].x;
if AStart then
Result[i].X := -Result[i].X;
end;
end;
begin
if not MarkersScaled then
begin
for t := Low(TLineEndMarker) to High(TLineEndMarker) do
for i := 0 to pts[t].PointCount - 1 do
begin
pts[t].Points[i].x := F * pts[t].Points[i].x;
pts[t].Points[i].y := F * pts[t].Points[i].y;
end;
MarkersScaled := True;
end;
for t := Low(TLineEndMarker) to High(TLineEndMarker) do
begin
FLineEndMarkers[t] := nil;
Sink := nil;
if pts[t].PointCount = 0 then
Continue;
if Succeeded(D2DFactory.CreatePathGeometry(FLineEndMarkers[t])) then
begin
if Succeeded(FLineEndMarkers[t].Open(Sink)) then
begin
try
Sink.BeginFigure(pts[t].Points[0], pts[t].BeginMode);
try
Sink.AddLines(@pts[t].Points[1], pts[t].PointCount - 1);
finally
Sink.EndFigure(pts[t].EndMode);
end;
finally
Sink.Close;
end;
end;
end;
end;
FLineEndMarkers[lemDisk] := nil;
Sink := nil;
if Succeeded(D2DFactory.CreatePathGeometry(FLineEndMarkers[lemDisk])) then
begin
if Succeeded(FLineEndMarkers[lemDisk].Open(Sink)) then
begin
try
Sink.BeginFigure(D2D1PointF(-0.5*F, 0), D2D1_FIGURE_BEGIN_FILLED);
try
Sink.AddArc(
D2D1ArcSegment(
D2D1PointF(0.5*F, 0),
D2D1SizeF(0.5*F, 0.5*F),
0.0,
D2D1_SWEEP_DIRECTION_CLOCKWISE,
D2D1_ARC_SIZE_SMALL
)
);
Sink.AddArc(
D2D1ArcSegment(
D2D1PointF(-0.5*F, 0),
D2D1SizeF(0.5*F, 0.5*F),
0.0,
D2D1_SWEEP_DIRECTION_CLOCKWISE,
D2D1_ARC_SIZE_SMALL
)
);
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
end;
end;
var SVGBuilder := TSVGBuilder_VisCtl2D.Create(True);
try
for t := Low(TLineEndMarker) to High(TLineEndMarker) do
if pts[t].PointCount > 0 then
for var Filled := Low(TFilledBool) to High(TFilledBool) do
for var Start := Low(TStartBool) to High(TStartBool) do
if (pts[t].BeginMode = D2D1_FIGURE_BEGIN_FILLED) and Filled then
FSVGMarkers[t, Filled, Start] := SVGBuilder.Polygon(GetPoints(t, Start)).Stroke('none')
else if pts[t].EndMode = D2D1_FIGURE_END_CLOSED then
FSVGMarkers[t, Filled, Start] := SVGBuilder.Polygon(GetPoints(t, Start)).Fill('none')
else
FSVGMarkers[t, Filled, Start] := SVGBuilder.PolyLine(GetPoints(t, Start));
for var Start := Low(TStartBool) to High(TStartBool) do
begin
FSVGMarkers[lemDisk, False, Start] := SVGBuilder.Circle(0.5*F).Fill('none');
FSVGMarkers[lemDisk, True, Start] := SVGBuilder.Circle(0.5*F).Stroke('none');
end;
finally
SVGBuilder.Free;
end;
end;
procedure TVisCtl2D.FreeDeviceResources;
var
Obj: TDrawable;
begin
if Assigned(FObjs) and Assigned(FObjs.List) then
for Obj in FObjs.List do
Obj.FreeDeviceResources;
FZoomRectBrush := nil;
FreeAndNil(FCanvas);
end;
function TVisCtl2D.GetObject(Index: Integer): TDrawable;
begin
if FObjs = nil then
Result := nil
else
Result := FObjs[Index];
end;
function TVisCtl2D.GetObjectCount: Integer;
begin
if FObjs = nil then
Result := 0
else
Result := FObjs.ItemCount;
end;
procedure TVisCtl2D.InvalidationTimerTimer(Sender: TObject);
begin
FInvalidationTimer.Enabled := False;
Invalidate;
end;
function TVisCtl2D.CanvasRect: TRect;
begin
Result.Left := 0;
Result.Top := 0;
Result.Right := Width * 96 div Screen.PixelsPerInch;
Result.Bottom := Height * 96 div Screen.PixelsPerInch;
end;
function TVisCtl2D.CanvasToSpace(const ACanvasCoords: TPointD): TPointD;
var
CR: TRect;
begin
CR := CanvasRect;
if (CR.Right = 0) or (CR.Bottom = 0) then
Result := TPoint.Zero
else
begin
Result.X := xmin + xspan * (ACanvasCoords.x - 0) / CR.Right;
Result.Y := ymin + yspan * (CR.Bottom - ACanvasCoords.y) / CR.Bottom;
end;
end;
procedure TVisCtl2D.ClearDiagram;
begin
if Assigned(FObjs) and Assigned(FObjs.List) then
FObjs.List.Clear;
end;
procedure TVisCtl2D.CopyToClipboard;
begin
var bm := TBitmap.Create(ClientWidth, ClientHeight);
try
var hdc := GetDC(Handle);
try
BitBlt(bm.Canvas.Handle, 0, 0, bm.Width, bm.Height, hdc, 0, 0, SRCCOPY);
finally
ReleaseDC(Handle, hdc);
end;
Clipboard.Assign(bm);
finally
bm.Free;
end;
end;
function SizeWidth(const S: TSize): Integer;
begin
Result := S.Width;
end;
function SizeHeight(const S: TSize): Integer;
begin
Result := S.Height;
end;
constructor TVisCtl2D.Create(AOwner: TComponent);
begin
inherited;
FInvalidationTimer := TTimer.Create(Self);
FInvalidationTimer.Interval := 50;
FInvalidationTimer.OnTimer := InvalidationTimerTimer;
FPrevMousePos := Point(-1, -1);
FInvFS := TFormatSettings.Invariant;
FView := TView2D.Create(Self);
FView.OnChange := ViewChanged;
FAxes := TAxes.Create(Self, FView);
FAxes.OnChange := ObjChanged;
ViewChanged(Self);
FGridLines := TGridLineFamilies.Create(Self, FView);
FGridLines.OnChange := ObjChanged;
FDiagram := TDiagram.Create(Self, FView);
FObjs := TDrawableList.Create(Self, FView);
FObjs.OnChange := ObjChanged;
TabStop := True;
CreateLineEndMarkers;
FCustomMenuItems := TList<TMenuItem>.Create;
CreateContextMenu;
end;
procedure TVisCtl2D.CreateContextMenu;
var
mi, smi: TMenuItem;
begin
FreeAndNil(FMenu);
FMenu := TPopupMenu.Create(Self);
FMenu.OnPopup := MenuPopup;
mi := TMenuItem.Create(FMenu);
mi.Caption := 'Centre at origin';
mi.Hint := 'Centres the view at (0, 0).';
mi.Tag := CMD_CENTERATORIGIN;
mi.OnClick := MenuCommand;
FMenu.Items.Add(mi);
mi := TMenuItem.Create(FMenu);
mi.Caption := 'Normalize';
mi.Hint := 'Adjusts the view so that 1 unit step in the horizontal and vertical directions have the same on-screen size.';
FMenu.Items.Add(mi);
smi := TMenuItem.Create(mi);
smi.Caption := 'Auto-normalize';
smi.Hint := 'Automatically normalizes the view when the window is resized.';
smi.Tag := CMD_TOGGLEAUTONORMALIZE;
smi.OnClick := MenuCommand;
FMnuAutoNormalize := smi;
mi.Add(smi);
mi.InsertNewLineAfter(smi);
smi := TMenuItem.Create(mi);
smi.Caption := 'Adjust horizontal';
smi.Hint := 'Adjusts the horizontal range.';
smi.Tag := CMD_NORMALIZEADJUSTHOR;
smi.OnClick := MenuCommand;
mi.Add(smi);
smi := TMenuItem.Create(mi);
smi.Caption := 'Adjust vertical';
smi.Hint := 'Adjusts the vertical range.';
smi.Tag := CMD_NORMALIZEADJUSTVERT;
smi.OnClick := MenuCommand;
mi.Add(smi);
FMenu.Items.InsertNewLineAfter(mi);
mi := TMenuItem.Create(FMenu);
mi.Caption := 'Settings';
mi.Hint := 'Displays the Visualisation Settings dialog box.';
mi.Tag := CMD_SETTINGS;
mi.OnClick := MenuCommand;
FMenu.Items.Add(mi);
FMenu.Items.InsertNewLineAfter(mi);
mi := TMenuItem.Create(FMenu);
mi.Caption := 'Save as SVG...'#9'Ctrl+S';
mi.Hint := 'Saves the current view as a Scalable Vector Graphics (SVG) file.';
mi.Tag := CMD_SAVESVG;
mi.OnClick := MenuCommand;
FMenu.Items.Add(mi);
mi := TMenuItem.Create(FMenu);
mi.Caption := 'Copy as bitmap'#9'Ctrl+C';
mi.Hint := 'Copies the current view to clipboard as a bitmap.';
mi.Tag := CMD_COPYBMP;
mi.OnClick := MenuCommand;
FMenu.Items.Add(mi);
end;
procedure TVisCtl2D.CreateWnd;
begin
inherited;
CreateDeviceResources;
end;
procedure TVisCtl2D.CustomizeMenu(AMenu: TMenu);
var
i: Integer;
begin
if FCustomMenuItems = nil then
Exit;
if AMenu = nil then
Exit;
for i := 0 to FCustomMenuItems.Count - 1 do
begin
if Assigned(FCustomMenuItems[i].Parent) then
FCustomMenuItems[i].Parent.Remove(FCustomMenuItems[i]);
AMenu.Items.Add(FCustomMenuItems[i]);
end;
end;
procedure TVisCtl2D.DblClick;
begin
inherited;
View.AnimateTo(CanvasToSpace(PixelsToDips(ScreenToClient(Mouse.CursorPos))), True);
end;
destructor TVisCtl2D.Destroy;
begin
if Assigned(FMenu) then
FMenu.CloseMenu;
FreeAndNil(FCanvas);
FreeAndNil(FCustomMenuItems);
FreeAndNil(FObjs);
FreeAndNil(FDiagram);
FreeAndNil(FGridLines);
FreeAndNil(FAxes);
FreeAndNil(FView);
inherited;
end;
function TVisCtl2D.DipsToPixels(const ARect: TRectD): TRect;
begin
Result.TopLeft := DipsToPixels(ARect.TopLeft);
Result.BottomRight := DipsToPixels(ARect.BottomRight);
end;
function TVisCtl2D.DipsToPixels(const APoint: TPointD): TPoint;
begin
Result.X := Round(APoint.X * Screen.PixelsPerInch / 96);
Result.Y := Round(APoint.Y * Screen.PixelsPerInch / 96);
end;
function TVisCtl2D.DoMouseWheelDown(Shift: TShiftState;
MousePos: TPoint): Boolean;
begin
ZoomOut;
Result := True;
end;
function TVisCtl2D.DoMouseWheelUp(Shift: TShiftState;
MousePos: TPoint): Boolean;
begin
ZoomIn;
Result := True;
end;
procedure TVisCtl2D.DrawZoomRect;
var
R: TRect;
begin
if not FZoomRect then
Exit;
R.TopLeft := Point(Min(FZoomCorner.X, FZoomCorner2.X), Min(FZoomCorner.Y, FZoomCorner2.Y));
R.BottomRight := Point(Max(FZoomCorner.X, FZoomCorner2.X), Max(FZoomCorner.Y, FZoomCorner2.Y));
Canvas.RenderTarget.FillRectangle(PixelsToDips(R), FZoomRectBrush);
end;
procedure TVisCtl2D.EndBackgroundPaint;
begin
Dec(FBackgroundPaintLevel);
end;
procedure TVisCtl2D.ExecCommand(ACommand: Integer);
begin
case ACommand of
CMD_SETTINGS:
Diagram.ShowOptionsForm;
CMD_CENTERATORIGIN:
View.AnimateTo(TPoint.Zero);
CMD_NORMALIZEADJUSTHOR:
View.Normalize(TCartesianAxis.X);
CMD_NORMALIZEADJUSTVERT:
View.Normalize(TCartesianAxis.Y);
CMD_TOGGLEAUTONORMALIZE:
AutoNormalize := not AutoNormalize;
CMD_SAVESVG:
SaveAsSVG;
CMD_COPYBMP:
CopyToClipboard;
end;
end;
procedure TVisCtl2D.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
var Numerator := IfThen(ssCtrl in Shift, 1, 10);
var Denominator := IfThen(ssCtrl in Shift, 200, 10);
if ssShift in Shift then
case Key of
VK_RIGHT:
ZoomX(-Numerator);
VK_LEFT:
ZoomX(Numerator);
VK_DOWN:
ZoomY(Numerator);
VK_UP:
ZoomY(-Numerator);
end
else
case Key of
VK_RIGHT:
Translate(xspan / Denominator, 0);
VK_LEFT:
Translate(-xspan / Denominator, 0);
VK_DOWN:
Translate(0, -yspan / Denominator);
VK_UP:
Translate(0, yspan / Denominator);
VK_ESCAPE:
if FZoomRect then
begin
FZoomRect := False;
Invalidate;
end;
end;
end;
procedure TVisCtl2D.KeyPress(var Key: Char);
begin
inherited;
case Key of
^C:
CopyToClipboard;
^S:
SaveAsSVG;
end;
end;
procedure TVisCtl2D.LowPriorityInvalidate;
begin
if FBackgroundPaintLevel <= 0 then
Invalidate
else
FInvalidationTimer.Enabled := True;
end;
procedure TVisCtl2D.MenuCommand(Sender: TObject);
begin
if not (Sender is TMenuItem) then
Exit;
ExecCommand(TMenuitem(Sender).Tag);
end;
procedure TVisCtl2D.MenuPopup(Sender: TObject);
begin
if Assigned(FMnuAutoNormalize) then
FMnuAutoNormalize.Checked := AutoNormalize;
if Assigned(FOnBeforeContextPopup) then
FOnBeforeContextPopup(Self);
end;
procedure TVisCtl2D.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if CanFocus then
SetFocus;
if Button = mbLeft then
FPrevMousePos := Point(X, Y);
if (Button = mbLeft) and (ssCtrl in Shift) or (Button = mbMiddle) then
begin
FZoomRect := True;
FZoomCorner := Point(X, Y);
FZoomCorner2 := FZoomCorner;
end;
end;
procedure TVisCtl2D.MouseMove(Shift: TShiftState; X, Y: Integer);
var
CR: TRect;
begin
inherited;
if (csLButtonDown in ControlState) and (FPrevMousePos.Y <> -1) then
begin
if FZoomRect then
begin
FZoomCorner2 := Point(X, Y);
Invalidate;
end
else
begin
CR := ClientRect;
if not CR.IsEmpty then
Translate(
-(X - FPrevMousePos.X) * xspan / CR.Width,
+(Y - FPrevMousePos.Y) * yspan / CR.Height
);
FPrevMousePos := Point(X, Y);
end;
end
else if (GetKeyState(VK_MBUTTON) < 0) and FZoomRect then
begin
FZoomCorner2 := Point(X, Y);
Invalidate;
end;
end;
procedure TVisCtl2D.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if FZoomRect then
begin
FZoomRect := False;
Invalidate;
View.AnimateTo(
CanvasToSpace(PixelsToDips(FZoomCorner)),
CanvasToSpace(PixelsToDips(FZoomCorner2))
);
end;
FPrevMousePos := Point(-1, -1);
end;
procedure TVisCtl2D.ObjChanged(Sender: TObject);
begin
LowPriorityInvalidate;
end;
class function TVisCtl2D.P(const X, Y: Double): TPointD;
begin
Result.X := X;
Result.Y := Y;
end;
procedure TVisCtl2D.Paint;
begin
inherited;
Canvas.RenderTarget.Clear(D2D1ColorF(Color));
FObjs.Draw(True);
GridLines.Draw;
Axes.Draw;
FObjs.Draw(False);
DrawZoomRect;
end;
function TVisCtl2D.PixelsToDips(const ARect: TRect): TRectD;
begin
Result.TopLeft := PixelsToDips(ARect.TopLeft);
Result.BottomRight := PixelsToDips(ARect.BottomRight);
end;
class function TVisCtl2D.Q(const X, Y: Double): TPointD;
begin
Result.X := Y;
Result.Y := X;
end;
procedure TVisCtl2D.RemoveMenuItem(AMenuItem: TMenuItem);
begin
if FCustomMenuItems = nil then
Exit;
if AMenuItem = nil then
Exit;
FCustomMenuItems.Remove(AMenuItem);
end;
procedure TVisCtl2D.RemoveObject(AObject: TDrawable);
begin
if Assigned(FObjs) and Assigned(FObjs.List) then
FObjs.List.Remove(AObject);
end;
function TVisCtl2D.PixelsToDips(const APoint: TPoint): TPointD;
begin
Result.X := APoint.X / Screen.PixelsPerInch * 96;
Result.Y := APoint.Y / Screen.PixelsPerInch * 96;
end;
procedure TVisCtl2D.SetAutoNormalize(const Value: Boolean);
begin
if FAutoNormalize <> Value then
begin
FAutoNormalize := Value;
if FAutoNormalize then
ExecCommand(CMD_NORMALIZE);
end;
end;
procedure TVisCtl2D.SetAxes(const Value: TAxes);
begin
FAxes.Assign(Value);
end;
procedure TVisCtl2D.SetGridLines(const Value: TGridLineFamilies);
begin
FGridLines.Assign(Value);
end;
procedure TVisCtl2D.SetView(const Value: TView2D);
begin
FView.Assign(Value);
end;
function TVisCtl2D.SpaceToCanvas(const X, Y: Double; DX, DY: Integer): TPointD;
begin
Result := SpaceToCanvas(TPointD.Create(X, Y), DX, DY);
end;
function TVisCtl2D.SpaceToCanvas(const ASpaceCoords: TPointD; const DX,
DY: Double): TPointD;
var
CR: TRect;
begin
CR := CanvasRect;
if (xspan > 0) and (yspan > 0) then
begin
Result.x := CR.Width * (ASpaceCoords.X - xmin) / xspan + DX;
Result.y := CR.Height * (1 - (ASpaceCoords.Y - ymin) / yspan) + DY;
end
else
Result := TPoint.Zero;
end;
function TVisCtl2D.SpaceToCanvas(const ASpaceCoords: TRectD;
AFlipped: Boolean): TRectD;
begin
Result.TopLeft := SpaceToCanvas(ASpaceCoords.TopLeft);
Result.BottomRight := SpaceToCanvas(ASpaceCoords.BottomRight);
if AFlipped then
TSwapper<Double>.Swap(Result.Top, Result.Bottom);
end;
function TVisCtl2D.SpaceToViewbox(const AViewBox: TViewBox;
const ASpaceCoords: TPointD; DX, DY: Integer): TPointD;
begin
if AViewBox.Valid then
begin
Result.x := AViewBox.Xmin + AViewBox.Width * (ASpaceCoords.X - xmin) / xspan + DX;
Result.y := AViewBox.Ymin + AViewBox.Height * (1 - (ASpaceCoords.Y - ymin) / yspan) + DY;
end
else
Result := TPoint.Zero;
end;
function TVisCtl2D.SpaceToCanvas(const ASpaceCoords: TPointD;
DX: Integer = 0; DY: Integer = 0): TPointD;
var
CR: TRect;
begin
CR := CanvasRect;
if (xspan > 0) and (yspan > 0) then
begin
Result.x := CR.Width * (ASpaceCoords.X - xmin) / xspan + DX;
Result.y := CR.Height * (1 - (ASpaceCoords.Y - ymin) / yspan) + DY;
end
else
Result := TPoint.Zero;
end;
procedure TVisCtl2D.Translate(const DX, DY: Double);
begin
View.&Set(View.XMin + DX, View.XMax + DX, View.YMin + DY, View.YMax + DY);
end;
function TVisCtl2D.TrySpaceToD2d1(const ASpaceCoords: TPointD;
out AD2d1Point: TD2D1Point2F): Boolean;
var
tmp: TPointD;
begin
tmp := SpaceToCanvas(ASpaceCoords);
Result :=
InRange(tmp.X, Single.MinValue, Single.MaxValue)
and
InRange(tmp.Y, Single.MinValue, Single.MaxValue);
if Result then
AD2d1Point := tmp;
end;
function TVisCtl2D.UnboundIdentity(const APoint: TD2D1Point2F): TD2D1Point2F;
begin
Result := APoint;
end;
function TVisCtl2D.UnboundXMax(const APoint: TD2D1Point2F): TD2D1Point2F;
begin
Result := APoint;
Result.x := CanvasRect.Right;
end;
function TVisCtl2D.UnboundXMin(const APoint: TD2D1Point2F): TD2D1Point2F;
begin
Result := APoint;
Result.x := 0;
end;
function TVisCtl2D.UnboundYMax(const APoint: TD2D1Point2F): TD2D1Point2F;
begin
Result := APoint;
Result.y := 0;
end;
function TVisCtl2D.UnboundYMin(const APoint: TD2D1Point2F): TD2D1Point2F;
begin
Result := APoint;
Result.y := CanvasRect.Bottom;
end;
procedure TVisCtl2D.SaveAsSVG(const AFileName: string;
const ASVGExportOptions: TSVGExportOptions);
begin
TFile.WriteAllText(AFileName, AsSVG(ASVGExportOptions), TEncoding.UTF8);
end;
type
TSaveDialogSVGData = class
Title,
Description: string;
Width, Height: string;
DoStretch: Boolean;
constructor Create(const ATitle, ADescription, AWidth, AHeight: string;
ADoStretch: Boolean);
end;
constructor TSaveDialogSVGData.Create(const ATitle, ADescription,
AWidth, AHeight: string; ADoStretch: Boolean);
begin
Title := ATitle;
Description := ADescription;
Width := AWidth;
Height := AHeight;
DoStretch := ADoStretch;
end;
procedure TVisCtl2D.SaveAsSVG;
var
Dlg: TFileSaveDialog;
begin
Dlg := TFileSaveDialog.Create(Self);
try
Dlg.Title := 'Save as SVG';
with Dlg.FileTypes.Add do
begin
DisplayName := 'SVG images';
FileMask := '*.svg';
end;
Dlg.Options := [fdoOverWritePrompt, fdoPathMustExist];
Dlg.DefaultExtension := 'svg';
Dlg.OnExecute := SaveAsSVGFileDialogExecute;
Dlg.OnFileOkClick := SaveAsSVGFileDialogOKClick;
if Dlg.Execute then
begin
var LSVGOptions := DefaultSVGExportOptions;
if TObject(Dlg.Tag) is TSaveDialogSVGData then
with TSaveDialogSVGData(Dlg.Tag) do
try
LSVGOptions.Title := Title;
LSVGOptions.Description := Description;
LSVGOptions.SetDimensionsFromText(Width, Height);
LSVGOptions.Stretch := DoStretch;
finally
Free;
end;
SaveAsSVG(Dlg.FileName, LSVGOptions);
end;
finally
Dlg.Free;
end;
end;
procedure TVisCtl2D.SaveAsSVGFileDialogExecute(Sender: TObject);
var
FDC: IFileDialogCustomize;
begin
try
if
(Sender is TFileSaveDialog)
and
(TFileSaveDialog(Sender).Dialog.QueryInterface(IID_IFileDialogCustomize, FDC) = S_OK)
then
begin
FDC.StartVisualGroup(SVGFDCCTL_Title + 100, 'Title:');
FDC.AddEditBox(SVGFDCCTL_Title, '');
FDC.EndVisualGroup;
FDC.StartVisualGroup(SVGFDCCTL_Descr + 100, 'Description:');
FDC.AddEditBox(SVGFDCCTL_Descr, '');
FDC.EndVisualGroup;
FDC.AddSeparator(61);
FDC.StartVisualGroup(SVGFDCCTL_Width + 100, 'Width:');
FDC.AddEditBox(SVGFDCCTL_Width, PChar(Self.ClientWidth.ToString));
FDC.EndVisualGroup;
FDC.StartVisualGroup(SVGFDCCTL_Height + 100, 'Height:');
FDC.AddEditBox(SVGFDCCTL_Height, PChar(Self.ClientHeight.ToString));
FDC.EndVisualGroup;
FDC.AddCheckButton(SVGFDCCTL_Stretch, 'Allow stretching', False);
end;
except
end;
end;
procedure TVisCtl2D.SaveAsSVGFileDialogOKClick(Sender: TObject;
var CanClose: Boolean);
var
FDC: IFileDialogCustomize;
begin
try
if
(Sender is TFileSaveDialog)
and
(TFileSaveDialog(Sender).Dialog.QueryInterface(IID_IFileDialogCustomize, FDC) = S_OK)
then
begin
var buf: PWideChar;
var Title, Descr, Width, Height: string;
if Succeeded(FDC.GetEditBoxText(SVGFDCCTL_Title, buf)) then
try
Title := buf;
finally
CoTaskMemFree(buf);
end;
if Succeeded(FDC.GetEditBoxText(SVGFDCCTL_Descr, buf)) then
try
Descr := buf;
finally
CoTaskMemFree(buf);
end;
if Succeeded(FDC.GetEditBoxText(SVGFDCCTL_Width, buf)) then
try
Width := buf;
finally
CoTaskMemFree(buf);
end;
if Succeeded(FDC.GetEditBoxText(SVGFDCCTL_Height, buf)) then
try
Height := buf;
finally
CoTaskMemFree(buf);
end;
var DoStretch: LongBool := False;
FDC.GetCheckButtonState(SVGFDCCTL_Stretch, DoStretch);
begin
var opt := DefaultSVGExportOptions;
try
opt.SetDimensionsFromText(Width, Height);
except
on E: Exception do
begin
MessageBox(
TFileSaveDialog(Sender).Handle,
PChar(E.Message),
PChar(TFileSaveDialog(Sender).Title),
MB_ICONERROR
);
CanClose := False;
Exit;
end;
end;
end;
if CanClose then
TFileSaveDialog(Sender).Tag :=
NativeInt(TSaveDialogSVGData.Create(Title, Descr, Width, Height, DoStretch));
end;
except
end;
end;
function TVisCtl2D.Scr(const X, Y: Double): TPointD;
begin
Result := SpaceToCanvas(P(X, Y));
end;
procedure TVisCtl2D.ViewChanged(Sender: TObject);
begin
xmin := FView.XMin;
xmax := FView.XMax;
ymin := FView.YMin;
ymax := FView.YMax;
LowPriorityInvalidate;
end;
procedure TVisCtl2D.WMContextMenu(var Message: TWMContextMenu);
var
P: TPoint;
begin
if Assigned(FMenu) then
begin
if Message.Pos = Point(-1, -1) then
P := ClientToScreen(BoundsRect.CenterPoint)
else
P := Message.Pos;
CustomizeMenu(FMenu);
FMenu.Popup(P.X, P.Y);
end
else
inherited;
end;
procedure TVisCtl2D.WMDisplayChange(var Message: TWMDisplayChange);
begin
Message.Result := 0;
Invalidate;
end;
procedure TVisCtl2D.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TVisCtl2D.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TVisCtl2D.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
res: HRESULT;
begin
BeginPaint(Handle, PaintStruct);
try
if Assigned(FCanvas) then
begin
FCanvas.BeginDraw;
try
Paint;
finally
res := FCanvas.RenderTarget.EndDraw;
if res = D2DERR_RECREATE_TARGET then
begin
FreeDeviceResources;
CreateDeviceResources;
var S := D2D1SizeU(ClientWidth, ClientHeight);
ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
Invalidate;
end;
end;
end;
finally
EndPaint(Handle, PaintStruct);
end;
end;
procedure TVisCtl2D.WMSize(var Message: TWMSize);
var
S: TD2DSizeU;
begin
if Assigned(FCanvas) then
begin
S := D2D1SizeU(ClientWidth, ClientHeight);
ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
end;
Invalidate;
if FAutoNormalize then
ExecCommand(CMD_NORMALIZE);
inherited;
end;
function TVisCtl2D.xspan: Double;
begin
Result := xmax - xmin;
end;
function TVisCtl2D.yspan: Double;
begin
Result := ymax - ymin;
end;
procedure TVisCtl2D.Zoom(const Factor: Double);
var
CP: TPointD;
fxsd2, fysd2: Double;
function XChOK: Boolean;
begin
Result := ((fxsd2 > 1E-12) or (Factor > 1)) and ((fxsd2 < 1E+37) or (Factor < 1));
end;
function YChOK: Boolean;
begin
Result := ((fysd2 > 1E-12) or (Factor > 1)) and ((fysd2 < 1E+37) or (Factor < 1));
end;
begin
CP := View.CenterPoint;
fxsd2 := Factor * xspan / 2;
fysd2 := Factor * yspan / 2;
if XChOK and YChOK then
View.&Set(
CP.X - fxsd2,
CP.X + fxsd2,
CP.Y - fysd2,
CP.Y + fysd2
);
end;
procedure TVisCtl2D.ZoomIn;
begin
Zoom(0.9);
end;
procedure TVisCtl2D.ZoomOut;
begin
Zoom(1.1);
end;
procedure TVisCtl2D.ZoomX(const A: Double);
begin
View.&Set(View.XMin - A * View.XSpan / 100, View.XMax + A * View.XSpan / 100,
View.YMin, View.YMax);
end;
procedure TVisCtl2D.ZoomY(const A: Double);
begin
View.&Set(View.XMin, View.XMax,
View.YMin - A * View.YSpan / 100, View.YMax + A * View.YSpan / 100);
end;
function TView2D.Scale(const P: TPointD): TPointD;
begin
Result.X := ScaleX(P.X);
Result.Y := -ScaleY(P.Y);
end;
function TView2D.ScaleX(const X: Double): Double;
begin
if XSpan <> 0 then
Result := X * FCtl.CanvasRect.Width / XSpan
else
Result := X;
end;
function TView2D.ScaleY(const Y: Double): Double;
begin
if YSpan <> 0 then
Result := Y * FCtl.CanvasRect.Height / YSpan
else
Result := Y;
end;
procedure TView2D.&Set(const AXFrom, AXTo, AYFrom, AYTo: Double;
APreferAxes: Boolean);
const
MinContentFraction = 0.5;
var
LXFrom, LXTo,
LYFrom, LYTo: Double;
begin
LXFrom := AXFrom;
LXTo := AXTo;
LYFrom := AYFrom;
LYTo := AYTo;
if APreferAxes then
begin
if (LXTo <= LXFrom) or (LYTo <= LYFrom) then
Exit;
if (LXTo > 0) and (LXFrom > -LXTo/15) and (15*(LXTo - LXFrom)/(16*LXTo) >= MinContentFraction) then
LXFrom := -LXTo/15;
if (LYTo > 0) and (LYFrom > -LYTo/15) and (15*(LYTo - LYFrom)/(16*LYTo) >= MinContentFraction) then
LYFrom := -LYTo/15;
if (LXFrom < 0) and (LXTo < -LXFrom/15) and (15*(LXTo - LXFrom)/(-16*LXTo) >= MinContentFraction) then
LXTo := -LXFrom/15;
if (LYFrom < 0) and (LYTo < -LYFrom/15) and (15*(LYTo - LYFrom)/(-16*LYTo) >= MinContentFraction) then
LYTo := -LYFrom/15;
end;
if
(FBounds[_xmin] <> LXFrom) or (FBounds[_xmax] <> LXTo) or
(FBounds[_ymin] <> LYFrom) or (FBounds[_ymax] <> LYTo)
then
if (LXTo - LXFrom > 1E-15) and (LYTo - LYFrom > 1E-15) then
begin
FBounds[_xmin] := LXFrom;
FBounds[_xmax] := LXTo;
FBounds[_ymin] := LYFrom;
FBounds[_ymax] := LYTo;
Changed;
end;
end;
procedure TView2D.AnimateTo(const ACenterPoint: TPointD; AMoveCursor: Boolean);
const
Gamma = 4.0;
var
i: Integer;
F, t: Double;
begin
F := 1 / ArcTan(Gamma);
for i := 0 to High(FTranslationAnimation) do
begin
t := i / High(FTranslationAnimation);
t := 2 * t - 1;
t := F * ArcTan(Gamma * t);
t := (t + 1) / 2;
FTranslationAnimation[i] := (1 - t) * CenterPoint + t * ACenterPoint;
end;
FTranslationAnimationBegin := Now;
FTranslationAnimationEnd := IncMilliSecond(FTranslationAnimationBegin,
Round(1000 * TranslationAnimationDurationSec));
FTranslationTimer.Interval := 50;
FTranslationTimer.Tag := Ord(AMoveCursor);
FTranslationTimer.Enabled := True;
end;
procedure TView2D.AnimateTo(const ACorner1, ACorner2: TPointD);
const
Gamma = 4.0;
var
LTopLeft, LBottomRight: TPointD;
R: TRectD;
i: Integer;
F, t: Double;
begin
if ACorner1 = ACorner2 then
Exit;
LTopLeft := TPointD.Create(Min(ACorner1.X, ACorner2.X), Min(ACorner1.Y, ACorner2.Y));
LBottomRight := TPointD.Create(Max(ACorner1.X, ACorner2.X), Max(ACorner1.Y, ACorner2.Y));
R.TopLeft := LTopLeft;
R.BottomRight := LBottomRight;
if (R.Width < 1E-38) or (R.Height < 1E-38) then
Exit;
F := 1 / ArcTan(Gamma);
for i := 0 to High(FZoomTranslationAnimation) do
begin
t := i / High(FZoomTranslationAnimation);
t := 2 * t - 1;
t := F * ArcTan(Gamma * t);
t := (t + 1) / 2;
FZoomTranslationAnimation[i].TopLeft := (1 - t) * TopLeft + t * LTopLeft;
FZoomTranslationAnimation[i].BottomRight := (1 - t) * BottomRight + t * LBottomRight;
end;
FTranslationAnimationBegin := Now;
FTranslationAnimationEnd := IncMilliSecond(FTranslationAnimationBegin,
Round(1000 * TranslationAnimationDurationSec));
FZoomTranslationTimer.Interval := 50;
FZoomTranslationTimer.Enabled := True;
end;
function TView2D.Area: Double;
begin
Result := XSpan * YSpan;
end;
procedure TView2D.Assign(Source: TPersistent);
begin
if Source is TView2D then
begin
if not CompareMem(@FBounds, @TView2D(Source).FBounds, SizeOf(FBounds)) then
begin
FBounds := TView2D(Source).FBounds;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end
else
inherited;
end;
function TView2D.BottomRight: TPointD;
begin
Result := TPointD.Create(XMax, YMax);
end;
procedure TView2D.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'xmin' then
XMin := V.ToRealNumber
else if S = 'xmax' then
XMax := V.ToRealNumber
else if S = 'ymin' then
YMin := V.ToRealNumber
else if S = 'ymax' then
YMax := V.ToRealNumber
else if S = 'centerpoint' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
CenterPoint := TPointD.Create(pos[0], pos[1]);
end;
end;
end;
constructor TView2D.Create(ACtl: TVisCtl2D);
begin
inherited Create(ACtl, nil);
FCtl := ACtl;
FBounds := DefBoundsArray;
FTranslationTimer := TTimer.Create(nil);
FTranslationTimer.Interval := 50;
FTranslationTimer.Enabled := False;
FTranslationTimer.OnTimer := TranslationTimerTimer;
FZoomTranslationTimer := TTimer.Create(nil);
FZoomTranslationTimer.Interval := 50;
FZoomTranslationTimer.Enabled := False;
FZoomTranslationTimer.OnTimer := ZoomTranslationTimerTimer;
Name := 'View';
OptionsFormClass := TVis2D_ViewSettingsFrm;
end;
destructor TView2D.Destroy;
begin
FreeAndNil(FZoomTranslationTimer);
FreeAndNil(FTranslationTimer);
inherited;
end;
function TView2D.GetBound(const Index: Integer): Double;
begin
Result := FBounds[Index]
end;
function TView2D.GetCenter: TPointD;
begin
Result.X := XMin + XSpan / 2;
Result.Y := YMin + YSpan / 2;
end;
function TView2D.MaxDistFromZero: Double;
begin
Result := MaxValue(
[
Hypot(XMin, YMin),
Hypot(XMax, YMin),
Hypot(XMax, YMax),
Hypot(XMin, YMax)
]
);
end;
function TView2D.MinDistFromZero: Double;
begin
if (Sign(XMin) <> Sign(XMax)) and (Sign(YMin) <> Sign(YMax)) then
Result := 0.0
else if Sign(XMin) <> Sign(XMax) then
Result := Min(Abs(YMin), Abs(YMax))
else if Sign(YMin) <> Sign(YMax) then
Result := Min(Abs(XMin), Abs(XMax))
else
Result := MinValue(
[
Hypot(XMin, YMin),
Hypot(XMax, YMin),
Hypot(XMax, YMax),
Hypot(XMin, YMax)
]
);
end;
procedure TView2D.Normalize(AFlexibleAxis: TCartesianAxis);
var
CP: TPointD;
D: Double;
begin
if (FCtl.ClientHeight < 8) or (FCtl.ClientWidth < 8) then
Exit;
CP := CenterPoint;
case AFlexibleAxis of
TCartesianAxis.X:
begin
D := YSpan * FCtl.ClientWidth / FCtl.ClientHeight / 2;
SetX(CP.X - D, CP.X + D);
end;
TCartesianAxis.Y:
begin
D := XSpan * FCtl.ClientHeight / FCtl.ClientWidth / 2;
SetY(CP.Y - D, CP.Y + D);
end;
end;
end;
procedure TView2D.SetBound(const Index: Integer; const Value: Double);
begin
if FBounds[Index] <> Value then
begin
FBounds[Index] := Value;
Changed;
end
end;
procedure TView2D.SetCenter(const Value: TPointD);
var
xsd2, ysd2: Double;
begin
xsd2 := XSpan / 2;
ysd2 := YSpan / 2;
&Set(
Value.X - xsd2,
Value.X + xsd2,
Value.Y - ysd2,
Value.Y + ysd2
);
end;
procedure TView2D.SetX(const AFrom, ATo: Double);
begin
if (FBounds[_xmin] <> AFrom) or (FBounds[_xmax] <> ATo) then
begin
FBounds[_xmin] := AFrom;
FBounds[_xmax] := ATo;
Changed;
end;
end;
procedure TView2D.SetY(const AFrom, ATo: Double);
begin
if (FBounds[_ymin] <> AFrom) or (FBounds[_ymax] <> ATo) then
begin
FBounds[_ymin] := AFrom;
FBounds[_ymax] := ATo;
Changed;
end;
end;
function TView2D.TopLeft: TPointD;
begin
Result := TPointD.Create(XMin, YMin);
end;
procedure TView2D.TranslationTimerTimer(Sender: TObject);
var
f: Double;
i: Integer;
mt: Integer;
begin
if CompareTime(Now, FTranslationAnimationEnd) = GreaterThanValue then
FTranslationTimer.Enabled := False;
f :=
EnsureRange(
MilliSecondsBetween(FTranslationAnimationBegin, Now) /
MilliSecondsBetween(FTranslationAnimationBegin, FTranslationAnimationEnd),
0,
1
);
i := EnsureRange(
Round(f * High(FTranslationAnimation)),
Low(FTranslationAnimation),
High(FTranslationAnimation)
);
CenterPoint := FTranslationAnimation[i];
if Boolean(FTranslationTimer.Tag) then
begin
Mouse.CursorPos := FCtl.ClientToScreen(
FCtl.DipsToPixels(FCtl.SpaceToCanvas(FTranslationAnimation[High(FTranslationAnimation)]))
);
if not FTranslationTimer.Enabled and SystemParametersInfo(SPI_GETMOUSETRAILS, 0, @mt, 0) and (mt > 1) then
begin
ShowCursor(False);
ShowCursor(True);
end;
end;
end;
function TView2D.XSpan: Double;
begin
Result := FBounds[_xmax] - FBounds[_xmin];
end;
function TView2D.YSpan: Double;
begin
Result := FBounds[_ymax] - FBounds[_ymin];
end;
procedure TView2D.ZoomTranslationTimerTimer(Sender: TObject);
var
f: Double;
i: Integer;
begin
if CompareTime(Now, FTranslationAnimationEnd) = GreaterThanValue then
FZoomTranslationTimer.Enabled := False;
f :=
EnsureRange(
MilliSecondsBetween(FTranslationAnimationBegin, Now) /
MilliSecondsBetween(FTranslationAnimationBegin, FTranslationAnimationEnd),
0,
1
);
i := EnsureRange(
Round(f * High(FZoomTranslationAnimation)),
Low(FZoomTranslationAnimation),
High(FZoomTranslationAnimation)
);
with FZoomTranslationAnimation[i] do
&Set(Left, Right, Top, Bottom);
end;
function TDrawable.amax(ALim: Boolean): Double;
begin
Result := 0;
end;
function TDrawable.amin(ALim: Boolean): Double;
begin
Result := 0;
end;
function TDrawable.aspan(ALim: Boolean): Double;
begin
Result := amax(ALim) - amin(ALim);
end;
function TDrawable.AxisScrPoint(const A: Double; D, D2: Integer): TPointD;
begin
Result := TPoint.Zero;
end;
function TDrawable.AxisSvgPoint(AViewBox: TViewBox; const A, D, D2: Double): TPointD;
begin
Result := TPoint.Zero;
end;
function TDrawable.Canvas: TDirect2DCanvas;
begin
Result := FCtl.Canvas;
end;
function TDrawable.CanvasRect: TRect;
begin
Result := FCtl.CanvasRect;
end;
procedure TDrawable.Changed(Sender: TObject);
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
class constructor TDrawable.ClassCreate;
begin
FInstances := TDictionary<TGUID, TDrawable>.Create;
FInstances.OnKeyNotify := InstanceListChanged;
end;
class destructor TDrawable.ClassDestroy;
begin
FreeAndNil(FInstances);
end;
procedure TDrawable.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'title' then
Title := V.ToString
else if S = 'description' then
Description := V.ToString
else if S = 'windowwidth' then
FCtl.SetWindowWidth(V.ToInt32)
else if S = 'windowheight' then
FCtl.SetWindowHeight(V.ToInt32)
else if S = 'autonormalize' then
FCtl.AutoNormalize := V.ToBoolean
else if S = 'detached' then
FCtl.SetDetached(V.ToBoolean)
end;
end;
constructor TDrawable.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
FVisible := True;
FCtl := ACtl;
FView := AView;
if Succeeded(CreateGUID(FGUID)) and Assigned(FInstances) then
FInstances.Add(FGUID, Self);
end;
function TDrawable.CreateReference: TAlgosimReference;
begin
Result := TAlgosimReference.CreateWithValue(FGUID);
end;
procedure TDrawable.Changed;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
destructor TDrawable.Destroy;
begin
if Assigned(FInstances) then
FInstances.Remove(FGUID);
inherited;
end;
function TDrawable.Direction(const Angle: Double): TPointD;
var
S, C: Double;
begin
SinCos(Angle, S, C);
Result := TPointD.Create(C, S);
end;
procedure TDrawable.Draw;
begin
end;
procedure TDrawable.DrawDisk(const P: TPointD; const R: Double);
var
Ellipse: TD2D1Ellipse;
begin
Ellipse := D2D1Ellipse(P, R, R);
Canvas.FillEllipse(Ellipse);
Canvas.DrawEllipse(Ellipse);
end;
procedure TDrawable.DrawDiskSp(const P: TPointD; const R: Double);
var
Ellipse: TD2D1Ellipse;
begin
Ellipse := D2D1Ellipse(FCtl.SpaceToCanvas(P), FView.ScaleX(R), FView.ScaleY(R));
Canvas.FillEllipse(Ellipse);
Canvas.DrawEllipse(Ellipse);
end;
procedure TDrawable.DrawDiskSpPx(const P: TPointD; const R: Double);
begin
Canvas.FillEllipse(D2D1Ellipse(FCtl.SpaceToCanvas(P), R, R));
Canvas.DrawEllipse(D2D1Ellipse(FCtl.SpaceToCanvas(P), R, R));
end;
procedure TDrawable.DrawEllipse(const R: TRectD);
var
RR: TRect;
begin
if R.TryToInt(RR) then
Canvas.Ellipse(RR);
end;
procedure TDrawable.DrawEllipseSp(const R: TRectD);
begin
DrawEllipse(FCtl.SpaceToCanvas(R));
end;
procedure TDrawable.DrawLine(const A, B: TPointD);
var
PA, PB: TPoint;
begin
if A.TryToInt(PA) and B.TryToInt(PB) then
begin
Canvas.MoveTo(PA.X, PA.Y);
Canvas.LineTo(PB.X, PB.Y);
end;
end;
procedure TDrawable.DrawLineEndMarker(AMarker: TLineEndMarker; AFilled: Boolean;
const P: TPointD; const ASizeX, ASizeY, AAngle: Double);
var
D2D1Point: TD2D1Point2F;
TransformedMarker: ID2D1TransformedGeometry;
begin
if AMarker = lemNone then
Exit;
if not FCtl.TrySpaceToD2d1(P, D2D1Point) then
Exit;
var LAngle: Single := -90 + 180*AAngle/Pi;
if Succeeded(D2DFactory.CreateTransformedGeometry(
FCtl.FLineEndMarkers[AMarker],
TD2DMatrix3x2F.Scale(ASizeX, ASizeY, D2d1Origin)
*
TD2DMatrix3x2F.Rotation(LAngle, D2d1Origin)
*
TD2DMatrix3x2F.Translation(D2D1Point),
TransformedMarker
)) then
if AFilled and AMarker.IsFilled then
Canvas.FillGeometry(TransformedMarker)
else
Canvas.DrawGeometry(TransformedMarker);
end;
procedure TDrawable.DrawLineEndMarkerSp(AMarker: TLineEndMarker; AFilled: Boolean;
const P: TPointD; const ASizeX, ASizeY, AAngle: Double);
begin
DrawLineEndMarker(AMarker, AFilled, FCtl.SpaceToCanvas(P), ASizeX, ASizeY, AAngle);
end;
procedure TDrawable.DrawLineSp(const A, B: TPointD);
begin
DrawLine(FCtl.SpaceToCanvas(A), FCtl.SpaceToCanvas(B));
end;
procedure TDrawable.DrawRect(const ARect: TRectD);
var
RR: TRect;
begin
if ARect.TryToInt(RR) then
Canvas.Rectangle(RR);
end;
procedure TDrawable.DrawRect(const ARect: TRectD; const ARotAngle: Double);
var
RR: TRect;
begin
if ARect.TryToInt(RR) then
begin
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Rotation(-180*ARotAngle/Pi, RR.TopLeft));
try
Canvas.Rectangle(RR);
finally
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity);
end;
end;
end;
procedure TDrawable.DrawRectSp(const ARect: TRectD; const ARotAngle: Double);
begin
DrawRect(FCtl.SpaceToCanvas(ARect), ARotAngle);
end;
procedure TDrawable.DrawTo(ASVG: TSVGBuilder_VisCtl2D);
begin
DrawToPrefix(ASVG);
DrawToContent(ASVG);
DrawToSuffix(ASVG);
end;
procedure TDrawable.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
end;
procedure TDrawable.DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D);
begin
end;
procedure TDrawable.DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D);
begin
end;
procedure TDrawable.DrawRectSp(const ARect: TRectD);
begin
DrawRect(FCtl.SpaceToCanvas(ARect));
end;
function TDrawable.FirstScrPoint(const A: Double; D, D2: Integer): TPointD;
begin
Result := TPoint.Zero;
end;
procedure TDrawable.FreeDeviceResources;
begin
end;
class function TDrawable.GetRealm: string;
begin
Result := 'ℝ²';
end;
class procedure TDrawable.InstanceListChanged(Sender: TObject;
const Item: TGUID; Action: TCollectionNotification);
begin
if Assigned(VisObjListChanged) then
VisObjListChanged(Sender);
end;
function TDrawable.LastScrPoint(const A: Double; D, D2: Integer): TPointD;
begin
Result := TPoint.Zero;
end;
function TDrawable.AxP(const A, B: Double): TPointD;
begin
Result.X := A;
Result.Y := B;
end;
function TDrawable.AxPScr(const A, B: Double): TPointD;
begin
Result := FCtl.SpaceToCanvas(AxP(A, B));
end;
procedure TDrawable.SetVisible(const Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
Changed;
end;
end;
procedure TDrawable.ShowOptionsForm(AParent: TCustomForm);
var
LOptionsFrm: TDrawableOptionsFrm;
begin
if Assigned(OptionsFormClass) then
begin
if AParent = nil then
AParent := GetParentForm(FCtl);
LOptionsFrm := OptionsFormClass.Create(AParent, Self);
try
Inc(FModalLevel);
try
LOptionsFrm.ShowModal;
finally
Dec(FModalLevel);
end;
finally
LOptionsFrm.Free;
end;
end
else
ShowMessage('This object has no configurable properties.');
end;
function TDrawable.SizePrimary(const S: TSize): Integer;
begin
Result := 0;
end;
function TDrawable.SizeSecondary(const S: TSize): Integer;
begin
Result := 0;
end;
procedure TDrawable.TextOut(const X, Y: Double; const Text: string);
begin
if
InRange(X, Integer.MinValue, Integer.MaxValue)
and
InRange(Y, Integer.MinValue, Integer.MaxValue)
then
Canvas.TextOut(Round(X), Round(Y), Text);
end;
class function TDrawable.TryGetDrawableByGUID(const AGUID: TGUID;
out ADrawable: TDrawable): Boolean;
begin
Result := Assigned(FInstances) and FInstances.TryGetValue(AGUID, ADrawable);
end;
constructor TDiagram.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Name := 'Diagram';
OptionsFormClass := TVisCtlOptionsFrm;
end;
function TDiagram.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('axes', FCtl.Axes.CreateReference);
Result.AddSubref('grids', FCtl.GridLines.CreateReference);
Result.AddSubref('view', FCtl.View.CreateReference);
Result.AddSubref('objects', FCtl.ObjectMgr.CreateReference);
end;
procedure TAxis.Assign(Source: TPersistent);
begin
if Source is TAxis then
begin
FAutomatic := TAxis(Source).FAutomatic;
FVisible := TAxis(Source).FVisible;
FColor := TAxis(Source).FColor;
FWidth := TAxis(Source).FWidth;
FMin := TAxis(Source).FMin;
FMax := TAxis(Source).FMax;
FTickDistance := TAxis(Source).FTickDistance;
FTickLength := TAxis(Source).FTickLength;
FTickWidth := TAxis(Source).FTickWidth;
FTickColor := TAxis(Source).FTickColor;
FTickSide := TAxis(Source).FTickSide;
FTicksVisible := TAxis(Source).FTicksVisible;
FNumberDistance := TAxis(Source).FNumberDistance;
FNumberUnitValue := TAxis(Source).FNumberUnitValue;
FNumberUnitSymbol := TAxis(Source).FNumberUnitSymbol;
FNumberFormat := TAxis(Source).FNumberFormat;
FNumberFont.Assign(TAxis(Source).FNumberFont);
FNumbersVisible := TAxis(Source).FNumbersVisible;
Changed;
end
else
inherited;
end;
function TAxis.AxSpan: Double;
begin
Result := AxMax - AxMin;
end;
procedure TAxis.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'automatic' then
Automatic := V.ToBoolean
else if S = 'color' then
Color := V.ToColor
else if S = 'axmin' then
AxMin := V.ToRealNumber
else if S = 'axmax' then
AxMax := V.ToRealNumber
else if S = 'numberdistance' then
NumberDistance := V.ToRealNumber
else if S = 'numberformat' then
NumberFormat := V.ToString
else if S = 'numberunitsymbol' then
NumberUnitSymbol := V.ToString
else if S = 'numberunitvalue' then
NumberUnitValue := V.ToRealNumber
else if S = 'numbersvisible' then
NumbersVisible := V.ToBoolean
else if S = 'position' then
Position := V.ToRealNumber
else if S = 'width' then
Width := V.ToInt32
else if S = 'textoffset' then
TextOffset := V.ToInt32
else if S = 'tickdistance' then
TickDistance := V.ToRealNumber
else if S = 'ticklength' then
TickLength := V.ToInt32
else if S = 'tickwidth' then
TickWidth := V.ToInt32
else if S = 'tickcolor' then
TickColor := V.ToColor
else if S = 'ticksvisible' then
TicksVisible := V.ToBoolean
else if S = 'visible' then
Visible := V.ToBoolean
end;
end;
constructor TAxis.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FNumberFont := TFont.Create;
FNumberFont.OnChange := Changed;
FTextFont := TFont.Create;
FTextFont.OnChange := Changed;
FTextOffset := DefaultTextOffset;
FAutomatic := DefaultAutomatic;
FColor := DefaultColor;
FWidth := DefaultWidth;
FTickDistance := DefaultTickDistance;
FTickLength := DefaultTickLength;
FTickWidth := DefaultTickWidth;
FTickColor := DefaultTickColor;
FTickSide := DefaultTickSide;
FTicksVisible := DefaultTicksVisible;
FNumberDistance := DefaultNumberDistance;
FNumberUnitValue := DefaultNumberUnitValue;
FNumberUnitSymbol := DefaultNumberUnitSymbol;
FNumberFormat := DefaultNumberFormat;
FNumbersVisible := DefaultNumbersVisible;
FVisible := DefaultVisible;
Name := 'Axis';
OptionsFormClass := TVis2D_AxisSettingsFrm;
end;
destructor TAxis.Destroy;
begin
FreeAndNil(FTextFont);
FreeAndNil(FNumberFont);
inherited;
end;
procedure TAxis.Draw;
var
a: Double;
S: string;
Sz: TSize;
P: TPointD;
M: Integer;
LNumDecimals: Integer;
LTickDistance,
LNumberDistance: Double;
LExp: Boolean;
LMinDist: Double;
LWhileGuard: Integer;
begin
if not Visible then
Exit;
if aspan <= 0 then
Exit;
if CanvasRect.IsEmpty then
Exit;
Canvas.Pen.Color := Color;
Canvas.Pen.Width := Width;
Canvas.Pen.Style := psSolid;
if Automatic then
begin
LNumberDistance := IntPower(10, Round(Log10(aspan / 10)));
LTickDistance := LNumberDistance;
if aspan / LNumberDistance < 5 then
begin
LNumberDistance := LNumberDistance / 2;
LTickDistance := LNumberDistance;
end
else if aspan / LNumberDistance > 15 then
LNumberDistance := LNumberDistance * 2;
end
else
begin
LTickDistance := TickDistance;
LNumberDistance := NumberDistance;
end;
DrawLine(AxisScrPoint(amin(True)), AxisScrPoint(amax(True)));
if TicksVisible and (LTickDistance > 0) and (aspan / LTickDistance < 1000) then
begin
a := amin(True) - rmod2(amin(True), LTickDistance);
Canvas.Pen.Color := TickColor;
Canvas.Pen.Width := TickWidth;
Canvas.Pen.Style := psSolid;
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
DrawLine(
AxisScrPoint(a, -IfThen(TickSide <> tsPositive, TickLength)),
AxisScrPoint(a, IfThen(TickSide <> tsNegative, TickLength))
);
a := a + LTickDistance;
Inc(LWhileGuard);
end;
end;
FNumberWidth := 0;
if NumbersVisible and (LNumberDistance > 0) and (aspan / LNumberDistance < 1000) then
begin
Canvas.Font.Assign(NumberFont);
Canvas.Brush.Style := bsClear;
M := SizePrimary(Canvas.TextExtent('500000'));
if Automatic and (aspan / LNumberDistance * M > SizePrimary(CanvasRect.Size)) then
begin
LMinDist := 1.2 * aspan * M / SizePrimary(CanvasRect.Size);
LNumberDistance := LMinDist;
LNumberDistance := IntPower(10, Ceil(Log10(LNumberDistance)));
if LNumberDistance / 5 > LMinDist then
LNumberDistance := LNumberDistance / 5
else if LNumberDistance / 2 > LMinDist then
LNumberDistance := LNumberDistance / 2
end;
LNumDecimals := Max(0, Ceil(-Log10(aspan/4)));
if not IsZero(amin) and not IsZero(amax) then
LExp := not InRange(Max(Log10(Abs(amin)), Log10(Abs(amax))), -4, 7)
else if not IsZero(amin) then
LExp := not InRange(Log10(Abs(amin)), -4, 7)
else
LExp := not InRange(Log10(Abs(amax)), -4, 7);
a := amin(True) - rmod2(amin(True), LNumberDistance);
M := Canvas.TextWidth(MINUS_SIGN) div 2;
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
if Abs(a) > Max(Abs(amin), Abs(amax))/10000 then
begin
if NumberFormat.IsEmpty then
if LExp then
S := FloatToStrF(a, ffExponent, 2, 0, FCtl.InvFS)
else
S := FloatToStrF(a, ffFixed, 8, LNumDecimals, FCtl.InvFS)
else
S := FormatFloat(NumberFormat, a, FCtl.InvFS);
S := S.Replace(HYPHEN_MINUS, MINUS_SIGN, [rfReplaceAll]);
Sz := Canvas.TextExtent(S);
FNumberWidth := Max(FNumberWidth, SizeSecondary(Sz));
P := AxisScrPoint(
a,
-TickLength - 2 - Ord(FVertFlag) * SizeSecondary(Sz),
-SizePrimary(Sz) div 2
);
if not FVertFlag and (a < 0) then
P.X := P.X - M;
TextOut(P.X, P.Y, S);
end;
a := a + LNumberDistance;
Inc(LWhileGuard);
end;
end;
end;
procedure TAxis.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
a: Double;
S: string;
Sz: TSize;
P: TPointD;
M: Integer;
LNumDecimals: Integer;
LTickDistance,
LNumberDistance: Double;
LExp: Boolean;
LMinDist: Double;
LWhileGuard: Integer;
begin
inherited;
if not Visible then
Exit;
if aspan <= 0 then
Exit;
if CanvasRect.IsEmpty then
Exit;
if Automatic then
begin
LNumberDistance := IntPower(10, Round(Log10(aspan / 10)));
LTickDistance := LNumberDistance;
if aspan / LNumberDistance < 5 then
begin
LNumberDistance := LNumberDistance / 2;
LTickDistance := LNumberDistance;
end
else if aspan / LNumberDistance > 15 then
LNumberDistance := LNumberDistance * 2;
end
else
begin
LTickDistance := TickDistance;
LNumberDistance := NumberDistance;
end;
ASVG
.Line(
AxisSvgPoint(ASVG.ViewBox, amin(True)),
AxisSvgPoint(ASVG.ViewBox, amax(True)))
.Stroke(Color)
.StrokeWidthPx(Width)
.Append;
if TicksVisible and (LTickDistance > 0) and (aspan / LTickDistance < 1000) then
begin
ASVG.BeginGroup
.&Class('ticks')
.Stroke(TickColor)
.StrokeWidthPx(TickWidth)
.Append;
a := amin(True) - rmod2(amin(True), LTickDistance);
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
ASVG
.Line(
AxisSvgPoint(ASVG.ViewBox, a, -IfThen(TickSide <> tsPositive, TickLength)),
AxisSvgPoint(ASVG.ViewBox, a, IfThen(TickSide <> tsNegative, TickLength)))
.Append;
a := a + LTickDistance;
Inc(LWhileGuard);
end;
ASVG.EndGroup.Append;
end;
FNumberWidth := 0;
if NumbersVisible and (LNumberDistance > 0) and (aspan / LNumberDistance < 1000) then
begin
ASVG.BeginGroup
.&Class('axis-labels')
.Font(NumberFont)
.TextAnchor(TAlignment(IfThen(FVertFlag, Ord(taRightJustify), Ord(taCenter))))
.AttribIf('dominant-baseline', 'central', FVertFlag)
.AttribIf('dominant-baseline', 'text-before-edge', not FVertFlag)
.Append;
Canvas.Font.Assign(NumberFont);
Canvas.Brush.Style := bsClear;
M := SizePrimary(Canvas.TextExtent('500000'));
if Automatic and (aspan / LNumberDistance * M > SizePrimary(CanvasRect.Size)) then
begin
LMinDist := 1.2 * aspan * M / SizePrimary(CanvasRect.Size);
LNumberDistance := LMinDist;
LNumberDistance := IntPower(10, Ceil(Log10(LNumberDistance)));
if LNumberDistance / 5 > LMinDist then
LNumberDistance := LNumberDistance / 5
else if LNumberDistance / 2 > LMinDist then
LNumberDistance := LNumberDistance / 2
end;
LNumDecimals := Max(0, Ceil(-Log10(aspan/4)));
if not IsZero(amin) and not IsZero(amax) then
LExp := not InRange(Max(Log10(Abs(amin)), Log10(Abs(amax))), -4, 7)
else if not IsZero(amin) then
LExp := not InRange(Log10(Abs(amin)), -4, 7)
else
LExp := not InRange(Log10(Abs(amax)), -4, 7);
a := amin(True) - rmod2(amin(True), LNumberDistance);
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
if Abs(a) > Max(Abs(amin), Abs(amax))/10000 then
begin
if NumberFormat.IsEmpty then
if LExp then
S := FloatToStrF(a, ffExponent, 2, 0, FCtl.InvFS)
else
S := FloatToStrF(a, ffFixed, 8, LNumDecimals, FCtl.InvFS)
else
S := FormatFloat(NumberFormat, a, FCtl.InvFS);
S := S.Replace(HYPHEN_MINUS, MINUS_SIGN, [rfReplaceAll]);
Sz := Canvas.TextExtent(S);
FNumberWidth := Max(FNumberWidth, SizeSecondary(Sz));
P := AxisSvgPoint(
ASVG.ViewBox,
a,
-TickLength - 2
);
ASVG
.Text(P, S)
.AttribIf('class', 'neg', a < 0)
.AttribIf('class', 'zero', a = 0)
.Append;
end;
a := a + LNumberDistance;
Inc(LWhileGuard);
end;
ASVG.EndGroup.Append;
end;
end;
procedure TAxis.DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
if not Visible then
Exit;
if aspan <= 0 then
Exit;
if CanvasRect.IsEmpty then
Exit;
ASVG
.BeginGroup
.&Class('axis')
.&Class(Name)
.Append('axis');
end;
procedure TAxis.DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
if ASVG.Undefine('axis') then
ASVG.EndGroup.Append;
end;
function TAxis.Limited: Boolean;
begin
Result := (FMin <> 0.0) or (FMax <> 0.0);
end;
procedure TAxis.SetAutomatic(const Value: Boolean);
begin
if FAutomatic <> Value then
begin
FAutomatic := Value;
Changed;
end;
end;
procedure TAxis.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
procedure TAxis.SetMax(const Value: Double);
begin
if FMax <> Value then
begin
FMax := Value;
Changed;
end;
end;
procedure TAxis.SetMin(const Value: Double);
begin
if FMin <> Value then
begin
FMin := Value;
Changed;
end;
end;
procedure TAxis.SetNumberDistance(const Value: Double);
begin
if FNumberDistance <> Value then
begin
FNumberDistance := Value;
Changed;
end;
end;
procedure TAxis.SetNumberFont(const Value: TFont);
begin
FNumberFont.Assign(Value);
end;
procedure TAxis.SetNumberFormat(const Value: string);
begin
if FNumberFormat <> Value then
begin
FNumberFormat := Value;
Changed;
end;
end;
procedure TAxis.SetNumbersVisible(const Value: Boolean);
begin
if FNumbersVisible <> Value then
begin
FNumbersVisible := Value;
Changed;
end;
end;
procedure TAxis.SetNumberUnitSymbol(const Value: string);
begin
if FNumberUnitSymbol <> Value then
begin
FNumberUnitSymbol := Value;
Changed;
end;
end;
procedure TAxis.SetNumberUnitValue(const Value: Double);
begin
if FNumberUnitValue <> Value then
begin
FNumberUnitValue := Value;
Changed;
end;
end;
procedure TAxis.SetPosition(const Value: Double);
begin
if FAxisPosition <> Value then
begin
FAxisPosition := Value;
Changed;
end;
end;
procedure TAxis.SetText(const Value: string);
begin
if FText <> Value then
begin
FText := Value;
Changed;
end;
end;
procedure TAxis.SetTextFont(const Value: TFont);
begin
FTextFont.Assign(Value);
end;
procedure TAxis.SetTextOffset(const Value: Integer);
begin
if FTextOffset <> Value then
begin
FTextOffset := Value;
Changed;
end;
end;
procedure TAxis.SetTickColor(const Value: TColor);
begin
if FTickColor <> Value then
begin
FTickColor := Value;
Changed;
end;
end;
procedure TAxis.SetTickDistance(const Value: Double);
begin
if FTickDistance <> Value then
begin
FTickDistance := Value;
Changed;
end;
end;
procedure TAxis.SetTickLength(const Value: Integer);
begin
if FTickLength <> Value then
begin
FTickLength := Value;
Changed;
end;
end;
procedure TAxis.SetTickSide(const Value: TTickSide);
begin
if FTickSide <> Value then
begin
FTickSide := Value;
Changed;
end;
end;
procedure TAxis.SetTicksVisible(const Value: Boolean);
begin
if FTicksVisible <> Value then
begin
FTicksVisible := Value;
Changed;
end;
end;
procedure TAxis.SetTickWidth(const Value: Integer);
begin
if FTickWidth <> Value then
begin
FTickWidth := Value;
Changed;
end;
end;
procedure TAxis.SetVisible(const Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
Changed;
end;
end;
procedure TAxis.SetWidth(const Value: Integer);
begin
if FWidth <> Value then
begin
FWidth := Value;
Changed;
end;
end;
function THorizontalAxis.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(FView.XMax, AxMax)
else
Result := FView.XMax;
end;
function THorizontalAxis.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(FView.XMin, AxMin)
else
Result := FView.XMin
end;
function THorizontalAxis.AxisScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, Position);
Result.X := Result.X + D2;
Result.Y := Result.Y - D;
end;
function THorizontalAxis.AxisSvgPoint(AViewBox: TViewBox; const A, D, D2: Double): TPointD;
begin
Result := FCtl.SpaceToViewbox(AViewBox, FCtl.P(A, Position));
Result.X := Result.X + D2;
Result.Y := Result.Y - D;
end;
procedure THorizontalAxis.Draw;
var
P: TPointD;
Sz: TSize;
begin
inherited;
if not Text.IsEmpty then
begin
Canvas.Font.Assign(TextFont);
Canvas.Brush.Style := bsClear;
Sz := Canvas.TextExtent(Text);
if Limited then
P := FCtl.SpaceToCanvas(
AxMin + AxSpan / 2,
0,
-Sz.cx div 2,
FNumberWidth + TextOffset
)
else
P := FCtl.SpaceToCanvas(
amin + aspan / 2,
0,
-Sz.cx div 2,
FNumberWidth + TextOffset
);
TextOut(P.X, P.Y, Text);
end;
end;
procedure THorizontalAxis.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
P: TPointD;
begin
inherited;
if not Text.IsEmpty then
begin
if Limited then
P := FCtl.SpaceToViewbox(
ASVG.ViewBox,
FCtl.P(AxMin + AxSpan / 2, 0),
0,
FNumberWidth + TextOffset
)
else
P := FCtl.SpaceToViewbox(
ASVG.ViewBox,
FCtl.P(amin + aspan / 2, 0),
0,
FNumberWidth + TextOffset
);
ASVG
.Text(P, Text)
.&Class('axis-text')
.TextAnchor(taCenter)
.DominantBaseline(taAlignTop)
.Font(TextFont)
.Append;
end;
end;
function THorizontalAxis.FirstScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, 0);
Result.Y := 0;
end;
function THorizontalAxis.LastScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, 0);
Result.Y := FCtl.CanvasRect.Height;
end;
function THorizontalAxis.SizePrimary(const S: TSize): Integer;
begin
Result := S.cx;
end;
function THorizontalAxis.SizeSecondary(const S: TSize): Integer;
begin
Result := S.cy;
end;
function TVerticalAxis.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(FView.YMax, AxMax)
else
Result := FView.YMax;
end;
function TVerticalAxis.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(FView.YMin, AxMin)
else
Result := FView.YMin;
end;
function TVerticalAxis.AxisScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(Position, A);
Result.X := Result.X + D;
Result.Y := Result.Y + D2;
end;
function TVerticalAxis.AxisSvgPoint(AViewBox: TViewBox; const A, D, D2: Double): TPointD;
begin
Result := FCtl.SpaceToViewbox(AViewBox, FCtl.P(Position, A));
Result.X := Result.X + D;
Result.Y := Result.Y + D2;
end;
function TVerticalAxis.AxP(const A, B: Double): TPointD;
begin
Result := TPointD.Create(B, A);
end;
procedure TVerticalAxis.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'rotatetext' then
RotateAxisText := V.ToBoolean
end;
end;
constructor TVerticalAxis.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FVertFlag := True;
end;
procedure TVerticalAxis.Draw;
var
P: TPointD;
Sz: TSize;
begin
inherited;
if not Text.IsEmpty then
begin
Canvas.Font.Assign(TextFont);
Canvas.Brush.Style := bsClear;
Sz := Canvas.TextExtent(Text);
if Limited then
P := FCtl.SpaceToCanvas(
0,
AxMin + AxSpan / 2,
-(FNumberWidth + TextOffset),
0
)
else
P := FCtl.SpaceToCanvas(
0,
amin + aspan / 2,
-(FNumberWidth + TextOffset),
0
);
if FRotateAxisText then
begin
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Rotation(-90, P));
try
TextOut(P.X - Sz.cx / 2, P.Y - Sz.cy, Text);
finally
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity);
end;
end
else
TextOut(P.X - Sz.cx, P.Y - Sz.cy / 2, Text);
end;
end;
procedure TVerticalAxis.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
P: TPointD;
begin
inherited;
if not Text.IsEmpty then
begin
if Limited then
P := FCtl.SpaceToViewbox(
ASVG.ViewBox,
FCtl.P(0, AxMin + AxSpan / 2),
-(FNumberWidth + TextOffset)
)
else
P := FCtl.SpaceToViewbox(
ASVG.ViewBox,
FCtl.P(0, amin + aspan / 2),
-(FNumberWidth + TextOffset)
);
if FRotateAxisText then
ASVG
.Text(P, Text)
.&Class('axis-text')
.TextAnchor(taCenter)
.Font(TextFont)
.Transform(RotationDeg(-90, P.X, P.Y))
.Append
else
ASVG
.Text(P, Text)
.&Class('axis-text')
.TextAnchor(taRightJustify)
.DominantBaseline(taVerticalCenter)
.Font(TextFont)
.Append;
end;
end;
function TVerticalAxis.FirstScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, A);
Result.X := 0;
end;
function TVerticalAxis.LastScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, A);
Result.X := FView.FCtl.CanvasRect.Width;
end;
procedure TVerticalAxis.SetRotateAxisText(const Value: Boolean);
begin
if FRotateAxisText <> Value then
begin
FRotateAxisText := Value;
Changed;
end;
end;
function TVerticalAxis.SizePrimary(const S: TSize): Integer;
begin
Result := S.cy;
end;
function TVerticalAxis.SizeSecondary(const S: TSize): Integer;
begin
Result := S.cx;
end;
procedure TAxes.Assign(Source: TPersistent);
begin
if Source is TAxes then
begin
FX.Assign(TAxes(Source).FX);
FY.Assign(TAxes(Source).FY);
end
else if Source is TAxis then
begin
FX.Assign(TAxis(Source));
FY.Assign(TAxis(Source));
end
else
inherited;
end;
constructor TAxes.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FX := THorizontalAxis.Create(ACtl, AView);
FX.Name := 'X axis';
FX.OnChange := Changed;
FY := TVerticalAxis.Create(ACtl, AView);
FY.Name := 'Y axis';
FY.OnChange := Changed;
Name := 'Axes';
OptionsFormClass := TVis2D_AxesSettingsFrm;
end;
function TAxes.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('x', FX.CreateReference);
Result.AddSubref('y', FY.CreateReference);
end;
destructor TAxes.Destroy;
begin
FreeAndNil(FY);
FreeAndNil(FX);
inherited;
end;
procedure TAxes.Draw;
begin
FX.Draw;
FY.Draw;
end;
procedure TAxes.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
FX.DrawTo(ASVG);
FY.DrawTo(ASVG);
end;
procedure TAxes.SetX(const Value: THorizontalAxis);
begin
FX.Assign(Value);
end;
procedure TAxes.SetY(const Value: TVerticalAxis);
begin
FY.Assign(Value);
end;
procedure TGridLineFamily.Assign(Source: TPersistent);
begin
if Source is TGridLineFamily then
begin
FMin := TGridLineFamily(Source).FMin;
FMax := TGridLineFamily(Source).FMax;
FDistance := TGridLineFamily(Source).FDistance;
FVisible := TGridLineFamily(Source).FVisible;
FWidth := TGridLineFamily(Source).FWidth;
FColor := TGridLineFamily(Source).FColor;
FPenStyle := TGridLineFamily(Source).FPenStyle;
Changed;
end
else
inherited;
end;
procedure TGridLineFamily.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'distance' then
Distance := V.ToRealNumber
else if S = 'axmin' then
AxMin := V.ToRealNumber
else if S = 'axmax' then
AxMax := V.ToRealNumber
else if S = 'linestart' then
LineBegin := V.ToRealNumber
else if S = 'lineend' then
LineEnd := V.ToRealNumber
else if S = 'visible' then
Visible := V.ToBoolean
else if S = 'width' then
Width := V.ToInt32
else if S = 'color' then
Color := V.ToColor
end;
end;
constructor TGridLineFamily.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FDistance := 1.0;
FVisible := DefaultVisible;
FWidth := DefaultWidth;
FColor := DefaultColor;
FPenStyle := DefaultPenStyle;
Name := 'Grid lines';
OptionsFormClass := TVis2D_GridSettingsFrm;
end;
procedure TGridLineFamily.Draw;
var
a: Double;
LWhileGuard: Integer;
begin
if Visible and (Distance > 0) and (aspan / Distance < 200) then
begin
a := amin(True) - rmod2(amin(True), Distance);
Canvas.Pen.Color := Color;
Canvas.Pen.Width := Width;
Canvas.Pen.Style := PenStyle;
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 200) do
begin
if LineLimited then
DrawLine(
AxPScr(a, FBegin),
AxPScr(a, FEnd)
)
else
DrawLine(
FirstScrPoint(a),
LastScrPoint(a)
);
a := a + Distance;
Inc(LWhileGuard);
end;
end;
end;
procedure TGridLineFamily.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
a: Double;
LWhileGuard: Integer;
begin
inherited;
if Visible and (Distance > 0) and (aspan / Distance < 200) then
begin
ASVG
.BeginGroup
.&Class('grid')
.&Class(Name)
.Stroke(Color)
.StrokeWidthPx(Width)
.Append;
a := amin(True) - rmod2(amin(True), Distance);
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 200) do
begin
if LineLimited then
ASVG
.Line(
AxPScr(a, FBegin),
AxPScr(a, FEnd)
)
.Append
else
ASVG
.Line(
FirstScrPoint(a),
LastScrPoint(a)
)
.Append;
a := a + Distance;
Inc(LWhileGuard);
end;
ASVG.EndGroup.Append;
end;
end;
function TGridLineFamily.Limited: Boolean;
begin
Result := (FMin <> 0.0) or (FMax <> 0.0);
end;
function TGridLineFamily.LineLimited: Boolean;
begin
Result := (FBegin <> 0.0) or (FEnd <> 0.0);
end;
procedure TGridLineFamily.SetBegin(const Value: Double);
begin
if FBegin <> Value then
begin
FBegin := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetDistance(const Value: Double);
begin
if FDistance <> Value then
begin
FDistance := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetEnd(const Value: Double);
begin
if FEnd <> Value then
begin
FEnd := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetMax(const Value: Double);
begin
if FMax <> Value then
begin
FMax := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetMin(const Value: Double);
begin
if FMin <> Value then
begin
FMin := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetPenStyle(const Value: TPenStyle);
begin
if FPenStyle <> psSolid then
begin
FPenStyle := psSolid;
Changed;
end;
end;
procedure TGridLineFamily.SetVisible(const Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
Changed;
end;
end;
procedure TGridLineFamily.SetWidth(const Value: Integer);
begin
if FWidth <> Value then
begin
FWidth := Value;
Changed;
end;
end;
function THorizontalGridLineFamily.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(FView.YMax, AxMax)
else
Result := FView.YMax;
end;
function THorizontalGridLineFamily.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(FView.YMin, AxMin)
else
Result := FView.YMin;
end;
function THorizontalGridLineFamily.AxisScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, A);
Result.X := Result.X + D;
Result.Y := Result.Y + D2;
end;
function THorizontalGridLineFamily.AxP(const A, B: Double): TPointD;
begin
Result.X := B;
Result.Y := A;
end;
function THorizontalGridLineFamily.FirstScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, A);
Result.X := 0;
end;
function THorizontalGridLineFamily.LastScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, A);
Result.X := FView.FCtl.CanvasRect.Width;
end;
function THorizontalGridLineFamily.SizePrimary(const S: TSize): Integer;
begin
Result := S.cy;
end;
function THorizontalGridLineFamily.SizeSecondary(const S: TSize): Integer;
begin
Result := S.cx;
end;
function TVerticalGridLineFamily.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(FView.XMax, AxMax)
else
Result := FView.XMax;
end;
function TVerticalGridLineFamily.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(FView.XMin, AxMin)
else
Result := FView.XMin;
end;
function TVerticalGridLineFamily.AxisScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, 0);
Result.X := Result.X + D2;
Result.Y := Result.Y - D;
end;
function TVerticalGridLineFamily.FirstScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, 0);
Result.Y := 0;
end;
function TVerticalGridLineFamily.LastScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(A, 0);
Result.Y := FCtl.CanvasRect.Height;
end;
function TVerticalGridLineFamily.SizePrimary(const S: TSize): Integer;
begin
Result := S.cx;
end;
function TVerticalGridLineFamily.SizeSecondary(const S: TSize): Integer;
begin
Result := S.cy;
end;
function TRadialGridLineFamily.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(Pi, AxMax)
else
Result := Pi;
end;
function TRadialGridLineFamily.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(-Pi, AxMin)
else
Result := -Pi;
end;
function TRadialGridLineFamily.AxP(const A, B: Double): TPointD;
var
s, c: Double;
begin
SinCos(A, s, c);
Result.X := B * c;
Result.Y := B * s;
end;
function TRadialGridLineFamily.FirstScrPoint(const A: Double; D,
D2: Integer): TPointD;
begin
Result := FCtl.Scr(0, 0);
end;
function TRadialGridLineFamily.LastScrPoint(const A: Double; D,
D2: Integer): TPointD;
var
s, c: Double;
begin
SinCos(A, s, c);
Result := FCtl.SpaceToCanvas(FView.MaxDistFromZero * TPointD.Create(c, s))
end;
function TCircularGridLineFamily.amax(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Min(FView.MaxDistFromZero, AxMax)
else
Result := FView.MaxDistFromZero;
end;
function TCircularGridLineFamily.amin(ALim: Boolean): Double;
begin
if ALim and Limited then
Result := Max(FView.MinDistFromZero, AxMin)
else
Result := FView.MinDistFromZero;
end;
function TCircularGridLineFamily.AxP(const A, B: Double): TPointD;
var
s, c: Double;
begin
SinCos(B, s, c);
Result.X := A * c;
Result.Y := A * s;
end;
procedure TCircularGridLineFamily.Draw;
var
a: Double;
LWhileGuard: Integer;
begin
if not Visible then
Exit;
if LineLimited and (LineEnd <= LineBegin) then
Exit;
if Visible and (Distance > 0) and (aspan / Distance < 1000) then
begin
a := amin(True) - rmod(amin(True), Distance);
Canvas.Pen.Color := Color;
Canvas.Pen.Width := Width;
Canvas.Pen.Style := PenStyle;
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
if LineLimited then
begin
var Geometry: ID2D1PathGeometry;
var Sink: ID2D1GeometrySink;
var Arc: TD2D1ArcSegment;
if Succeeded(D2DFactory.CreatePathGeometry(Geometry)) then
begin
FillChar(Arc, SizeOf(Arc), 0);
Arc.point := AxPScr(a, LineEnd);
Arc.size := D2D1SizeF(FView.ScaleX(a), FView.ScaleY(a));
Arc.rotationAngle := 0;
Arc.sweepDirection := D2D1_SWEEP_DIRECTION_COUNTER_CLOCKWISE;
Arc.arcSize := D2D1_ARC_SIZE(Ord(LineEnd - LineBegin > Pi));
if Succeeded(Geometry.Open(Sink)) then
try
Sink.BeginFigure(AxPScr(a, LineBegin), D2D1_FIGURE_BEGIN_HOLLOW);
try
Sink.AddArc(Arc);
finally
Sink.EndFigure(D2D1_FIGURE_END_OPEN);
end;
finally
Sink.Close;
end;
Canvas.RenderTarget.DrawGeometry(Geometry, Canvas.Pen.Brush.Handle, Canvas.Pen.Width, Canvas.Pen.StrokeStyle);
end;
end
else
Canvas.DrawEllipse(D2D1Ellipse(FCtl.Scr(0, 0), FView.ScaleX(a), FView.ScaleY(a)));
a := a + Distance;
Inc(LWhileGuard);
end;
end;
end;
procedure TCircularGridLineFamily.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
a: Double;
LWhileGuard: Integer;
begin
if LineLimited and (LineEnd <= LineBegin) then
Exit;
if Visible and (Distance > 0) and (aspan / Distance < 1000) then
begin
ASVG
.BeginGroup
.&Class('grid')
.&Class(Name)
.Stroke(Color)
.StrokeWidthPx(Width)
.Fill('none')
.Append;
a := amin(True) - rmod(amin(True), Distance);
LWhileGuard := 0;
while (a <= amax(True)) and (LWhileGuard < 1000) do
begin
if LineLimited then
ASVG
.Arc(FCtl.SpaceToViewbox(ASVG.ViewBox, TPoint.Zero), FView.ScaleX(a), FView.ScaleY(a), LineBegin, LineEnd)
.Append
else
ASVG
.Ellipse(FCtl.SpaceToViewbox(ASVG.ViewBox, TPoint.Zero), FView.ScaleX(a), FView.ScaleY(a))
.Append;
a := a + Distance;
Inc(LWhileGuard);
end;
ASVG.EndGroup.Append;
end;
end;
procedure TGridLineFamilies.Assign(Source: TPersistent);
begin
if Source is TGridLineFamilies then
begin
FHorizontalPrimary.Assign(TGridLineFamilies(Source).FHorizontalPrimary);
FHorizontalSecondary.Assign(TGridLineFamilies(Source).FHorizontalSecondary);
FVerticalPrimary.Assign(TGridLineFamilies(Source).FVerticalPrimary);
FVerticalSecondary.Assign(TGridLineFamilies(Source).FVerticalSecondary);
FRadialPrimary.Assign(TGridLineFamilies(Source).FRadialPrimary);
FRadialSecondary.Assign(TGridLineFamilies(Source).FRadialSecondary);
FCircular.Assign(TGridLineFamilies(Source).FCircular);
end
else if Source is TGridLineFamily then
begin
FHorizontalPrimary.Assign(TGridLineFamily(Source));
FHorizontalSecondary.Assign(TGridLineFamily(Source));
FVerticalPrimary.Assign(TGridLineFamily(Source));
FVerticalSecondary.Assign(TGridLineFamily(Source));
FRadialPrimary.Assign(TGridLineFamily(Source));
FRadialSecondary.Assign(TGridLineFamily(Source));
FCircular.Assign(TGridLineFamily(Source));
end
else
inherited;
end;
constructor TGridLineFamilies.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FHorizontalPrimary := THorizontalGridLineFamily.Create(ACtl, AView);
FHorizontalPrimary.Distance := 5;
FHorizontalPrimary.Name := 'Primary horisontal';
FHorizontalPrimary.OnChange := Changed;
FHorizontalSecondary := THorizontalGridLineFamily.Create(ACtl, AView);
FHorizontalSecondary.Distance := 1;
FHorizontalSecondary.Name := 'Secondary horisontal';
FHorizontalSecondary.OnChange := Changed;
FVerticalPrimary := TVerticalGridLineFamily.Create(ACtl, AView);
FVerticalPrimary.Distance := 5;
FVerticalPrimary.Name := 'Primary vertical';
FVerticalPrimary.OnChange := Changed;
FVerticalSecondary := TVerticalGridLineFamily.Create(ACtl, AView);
FVerticalSecondary.Distance := 1;
FVerticalSecondary.Name := 'Secondary vertical';
FVerticalSecondary.OnChange := Changed;
FRadialPrimary := TRadialGridLineFamily.Create(ACtl, AView);
FRadialPrimary.Distance := Pi/4;
FRadialPrimary.Name := 'Primary radial';
FRadialPrimary.OnChange := Changed;
FRadialSecondary := TRadialGridLineFamily.Create(ACtl, AView);
FRadialSecondary.Distance := Pi/8;
FRadialSecondary.Name := 'Secondary radial';
FRadialSecondary.OnChange := Changed;
FCircular := TCircularGridLineFamily.Create(ACtl, AView);
FCircular.Distance := 10;
FCircular.Name := 'Primary circular';
FCircular.OnChange := Changed;
Name := 'Grid lines';
OptionsFormClass := TVis2D_GridFamiliesSettingsFrm;
end;
function TGridLineFamilies.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('horizontal', FHorizontalPrimary.CreateReference);
Result.AddSubref('horizontal2', FHorizontalSecondary.CreateReference);
Result.AddSubref('vertical', FVerticalPrimary.CreateReference);
Result.AddSubref('vertical2', FVerticalSecondary.CreateReference);
Result.AddSubref('radial', FRadialPrimary.CreateReference);
Result.AddSubref('radial2', FRadialSecondary.CreateReference);
Result.AddSubref('circular', FCircular.CreateReference);
end;
destructor TGridLineFamilies.Destroy;
begin
FreeAndNil(FCircular);
FreeAndNil(FRadialSecondary);
FreeAndNil(FRadialPrimary);
FreeAndNil(FVerticalSecondary);
FreeAndNil(FVerticalPrimary);
FreeAndNil(FHorizontalSecondary);
FreeAndNil(FHorizontalPrimary);
inherited;
end;
procedure TGridLineFamilies.Draw;
begin
FCircular.Draw;
FHorizontalSecondary.Draw;
FVerticalSecondary.Draw;
FRadialSecondary.Draw;
FHorizontalPrimary.Draw;
FVerticalPrimary.Draw;
FRadialPrimary.Draw;
end;
procedure TGridLineFamilies.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
FCircular.DrawTo(ASVG);
FHorizontalSecondary.DrawTo(ASVG);
FVerticalSecondary.DrawTo(ASVG);
FRadialSecondary.DrawTo(ASVG);
FHorizontalPrimary.DrawTo(ASVG);
FVerticalPrimary.DrawTo(ASVG);
FRadialPrimary.DrawTo(ASVG);
end;
procedure TGridLineFamilies.SetCircular(const Value: TCircularGridLineFamily);
begin
FCircular.Assign(Value);
end;
procedure TGridLineFamilies.SetHorizontalPrimary(const Value: THorizontalGridLineFamily);
begin
FHorizontalPrimary.Assign(Value);
end;
procedure TGridLineFamilies.SetHorizontalSecondary(
const Value: THorizontalGridLineFamily);
begin
FHorizontalSecondary.Assign(Value);
end;
procedure TGridLineFamilies.SetRadialPrimary(const Value: TRadialGridLineFamily);
begin
FRadialPrimary.Assign(Value);
end;
procedure TGridLineFamilies.SetRadialSecondary(const Value: TRadialGridLineFamily);
begin
FRadialSecondary.Assign(Value);
end;
procedure TGridLineFamilies.SetVerticalPrimary(const Value: TVerticalGridLineFamily);
begin
FVerticalPrimary.Assign(Value);
end;
procedure TGridLineFamilies.SetVerticalSecondary(const Value: TVerticalGridLineFamily);
begin
FVerticalSecondary.Assign(Value);
end;
procedure TElementStyle.Assign(Source: TPersistent);
begin
if Source is TElementStyle then
begin
FColor := TElementStyle(Source).FColor;
FOpacity := TElementStyle(Source).FOpacity;
FBorderColor := TElementStyle(Source).FBorderColor;
FBorderWidth := TElementStyle(Source).FBorderWidth;
FDisplacement := TElementStyle(Source).FDisplacement;
Changed;
end
else
inherited;
end;
procedure TElementStyle.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'linecolor' then
BorderColor := V.ToColor
else if S = 'linewidth' then
BorderWidth := V.ToInt32
else if S = 'fillcolor' then
Color := V.ToColor
else if S = 'fillopacity' then
Opacity := EnsureRange(Round(V.ToRealNumber * Opacity.MaxValue), Opacity.MinValue, Opacity.MaxValue)
else if S = 'displacement' then
Displacement := V.ToRealNumber
end;
end;
constructor TElementStyle.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FColor := DefaultColor;
FOpacity := DefaultOpacity;
FBorderColor := DefaultBorderColor;
FBorderWidth := DefaultBorderWidth;
Name := 'Style';
OptionsFormClass := TVis2D_ElementSettingsFrm;
FElementStyleParts := [espColor, espOpacity, espBorderColor, espBorderWidth];
end;
function TElementStyle.GetOpacityFraction: Double;
begin
Result := Opacity / Opacity.MaxValue;
end;
procedure TElementStyle.SetBorderColor(const Value: TColor);
begin
if FBorderColor <> Value then
begin
FBorderColor := Value;
Changed;
end;
end;
procedure TElementStyle.SetBorderWidth(const Value: Integer);
begin
if FBorderWidth <> Value then
begin
FBorderWidth := Value;
Changed;
end;
end;
procedure TElementStyle.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
procedure TElementStyle.SetDisplacement(const Value: Double);
begin
if FDisplacement <> Value then
begin
FDisplacement := Value;
Changed;
end;
end;
procedure TElementStyle.SetOpacity(const Value: Byte);
begin
if FOpacity <> Value then
begin
FOpacity := Value;
Changed;
end;
end;
procedure TElementStyle.SetOpacityFraction(const Value: Double);
begin
Opacity := Round(Opacity.MaxValue * EnsureRange(Value, 0, 1));
end;
function TCategoryElements.MaxValue: Double;
var
Elem: TCategoryElement;
begin
Result := 0;
for Elem in Self do
if Elem.Value > Result then
Result := Elem.Value;
end;
function TCategoryElements.RelativeValues: TArray<Double>;
var
LSum: Double;
i: Integer;
begin
SetLength(Result, Count);
LSum := Sum;
if LSum <> 0 then
for i := 0 to Count - 1 do
Result[i] := Self[i].Value / LSum;
end;
function TCategoryElements.Sum: Double;
var
Elem: TCategoryElement;
begin
Result := 0;
for Elem in Self do
Result := Result + Elem.Value;
end;
procedure TCategoryElement.Assign(Source: TPersistent);
begin
if Source is TCategoryElement then
begin
FLabel := TCategoryElement(Source).FLabel;
FValue := TCategoryElement(Source).FValue;
FStyle.Assign(TCategoryElement(Source).FStyle);
Changed;
end
else
inherited;
end;
procedure TCategoryElement.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'label' then
&Label := V.ToString
else if S = 'value' then
Value := V.ToRealNumber;
end;
FStyle.Configure(ASettings);
end;
constructor TCategoryElement.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.OnChange := Changed;
Name := 'Category';
OptionsFormClass := TVis2D_CategorySettingsFrm;
end;
destructor TCategoryElement.Destroy;
begin
FreeAndNil(FStyle);
inherited;
end;
procedure TCategoryElement.SetLabel(const Value: string);
begin
if FLabel <> Value then
begin
FLabel := Value;
Changed;
end;
end;
procedure TCategoryElement.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
procedure TCategoryElement.SetValue(const Value: Double);
begin
if FValue <> Value then
begin
FValue := Value;
Changed;
end;
end;
function TCategoryChart.AddCategory(const ALabel: string;
const AValue: Double): TCategoryElement;
begin
Result := TCategoryElement.Create(FCtl, FView);
FCategories.Add(Result);
Result.&Label := ALabel;
Result.Value := AValue;
Result.OnChange := Changed;
end;
procedure TCategoryChart.Assign(Source: TPersistent);
var
Cat: TCategoryElement;
begin
if Source is TElementStyle then
begin
if Assigned(FCategories) then
for Cat in FCategories do
if Assigned(Cat) and Assigned(Cat.Style) then
Cat.Style.Assign(Source);
end
else
inherited;
end;
procedure TCategoryChart.CategoriesNotify(Sender: TObject;
const Item: TCategoryElement; Action: TCollectionNotification);
begin
Changed;
end;
procedure TCategoryChart.Clear;
begin
FCategories.Clear;
end;
procedure TCategoryChart.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'legend' then
ShowLegend := V.ToBoolean
else if S = 'labels' then
LabelVisible := V.ToBoolean
else if S = 'labelposition' then
LabelPosition := V.ToRealNumber
else if S = 'valuelabels' then
ValueLabelVisible := V.ToBoolean
else if S = 'valuelabelposition' then
ValueLabelPosition := V.ToRealNumber
else if S = 'valueformat' then
ValueFormat := V.ToString
end;
end;
constructor TCategoryChart.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FCategories := TCategoryElements.Create;
FCategories.OnNotify := CategoriesNotify;
FLegendStyle := TElementStyle.Create(ACtl, AView);
FLegendStyle.Name := 'Legend';
FLegendStyle.Color := clWhite;
FLegendStyle.OnChange := Changed;
FChartTypeName := 'Category chart';
Name := 'Category chart';
OptionsFormClass := TVis2D_CategoryChartSettingsFrm;
end;
function TCategoryChart.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('legend', FLegendStyle.CreateReference);
for var cat in FCategories do
Result.AddSubref(cat.&Label, cat.CreateReference);
end;
destructor TCategoryChart.Destroy;
begin
FreeAndNil(FLabelFont);
FreeAndNil(FValueFont);
FreeAndNil(FLegendFont);
FreeAndNil(FLegendStyle);
FreeAndNil(FCategories);
inherited;
end;
procedure TCategoryChart.Draw;
var
CR: TRect;
Cat: TCategoryElement;
W, H, LH: Double;
x, y: Double;
R: TRect;
M: TSize;
Ms: Integer;
begin
inherited;
if FShowLegend then
begin
Canvas.Brush.Color := FLegendStyle.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(FLegendStyle.Opacity / FLegendStyle.Opacity.MaxValue);
Canvas.Pen.Color := FLegendStyle.BorderColor;
Canvas.Pen.Width := FLegendStyle.BorderWidth;
Canvas.Pen.Style := psSolid;
if Assigned(FLegendFont) then
Canvas.Font.Assign(FLegendFont)
else
Canvas.Font.Assign(FCtl.Font);
M := Canvas.TextExtent('M');
Ms := Max(M.cx, M.cy);
W := 0.0;
LH := 0.0;
H := 0.0;
CR := CanvasRect;
for Cat in FCategories do
with Canvas.TextExtent(Cat.&Label) do
begin
if cx > W then
W := cx;
if (H = 0.0) and (cy <> 0.0) then
LH := cy;
end;
W := W + 2*Ms;
H := FCategories.Count * LH + (FCategories.Count - 1) * 0.25 * LH;
if W > CR.Width div 2 then
W := CR.Width div 2;
if H > CR.Height then
H := CR.Height;
if (H <= 0) or (W <= 0) then
Exit;
if not TRectD.Create(CR.Width - W - 20*3, 20, CR.Width - 20, 20*3 + H).TryToInt(R) then
Exit;
Canvas.Rectangle(R);
x := R.Left + 20;
y := R.Top + 20;
for Cat in FCategories do
begin
Canvas.Brush.Color := Cat.Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Cat.Style.Opacity / Cat.Style.Opacity.MaxValue);
Canvas.FillRect(Rect(Round(x), Round(y), Round(x + Ms), Round(y + Ms)));
Canvas.Brush.Style := bsClear;
TextOut(x + 2*Ms, y, Cat.&Label);
y := y + 1.25*LH;
end;
end;
end;
procedure TCategoryChart.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
CR: TRect;
Cat: TCategoryElement;
W, H, LH: Double;
x, y: Double;
R: TRect;
M: TSize;
Ms: Integer;
begin
inherited;
if FShowLegend then
begin
if Assigned(FLegendFont) then
Canvas.Font.Assign(FLegendFont)
else
Canvas.Font.Assign(FCtl.Font);
M := Canvas.TextExtent('M');
Ms := Max(M.cx, M.cy);
W := 0.0;
LH := 0.0;
H := 0.0;
CR := CanvasRect;
for Cat in FCategories do
with Canvas.TextExtent(Cat.&Label) do
begin
if cx > W then
W := cx;
if (H = 0.0) and (cy <> 0.0) then
LH := cy;
end;
W := W + 2*Ms;
H := FCategories.Count * LH + (FCategories.Count - 1) * 0.25 * LH;
if W > CR.Width div 2 then
W := CR.Width div 2;
if H > CR.Height then
H := CR.Height;
if (H <= 0) or (W <= 0) then
Exit;
if not TRectD.Create(CR.Width - W - 20*3, 20, CR.Width - 20, 20*3 + H).TryToInt(R) then
Exit;
ASVG
.BeginGroup
.&Class('legend')
.Append;
ASVG
.Rect(R)
.Fill(FLegendStyle.Color)
.FillOpacity(FLegendStyle.OpacityFraction)
.Stroke(FLegendStyle.BorderColor)
.StrokeWidthPx(FLegendStyle.BorderWidth)
.Append;
x := R.Left + 20;
y := R.Top + 20;
for Cat in FCategories do
begin
ASVG
.BeginGroup
.Append;
ASVG
.Rect(x, y, Ms, Ms)
.&Class('category-icon')
.Fill(Cat.Style.Color)
.FillOpacity(Cat.Style.OpacityFraction)
.Append;
ASVG
.Text(x + 2*Ms, y + 0.5*Ms, Cat.&Label)
.Font(FLegendFont)
.DominantBaseline(taVerticalCenter)
.Append;
ASVG.EndGroup.Append;
y := y + 1.25*LH;
end;
ASVG.EndGroup.Append;
end;
end;
procedure TCategoryChart.DrawToPrefix(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
ASVG
.BeginGroup
.&Class('category-chart')
.&Class(ChartTypeName.ToLower)
.Append;
ASVG.GroupTitle(Title).Append;
ASVG.GroupDescription(Description).Append;
end;
procedure TCategoryChart.DrawToSuffix(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
ASVG.EndGroup.Append;
end;
function TCategoryChart.GetLabelFont: TFont;
begin
if FLabelFont = nil then
begin
FLabelFont := TFont.Create;
if Assigned(FCtl) and Assigned(FCtl.Font) then
FLabelFont.Assign(FCtl.Font);
FLabelFont.OnChange := Changed;
end;
Result := FLabelFont;
end;
function TCategoryChart.GetLegendFont: TFont;
begin
if FLegendFont = nil then
begin
FLegendFont := TFont.Create;
if Assigned(FCtl) and Assigned(FCtl.Font) then
FLegendFont.Assign(FCtl.Font);
FLegendFont.OnChange := Changed;
end;
Result := FLegendFont;
end;
function TCategoryChart.GetValueFont: TFont;
begin
if FValueFont = nil then
begin
FValueFont := TFont.Create;
if Assigned(FCtl) and Assigned(FCtl.Font) then
FValueFont.Assign(FCtl.Font);
FValueFont.OnChange := Changed;
end;
Result := FValueFont;
end;
procedure TCategoryChart.SetCategories(const Value: TCategoryElements);
var
i: Integer;
Cat: TCategoryElement;
begin
FCategories.Clear;
if Assigned(Value) then
for i := 0 to Value.Count - 1 do
begin
Cat := TCategoryElement.Create(FCtl, FView);
FCategories.Add(Cat);
Cat.Assign(Value[i]);
Cat.OnChange := Changed;
end;
end;
procedure TCategoryChart.SetLabelFont(const Value: TFont);
begin
if FLabelFont = nil then
begin
FLabelFont := TFont.Create;
FLabelFont.OnChange := Changed;
end;
FLabelFont.Assign(Value);
end;
procedure TCategoryChart.SetLabelPosition(const Value: Double);
begin
if FLabelPosition <> Value then
begin
FLabelPosition := Value;
Changed;
end;
end;
procedure TCategoryChart.SetLabelVisible(const Value: Boolean);
begin
if FLabelVisible <> Value then
begin
FLabelVisible := Value;
Changed;
end;
end;
procedure TCategoryChart.SetLegendFont(const Value: TFont);
begin
if FLegendFont = nil then
begin
FLegendFont := TFont.Create;
FLegendFont.OnChange := Changed;
end;
FLegendFont.Assign(Value);
end;
procedure TCategoryChart.SetLegendStyle(const Value: TElementStyle);
begin
FLegendStyle.Assign(Value);
end;
procedure TCategoryChart.SetShowLegend(const Value: Boolean);
begin
if FShowLegend <> Value then
begin
FShowLegend := Value;
Changed;
end;
end;
procedure TCategoryChart.SetValueFont(const Value: TFont);
begin
if FValueFont = nil then
begin
FValueFont := TFont.Create;
FValueFont.OnChange := Changed;
end;
FValueFont.Assign(Value);
end;
procedure TCategoryChart.SetValueFormat(const Value: string);
begin
if FValueFormat <> Value then
begin
FValueFormat := Value;
Changed;
end;
end;
procedure TCategoryChart.SetValueLabelPosition(const Value: Double);
begin
if FValueLabelPosition <> Value then
begin
FValueLabelPosition := Value;
Changed;
end;
end;
procedure TCategoryChart.SetValueLabelVisible(const Value: Boolean);
begin
if FValueLabelVisible <> Value then
begin
FValueLabelVisible := Value;
Changed;
end;
end;
function TBarChart.AddBar(const ALabel: string; const AValue: Double): TCategoryElement;
begin
Result := AddCategory(ALabel, AValue);
end;
procedure TBarChart.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'baroffset' then
BarOffset := V.ToRealNumber
else if S = 'barwidth' then
BarWidth := V.ToRealNumber
else if S = 'barspacing' then
BarSpacing := V.ToRealNumber
end;
end;
constructor TBarChart.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FBarOffset := 0.5;
FBarWidth := 1;
FBarSpacing := 0.25;
FChartTypeName := 'Bar chart';
FLabelVisible := True;
FValueLabelVisible := False;
FLabelPosition := -8;
FValueLabelPosition := 8;
Name := 'Bar chart';
FDetailsOptionsFrmClass := TVis2D_BarChartSettingsFrm;
end;
procedure TBarChart.Draw;
var
i: Integer;
x: Double;
begin
if Bars = nil then
Exit;
x := FBarOffset;
for i := 0 to Bars.Count - 1 do
begin
DrawBar(Bars[i], i, x);
x := x + FBarWidth + FBarSpacing;
end;
inherited;
end;
procedure TBarChart.DrawBar(ABar: TCategoryElement; AIndex: Integer;
const AOffset: Double);
var
R: TRect;
S: string;
begin
Canvas.Brush.Color := ABar.Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(ABar.Style.Opacity / ABar.Style.Opacity.MaxValue);
Canvas.Pen.Color := ABar.Style.BorderColor;
Canvas.Pen.Width := ABar.Style.BorderWidth;
Canvas.Pen.Style := psSolid;
DrawRectSp(TRectD.Create(AOffset, ABar.Value, AOffset + FBarWidth, 0));
if Assigned(FLabelFont) then
Canvas.Font.Assign(FLabelFont)
else
Canvas.Font.Assign(FCtl.Font);
Canvas.Brush.Style := bsClear;
if FLabelVisible and FCtl.SpaceToCanvas(TRectD.Create(AOffset, 0, AOffset + FBarWidth, 0)).TryToInt(R) then
begin
S := ABar.&Label;
var Sz := Canvas.TextExtent(S);
if InRange(FLabelPosition, 0, 1) then
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
FLabelPosition * ABar.Value,
-Sz.cx div 2,
-Sz.cy div 2)
do
TextOut(X, Y, S);
end
else if FLabelPosition > 1 then
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
ABar.Value,
-Sz.cx div 2,
IfThen(ABar.Value >= 0, -Sz.cy) - Sign(ABar.Value) * Round(FLabelPosition))
do
TextOut(X, Y, S);
end
else
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
0,
-Sz.cx div 2,
IfThen(ABar.Value < 0, -Sz.cy) - Sign(ABar.Value) * Round(FLabelPosition))
do
TextOut(X, Y, S);
end;
end;
if FValueLabelVisible then
begin
if Assigned(FValueFont) then
Canvas.Font.Assign(FValueFont);
var LValueFormat := FValueFormat;
if LValueFormat.IsEmpty then
if IsInteger(ABar.Value) then
LValueFormat := '#'
else
LValueFormat := '#.00';
S := FormatFloat(LValueFormat, ABar.Value, FCtl.InvFS).Replace(HYPHEN_MINUS, MINUS_SIGN);
var Sz := Canvas.TextExtent(S);
if InRange(FValueLabelPosition, 0, 1) then
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
FValueLabelPosition * ABar.Value,
-Sz.cx div 2,
-Sz.cy div 2)
do
TextOut(X, Y, S);
end
else if FValueLabelPosition > 1 then
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
ABar.Value,
-Sz.cx div 2,
IfThen(ABar.Value >= 0, -Sz.cy) - Sign(ABar.Value) * Round(FValueLabelPosition))
do
TextOut(X, Y, S);
end
else
begin
with
FCtl.SpaceToCanvas(
AOffset + FBarWidth / 2,
0,
-Sz.cx div 2,
IfThen(ABar.Value < 0, -Sz.cy) - Sign(ABar.Value) * Round(FValueLabelPosition))
do
TextOut(X, Y, S);
end;
end;
end;
procedure TBarChart.DrawBarTo(ASVG: TSVGBuilder_VisCtl2D; ABar: TCategoryElement;
AIndex: Integer; const AOffset: Double);
begin
ASVG
.BeginGroup
.&Class('bar')
.Append;
ASVG
.Rect(FCtl.SpaceToCanvas(
TRectD.Create(AOffset, Max(0, ABar.Value), AOffset + FBarWidth, Min(0, ABar.Value))
))
.Fill(ABar.Style.Color)
.FillOpacity(ABar.Style.OpacityFraction)
.Stroke(ABar.Style.BorderColor)
.StrokeWidthPx(ABar.Style.BorderWidth)
.Append;
if FLabelVisible then
begin
if InRange(FLabelPosition, 0, 1) then
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
FLabelPosition * ABar.Value
)
),
ABar.&Label
)
.&Class('category-label')
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Font(FLabelFont)
.Append
else if FLabelPosition > 1 then
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
ABar.Value
),
0,
-Sign(ABar.Value) * Round(FLabelPosition)
),
ABar.&Label
)
.&Class('category-label')
.TextAnchor(taCenter)
.AttribIf('dominant-baseline', 'text-before-edge', ABar.Value < 0)
.Font(FLabelFont)
.Append
else
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
0
),
0,
-Sign(ABar.Value) * Round(FLabelPosition)),
ABar.&Label
)
.&Class('category-label')
.TextAnchor(taCenter)
.AttribIf('dominant-baseline', 'text-before-edge', ABar.Value >= 0)
.Font(FLabelFont)
.Append;
end;
if FValueLabelVisible then
begin
var LValueFormat := FValueFormat;
if LValueFormat.IsEmpty then
if IsInteger(ABar.Value) then
LValueFormat := '#'
else
LValueFormat := '#.00';
var S := FormatFloat(LValueFormat, ABar.Value, FCtl.InvFS).Replace(HYPHEN_MINUS, MINUS_SIGN);
if InRange(FValueLabelPosition, 0, 1) then
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
FValueLabelPosition * ABar.Value
)
),
S
)
.&Class('value-label')
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Font(FValueFont)
.Append
else if FValueLabelPosition > 1 then
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
ABar.Value
),
0,
-Sign(ABar.Value) * Round(FValueLabelPosition)
),
S
)
.&Class('value-label')
.TextAnchor(taCenter)
.AttribIf('dominant-baseline', 'text-before-edge', ABar.Value < 0)
.Font(FValueFont)
.Append
else
ASVG
.Text(
FCtl.SpaceToViewbox(ASVG.ViewBox,
TPointD.Create(
AOffset + FBarWidth / 2,
0
),
0,
-Sign(ABar.Value) * Round(FValueLabelPosition)),
S
)
.&Class('value-label')
.TextAnchor(taCenter)
.AttribIf('dominant-baseline', 'text-before-edge', ABar.Value >= 0)
.Font(FValueFont)
.Append;
end;
ASVG.EndGroup.Append;
end;
procedure TBarChart.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
i: Integer;
x: Double;
begin
if Bars = nil then
Exit;
x := FBarOffset;
for i := 0 to Bars.Count - 1 do
begin
DrawBarTo(ASVG, Bars[i], i, x);
x := x + FBarWidth + FBarSpacing;
end;
inherited;
end;
procedure TBarChart.SetBarOffset(const Value: Double);
begin
if FBarOffset <> Value then
begin
FBarOffset := Value;
Changed;
end;
end;
procedure TBarChart.SetBarSpacing(const Value: Double);
begin
if FBarSpacing <> Value then
begin
FBarSpacing := Value;
Changed;
end;
end;
procedure TBarChart.SetBarWidth(const Value: Double);
begin
if FBarWidth <> Value then
begin
FBarWidth := Value;
Changed;
end;
end;
constructor TDrawableList.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FList := TObjectList<TDrawable>.Create;
FList.OnNotify := ObjsNotify;
OptionsFormClass := TVis2D_ObjMgrFrm;
end;
destructor TDrawableList.Destroy;
begin
FreeAndNil(FList);
inherited;
end;
procedure TDrawableList.Draw(BottomLayer: Boolean);
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) and obj.Visible and (obj.BehindAxes = BottomLayer) then
obj.Draw;
end;
procedure TDrawableList.Draw;
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) and obj.Visible then
obj.Draw;
end;
procedure TDrawableList.DrawTo(ASVG: TSVGBuilder_VisCtl2D; BottomLayer: Boolean);
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) and obj.Visible and (obj.BehindAxes = BottomLayer) then
obj.DrawTo(ASVG);
end;
procedure TDrawableList.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
if Assigned(FList) then
for var obj in FList do
if Assigned(obj) and obj.Visible then
obj.DrawTo(ASVG);
end;
function TDrawableList.GetItem(Index: Integer): TDrawable;
begin
Result := FList[Index];
end;
function TDrawableList.GetItemCount: Integer;
begin
if Assigned(FList) then
Result := FList.Count
else
Result := 0;
end;
procedure TDrawableList.MoveDown(ADrawable: TDrawable);
begin
var Idx := FList.IndexOf(ADrawable);
if Idx <> -1 then
begin
FList.Move(Idx, Succ(Idx));
Changed;
end;
end;
procedure TDrawableList.MoveUp(ADrawable: TDrawable);
begin
var Idx := FList.IndexOf(ADrawable);
if Idx <> -1 then
begin
FList.Move(Idx, Pred(Idx));
Changed;
end;
end;
procedure TDrawableList.ObjsNotify(Sender: TObject; const Item: TDrawable;
Action: TCollectionNotification);
begin
Changed;
end;
procedure TDrawableList.SetItem(Index: Integer; const Value: TDrawable);
begin
FList[Index] := Value;
end;
procedure THistogram.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'binwidth' then
BinWidth := V.ToRealNumber
else if S = 'startat' then
StartAt := V.ToRealNumber
end;
FStyle.Configure(ASettings);
end;
constructor THistogram.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.OnChange := Changed;
FBinWidth := 1;
Name := 'Histogram';
OptionsFormClass := TVis2D_HistogramSettingsFrm;
end;
destructor THistogram.Destroy;
begin
FreeAndNil(FStyle);
inherited;
end;
procedure THistogram.Draw;
begin
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
for var i := 0 to High(FBinValues) do
DrawRectSp(
TRectD.Create(
FActualStartAt + FBinWidth * i,
FBinValues[i],
FActualStartAt + FBinWidth * Succ(i),
0
)
);
end;
procedure THistogram.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
ASVG
.BeginGroup
.&Class('histogram')
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
ASVG.GroupTitle(Title).Append;
ASVG.GroupDescription(Description).Append;
for var i := 0 to High(FBinValues) do
ASVG
.Rect(
FCtl.SpaceToCanvas(
TRectD.Create(
FActualStartAt + FBinWidth * i,
FBinValues[i],
FActualStartAt + FBinWidth * Succ(i),
0
)
)
)
.Append;
ASVG.EndGroup.Append;
end;
function THistogram.GetBinIndex(const Value: Double): Integer;
begin
Result := EnsureRange(
Floor((Value - FActualStartAt) / FBinWidth),
0,
High(FBinValues)
);
end;
function THistogram.GetDataLength: Integer;
begin
Result := Length(FData);
end;
function THistogram.GetMaxBinValue: Int64;
var
i: Integer;
begin
if Length(FBinValues) = 0 then
Exit(0);
Result := FBinValues[0];
for i := 1 to High(FBinValues) do
if FBinValues[i] > Result then
Result := FBinValues[i];
end;
procedure THistogram.Recompute;
var
BinCountFlt: Double;
BinCount: Integer;
x: Double;
begin
FBinValues := nil;
if FBinWidth <= 0 then
Exit;
RecomputeStartAt;
BinCountFlt := (FMaxDataValue - FActualStartAt) / FBinWidth;
if BinCountFlt > 10000000 then
Exit;
BinCount := Trunc(BinCountFlt + 1);
if BinCount = 0 then
BinCount := 1;
SetLength(FBinValues, BinCount);
for x in FData do
Inc(FBinValues[GetBinIndex(x)]);
end;
procedure THistogram.RecomputeStartAt;
begin
if FStartAt > FMinDataValue then
FActualStartAt := FStartAt - FBinWidth * Ceil((FStartAt - FMinDataValue) / FBinWidth)
else
FActualStartAt := FStartAt;
end;
procedure THistogram.SetBinWidth(const Value: Double);
begin
if Value <= 0 then
Exit;
if FBinWidth <> Value then
begin
FBinWidth := Value;
RecomputeStartAt;
Recompute;
Changed;
end;
end;
procedure THistogram.SetData(const Value: TArray<Double>);
begin
FData := Copy(Value);
if Length(FData) > 0 then
begin
FMinDataValue := MinValue(FData);
FMaxDataValue := MaxValue(FData)
end
else
begin
FMinDataValue := 0.0;
FMaxDataValue := 0.0
end;
FDataSpan := FMaxDataValue - FMinDataValue;
FStartAt := FMinDataValue;
RecomputeStartAt;
Recompute;
Changed;
end;
procedure THistogram.SetStartAt(const Value: Double);
begin
if FStartAt <> Value then
begin
FStartAt := Value;
RecomputeStartAt;
Recompute;
Changed;
end;
end;
procedure THistogram.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
procedure TXYPlot.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'pointsize' then
PointSize := V.ToInt32
else if S = 'points' then
Points := V.ToBoolean
else if S = 'lines' then
Lines := V.ToBoolean
else if S = 'area' then
Area := V.ToBoolean
end;
FStyle.Configure(ASettings);
end;
constructor TXYPlot.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.OnChange := Changed;
FPointSize := DefaultPointSize;
FPoints := True;
Name := 'XY plot';
OptionsFormClass := TVis2D_XYPlotSettingsFrm;
end;
destructor TXYPlot.Destroy;
begin
FreeAndNil(FStyle);
inherited;
end;
procedure TXYPlot.Draw;
var
i: Integer;
Trapezoid: ID2D1PathGeometry;
Sink: ID2D1GeometrySink;
D2d1Point: TD2D1Point2F;
begin
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
var FPointSizeDiv2 := FPointSize / 2;
if Assigned(FData) then
begin
if FArea and (Length(FData) >= 2) then
begin
if Succeeded(D2DFactory.CreatePathGeometry(Trapezoid)) then
begin
if Succeeded(Trapezoid.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(FCtl.P(FData[0].X, 0), D2d1Point) then
Exit;
Sink.BeginFigure(D2d1Point, D2D1_FIGURE_BEGIN_FILLED);
try
for i := 0 to High(FData) do
begin
if not FCtl.TrySpaceToD2d1(FData[i], D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
end;
if not FCtl.TrySpaceToD2d1(FCtl.P(FData[High(FData)].X, 0), D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
Canvas.FillGeometry(Trapezoid);
end;
end;
end;
if FLines and (Length(FData) >= 2) then
begin
if Succeeded(D2DFactory.CreatePathGeometry(Trapezoid)) then
begin
if Succeeded(Trapezoid.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(FData[0], D2d1Point) then
Exit;
Sink.BeginFigure(D2d1Point, D2D1_FIGURE_BEGIN_HOLLOW);
try
for i := 1 to High(FData) do
begin
if not FCtl.TrySpaceToD2d1(FData[i], D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
end;
Sink.AddLine(D2d1Point);
finally
Sink.EndFigure(D2D1_FIGURE_END_OPEN);
end;
finally
Sink.Close;
end;
Canvas.DrawGeometry(Trapezoid);
end;
end;
end;
if FPoints then
for i := Low(FData) to High(FData) do
DrawDiskSpPx(FData[i], FPointSizeDiv2);
end;
end;
procedure TXYPlot.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
var FPointSizeDiv2 := FPointSize / 2;
if Assigned(FData) and (FArea or FLines or FPoints) then
begin
ASVG
.BeginGroup
.&Class('xy-plot')
.Append;
ASVG.GroupTitle(Title).Append;
ASVG.GroupDescription(Description).Append;
if FArea and (Length(FData) >= 2) then
begin
var Vertices: TArray<TPointD>;
SetLength(Vertices, Length(FData) + 2);
Vertices[0] := FCtl.SpaceToViewbox(ASVG.ViewBox, FCtl.P(FData[0].X, 0));
for var i := 0 to High(FData) do
Vertices[i + 1] := FCtl.SpaceToViewbox(ASVG.ViewBox, FData[i]);
Vertices[High(Vertices)] := FCtl.SpaceToViewbox(ASVG.ViewBox, FCtl.P(FData[High(FData)].X, 0));
ASVG
.Polygon(Vertices)
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke('none')
.Append;
end;
if FLines and (Length(FData) >= 2) then
begin
var Vertices: TArray<TPointD>;
SetLength(Vertices, Length(FData));
for var i := 0 to High(FData) do
Vertices[i] := FCtl.SpaceToViewbox(ASVG.ViewBox, FData[i]);
ASVG
.PolyLine(Vertices)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
end;
if FPoints then
begin
ASVG
.BeginGroup
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
for var i := 0 to High(FData) do
with FCtl.SpaceToViewbox(ASVG.ViewBox, FData[i]) do
if
(x + FPointSizeDiv2 >= ASVG.ViewBox.Xmin)
and
(x - FPointSizeDiv2 <= ASVG.ViewBox.Xmax)
and
(y + FPointSizeDiv2 >= ASVG.ViewBox.Ymin)
and
(y - FPointSizeDiv2 <= ASVG.ViewBox.Ymax)
then
ASVG
.Circle(x, y, px(FPointSizeDiv2))
.Append;
ASVG.EndGroup.Append;
end;
ASVG.EndGroup.Append;
end;
end;
procedure TXYPlot.SetLines(const Value: Boolean);
begin
if FLines <> Value then
begin
FLines := Value;
Changed;
end;
end;
procedure TXYPlot.SetArea(const Value: Boolean);
begin
if FArea <> Value then
begin
FArea := Value;
Changed;
end;
end;
procedure TXYPlot.SetData(const Value: TArray<TPointD>);
begin
FData := Copy(Value);
Changed;
end;
procedure TXYPlot.SetPoints(const Value: Boolean);
begin
if FPoints <> Value then
begin
FPoints := Value;
Changed;
end;
end;
procedure TXYPlot.SetPointSize(const Value: Integer);
begin
if FPointSize <> Value then
begin
FPointSize := Value;
Changed;
end;
end;
procedure TXYPlot.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
function TPieChart.AddCategory(const ALabel: string;
const AValue: Double): TCategoryElement;
begin
Result := inherited;
Result.Style.Color := THSV.Create(rmod(120 + 30 * FCategories.Count, 360), 0.28, 0.88);
end;
function TPieChart.AddSlice(const ALabel: string;
const AValue: Double): TCategoryElement;
begin
Result := AddCategory(ALabel, AValue)
end;
procedure TPieChart.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'startangle' then
StartAngle := V.ToRealNumber
else if S = 'x' then
Origin := TPointD.Create(V.ToRealNumber, Origin.Y)
else if S = 'y' then
Origin := TPointD.Create(Origin.X, V.ToRealNumber)
else if S = 'position' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
Origin := TPointD.Create(pos[0], pos[1]);
end
else if S = 'radius' then
Radius := V.ToRealNumber
end;
end;
constructor TPieChart.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FRadius := 1;
FLabelVisible := True;
FValueLabelVisible := True;
FLabelPosition := DefaultLabelPosition;
FValueLabelPosition := 10;
FChartTypeName := 'Pie chart';
Name := 'Pie chart';
FDetailsOptionsFrmClass := TVis2D_PieChartSettingsFrm;
end;
procedure TPieChart.Draw;
var
i: Integer;
x: Double;
R: TArray<Double>;
begin
if Slices = nil then
Exit;
R := Slices.RelativeValues;
x := FStartAngle;
for i := 0 to Slices.Count - 1 do
begin
DrawSlice(Slices[i], R[i], i, x);
x := x + R[i];
end;
x := FStartAngle;
for i := 0 to Slices.Count - 1 do
begin
DrawSliceLabels(Slices[i], R[i], i, x);
x := x + R[i];
end;
inherited;
end;
procedure TPieChart.DrawSlice(ASlice: TCategoryElement; const AFraction: Double;
AIndex: Integer; const AOffset: Double);
const
GreaterThanOrEqualTo180: array[Boolean] of TD2D1ArcSize = (D2D1_ARC_SIZE_SMALL, D2D1_ARC_SIZE_LARGE);
var
Pie: ID2D1PathGeometry;
Sink: ID2D1GeometrySink;
Arc: TD2D1ArcSegment;
D2d1Point: TD2D1Point2F;
begin
Canvas.Brush.Color := ASlice.Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(ASlice.Style.Opacity / ASlice.Style.Opacity.MaxValue);
Canvas.Pen.Color := ASlice.Style.BorderColor;
Canvas.Pen.Width := ASlice.Style.BorderWidth;
Canvas.Pen.Style := psSolid;
if AFraction > 0 then
if Succeeded(D2DFactory.CreatePathGeometry(Pie)) then
begin
if Succeeded(Pie.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(FOrigin, D2d1Point) then
Exit;
Sink.BeginFigure(D2d1Point, D2D1_FIGURE_BEGIN_FILLED);
try
if not FCtl.TrySpaceToD2d1(FOrigin + FRadius * Direction(2*Pi*AOffset), D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
if not FCtl.TrySpaceToD2d1(FOrigin + FRadius * Direction(2*Pi*(AOffset + AFraction)), D2d1Point) then
Exit;
Arc.point := D2d1Point;
Arc.size := D2D1SizeF(FView.ScaleX(FRadius), FView.ScaleY(FRadius));
Arc.rotationAngle := 0.0;
Arc.sweepDirection := D2D1_SWEEP_DIRECTION_COUNTER_CLOCKWISE;
Arc.arcSize := GreaterThanOrEqualTo180[AFraction >= 0.5];
Sink.AddArc(Arc);
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
if ASlice.Style.Displacement <> 0 then
Canvas.RenderTarget.SetTransform(
TD2DMatrix3x2F.Translation(
FView.Scale(
ASlice.Style.Displacement * FRadius * Direction(2*Pi*(AOffset + AFraction / 2))
)
)
);
try
Canvas.FillGeometry(Pie);
Canvas.DrawGeometry(Pie);
finally
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity);
end;
end;
end;
end;
procedure TPieChart.DrawSliceLabels(ASlice: TCategoryElement;
const AFraction: Double; AIndex: Integer; const AOffset: Double);
var
Sz: TSize;
S: string;
begin
if AFraction <= 0 then
Exit;
if not FLabelVisible and not FValueLabelVisible then
Exit;
if ASlice.Style.Displacement <> 0 then
Canvas.RenderTarget.SetTransform(
TD2DMatrix3x2F.Translation(
FView.Scale(
ASlice.Style.Displacement * FRadius * Direction(2*Pi*(AOffset + AFraction / 2))
)
)
);
try
if Assigned(FLabelFont) then
Canvas.Font.Assign(FLabelFont)
else
Canvas.Font.Assign(FCtl.Font);
Canvas.Brush.Style := bsClear;
if FLabelVisible then
begin
S := ASlice.&Label;
Sz := Canvas.TextExtent(S);
if Sz.cx > 2 * FView.ScaleX(FRadius) then
Exit;
if Sz.cy > 2 * FView.ScaleY(FRadius) then
Exit;
if FLabelPosition < 1 then
begin
with FCtl.SpaceToCanvas(FRadius * FLabelPosition * Direction(2*Pi*(AOffset + AFraction / 2))) do
TextOut(X - Sz.Width / 2, Y - Sz.Height / 2, S);
end
else
begin
with
FCtl.SpaceToCanvas(
FRadius * Direction(2*Pi*(AOffset + AFraction / 2)),
Round(-Sz.cx / 2 + (FLabelPosition + Sz.cx / 2) * Cos(2*Pi*(AOffset + AFraction / 2))),
Round(-Sz.cy / 2 - (FLabelPosition + Sz.cy / 2) * Sin(2*Pi*(AOffset + AFraction / 2)))
)
do
TextOut(X, Y, S);
end;
end;
if FValueLabelVisible then
begin
if Assigned(FValueFont) then
Canvas.Font.Assign(FValueFont);
var LValueFormat := FValueFormat;
if LValueFormat.IsEmpty then
if IsInteger(ASlice.Value) then
LValueFormat := '#'
else
LValueFormat := '#.00';
S := FormatFloat(LValueFormat, ASlice.Value, FCtl.InvFS).Replace(HYPHEN_MINUS, MINUS_SIGN);
Sz := Canvas.TextExtent(S);
if Sz.cx > 2 * FView.ScaleX(FRadius) then
Exit;
if Sz.cy > 2 * FView.ScaleY(FRadius) then
Exit;
if FValueLabelPosition < 1 then
begin
with FCtl.SpaceToCanvas(FRadius * FValueLabelPosition * Direction(2*Pi*(AOffset + AFraction / 2))) do
TextOut(X - Sz.Width / 2, Y - Sz.Height / 2, S);
end
else
begin
with
FCtl.SpaceToCanvas(
FRadius * Direction(2*Pi*(AOffset + AFraction / 2)),
Round(-Sz.cx / 2 + (FValueLabelPosition + Sz.cx / 2) * Cos(2*Pi*(AOffset + AFraction / 2))),
Round(-Sz.cy / 2 - (FValueLabelPosition + Sz.cy / 2) * Sin(2*Pi*(AOffset + AFraction / 2)))
)
do
TextOut(X, Y, S);
end;
end;
finally
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity);
end;
end;
procedure TPieChart.DrawSliceLabelsTo(ASVG: TSVGBuilder_VisCtl2D;
ASlice: TCategoryElement; const AFraction: Double; AIndex: Integer;
const AOffset: Double);
begin
if AFraction <= 0 then
Exit;
if not FLabelVisible and not FValueLabelVisible then
Exit;
if ASlice.Style.Displacement <> 0 then
ASVG
.BeginGroup
.Transform(
Translation(
FView.Scale(
ASlice.Style.Displacement * FRadius * Direction(TwoPi * (AOffset + AFraction / 2))
)
)
)
.Append('pie slice transform');
if FLabelVisible then
if FLabelPosition < 1 then
ASVG
.Text(
FCtl.SpaceToCanvas(FLabelPosition * FRadius * Direction(TwoPi * (AOffset + AFraction / 2))),
ASlice.&Label
)
.&Class('category-label')
.Font(FLabelFont)
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Append
else
begin
if Assigned(FLabelFont) then
Canvas.Font.Assign(FLabelFont)
else
Canvas.Font.Assign(FCtl.Font);
var Sz := Canvas.TextExtent(ASlice.&Label);
ASVG
.Text(
FCtl.SpaceToCanvas(
FRadius * Direction(TwoPi * (AOffset + AFraction / 2)),
(FLabelPosition + Sz.cx / 2) * Cos(2*Pi*(AOffset + AFraction / 2)),
-(FLabelPosition + Sz.cy / 2) * Sin(2*Pi*(AOffset + AFraction / 2))
),
ASlice.&Label
)
.&Class('category-label')
.Font(FLabelFont)
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Append
end;
if FValueLabelVisible then
begin
var LValueFormat := FValueFormat;
if LValueFormat.IsEmpty then
if IsInteger(ASlice.Value) then
LValueFormat := '#'
else
LValueFormat := '#.00';
var S := FormatFloat(LValueFormat, ASlice.Value, FCtl.InvFS).Replace(HYPHEN_MINUS, MINUS_SIGN);
if FValueLabelPosition < 1 then
ASVG
.Text(
FCtl.SpaceToCanvas(FValueLabelPosition * FRadius * Direction(TwoPi * (AOffset + AFraction / 2))),
S
)
.&Class('value-label')
.Font(FValueFont)
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Append
else
begin
if Assigned(FValueFont) then
Canvas.Font.Assign(FValueFont)
else
Canvas.Font.Assign(FCtl.Font);
var Sz := Canvas.TextExtent(S);
ASVG
.Text(
FCtl.SpaceToCanvas(
FRadius * Direction(TwoPi * (AOffset + AFraction / 2)),
(FValueLabelPosition + Sz.cx / 2) * Cos(2*Pi*(AOffset + AFraction / 2)),
-(FValueLabelPosition + Sz.cy / 2) * Sin(2*Pi*(AOffset + AFraction / 2))
),
S
)
.&Class('value-label')
.Font(FValueFont)
.TextAnchor(taCenter)
.DominantBaseline(taVerticalCenter)
.Append
end;
end;
if ASVG.Undefine('pie slice transform') then
ASVG.EndGroup.Append;
end;
procedure TPieChart.DrawSliceTo(ASVG: TSVGBuilder_VisCtl2D; ASlice: TCategoryElement;
const AFraction: Double; AIndex: Integer; const AOffset: Double);
begin
if AFraction <= 0 then
Exit;
ASVG
.Sector(
FCtl.SpaceToCanvas(0, 0),
FView.ScaleX(FRadius),
FView.ScaleY(FRadius),
TwoPi * AOffset,
TwoPi * (AOffset + AFraction)
)
.&Class('slice')
.Fill(ASlice.Style.Color)
.FillOpacity(ASlice.Style.OpacityFraction)
.Stroke(ASlice.Style.BorderColor)
.Stroke(ASlice.Style.BorderWidth)
.TransformIf(
Translation(
FView.Scale(
ASlice.Style.Displacement * FRadius * Direction(TwoPi * (AOffset + AFraction / 2))
)
),
ASlice.Style.Displacement <> 0.0)
.Append;
end;
procedure TPieChart.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
i: Integer;
x: Double;
R: TArray<Double>;
begin
if Slices = nil then
Exit;
R := Slices.RelativeValues;
x := FStartAngle;
for i := 0 to Slices.Count - 1 do
begin
DrawSliceTo(ASVG, Slices[i], R[i], i, x);
x := x + R[i];
end;
x := FStartAngle;
for i := 0 to Slices.Count - 1 do
begin
DrawSliceLabelsTo(ASVG, Slices[i], R[i], i, x);
x := x + R[i];
end;
inherited;
end;
procedure TPieChart.SetOrigin(const Value: TPointD);
begin
if FOrigin <> Value then
begin
FOrigin := Value;
Changed;
end;
end;
procedure TPieChart.SetRadius(const Value: Double);
begin
if FRadius <> Value then
begin
FRadius := Value;
Changed;
end;
end;
procedure TPieChart.SetStartAngle(const Value: Double);
begin
if FStartAngle <> Value then
begin
FStartAngle := Value;
Changed;
end;
end;
procedure TPixmap.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'pixmap' then
begin
var bm := (V as TAlgosimPixmap).Value.CreateGDIBitmap;
try
Bitmap := bm;
finally
bm.Free;
end;
end
else if S = 'x' then
Rect := TRectD.Create(V.ToRealNumber, Rect.Top, V.ToRealNumber + Rect.Width, Rect.Bottom)
else if S = 'y' then
Rect := TRectD.Create(Rect.Left, V.ToRealNumber, Rect.Right, V.ToRealNumber + Rect.Height)
else if S = 'width' then
Rect := TRectD.Create(Rect.Left, Rect.Top, Rect.Left + V.ToRealNumber, Rect.Bottom)
else if S = 'height' then
Rect := TRectD.Create(Rect.Left, Rect.Top, Rect.Right, Rect.Top + V.ToRealNumber)
else if S = 'position' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
Rect := TRectD.Create(pos[0], pos[1], pos[0] + Rect.Width, pos[1] + Rect.Height);
end;
end;
FStyle.Configure(ASettings);
end;
constructor TPixmap.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FBehindAxes := True;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.Parts := [espOpacity, espBorderColor, espBorderWidth];
FStyle.BorderWidth := 0;
FStyle.OnChange := Changed;
FStyle.Name := 'Pixmap';
OptionsFormClass := TVis2D_ElementSettingsFrm;
Name := 'Pixmap';
end;
destructor TPixmap.Destroy;
begin
FD2D1Bitmap := nil;
FreeAndNil(FBitmap);
FreeAndNil(FStyle);
inherited;
end;
procedure TPixmap.Draw;
var
R: TRectD;
RR: TD2DRectF;
RRR: TRect;
begin
if FBitmap = nil then
Exit;
if FD2D1Bitmap = nil then
FD2D1Bitmap := Canvas.CreateBitmap(FBitmap);
R := FCtl.SpaceToCanvas(FRect);
RR := R;
Canvas.RenderTarget.DrawBitmap(FD2D1Bitmap, @RR, FStyle.Opacity / FStyle.Opacity.MaxValue);
if Style.BorderWidth > 0 then
begin
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
if R.TryToInt(RRR) then
Canvas.Rectangle(RRR);
end;
end;
procedure TPixmap.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
if FBitmap = nil then
Exit;
var R := FCtl.SpaceToCanvas(FRect, FRect.Top < FRect.Bottom);
var MS := TMemoryStream.Create;
var d: string;
try
FBitmap.SaveToStream(MS);
d := TNetEncoding.Base64.EncodeBytesToString(MS.Memory, MS.Size);
finally
MS.Free;
end;
if not Title.IsEmpty or not Description.IsEmpty then
begin
ASVG.BeginGroup.Append('implicit image group');
ASVG.GroupTitle(Title).Append;
ASVG.GroupDescription(Description).Append;
end;
ASVG
.Image(R, 'data:image/png;base64,' + d)
.Attrib('preserveAspectRatio', 'none')
.Opacity(Style.OpacityFraction)
.Append;
if Style.BorderWidth <> 0 then
ASVG
.Rect(R)
.&Class('image-frame')
.Fill('none')
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
if ASVG.Undefine('implicit image group') then
ASVG.EndGroup.Append;
end;
procedure TPixmap.FreeDeviceResources;
begin
FD2D1Bitmap := nil;
inherited;
end;
procedure TPixmap.SetBitmap(const Value: TBitmap);
begin
if FBitmap = nil then
FBitmap := TBitmap.Create;
FBitmap.Assign(Value);
FD2D1Bitmap := nil;
end;
procedure TPixmap.SetRect(const Value: TRectD);
begin
if FRect <> Value then
begin
FRect := Value;
Changed;
end;
end;
procedure TPixmap.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
constructor THeatmap.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Style.Name := 'Heatmap';
Name := 'Heatmap';
end;
procedure TVectorField.AddVector(const APosition: TPointD;
const AVector: TVectorD);
var
M: Double;
begin
if IsZero(AVector.Norm) then
Exit;
FVectors.Add(TVectorFieldElement.Create(APosition, AVector));
M := AVector.Norm;
if M > FMaxMag then
FMaxMag := M;
end;
procedure TVectorField.BeginAddVector;
begin
end;
procedure TVectorField.Clear;
begin
FMaxMag := 0.0;
if FVectors.Count > 0 then
begin
FVectors.Clear;
CreateMatrices;
Changed;
end;
end;
procedure TVectorField.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'arrowscale' then
ArrowScale := V.ToRealNumber
else if S = 'usemagnitude' then
UseMagnitude := V.ToBoolean
end;
FStyle.Configure(ASettings);
end;
constructor TVectorField.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FVectors := TList<TVectorFieldElement>.Create;
FMatrices := TList<TD2D1Matrix3x2F>.Create;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.BorderWidth := 0;
FStyle.OnChange := Changed;
FUseMag := True;
FBehindAxes := True;
FArrowScale := 1.0;
Name := 'Vector field';
OptionsFormClass := TVis2D_VectorFieldSettingsFrm;
end;
procedure TVectorField.CreateArrow;
var
Sink: ID2D1GeometrySink;
const
f = 1;
a = f*1.0;
b = f*10.0;
c = 0.5;
d = f*2.0;
pts: array[0..6] of TD2D1Point2F =
(
(x: a; y: b),
(x: a; y: -(1 - c) * b),
(x: a + d; y: -(1 - c) * b),
(x: 0; y: -b),
(x: -a - d; y: -(1 - c) * b),
(x: -a; y: -(1 - c) * b),
(x: -a; y: b)
);
begin
FArrow := nil;
if Succeeded(D2DFactory.CreatePathGeometry(FArrow)) then
begin
if Succeeded(FArrow.Open(Sink)) then
begin
try
Sink.BeginFigure(pts[0], D2D1_FIGURE_BEGIN_FILLED);
try
Sink.AddLines(@pts[1], Length(pts) - 1);
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
end;
end;
end;
procedure TVectorField.CreateMatrices;
var
q: Double;
S: TD2DMatrix3x2F;
const
F = 180.0 / Pi;
begin
FMatrices.Clear;
FMatrices.Capacity := FVectors.Count;
S := TD2DMatrix3x2F.Scale(FArrowScale, FArrowScale, D2d1Origin);
for var v in FVectors do
begin
if FUseMag then
begin
q := FArrowScale * v.Vector.Norm / FMaxMag;
FMatrices.Add(
TD2DMatrix3x2F.Scale(q, q, D2d1Origin)
*
TD2DMatrix3x2F.Rotation(90 - F*ArcTan2(v.Vector.Y, v.Vector.X), D2d1Origin)
)
end
else
FMatrices.Add(
S
*
TD2DMatrix3x2F.Rotation(90 - F*ArcTan2(v.Vector.Y, v.Vector.X), D2d1Origin)
);
end;
end;
destructor TVectorField.Destroy;
begin
FreeAndNil(FStyle);
FreeAndNil(FMatrices);
FreeAndNil(FVectors);
inherited;
end;
procedure TVectorField.Draw;
var
p: TD2D1Point2F;
begin
if FArrow = nil then
CreateArrow;
Canvas.Brush.Color := FStyle.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(FStyle.Opacity / FStyle.Opacity.MaxValue);
Canvas.Pen.Color := FStyle.BorderColor;
Canvas.Pen.Width := FStyle.BorderWidth;
if Assigned(FArrow) and Assigned(FMatrices) and (FVectors.Count = FMatrices.Count) then
try
for var i := 0 to FVectors.Count - 1 do
begin
if not FCtl.TrySpaceToD2d1(FVectors[i].Position, p) then
Continue;
Canvas.RenderTarget.SetTransform(FMatrices[i] * TD2DMatrix3x2F.Translation(p));
Canvas.FillGeometry(FArrow);
if Canvas.Pen.Width > 0 then
Canvas.DrawGeometry(FArrow);
end;
finally
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity)
end;
end;
procedure TVectorField.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
if (FVectors = nil) or (FVectors.Count = 0) then
Exit;
if not ASVG.HasID('vf-arrow') then
begin
ASVG
.DefSymbol('vf-arrow', '-6 -20 12 40')
.Append;
ASVG.GroupDescription('The arrow used for vector fields.').Append;
ASVG
.Polygon(
[
Point( 1, 10),
Point( 1, -5),
Point( 3, -5),
Point( 0, -10),
Point(-3, -5),
Point(-1, -5),
Point(-1, 10)
]
)
.Append;
ASVG.EndDefSymbol;
end;
var LMaxMag := IfThen(FMaxMag > 0, FMaxMag, 1);
ASVG
.BeginGroup
.&Class('vector-field')
.Fill(FStyle.Color)
.FillOpacity(FStyle.OpacityFraction)
.Stroke(FStyle.BorderColor)
.StrokeWidthPx(FStyle.BorderWidth)
.Append;
ASVG.GroupTitle(Title).Append;
ASVG.GroupDescription(Description).Append;
for var i := 0 to FVectors.Count - 1 do
ASVG
.Use('#vf-arrow')
.Transform(
Translation(FCtl.SpaceToCanvas(FVectors[i].Position))
*
RotationRad(PiDiv2 - ArcTan2(FVectors[i].Vector.Y, FVectors[i].Vector.X))
*
Scaling(FArrowScale * IfThen(FUseMag, FVectors[i].Vector.Norm / LMaxMag, 1))
*
Translation(TVectorD.Create(-6, -20))
)
.Width(12)
.Height(40)
.Append;
ASVG.EndGroup.Append;
end;
procedure TVectorField.EndAddVector;
begin
CreateMatrices;
Changed;
end;
procedure TVectorField.SetArrowScale(const Value: Double);
begin
if Value < 0 then
Exit;
if FArrowScale <> Value then
begin
FArrowScale := Value;
CreateMatrices;
Changed;
end;
end;
procedure TVectorField.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
procedure TVectorField.SetUseMag(const Value: Boolean);
begin
if FUseMag <> Value then
begin
FUseMag := Value;
CreateMatrices;
Changed;
end;
end;
constructor TVectorField.TVectorFieldElement.Create(const APosition: TPointD;
const AVector: TVectorD);
begin
Position := APosition;
Vector := AVector;
end;
constructor TDrawableOptionsFrm.Create(AOwner: TComponent;
ADrawable: TDrawable);
begin
FDrawable := ADrawable;
inherited Create(AOwner);
Initialize;
FInitialized := True;
end;
procedure TDrawableOptionsFrm.DrawableDestroyed(Sender: TObject);
begin
end;
procedure TDrawableOptionsFrm.Initialize;
begin
end;
procedure TDrawableOptionsFrm.Reassign(ADrawable: TDrawable);
begin
if Assigned(FDrawable) and Initialized then
UpdateDrawable;
FDrawable := ADrawable;
FInitialized := False;
Initialize;
FInitialized := True;
end;
procedure TDrawableOptionsFrm.UpdateDrawable;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TGeometry.Configure(ASettings: TAlgosimStructure);
begin
inherited;
FStyle.Configure(ASettings);
end;
constructor TGeometry.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FStyle := TElementStyle.Create(ACtl, AView);
FStyle.OnChange := Changed;
Name := 'Geometry';
FStyle.Name := 'Geometry';
OptionsFormClass := TVis2D_ElementSettingsFrm;
end;
destructor TGeometry.Destroy;
begin
FreeAndNil(FStyle);
inherited;
end;
procedure TGeometry.SetStyle(const Value: TElementStyle);
begin
FStyle.Assign(Value);
end;
procedure TLine.AdjustLineToMarkers(out AStart, AEnd: TPointD);
var
P, D, v: TPointD;
L, La, Lb: Double;
begin
AStart := FCtl.SpaceToCanvas(FStart);
AEnd := FCtl.SpaceToCanvas(FEnd);
P := (AStart + AEnd) / 2;
D := AEnd - AStart;
L := D.Norm;
if IsZero(L) then
Exit;
v := D / L;
La := TPointD.Distance(AStart, p);
Lb := TPointD.Distance(AEnd, p);
AStart := P - Max(0, La - FStartMarker.LineDelta) * v;
AEnd := P + Max(0, Lb - FEndMarker.LineDelta) * v;
end;
procedure TLine.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'start' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
Start := TPointD.Create(pos[0], pos[1]);
end
else if S = 'end' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
&End := TPointD.Create(pos[0], pos[1]);
end
end;
end;
constructor TLine.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Name := 'Line';
Style.Name := Name;
Style.Parts := [espBorderColor, espBorderWidth];
FStartMarker := TLineEndMarkerDrawable.Create(ACtl, AView);
FStartMarker.OnChange := Changed;
FStartMarker.Line := Self;
FStartMarker.Name := 'Start';
FEndMarker := TLineEndMarkerDrawable.Create(ACtl, AView);
FEndMarker.OnChange := Changed;
FEndMarker.Line := Self;
FEndMarker.Name := 'End';
OptionsFormClass := TVis2D_LineSettingsFrm;
end;
function TLine.CreateReference: TAlgosimReference;
begin
Result := inherited;
Result.AddSubref('start', FStartMarker.CreateReference);
Result.AddSubref('end', FEndMarker.CreateReference);
end;
destructor TLine.Destroy;
begin
FreeAndNil(FEndMarker);
FreeAndNil(FStartMarker);
inherited;
end;
procedure TLine.Draw;
var
LStart, LEnd: TPointD;
begin
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
AdjustLineToMarkers(LStart, LEnd);
DrawLine(LStart, LEnd);
FStartMarker.Draw;
FEndMarker.Draw;
end;
procedure TLine.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
LStart, LEnd: TPointD;
begin
inherited;
var LActualStart := FCtl.SpaceToCanvas(FStart);
var LActualEnd := FCtl.SpaceToCanvas(FEnd);
AdjustLineToMarkers(LStart, LEnd);
ASVG
.Line(LStart, LEnd)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.MarkerStart(FStartMarker.GetSVGID(ASVG))
.MarkerEnd(FEndMarker.GetSVGID(ASVG))
.AttribIf('asd:x1', LActualStart.X, not SameValue(LStart.X, LActualStart.X))
.AttribIf('asd:y1', LActualStart.Y, not SameValue(LStart.Y, LActualStart.Y))
.AttribIf('asd:x2', LActualEnd.X, not SameValue(LEnd.X, LActualEnd.X))
.AttribIf('asd:y2', LActualEnd.Y, not SameValue(LEnd.Y, LActualEnd.Y))
.Append;
end;
function TLine.DX: Double;
begin
Result := FEnd.X - FStart.X;
end;
function TLine.DY: Double;
begin
Result := FEnd.Y - FStart.Y;
end;
procedure TLine.SetEnd(const Value: TPointD);
begin
if FEnd <> Value then
begin
FEnd := Value;
Changed;
end;
end;
procedure TLine.SetEndMarker(const Value: TLineEndMarkerDrawable);
begin
FEndMarker.Assign(Value);
end;
procedure TLine.SetStart(const Value: TPointD);
begin
if FStart <> Value then
begin
FStart := Value;
Changed;
end;
end;
procedure TLine.SetStartMarker(const Value: TLineEndMarkerDrawable);
begin
FStartMarker.Assign(Value);
end;
procedure TRectangle.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'top' then
Rect := TRectD.Create(Rect.Left, V.ToRealNumber, Rect.Right, Rect.Bottom)
else if S = 'left' then
Rect := TRectD.Create(V.ToRealNumber, Rect.Top, Rect.Right, Rect.Bottom)
else if S = 'right' then
Rect := TRectD.Create(Rect.Left, Rect.Top, V.ToRealNumber, Rect.Bottom)
else if S = 'bottom' then
Rect := TRectD.Create(Rect.Left, Rect.Top, Rect.Right, V.ToRealNumber)
else if S = 'rotation' then
Angle := V.ToRealNumber
end;
end;
constructor TRectangle.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Name := 'Rectangle';
Style.Name := Name;
Style.Parts := [espColor, espOpacity, espBorderColor, espBorderWidth];
end;
procedure TRectangle.Draw;
begin
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
if FRotAngle = 0.0 then
DrawRectSp(FRect)
else
DrawRectSp(FRect, FRotAngle);
end;
procedure TRectangle.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
var R := FCtl.SpaceToCanvas(FRect, True);
ASVG
.Rect(R)
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.TransformIf(RotationRad(-FRotAngle, R.Left, R.Bottom), FRotAngle <> 0.0)
.Append;
end;
procedure TRectangle.SetRect(const Value: TRectD);
begin
if FRect <> Value then
begin
FRect := Value;
Changed;
end;
end;
procedure TRectangle.SetRotAngle(const Value: Double);
begin
if FRotAngle <> Value then
begin
FRotAngle := Value;
Changed;
end;
end;
procedure TCircle.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'position' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
Center := TPointD.Create(pos[0], pos[1]);
end
else if S = 'radius' then
Radius := V.ToRealNumber
end;
end;
constructor TCircle.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Name := 'Circle';
FRadius := 1.0;
Style.Name := Name;
Style.Parts := [espColor, espOpacity, espBorderColor, espBorderWidth];
end;
procedure TCircle.Draw;
begin
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
DrawDiskSp(FCenter, FRadius);
end;
procedure TCircle.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
ASVG
.Ellipse2(
FCtl.SpaceToCanvas(FCenter),
FView.ScaleX(FRadius),
FView.ScaleY(FRadius)
)
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
end;
procedure TCircle.SetCenter(const Value: TPointD);
begin
if FCenter <> Value then
begin
FCenter := Value;
Changed;
end;
end;
procedure TCircle.SetRadius(const Value: Double);
begin
if FRadius <> Value then
begin
FRadius := Value;
Changed;
end;
end;
procedure TPolygon.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'vertices' then
Points := ASOToR2Array(V)
end;
end;
constructor TPolygon.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
Name := 'Polygon';
Style.Name := Name;
Style.Parts := [espColor, espOpacity, espBorderColor, espBorderWidth];
end;
procedure TPolygon.Draw;
var
Polygon: ID2D1PathGeometry;
Sink: ID2D1GeometrySink;
pts: TArray<TD2D1Point2F>;
i: Integer;
begin
if (Style.Opacity <> 0) or (Style.BorderWidth > 0) then
begin
if Length(FPoints) < 3 then
Exit;
SetLength(pts, Length(FPoints));
for i := 0 to High(FPoints) do
if not FCtl.TrySpaceToD2d1(FPoints[i], pts[i]) then
Exit;
if Succeeded(D2DFactory.CreatePathGeometry(Polygon)) then
begin
if Succeeded(Polygon.Open(Sink)) then
begin
try
Sink.BeginFigure(pts[0], D2D1_FIGURE_BEGIN_FILLED);
try
Sink.AddLines(@pts[1], Length(pts) - 1);
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
end;
end;
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
if Style.Opacity <> 0 then
Canvas.FillGeometry(Polygon);
if Style.BorderWidth > 0 then
Canvas.DrawGeometry(Polygon);
end;
end;
procedure TPolygon.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
var LPoints: TArray<TPointD>;
SetLength(LPoints, Length(FPoints));
for var i := 0 to High(FPoints) do
LPoints[i] := FCtl.SpaceToCanvas(FPoints[i]);
ASVG
.Polygon(LPoints)
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
end;
procedure TPolygon.SetPoints(const Value: TArray<TPointD>);
begin
FPoints := Copy(Value);
Changed;
end;
procedure TText.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'text' then
Text := V.ToString
else if S = 'fontname' then
Font.Name := V.ToString
else if S = 'fontsize' then
Font.Size := V.ToInt32
else if S = 'bold' then
if V.ToBoolean then
Font.Style := Font.Style + [fsBold]
else
Font.Style := Font.Style - [fsBold]
else if S = 'italic' then
if V.ToBoolean then
Font.Style := Font.Style + [fsItalic]
else
Font.Style := Font.Style - [fsItalic]
else if S = 'underline' then
if V.ToBoolean then
Font.Style := Font.Style + [fsUnderline]
else
Font.Style := Font.Style - [fsUnderline]
else if S = 'strikethrough' then
if V.ToBoolean then
Font.Style := Font.Style + [fsStrikeout]
else
Font.Style := Font.Style - [fsStrikeout]
else if S = 'textcolor' then
Font.Color := V.ToColor
else if S = 'boxed' then
Boxed := V.ToBoolean
else if S = 'position' then
begin
var pos := V.AsRealVector;
if pos.Dimension = 2 then
Position := TPointD.Create(pos[0], pos[1]);
end
else if S = 'width' then
Width := V.ToRealNumber
else if S = 'height' then
Height := V.ToRealNumber
else if S = 'userect' then
UseRect := V.ToBoolean
else if S = 'anchorpoint' then
AnchorPoint := TAnchorPoint.FromString(V.ToString)
else if S = 'zoomtext' then
ZoomText := V.ToBoolean
else if S = 'zoomrect' then
ZoomRect := V.ToBoolean
else if S = 'alignment' then
Align := AlignmentFromString(V.ToString)
else if S = 'verticalalignment' then
VertAlign := VerticalAlignmentFromString(V.ToString)
else if S = 'padding' then
Padding := V.ToInt32
else if S = 'textanchorpoint' then
TextAnchorPoint := TAnchorPoint.FromString(V.ToString)
end;
end;
constructor TText.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FFont := TFont.Create;
FFont.Assign(ACtl.Font);
FFont.OnChange := Changed;
FText := 'Text';
Name := 'Text';
Style.Name := Name;
Style.Parts := [espColor, espOpacity, espBorderColor, espBorderWidth];
Style.Opacity := 64;
FPadding := 4;
FAlign := taCenter;
FVertAlign := taVerticalCenter;
OptionsFormClass := TVis2D_TextSettingsFrm;
end;
destructor TText.Destroy;
begin
FreeAndNil(FFont);
inherited;
end;
procedure TText.Draw;
const
HorizontalAlignments: array[TAlignment] of TTextFormats =
(tfLeft, tfRight, tfCenter);
VerticalAlignments: array[TVerticalAlignment] of TTextFormats =
(tfTop, tfBottom, tfVerticalCenter);
var
R: TRect;
S: string;
Sz: TSize;
W, H: Double;
begin
inherited;
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
Canvas.Font.Assign(FFont);
S := FText;
Sz := Canvas.TextExtent(S);
if not FCtl.SpaceToCanvas(FPosition).TryToInt(R.TopLeft) then
Exit;
if FUseRect then
begin
if FZoomRect then
begin
W := FView.ScaleX(FWidth);
H := FView.ScaleY(FHeight)
end
else
begin
W := FWidth;
H := FHeight
end;
if not InRange(W, 0, Integer.MaxValue) or not InRange(H, 0, Integer.MaxValue) then
Exit;
R.Width := Round(W);
R.Height := Round(H);
end
else
begin
R.Width := Sz.cx + 2*FPadding;
R.Height := Sz.cy + 2*FPadding;
end;
AlignRect(R, FAnchorPoint);
if FBoxed then
Canvas.Rectangle(R);
Canvas.Brush.Style := bsClear;
if FZoomText then
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Scale(10 / FView.XSpan, 10 / FView.YSpan, R.CenterPoint));
try
if FUseRect then
Canvas.TextRect(R, S,
[tfSingleLine, HorizontalAlignments[FAlign], VerticalAlignments[FVertAlign]])
else
Canvas.TextOut(R.Left + FPadding, R.Top + FPadding, S);
finally
if FZoomText then
Canvas.RenderTarget.SetTransform(TD2DMatrix3x2F.Identity);
end;
end;
procedure TText.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
Canvas.Font.Assign(FFont);
var Sz := Canvas.TextExtent(FText);
var R: TRectD;
R.TopLeft := FCtl.SpaceToCanvas(FPosition);
if FUseRect then
begin
var W, H: Double;
if FZoomRect then
begin
W := FView.ScaleX(FWidth);
H := FView.ScaleY(FHeight)
end
else
begin
W := FWidth;
H := FHeight
end;
R.Width := W;
R.Height := H;
end
else
begin
R.Width := Sz.cx + 2*FPadding;
R.Height := Sz.cy + 2*FPadding;
end;
AlignRect(R, FAnchorPoint);
if FBoxed then
ASVG
.Rect(R)
.&Class('text-frame')
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
var P := R.TopLeft;
if FUseRect then
begin
case FAlign of
taLeftJustify:
P.X := R.Left;
taCenter:
P.X := R.MidPoint.X;
taRightJustify:
P.X := R.Right;
end;
case FVertAlign of
taAlignTop:
P.Y := R.Top;
taVerticalCenter:
P.Y := R.MidPoint.Y;
taAlignBottom:
P.Y := R.Bottom;
end;
end
else
P := R.TopLeft + TVectorD.Create(FPadding, FPadding);
var txt :=
ASVG
.Text(P, FText)
.Font(FFont);
if FUseRect then
txt := txt
.TextAnchor(FAlign)
.DominantBaseline(FVertAlign)
else
txt := txt
.DominantBaseline(taAlignTop);
txt.Append;
end;
function TText.GetTextAnchorPoint: TAnchorPoint;
const
AnchorPoints: array[TAlignment, TVerticalAlignment] of TAnchorPoint =
(
(apTopLeft, apBottomLeft, apLeft),
(apTopRight, apBottomRight, apRight),
(apTop, apBottom, apCenter)
);
begin
Result := AnchorPoints[FAlign, FVertAlign];
end;
procedure TText.SetAlign(const Value: TAlignment);
begin
if FAlign <> Value then
begin
FAlign := Value;
Changed;
end;
end;
procedure TText.SetAnchorPoint(const Value: TAnchorPoint);
begin
if FAnchorPoint <> Value then
begin
FAnchorPoint := Value;
Changed;
end;
end;
procedure TText.SetBoxed(const Value: Boolean);
begin
if FBoxed <> Value then
begin
FBoxed := Value;
Changed;
end;
end;
procedure TText.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
end;
procedure TText.SetHeight(const Value: Double);
begin
if FHeight <> Value then
begin
FHeight := Value;
Changed;
end;
end;
procedure TText.SetPadding(const Value: Integer);
begin
if FPadding <> Value then
begin
FPadding := Value;
Changed;
end;
end;
procedure TText.SetPosition(const Value: TPointD);
begin
if FPosition <> Value then
begin
FPosition := Value;
Changed;
end;
end;
procedure TText.SetText(const Value: string);
begin
if FText <> Value then
begin
FText := Value;
Changed;
end;
end;
procedure TText.SetTextAnchorPoint(const Value: TAnchorPoint);
begin
case Value of
apTopLeft,
apTop,
apTopRight:
VertAlign := taAlignTop;
apLeft,
apCenter,
apRight:
VertAlign := taVerticalCenter;
apBottomLeft,
apBottom,
apBottomRight:
VertAlign := taAlignBottom;
end;
case Value of
apTopLeft,
apLeft,
apBottomLeft:
Align := taLeftJustify;
apTop,
apCenter,
apBottom:
Align := taCenter;
apTopRight,
apRight,
apBottomRight:
Align := taRightJustify;
end;
end;
procedure TText.SetUseRect(const Value: Boolean);
begin
if FUseRect <> Value then
begin
FUseRect := Value;
Changed;
end;
end;
procedure TText.SetVertAlign(const Value: TVerticalAlignment);
begin
if FVertAlign <> Value then
begin
FVertAlign := Value;
Changed;
end;
end;
procedure TText.SetWidth(const Value: Double);
begin
if FWidth <> Value then
begin
FWidth := Value;
Changed;
end;
end;
procedure TText.SetZoomRect(const Value: Boolean);
begin
if FZoomRect <> Value then
begin
FZoomRect := Value;
Changed;
end;
end;
procedure TText.SetZoomText(const Value: Boolean);
begin
if FZoomText <> Value then
begin
FZoomText := Value;
Changed;
end;
end;
class function TLineEndMarkerHelper.FromString(const S: string): TLineEndMarker;
begin
for var lem := Low(TLineEndMarker) to High(TLineEndMarker) do
if lem.ToString = S then
Exit(lem);
raise Exception.CreateFmt('Unknown line end marker: "%s"', [S]);
end;
function TLineEndMarkerHelper.IsFilled: Boolean;
begin
Result := Self in [lemSolidArrow, lemSemiArrow, lemDisk, lemSquare, lemSquare2];
end;
function TLineEndMarkerHelper.ToString: string;
begin
if InRange(Ord(Self), Ord(Low(TLineEndMarker)), Ord(High(TLineEndMarker))) then
Result := MarkerNames[Self]
else
Result := '';
end;
procedure TLineEndMarkerDrawable.AdaptToLine;
begin
if FLine = nil then
Exit;
FWidth := FLine.Style.BorderWidth;
if FLine.FEndMarker = Self then
begin
FPoint := FLine.&End;
FAngle := ArcTan2(-FView.ScaleY(FLine.DY), FView.ScaleX(FLine.DX));
end
else
begin
FPoint := FLine.Start;
FAngle := Pi + ArcTan2(-FView.ScaleY(FLine.DY), FView.ScaleX(FLine.DX));
end
end;
procedure TLineEndMarkerDrawable.Assign(Source: TPersistent);
begin
if Source is TLineEndMarkerDrawable then
begin
FLineEndMarker := TLineEndMarkerDrawable(Source).FLineEndMarker;
FPoint := TLineEndMarkerDrawable(Source).FPoint;
FAngle := TLineEndMarkerDrawable(Source).FAngle;
FSizeX := TLineEndMarkerDrawable(Source).FSizeX;
FSizeY := TLineEndMarkerDrawable(Source).FSizeY;
FWidth := TLineEndMarkerDrawable(Source).FWidth;
FColor := TLineEndMarkerDrawable(Source).FColor;
end
else
inherited;
end;
procedure TLineEndMarkerDrawable.Configure(ASettings: TAlgosimStructure);
var
i: Integer;
S: string;
V: TAlgosimObject;
begin
inherited;
for i := 1 to ASettings.MemberCount do
begin
S := ASettings.Members[i].Name;
V := ASettings.Members[i].Value;
if S = 'shape' then
Kind := TLineEndMarker.FromString(V.ToString)
else if S = 'filled' then
Filled := V.ToBoolean
else if S = 'sizex' then
SizeX := V.ToRealNumber
else if S = 'sizey' then
SizeY := V.ToRealNumber
else if S = 'size' then
Size := V.ToRealNumber
else if S = 'linewidth' then
Width := V.ToInt32
else if S = 'color' then
Color := V.ToColor
else if S = 'linecolor' then
LineColor := V.ToBoolean
end;
end;
constructor TLineEndMarkerDrawable.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FFilled := True;
FSizeX := 4.0;
FSizeY := 4.0;
FWidth := 1;
FColor := clNavy;
FLineColor := True;
FName := 'Line ending';
OptionsFormClass := TVis2D_LineEndSettingsFrm;
end;
procedure TLineEndMarkerDrawable.Draw;
var
LColor: TColor;
begin
inherited;
if FLineEndMarker = lemNone then
Exit;
if Assigned(FLine) then
AdaptToLine
else
Exit;
if Assigned(FLine) and FLineColor then
LColor := FLine.Style.BorderColor
else
LColor := FColor;
Canvas.Brush.Color := LColor;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := LColor;
Canvas.Pen.Width := FWidth;
Canvas.Pen.Style := psSolid;
DrawLineEndMarker(FLineEndMarker, FFilled, FPoint, FSizeX, FSizeY, FAngle);
end;
procedure TLineEndMarkerDrawable.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
begin
inherited;
end;
function TLineEndMarkerDrawable.GetSVGID(ASVG: TSVGBuilder_VisCtl2D): string;
var
LColor: TColor;
begin
Result := '';
if FLineEndMarker = lemNone then
Exit;
if Assigned(FLine) then
AdaptToLine
else
Exit;
if FLineColor then
LColor := FLine.Style.BorderColor
else
LColor := FColor;
var LMarkerDef := Default(TSVGBuilder_VisCtl2D.TMarkerDef);
LMarkerDef.Shape := FLineEndMarker;
LMarkerDef.Filled := FFilled;
LMarkerDef.Start := FLine.FStartMarker = Self;
LMarkerDef.Width := Round(FSizeX / LMarkerDef.SizeUnit);
LMarkerDef.Height := Round(FSizeY / LMarkerDef.SizeUnit);
LMarkerDef.LineWidth := FLine.Style.BorderWidth;
LMarkerDef.Color := LColor;
Result := ASVG.GetMarkerName(FCtl, LMarkerDef, LineDelta);
end;
function TLineEndMarkerDrawable.LineDelta: Double;
begin
case Kind of
lemNone:
Result := 0.0;
lemLineArrow:
if Assigned(FLine) then
Result := FLine.Style.BorderWidth
else
Result := FWidth;
lemSolidArrow:
Result := FSizeY * LEM_CONST * Sqrt2;
lemSemiArrow:
Result := FSizeY * LEM_CONST * InvSqrt2;
lemDisk:
if FFilled then
Result := 0.0
else
Result := FSizeY * LEM_CONST / 2;
lemSquare:
if FFilled then
Result := 0.0
else
Result := FSizeY * LEM_CONST * InvSqrt2;
lemSquare2:
if FFilled then
Result := 0.0
else
Result := FSizeY * LEM_CONST / 2;
lemLine:
Result := 0.0;
lemBroken:
if Assigned(FLine) then
Result := -FLine.Style.BorderWidth / 2
else
Result := -FWidth / 2;
else
Result := 0.0;
end;
end;
procedure TLineEndMarkerDrawable.SetAngle(const Value: Double);
begin
if FAngle <> Value then
begin
FAngle := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetFilled(const Value: Boolean);
begin
if FFilled <> Value then
begin
FFilled := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetLineColor(const Value: Boolean);
begin
if FLineColor <> Value then
begin
FLineColor := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetLineEndMarker(const Value: TLineEndMarker);
begin
if FLineEndMarker <> Value then
begin
FLineEndMarker := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetPoint(const Value: TPointD);
begin
if FPoint <> Value then
begin
FPoint := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetSize(const Value: Double);
begin
if (FSizeX <> Value) or (FSizeY <> Value) then
begin
FSizeX := Value;
FSizeY := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetSizeX(const Value: Double);
begin
if FSizeX <> Value then
begin
FSizeX := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetSizeY(const Value: Double);
begin
if FSizeY <> Value then
begin
FSizeY := Value;
Changed;
end;
end;
procedure TLineEndMarkerDrawable.SetWidth(const Value: Integer);
begin
if FWidth <> Value then
begin
FWidth := Value;
Changed;
end;
end;
constructor TRegion.Create(ACtl: TVisCtl2D; AView: TView2D);
begin
inherited;
FPoints := False;
FLines := False;
FArea := True;
FValidateRegion := True;
Name := 'Region';
end;
procedure TRegion.Draw;
var
i: Integer;
Trapezoid: ID2D1PathGeometry;
Sink: ID2D1GeometrySink;
D2d1Point: TD2D1Point2F;
PntFcn: function(const X1, X2: Double): TPointD;
UnboundMin, UnboundMax: function(const APoint: TD2D1Point2F): TD2D1Point2F of object;
begin
Canvas.Brush.Color := Style.Color;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Handle.SetOpacity(Style.Opacity / Style.Opacity.MaxValue);
Canvas.Pen.Color := Style.BorderColor;
Canvas.Pen.Width := Style.BorderWidth;
Canvas.Pen.Style := psSolid;
var FPointSizeDiv2 := FPointSize / 2;
case FAxis of
TCartesianAxis.X:
begin
PntFcn := FCtl.P;
UnboundMin := FCtl.UnboundYMin;
UnboundMax := FCtl.UnboundYMax;
end;
TCartesianAxis.Y:
begin
PntFcn := FCtl.Q;
UnboundMin := FCtl.UnboundXMin;
UnboundMax := FCtl.UnboundXMax;
end;
else
Exit;
end;
if not FUnboundedMin then
UnboundMin := FCtl.UnboundIdentity;
if not FUnboundedMax then
UnboundMax := FCtl.UnboundIdentity;
if Assigned(FSliceData) then
begin
if FArea and (Length(FSliceData) >= 2) then
begin
if Succeeded(D2DFactory.CreatePathGeometry(Trapezoid)) then
begin
if Succeeded(Trapezoid.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[0].t, FSliceData[0].a), D2d1Point) then
Exit;
Sink.BeginFigure(UnboundMin(D2d1Point), D2D1_FIGURE_BEGIN_FILLED);
try
for i := 1 to High(FSliceData) do
begin
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[i].t, FSliceData[i].a), D2d1Point) then
Exit;
Sink.AddLine(UnboundMin(D2d1Point));
end;
for i := High(FSliceData) downto 0 do
begin
if (FSliceData[i].b >= FSliceData[i].a) or not FValidateRegion then
begin
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[i].t, FSliceData[i].b), D2d1Point) then
Exit;
end
else
begin
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[i].t, FSliceData[i].a), D2d1Point) then
Exit;
end;
Sink.AddLine(UnboundMax(D2d1Point));
end;
finally
Sink.EndFigure(D2D1_FIGURE_END_CLOSED);
end;
finally
Sink.Close;
end;
Canvas.FillGeometry(Trapezoid);
end;
end;
end;
if FLines and (Length(FSliceData) >= 2) then
begin
if not FUnboundedMin and Succeeded(D2DFactory.CreatePathGeometry(Trapezoid)) then
begin
if Succeeded(Trapezoid.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[0].t, FSliceData[0].a), D2d1Point) then
Exit;
Sink.BeginFigure(D2d1Point, D2D1_FIGURE_BEGIN_HOLLOW);
try
for i := 1 to High(FSliceData) do
begin
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[i].t, FSliceData[i].a), D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
end;
finally
Sink.EndFigure(D2D1_FIGURE_END_OPEN);
end;
finally
Sink.Close;
end;
Canvas.DrawGeometry(Trapezoid);
end;
end;
if not FUnboundedMax and Succeeded(D2DFactory.CreatePathGeometry(Trapezoid)) then
begin
if Succeeded(Trapezoid.Open(Sink)) then
begin
try
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[0].t, FSliceData[0].b), D2d1Point) then
Exit;
Sink.BeginFigure(D2d1Point, D2D1_FIGURE_BEGIN_HOLLOW);
try
for i := 1 to High(FSliceData) do
begin
if not FCtl.TrySpaceToD2d1(PntFcn(FSliceData[i].t, FSliceData[i].b), D2d1Point) then
Exit;
Sink.AddLine(D2d1Point);
end;
finally
Sink.EndFigure(D2D1_FIGURE_END_OPEN);
end;
finally
Sink.Close;
end;
Canvas.DrawGeometry(Trapezoid);
end;
end;
end;
if FPoints then
for i := Low(FSliceData) to High(FSliceData) do
begin
if not FUnboundedMin then
DrawDiskSpPx(PntFcn(FSliceData[i].t, FSliceData[i].a), FPointSizeDiv2);
if not FUnboundedMax then
DrawDiskSpPx(PntFcn(FSliceData[i].t, FSliceData[i].b), FPointSizeDiv2);
end;
end;
end;
procedure TRegion.DrawToContent(ASVG: TSVGBuilder_VisCtl2D);
var
PntFcn: function(const X1, X2: Double): TPointD;
UnboundMin, UnboundMax: function(const APoint: TD2DPoint2f): TD2DPoint2f of object;
begin
inherited;
if FSliceData = nil then
Exit;
var FPointSizeDiv2 := FPointSize / 2;
case FAxis of
TCartesianAxis.X:
begin
PntFcn := FCtl.P;
UnboundMin := FCtl.UnboundYMin;
UnboundMax := FCtl.UnboundYMax;
end;
TCartesianAxis.Y:
begin
PntFcn := FCtl.Q;
UnboundMin := FCtl.UnboundXMin;
UnboundMax := FCtl.UnboundXMax;
end;
else
Exit;
end;
if not FUnboundedMin then
UnboundMin := FCtl.UnboundIdentity;
if not FUnboundedMax then
UnboundMax := FCtl.UnboundIdentity;
if FArea and (Length(FSliceData) >= 2) then
begin
var pts: TArray<TPointD>;
SetLength(pts, Length(FSliceData) * 2);
for var i := 0 to High(FSliceData) do
pts[i] := UnboundMin(FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].a)));
for var i := High(FSliceData) downto 0 do
if (FSliceData[i].b >= FSliceData[i].a) or not FValidateRegion then
pts[Length(FSliceData) + High(FSliceData) - i] :=
UnboundMax(FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].b)))
else
pts[Length(FSliceData) + High(FSliceData) - i] :=
UnboundMax(FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].a)));
ASVG
.Polygon(pts)
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke('none')
.Append;
end;
if FLines and (Length(FSliceData) >= 2) then
begin
if not FUnboundedMin then
begin
var pts: TArray<TPointD>;
SetLength(pts, Length(FSliceData));
for var i := 0 to High(FSliceData) do
pts[i] := FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].a));
ASVG
.PolyLine(pts)
.&Class('low-bound')
.Fill('none')
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
end;
if not FUnboundedMax then
begin
var pts: TArray<TPointD>;
SetLength(pts, Length(FSliceData));
for var i := 0 to High(FSliceData) do
pts[i] := FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].b));
ASVG
.PolyLine(pts)
.&Class('high-bound')
.Fill('none')
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
end;
end;
if FPoints then
begin
ASVG
.BeginGroup
.Fill(Style.Color)
.FillOpacity(Style.OpacityFraction)
.Stroke(Style.BorderColor)
.StrokeWidthPx(Style.BorderWidth)
.Append;
if not FUnboundedMin then
begin
ASVG
.BeginGroup
.&Class('low-bound')
.Append;
for var i := 0 to High(FSliceData) do
ASVG
.Circle(FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].a)), FPointSizeDiv2)
.Append;
ASVG.EndGroup.Append;
end;
if not FUnboundedMax then
begin
ASVG
.BeginGroup
.&Class('high-bound')
.Append;
for var i := 0 to High(FSliceData) do
ASVG
.Circle(FCtl.SpaceToCanvas(PntFcn(FSliceData[i].t, FSliceData[i].b)), FPointSizeDiv2)
.Append;
ASVG.EndGroup.Append;
end;
ASVG.EndGroup.Append;
end;
end;
procedure TRegion.SetAxis(const Value: TCartesianAxis);
begin
if FAxis <> Value then
begin
FAxis := Value;
Changed;
end;
end;
procedure TRegion.SetSliceData(const Value: TArray<TSlice>);
begin
FSliceData := Copy(Value);
Changed;
end;
procedure TRegion.SetUnboundedMax(const Value: Boolean);
begin
if FUnboundedMax <> Value then
begin
FUnboundedMax := Value;
Changed;
end;
end;
procedure TRegion.SetUnboundedMin(const Value: Boolean);
begin
if FUnboundedMin <> Value then
begin
FUnboundedMin := Value;
Changed;
end;
end;
procedure TRegion.SetValidateRegion(const Value: Boolean);
begin
if FValidateRegion <> Value then
begin
FValidateRegion := Value;
Changed;
end;
end;
constructor TSlice.Create(const t, a, b: Double);
begin
Self.t := t;
Self.a := a;
Self.b := b;
end;
function TSVGExportOptions.AutomaticAspectRatio: Boolean;
begin
Result := (Width = 0) or (Height = 0);
end;
function TSVGExportOptions.AutomaticHeight: Boolean;
begin
result := Height = 0;
end;
function TSVGExportOptions.AutomaticSize: Boolean;
begin
Result := (Width = 0) and (Height = 0);
end;
function TSVGExportOptions.AutomaticWidth: Boolean;
begin
Result := Width = 0;
end;
procedure TSVGExportOptions.SetDimensionsFromText(const AWidth,
AHeight: string);
procedure ParseValue(const S: string; out V: Double; out U: string);
begin
if S.Trim.IsEmpty then
begin
V := 0.0;
U := '';
Exit;
end;
var Vs: string;
U := '';
Vs := S;
for var KnownUnit in SVGLengthUnits do
if not KnownUnit.IsEmpty and S.EndsWith(KnownUnit, True) then
begin
U := KnownUnit;
Vs := Copy(S, 1, S.Length - U.Length);
Break;
end;
try
V := StrToFloat(Vs);
except
V := StrToFloat(Vs, TFormatSettings.Invariant);
end;
end;
var
WValue, HValue: Double;
WUnit, HUnit: string;
begin
ParseValue(AWidth, WValue, WUnit);
ParseValue(AHeight, HValue, HUnit);
if (WUnit <> HUnit) and (WValue <> 0) and (HValue <> 0) then
raise ESVGException.Create('Width and height units do not match.');
if WValue < 0 then
raise ESVGException.Create('Width must not be negative.');
if HValue < 0 then
raise ESVGException.Create('Height must not be negative.');
Self.Width := WValue;
Self.Height := HValue;
if WValue <> 0 then
Self.LengthUnit := WUnit
else
Self.LengthUnit := HUnit;
end;
function TSVGExportOptions.SpecificAspectRatio: Boolean;
begin
Result := (Width <> 0) and (Height <> 0);
end;
function TSVGExportOptions.SpecificHeight: Boolean;
begin
Result := Height <> 0;
end;
function TSVGExportOptions.SpecificSize: Boolean;
begin
Result := (Width <> 0) and (Height <> 0);
end;
function TSVGExportOptions.SpecificWidth: Boolean;
begin
Result := Width <> 0;
end;
procedure TSVGExportOptions.Validate;
begin
if
(Width < 0)
or
(Height < 0)
or
(IndexStr(LengthUnit, SVGLengthUnits) = -1)
then
raise ESVGException.Create('Invalid SVG export options.');
end;
constructor TSVGBuilder_VisCtl2D.Create(AAbstract: Boolean);
begin
inherited;
FMarkerDict := TMarkerDict.Create;
end;
destructor TSVGBuilder_VisCtl2D.Destroy;
begin
FreeAndNil(FMarkerDict);
inherited;
end;
function TSVGBuilder_VisCtl2D.GetMarkerName(ACtl: TVisCtl2D;
const AMarkerDef: TMarkerDef; const ALineDelta: Double): string;
var
LMarkerData: TMarkerData;
begin
if FMarkerDict.TryGetValue(AMarkerDef, LMarkerData) then
Exit(LMarkerData.Name);
var LFilled := AMarkerDef.Filled and AMarkerDef.Shape.IsFilled;
Result := AMarkerDef.GetName;
var LMarkerTag := DefMarker
(
Result,
TViewBox.Create(-100, -100, 200, 200, AMarkerDef.Width * AMarkerDef.SizeUnit, AMarkerDef.Height * AMarkerDef.SizeUnit),
ALineDelta * IfThen(AMarkerDef.Start, 1, -1),
0,
200 * AMarkerDef.Width * AMarkerDef.SizeUnit,
200 * AMarkerDef.Height* AMarkerDef.SizeUnit,
False
)
.Attrib('orient', 'auto');
LMarkerTag.Append;
ACtl.FSVGMarkers[AMarkerDef.Shape, AMarkerDef.Filled, AMarkerDef.Start]
.RescalePoints(AMarkerDef.Height * AMarkerDef.SizeUnit, AMarkerDef.Width * AMarkerDef.SizeUnit)
.FillIf(AMarkerDef.Color, LFilled)
.StrokeIf(AMarkerDef.Color, not LFilled)
.StrokeWidthIf(AMarkerDef.LineWidth, not LFilled)
.Associate(Self)
.Append;
EndDefMarker;
LMarkerData.Name := Result;
LMarkerData.Marker := LMarkerTag;
FMarkerDict.Add(AMarkerDef, LMarkerData);
end;
function TSVGBuilder_VisCtl2D.TMarkerDef.GetName: string;
var
LColorName: string;
begin
if not TryGetColorName(Color, LColorName) then
LColorName := ColorToHex(Color);
Result := 'marker-' + Shape.ToString.Replace(#32, '-').ToLower + IfThen(Start, '-s')
+ IfThen(Filled, '-filled') + '-' + Width.ToString + '-' + Height.ToString
+ '-' + LineWidth.ToString + '-' + LColorName;
end;
end.