I was searching for desing patterns in Tcl
tcl is a dynamic language and provides other possibilities like Java and so on.
This is my script showin an implementation of the strategy pattern with TclOO
#
#
# Strategy Pattern in tcl with TclOO
#
#
# by Manfred Rosenberger (2016)
#
#
#
package require TclOO
#
oo::class create AbstractShape {
#
# this class will be sourced by concrete classes like
# like triangles, squares, pentagons, hexagons ...
#
variable shapeArray
variable shapePerimeter
variable shapeSideLength
#
constructor {} {
variable shapeArray 0
variable shapePerimeter 0
variable shapeSideLength 0
#
puts " ... AbstractShape"
#
puts "[info object class]"
#
}
#
destructor {
puts " [self] destroy"
}
#
method unknown {target_method args} {
next $target_method $args
}
#
# the following methods are just prototypes to set
# array, perimeter and sideLength
#
method setArraySize {array} {
variable shapeArray
#
set shapeArray
#
return $shapeArray
}
method setPerimeter {perimeter} {
variable shapePerimeter
#
set shapePerimeter
#
return $shapePerimeter
}
method setSideLength {length} {
variable shapeSideLength
#
set shapeSideLength
#
return $shapeSideLength
}
#
# the following methods provides getter methods for
# array, perimeter and sideLength
#
method getArraySize {} {
variable shapeArray
return $shapeArray
}
method getPerimeter {} {
variable shapePerimeter
return $shapePerimeter
}
method getSideLength {} {
variable shapeSideLength
return $shapeSideLength
}
#
# method setStrategy is inherited by calling this superclass
# and available in all objects build with classes derived from this superclass
#
method setStrategy {strategyClass} {
puts " current Strategy: [info object class [self]]"
puts " set Strategy: $strategyClass"
# puts " -> 2 - [self]"
oo::objdefine [self] class $strategyClass
puts " new Strategy: [info object class [self]]"
}
#
method getShapeType {} {
# returns the classname of the object
return [info object class [self]]
}
#
}
#
oo::class create ShapeSquare {
#
superclass AbstractShape
#
variable shapeArray
variable shapePerimeter
variable shapeSideLength
#
constructor {sideLength} {
variable shapeArray 0
variable shapePerimeter 0
variable shapeSideLength $sideLength
#
my setSideLength $sideLength
#
}
#
destructor {
puts " [self] destroy"
}
#
method unknown {target_method args} {
next $target_method $args
}
#
method setArraySize {arraySize} {
variable shapeArray
variable shapeSideLength
#
puts " ... setArraySize $arraySize"
set _sideLength [expr pow($arraySize,0.5)]
my setSideLength $_sideLength
#
return $shapeArray
}
method setPerimeter {perimeter} {
variable shapePerimeter
variable shapeSideLength
#
puts " ... setPerimeter $perimeter"
set _sideLength [expr $perimeter / 4.0]
my setSideLength $_sideLength
#
return $shapePerimeter
}
method setSideLength {length} {
variable shapeArray
variable shapePerimeter
variable shapeSideLength
#
puts " ... setSideLength $length"
set shapeSideLength $length
set shapeArray [expr pow($length,2)]
set shapePerimeter [expr 4 * $length]
#
return $shapeSideLength
}
#
}
oo::class create ShapeTriangle {
#
superclass AbstractShape
#
variable shapeArray
variable shapePerimeter
variable shapeSideLength
#
constructor {sideLength} {
variable shapeArray 0
variable shapePerimeter 0
variable shapeSideLength 0
#
my setSideLength $sideLength
#
}
#
destructor {
puts " [self] destroy"
}
#
method unknown {target_method args} {
next $target_method $args
}
#
#
method setArraySize {arraySize} {
variable shapeArray
variable shapeSideLength
#
puts " ... setArraySize $arraySize"
set _sideLength [expr pow($arraySize*4/pow(3,0.5),0.5)]
my setSideLength $_sideLength
#
return $shapeArray
}
method setPerimeter {perimeter} {
variable shapePerimeter
variable shapeSideLength
#
puts " ... setPerimeter $perimeter"
set _sideLength [expr $perimeter / 3.0]
my setSideLength $_sideLength
#
return $shapePerimeter
}
method setSideLength {length} {
variable shapeArray
variable shapePerimeter
variable shapeSideLength
#
puts " ... setSideLength $length"
set shapeSideLength $length
set shapeArray [expr pow($length,2)*pow(3,0.5)/4]
set shapePerimeter [expr 3 * $length]
#
return $shapeSideLength
}
#
}
#
#
puts "\n"
puts " ---- test ShapeSquare: -----------------------------------------------------------"
puts "\n"
set mySquare [ShapeSquare new 5]
puts " -> [$mySquare getShapeType] ==\n"
#
puts " ... getArraySize [$mySquare getArraySize]"
puts " ... getPerimeter [$mySquare getPerimeter]"
puts " ... getSideLength [$mySquare getSideLength]"
#
puts ""
$mySquare setSideLength 10
#
puts " ... getArraySize [$mySquare getArraySize]"
puts " ... getPerimeter [$mySquare getPerimeter]"
puts " ... getSideLength [$mySquare getSideLength]"
#
puts ""
$mySquare setPerimeter 80
#
puts " ... getArraySize [$mySquare getArraySize]"
puts " ... getPerimeter [$mySquare getPerimeter]"
puts " ... getSideLength [$mySquare getSideLength]"
#
puts ""
$mySquare setArraySize 900
#
puts " ... getArraySize [$mySquare getArraySize]"
puts " ... getPerimeter [$mySquare getPerimeter]"
puts " ... getSideLength [$mySquare getSideLength]"
#
#
#
#
puts "\n"
puts " ---- test ShapeTriangle: ---------------------------------------------------------"
puts "\n"
set myTriangle [ShapeTriangle new 5]
puts " -> [$myTriangle getShapeType] ==\n"
#
puts " ... getArraySize [$myTriangle getArraySize]"
puts " ... getPerimeter [$myTriangle getPerimeter]"
puts " ... getSideLength [$myTriangle getSideLength]"
#
puts ""
$myTriangle setSideLength 10
#
puts " ... getArraySize [$myTriangle getArraySize]"
puts " ... getPerimeter [$myTriangle getPerimeter]"
puts " ... getSideLength [$myTriangle getSideLength]"
#
puts ""
$myTriangle setPerimeter 90
#
puts " ... getArraySize [$myTriangle getArraySize]"
puts " ... getPerimeter [$myTriangle getPerimeter]"
puts " ... getSideLength [$myTriangle getSideLength]"
#
puts ""
$myTriangle setArraySize 900
#
puts " ... getArraySize [$myTriangle getArraySize]"
puts " ... getPerimeter [$myTriangle getPerimeter]"
puts " ... getSideLength [$myTriangle getSideLength]"
#
puts "\n\n"
puts "-- and now magic -- strategy pattern in tcl, a dynamic language"
puts "\n"
#
puts "\n ... myShape is a Square"
set myShape [ShapeSquare new 5]
puts " -> [$myShape getShapeType] ==\n"
puts " ... getArraySize [$myShape getArraySize]"
puts " ... getPerimeter [$myShape getPerimeter]"
puts " ... getSideLength [$myShape getSideLength]"
#
puts "\n ... myShape becomes a Triangle"
#
# oo::objdefine $myShape class ShapeTriangle
# we handle this a little bit more comfortable
#
$myShape setStrategy ShapeTriangle
#
#
#
puts " -> [$myShape getShapeType] ==\n"
puts " ... getArraySize [$myShape getArraySize]"
puts " ... getPerimeter [$myShape getPerimeter]"
puts " ... getSideLength [$myShape getSideLength]"
#
puts "\n ... values did not change so far:("
#
puts "\n ... updat myShape by set a value with its setter-method"
$myShape setSideLength 5
puts " ... getArraySize [$myShape getArraySize]"
puts " ... getPerimeter [$myShape getPerimeter]"
puts " ... getSideLength [$myShape getSideLength]"
puts "\n ... magic, or?"
puts " :) ... what do you think?"
dkf - 2016-06-29 06:21:54
The Strategy pattern, as described on Wikipedia, is trivial to implement in any Tcl object system. All it requires is for there to be a way to delegate a method's behaviour to another object (strictly, anything that follows the invocation pattern; ensembles also work). In TclOO, you have several options, but this is the classic version:
oo::class create BrakingStrategy {
method applyBrakes {} { ... }
}
oo::class create Car {
variable brakingStrategy
constructor b {
set brakingStrategy $b
}
method brake {} {
$brakingStrategy applyBrakes
}
}That is about all it requires, and typing more on mobile isn't fun anyway...