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

  1. # Small-scale experiments with Bayesian networks:
  2. # Do I understand the technique?
  3. #
  4.  
  5. package require TclOO
  6. namespace import oo::*
  7.  
  8. oo::class create Static {
  9. method static {args} {
  10. if {![llength $args]} return
  11. set callclass [lindex [self caller] 0]
  12. oo::objdefine $callclass export varname
  13. foreach vname $args {
  14. lappend pairs [$callclass varname $vname] $vname
  15. }
  16. uplevel 1 upvar {*}$pairs
  17. }
  18. }
  19.  
  20. class create logicalNode {
  21. mixin Static
  22. variable myname
  23. variable depends
  24. variable table
  25. variable probabilityTrue
  26.  
  27. constructor {name {dependencies {}} {conditions {}}} {
  28. my static nodes
  29.  
  30. #CheckDependencies $dependencies
  31. #CheckTable $conditions
  32. set depends [my GetObjects $dependencies]
  33. set table $conditions
  34.  
  35. set probabilityTrue 0.5
  36.  
  37. set myname $name
  38. set nodes($name) [self object]
  39. }
  40.  
  41. method set {args} {
  42.  
  43. foreach {value probability} $args {
  44. if { $probability < 0.0 || $probability > 1.0 } {
  45. return -code error "Probability must be between 0 and 1 - found: $probability"
  46. }
  47. if { $value == "true" } {
  48. set probabilityTrue $probability
  49. }
  50. if { $value == "false" } {
  51. set probabilityTrue [expr {1.0 - $probability}]
  52. }
  53. }
  54. }
  55.  
  56. method GetObjects {names} {
  57. my static nodes
  58. puts "Available nodes: [array names nodes]"
  59. set objects {}
  60. foreach name $names {
  61. if { [info exists nodes($name)] } {
  62. lappend objects $nodes($name)
  63. } else {
  64. return -code error "Node $name not defined yet"
  65. }
  66. }
  67. }
  68.  
  69. method print {} {
  70. my static nodes
  71. puts "Name: $myname"
  72. puts " True: $probabilityTrue"
  73. puts " False: [expr {1.0 - $probabilityTrue}]"
  74. puts " [array names nodes]"
  75. }
  76. }
  77.  
  78. set b [logicalNode new "B"]
  79. $b print
  80. set a [logicalNode new "A" "B"]
  81. $a set true 0.1
  82. $a print
  83.  
  84. #
  85. # Result: why the error?
  86. #
  87. ## Available nodes:
  88. ## Name: B
  89. ## True: 0.5
  90. ## False: 0.5
  91. ## B
  92. ## Available nodes:
  93. ## Node B not defined yet
  94. ## while executing
  95. ## "my GetObjects $dependencies"
  96. ## (class "::logicalNode" constructor line 10)
  97. ## invoked from within
  98. ## "logicalNode new "A" "B""
  99. ## invoked from within
  100. ## "set a [logicalNode new "A" "B"]"
  101. ## (file "bayesian_error.tcl" line 72)
  102.