unit Dates;

interface

uses
  SysUtils, Classes;

type
  TDate = class (TComponent)
  private
    FMonth, FDay, FYear: Integer;
    FOnChange: TNotifyEvent;
  protected
    function DaysInMonth: Integer;
    procedure SetMonth (Value: Integer);
    procedure SetYear (Value: Integer);
    procedure SetDay (Value: Integer);
    procedure DoChange; virtual;
  public
    constructor Create (AOwner: TComponent); override;
    constructor Init (m, d, y: Integer);
    procedure SetValue (m, d, y: Integer);
    function LeapYear: Boolean;
    procedure Increase;
    procedure Decrease;
    procedure Add (NumberOfDays: Integer);
    procedure Subtract (NumberOfDays: Integer);
    function GetText: string;
    // properties:
    property Text: string read GetText;
  published
    property Day: Integer read FDay write SetDay;
    property Month: Integer read FMonth write SetMonth;
    property Year: Integer read FYear write SetYear;
    // event:
    property OnChange: TNotifyEvent
      read FonChange write FOnChange;
  end;

// dates exception
type
  EDateOutOfRange = class (Exception);

procedure Register;

implementation

constructor TDate.Create (AOwner: TComponent);
var
  Y, D, M: Word;
begin
  inherited Create (AOwner);
  // today...
  DecodeDate (Now, Y, M, D);
  FYear := Y;
  FMonth := M;
  FDay := D;
end;

constructor TDate.Init (m, d, y: Integer);
begin
  SetValue (m, d, y);
end;

procedure TDate.DoChange;
begin
  if Assigned (FOnChange) then
    FOnChange (self);
end;

procedure TDate.SetValue (m, d, y: Integer);
var
  OldY, OldM: Integer;
begin
  // store the old value
  OldY := FYear;
  OldM := FMonth;
  // assing the new value
  try
    FYear := y;
    // check the ranges
    SetMonth (m);
    SetDay (d);
    DoChange;
  except
    on EDateOutOfRange do
    begin
      // reset the values
      FYear := OldY;
      FMonth := OldM;
      // let the error show up
      raise;
    end;
  end;
end;

procedure TDate.SetMonth (Value: Integer);
begin
  if (Value >= 1) and (Value <= 12) then
  begin
    FMonth := Value;
    DoChange;
  end
  else
    raise EDateOutOfRange.Create ('Month out of range');
end;

procedure TDate.SetYear (Value: Integer);
begin
  FYear := Value;
  DoChange;
end;

procedure TDate.SetDay (Value: Integer);
begin
  if (Value >= 1) and (Value <= DaysInMonth) then
  begin
    FDay := Value;
    DoChange;
  end
  else
    raise EDateOutOfRange.Create ('Day out of range');
end;

function TDate.LeapYear: Boolean;
begin
  // compute leap years, considering "exceptions"
  if (FYear mod 4 <> 0) then
    LeapYear := False
  else if (FYear mod 100 <> 0) then
    LeapYear := True
  else if (FYear mod 400 <> 0) then
    LeapYear := False
  else
    LeapYear := True;
end;

function TDate.DaysInMonth: Integer;
begin
  case FMonth of
    1, 3, 5, 7, 8, 10, 12:
      DaysInMonth := 31;
    4, 6, 9, 11:
      DaysInMonth := 30;
    2:
      if (LeapYear) then
        DaysInMonth := 29
      else
        DaysInMonth := 28;
    else
      // if the month is not correct
      DaysInMonth := 0;
  end;
end;

procedure TDate.Increase;
begin
  // if this day is not the last of the month
  if FDay < DaysInMonth then
    Inc (FDay) // increase the value by 1
  else
  // if it is not in December
    if FMonth < 12 then
    begin
      // Day 1 of next month
      Inc (FMonth);
      FDay := 1;
    end
    else
    begin
      // else it is next year New Year's Day
      Inc (FYear);
      FMonth := 1;
      FDay := 1;
    end;
  DoChange;
end;

// exactly the reverse of the Increase method
procedure TDate.Decrease;
begin
  if FDay > 1 then
    Dec (FDay) // decrease the value by 1
  else
    // it is the first of a month
    if FMonth > 1 then
    begin
      // assign last day of previous month
      Dec (FMonth);
      FDay := DaysInMOnth;
    end
    else
    // it is the first of January
    begin
      // assign last day of previous year
      Dec (FYear);
      FMonth := 12;
      FDay := DaysInMOnth;
    end;
  DoChange;
end;

function TDate.GetText: string;
begin
  GetText :=  Format ('%s %d, %d',
    [LongMonthNames[Month], Day, Year]);
