#! /usr/local/tcl/bin/wish # # ___ 0 Michel Beaudouin-Lafon e-mail: mbl@lri.fr # / \ / LRI - Bat 490 www : http://www-ihm.lri.fr/~mbl # / __/ / Universite de Paris-Sud voice : +33 1 69 15 69 10 # /__ \/ 91 405 ORSAY Cedex - FRANCE fax : +33 1 69 15 65 86 # # Package permettant d'utiliser des machines a etats en Tcl/Tk. # Voir la documentation jointe "Machines a etat mini-tutorial". # Les autres fichiers de ce repertoire sont des exemples d'utilisation. # # syntax : # StateMachine::define { # local ... # # state { # enter { ... } # when ... # when ... # ... # leave { ... } # } # # states ... { ... } # # lproc {args} {body} # } # # local is used to declare local variables # state is used to declare a state # states is used to declare transitions common to several states # lproc is used to declare local procedures. # Using variable in an lproc enables acces to the local variables of the state machine # # within a state, # enter is used to declare code to be executed when this state becomes current # leave is used to declare code to be executed when this state is no longer current # when is used to declare transitions # # valid s and mapping to Tk event in a transition: # Down # Move # Motion # Up # Key note: Key- is also recognized # EnterItem <> virtual event when entering a canvas item # LeaveItem <> virtual event when leaving a canvas item # TimeOut <> virtual event generated by arm # # valid clauses in transitions: # with specify that the modifier key must be down # at put current mouse position in # onItem check that cursor is on a canvas item and put its item number in # withTag check that cursor is on a canvas item with the given tag # note: these must be combined like this: onItem i withTag t # and check that is true # do execute body # -> next state is sname # ### TBD # by store in the motion since last event that moved mouse # # - enable and disable code to be executed when the machine is enabled/disabled # state_machine { # enable widget {...} # widget is the name of the widget for which the machine # disable widget {...} # is enabled/disabled # } # - the enter code of the initial state is not executed # -> maybe not a problem with the enable/disable code # or should be automatically appended to the enable code? # - question: what to do if the same machine is used for several widgets # right now there is one global state, i.e. one machine. # - onTag condition for texts # - inheritance and combination of state machines... # - compile state machine into a file for faster reload # - replace sm array in StateMachine by a set of local variables. Should be faster and easier to read # package provide StateMachine 1.1 # we define 3 namespaces: # StateMachine for the definition of a state machine # StateMachine::Define for the procs that are valid inside the definition of a machine # StateMachine::State for the procs that are valid inside the definition of a state # # a state machine is compiled into a namespace whose name is that of the machine and a set # of bindings for the bindtag sm where name is the name of the machine. # # namespace for the definition of a state machine: # define # enable/disable # namespace eval ::StateMachine { namespace export define enable disable # sm contains the description of the state machine as it is parsed. # it is an array with the following indices: # name name of the state machine # locals list of names of local variables # states list of names of states # events list of names of events # for each event ev: # ev list of transitions for the event ev # a transition is a tuple (state, init, cond, body, newstate) # where state is the starting state, init the initialization code, # cond the condition, body the action and newstate the destination state. # curstate name of the state being defined variable sm # define a state machine # proc define {name body} { variable sm # reinitialize sm foreach key [array names sm] { unset sm($key) } array set sm " name $name locals {} events {} states {} " # create the description of the machine: # evaluate its description in the context of the StateMachine::Define namespace namespace eval Define $body #parray sm # create local variables and procs in the state machine # - vars declared in the machine # - vars to execute the machine: current state, event and widget # - proc to arm a timeout namespace eval ::$name { foreach var $::StateMachine::sm(locals) { variable $var } variable _state [lindex $::StateMachine::sm(states) 0] variable _event {} variable _widget {} variable _armId {} # store the representation of the machine in case we want to inherit from it variable _locals $::StateMachine::sm(locals) variable _states $::StateMachine::sm(states) variable _events $::StateMachine::sm(events) foreach event $_events { set _trans($event) $::StateMachine::sm($event) } proc arm {ms {event TimeOut}} { variable _armId variable _widget after cancel _armId set _armId [after $ms "event generate $_widget <<$event>>"] } } # translate transitions for widgets into bindings foreach event $sm(events) { #puts "translating event $event" # bind contains the generated code. It has the following structure: # bind smMachineName { # namespace eval { # declarations and initializations... # # switch -exact $state { # aState { # init variables... # if (cond1) { # action 1 # } else { # init variables... # if (cond2) { # action 2 # } .... # .... # } # } # ... # } # } # } set bind "bind sm$name <$event> \{\n" append bind " namespace eval ::$name \{\n\n" append bind " switch -exact \$_state \{\n" # for each event, we have a list of tuples (state, init, cond, body, newstate) # where state is the state for this handler, init the initialization part, # cond the condition to test, body the action and newstate the state change. # Successive tuples with the same state must be translated into a # cascade of if/then/else, and we must check that all bodies but the # last one in such a sequence have a condition. set lastState "" set lastCond 0 set closeBrace "" foreach {state init cond body newstate} $sm($event) { #puts "processing transition to $newstate" # create the code for the change of state, # including the leave code for the current state # and the enter code for the new state if {$newstate != ""} { if [info exist sm($state:leave)] { append body "\n$sm($state:leave)" } append body "\n\t\t\tset _state $newstate" if [info exist sm($newstate:enter)] { append body "\n$sm($newstate:enter)" } } # create the code for the transition if {$cond != ""} { set body "$init\n\t\t\tif \{$cond\} \{\n$body\t\t\t\}" set hasCond 1 } else { set body "$init\n$body" set hasCond 0 } # append transition to current binding if {$state == $lastState} { if {$lastCond != 1} { error "$name: no condition for transition $event in state $state" return } append bind " else \{\n$body" append closeBrace \} } else { append bind "\t\t$closeBrace" append bind "\n\t\t$state \{\n$body" set closeBrace \} } set lastState $state set lastCond $hasCond } append bind "\t\t$closeBrace\n\t\}\n \}\n\}\n" # create the binding #puts $bind eval $bind } } # enable/disable state machines # proc enable1 {sm widget} { # add a bindtag to the widget set tags [bindtags $widget] lappend tags sm$sm bindtags $widget $tags # define tag bindings for canvases and texts to remap Enter/Leave events # to / virtual events ### should only do this if necessary switch -exact -- [winfo class $widget] { Canvas { $widget bind all "event generate $widget <> -x %x -y %y" # " -detail %d -focus %f -mode %m -root %R -rootx %X -rooty %Y \ -state %s -subwindow %S -time %t -x %x -y %y" $widget bind all "event generate $widget <> -x %x -y %y" } Text { $widget tag bind all "event generate $widget <> -x %x -y %y" $widget tag bind all "event generate $widget <> -x %x -y %y" } } } proc enable {sm args} { foreach widget $args { enable1 $sm $widget } } proc disable1 {sm widget} { # remove bindtag from widget set tags {} foreach tag [bindtags $widget] { if {$tag != "sm$sm"} { lappend tags $tag } } bindtags $widget $tags # remove tag bindings for Canvases and Texts switch -exact -- [winfo class $widget] { Canvas { $widget bind all {} $widget bind all {} } Text { $widget tag bind all {} $widget tag bind all {} } } } proc disable {sm args} { foreach widget $args { disable1 $sm $widget } } } # namespace holding the procs valid inside the definition of a machine: # local # state # lproc # namespace eval ::StateMachine::Define { # declare local variables # proc local {args} { variable [namespace parent]::sm # store the variable names in the "locals" field ### should allow initial values foreach var $args { lappend sm(locals) $var } } # declare a state # proc state {name body} { variable [namespace parent]::sm # append name of state to the "states" field set sm(curstate) $name if {[lsearch -exact $sm(states) $name] < 0} { lappend sm(states) $name } # define the transitions: # evaluate the body of the state in the StateMachine::State namespace namespace eval [namespace parent]::State $body } # declare transitions for several states # proc states {args} { set body [lindex $args end] set states [lreplace $args end end] foreach state $states { state $state $body } } # declare a local proc # proc lproc {name args body} { variable [namespace parent]::sm namespace eval ::$sm(name) [list proc $name $args $body] } } # namespace holding the procs valid inside the definition of a state # enter/leave # when # namespace eval ::StateMachine::State { # smEvent maps event names used in the state machine into Tk events variable smEvent array set smEvent { Down ButtonPress-1 Move Button1-Motion Motion Motion Up ButtonRelease-1 Key KeyPress Enter Enter Leave Leave EnterItem LeaveItem TimeOut } # smClauses maps event names to the ordered list of valid clauses for this event variable smClauses array set smClauses { Down {with at onItem withTag and do ->} Move {with at onItem withTag and do ->} Motion {with at onItem withTag and do ->} Up {with at onItem withTag and do ->} Key {with at onItem withTag and do ->} Enter {with at onItem withTag and do ->} Leave {with at onItem withTag and do ->} EnterItem {with at onItem withTag and do ->} LeaveItem {with at onItem withTag and do ->} TimeOut {and do ->} } # declare enter/leave actions # proc enter {body} { variable [namespace parent]::sm set state $sm(curstate) append sm($state:enter) $body\n } proc leave {body} { variable [namespace parent]::sm set state $sm(curstate) append sm($state:leave) $body\n } # declare a transition # args is a list of couples keyword/value # that define the condition, action and destination state of the transition # proc when {event args} { variable smEvent variable smClauses variable [namespace parent]::sm set state $sm(curstate) # mod is the modifier part of the event # detail is the detail part of the event # init is the initialization part (initialize variables) # cond is the condition # body is the action part # newState is destination state # prevClause is the index of the previous clause to check the ordering set mod "" set detail "" set init "" set cond "" set body "" set newState "" set prevClause -1 # special case for Key events: Key-xx is translated to event=Key and detail=xx if [regexp ^Key-(.*$) $event foo detail] { set event Key } # check that we know about this event if {! [info exists smEvent($event)]} { error "$sm(name): unknown event $event in when clause" } # start body with code that stores current event and widget in state machine (useful to trace events) append body "\t\t\tset _event $event\n" append body "\t\t\tset _widget %W\n" # parse the description of the transition if {[llength $args] %2 != 0} { error "$sm(name): malformed when clause in transition from $state by $event" return } foreach {key value} $args { # check that the clause is valid for the event set clause [lsearch $smClauses($event) $key] if {$clause < 0} { error "$sm(name): invalid clause $key in transition from $state by $event" } elseif {$clause < $prevClause} { error "$sm(name): invalid clause order $key in transition from $state by $event" } set prevClause $clause # lookup the key and interpret the value accordingly switch -exact -- $key { with { set mod $value } at { # at P : store current position in variable P append init "\t\t\tset $value \[list %x %y\]\n" } onItem { # onItem foo : define condition that cursor is on a canvas item # and initialize variable foo with the item number. # obviously this works only for a canvas append init "\t\t\tset $value \[%W find withtag current\]\n" set test "\[llength \$$value\] > 0" if {$cond != ""} { append cond " && $test" } else { set cond "$test" } # Enter and Leave are special for canvas items. # we define tag bindings in texts and canvases that remap them to # and virtual events switch -exact -- $event { Enter { set event EnterItem} Leave { set event LeaveItem} } } withTag { # withTag foo : define condition that cursor is on canvas item with tag foo # obviously this works only for a canvas set test "\[lsearch -exact \[%W gettags current\] $value\] >= 0" if {$cond != ""} { append cond " && $test" } else { set cond "$test" } # Enter and Leave are special for canvas items. # we define tag bindings in texts and canvases that remap them to # and virtual events switch -exact -- $event { Enter { set event EnterItem} Leave { set event LeaveItem} } } and { # and {cond} : define condition if {$cond != ""} { append cond " && $value" } else { set cond "$value" } } do { # do {action} : define action append body $value } -> { # -> state : define destination state set newState $value } default { error "$sm(name) : unknown key \"$key\" in transition from $state by $event" return } } } # build the tk event spec set tkevent "" if {$mod != ""} { append tkevent $mod- } append tkevent $smEvent($event) if {$detail != ""} { append tkevent -$detail } # append the event to the "events" field if it is not already there if [info exist sm(events)] { if {[lsearch -exact $sm(events) $tkevent] < 0} { lappend sm(events) $tkevent } } else { set sm(events) $tkevent } # create the description of the transition and store it at the event index lappend sm($tkevent) $state $init $cond $body $newState } }