[Zarutian]: The code/and or text by Zarutian on this page is licensed under the Creative Commons Attribution-NonCommercial-ShareAlike License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc-sa/2.5/ or send a letter to Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA.

======
proc comment args {}

proc makeReplicatedInterp {sync_proc {seed -1}} {
    proc [lindex [info level 0] 0] [list sync_proc [list seed [incr seed]]] [info body [lindex [info level 0] 0]]

    set interp [interp create -safe]

    foreach item { fconfigure tell seek puts gets fileevent after } {
        catch { $interp hide $item }
    }

    $interp eval {
        proc info_proc name {
            set argl {}
            foreach arg [info args $name] {
                if [info default $name $arg df] { lappend arg $df }
                lappend argl $arg
            }
            list $argl [info body $name]
        }
        proc info_getVar name {
            # must give the whole name if var is an array
            upvar $name tmp
            set traceStorage [trace info variable tmp]
            foreach trace $traceStorage {
                trace remove variable $name [lindex $trace 0] [lindex $trace 1]
            }
            set res [set tmp]
            foreach trace $traceStorage {
                trace add variable $name [lindex $trace 0] [lindex $trace 1]
            }
            return $res
        }
    }

    set body {
        # assumes that the resulting proc will have args
        set interp %interp%
        set sync_proc %sync_proc%

        set delegate [list]
        switch -exact -- [lindex $args 0] {
            "eval" {
                set delegate [concat [list $interp eval] [lrange $args 1 end]]
                $sync_proc [lindex [info level 0] 0] [lrange $args 1 end]]
            }
            "eval-without-sync" {
                set delegate [concat [list $interp eval] [lrange $args 1 end]]
            }
            "delete" {
                interp delete $interp
            }
            "snapshot" {
                set stack {}
                set namespaces [list]
                set body {
                    foreach ns [$interp eval [list namespace children [lindex $stack end]]] {
                        lappend stack $ns
                        eval $body
                        set stack [lrange $stack 0 end-1]
                    }
                    lappend namespaces [lindex $stack end]
                }
                eval $body
                set res "# -Snapshot begins-\n"
                foreach ns $namespaces {
                    append res "namespace eval [list $ns] \{\n"
                    # variables:
                    set vars [$interp eval [list namespace eval $ns [list info vars]]]
                    if {$ns != {}} {
                        set globals [$interp eval [list namespace eval $ns [list info globals]]]
                        set tmp [list]
                        foreach var $vars {
                            if {[lsearch -exact $globals $var] == -1} { lappend tmp $var }
                        }
                        set vars $tmp
                    }
                    foreach var $vars {
                        set fullname "[set ns]::[set var]"
                        if {[$interp eval [list array exists $fullname]]} {
                            foreach name [$interp eval [list array names $fullname]] {
                                set tmp "[set fullname]([set name])"
                                append res "  set [list [set tmp]] [list [$interp eval [list info_getVar $tmp]]]\n"
                            }
                        } else {
                            append res "  set [list [set var]] [list [$interp eval [list info_getVar $fullname]]]\n"
                        }
                    }
                    # procedures:
                    set procs [$interp eval [list namespace eval $ns [list info procs]]]
                    foreach proc $procs {
                        set fullname "[set ns]::[set proc]"
                        set lambda [$interp eval [list info_proc $fullname]]
                        append res "  proc [list $proc] [list [lindex $lambda 0]] [list [lindex $lambda 1]]\n"
                    }
                    append res "\}\n"
                    # traces:
                    foreach var $vars {
                        set fullname "[set ns]::[set var]"
                        foreach trace [$interp eval [list trace info variable $fullname]] {
                            append res "trace add variable [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
                        }
                    }
                    foreach proc $procs {
                        set fullname "[set ns]::[set proc]"
                        foreach trace [$interp eval [list trace info command $fullname]] {
                            append res "trace add command [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
                        }
                        foreach trace [$interp eval [list trace info execution $fullname]] {
                            append res "trace add execution [list $fullname] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
                        }
                    }             
                }
                append res "# -Snapshot ends-\n"
                return $res
            }
        } 
        if {$delegate != {}} { return [eval $delegate] }
    }

    set id "replicatedInterp[set seed]"
    proc $id args [string map [list %interp% $interp %sync_proc% $sync_proc] $body]
    return $id
}
======

