The Decorator Design Pattern in Delphi

The decorator pattern, as defined in the book, with one glaring exception, is pretty easy to get a handle on and really isn’t going to take a lot of work from me in way of text here.

The Decorator Pattern ... is a design pattern that allows new/additional behaviour to be added to an existing object dynamically.
-- Wikipedia
The Decorator Pattern attaches additional responsibilities to an object dynamically.  Decorators provide a flexible alternative to subclassing for extending functionality.
-- Head First Design Patterns

The Beverage super-class I have put in it’s own unit just to provide me with the ability to also separate the Coffee and Condiment classes.  This, to me, is the logical thing to do and it also keeps the units small enough to present here.

The uBeverage Unit:

unit uBeverage;

interface

type
  TBeverage = class abstract(TObject)
  private
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; virtual; abstract;
    function GetDescription: string; virtual; abstract;
  public
    constructor Create; overload; virtual; abstract;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TCondimentDecorator = class abstract(TBeverage)
  public
    constructor Create(const ABeverage: TBeverage); overload; virtual; abstract;
  end;

implementation

end.

The uCoffee Unit:

unit uCoffees;

interface

uses
  uBeverage;

type
  TEspresso = class(TBeverage)
  private
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
  public
    constructor Create; override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  THouseBlend = class(TBeverage)
  private
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
  public
    constructor Create; override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TDarkRoast = class(TBeverage)
  private
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
  public
    constructor Create; override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TDecaf = class(TBeverage)
  private
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
  public
    constructor Create; override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

implementation

uses
  SysUtils;

resourcestring
  csCoffee = 'A %s has been poured for you.';

  { TEspresso }

constructor TEspresso.Create;
begin
  inherited;
  Description := 'Espresso';
  Cost := 2.99;
  Writeln(Format(csCoffee, [Description]));
end;

function TEspresso.GetCost: single;
begin
  Result := FCost;
end;

function TEspresso.GetDescription: string;
begin
  Result := FDescription;
end;

constructor THouseBlend.Create;
begin
  inherited;
  FDescription := 'House Blend Coffee';
  FCost := 1.89;
  Writeln(Format(csCoffee, [Description]));
end;

{ THouseBlend }

function THouseBlend.GetCost: single;
begin
  Result := FCost;
end;

function THouseBlend.GetDescription: string;
begin
  Result := FDescription;
end;

constructor TDarkRoast.Create;
begin
  inherited;
  FDescription := 'Dark Roast Coffee';
  FCost := 3.99;
  Writeln(Format(csCoffee, [Description]));
end;

{ TDarkRoast }

function TDarkRoast.GetCost: single;
begin
  Result := FCost;
end;

function TDarkRoast.GetDescription: string;
begin
  Result := FDescription;
end;

{ Decaf }
constructor TDecaf.Create;
begin
  inherited;
  FDescription := 'Decafinated Coffee';
  FCost := 2.05;
  Writeln(Format(csCoffee, [Description]));
end;

function TDecaf.GetCost: single;
begin
  Result := FCost;
end;

function TDecaf.GetDescription: string;
begin
  Result := FDescription;
end;

end.

The uCondiments Unit:

unit uCondiments;

interface

uses
  uBeverage;

type
  TMocha = class(TCondimentDecorator)
  private
    FBeverage: TBeverage;
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
    property Beverage: TBeverage read FBeverage write FBeverage;
  public
    destructor Destroy; override;
    constructor Create(const ABeverage: TBeverage); override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TMilk = class(TCondimentDecorator)
  private
    FBeverage: TBeverage;
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
    property Beverage: TBeverage read FBeverage write FBeverage;
  public
    destructor Destroy; override;
    constructor Create(const ABeverage: TBeverage); override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TSoy = class(TCondimentDecorator)
  private
    FBeverage: TBeverage;
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
    property Beverage: TBeverage read FBeverage write FBeverage;
  public
    destructor Destroy; override;
    constructor Create(const ABeverage: TBeverage); override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

  TWhip = class(TCondimentDecorator)
  private
    FBeverage: TBeverage;
    FCost: single;
    FDescription: string;
  protected
    function GetCost: single; override;
    function GetDescription: string; override;
    property Beverage: TBeverage read FBeverage write FBeverage;
  public
    destructor Destroy; override;
    constructor Create(const ABeverage: TBeverage); override;
    property Cost: single read GetCost write FCost;
    property Description: string read GetDescription write FDescription;
  end;

