2013/11/18 Jürgen Hestermann <juergen.hesterm...@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
-- _______________________________________________ Lazarus mailing list Lazarus@lists.lazarus.freepascal.org http://lists.lazarus.freepascal.org/mailman/listinfo/lazarus