[Lazarus] DateDif function needed
Frederic Da Vitoria
davitofrg at gmail.com
Wed Nov 20 11:16:35 CET 2013
2013/11/18 Jürgen Hestermann <juergen.hestermann at gmx.de>
>
> Am 2013-11-18 13:11, schrieb Frederic Da Vitoria:
>
> First of all, I decided to use a different name. DateDiff comes from
>> Excel, this is Lazarus, we should try to use names consistent with our
>> functions. I chose DatesToAge, but I am not convinced this name is any
>> better to any other name which has been used in this thread. I'll keep it
>> here as this allows to distinguish my routine from others.
>>
>
> I still find "CalenderDiff" the best name for this function
> because it clearly states that differences are calculated for calender
> dates and not for an homogeneous stream of seconds/hours/days.
Here are the latest (and I hope final) versions. I finally managed to reach
correct results, even if the code is a bit clunky for my taste.
"DatesToAge" can be changed to "CalendarDiff" (or
"WesternGregorianCalendarDiff" :-) ), I don't care, I have kept
"DatesToAge" until now because I felt it made discussions about the
different implementations clearer (one could easily miss the difference
between "CalendarDiff" and "CalendarDateDiff")
I have tried to give statistics of the differences in results with waldo
kitty's function, but the differences are too wide, the version I fetched
from this thread is obviously buggy. I'll try again after updating from
svn, but I can't do it here (at work), this will have to wait until this
evening.
//////////////////////////// uDateDiff.pas:
unit uDateDiff;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, StdCtrls, DateUtils;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
// This function ensures that adding parts to a date is done in the correct
order: years first, days last
// It is not called by DatesToAge, but is the reference used to check
DatesToAge's results.
function IncDate (const aDate : TDate ; const Years, Months, Days:
integer) : TDate ;
begin { IncDate }
result := IncDay (IncMonth (IncYear (aDate, years), months), days)
end { IncDate } ;
// Gives the age in months between Date1 and Date2.
// abs (Months) will always be <= 12
// abs (Days) will always be <= 31
// if Date1 < Date2, Years, Months and Day will all be >= 0
// if Date1 > Date2, Years, Months and Day will all be <= 0
procedure DatesToAge (Date1, Date2 : TDate ; out Years, Months, Days :
integer) ;
var
day1, day2, year1, year2, month1, month2 : word ;
work_year, work_month, work_day : word ; // work date for intermediate
calculations
procedure ProcessPositive ;
var
month2_after_carry : integer ;
begin {ProcessPositive}
if day2 >= day1
then month2_after_carry := month2
else month2_after_carry := month2 - 1 ;
if month2_after_carry >= month1
then begin
Years := year2 - year1 ;
Months := month2_after_carry - month1
end {then}
else begin
Years := year2 - year1 - 1 ;
Months := month2_after_carry - month1 + 12
end {else} ;
if day2 >= day1
then Days := day2 - day1
else begin
DecodeDate (IncMonth (date2, -1), work_year, work_month, work_day) ;
Days := day2 - day1 + DaysInAMonth (work_year, work_month)
end {else} ;
// now it's time to adjust the dates
while IncDate (date1, Years, Months, Days) < Date2 do Inc (Days) ;
while IncDate (date1, Years, Months, Days) > Date2 do Dec (Days) ;
if Days >= 28
then begin // check if result can be optimized
if Months >= 11
then begin
work_year := Years + 1 ;
work_month := Months + 1 - 12
end {then}
else begin
work_year := Years ;
work_month := Months + 1
end {else} ;
if IncDate (date1, work_year, work_month, 0) <= Date2
then begin // ok, it works
Years := work_year;
Months := work_month ;
Days := 0 ;
while IncDate (date1, Years, Months, Days) < Date2 do Inc (Days)
end {then}
end {then}
end {ProcessPositive} ;
procedure ProcessNegative ; // date2 < date1: result will be negative.
Completely different algorithm from ProcessPositive
begin {ProcessNegative}
Years := year2 - year1 ;
Months := month2 - month1 ;
if Months < -12
then begin
Dec (Years) ;
Inc (Months, 12)
end {then}
else if Months > 0
then begin
Inc (Years) ;
Dec (Months, 12)
end {then} ;
Days := day2 - day1 ;
if Days > 0
then begin
Inc (Months) ;
if Months > 0
then begin
Inc (Years) ;
Dec (Months, 12)
end {then} ;
Dec (Days, 30) // approximate value, will be adjusted later
end {then} ;
// now it's time to adjust the dates
while IncDate (date1, Years, Months, Days) < Date2 do Inc (Days) ;
if Days > 0
then begin
Inc (Months) ;
if Months > 0
then begin
Inc (Years) ;
Dec (Months, 12)
end {then} ;
Dec (Days, 28) // approximate value, will be adjusted later
end {then} ;
while IncDate (date1, Years, Months, Days) > Date2 do Dec (Days) ;
if IncDate (date1, Years, Months, 0) = DaysInAMonth (year1+Years,
month1+Months)
then begin
Days := day1 - DaysInAMonth (year1+Years, month1+Months) ;
if Months = 12
then begin
Inc (Years) ;
Months := 1
end {then}
else Inc (Months)
end {then}
end {ProcessNegative} ;
begin {DatesToAge}
Days := 0;
Months := 0 ;
Years := 0 ;
DecodeDate (date1, year1, month1, day1) ;
DecodeDate (date2, year2, month2, day2) ;
if date1 <= date2
then ProcessPositive
else ProcessNegative
end {DatesToAge} ;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
years, months, days: integer; // result of the DatesToAge procedure
day_count_1, day_count_2: integer ;
date1, date2, date3 : TDate ;
test_ok : boolean ;
begin
Memo1.Clear ;
Memo1.Append ('Running...');
test_ok := TRUE ;
for day_count_1 := 0 to DaysBetween (EncodeDate (2000, 01, 01),
EncodeDate (2005, 12, 31)) do begin
date1 := EncodeDate (2000, 01, 01) + day_count_1 ;
for day_count_2 := -(365*5) to (365*5) do begin
date2 := IncDay (date1, day_count_2) ;
DatesToAge(date1, date2, years, months, days) ;
date3 := IncDate (date1, years, months, days) ;
if (date3 <> date2)
or (abs (days) > 31)
or (abs (months) > 11)
or ((date2 > date1) and ((years < 0) or (months < 0) or (days
< 0)))
or ((date2 < date1) and ((years > 0) or (months > 0) or (days
> 0)))
then begin
test_ok := FALSE ;
Memo1.Append ('------'+DateToStr (date1)+' '+DateToStr
(date2)+' Y='+IntToStr (years)+' M='+IntToStr (months)+' D='+IntToStr
(days)+' '+DateToStr (date3));
Memo1.Append ('IncYear='+DateToStr (IncYear (date1,
Years))+', IncMonth+IncYear='+DateToStr (IncMonth (IncYear (date1, years),
months)));
Memo1.Append ('IncMonth+IncYear='+DateToStr (IncMonth
(IncYear (date1, 3), 12)));
exit
end {then} ;
end {for}
end {for} ;
if test_ok
then Memo1.Append('Finished OK')
else Memo1.Append('Finished KO');
end;
end {uDateDiff}.
//////////////////////////// uDateDiff.lfm:
object Form1: TForm1
Left = 1322
Height = 277
Top = 35
Width = 584
Caption = 'Form1'
ClientHeight = 277
ClientWidth = 584
LCLVersion = '1.2.0.1'
object Button1: TButton
Left = 8
Height = 25
Top = 8
Width = 75
Caption = 'Button1'
OnClick = Button1Click
TabOrder = 0
end
object Memo1: TMemo
Left = 88
Height = 259
Top = 8
Width = 489
Anchors = [akTop, akLeft, akRight, akBottom]
ScrollBars = ssAutoBoth
TabOrder = 1
end
end
--
Frederic Da Vitoria
(davitof)
Membre de l'April - « promouvoir et défendre le logiciel libre » -
http://www.april.org
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.lazarus-ide.org/pipermail/lazarus/attachments/20131120/5bf1705f/attachment-0003.html>
More information about the Lazarus
mailing list