implementation

uses
  SysUtils;

resourcestring
  csCondiment = '%s has been added to your Coffee.';

constructor TMocha.Create(const ABeverage: TBeverage);
begin
  inherited;
  Beverage := ABeverage;
  Writeln(Format(csCondiment, ['Mocha']));
end;

destructor TMocha.Destroy;
begin
  Beverage.Free;
  inherited;
end;

function TMocha.GetCost: single;
begin
  Result := 0.80 + Beverage.Cost;
end;

function TMocha.GetDescription: string;
begin
  Result := Beverage.Description + ', Mocha';
end;

{ TMilk }

constructor TMilk.Create(const ABeverage: TBeverage);
begin
  inherited;
  Beverage := ABeverage;
  Writeln(Format(csCondiment, ['Milk']));
end;

destructor TMilk.Destroy;
begin
  Beverage.Free;
  inherited;
end;

function TMilk.GetCost: single;
begin
  Result := 0.50 + Beverage.Cost;
end;

function TMilk.GetDescription: string;
begin
  Result := Beverage.Description + ', Steamed Milk';
end;

{ TSoy }

constructor TSoy.Create(const ABeverage: TBeverage);
begin
  inherited;
  Beverage := ABeverage;
  Writeln(Format(csCondiment, ['Soy']));
end;

destructor TSoy.Destroy;
begin
  Beverage.Free;
  inherited;
end;

function TSoy.GetCost: single;
begin
  Result := 0.95 + Beverage.Cost;
end;

function TSoy.GetDescription: string;
begin
  Result := Beverage.Description + ', Soy';
end;

{ TWhip }

constructor TWhip.Create(const ABeverage: TBeverage);
begin
  inherited;
  Beverage := ABeverage;
  Writeln(Format(csCondiment, ['Whip']));
end;

destructor TWhip.Destroy;
begin
  Beverage.Free;
  inherited;
end;

function TWhip.GetCost: single;
begin
  Result := 1.10 + Beverage.Cost;
end;

function TWhip.GetDescription: string;
begin
  Result := Beverage.Description + ', Whip';
end;

end.

Now we just need a program front end to tie it all together, see if our code works and provide a dynamic environment to prove that the decorators are decorating properly.  First I would like to explain a bit of the code you will see in the console application that I will use.  Console applications are very rudimentary in Delphi so I’ve added a “Console unit” developed by Rudy Velthuis to assist with some simple console functionality.  I have taken some liberty with the unit provided by Rudy and changed the name of the unit for clarity to “Console_Ext” before I compiled it ... the code does simply just extend and not replace the console.  You do not need to download and install the unit to work with my code as I have commented out the {$DEFINE USE_CONSOLE_EXT} line to leave you with the scrolling off to oblivion console app native to Delphi.  I do recommend you get and use the code from Rudy if you do very much console testing at all.  The only part I needed from the unit is ClrScr.
The StarbuzzCoffee Unit:

program StarbuzzCoffee;
{$APPTYPE CONSOLE}
//{$DEFINE USE_CONSOLE_EXT}

uses
  SysUtils,
{$IFDEF USE_CONSOLE_EXT} Console_Ext, {$ENDIF}
  uCondiments in 'uCondiments.pas',
  uBeverage in 'uBeverage.pas',
  uCoffees in 'uCoffees.pas';

var {global and visible to all Methods.}
  Coffee: TBeverage;
  Quit: string;

procedure ClearScreen;
begin
{$IFDEF USE_CONSOLE_EXT}
  ClrScr;
{$ELSE}
  Writeln;
{$ENDIF}
end;

function CoffeeSelected: Boolean;
var
  strInput: string;
  intValue: Integer;

