[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