http://c2.com/cgi/wiki?TupleSpace

http://c2.com/cgi/wiki?LindaTupleSpaces

 package require md5 2

 # A very simple implementation of a Linda-like Tuplespace.
 # Tuples take the form {field1 ... fieldN}.
 #
 namespace eval tuplespace {
    # This array defines the tuplespace. Each column contains a list
    # of matching tuple ids (tids). The hash is a combination of
    # column number, tuple field. (.e.g - tspace(0,hello) references any
    # tuple (via its id) that has 'hello' in its first column.
    #
     variable tspace

    # Tuples are referenced in tspace by tuple ids (tids). Tids are
    # md5 hashes of the actual tuple and are used as an index into the
    # array that holds the tuples.
    #
    variable tid_arr
    
    # Put a tuple out into tuplespace.
    #
    proc out {tuple} {
        variable tspace
        set tid [new_tid $tuple];   # create a new tuple id.
        # For each field in the tuple, asign it to a column in tuplespace.
        #
        set fn 0
        foreach tpf $tuple {
            lappend tspace($fn,$tpf) $tid;# this column now references tid.
            incr fn
        }
        return $tid
    }
    
    # Read (non-destructively) one (default) or more tuples from the space
    # matched by 'tpat'. Tpat is a tuple specification that may have a
    # "don't care" placeholder (?) in place of any tuple field. At least
    # one matching tuple field must be supplied. If rd_multiple is 1, then
    # return all matching tuples.
    #
    proc rd {tpat {rd_multiple 0}} {
        set res {}
        foreach tid [_rd $tpat $rd_multiple] {
            if {!$rd_multiple} {
                return [tid.tuple $tid]
            }
            lappend res [tid.tuple $tid]
        }
        return $res
    }
    
    
    # Take (by removing) a tuple from the space that matches 'tpat'.
    #
    proc in {tpat} {
        set res {}

        foreach tid [_rd $tpat] {
            set res [tid.tuple $tid]
            _remove $tid
        }
        return $res
    }

    # Return a directory listing of all tuples that match 'tpat'.
    #
    proc dir {tpat} {
        return [rd $tpat 1]
    }

    # Do all of the work of reading a tuple.
    #
    proc _rd {tpat {rd_multiple 0}} {
        variable tspace
        set match {}

        # Look at all of the supplied pattern fields and collect
        # a list of matching tuples (based on each field). If a field
        # fails to match (and the field is not ?, return an empty tuple).
        #
        set fn 0
        foreach tpf $tpat {
            if {[string equal $tpf "?"]} {
                incr fn
                continue
            }
            if {![info exists tspace($fn,$tpf)]} {
                return {}
            }
            lappend match $tspace($fn,$tpf)
            incr fn
        }
        return [_intersection $match $tpat $rd_multiple]
    }
    
    # Find the intersection between all of the matched (candidate) tuples.
    #
    proc _intersection {match tpat rd_multiple} {
        # Calculate the number of fields actually supplied in tpat.
        # This is the number intersections in the matches we must find
        # in order to return a tuple.
        #
        set tpat_len [llength [lsearch -not -all -exact $tpat ?]]
        set tpat_len [llength [lsearch -not -all -exact $tpat ?]]
        # Find the intersect of these collected matches. The first
        # intersect count that equal $tpat_len is our matched
        # tuple (unless all matches are requested).
        #
        set result {}
        foreach tid [join $match] {
            set tuple [tid.tuple $tid]
            if {[llength $tuple] != [llength $tpat]} {
                continue
            }
            if {![info exists intersect($tuple)]} {
                set intersect($tuple) 1
            } else {
                incr intersect($tuple)
            }
            if {$intersect($tuple) == $tpat_len} {
                lappend result $tid
                if {!$rd_multiple} {
                    break
                }
            }
        }
        return $result
    }
    
    # Remove a tuple from the space based on the tuple id.
    #
    proc _remove {tid} {
        variable tspace
        set tuple [tid.tuple $tid]
        set fn 0
        foreach tpf $tuple {
            if {[info exists tspace($fn,$tpf)]} {
                set tspace($fn,$tpf) [lsearch -all -not -inline \
                                          $tspace($fn,$tpf) $tid]
            }
            incr fn
        }
        tid.delete $tid
    }
    
    # Create a new tid to hold a tuple.
    #
    proc new_tid {tuple} {
        variable tid_arr
        set id [tid $tuple]
        set tid_arr($id) $tuple
        return $id
    }

    # Calculate the tid from a give tuple.
    #
    proc tid {tuple} {
        return "\#Tuple[::md5::md5 -hex $tuple]"
    }

    # Return the tuple from the given tid.
    #
    proc tid.tuple {tid} {
        variable  tid_arr
        return $tid_arr($tid)
    }
    
    # Destroy a tuple named by tid.
    #
    proc tid.delete {tid} {
        variable tid_arr
        unset tid_arr($tid)
    }

    # Flush a tuple from memory, but keep the tspace references around.
    # DANGEROUS!
    proc tid.flush_tuple {tid} {
        variable tid_arr
        set tid_arr($tid) {}
    }
 }

 # Examples:

 puts [tuplespace::out {hello there Todd Coram}]
 puts [tuplespace::out {hello there Maroc Ddot}]
 puts [tuplespace::out {linda space}]

 puts [tuplespace::dir {hello there ? ?}]
 puts [tuplespace::rd {hello there ? ?}]
 puts [tuplespace::in {hello there ? ?}]
 puts [tuplespace::dir {hello there ? ?}]
 puts [tuplespace::in {hello there ? ?}]
 puts [tuplespace::dir {hello there ? ?}]

 puts [tuplespace::out {hello there test etc}]

 [md5 {hello there test etc}]

 % puts "123456789[md5 {hello there test etc}]"
 ììÆ?¼ê[3#ü~²ºq
 % puts "123456789xxx[md5 {hello there test etc}]"
 ììÆ?¼ê[3#xxxü~²ºq

 # Meta-kit persistence for the tuplespace.
 #
 namespace eval tuplespace-db {
    proc open {dbpath} {
        mk::file open db $dbpath
        mk::view layout db.tspace "id tuple"
        _load
    }

    proc close {} {
        mk::file close db
    }

    proc _load {} {
        trace variable ::tuplespace::tid_arr ruw {}
        mk::loop row db.tspace {
            set tuple [mk::get $row tuple]
            set tid [tuplespace::out $tuple]
            tuplespace::tid.flush_tuple $tid
        }
        trace variable ::tuplespace::tid_arr ruw ::tuplespace-db::getset
    }

    proc getset {name tid op} {
        switch -- $op {
            w { _write $tid }
            r { _read $tid }
            u { _unset $tid }
        }
    }

    proc _unset {tid} {
        set r [mk::select db.tspace -count 1 \
                   -exact id $tid]
        if {$r != {}} {
            mk::row delete db.tspace!$r
            mk::file commit db.tspace
        }
    }

    proc _read {tid} {
        if {[tuplespace::tid.tuple $tid] == {}} {
            # reload from database
            #
            set r [mk::select db.tspace -count 1 -exact id $tid]
            tuplespace::new_tid [mk::get db.tspace!$r tuple]
        }
    }

    proc _write {tid} {
        set tuple [tuplespace::tid.tuple $tid]

        # See if the tuple already exists in the database.
        #
        set r [mk::select db.tspace -count 1 -exact id $tid]
        if {$r != {}} {
            # Replace the tuple.
            #
            mk::set db.tspace!$r id $tid tuple $tuple
        } else {
            # Nope, add a new row.
            #
            mk::row append db.tspace id $tid tuple $tuple
        }
        mk::file commit db.tspace
    }
 }

    # Calculate the tid from a give tuple.
    #
    package require base64
    proc tid {tuple} {
        return "\#Tuple[::base64::encode [::md5::md5 $tuple]]"
    }

  mk::view layout db.tspace "id tuple"

  mk::view layout db.tspace "id:B tuple"

 namespace eval tuplespace_server {
    array set cb {}
    
    proc register_cb {chan tpat} {
        variable cb
        lappend cb($chan) $tpat
        return "ok"
    }
    
    proc deregister_cb {chan} {
        variable cb
        unset cb($chan)
        return "ok"
    }
    
    proc read {chan cmd tpat} {
        set res [::tuplespace::$cmd $tpat]
        return "ok $res"
    }
    
    proc write {chan tuple} {
        variable cb
        set tid [::tuplespace::out $tuple]
        foreach cbchan [array names cb] {
            foreach tpat $cb($cbchan) {
                if {[::tuplespace::rd $tpat] != {}} {
                    puts $cbchan "cb $tpat"
                }
            }
        }
        return "ok $tid"
    }
    
    proc dispatch {chan cmd tuple} {
        switch -- $cmd {
            cb {
                set res [register_cb $chan $tuple]
            }
            rd -
            dir -
            in {

                set res [read $chan $cmd $tuple]
            }
            out {
                set res [write $chan $tuple]
            }
            default {
                set res "error invalid command!"
            }
        }
        puts $chan $res
    }
 }

 proc register_client {chan addr port} {
    fconfigure $chan -blocking 0 -buffering line
    fileevent $chan readable [list handle_input $chan]
 }

 proc handle_input {chan} {
    if {![eof $chan]} {
        if {[gets $chan data] == -1} {
            return;                     # only handle complete lines
        }
    } else {
        catch {close $chan}
        ::tuplespace_server::deregister_cb $chan
        return
    }
    set l [regexp -inline -- {(\w+)\s+(.*)} $data]
    if {[llength $l] != 3} {
        puts $chan "error usage: command {tuple}"
    } else {
        foreach {dummy cmd tuple} $l break
        puts stderr "cmd=($cmd), tuple=($tuple)"
        ::tuplespace_server::dispatch $chan $cmd $tuple
    }
 }

 socket -server [list register_client] 6667
 vwait ::forever

  out tom baker 56
  out bob baker 54
  dir ? baker ?
  cb ? baker ?
  out ginger baker

    proc register_cb {chan tpat} {
        ::tuplespace::out [list cb_clients $chan $tpat]
        return "ok"
    }
    
    proc deregister_cb {chan {tpat ?}} {
        foreach cb [::tuplespace::dir [list cb_clients $chan $tpat]] {
            ::tuplespace::in [list cb_clients $chan [lindex $cb 2]]
        }
        return "ok"
    }

    proc tuple_match {tpat tid} {
        foreach tuple [::tuplespace::dir $tpat] {
            if {[::tuplespace::tid $tuple] == $tid} {
                return 1
            }
        }
        return 0
    }

    proc write {chan tuple} {
        set tid [::tuplespace::out $tuple]
        foreach client [::tuplespace::dir [list cb_clients ? ?]] {
            foreach {cb_clients chan tpat} $client break
            if {[tuple_match $tpat $tid]} {
                if {[catch {puts $chan "cb $tpat"}] != 0} {
                    deregister_cb $chan
                }
            }
        }
        return "ok $tid"
    }

1. Take only grabs one matching tuple, right? (Yes - Todd Coram)
2. Do tuple IDs have to be unique for all time as well as at any given time for all tuples? (The ID value is directly related to the contents of the tuple. {Hello World} will always have the same unique ID, regardless when it was put into the space. Or, at least as unique as MD5 hashing allows - Todd Coram ;-)
3. Are duplicates allowed (duplicates for all but tuple ID, I guess) (No. A exact duplicate tuple will produce the same ID and squash the old one. - Todd Coram) escargo 3 Apr 2005 - Wouldn't an exact duplicate not need to be written, since it's already in the data base?

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References