[Zarutian] 27. june 2005: what I have been working with:

======
wm withdraw .
proc comment args {}
proc getCallstack {} {
    set level [info level]
    set tmp [list]
    for {set i 0} { $i <= $level } { incr i } {
        lappend tmp [info level $i]
    }
    return $tmp
}

proc save_state args {
    # ná í stikur fallsins/ferilins
    set vars [lindex $args 0]
    set op   [lindex $args end]
    
    if {$op == "leave"} {
        # assumes that template for the traced procedure is
        # kept in variable body in the traced procedure's stackframe
        upvar body body
        set subst [list %body% [list $body]]
        foreach item $vars {
            upvar $item tmp
            lappend subst "%[set item]%"
            lappend subst [list $tmp ]
        }
        set caller [lindex [info level 1] 0]
        proc $caller [list [info args $caller]] [string map $subst $body]
    }
}

proc lcombine {listA listB} {
    set res [list]
    foreach item $listA {
        lappend res $item
    }
    foreach item $listB {
        lappend res $item
    }
    set res
}

proc lremove {list item} {
    set r [lsearch -exact $list $item]
    return [lreplace $list $r $r]
}

proc clock_millisecs {} {
    # crude but gets the job done for now
    set a [clock seconds]
    set b [clock clicks -millisec]
    set c [string range $b end-2 end]
    while {[string index $c 0] == "0"} {
        set c [string range $c 1 end]
    }
    if {[string index $b 0] == "-"} {
        set b [format "%03d" [expr 1000 -$c]]
    } else {
        set b $c
    }
    return "[set a][set b]"
}

proc makeReplicatedSafeInterp {sync_proc {seed -1}} {
     set me [lindex [info level 0] 0]
     proc $me [list sync_proc [list seed [incr seed]]] [info body $me]
     set name "replicaInterp[set seed]"
     set body {
         # nearly instance variables ;-)
         set body %body% ; # sort of template for the procedure
         set sync_proc %sync_proc%
         set sub_interp %sub_interp%
         set state_log %state_log%
         # stuff to save
         set vars [list sync_proc sub_interp state_log]
         trace add execution [lindex [info level 0] 0] leave [list save_state $vars]

         # initilize
         set dispatch [list]

         # method dispatch: (or nearly so)
         switch -exact -- [lindex $args 0] {
             "snapshot" {
                 set dispatch "return"
                 lappend dispatch $state_log
             }
             "alias_called" {
                 set dispatch $sub_interp
                 lappend dispatch "invokehidden"
                 set dispatch [lcombine $dispatch [lrange $args 1 end]]
                 # save_state doesn't work well with recursive functions I see
                 upvar state_log state_log2
                 lappend state_log2 [list [clock_millisecs] [lrange $args 1 end]]
             }
             "eval" {
                 $sync_proc cause [lrange $args 1 end] [lindex [info level 0] 0]
                 set dispatch $sub_interp
                 lappend dispatch "eval"
                 set dispatch [lcombine $dispatch [lrange $args 1 end]]
                 if {[llength $dispatch] > 0} {
                     set code [catch { eval $dispatch } res]
                     $sync_proc expected [lrange $args 1 end] $code $res [lindex [info level 0] 0]
                 }
             }
             "eval-without-cause" {
                 set dispatch $sub_interp
                 lappend dispatch "eval"
                 set dispatch [lcombine $dispatch [lrange $args 1 end]]
             }
             default {
                 set dispatch $sub_interp
                 set dispatch [lcombine $dispatch $args] 
             }
        }
        if {[llength $dispatch] > 0} {
            return [eval $dispatch]
        }
    }
    set sub_interp [interp create -safe]
    foreach item { after append binary catch close fcopy fileevent flush foreach gets incr info interp lappend lset namespace package proc puts read regexp regsub rename scan seek set trace unset } {
        $sub_interp hide $item
        $sub_interp alias $item $name alias_called $item
    }
    set subst [list %body% [list $body] %sync_proc% [list $sync_proc] %sub_interp% [list $sub_interp] %state_log% "{}"]
    proc $name args [string map $subst $body]
    return $name
}

