Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 03 - Project IntfDemo

Project Structure

IntfDemo.dpr
program IntfDemo;

uses
  Forms,
  InftForm in 'InftForm.pas' {Form1},
  WalkIntf in 'WalkIntf.pas';

{$R *.RES}

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

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    btnRunner: TButton;
    btnAthlete: TButton;
    btnClear: TButton;
    btnMyJumper: TButton;
    procedure btnRunnerClick(Sender: TObject);
    procedure btnAthleteClick(Sender: TObject);
    procedure btnClearClick(Sender: TObject);
    procedure btnMyJumperClick(Sender: TObject);
  public
    procedure Log (str: string);
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  WalkIntf;

procedure TForm1.btnRunnerClick(Sender: TObject);
var
  W1: IWalker;
begin
  W1 := TRunner.Create;
  Log ('TRunner.Create');
  Log (W1.Run);
  Log (W1.Walk);
  Log (W1.Run);
  Log ('');
end;

procedure TForm1.Log(str: string);
begin
  ListBox1.Items.Add (str);
end;

procedure TForm1.btnAthleteClick(Sender: TObject);
var
  W1: IWalker;
  J1: IJumper;
begin
  W1 := TAthlete.Create;
  Log ('TAthlete.Create');
  Log (W1.Run);
  Log (W1.Walk);
  Log (W1.Run);
  Log ((W1 as IJumper).Jump);

  // see Chapter 4 (System unit) for a description
  // of the Supports RTL function
  if Supports (w1, IJumper) then
  begin
    J1 := W1 as IJumper;
    Log (J1.Walk);
  end;
  Log ('');
end;

procedure TForm1.btnClearClick(Sender: TObject);
begin
  ListBox1.Clear;
end;

procedure TForm1.btnMyJumperClick(Sender: TObject);
var
  J1: IJumper;
begin
  J1 := TMyJumper.Create as IJumper;

  Log ('TMyJumper.Create');
  Log (J1.Walk);
  Log (J1.Jump);
  Log (J1.Walk);
  Log ('');
end;

end.
WalkIntf.pas
unit WalkIntf;

interface

type
  IWalker = interface
    ['{0876F200-AAD3-11D2-8551-CCA30C584521}']
    function Walk: string;
    function Run: string;
    procedure SetPos (Value: Integer);
    function GetPos: Integer;

    property Position: Integer
      read GetPos write SetPos;
  end;

  IJumper = interface
    ['{0876F201-AAD3-11D2-8551-CCA30C584521}']
    function Jump: string;
    function Walk: string;
    procedure SetPos (Value: Integer);
    function GetPos: Integer;

    property Position: Integer
      read GetPos write SetPos;
  end;

  TJumperImpl = class (TAggregatedObject, IJumper)
  private
    Pos: Integer;
  public
    function Jump: string;
    function Walk: string;
    procedure SetPos (Value: Integer);
    function GetPos: Integer;

    property Position: Integer
      read GetPos write SetPos;
  end;

  TRunner = class (TInterfacedObject, IWalker)
  private
    Pos: Integer;
  public
    function Walk: string;
    function Run: string;
    procedure SetPos (Value: Integer);
    function GetPos: Integer;
    destructor Destroy; override;
  end;

  TMyJumper = class (TInterfacedObject, IJumper)
  private
    fJumpImpl: TJumperImpl;
  public
    constructor Create;
    property Jumper: TJumperImpl
      read fJumpImpl implements IJumper;
    destructor Destroy; override;
  end;

  TAthlete = class (TInterfacedObject, IWalker, IJumper)
  private
    fJumpImpl: TJumperImpl;
  public
    constructor Create;
    destructor Destroy; override;
    function Run: string; virtual;
    function Walk1: string; virtual;
    function IWalker.Walk = Walk1;
    procedure SetPos (Value: Integer);
    function GetPos: Integer;

    property Jumper: TJumperImpl
      read fJumpImpl implements IJumper;
  end;

implementation

uses
  Dialogs, Windows, SysUtils;

{ TJumperImpl }

function TJumperImpl.Walk;
begin
  Inc (Pos);
  Result := IntToStr (Pos) + ': Walk';
end;

function TJumperImpl.Jump;
begin
  Inc (Pos, 3);
  Result := IntToStr (Pos) + ': Jump';
end;

function TJumperImpl.GetPos: Integer;
begin
  Result := Pos;
end;

procedure TJumperImpl.SetPos(Value: Integer);
begin
  Pos := Value;
end;

{ TAthlete }

constructor TAthlete.Create;
begin
  fJumpImpl := TJumperImpl.Create (self);
end;

destructor TAthlete.Destroy;
begin
  inherited;
  fJumpImpl.Free;
  MessageBox (0, 'TAthlete object destroyed', 'IntfDemo', MB_OK);
end;

function TAthlete.GetPos: Integer;
begin
  Result := fJumpImpl.Position;
end;

function TAthlete.Run;
begin
  fJumpImpl.Position := fJumpImpl.Position + 2;
  Result := IntToStr (fJumpImpl.Position) + ': Run';
end;

procedure TAthlete.SetPos(Value: Integer);
begin
  fJumpImpl.Position := Value;
end;

function TAthlete.Walk1;
begin
  fJumpImpl.Position := fJumpImpl.Position + 1;
  Result := IntToStr (fJumpImpl.Position) + ': Walk';
end;

{ TRunner }

destructor TRunner.Destroy;
begin
  inherited;
  MessageBox (0, 'TRunner object destroyed', 'IntfDemo', MB_OK);
end;

function TRunner.GetPos: Integer;
begin
  Result := Pos;
end;

function TRunner.Run;
begin
  Inc (Pos, 2);
  Result := IntToStr (Pos) + ': Run';
end;

procedure TRunner.SetPos(Value: Integer);
begin
  Pos := Value;
end;

function TRunner.Walk;
begin
  Inc (Pos);
  Result := IntToStr (Pos) + ': Walk';
end;

{ TMyJumper }

constructor TMyJumper.Create;
begin
  fJumpImpl := TJumperImpl.Create (self);
end;

destructor TMyJumper.Destroy;
begin
  inherited;
  fJumpImpl.Free;
  MessageBox (0, 'TMyJumper object destroyed', 'IntfDemo', MB_OK);
end;

end.
InftForm.dfm
object Form1: TForm1
  Left = 261
  Top = 106
  Width = 432
  Height = 239
  Caption = 'Interface Demo'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object ListBox1: TListBox
    Left = 104
    Top = 16
    Width = 305
    Height = 185
    Color = clWindow
    ItemHeight = 13
    TabOrder = 0
  end
  object btnRunner: TButton
    Left = 16
    Top = 16
    Width = 75
    Height = 25
    Caption = 'Runner'
    TabOrder = 1
    OnClick = btnRunnerClick
  end
  object btnAthlete: TButton
    Left = 16
    Top = 80
    Width = 75
    Height = 25
    Caption = 'Athlete'
    TabOrder = 2
    OnClick = btnAthleteClick
  end
  object btnClear: TButton
    Left = 16
    Top = 176
    Width = 75
    Height = 25
    Caption = 'Clear'
    TabOrder = 3
    OnClick = btnClearClick
  end
  object btnMyJumper: TButton
    Left = 16
    Top = 48
    Width = 75
    Height = 25
    Caption = 'My Jumper'
    TabOrder = 4
    OnClick = btnMyJumperClick
  end
end