Updated 2016-06-29 06:21:54 by dkf

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


[Category Strategy Pattern]