proc snapshotToTclScript {snapshot} {
    # attemp 1
    # this procedure is too big break it up into sub procedures
    set variables()  ""
    set procedures() ""
    set tracers_for_variables() ""
    set tracers_for_commands() ""
    set tracers_for_executions() ""

    foreach item $snapshot {
        set timestamp [lindex $item 0]
        set command   [lindex $item 1]
        if {([lindex $command 0] == "set") && ([llength $command] == 3)} {
            set variables([lindex $command 1]) [lindex $command 2]
        } elseif {([lindex $command 0] == "unset") && ([llengthh $command] == 2)} {
            unset variables([lindex $command 1])
        } elseif {[lindex $command 0] == "array"} {
            set arrayName [lindex $command 2]
            if {[lindex $command 1] == "set"} {
                foreach {name value} [lindex $command 3] {
                    set variables([set arrayName]([set name])) [set value]
                }
            } elseif {[lindex $command 1] == "unset"} {
                foreach {name value} [array get variables] {
                    if {[string match "[set arrayName](*)" $name]} {
                        unset variables([set name])
                    }
                }
            }
        } elseif {[lindex $command 0] == "proc"} {
            # doesnt gets the namespace in which the proc was defined in
            set procedures([lindex $command 1]) [list [lindex $command 2] [lindex $command 3]]
        } elseif {[lindex $command 0] == "rename"} {
            if {[lindex $command 2] == ""} {
                unset procedures([lindex $command 1])
            } else {
                set tmp procedures([lindex $command 1])
                unset procedures([lindex $command 1])
                set procedures([lindex $command 2]) $tmp
            }
        } elseif {[lindex $command 0] == "trace"} {
            set name [lindex $command 3]
            set ops  [lindex $command 4]
            set cmd  [lindex $command 5]
            if {[lindex $command 1] == "add"} {
                if {[lindex $command 2] == "command"} {
                    lappend tracers_for_commands($name) [list $ops $cmd]
                } elseif {[lindex $command 2] == "execution"} {
                    lappend tracers_for_executions($name) [list $ops $cmd]
                } elseif {[lindex $command 2] == "variable"} {
                    lappend tracers_for_variables($name) [list $ops $cmd]
                }
            } elseif {[lindex $command 1] == "remove"} {
                if {[lindex $command 2] == "command"} {
                    set tracers_for_commands($name) [lremove $tracers_for_commands($name) [list $ops $cmd]]
                } elseif {[lindex $command 2] == "execution"} {
                    set tracers_for_executions($name) [lremove $tracers_for_executions($name) [list $ops $cmd]]
                } elseif {[lindex $command 2] == "variable"} {
                    set tracers_for_variables($name) [lremove $tracers_for_variables($name) [list $ops $cmd]]
                }
            } else {
                # for the deprecaded trace commands, not supported
            }
        } elseif {[lindex $command 0] == "after"} {
            # how shall I implement this?
            # implemented as: when \{([clock_millisec] + $interval) < \[clock_millisec\]\} $body
            # where $interval is the interval that after must wait and $body is the script body
            # which will fire when the after fires?
            # problem: if the above method is used then timing of two concurrent animation will
            #          be thrown right out of the window
             
        }
    }
    
         set res "# Snapshot -begin-\n"
    append res "# variables:\n"
    foreach {key value} [array get variables] {
        append res "set [list [set key]] [list [set value]]\n"
    }
    append res "# procedures:\n"
    foreach {key value} [array get procedures] {
        append res "proc [list [set key]] [list [lindex $value 0]] [list [lindex $value 1]]\n"
    }
    append res "# tracers for variables:\n"
    foreach {key value} [array get tracers_for_variables] {
        foreach trace $value {
            append res "trace add variable [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
        }
    }
    append res "# tracers for commands:\n"
    foreach {key value} [array get tracers_for_commands] {
        foreach trace $value {
            append res "trace add command [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
        }
    }
    append res "# tracers for executions:\n"
    foreach {key value} [array get tracers_for_executions] {
        foreach trace $value {
            append res "trace add execution [list [set key]] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
        }
    }
    append res "# Snapshot -end-\n"
    return [set res]
}
======

