Home: Code Repository: Mastering Delphi 5

Project CONTAIN

Project Structure

CONTAIN.DPR
LISTFORM.PAS
DATES.PAS
LISTFORM.DFM

program Contain;

uses
  Forms,
  ListForm in 'ListForm.pas' {Form1},
  Dates in 'Dates.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

unit ListForm;

interface

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

type
  TForm1 = class(TForm)
    ButtonAdd: TButton;
    ButtonList: TButton;
    ListBox1: TListBox;
    ButtonWrong: TButton;
    btnListStack: TButton;
    btnQueue: TButton;
    procedure ButtonAddClick(Sender: TObject);
    procedure ButtonListClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonWrongClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnListStackClick(Sender: TObject);
    procedure btnQueueClick(Sender: TObject);
  private
    ListDate: TObjectList;
    Stack: TStack;
    Queue: TQueue;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Dates;

procedure TForm1.ButtonAddClick(Sender: TObject);
begin
  ListDate.Add (TDate.Create (
    1900 + Random (200), 1 + Random (12), 1 + Random (30)));
end;

procedure TForm1.ButtonListClick(Sender: TObject);
var
  I: Integer;
begin
  ListBox1.Clear;
  for I := 0 to ListDate.Count - 1 do
    Listbox1.Items.Add ((TObject(ListDate [I]) as TDate).Text);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  I: Integer;
begin
  Randomize;
  ListDate := TObjectList.Create (True);
  Stack := TStack.Create;
  Queue := TQueue.Create;

  for I := 1 to 10 do
  begin
    Stack.Push (Pointer (I));
    Queue.Push (Pointer (I));
  end;
end;

procedure TForm1.ButtonWrongClick(Sender: TObject);
begin
  // add a button to the list
  ListDate.Add (Sender);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  ListDate.Free;
  Stack.Free;
  Queue.Free;
end;

procedure TForm1.btnListStackClick(Sender: TObject);
var
  Stack2: TStack;
begin
  Stack2 := TStack.Create;
  ListBox1.Clear;
  // lists removing
  while Stack.Count > 0 do
  begin
    ListBox1.Items.Add (IntToStr (Integer (Stack.Peek)));
    Stack2.Push (Stack.Pop);
  end;
  // restores
  while Stack2.Count > 0 do
    Stack.Push (Stack2.Pop);

  ShowMessage ('Removed: ' + IntToStr (Integer (Stack.Pop)));
end;

procedure TForm1.btnQueueClick(Sender: TObject);
var
  I: Integer;
begin
  ListBox1.Clear;
  for I := 0 to Queue.Count - 1 do
  begin
    ListBox1.Items.Add (IntToStr (Integer (Queue.Peek)));
    Queue.Push (Queue.Pop);
  end;
  ShowMessage ('Removed: ' + IntToStr (Integer (Queue.Pop)));
end;

end.

unit Dates;

interface

uses
  Classes, SysUtils;

type
  TDate = class (TComponent)
  private
    fDate: TDateTime;
    FOnChange: TNotifyEvent;
    function GetYear: Integer;
    function GetDay: Integer;
    function GetMonth: Integer;
    procedure SetDay(const Value: Integer);
    procedure SetMonth(const Value: Integer);
    procedure SetYear(const Value: Integer);
  protected
    procedure DoChange; virtual;
  public
    constructor Create (AOwner: TComponent); overload; override;
    constructor Create (y, m, d: Integer); reintroduce; overload;
    procedure SetValue (y, m, d: Integer); overload;
    procedure SetValue (NewDate: TDateTime); overload;
    function LeapYear: Boolean;
    procedure Increase (NumberOfDays: Integer = 1);
    procedure Decrease (NumberOfDays: Integer = 1);
    function GetText: string; virtual;
    property Text: string read GetText;
  published
    property Day: Integer read GetDay write SetDay;
    property Month: Integer read GetMonth write SetMonth;
    property Year: Integer read GetYear write SetYear;
    property OnChange: TNotifyEvent
      read FonChange write FOnChange;
  end;

  // custom exception
  EDateOutOfRange = class (Exception)
  end;

procedure Register;

implementation

procedure TDate.SetValue (y, m, d: Integer);
begin
  fDate := EncodeDate (y, m, d);
  // fire the event
  DoChange;
end;

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

procedure TDate.Increase (NumberOfDays: Integer = 1);
begin
  fDate := fDate + NumberOfDays;
  // fire the event
  DoChange;
end;

function TDate.GetText: string;
begin
  GetText := DateToStr (fDate);
end;

procedure TDate.Decrease (NumberOfDays: Integer = 1);
begin
  fDate := fDate - NumberOfDays;
  // fire the event
  DoChange;
end;

constructor TDate.Create (y, m, d: Integer);
begin
  fDate := EncodeDate (y, m, d);
end;

constructor TDate.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // today...
  fDate := Date;
end;

function TDate.GetYear: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := y;
end;

procedure TDate.SetValue(NewDate: TDateTime);
begin
  fDate := NewDate;
  // fire the event
  DoChange;
end;

function TDate.GetDay: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := d;
end;

function TDate.GetMonth: Integer;
var
  y, m, d: Word;
begin
  DecodeDate (fDate, y, m, d);
  Result := m;
end;

procedure TDate.SetDay(const Value: Integer);
begin
  if (Value < 0) or (Value > 31) then
    raise EDateOutOfRange.Create ('Invalid month');
  SetValue (Year, Month, Value);
end;

procedure TDate.SetMonth(const Value: Integer);
begin
  if (Value < 0) or (Value > 12) then
    raise EDateOutOfRange.Create ('Invalid month');
  SetValue (Year, Value, Day);
end;

procedure TDate.SetYear(const Value: Integer);
begin
  SetValue (Value, Month, Day);
end;

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

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

end.

object Form1: TForm1
  Left = 237
  Top = 110
  Width = 398
  Height = 304
  Caption = 'List Demo'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object ButtonAdd: TButton
    Left = 24
    Top = 24
    Width = 89
    Height = 25
    Caption = '&Add'
    TabOrder = 0
    OnClick = ButtonAddClick
  end
  object ButtonList: TButton
    Left = 24
    Top = 64
    Width = 89
    Height = 25
    Caption = '&List'
    TabOrder = 1
    OnClick = ButtonListClick
  end
  object ListBox1: TListBox
    Left = 136
    Top = 24
    Width = 225
    Height = 225
    ItemHeight = 13
    TabOrder = 2
  end
  object ButtonWrong: TButton
    Left = 24
    Top = 104
    Width = 89
    Height = 25
    Caption = 'Add &Wrong'
    TabOrder = 3
    OnClick = ButtonWrongClick
  end
  object btnListStack: TButton
    Left = 24
    Top = 184
    Width = 89
    Height = 25
    Caption = 'List &Stack'
    TabOrder = 4
    OnClick = btnListStackClick
  end
  object btnQueue: TButton
    Left = 24
    Top = 224
    Width = 89
    Height = 25
    Caption = 'List &Queue'
    TabOrder = 5
    OnClick = btnQueueClick
  end
end