See also Design patterns in Tcl, Incr Tcl Design Patterns.
IANAPG (I am not a patterns guru), so I use the example code from http://www.dofactory.com/Patterns/Patterns.aspx as a base for my implementations.
if 0 {
Chain-of-responsibility:
Description: Avoid coupling the sender of a request to its receiver by giving more than one object a chance to handle the request. Chain the receiving objects and pass the request along the chain until an object handles it.
Implementation notes: Uses a linked list of snit objects, each having a handle method, a -command option and a -next option. The handle method evaluates the code in the -command option together with any arguments given. If the result is the empty string, it asks the next object in the chain to handle it. }
package require snit
snit::type handler {
option -next list
option -command
method handle args {
if {[eval [$self cget -command] $self $args] eq {}} {
eval [$self cget -next] handle $args
}
}
}
# ''Usage example:''
proc director {self request} {
if {$request >= 0 && $request < 10} {
puts "$self handled request $request"
}
}
proc vicePresident {self request} {
if {$request >= 10 && $request < 20} {
puts "$self handled request $request"
}
}
proc president {self request} {
if {$request >= 20 && $request < 30} {
puts "$self handled request $request"
}
}
proc main args {
handler Mary -command president
handler Gus -command vicePresident -next Mary
handler Tom -command director -next Gus
foreach request [list 2 5 14 22 18 38 3 27 20] {
Tom handle $request
}
}if 0 {
Command:
Description: Encapsulate a request as an object, thereby letting you parameterize clients with different requests, queue or log requests, and support undoable operations.
Implementation notes: This pattern requires interaction between at least three objects:
}
package require snit
snit::type command {
option -actor
option -action
method execute {} {
[$self cget -actor] action [$self cget -action]
}
}
snit::type actor {
variable state 0
method action action {
set state [eval expr $state $action]
}
}
snit::type invoker {
option -actor
variable commands
variable current 0
method redo levels {
for {set i 0} {$i < $levels} {incr i} {
if {$current < [llength $commands]} {
set cmd [lindex $commands $current 0]
set total [$cmd execute]
puts "Total = $total (following [$cmd cget -action])"
incr current
}
}
}
method undo levels {
for {set i 0} {$i <= $levels} {incr i} {
if {$current > 0} {
set cmd [lindex $commands [incr current -1] 1]
set total [$cmd execute]
puts "Total = $total (following [$cmd cget -action])"
}
}
}
method compute args {
set cmd1 [command %AUTO% -actor [$self cget -actor] -action $args]
set cmd2 [command %AUTO% -actor [$self cget -actor] \
-action [string map {+ - - + * / / *} $args]]
lappend commands [list $cmd1 $cmd2]
$self redo 1
}
}
# ''Usage example:''
proc main args {
invoker user -actor [actor %AUTO%]
user compute + 100
user compute - 50
user compute * 10
user compute / 2
puts "---- Undo 4 levels"
user undo 4
puts "---- Redo 3 levels"
user redo 3
}if 0 {
Iterator:
Description: Provide a way to access the elements of an aggregate object sequentially without exposing its underlying representation.
Implementation notes: The object is wrapped in a class that provides methods for finding the first element, finding the next element, dereferencing the current element, and a predicate for determining if all elements have been traversed. }
package require snit
snit::type stringIterator {
option -variable
variable varname
variable current 0
method first {} {
string index [set [$self cget -variable]] [set current 0]
}
method next {} {
string index [set [$self cget -variable]] [incr current]
}
method isDone {} {
expr {$current >= [string length [set [$self cget -variable]]]}
}
method currentItem {{value {}}} {
set varname [$self cget -variable]
if {$value eq {}} {
string index [set $varname] $current
} else {
set $varname [string replace [set $varname] $current $current $value]
}
}
}
# Usage example:
proc main args {
set ::a {Hello World}
set i [stringIterator %AUTO% -variable ::a]
for {$i first} {![$i isDone]} {$i next} {
puts [$i currentItem]
}
}if 0 {
Mediator:
Description: Define an object that encapsulates how a set of objects interact. Mediator promotes loose coupling by keeping objects from referring to each other explicitly, and it lets you vary their interaction independently.
}
package require snit
snit::type mediator {
variable colleagues
method register {name class} {
set object [set colleagues($name) [$class %AUTO% -name $name]]
$object configure -mediator $self
return $object
}
method send {from whom what} {
if {[info exists colleagues($whom)]} {
$colleagues($whom) receive $from $what
}
}
}
snit::type beatleParticipant {
option -name
option -mediator
method send {whom what} {
[$self cget -mediator] send [$self cget -name] $whom $what
}
method receive {from what} {
puts "To a Beatle: $from to [$self cget -name]: '$what'"
}
}
snit::type nonBeatleParticipant {
option -name
option -mediator
method send {whom what} {
[$self cget -mediator] send [$self cget -name] $whom $what
}
method receive {from what} {
puts "To a Non-Beatle: $from to [$self cget -name]: '$what'"
}
}
# Usage example:
proc main args {
# Create chatroom
mediator c
# Create 'chatters' and register them
set George [c register George beatleParticipant]
set Paul [c register Paul beatleParticipant]
set Ringo [c register Ringo beatleParticipant]
set John [c register John beatleParticipant]
set Yoko [c register Yoko nonBeatleParticipant]
# Chatting participants
$Yoko send "John" "Hi John!"
$Paul send "Ringo" "All you need is love"
$Ringo send "George" "My sweet Lord"
$Paul send "John" "Can't buy me love"
$John send "Yoko" "My sweet love"
}if 0 {
Memento:
Description: Without violating encapsulation, capture and externalize an object's internal state so that the object can be restored to this state later.
Implementation notes: The state of a snit is stored in the options array and in the instance variables. Saving/restoring the options trivial, as shown below. Saving/restoring instance variables requires devising some packing/unpacking scheme. }
package require snit
# originator
snit::type salesProspect {
option -name
option -phone
option -budget
variable currency \$
method show {} {
puts "\nSales prospect ---- "
puts "Name: [$self cget -name]"
puts "Phone: [$self cget -phone]"
puts "Budget: $currency[$self cget -budget]"
}
method euro {} {set currency \u20AC}
method createMemento {} {
array set variables [list currency $currency]
set m [prospectMemory %AUTO% -state [list [array get options] [array get variables]]]
}
method restoreMemento {memento} {
foreach {optionList variableList} [$memento cget -state] break
array set options $optionList
foreach {name val} $variableList {
set $name $val
}
}
}
# memento
snit::type prospectMemory {
option -state
}
# Usage example:
proc main args {
salesProspect s
s configurelist {
-name "Noel van Halen"
-phone "(412) 256-0990"
-budget 25000.0
}
s show
set m [s createMemento]
s configurelist {
-name "Leo Welch"
-phone "(310) 209-7111"
-budget 1000000.0
}
s euro
s show
s restoreMemento $m
s show
}if 0 {
Observer:
Description: Define a one-to-many dependency between objects so that when one object changes state, all its dependents are notified and updated automatically.
Implementation notes: }
package require snit
snit::type investor {
option -name
method update stock {
puts -nonewline "Investor [$self cget -name] notified of "
puts -nonewline "[$stock cget -symbol]'s change to "
puts [format "%.2f" [$stock cget -price]]
}
}
snit::type stock {
option -symbol
option -price
onconfigure -price value {
set options(-price) $value
$self notify
}
variable investors {}
method attach investor {lappend investors $investor}
method detach investor {
set i [lsearch $investors $investor]
if {$i >= 0} {
set investors [lreplace $investors $i $i]
}
}
method notify {} {
foreach investor $investors {
$investor update $self
}
}
}
snit::type IBM {
delegate method * to base
delegate option * to base
variable base
constructor args {
set base [stock %AUTO%]
$self configurelist $args
}
}
# ''Usage example:''
proc main args {
investor s -name Sorros
investor b -name Berkshire
IBM ibm -symbol IBM -price 120.00
ibm attach s
ibm attach b
foreach p {120.10 121.00 120.50 120.75} {
ibm configure -price $p
}
}if 0 {
State:
Description: Allow an object to alter its behavior when its internal state changes. The object will appear to change its class.
Implementation notes: (as suggested by WHD)
}
package require snit
snit::type redState {
option -account
option -balance
onconfigure -balance value {
set options(-balance) $value
if {[set acct [$self cget -account]] ne {}} {
if {[$self cget -balance] > $upperLimit} {
[$self cget -account] alter silverState
}
}
}
variable upperLimit 0.0
variable serviceFee 15.00
method deposit amount {
$self configure -balance [expr [$self cget -balance] + $amount - $serviceFee]
}
method withdraw amount {
puts "No funds available to withdraw!"
}
method payInterest {} {}
}
snit::type silverState {
option -account
option -balance
onconfigure -balance value {
set options(-balance) $value
if {[set acct [$self cget -account]] ne {}} {
set balance $value
if {$balance > $upperLimit} {
$acct alter goldState
} elseif {$balance < $lowerLimit} {
$acct alter redState
}
}
}
variable interest 0.0
variable lowerLimit 0.0
variable upperLimit 1000.0
method deposit amount {
$self configure -balance [expr [$self cget -balance] + $amount]
}
method withdraw amount {
$self configure -balance [expr [$self cget -balance] - $amount]
}
method payInterest {} {
$self configure -balance [expr [$self cget -balance] * (1 + $interest)]
}
}
snit::type goldState {
option -account
option -balance
onconfigure -balance value {
set options(-balance) $value
if {[set acct [$self cget -account]] ne {}} {
set balance $value
if {$balance < 0.0} {
$acct alter redState
} elseif {$balance < $lowerLimit} {
$acct alter silverState
}
}
}
variable interest 0.05
variable lowerLimit 1000.0
method deposit amount {
$self configure -balance [expr [$self cget -balance] + $amount]
}
method withdraw amount {
$self configure -balance [expr [$self cget -balance] - $amount]
}
method payInterest {} {
$self configure -balance [expr [$self cget -balance] * (1 + $interest)]
}
}
snit::type account {
option -owner
delegate method * to state
delegate option * to state
variable state
method balance {} {
$state cget -balance
}
method deposit amount {
$state deposit $amount
puts [format "Deposited %.2f --- " $amount]
puts [format "Balance = %.2f" [$self balance]]
puts [format "Status = %s" $state]
puts {}
}
method withdraw amount {
$state withdraw $amount
puts [format "Withdrew %.2f --- " $amount]
puts [format "Balance = %.2f" [$self balance]]
puts [format "Status = %s" $state]
puts {}
}
method payInterest {} {
$state payInterest
puts "Interest Paid --- "
puts [format "Balance = %.2f" [$self balance]]
puts [format "Status = %s" $state]
puts {}
}
method alter t {
set state [$t ::%AUTO% -balance [$state cget -balance] -account [$state cget -account]]
}
constructor args {
set state [silverState ::%AUTO% -balance 0.0 -account $self]
$self configurelist $args
}
}
# ''Usage example:''
proc main args {
account account -owner "Molly Brown"
account deposit 500.0
account deposit 300.0
account deposit 550.0
account payInterest
account withdraw 2000.00
account withdraw 1100.00
}if 0 {
Strategy:
Description: Define a family of algorithms, encapsulate each one, and make them interchangeable. Strategy lets the algorithm vary independently from clients that use it.
Implementation notes:
}
package require snit
snit::type warlord {
option -strategy
method hearBirdSing {} {
if {[$self cget -strategy] ne {}} {
[$self cget -strategy] do
} else {
puts ...
}
}
}
snit::type nobunaga {
method do {} {
puts "If the bird does not sing, I shall wring its neck."
}
}
snit::type hideyoshi {
method do {} {
puts "I shall try to teach the bird to sing."
}
}
snit::type ieyasu {
method do {} {
puts "I shall wait for the bird to sing."
}
}
# ''Usage example:''
proc main args {
# the warlord Rikyu wants to hear the bird sing, but it won't.
warlord Rikyu
Rikyu hearBirdSing
# which great leader from history will Rikyu borrow a strategy from?
Rikyu configure -strategy [hideyoshi %AUTO%]
Rikyu hearBirdSing
}Function objects:
See: Snit Lambda