{ ***************************************************************************** See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** Authors: Alexander Klenin } unit TAIntervalSources; {$MODE ObjFPC}{$H+} interface uses Classes, TAChartUtils, TACustomSource; type { TIntervalChartSource } TIntervalChartSource = class(TCustomChartSource) strict private FParams: TChartAxisIntervalParams; procedure SetParams(AValue: TChartAxisIntervalParams); strict protected procedure CalculateIntervals( AParams: TValuesInRangeParams; out ABestStart, ABestStep: Double); protected function GetCount: Integer; override; function GetItem(AIndex: Integer): PChartDataItem; override; procedure SetXCount(AValue: Cardinal); override; procedure SetYCount(AValue: Cardinal); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ValuesInRange( AParams: TValuesInRangeParams; var AValues: TChartValueTextArray); override; published property Params: TChartAxisIntervalParams read FParams write SetParams; end; TDateTimeStep = ( dtsYear, dtsQuarter, dtsMonth, dtsWeek, dtsDay, dtsHour, dtsMinute, dtsSecond, dtsMillisecond ); TDateTimeSteps = set of TDateTimeStep; const DATE_TIME_STEPS_ALL = [Low(TDateTimeStep) .. High(TDateTimeStep)]; type { TDateTimeStepFormat } TDateTimeStepFormat = class(TPersistent) private FSource: TBasicChartSource; FYearFmt: String; FMonthFmt: String; FWeekFmt: String; FDayFmt: String; FHourFmt: String; FMinuteFmt: String; FSecondFmt: String; FMillisecondFmt: String; function IsStoredYearFmt: Boolean; function IsStoredMonthFmt: Boolean; function IsStoredWeekFmt: Boolean; function IsStoredDayFmt: Boolean; function IsStoredHourFmt: Boolean; function IsStoredMinuteFmt: Boolean; function IsStoredSecondFmt: Boolean; function IsStoredMillisecondFmt: Boolean; procedure SetYearFmt(const AValue: String); procedure SetMonthFmt(const AValue: String); procedure SetWeekFmt(const AValue: String); procedure SetDayFmt(const AValue: String); procedure SetHourFmt(const AValue: String); procedure SetMinuteFmt(const AValue: String); procedure SetSecondFmt(const AValue: String); procedure SetMillisecondFmt(const AValue: String); public constructor Create(ASource: TBasicChartSource); published property YearFormat: String read FYearFmt write SetYearFmt stored IsStoredYearFmt; property MonthFormat: String read FMonthFmt write SetMonthFmt stored IsStoredMonthFmt; property WeekFormat: String read FWeekFmt write SetWeekFmt stored IsStoredWeekFmt; property DayFormat: String read FDayFmt write SetDayFmt stored IsStoredDayFmt; property HourFormat: String read FHourFmt write SetHourFmt stored IsStoredHourFmt; property MinuteFormat: String read FMinuteFmt write SetMinuteFmt stored IsStoredMinuteFmt; property SecondFormat: String read FSecondFmt write SetSecondFmt stored IsStoredSecondFmt; property MillisecondFormat: String read FMillisecondFmt write SetMillisecondFmt stored IsStoredMillisecondFmt; end; { TDateTimeIntervalChartSource } TDateTimeStepChangeEvent = procedure (Sender: TObject; ASteps: TDateTimeStep) of object; TDateTimeIntervalChartSource = class(TIntervalChartSource) strict private FDateTimeFormat: String; FDateTimeStepFormat: TDateTimeStepFormat; FSteps: TDateTimeSteps; FSuppressPrevUnit: Boolean; FOnDateTimeStepChange: TDateTimeStepChangeEvent; procedure SetDateTimeFormat(AValue: String); procedure SetSteps(AValue: TDateTimeSteps); procedure SetSuppressPrevUnit(AValue: Boolean); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ValuesInRange( AParams: TValuesInRangeParams; var AValues: TChartValueTextArray); override; published property DateTimeFormat: String read FDateTimeFormat write SetDateTimeFormat; property DateTimeStepFormat: TDateTimeStepFormat read FDateTimeStepFormat write FDateTimeStepFormat; property Steps: TDateTimeSteps read FSteps write SetSteps default DATE_TIME_STEPS_ALL; property SuppressPrevUnit: Boolean read FSuppressPrevUnit write SetSuppressPrevUnit default true; property OnDateTimeStepChange: TDateTimeStepChangeEvent read FOnDateTimeStepChange write FOnDateTimeStepChange; end; const DEFAULT_YEAR_FORMAT = 'yyyy'; // DEFAULT_QUARTER_FORMAT = 'Q/yyyy'; DEFAULT_MONTH_FORMAT = 'mm/yyyy'; DEFAULT_WEEK_FORMAT = 'dd/mm'; DEFAULT_DAY_FORMAT = 'dd/mm'; DEFAULT_HOUR_FORMAT = 'dd hh:nn'; DEFAULT_MINUTE_FORMAT = 'hh:nn'; DEFAULT_SECOND_FORMAT = 'nn:ss'; DEFAULT_MILLISECOND_FORMAT = 'szzz"ms"'; procedure Register; implementation uses DateUtils, Math, StrUtils, SysUtils, TAMath; const YEAR = 365.25; DATE_STEP_INTERVALS: array [TDateTimeStep] of Double = ( YEAR, YEAR / 4, YEAR / 12, 7, 1, OneHour, OneMinute, OneSecond, OneMillisecond ); type TSourceIntervalParams = class(TChartAxisIntervalParams) strict protected procedure Changed; override; end; TDateTimeIntervalsHelper = object FBestStep: TDateTimeStep; FBestStepCoeff: Double; FOrigParams: TValuesInRangeParams; FStep: TDateTimeStep; FStepLen: Double; function AxisToGraph(AX: Double): Double; procedure CheckStep(AStepCoeff: Double); function GraphToAxis(AX: Double): Double; function NextValue(AValue: TDateTime): Double; function StartValue(AValue: TDateTime): TDateTime; end; procedure Register; begin RegisterComponents( CHART_COMPONENT_IDE_PAGE, [ TIntervalChartSource, TDateTimeIntervalChartSource ]); end; function SafeRound(AValue: Double): Double; inline; begin Result := Int(AValue * 1e9) / 1e9; end; { TDateTimeIntervalsHelper } function TDateTimeIntervalsHelper.AxisToGraph(AX: Double): Double; begin Result := FOrigParams.FAxisToGraph(AX) * DATE_STEP_INTERVALS[FStep]; end; procedure TDateTimeIntervalsHelper.CheckStep(AStepCoeff: Double); begin // Strict inequaltity is importatnt to avoid steps like "ten quarters". if (1.0 <= AStepCoeff) and (AStepCoeff < FBestStepCoeff) then begin FBestStepCoeff := AStepCoeff; FBestStep := FStep; FStepLen := DATE_STEP_INTERVALS[FBestStep] * FBestStepCoeff; end; end; function TDateTimeIntervalsHelper.GraphToAxis(AX: Double): Double; begin Result := FOrigParams.FGraphToAxis(AX / DATE_STEP_INTERVALS[FStep]); end; function TDateTimeIntervalsHelper.NextValue(AValue: TDateTime): Double; begin case FBestStep of dtsYear: if FBestStepCoeff > 10 then // DateTime arithmetics fails on large year numbers. Result := AValue + FStepLen else Result := IncYear(AValue, Round(FBestStepCoeff)); dtsQuarter: Result := IncQuarter(AValue, Round(FStepLen/DATE_STEP_INTERVALS[dtsQuarter])); dtsMonth: Result := IncMonth(AValue, Round(FBestStepCoeff)); otherwise Result := AValue + FStepLen; end; end; function TDateTimeIntervalsHelper.StartValue(AValue: TDateTime): TDateTime; var d, m, y: Word; begin Result := Int(AValue / FStepLen - 1) * FStepLen; case FBestStep of dtsYear: // DateTime arithmetics fails on large year numbers. if FBestStepCoeff <= 10 then Result := StartOfTheYear(AValue); dtsQuarter: begin Result := StartOfTheQuarter(AValue); // Make sure that first mark is at start of year. if round(FStepLen/DATE_STEP_INTERVALS[dtsQuarter]) = 2 then begin DecodeDate(Result, y,m,d); if m < 7 then m := 1 else m := 7; Result := EncodeDate(y, m, 1); end; end; dtsMonth: Result := StartOfTheYear(AValue); dtsWeek: Result := StartOfTheWeek(AValue); else ; end; end; { TSourceIntervalParams } procedure TSourceIntervalParams.Changed; begin with GetOwner as TCustomChartSource do begin BeginUpdate; EndUpdate; end; end; { TIntervalChartSource } procedure TIntervalChartSource.CalculateIntervals( AParams: TValuesInRangeParams; out ABestStart, ABestStep: Double); procedure CalcMinMaxCount(out AMinCount, AMaxCount: Integer); var imageWidth, len: Integer; begin // If the axis transformation is non-linear, steps may not be equidistant. // However, both minimax and maximin will be achieved on equal steps. with AParams do imageWidth := Abs(ToImage(FMax) - ToImage(FMin)); if aipUseMinLength in Params.Options then len := AParams.FScale(Max(Params.MinLength, 2)) else len := 2; AMaxCount := Max(imageWidth div len, 2); if aipUseMaxLength in Params.Options then begin len := AParams.FScale(Max(Params.MaxLength, 2)); AMinCount := Max((imageWidth + 1) div len, 2); end else AMinCount := 2; end; procedure TryStep(AStep: Double; var ABestCount: Integer); var m, start: Double; mi, prev, cnt: Int64; begin if AStep <= 0 then exit; start := Int(AParams.FMin / AStep) * AStep; m := start; prev := AParams.ToImage(m); cnt := 0; while m <= AParams.FMax do begin mi := AParams.ToImage(m + AStep); if not AParams.IsAcceptableStep(Abs(prev - mi)) then exit; m += AStep; prev := mi; cnt += 1; end; if not (aipUseCount in Params.Options) or (ABestCount <= 0) or (Abs(cnt - Params.Count) < Abs(ABestCount - Params.Count)) then begin ABestStart := start - AStep; ABestStep := AStep; ABestCount := cnt; end; end; var minCount, maxCount, bestCount: Integer; s, sv: Double; begin CalcMinMaxCount(minCount, maxCount); bestCount := 0; if aipInteger in Params.Options then begin ABestStart := Int(AParams.FMin); ABestStep := 1.0; bestCount := Round(AParams.FMax) - round(ABestStart); if bestCount <= maxCount then exit; end; if aipUseNiceSteps in Params.Options then begin s := AParams.CountToStep(minCount) * 10; while s >= Max(AParams.CountToStep(maxCount), AParams.FMinStep) do begin for sv in Params.StepValues do TryStep(s * sv, bestCount); // We are not required to pick the best count, so any one will do. if not (aipUseCount in Params.Options) and (bestCount > 0) then break; s *= 0.1; end; end; if (aipInteger in Params.Options) and (bestCount > maxCount) then bestCount := 0; if bestCount > 0 then exit; // Either nice steps were not required, or we failed to find one. if aipUseCount in Params.Options then bestCount := EnsureRange(Params.Count, minCount, maxCount) else bestCount := minCount; ABestStep := (AParams.FMax - AParams.FMin) / bestCount; ABestStart := AParams.FMin - ABestStep; end; constructor TIntervalChartSource.Create(AOwner: TComponent); begin inherited Create(AOwner); FParams := TChartAxisIntervalParams.Create(Self); end; destructor TIntervalChartSource.Destroy; begin FreeAndNil(FParams); inherited; end; function TIntervalChartSource.GetCount: Integer; begin Result := 0; end; function TIntervalChartSource.GetItem(AIndex: Integer): PChartDataItem; begin Unused(AIndex); Result := nil; end; procedure TIntervalChartSource.SetParams(AValue: TChartAxisIntervalParams); begin if FParams = AValue then exit; FParams.Assign(AValue); InvalidateCaches; Notify; end; procedure TIntervalChartSource.SetXCount(AValue: Cardinal); begin Unused(AValue); raise EXCountError.Create('Cannot set XCount'); end; procedure TIntervalChartSource.SetYCount(AValue: Cardinal); begin Unused(AValue); raise EYCountError.Create('Cannot set YCount'); end; procedure TIntervalChartSource.ValuesInRange( AParams: TValuesInRangeParams; var AValues: TChartValueTextArray); const // Arbitrary limit to prevent hangup/OOM in case of bug in CalculateIntervals. MAX_COUNT = 10000; var start, step, m, eps: Double; i: Integer; begin if AParams.FMin >= AParams.FMax then exit; AParams.FIntervals := Params; if aipGraphCoords in Params.Options then begin AParams.FMin := AParams.FAxisToGraph(AParams.FMin); AParams.FMax := AParams.FAxisToGraph(AParams.FMax); end; EnsureOrder(AParams.FMin, AParams.FMax); CalculateIntervals(AParams, start, step); if step <= 0 then exit; eps := (AParams.FMax - AParams.FMin) * RANGE_EPSILON; m := start; SetLength(AValues, Trunc(Min((AParams.FMax - m) / step + 2, MAX_COUNT))); for i := 0 to High(AValues) do begin if IsZero(m, eps) then m := 0; AValues[i].FValue := m; if m > AParams.FMax then begin SetLength(AValues, i + 1); break; end; m += step; end; if aipGraphCoords in Params.Options then for i := 0 to High(AValues) do AValues[i].FValue := AParams.FGraphToAxis(AValues[i].FValue); for i := 0 to High(AValues) do begin AParams.RoundToImage(AValues[i].FValue); // Extra format arguments for compatibility with FormatItem. AValues[i].FText := Format( AParams.FFormat, [AValues[i].FValue, 0.0, '', 0.0, 0.0]); end; end; { TDateTimeStepFormat } constructor TDateTimeStepFormat.Create(ASource: TBasicChartSource); begin inherited Create; FSource := ASource; FYearFmt := DEFAULT_YEAR_FORMAT; FMonthFmt := DEFAULT_MONTH_FORMAT; FWeekFmt := DEFAULT_WEEK_FORMAT; FDayFmt := DEFAULT_DAY_FORMAT; FHourFmt := DEFAULT_HOUR_FORMAT; FMinuteFmt := DEFAULT_MINUTE_FORMAT; FSecondFmt := DEFAULT_SECOND_FORMAT; FMillisecondFmt := DEFAULT_MILLISECOND_FORMAT; end; function TDateTimeStepFormat.IsStoredYearFmt: Boolean; begin Result := FYearFmt <> DEFAULT_YEAR_FORMAT; end; function TDateTimeStepFormat.IsStoredMonthFmt: Boolean; begin Result := FMonthFmt <> DEFAULT_MONTH_FORMAT; end; function TDateTimeStepFormat.IsStoredWeekFmt: Boolean; begin Result := FWeekFmt <> DEFAULT_WEEK_FORMAT; end; function TDateTimeStepFormat.IsStoredDayFmt: Boolean; begin Result := FDayFmt <> DEFAULT_DAY_FORMAT; end; function TDateTimeStepFormat.IsStoredHourFmt: Boolean; begin Result := FHourFmt <> DEFAULT_HOUR_FORMAT; end; function TDateTimeStepFormat.IsStoredMinuteFmt: Boolean; begin Result := FMinuteFmt <> DEFAULT_MINUTE_FORMAT; end; function TDateTimeStepFormat.IsStoredSecondFmt: Boolean; begin Result := FSecondFmt <> DEFAULT_SECOND_FORMAT; end; function TDateTimeStepFormat.IsStoredMillisecondFmt: Boolean; begin Result := FMillisecondFmt <> DEFAULT_MILLISECOND_FORMAT; end; procedure TDateTimeStepFormat.SetYearFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FYearFmt) then begin FSource.BeginUpdate; FYearFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetMonthFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FMonthFmt) then begin FSource.BeginUpdate; FMonthFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetWeekFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FWeekFmt) then begin FSource.BeginUpdate; FWeekFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetDayFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FDayFmt) then begin FSource.BeginUpdate; FDayFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetHourFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FHourFmt) then begin FSource.BeginUpdate; FHourFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetMinuteFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FMinuteFmt) then begin FSource.BeginUpdate; FMinuteFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetSecondFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FSecondFmt) then begin FSource.BeginUpdate; FSecondFmt := AValue; FSource.EndUpdate; end; end; procedure TDateTimeStepFormat.SetMillisecondFmt(const AValue: String); begin if (AValue <> '') and (AValue <> FMillisecondFmt) then begin FSource.BeginUpdate; FMillisecondFmt := AValue; FSource.EndUpdate; end; end; { TDateTimeIntervalChartSource } constructor TDateTimeIntervalChartSource.Create(AOwner: TComponent); begin inherited Create(AOwner); FSteps := DATE_TIME_STEPS_ALL; FSuppressPrevUnit := true; FDateTimeStepFormat := TDateTimeStepFormat.Create(self); end; destructor TDateTimeIntervalChartSource.Destroy; begin FDateTimeStepFormat.Free; inherited; end; procedure TDateTimeIntervalChartSource.SetDateTimeFormat(AValue: String); begin if FDateTimeFormat = AValue then exit; FDateTimeFormat := AValue; InvalidateCaches; Notify; end; procedure TDateTimeIntervalChartSource.SetSteps(AValue: TDateTimeSteps); begin if FSteps = AValue then exit; FSteps := AValue; InvalidateCaches; Notify; end; procedure TDateTimeIntervalChartSource.SetSuppressPrevUnit(AValue: Boolean); begin if FSuppressPrevUnit = AValue then exit; BeginUpdate; FSuppressPrevUnit := AValue; EndUpdate; end; procedure TDateTimeIntervalChartSource.ValuesInRange( AParams: TValuesInRangeParams; var AValues: TChartValueTextArray); var helper: TDateTimeIntervalsHelper; prevSt: TSystemTime; function DoFormatDateTime(AFormat: String; AValue: TDateTime): String; var optn: TFormatDateTimeOptions; begin if pos('[', AFormat) > 0 then optn := [fdoInterval] else optn := []; Result := FormatDateTime(AFormat, AValue, optn); end; function FormatLabel(AValue: TDateTime): String; var st: TSystemTime; begin if DateTimeFormat <> '' then exit(DoFormatDateTime(DateTimeFormat, AValue)); DateTimeToSystemTime(AValue, st); case helper.FBestStep of dtsYear: Result := FormatDateTime(DateTimeStepFormat.YearFormat, AValue); dtsQuarter: Result := IntToRoman((MonthOf(AValue)-1) div 3 + 1) + '/' + FormatDateTime(DateTimeStepFormat.YearFormat, AValue); dtsMonth: if FSuppressPrevUnit and (st.Year = prevSt.Year) then Result := FormatDateTime('mm', AValue) else Result := FormatDateTime(DateTimeStepFormat.MonthFormat, AValue); dtsWeek: Result := FormatDateTime(DateTimeStepFormat.WeekFormat, AValue); dtsDay: if FSuppressPrevUnit and (st.Month = prevSt.Month) then Result := DoFormatDateTime('dd', AValue) else Result := DoFormatDateTime(DateTimeStepFormat.DayFormat, AValue); dtsHour: if FSuppressPrevUnit and (st.Day = prevSt.Day) then Result := DoFormatDateTime('hh:00', AValue) else Result := DoFormatDateTime(DateTimeStepFormat.HourFormat, AValue); dtsMinute: if FSuppressPrevUnit and (st.Hour = prevSt.Hour) then Result := DoFormatDateTime('nn', AValue) else Result := DoFormatDateTime(DateTimeStepFormat.MinuteFormat, AValue); dtsSecond: if FSuppressPrevUnit and (st.Minute = prevSt.Minute) then Result := DoFormatDateTime('ss', AValue) else Result := DoFormatDateTime(DateTimeStepFormat.SecondFormat, AValue); dtsMillisecond: if FSuppressPrevUnit and (st.Second = prevSt.Second) then Result := IntToStr(st.Millisecond) + 'ms' else Result := DoFormatDateTime(DateTimeStepFormat.MillisecondFormat, AValue); end; if InRange(AValue, helper.FOrigParams.FMin, helper.FOrigParams.FMax) then prevSt := st; end; procedure AddValue(AIndex: Integer; AValue: Double); begin with AValues[AIndex] do begin FValue := AValue; FText := Format( AParams.FFormat, [AValue, 0.0, FormatLabel(AValue), 0.0, 0.0]); end; end; const MAX_COUNT = 1000; // Arbitraty limit to prevent OOM in case of a bug. var i, cnt: Integer; x, start, stepLen: Double; begin if (AParams.FMin >= AParams.FMax) or (aipGraphCoords in Params.options) then exit; AParams.FIntervals := Params; helper.FOrigParams := AParams; AParams.FAxisToGraph := @helper.AxisToGraph; AParams.FGraphToAxis := @helper.GraphToAxis; AParams.FMinStep := 1.0; helper.FBestStepCoeff := SafeInfinity; for helper.FStep in Steps do begin AParams.FMin := helper.FOrigParams.FMin / DATE_STEP_INTERVALS[helper.FStep]; AParams.FMax := helper.FOrigParams.FMax / DATE_STEP_INTERVALS[helper.FStep]; CalculateIntervals(AParams, start, stepLen); helper.CheckStep(stepLen); end; if IsInfinite(helper.FBestStepCoeff) then exit; start := helper.StartValue(helper.FOrigParams.FMin); cnt := 1; x := start; while (x <= helper.FOrigParams.FMax) and (cnt < MAX_COUNT) do begin cnt += 1; x := helper.NextValue(x); end; i := Length(AValues); SetLength(AValues, i + cnt); FillChar(prevSt, SizeOf(prevSt), $FF); x := start; while (x <= helper.FOrigParams.FMax) and (i < cnt - 1) do begin AddValue(i, x); i += 1; x := helper.NextValue(x); end; AddValue(i, x); if Assigned(FOnDateTimeStepChange) then FOnDateTimeStepChange(self, helper.FBestStep); end; end.