Updated 2012-08-30 11:02:51 by RLE

Originally by Danny Dulai http://www.ishiboo.com/~nirva/Projects/phasemachines/ . I've found phasemachines to be very useful. --dnm
 #
 # Commands added while inside phase machine:
 #
 #   phase_go_cb <num>
 #      Returns a callback to the phase given by the number in the
 #      argument. The first phase is 0, the second is 1, etc...
 #
 #   phase_prev_cb
 #      Just like phase_go_cb, but it always returns the callback
 #      to the previous phase
 #
 #   phase_same_cb
 #      Just like phase_go_cb, but it always returns the callback
 #      to the current phase
 #
 #   phase_next_cb
 #      Just like phase_go_cb, but it always returns the callback
 #      to the next phase
 #
 #   phase_go <num> <args>
 #      equiv of doing: eval [phase_go_cb <num>] <args>
 #
 #   phase_next <args>
 #      equiv of doing: eval [phase_next_cb] <args>
 #
 #   phase_exit
 #      cleanup resources used by phase machine
 #
 #------------------------------------------------------------
 #
 # Simple Example:
 #
 # proc foo { name nextphase } {
 #     puts helu
 #     after 1000 "$nextphase yay$name"
 # }
 #
 # phasemachine test { name } {
 #     foo $name [phase_next_cb]
 # } { str } {
 #     puts $str
 #     phase_exit
 # }
 #
 # test hrm
 # vwait done
 #
 # Looping example:
 #
 # proc foo { name nextphase } {
 #     puts helu
 #     after 1000 "$nextphase yay$name"
 # }
 #
 # phasemachine test { name num } {
 #     puts --inphase0:$name:$num
 #     foo $name [phase_next_cb]
 #
 # } { str } {
 #     puts --inphase1:$str
 #     foo $str [phase_next_cb]
 #
 # } { str } {
 #     puts --inphase2:$str
 #     puts helu
 #     after 1000
 #     phase_go 0 bar [expr $num + 1]
 # }
 #
 #test hrm 0
 #vwait done
 #
 #
 
 #------------------------------------------------------------------------------
 
 namespace eval ::phasemachine { set _id 0 }
 proc ::phasemachine::fixvar { v } {
     regsub {([^(]*)\(.*\)} $v {\1} var
     return $var
 }
 
 proc ::phasemachine::__set { id arg } {
     upvar ::phasemachine::${id}::funcs funcs
     upvar ::phasemachine::${id}::state state
 
     if {[llength $arg] < 1 || [llength $arg] > 2} {
        error "wrong # args: should be \"set varName ?newValue?\""
        return
     }
 
     namespace eval ::phasemachine::$id [list variable [fixvar [lindex $arg 0]]]
     if {[llength $arg] == 1} {
        namespace eval ::phasemachine::$id [list ::set [lindex $arg 0]]
     } else {
        namespace eval ::phasemachine::$id [list ::set [lindex $arg 0] [lindex $arg 1]]
     }
 }
 
 proc ::phasemachine::__go_phase { id num args } {
     upvar ::phasemachine::${id}::funcs funcs
     upvar ::phasemachine::${id}::state state
 
     set state $num
 
     set num [expr $num * 2]
     set a [lindex $funcs $num]
     incr num
     set f [lindex $funcs $num]
 
     set i 0
     foreach a2 $a {
        set def 0
        if {[llength $a2] != 1} {
            set def 1
            set a3 [lindex $a2 1]
            set a2 [lindex $a2 0]
        }
        namespace eval ::phasemachine::$id [list variable [fixvar $a2]]
        if {$def && $i >= [llength $args]} {
            namespace eval ::phasemachine::$id [list ::set $a2 $a3]
        } else {
            namespace eval ::phasemachine::$id [list ::set $a2 [lindex $args $i]]
        }
        incr i
     }
 
     namespace eval ::phasemachine::$id [list eval $f]
 }
 
 proc phasemachine { funcname args } {
     if {[llength $args] < 2 || [expr [llength $args] % 2] != 0} {
        error {wrong # args: should be "phasemachine name args body [args body..]"}
     }
 
     proc $funcname args "
        upvar ::phasemachine::_id id
        incr id
        namespace eval ::phasemachine::\$id {set state -1}
        namespace eval ::phasemachine::\$id {set funcs [list $args]}
         proc ::phasemachine::\${id}::phase_get_current { } \"return \\\$::phasemachine::\${id}::state\"
        proc ::phasemachine::\${id}::phase_go { num args } \"eval \\\[phase_go_cb \\\$num\\\] \\\$args\"
        proc ::phasemachine::\${id}::phase_next { args } \"eval \\\[phase_next_cb\\\] \\\$args\"
        proc ::phasemachine::\${id}::phase_go_cb { num } \"return \\\[list ::phasemachine::__go_phase \$id \\\$num\\\]\"
        proc ::phasemachine::\${id}::phase_prev_cb { } \"return \\\[list ::phasemachine::__go_phase \$id \\\[expr \\\$::phasemachine::\${id}::state - 1\\\]\\\]\"
        proc ::phasemachine::\${id}::phase_same_cb { } \"return \\\[list ::phasemachine::__go_phase \$id \\\$::phasemachine::\${id}::state\\\]\"
        proc ::phasemachine::\${id}::phase_next_cb { } \"return \\\[list ::phasemachine::__go_phase \$id \\\[expr \\\$::phasemachine::\${id}::state + 1\\\]\\\]\"
        proc ::phasemachine::\${id}::set { args } \"return \\\[::phasemachine::__set \$id \\\$args\\\]\"
        proc ::phasemachine::\${id}::phase_exit { } \"namespace delete ::phasemachine::\$id\"
        eval \[::phasemachine::\${id}::phase_next_cb\] \$args
     "
 }