Command:    Side-effects? (does invokation of the command change the var env?)

======
after          yes
append         yes
array          yes (array set)
binary         yes (binary scan)
break          nope (flow control)
case           nope
catch          yes (if args more than 1)
clock          no (simply calculation and an accessor)
close          yes (I/O)
concat         nope
continue       nope (flow control)
eof            nope (I/O state checker)
error          nope (???)
eval           nope (???)
expr           nope (calculations)
fblocked       nope (I/O state checker)
fcopy          yes (I/O)
fileevent      yes (I/O)
flush          yes (I/O)
for            nope (not directly)
foreach        yes (changes some var as it iterates throug a list)
format         nope
gets           yes (I/O)
global         nope (just opens up access for the current procedure to access that global var)
if             nope
incr           yes
info           yes (info script)
interp         yes (???)
join           nope
lappend        yes
lindex         nope
linsert        nope
list           nope
llength        nope
lrange         nope
lreplace       nope
lsearch        nope
lset           yes
lsort          nope
namespace      yes
package        yes
pid            nope
proc           yes
puts           yes (I/O)
read           yes (I/O)
regexp         yes
regsub         yes
rename         yes
return         nope (flow control)
scan           yes
seek           yes
set            yes
split          nope
string         nope
subst          nope (not directly)
switch         nope
tell           nope (I/O state checker/accessor)
time           nope (not directly)
trace          yes
unset          yes
update         nope
uplevel        see eval
upvar          ???
variable       see global
vwait          nope
while          nope
======

======
proc prepend {varname data} {
        upvar $varname tmp
        set tmp "[set data][set tmp]"
}
proc lexclude {b a} {
        # returns list a where all elements of list b have been removed.
        set tmp [list]
        foreach item $a {
            if {[lsearch $b $item] == -1} {
                lappend tmp $item
            }
        }
        return $tmp
}
======

----

