├── Singleton └── singleton.tcl ├── Iterator └── Iterator.tcl ├── Decorator └── Decorator.tcl ├── AbstractClassHelper.tcl ├── Strategy ├── strategy.tcl └── strategy_with_abstract.tcl ├── Visitor └── Visitor.tcl ├── Bridge └── Bridge.tcl ├── State └── State.tcl ├── Memento └── memento.tcl ├── LICENSE ├── Chain_of_responsibility ├── chain_of_responsibility.tcl └── chain_of_responsibility2.tcl ├── Command └── command.tcl ├── README.md ├── Observer └── Observer.tcl ├── Abstract_factory └── AbstrarctFactory.tcl ├── Composite └── Composite.tcl ├── Builder └── Builder.tcl ├── Mediator └── mediator.tcl └── Interpreter └── Interpreter.tcl /Singleton/singleton.tcl: -------------------------------------------------------------------------------- 1 | package require oo::util 2 | 3 | ################################################################################ 4 | # Only one instance of this kind of object possible. # 5 | ################################################################################ 6 | ooutil::singleton create logger { 7 | constructor {} { 8 | puts "Singleton example" 9 | } 10 | 11 | method log {str} { 12 | puts $str 13 | } 14 | } 15 | 16 | set obj1 [logger new] 17 | set obj2 [logger new] 18 | puts "obj1 handler: $obj1\,obj2 handler: $obj2 " 19 | 20 | puts [info class instances logger] -------------------------------------------------------------------------------- /Iterator/Iterator.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | oo::class create collection { 5 | variable data 6 | 7 | constructor {d} { 8 | set data $d 9 | } 10 | 11 | method create_iterator {} { 12 | return [iterator new [self]] 13 | } 14 | } 15 | 16 | 17 | oo::class create iterator { 18 | variable collection 19 | variable index 20 | 21 | constructor {c} { 22 | set index 0 23 | set collection $c 24 | } 25 | 26 | method next {} { 27 | if {$index == [llength [set [set collection]::data]]} { 28 | return -code error "OutOfList" 29 | } 30 | set ret [lindex [set [set collection]::data] $index] 31 | incr index 32 | return $ret 33 | } 34 | } 35 | 36 | 37 | set obj [collection new [list 1 2 3 4]] 38 | set iter [$obj create_iterator] 39 | while {[catch {set val [$iter next]}] != 1} { 40 | puts $val 41 | } -------------------------------------------------------------------------------- /Decorator/Decorator.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Extend method functionality without changing method # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | oo::class create TestMethod { 11 | 12 | method someBasicMethod {a b} { 13 | return [expr $a + $b] 14 | } 15 | 16 | #decorator 17 | method exampleDecorator {args} { 18 | set res [next {*}$args] 19 | if {$res < 0} { 20 | return 0 21 | } elseif {$res > 10} { 22 | return 10 23 | } else { 24 | return $res 25 | } 26 | } 27 | 28 | filter exampleDecorator 29 | } 30 | 31 | set n [TestMethod new] 32 | puts [$n someBasicMethod 1 2] 33 | puts [$n someBasicMethod -10 2] 34 | puts [$n someBasicMethod 1 20] -------------------------------------------------------------------------------- /AbstractClassHelper.tcl: -------------------------------------------------------------------------------- 1 | #Implemantation of class used to create abstract methods - ref to wiki article https://wiki.tcl.tk/40639 2 | oo::class create ::class { 3 | superclass oo::class 4 | self method create {name args} { 5 | set instance [next $name {*}$args] 6 | oo::define $instance superclass -append [self] 7 | return $instance 8 | } 9 | method new args { 10 | my 11 | next {*}$args 12 | } 13 | method create {name args} { 14 | my 15 | next $name {*}$args 16 | } 17 | 18 | method {} { 19 | foreach m [info class methods [self] -all] { 20 | set call [lindex [info class call [self] $m] 0] 21 | if {[lindex $call 0] eq "method" && [lindex $call 3] eq "method"} { 22 | set cls [lindex $call 2] 23 | set body [lindex [info class definition $cls $m] 1] 24 | if {$body eq "abstract"} { 25 | return -code error -level 2 \ 26 | -errorcode {CLASS ABSTRACTMETHOD} \ 27 | "[self] is abstract (method \"$m\")" 28 | } 29 | } 30 | } 31 | } 32 | } -------------------------------------------------------------------------------- /Strategy/strategy.tcl: -------------------------------------------------------------------------------- 1 | 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Different algorithms which can be used interchangeably # 6 | # Strategy lets the algorithm vary independently from the clients that use it. # 7 | ################################################################################ 8 | oo::class create Strategy1 { 9 | constructor {} { 10 | puts "Strategy 1" 11 | } 12 | 13 | method doSomething {} { 14 | puts "doSomething according to the strategy 1" 15 | } 16 | } 17 | 18 | oo::class create Strategy2 { 19 | constructor {} { 20 | puts "Strategy 2" 21 | } 22 | 23 | method doSomething {} { 24 | puts "doSomething according to the strategy 2" 25 | } 26 | } 27 | 28 | oo::class create Client { 29 | variable strategy 30 | 31 | constructor s { 32 | set strategy $s 33 | } 34 | 35 | method action {} { 36 | $strategy doSomething 37 | } 38 | } 39 | 40 | #initialize app with strategy1 41 | set strategy [Strategy1 new] 42 | set myApp [Client new $strategy] 43 | $myApp action 44 | 45 | 46 | set strategy [Strategy2 new] 47 | set myApp [Client new $strategy] 48 | $myApp action -------------------------------------------------------------------------------- /Visitor/Visitor.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Different algorithms which can be used interchangeably # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create Element { 13 | method accept {visitor} abstract 14 | } 15 | 16 | class create ConcreteElement1 { 17 | superclass Element 18 | method accept {visitor} { 19 | $visitor accepted [self] 20 | } 21 | } 22 | 23 | class create ConcreteElement2 { 24 | method accept {visitor} { 25 | $visitor accepted [self] 26 | } 27 | } 28 | 29 | class create Visitor { 30 | method accepted {o} abstract 31 | } 32 | 33 | class create ConcreteVisitor { 34 | method accepted {o} { 35 | puts "ConcreteVisitor: accepted by $o" 36 | } 37 | } 38 | 39 | set Element1 [ConcreteElement1 new] 40 | set Element2 [ConcreteElement2 new] 41 | set Visitor1 [ConcreteVisitor new] 42 | 43 | $Element1 accept $Visitor1 44 | $Element2 accept $Visitor1 -------------------------------------------------------------------------------- /Bridge/Bridge.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Decouple an abstraction from its implementation so that the two can vary # 6 | # independently # 7 | # This example uses abstract method implemented according to the wiki article: # 8 | # https://wiki.tcl.tk/40639 # 9 | ################################################################################ 10 | 11 | source {../AbstractClassHelper.tcl} 12 | 13 | class create AbstractionInterface { 14 | variable _implementator 15 | 16 | constructor {implementator} { 17 | set _implementator $implementator 18 | } 19 | 20 | method doSomething {str} { 21 | $_implementator doSomething_implementation $str 22 | } 23 | } 24 | 25 | class create AbstractImplementator { 26 | 27 | method doSomething_implementation {str} abstract 28 | } 29 | 30 | class create Implementator { 31 | superclass AbstractImplementator 32 | 33 | method doSomething_implementation {str} { 34 | puts $str 35 | } 36 | } 37 | 38 | 39 | set implementator [Implementator new] 40 | set interface [AbstractionInterface new $implementator] 41 | 42 | $interface doSomething "test 123" -------------------------------------------------------------------------------- /State/State.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Object state as a class - an object oriented state machine # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create Context { 13 | variable state 14 | 15 | 16 | constructor {s} { 17 | set state $s 18 | } 19 | 20 | method request {} { 21 | $state handle 22 | } 23 | 24 | method setState {s} { 25 | set state $s 26 | } 27 | } 28 | 29 | class create State { 30 | method handle {} abstract 31 | } 32 | 33 | class create ConcreteState1 { 34 | superclass State 35 | 36 | method handle {} { 37 | puts "C1 handle request" 38 | } 39 | } 40 | 41 | class create ConcreteState2 { 42 | superclass State 43 | 44 | method handle {} { 45 | puts "C2 handle request" 46 | } 47 | } 48 | 49 | set C1 [ConcreteState1 new] 50 | set C2 [ConcreteState2 new] 51 | set Context1 [Context new $C1] 52 | $Context1 request 53 | $Context1 setState $C2 54 | $Context1 request -------------------------------------------------------------------------------- /Memento/memento.tcl: -------------------------------------------------------------------------------- 1 | package require TclOO 2 | 3 | ################################################################################ 4 | # Store internal object state and restore on request. # 5 | ################################################################################ 6 | oo::class create Persistence { 7 | variable pers 8 | 9 | method initialize {} { 10 | array set pers [] 11 | } 12 | 13 | method store {obj} { 14 | foreach v [info object vars $obj] { 15 | set pers($v) [set [set obj]::$v] 16 | } 17 | } 18 | 19 | method restore {obj} { 20 | foreach var [array names pers] { 21 | set [set obj]::$var $pers($var) 22 | } 23 | } 24 | } 25 | 26 | oo::class create Originator { 27 | mixin Persistence 28 | 29 | variable var1 30 | variable var2 31 | 32 | constructor {} { 33 | set var1 0 34 | set var2 0 35 | } 36 | 37 | method updateVars {v1 v2} { 38 | set var1 $v1 39 | set var2 $v2 40 | } 41 | 42 | method printVars {} { 43 | puts "var1: $var1 var2: $var2" 44 | } 45 | 46 | method dumpState {} { 47 | my store [self] 48 | } 49 | 50 | method restoreState {} { 51 | my restore [self] 52 | } 53 | } 54 | 55 | set obj [Originator new] 56 | $obj printVars 57 | $obj dumpState 58 | $obj updateVars 10 200 59 | $obj printVars 60 | $obj restoreState 61 | $obj printVars -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, level44 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Chain_of_responsibility/chain_of_responsibility.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # More than one object has chance to handle request. # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create handler { 13 | variable _successor 14 | 15 | constructor {{successor -1}} { 16 | set _successor $successor 17 | } 18 | 19 | method handle {} abstract 20 | } 21 | 22 | class create concreteHandler1 { 23 | superclass handler 24 | variable _sucessor 25 | 26 | method handle {} { 27 | if {1} { 28 | puts "handler 1 - possible" 29 | #object can handle this request 30 | } else { 31 | puts "handler 1 - not possible" 32 | $_successor handle 33 | } 34 | } 35 | } 36 | 37 | class create concreteHandler2 { 38 | superclass handler 39 | variable _successor 40 | 41 | method handle {} { 42 | if {0} { 43 | puts "handler 2 - possible" 44 | #object cannot handle this request 45 | } else { 46 | puts "handler 2 - not possible" 47 | $_successor handle 48 | } 49 | } 50 | } 51 | 52 | set cHandler1 [concreteHandler1 new] 53 | set cHandler2 [concreteHandler2 new $cHandler1] 54 | 55 | $cHandler2 handle -------------------------------------------------------------------------------- /Command/command.tcl: -------------------------------------------------------------------------------- 1 | 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Request as object to log requests, expand API by unavailable methods # 6 | ################################################################################ 7 | oo::class create Book { 8 | variable author 9 | variable title 10 | variable content 11 | 12 | constructor {a t} { 13 | set author $a 14 | set title $t 15 | set content "Not ready yet" 16 | } 17 | 18 | method getAuthor {} { 19 | return $author 20 | } 21 | 22 | method getTitle {} { 23 | return $title 24 | } 25 | 26 | method getContent {} { 27 | return $content 28 | } 29 | } 30 | 31 | oo::class create Command { 32 | variable receiver 33 | 34 | constructor {c} { 35 | set receiver $c 36 | } 37 | 38 | method execute {} { 39 | 40 | } 41 | } 42 | 43 | oo::class create BookAuthor { 44 | superclass Command 45 | variable receiver 46 | 47 | method execute {} { 48 | return [$receiver getAuthor] 49 | } 50 | } 51 | 52 | oo::class create BookTitle { 53 | superclass Command 54 | variable receiver 55 | 56 | method execute {} { 57 | return [$receiver getTitle] 58 | } 59 | } 60 | 61 | oo::class create BookSummary { 62 | superclass Command 63 | variable receiver 64 | 65 | method execute {} { 66 | set resp "Author: [$receiver getAuthor]\n" 67 | append resp "Title: [$receiver getTitle]\n" 68 | append resp "Content: [$receiver getContent]\n" 69 | return $resp 70 | } 71 | } 72 | 73 | set book1 [Book new "Anonymous Writer" "Design Patterns"] 74 | set command1 [BookAuthor new $book1] 75 | set command2 [BookTitle new $book1] 76 | set command3 [BookSummary new $book1] 77 | puts [$command1 execute] 78 | puts [$command2 execute] 79 | puts "Summary:" 80 | puts [$command3 execute] -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # design-patterns-in-tcl 2 | A collection of popular design patterns implemented in TCL language with TclOO package 3 | 4 | ### Collection contains : 5 | - Abstract factory - Provide an interface for creating families of related or dependent objects without specifying their concrete classes. 6 | - Bridge - Decouple an abstraction from its implementation so that the two can vary independently. 7 | - Builder - Separate the construction of a complex object from its representation so that the same construction process can create different representations. 8 | - Chain of responsibility - More than one object has chance to handle request. 9 | - Command - Request as object to log requests, expand API by unavailable methods. 10 | - Composite - Compose objects into tree structures to represent part-whole hierarchies. 11 | - Decorator - Extend method functionality without changing method. 12 | - Facade (TBD) 13 | - Flyweight (TBD) 14 | - Interpreter - Define representation for some grammar. 15 | - Iterator 16 | - Mediator - Simplifing communication between objects. 17 | - Memento - Store internal object state and restore on request. 18 | - Observer - Notify all registered objects about changes. 19 | - Singleton - Only one instance of this kind of object possible. 20 | - State - Object state as a class - an object oriented state machine. 21 | - Strategy - Different algorithms which can be used interchangeably. 22 | - Visitor - Different algorithms which can be used interchangeably. 23 | 24 | ### Theory and additional meterials 25 | Design patterns implemented according to the tips and documentation available on the [sourcemaking.com](https://sourcemaking.com/design_patterns) webpage and in the [Design Patterns: Elements Of Reusable Object-Oriented Software](https://read.amazon.com/kp/embed?asin=B000SEIBB8&preview=newtab&linkCode=kpe&ref_=cm_sw_r_kb_dp_HaFbAbXCYNF0Z) book 26 | -------------------------------------------------------------------------------- /Chain_of_responsibility/chain_of_responsibility2.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # More than one object has chance to handle request. # 6 | # Handlers does not know about each other. # 7 | # This example uses abstract method implemented according to the wiki article: # 8 | # https://wiki.tcl.tk/40639 # 9 | ################################################################################ 10 | 11 | source {../AbstractClassHelper.tcl} 12 | 13 | class create handler { 14 | method handle {} abstract 15 | } 16 | 17 | class create concreteHandler1 { 18 | superclass handler 19 | 20 | method handle {} { 21 | if {0} { 22 | puts "handler 1 - possible" 23 | return 0 24 | } else { 25 | puts "handler 1 - not possible" 26 | return -1 27 | } 28 | } 29 | } 30 | 31 | class create concreteHandler2 { 32 | superclass handler 33 | 34 | method handle {} { 35 | if {1} { 36 | puts "handler 2 - possible" 37 | return 0 38 | } else { 39 | puts "handler 2 - not possible" 40 | return -1 41 | } 42 | } 43 | } 44 | 45 | class create requestHandler { 46 | variable handlers 47 | 48 | constructor {} { 49 | set handler [list] 50 | } 51 | 52 | method registerHandler {handler} { 53 | lappend handlers $handler 54 | } 55 | 56 | method handle {} { 57 | foreach handler $handlers { 58 | if {[set resp [$handler handle]] >= 0} { 59 | return $resp 60 | } 61 | } 62 | return -1 63 | } 64 | } 65 | 66 | set cHandler1 [concreteHandler1 new] 67 | set cHandler2 [concreteHandler2 new] 68 | 69 | set rHandler [requestHandler new] 70 | $rHandler registerHandler $cHandler1 71 | $rHandler registerHandler $cHandler2 72 | 73 | puts [$rHandler handle] -------------------------------------------------------------------------------- /Observer/Observer.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Notify all registered objects about changes # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create Subject { 13 | variable state 14 | variable observers 15 | 16 | constructor {} { 17 | set state 0 18 | set observers [list] 19 | } 20 | 21 | method attach {o} { 22 | lappend observers $o 23 | } 24 | 25 | method detach {o} { 26 | set observers [lreplace $observers [lsearch $observers $o] [lsearch $observers $o]] 27 | } 28 | 29 | method notify {} { 30 | foreach observer $observers { 31 | $observer update $state 32 | } 33 | } 34 | 35 | method update_state {s} { 36 | set state $s 37 | [self] notify 38 | } 39 | } 40 | 41 | class create Observer { 42 | variable observer_state 43 | 44 | constructor {} { 45 | set observer_state 0 46 | } 47 | 48 | method update {s} abstract 49 | } 50 | 51 | class create ConcreteObserver1 { 52 | superclass Observer 53 | variable observer_state 54 | 55 | method update {s} { 56 | set observer_state $s 57 | puts "C1 updated to $observer_state" 58 | } 59 | } 60 | 61 | class create ConcreteObserver2 { 62 | superclass Observer 63 | variable observer_state 64 | 65 | method update {s} { 66 | set observer_state $s 67 | puts "C2 updated to $observer_state" 68 | } 69 | } 70 | 71 | set c1 [ConcreteObserver1 new] 72 | set c2 [ConcreteObserver2 new] 73 | 74 | set s [Subject new] 75 | $s attach $c1 76 | $s attach $c2 77 | 78 | $s update_state 3 79 | $s update_state 5 80 | 81 | $s detach $c1 82 | 83 | $s update_state 6 -------------------------------------------------------------------------------- /Strategy/strategy_with_abstract.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Different algorithms which can be used interchangeably # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | #implementation abstract class strategy 13 | class create Strategy { 14 | method doSomething {} abstract 15 | } 16 | 17 | #implementation of concrete strategy 18 | class create Strategy1 { 19 | superclass Strategy 20 | constructor {} { 21 | puts "Strategy 1" 22 | } 23 | 24 | method doSomething {} { 25 | puts "doSomething according to the strategy 1" 26 | } 27 | } 28 | 29 | #implementation of concrete strategy 30 | class create Strategy2 { 31 | superclass Strategy 32 | constructor {} { 33 | puts "Strategy 2" 34 | } 35 | 36 | method doSomething {} { 37 | puts "doSomething according to the strategy 2" 38 | } 39 | } 40 | 41 | #implementation without required doSomething method only to show that abstract method works 42 | class create Strategy3 { 43 | superclass Strategy 44 | constructor {} { 45 | puts "Defined only to show that abstract class works" 46 | } 47 | } 48 | 49 | class create Client { 50 | variable strategy 51 | 52 | constructor s { 53 | set strategy $s 54 | } 55 | 56 | method action {} { 57 | $strategy doSomething 58 | } 59 | } 60 | 61 | #initialize app with strategy1 62 | set strategy [Strategy1 new] 63 | set myApp [Client new $strategy] 64 | $myApp action 65 | $myApp destroy 66 | 67 | set strategy [Strategy2 new] 68 | set myApp [Client new $strategy] 69 | $myApp action 70 | $myApp destroy 71 | 72 | #uncomment to test if abstract class works 73 | # set strategy [Strategy3 new] 74 | # set myApp [Client new $strategy] 75 | # $myApp action 76 | # $myApp destroy 77 | -------------------------------------------------------------------------------- /Abstract_factory/AbstrarctFactory.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Provide an interface for creating families of related or dependent # 6 | # objects without specifying their concrete classes. # 7 | # This example uses abstract method implemented according to the wiki article: # 8 | # https://wiki.tcl.tk/40639 # 9 | ################################################################################ 10 | 11 | source {../AbstractClassHelper.tcl} 12 | 13 | class create AbstractFactory { 14 | 15 | method create_product_a {} abstract 16 | 17 | method create_product_b {} abstract 18 | } 19 | 20 | class create ConcreteFactory1 { 21 | 22 | method create_product_a {} { 23 | return [ProductA1 new] 24 | } 25 | 26 | method create_product_b {} { 27 | return [ProductB1 new] 28 | } 29 | } 30 | 31 | class create ConcreteFactory2 { 32 | 33 | method create_product_a {} { 34 | return [ProductA2 new] 35 | } 36 | 37 | method create_product_b {} { 38 | return [ProductB2 new] 39 | } 40 | } 41 | 42 | class create Product { 43 | method interface {} abstract 44 | } 45 | 46 | class create ProductA1 { 47 | method interface {} { 48 | puts "Interface called for [info object class [self]]" 49 | } 50 | } 51 | 52 | class create ProductB1 { 53 | method interface {} { 54 | puts "Interface called for [info object class [self]]" 55 | } 56 | } 57 | 58 | class create ProductA2 { 59 | method interface {} { 60 | puts "Interface called for [info object class [self]]" 61 | } 62 | } 63 | 64 | class create ProductB2 { 65 | method interface {} { 66 | puts "Interface called for [info object class [self]]" 67 | } 68 | } 69 | 70 | set Factory1 [ConcreteFactory1 new] 71 | set Factory2 [ConcreteFactory2 new] 72 | 73 | set someProduct1 [$Factory1 create_product_a] 74 | set someProduct2 [$Factory2 create_product_a] 75 | 76 | $someProduct1 interface 77 | $someProduct2 interface 78 | -------------------------------------------------------------------------------- /Composite/Composite.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Compose objects into tree structures to represent part-whole hierarchies. # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create Component { 13 | method doSomething {} abstract 14 | } 15 | 16 | class create Composite { 17 | superclass Component 18 | 19 | variable _children 20 | 21 | constructor {} { 22 | set _children [] 23 | } 24 | 25 | method doSomething {} { 26 | #foreach child doSomething 27 | foreach child $_children { 28 | $child doSomething 29 | } 30 | } 31 | 32 | method add {component} { 33 | lappend _children $component 34 | } 35 | 36 | method remove {component} { 37 | set _children [lreplace $_children [lsearch $_children $component] [lsearch $_children $component]] 38 | } 39 | } 40 | 41 | class create Leaf { 42 | superclass Component 43 | 44 | variable _name 45 | 46 | constructor {name} { 47 | set _name $name 48 | } 49 | 50 | method doSomething {} { 51 | puts "doSomething for [self] $_name" 52 | } 53 | } 54 | 55 | set leaf1 [Leaf new "Leaf1"] 56 | set leaf2 [Leaf new "Leaf2"] 57 | set leaf3 [Leaf new "Leaf3"] 58 | set composite1 [Composite new] 59 | set composite2 [Composite new] 60 | 61 | #simulate following structure 62 | #-composite1 63 | # -leaf1 64 | # -composite2 65 | # -leaf2 66 | # -leaf3 67 | $composite1 add $leaf1 68 | $composite2 add $leaf2 69 | $composite2 add $leaf3 70 | $composite1 add $composite2 71 | puts "Call doSomething for full structure" 72 | $composite1 doSomething 73 | 74 | #remove leaf3 and call doSomething again 75 | $composite2 remove $leaf3 76 | puts "Call doSomething for structure without leaf3" 77 | $composite1 doSomething 78 | 79 | #remove composite2 and coll doSomething again 80 | $composite1 remove $composite2 81 | puts "Call doSomething for structure without composite2" 82 | $composite1 doSomething -------------------------------------------------------------------------------- /Builder/Builder.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Separate the construction of a complex object from its representation so # 6 | # that the same construction process can create different representations. # 7 | # This example uses abstract method implemented according to the wiki article: # 8 | # https://wiki.tcl.tk/40639 # 9 | ################################################################################ 10 | 11 | source {../AbstractClassHelper.tcl} 12 | 13 | class create Director { 14 | variable _builder 15 | 16 | constructor {builder} { 17 | set _builder $builder 18 | } 19 | 20 | method buildProduct {} { 21 | $_builder buildWheels 22 | $_builder buildBody 23 | $_builder buildEngine 24 | } 25 | } 26 | 27 | class create Builder { 28 | variable Product 29 | 30 | constructor {} { 31 | set Product [Product new] 32 | } 33 | 34 | method buildWheels {} abstract 35 | method buildBody {} abstract 36 | method buildEngine {} abstract 37 | } 38 | 39 | class create ConcreteBuilder { 40 | superclass Builder 41 | variable Product 42 | 43 | # constructor {args} { 44 | # next {*}$args 45 | # } 46 | 47 | method buildWheels {} { 48 | puts "Building wheels" 49 | $Product wheels 4 50 | } 51 | 52 | method buildBody {} { 53 | puts "Building body" 54 | $Product body sedan 55 | } 56 | 57 | method buildEngine {} { 58 | puts "Building engine" 59 | $Product engine "v6" 60 | } 61 | 62 | method product {} { 63 | return $Product 64 | } 65 | } 66 | 67 | class create Product { 68 | variable _wheels 69 | variable _body 70 | variable _engine 71 | 72 | constructor {} { 73 | set _wheels -1 74 | set _body -1 75 | set _engine -1 76 | } 77 | 78 | method wheels {wheels} { 79 | set _wheels $wheels 80 | } 81 | 82 | method body {body} { 83 | set _body $body 84 | } 85 | 86 | method engine {engine} { 87 | set _engine $engine 88 | } 89 | 90 | method specification {} { 91 | return [dict create wheels $_wheels body $_body engine $_engine] 92 | } 93 | } 94 | 95 | set builder [ConcreteBuilder new] 96 | set director [Director new $builder] 97 | $director buildProduct 98 | set product [$builder product] 99 | puts [$product specification] -------------------------------------------------------------------------------- /Mediator/mediator.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Simplifing communication between objects # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create mediator { 13 | variable collegues 14 | 15 | constructor {} { 16 | array set collegues [list] 17 | } 18 | 19 | method addCollegue {name} abstract 20 | 21 | method removeCollegue {name} abstract 22 | 23 | method sendMsg {msg collegue} abstract 24 | } 25 | 26 | class create collegue { 27 | variable mediator 28 | 29 | constructor {m} { 30 | set mediator $m 31 | } 32 | 33 | method receive {msg} abstract 34 | } 35 | 36 | class create concreteMediator { 37 | superclass mediator 38 | variable collegues 39 | 40 | constructor {} { 41 | next 42 | } 43 | 44 | method addCollegue {name collegue} { 45 | set collegues($name) $collegue 46 | } 47 | 48 | method removeCollegue {$name} { 49 | unset -nocomplain collegues($name) 50 | } 51 | 52 | method sendMsg {msg collegue} { 53 | foreach name [array names collegues] { 54 | if {$collegue != $collegues($name)} { 55 | $collegues($name) receive $msg 56 | } 57 | } 58 | } 59 | } 60 | 61 | class create concreteCollegue1 { 62 | superclass collegue 63 | variable mediator 64 | 65 | method receive {msg} { 66 | puts "Received C1: $msg" 67 | } 68 | 69 | method send {msg} { 70 | $mediator sendMsg $msg [self] 71 | } 72 | } 73 | 74 | class create concreteCollegue2 { 75 | superclass collegue 76 | variable mediator 77 | 78 | method receive {msg} { 79 | puts "Received C2: $msg" 80 | } 81 | 82 | method send {msg} { 83 | $mediator sendMsg $msg [self] 84 | } 85 | } 86 | 87 | class create concreteCollegue3 { 88 | superclass collegue 89 | variable mediator 90 | 91 | method receive {msg} { 92 | puts "Received C3: $msg" 93 | } 94 | 95 | method send {msg} { 96 | $mediator sendMsg $msg [self] 97 | } 98 | } 99 | 100 | 101 | set m [concreteMediator new] 102 | set c1 [concreteCollegue1 new $m] 103 | set c2 [concreteCollegue2 new $m] 104 | set c3 [concreteCollegue3 new $m] 105 | 106 | $m addCollegue 'C1' $c1 107 | $m addCollegue 'C2' $c2 108 | $m addCollegue 'C3' $c3 109 | 110 | $c1 send "Communication test from C1" 111 | $c2 send "Communication test from C2" -------------------------------------------------------------------------------- /Interpreter/Interpreter.tcl: -------------------------------------------------------------------------------- 1 | console show 2 | package require TclOO 3 | 4 | ################################################################################ 5 | # Define representation for some grammar # 6 | # This example uses abstract method implemented according to the wiki article: # 7 | # https://wiki.tcl.tk/40639 # 8 | ################################################################################ 9 | 10 | source {../AbstractClassHelper.tcl} 11 | 12 | class create Interpreter { 13 | variable data 14 | 15 | constructor {d} { 16 | set data $d 17 | } 18 | 19 | method interpret {m} abstract 20 | } 21 | 22 | class create ConcreteInterpreter { 23 | method interpret {m o} { 24 | if {[regexp {book\s([0-9])\sget\s(title|author|content)} $m match bookNumber bookCommand]} { 25 | switch $bookCommand { 26 | "title" { 27 | return [$o getTitle $bookNumber] 28 | } 29 | "author" { 30 | return [$o getAuthor $bookNumber] 31 | } 32 | "content" { 33 | return [$o getContent $bookNumber] 34 | } 35 | } 36 | } else { 37 | return "Wrong command" 38 | } 39 | } 40 | } 41 | 42 | class create Book { 43 | variable _author 44 | variable _title 45 | variable _content 46 | 47 | constructor {author title content} { 48 | set _author $author 49 | set _title $title 50 | set _content $content 51 | } 52 | 53 | method getAuthor {} { 54 | return $_author 55 | } 56 | 57 | method getTitle {} { 58 | return $_title 59 | } 60 | 61 | method getContent {} { 62 | return $_content 63 | } 64 | } 65 | 66 | class create Books { 67 | variable books 68 | 69 | constructor {} { 70 | set books [list] 71 | } 72 | 73 | method addBook {author title content} { 74 | lappend books [Book new $author $title $content] 75 | } 76 | 77 | method getAuthor {bookNumber} { 78 | return [[lindex $books [expr $bookNumber - 1]] getAuthor] 79 | } 80 | 81 | method getTitle {bookNumber} { 82 | return [[lindex $books [expr $bookNumber - 1]] getTitle] 83 | } 84 | 85 | method getContent {bookNumber} { 86 | return [[lindex $books [expr $bookNumber - 1]] getContent] 87 | } 88 | 89 | #filtering wrong requests 90 | method checkLimit {args} { 91 | set method [lindex [self target] end] 92 | if {$method in [list getAuthor getTitle getContent]} { 93 | if {[string is digit $args]} { 94 | if {$args > [llength $books]} { return "Wrong book number" } 95 | } else { return "Wrong book number" } 96 | } 97 | next {*}$args 98 | } 99 | filter checkLimit 100 | } 101 | 102 | set library [Books new] 103 | $library addBook "Edgard Nowak" "PHP for dummies" "Chapter 1 tbd" 104 | $library addBook "Marian Kowalski" "jQuery for dummies" "Chapter 1 tbd" 105 | 106 | set c [ConcreteInterpreter new] 107 | puts [$c interpret "book 1 get title" $library] 108 | puts [$c interpret "book 1 get author" $library] 109 | puts [$c interpret "book 2 get title" $library] 110 | puts [$c interpret "book 2 get author" $library] 111 | #index out of range 112 | puts [$c interpret "book 3 get author" $library] 113 | #wrong command 114 | puts [$c interpret "books 3 get author" $library] 115 | --------------------------------------------------------------------------------