Posted to tcl by arjen at Wed Feb 12 12:28:26 GMT 2014view raw

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