end;

procedure TDate.Add (NumberOfDays: Integer);
var
  N: Integer;
begin
  // increase the day n times
  for N := 1 to NumberOfDays do
    Increase;
end;

procedure TDate.Subtract (NumberOfDays: Integer);
var
  N: Integer;
begin
  // decrease the day n times
  for N := 1 to NumberOfDays do
    Decrease;
end;

procedure Register;
begin
  RegisterComponents ('Md3', [TDate]);
end;

end.

unit DateL;

interface

uses
  Classes, Dates;

type
  // inheritance based
  TDateListI = class (TList)
  protected
    procedure Put(Index: Integer; Item: TDate);
    function Get (Index: Integer): TDate;
  public
    procedure Add (Obj: TDate);
    property Items[Index: Integer]: TDate
      read Get write Put; default;
  end;

  // wrapper based
  TDateListW = class(TObject)
  private
    FList: TList;
    function Get(Index: Integer): TDate;
    procedure Put(Index: Integer; Item: TDate);
    function GetCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;
    function Add(Item: TDate): Integer;
    function Equals(List: TDateListW): Boolean;
    property Count: Integer read GetCount;
    property Items[Index: Integer]: TDate
      read Get write Put; default;
  end;

implementation

// inherited version

procedure TDateListI.Add (Obj: TDate);
begin
  inherited Add (Obj)
end;

procedure TDateListI.Put(Index: Integer; Item: TDate);
begin
  inherited Put (Index, Item)
end;

function TDateListI.Get (Index: Integer): TDate;
begin
  Result := inherited Get (Index);
end;

// embedded version

constructor TDateListW.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TDateListW.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

function TDateListW.Get(Index: Integer): TDate;
begin
  Result := FList[Index];
end;

procedure TDateListW.Put(Index: Integer; Item: TDate);
begin
  FList[Index] := Item;
end;

function TDateListW.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TDateListW.Add(Item: TDate): Integer;
begin
  Result := FList.Add(Item);
end;

function TDateListW.Equals(List: TDateListW): Boolean;
var
  I: Integer;
begin
  Result := False;
  if List.Count <> FList.Count then Exit;
  for I := 0 to List.Count - 1 do
    if List[I] <> FList[I] then
      Exit;
  Result := True;
end;

end.

unit DateForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DateL;

type
  TForm1 = class(TForm)
    ButtonAddDates: TButton;
    ButtonAddButton: TButton;
    ListBox1: TListBox;
    ComboBox1: TComboBox;
    ButtonAddPointer: TButton;
    procedure ButtonAddDatesClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonAddButtonClick(Sender: TObject);
    procedure ButtonAddPointerClick(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    ListI: TDateListI;
    ListW: TDateListW;
  public
    procedure UpdateList;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Dates;

procedure TForm1.ButtonAddDatesClick(Sender: TObject);
var
  I: Integer;
  Date: TDate;
begin
  Randomize;
  for I := 1 to 10 do
  begin
    Date := TDate.Init (
      1 + Random (12),
      1 + Random (28), // required to be safe
      1900 + Random (200));
    ListI.Add (Date);
  end;
  for I := 1 to 10 do
  begin
    Date := TDate.Init (
      1 + Random (12),
      1 + Random (28), // required to be safe
      1900 + Random (200));
    ListW.Add (Date);
  end;
  UpdateList;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ListI := TDateListI.Create;
  ListW := TDateListW.Create;
  ComboBox1.ItemIndex := 0;
end;

procedure TForm1.ButtonAddButtonClick(Sender: TObject);
begin
  ListW.Add (TDate(Sender));
  TList(ListI).Add (Sender);
  UpdateList;
end;

procedure TForm1.ButtonAddPointerClick(Sender: TObject);
var
  P: Pointer;
begin
  P := @Form1;
  ListW.Add (P);
  ListI.Add (P);
  UpdateList;
end;

procedure TForm1.UpdateList;
var
  I: Integer;
begin
  ListBox1.Clear;
  try
    if ComboBox1.ItemIndex = 0 then
      for I := 0 to ListI.Count - 1 do
        Listbox1.Items.Add (
          ListI [I].GetText)
    else
      for I := 0 to ListW.Count - 1 do
        Listbox1.Items.Add (
          ListW [I].GetText);
  except
    on E:Exception do
      Listbox1.Items.Add ('Error: ' +
        E.MEssage);
  end;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
  UpdateList;
end;


procedure TForm1.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  // remove objects from lists
  for I := 0 to ListW.Count - 1 do
    ListW [I].Free;
  for I := 0 to ListI.Count - 1 do
    ListI [I].Free;
end;

end.