See [Design patterns in Tcl].

Started by [Peter Lewerin] (2003-08-17).

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.

'''Chain-of-responsibility:''' "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."

 package require snit
 
 snit::type handler {
 	option -handleIf
 	variable condition false
 	onconfigure -handleIf value {set condition $value}
 
 	option -handleBy 
 	variable consequent {}
 	onconfigure -handleBy value {set consequent $value}
 	
 	option -elseReportTo
 	variable alternative {}
 	onconfigure -elseReportTo value {
 		set alternative [concat $value handle \$request]
 	}
 	  
 	method handle request {
 		if $condition $consequent $alternative
 	}
 }

Example:
 
 proc main args {
 	handler Tom -handleIf {
 		$request >= 0 && $request < 10
 	} -handleBy {
 		puts "$self handled request $request"
 	} -elseReportTo Gus

 	handler Gus -handleIf {
 		$request >= 10 && $request < 20
 	} -handleBy {
 		puts "$self handled request $request"
 	} -elseReportTo Mary

 	handler Mary -handleIf {
 		$request >= 20 && $request < 30
 	} -handleBy {
 		puts "$self handled request $request"
 	}
 
 	foreach request [list 2 5 14 22 18 38 3 27 20] {
 		Tom handle $request
 	}
 }

----
'''Command:''' "Encapsulate a request as an object, thereby letting you parameterize clients with different requests, queue or log requests, and support undoable operations."

 package require snit
 
 snit::type command {
 	option -calculator
 	
 	variable state 0
 	
 	method execute {operator operand} {
 		set state [[$self cget -calculator] $operator $state $operand]
 		puts "Total = $state (following $operator $operand)"
 	}

 	method unexecute {operator operand} {
 		set state [[$self cget -calculator] inverse $operator $state $operand]
 		puts "Total = $state (following inverse $operator $operand)"
 	}
 }
 
 # receiver
 snit::type arithmeticCalculator {
 	method + {op1 op2} {$self operation + $op1 $op2}
 	
 	method - {op1 op2} {$self operation - $op1 $op2}
 	
 	method * {op1 op2} {$self operation * $op1 $op2}
 	
 	method / {op1 op2} {$self operation / $op1 $op2}
 	
 	method operation {operator op1 op2} {
 		expr [list $op1 $operator $op2]
 	}

 	method inverse {operator op1 op2} {
 		$self operation [string map {+ - - + * / / *} $operator] $op1 $op2
 	}
 }
 
 snit::type invoker {
 	variable commands
 	variable current 0
 	
 	method redo levels {
 		puts "---- Redo $levels levels"
 		for {set i 0} {$i < $levels} {incr i} {
 			if {$current < [llength $commands]} {
 				foreach {cmd opt opd} [lindex $commands $current] {
 					$cmd execute $opt $opd
 				}
 				incr current
 			}
 		}
 	}
 	
 	method undo levels {
 		puts "---- Undo $levels levels"
 		for {set i 0} {$i <= $levels} {incr i} {
 			if {$current >= 0} {
 				foreach {cmd opt opd} [lindex $commands [incr current -1]] {
 					$cmd unexecute $opt $opd
 				}
 			}
 		}
 	}
 	
 	method invoke {command operator operand} {
 		$command execute $operator $operand
 		lappend commands [list $command $operator $operand]
 		set current [llength $commands]
 		incr current
 	}
 }

Example:
 
 proc main args {
 	set cmd [command %AUTO% -calculator [arithmeticCalculator %AUTO%]]
 	invoker user

 	user invoke $cmd + 100
 	user invoke $cmd - 50
 	user invoke $cmd * 10
 	user invoke $cmd / 2
 	
 	user undo 4
 	user redo 3
 }

----
'''Iterator:''' "Given a language, define a representation for its grammar along with an interpreter that uses the representation to interpret sentences in the language."