[Zarutian] 19 june 2005: This developed out of the idea outlined by the Croquet Project (http://www.opencroquet.org/Croquet_Technologies/architecture.html). 
Which is to replicate state of an object over many machines and synchronize those replicas.

This is a bit crude and thrown together implemention.

First, start of by setting up an slave interp. Alias after to be able to capture after scripts.

======
set i [interp create -safe]

proc slave_after args {
    puts "debug: [info level 0]"
    set i [lindex $args 0]
    if {[lindex $args 1] != "info"} {
        store_after_script [lindex $args 0] [clock seconds] [lrange $args 1 end]
    }
    set tmp $i
    lappend tmp "invokehidden" 
    lappend tmp "after"
    foreach arg [lrange $args 1 end] { lappend tmp $arg }
    puts "debug:\t \$tmp = [list $tmp]"
    eval $tmp  
}
$i hide after
$i alias after slave_after $i
======

Then set up probe procedures for dumping the state of the slave interp.

======
#proc store_after_script {interp when_invoked args} {
#  puts "debug: [info level 0]"
#  variable after_scripts
#  set first [lindex $args 0]
#  if {[string is digit $first]} {
#    while {[string length $first] < 4} {
#      prepend first "0" 
#    }
#    append after_scripts($interp) "when \{\[clock seconds\] > ($when_invoked +"
#    append after_scripts($interp) " [string range $first 0 end-3])\} \{\n"
#    append after_scripts($interp) "  after [string range $first end-2 end] [list [lindex [lindex $args 1] 1]]\n"
#    append after_scripts($interp) "\} 1000\n"
#  } else {
#    append after_scripts($interp) "when \{\[clock seconds\] > $when_invoked \} \{\n  after "
#    foreach arg $args {
#      append after_scripts($interp) $arg
#      append after_scripts($interp) " "
#    } 
#    append after_scritps($interp) "\n\}\n"
#  }
#}
proc store_after_script {interp when_invoked args} {
    puts "debug: [info level 0]"
    variable after_scripts
    append after_scripts($interp) "reschedule_after_script $when_invoked [list $args]\n"
}
proc capture_after_scripts {interp} {
    set res {
        proc when {condition body {interval 1000}} {
            if $condition $body else {
                after $interval [info level 0]
            }
        }
    }
    variable after_scripts
    if {[info exists after_scritps($interp)]} {
        append res $after_scripts($interp)
    }
    return $res
}
# a helper functions:
proc interp_ns {interp namespace script} {
    return [$interp eval [list namespace eval $namespace $script]]
}
proc list_vars {interp namespace} {
    set globals [interp_ns $interp $namespace {info globals}]
    if {$namespace == {}} { set globals {} }
    set vars [interp_ns $interp $namespace {info vars}]
    return [lexclude $globals $vars]
}
proc capture_vars {interp {namespace {}}} {
    set vars [list_vars $interp $namespace]
         set tmp "# variables: \n"
    append tmp "namespace eval [list $namespace] \{\n"
    foreach var $vars {
        if {[interp_ns $interp $namespace [list array exists $var]]} {
            append tmp "array set [list $var] [list [interp_ns $interp $namespace [list array get $var]]]\n"
        } else {
            append tmp "set [list $var] [list [interp_ns $interp $namespace [list set $var]]]\n"
        }
    }
    append tmp "\}"
    return $tmp
}
proc capture_procs {interp {namespace {}}} {
    set procs [interp_ns $interp $namespace {info procs}]
    set tmp "# procedures: \n"
    append tmp "namespace eval [list $namespace] \{\n"
    foreach proc $procs {
        # dangerous asumption: expect that no variable will be named: {}
        # why: because it's the only way to squease data out of [info default]
        # proposed alt: add an -withDefaults to [info args]
        set args [list]
        foreach arg [interp_ns $interp $namespace [list info args $proc]] {
            if {[interp_ns $interp $namespace [list info default $proc $arg {}]]} {
                lappend args [list $arg [interp_ns $interp $namespace [list set {}]]]
            } else {
                lappend args $arg
            }
            catch { [interp_ns $interp $namespace [list unset {}]] }
        }
        set body [interp_ns $interp $namespace [list info body $proc]]
        append tmp "proc [list $proc] [list $args] [list $body]\n"
    }
    append tmp "\}"
    return $tmp
}
proc capture_varTraces {interp {namespace {}}} {
    set vars [list_vars $interp $namespace]
         set tmp "# traces on variables: \n"
    append tmp "namespace eval [list $namespace] \{\n"
    foreach var $vars {
        set traces [interp_ns $interp $namespace [list trace info variable $var]]
        foreach trace $traces {
            append tmp "trace add variable [list $var] [list [lindex $trace 0]] [list [lindex $trace 1]]\n"
        }
    }
    append tmp "\}"
    return $tmp
}
proc capture_all {interp {namespace {}}} {
    set tmp ""
    if {$namespace == {}} {
        append tmp "# Fascmile of interp state -BEGIN- \n"
    }
    append tmp "[capture_vars  $interp $namespace]\n"
    append tmp "[capture_procs $interp $namespace]\n"
    append tmp "[capture_varTraces $interp $namespace]\n"
    append tmp "[capture_after_scripts $interp]\n"

    set children [$interp eval [list namespace children $namespace]]
    if {[llength $children] > 0} {
        foreach child $children {
            append tmp [capture_all $interp $child]
        }
    }
    if {$namespace == {}} {
        append tmp "# Fascmile of interp state -END- \n"
    }
    return $tmp
}

proc update_replicas args {
    puts "debug: [info level 0]"
    variable channels_to_Replicas'_masters
    foreach chan [set channels_to_Replicas'_masters] {
        catch {
            puts $chan "cause [list $args]"
            flush $chan
        }
    }
}
======

Next handle incoming requests from other instances of the same replicated slave interp

======
proc connection_handler {sock} {
    variable buffers
    append buffers($sock) [gets $sock]
    append buffers($sock) "\n"
    if {[info complete $buffers($sock)]} {
        switch -exact -- [lindex $buffers($sock) 0] {
            "cause" {
                variable i
                if {[lsearch [$i hidden] [lindex [lindex $buffers($sock) 1] 0]] != -1} {
                    set tmp $i
                    lappend tmp "invokehidden"
                    foreach item [lindex $buffers($sock) 1] { lappend tmp $item }
                    eval $tmp
                } else {
                    $i eval [lindex $buffers($sock) 1]
                }
            }
            "gimme_snapshot" {
                variable i
                set tmp [capture_all $i]
                catch {
                    puts $sock "snapshot [list $tmp]"
                    flush $sock
                }
            }
        }
        unset buffers($sock)
    }
    if {[eof $sock]} { close $sock; return }
}
======

Not fully tested yet

I am thinking I am aproaching this proplem from a wrong perspective.
----
[Lars H], 20 June 2005: Maybe if you gave more of an explanation of how it's supposed to work someone could lend a hand. For starters, what's the idea behind doing something special with [after]? It's probably a key part of the approach, but to what end isn't terribly clear from the above.

As an aside, the many
======
puts "debug: ..."
======

lines are better coded like e.g.

======
putdebug ...
======

with

======
proc putdebug {str} {puts "debug: $str"}
======

as they can then easily be disabled by a simple

======
proc putdebug {str} {}
======

when you're not debugging.

[Zarutian] 22 june 2005: Well the basic idea is to store the starting state of an object 
(here an slave interp), instancenate an object by using that state (replicate the object) 
and synchronise these two (or more) replicas together by sending external influences to all replicas in the same sequence as they occur (from some coordnator's point of view which could be the origin replica of a given external influence). How's that for a sentence ;-)

Why I have such an interest in after is that unfired after-scripts are part of the slave's interp state.

[Zarutian] 2005-06-199 23:23: Something like this would be cleaner:

======
proc makeReplicatedSafeInterp {sync_proc {seed -1}} {
    proc [lindex [info level 0] 0] [list sync_chan [list seed [incr seed]]] [info body [lindex [info level 0]]
    set body {
        # nearly instance variables ;-)
        set body %body%
        set sync_proc %sync_proc%
        set sub_interp %sub_interp%
        set state_log %state_log%
        # stuff to save
        set subst [list \%body\% $body \%sync_proc\% $sync_proc \%sub_interp\% $sub_interp \%state_log\% $state_log]
        trace add execution [lindex [info level 0] 0] leave save_state

        # initilize
        set dispatch false

        # method dispatch: (or nearly so)
        switch -exact -- [lindex $args 0] {
            "alias_called" {
                set tmp $sub_interp
                lappend tmp "invokehidden"
                foreach arg [lrange $args 1 end] {
                    lappend tmp arg
                }
                eval $tmp
            }
            "eval" {
                $sync_proc cause [lrange $args 1 end] [lindex [info level 0] 0]
                set dispatch true
            }
            default { set dispatch true }
        }
        
        # save yourself!

        proc [lindex [info level 0] 0] args [string map $subst $body]

        if {$dispatch} {
            set tmp $sub_interp
            foreach arg $args {
                lappend tmp $arg
            }
            return [eval $tmp]
        }
    }
    set subst [list \%body\% $body \ 
                                    \%sync_proc\% $sync_proc \
                                    \%sub_interp\% $sub_interp \
                        ]
    proc "replicaInterp[set seed]" args [string map $subst $body]
}
proc save args {}
======

<<categories>> Interprocess Communication