begin
  Result := False;
  Writeln('Welcome to Starbuzz.');
  Writeln('1) House Blend');
  Writeln('2) Dark Roast');
  Writeln('3) Decaf');
  Writeln('4) Espresso');
  Write('Select a Coffee and press Enter: ');
  ReadLn(strInput);
  if TryStrToInt(strInput, intValue) then
    begin
      ClearScreen;
      case intValue of
        1: Coffee := THouseBlend.Create;
        2: Coffee := TDarkRoast.Create;
        3: Coffee := TDecaf.Create;
        4: Coffee := TEspresso.Create;
      end;
      if Assigned(Coffee) then
        Result := True;
    end;
end;

function CondimentsAdded: Boolean;
var
  strInput: string;
  intValue: Integer;
  bolFinished: Boolean;
begin
  bolFinished := False;
  repeat
    Writeln('Make a Condiment Selection and press Enter:');
    Writeln('0) Nothing more thank-you.');
    Writeln('1) Milk');
    Writeln('2) Mocha');
    Writeln('3) Soy');
    Writeln('4) Whip');
    Writeln('[Enter anything else to quit.]');
    Write('Select a Condiment: ');
    ReadLn(strInput);
    if TryStrToInt(strInput, intValue) then
      begin
        ClearScreen;
        Result := True;
        case intValue of
          0: bolFinished := True;
          1: Coffee := TMilk.Create(Coffee);
          2: Coffee := TMocha.Create(Coffee);
          3: Coffee := TSoy.Create(Coffee);
          4: Coffee := TWhip.Create(Coffee);
        end;
      end
    else
      Result := False;
  until bolFinished or (Result = False);
end;

begin
  repeat
    try
      ClearScreen;
      if CoffeeSelected and CondimentsAdded then
        begin
          Writeln;
          Writeln('Your order is as follows:');
          Writeln(Coffee.Description + '. Please pay: $' + FormatCurr('0.00', Coffee.Cost));
        end;
    finally
      FreeAndNil(Coffee);
    end;
    Writeln;
    Write('Would you like to Quit [Y/N]?');
    ReadLn(Quit);
  until UpperCase(Quit) = 'Y';

end.

And there you have it ... a Delphi Decorator.

Comments ...

I won’t even bother getting into my thoughts on the metaphor used, as it has been more than adequately covered in this article on stackoverflow.  I must however comment that it broke my heart to copy and paste that much code, that many times, just to provide a different price and description for a coffee.  Finally, although trivial in retrospect, the big thing [the exception mentioned way above] about this pattern is  “attaching additional responsibilities to an object dynamically” ... well, what’s with the hard coded example then?  Once I did find an example that gave at least an idea of how to implement the pattern dynamically, in Delphi FWIW, it was smooth going.
The logic of the implementation of this pattern really makes you think.  I mean who, is exactly wrapped up in who?  One point I want to make clear, the results of the demonstration really don’t make much sense unless you follow exactly what is happening.  The example Description call, digs down to the core and creates the description on it’s way back out.  To understand this, you really need to play with the code a bit ... experimenting until you fully understand the recursive nature of the final object.

Using Classes instead of Interfaces

There was a bit of discussion with the Strategy Pattern post that I did on my use of Interfaces.  Now, because a pattern is a pattern is a pattern and should be applicable whatever code structure you decide to use, I am using and will stick to classes alone for as long as it is possible.  My only concern with this decision is that what I am producing is not a direct translation of the Java code, which is still my sole intent but if you can live with my choice ... so can I.

In Closing ...

The above is summary and [my rendition of] the Delphi code taken from the third chapter of the book, Head First Design Patterns from O’Reilly.
As I mentioned in the first post in this series, I’m studying Design Patterns using the Head First Design Patterns book from O’Reilly.   As part of this learning process I’m working through the existing examples written in Java and recreating them in Delphi.  This is the forth post in the series and the third that actually deals with one of the design patterns.  The first post in the series also provides a list of additional resources on Design Patterns in Delphi that I’ve managed to track down.  I must mention again that I don’t plan on teaching you design patterns, as that would be quite presumptuous of me considering that I’m just a student of them myself.  I do intend to provide simply an overview of what I’ve learned and the resulting code I produced in the process.
Thanks for stopping by ...
Dave