----
'''Iterator:''' "Provide a way to access the elements of an aggregate object sequentially without exposing its underlying representation."

 package require snit

 snit::type stringIterator {
 	method new {varname} {
	  	set i [iterator %AUTO% -variable $varname -firstCommand {
	  		string index $%N [set %C 0]
	  	} -nextCommand {
	  		string index $%N $%C
	  	} -donePredicate {
	  		expr {$%C >= [string length $%N]}
	  	} -currentReader {
	  		string index $%N $%I
	  	} -currentWriter {
	  		set %N [string replace $%N $%I $%I $%V]
	  	}]
 	}
 }
 
 snit::type iterator {
 	option -variable
 	variable varname
 	onconfigure -variable value {set varname $value}

 	option -firstCommand
 	option -nextCommand
 	option -donePredicate
 	option -currentReader
 	option -currentWriter
 	
 	variable current
 	
 	method first {} {
 		set cmd [$self cget -firstCommand]
 		lappend mappings %C [varname current] %N $varname
 		set cmd [string map $mappings $cmd]
 		eval $cmd
 	}
 	
 	method next {} {
 		set cmd [$self cget -nextCommand]
 		lappend mappings %C [varname current] %N $varname
 		set cmd [string map $mappings $cmd]
 		incr current
 		eval $cmd
 	}
 	
 	method isDone {} {
 		set cmd [$self cget -donePredicate]
 		lappend mappings %C [varname current] %N $varname
 		set cmd [string map $mappings $cmd]
 		eval $cmd
 	}
 	
 	method currentItem {{value {}}} {
 		if {$value eq {}} {
 			set cmd [$self cget -currentReader]
 		} else {
 			set cmd [$self cget -currentWriter]
 		}
 		lappend mappings %N $varname %I current %V value
 		set cmd [string map $mappings $cmd]
 		eval $cmd
 	}
 } 

Example:
 
 proc main args {
 	set ::a {Hello World}
 	stringIterator si
 	set i [si new ::a]
 	for {$i first} {![$i isDone]} {$i next} {
 		puts [$i currentItem]
 	}
 }

----
'''Mediator:''' "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 chatroom {
 	variable participants
 	
 	method register participant {
 		set participants([$participant cget -name]) $participant
 		$participant configure -chatroom $self
 	}
 	
 	method send {from whom what} {
 		if {[info exists participants($whom)]} {
 			set recipient $participants($whom)
 			$recipient receive $from $what
 		}
 	}
 }

 snit::type participant {
 	option -name 
 	option -chatroom
 	
 	method send {whom what} {
 		[$self cget -chatroom] send [$self cget -name] $whom $what
 	}
 	
 	method receive {from what} {
 		return "$from to [$self cget -name]: '$what'"
 	}
 } 
 
 snit::type beatleParticipant {
 	delegate option * to base
 	delegate method send to base

 	variable base
 	 	
 	method receive {from what} {
 		puts "To a Beatle: [$base receive $from $what]"
 	}
 	
 	constructor args {
 		set base [participant %AUTO%]
 		$self configurelist $args
 	}
  }
 
 snit::type nonBeatleParticipant {
 	delegate option * to base
 	delegate method send to base
 	
 	variable base
 	 	
 	method receive {from what} {
 		puts "To a Non-Beatle: [$base receive $from $what]"
 	}
 	
 	constructor args {
 		set base [participant %AUTO%]
 		$self configurelist $args
 	}
 }

Example:
 
 proc main args {
	 # Create chatroom
	 chatroom c
	 
	 # Create 'chatters' and register them
	 set George [beatleParticipant %AUTO% -name George]
	 set Paul   [beatleParticipant %AUTO% -name Paul]
	 set Ringo  [beatleParticipant %AUTO% -name Ringo]
	 set John   [beatleParticipant %AUTO% -name John]
	 set Yoko   [nonBeatleParticipant %AUTO% -name Yoko]
	 
	 c register $George
	 c register $Paul
	 c register $Ringo
	 c register $John
	 c register $Yoko
	 
	 # 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"
 }

----
'''Memento:''' "Without violating encapsulation, capture and externalize an object's internal state so that the object can be restored to this state later."

 package require snit

 # originator 
 snit::type salesProspect {
 	option -name
 	option -phone
 	option -budget
 	
 	method show {} {
 		puts "\nSales prospect ---- "
 		puts "Name: [$self cget -name]" 
 		puts "Phone: [$self cget -phone]" 
 		puts "Budget: [$self cget -budget]" 
	}
 	
 	method createMemento {} {
 		set m [prospectMemory %AUTO% -state [array get options]]
 	}
 	
 	method restoreMemento {memento} {
 		array set options [$memento cget -state]
 	}
 }
 
 # memento
 snit::type prospectMemory {
 	option -state
 }

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 show
 	
 	s restoreMemento $m
 	s show
 }

----
'''Observer:''' "Define a one-to-many dependency between objects so that when one object changes state, all its dependents are notified and updated automatically."

 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
 	}
 }

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
 	}
 }