I was searching for desing patterns in Tcl

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

here is my script how the strategy pattern can be used 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"    
                #
        }
            #
        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    
            variable shapePerimeter    
            variable shapeSideLength
                #
            set shapeArray    
                #
            return $shapeArray
        }    
        method setPerimeter {perimeter} {
            variable shapeArray    
            variable shapePerimeter    
            variable shapeSideLength
                #
            set shapePerimeter    
                #
            return $shapePerimeter
        }    
        method setSideLength {length} {
            variable shapeArray    
            variable shapePerimeter    
            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 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 shapePerimeter    
            variable shapeSideLength
                #
            puts "             ... setArraySize $arraySize"
            set _sideLength [expr pow($arraySize,0.5)]
            my setSideLength $_sideLength            
                #
            return $shapeArray
        }    
        method setPerimeter {perimeter} {
            variable shapeArray    
            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 shapePerimeter    
            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 shapeArray    
            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
    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 :) ... what do you think"    
    

======


----

<<categories>>TclOO
<<categories>>Strategy Pattern