[Lazarus] DateDif function needed

Frederic Da Vitoria davitofrg at gmail.com
Mon Nov 18 13:11:10 CET 2013


2013/11/18 Michael Schnell <mschnell at lumino.de>

> On 11/16/2013 06:40 PM, Michael Van Canneyt wrote:
>
>>
>> I think it's fairly simple, really. ...
>>
>>  This does make some sense, even for me :-)
>

I ask in advance all those who thought that this thread was finally dead to
excuse me.

I have been working on this since the beginning. Date calculations is a
subject I like, I love the quirks we have to use to make them right.

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.

Since the beginning, I felt that there was something missing in how we were
tackling the problem: there were dark spaces in what the result should be.
Unless I missed something, nobody defined a good way to tell if a result
was correct or not. I felt we needed a way to check the calculations in a
loop. I decided to use the IncXXX functions to do this. This has 2
advantages IMO: this would rely on preexisting functions (no need to add a
new function for performing the check), and it allows to define what the
datediff routine does in a simple way: DateDiff is the reverse function of
IncYear+IncMonth+IncDay. It also should allow some mathematical tricks like
DatesToAge (date1, date3) = DatesToAge (date1, date2) + DatesToAge (date2,
date3) (kind of associativity). This has a consequence: the result is
exclusive, but if you need the inclusive result, just send date2+1 instead
of date2.

I wanted to avoid brute force, so I started with the Jedi code. I first
tried to incrementally correct the code, bad idea, of course, all I ended
up with was useless messy code. Then I used a spreadsheet to try to find
out what the desirable steps were. I did find some of them, but I kept
stumbling on other problems further on in my test loop. After one week of
this (I only spent my free hours, around 2 hours a day, but still...) I
decided it was time to quit. Michael's post convinced me that brute force
had something. So I fell back to another algorithm: calculate an estimation
of the result, then use a loop to correct it. Still more efficient than
brute force. I finally reached the code which follows.

This implementation has been tested with date1 from 2001-01-01 to
2005-12-31 and date2 varying from date1 - 5 years to date1 + 5 years.
Overkill, given the algorithm, but that was the test loop I had for my
previous test and I kept it. I first define an IncDate function. This
combines IncYear, IncMonth and IncDay, ensuring that the combination is
done in the "corrrect" order: first add years, then add months, then add
days, because the result could be different if you add days first, for
example. It should be relatively easy to remove the swapping step from the
previous implementations. DatesToAge would then work both ways and if
someone needed a unsigned version, one could easily swap the parameters
before calling DatesToAge. For this, I'd remove the swapping step and
correct the existing code to handle negative values. But I won't try this
if nobody is interested in my version :-)

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 {TForm1} ;

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
function  IncDate (const aDate : TDate ; const Years, Months, Days:
integer) : TDate ;
begin { IncDate }
  result := IncDay (IncMonth (IncYear (aDate, years), months), days)
end { IncDate } ;

procedure DatesToAge (Date1, Date2: TDate ; out Years, Months, Days:
integer);
var
  d1, d2: word;
  month2_after_carry : integer ;
  y1, y2, m1, m2: word;
  yw, mw, dw : word ; // work date for intermediate calculations
  temp_date: TDate;
begin {DatesToAge}
  if Date1 > Date2
    then begin {SwapDates}
      temp_date := Date1;
      Date1 := Date2;
      Date2 := temp_date;
    end {SwapDates};
  Days := 0;
  Months := 0 ;
  Years := 0 ;
  DecodeDate (date1, y1, m1, d1) ;
  DecodeDate (date2, y2, m2, d2) ;
  if d2 >= d1
    then month2_after_carry := m2
    else month2_after_carry := m2 - 1 ;
  if month2_after_carry >= m1
    then begin
      Years := y2 - y1 ;
      Months := month2_after_carry - m1
    end {then}
    else begin
      Years := y2 - y1 - 1 ;
      Months := month2_after_carry - m1 + 12
    end {else} ;
  if d2 >= d1
    then Days := d2 - d1
    else begin
      DecodeDate (IncMonth (date2, -1), yw, mw, dw) ;
      Days := d2 - d1 + DaysInAMonth (yw, mw)
    end {else} ;
  while IncDate (date1, Years, Months, Days) < Date2 do Inc (Days) ;
  while IncDate (date1, Years, Months, Days) > Date2 do Dec (Days) ;
  if IncDate (date1, Years, Months, 0) = DaysInAMonth (y1+Years, m1+Months)
    then begin
      Days := d1 - DaysInAMonth (y1+Years, m1+Months) ;
      if Months = 12
        then begin
          Inc (Years) ;
          Months := 1
        end {then}
        else Inc (Months)
    end {then}
end {DatesToAge} ;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
var
  years, months, days: integer;
  day_count_1, day_count_2: integer ;
  date1, date2, date3 : TDate ;
  test_ok : boolean ;
begin {TForm1.Button1Click}
  Memo1.Clear ;
  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 := 0 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)
        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)));
          exit
        end {then}
    end {for}
  end {for} ;
  if test_ok
    then Memo1.Append ('Finished OK')
    else Memo1.Append ('Finished KO')
end {TForm1.Button1Click} ;

end {uDateDiff}.

uDateDiff.lfm :

object Form1: TForm1
  Left = 1397
  Height = 106
  Top = 35
  Width = 501
  Caption = 'Form1'
  ClientHeight = 106
  ClientWidth = 501
  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 = 88
    Top = 8
    Width = 406
    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/20131118/db5167eb/attachment-0003.html>


More information about the Lazarus mailing list