Updated 2017-05-26 17:08:12 by ak

I was searching for design patterns in Tcl

Tcl is a dynamic language and provides other possibilities like Java and so on.

This script shows 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...

AK - 2017-05-25 10:52:15

A slight modification to the above uses an alias for access to the strategy object instead of placing it into a variable. Effectively the object's namespace is used for storage and linkage. This makes the call sites more readable, less dynamic. Not sure if it compiles to better byte code or not.
oo::class create Car {
     constructor b {
         interp alias {} [namespace current]::Brakes {} $b
         # b has to be an FQN, or we need code to determine such.
     }
     method brake {} {
         Brakes applyBrakes
     }
}

ak - 2017-05-26 17:08:12

As a last note, while it might be tempting to use namespace import to pull the command into the scope, that is contra-indicated for several reasons:

  1. You cannot import anything which is not exported explicitly via namespace export. Most commands are not exported and most people are not in the habit of doing this on the off chance somebody might wish to use it.
  2. The import will make the command only available under its original name. A rename must be used if that does not fit in the destination. And if there are naming conflicts with multiple imports, care must be taken to choose a proper order for imports and renames.

The form using interp alias has none of the troubles.


[Category Strategy Pattern]