Posted to tcl by aspect at Wed Feb 12 12:43:10 GMT 2014view pretty

#     Small-scale experiments with Bayesian networks:
#     Do I understand the technique?
#

package require TclOO
namespace import oo::*

oo::class create Static {
    method static {args} {
        if {![llength $args]} return
        set callclass [lindex [self caller] 0]
        oo::objdefine $callclass export varname
        foreach vname $args {
            lappend pairs [$callclass varname $vname] $vname
        }
        uplevel 1 upvar {*}$pairs
    }
}

class create logicalNode {
    mixin Static
    variable myname
    variable depends
    variable table
    variable probabilityTrue

    constructor {name {dependencies {}} {conditions {}}} {
        my static nodes

        #CheckDependencies $dependencies
        #CheckTable        $conditions
        set depends [my GetObjects $dependencies]
        set table   $conditions

        set probabilityTrue 0.5

        set myname       $name
        set nodes($name) [self object]
    }

    method set {args} {

        foreach {value probability} $args {
            if { $probability < 0.0 || $probability > 1.0 } {
                return -code error "Probability must be between 0 and 1 - found: $probability"
            }
            if { $value == "true" } {
                set probabilityTrue $probability
            }
            if { $value == "false" } {
                set probabilityTrue [expr {1.0 - $probability}]
            }
        }
    }

    method GetObjects {names} {
        my static nodes
        puts "Available nodes: [array names nodes]"
        set objects {}
        foreach name $names {
            if { [info exists nodes($name)] } {
                lappend objects $nodes($name)
            } else {
                return -code error "Node $name not defined yet"
            }
        }
    }

    method print {} {
        my static nodes
        puts "Name: $myname"
        puts "    True:  $probabilityTrue"
        puts "    False: [expr {1.0 - $probabilityTrue}]"
        puts "    [array names nodes]"
    }
}

set b [logicalNode new "B"]
$b print
set a [logicalNode new "A" "B"]
$a set true 0.1
$a print

#
# Result: why the error?
#
##	Available nodes: 
##	Name: B
##	    True:  0.5
##	    False: 0.5
##	    B
##	Available nodes: 
##	Node B not defined yet
##	    while executing
##	"my GetObjects $dependencies"
##	    (class "::logicalNode" constructor line 10)
##	    invoked from within
##	"logicalNode new "A" "B""
##	    invoked from within
##	"set a [logicalNode new "A" "B"]"
##	    (file "bayesian_error.tcl" line 72)