Arjen Markus (20 january 2005) Somehow, the idea of an
expert system filled with
[knowledge
] and (semi-)empiricial rules is very appealing. Classical expert systems combine hundreds or thousands of
[rule
]s to get to a
[conclusion
] and they are mostly limited to a small domain. I have little or no actual experience with such systems, though I have some with simple rule-based modelling.
The script below tries to use
rules and direct questions to conclude something about the problem the user is facing. It does so by examining the information it has - can a rule be applied (that is: do we have all the data to evaluate its condition)? It does something somewhat unusual: if a variable already has a value, then a
new line of reasoning is set up. Currently there is no way to make a composite conclusion out of this and the script is merely an experiment.
What I can say about it is this:
- Setting up this expert system shell was easy
- Even with the very limited set of rules I use here, debugging this "[rule base]" is a tough job (partly because it is incomplete, partly because new lines of reasoning do not behave as expected - a bug in the software or a bug in my expectations?)
So, I am starting to realise the tough job it must be to set up a full-blown expert system :) Well, anyway: enjoy!
# reason_rules.tcl --
# Attempt to reason with simple rules - a sort of minimal
# expert system shell.
#
namespace eval ::Reason {
namespace export ASK MSG IF SET deduce
variable rules
variable Nrules 0
variable LOR 0
variable NLOR 0
}
# CloneLOR --
# Set up a new "line of reasoning", copied from the current one
# Arguments:
# None
# Result:
# Name of the new line of reasoning
# Side effects:
# New namespace created, filled with the variables of the parent
#
proc ::Reason::CloneLOR {} {
variable LOR
variable NLOR
variable Nrules
variable rules
set newLOR $NLOR
puts "(Cloning LOR$LOR -- new LOR: $newLOR)"
incr NLOR
#
# Create the namespace
#
namespace eval $newLOR {}
#
# Copy the variables
#
foreach v [info vars ${LOR}::*] {
regexp {[^:]+$} $v v
set ${newLOR}::$v [set ${LOR}::$v]
}
#
# Register the LOR with the visible rules
#
foreach r [array names rules *,LOR] {
if { [lsearch [set rules($r)] $LOR] >= 0 } {
lappend rules($r) $newLOR
}
}
return $newLOR
}
# SET --
# Set a variable in the current "line of reasoning",
# possibly clone the line of reasoning.
# Arguments:
# var Name of the variable
# value Value to which it will be set
# Result:
# None
# Side effects:
# If the variable already had a value, a new line
# of reasoning is started
#
proc ::Reason::SET {var value } {
variable LOR
set LOR_set $LOR
if { [info exists ${LOR}::$var] } {
set LOR_set [CloneLOR]
}
set ${LOR_set}::$var $value
}
# ASK --
# Ask a question
# Arguments:
# var Name of the variable
# text Text to be displayed
# values List of value-text pairs (optional)
# Result:
# None
# Side effects:
# 1. Variable is set to the value typed in
# 2. If the variable already had a value, a new line
# of reasoning is started
#
proc ::Reason::ASK {var text {values {}} } {
variable LOR
puts "(LOR$LOR) $text"
if { $values == {} } {
#
# Logical parameter
#
puts -nonewline "Yes or no? "
flush stdout
gets stdin answer
if { [string first "Y" [string toupper $answer]] == 0 } {
SET $var 1
} else {
SET $var 0
}
} else {
set hasanswer 0
while { ! $hasanswer } {
set choice 0
foreach {v t} $values {
incr choice
puts "$choice. $t"
}
puts -nonewline "Answer: "
flush stdout
gets stdin answer
if { $answer >= 1 && $answer <= $choice } {
SET $var [lindex $values [expr {2*($answer-1)}]]
set hasanswer 1
}
}
}
}
# IF --
# Define a rule
# Arguments:
# cond Condition for the rule
# true "True" part
# else Dummy (optional)
# false "False" part (optional)
# Result:
# None
# Side effects:
# New rule in rule base
#
proc ::Reason::IF {cond true {else {}} {false {}} } {
variable LOR
variable rules
variable Nrules
set rules($Nrules,LOR) $LOR
set rules($Nrules,active) 1
set rules($Nrules,cond) $cond
set rules($Nrules,true) $true
set rules($Nrules,false) $false
incr Nrules
}
# MSG --
# Print a message
# Arguments:
# text Text to be printed
# Result:
# None
# Side effects:
# Text on screen
#
proc ::Reason::MSG {text} {
variable LOR
puts "(LOR$LOR) $text"
}
# deduce --
# Start the reasoning process
# Arguments:
# rulebase The rule base in question
# Result:
# None
# Side effects:
# Printed statements
#
proc ::Reason::deduce {rulebase} {
variable LOR
variable NLOR
variable rules
variable cond
variable rule
variable Nrules
namespace eval $NLOR {}
incr NLOR
eval $rulebase
set activeLOR 1
while { $activeLOR } {
set activeLOR 0
set activeRule 0
for { set rule 0 } { $rule < $Nrules } { incr rule } {
for { set LOR 0 } { $LOR < $NLOR } { incr LOR } {
set pos [lsearch $rules($rule,LOR) $LOR]
#puts "LOR$LOR: $rules($rule,cond) - $rules($rule,LOR)"
if { $pos < 0 } {continue}
#
# See if the rule fires ... (only once per LOR)
#
if { [catch {
namespace eval $LOR {
set ::Reason::cond \
[expr $::Reason::rules($::Reason::rule,cond)]
} } msg] } {
continue ;# An error occurred - the rule can not be applied
} else {
set activeRule 1
set rules($rule,LOR) [lreplace $rules($rule,LOR) $pos $pos]
if { $cond } {
eval $rules($rule,true)
} else {
eval $rules($rule,false)
}
}
}
# At least one line of reasoning still busy ...
set activeLOR [expr {$activeLOR || $activeRule}]
}
}
puts "Done"
}
# main --
# Test the code
#
namespace import ::Reason::*
#
# Simple test case
#
if { 0 } {
deduce {
#ASK x "Is it true?"
IF { $x } {
MSG "Yes!"
ASK y "Is it really true?"
IF { ! $z } {
MSG "You were kidding!"
} ELSE {
MSG "Well, well ..."
}
SET z 1
}
IF { ! $x } {
MSG "No!"
}
#
# After all the rules have been defined!
#
SET x 0
SET x 1
}
}
# Half-serious attempt to make a rule-base for debugging computational
# programs: one file with input goes in, one file with output comes out
# What actions to take to find the bug?
#
deduce {
IF { $symptom == "crash" } {
ASK crash_in_debugger "Does it happen in the debugger too?"
}
IF { $symptom == "own_message" } {
ASK reason_own_message "Is the reason for printing the message clear?"
IF { $reason_own_message } {
MSG "Try and see how this is related to the input"
} ELSE {
MSG "Use the debugger to step through the program unitl the message is reached"
}
}
IF { $symptom == "no_output" } {
ASK known_pos_stopping "Do you know where the program stops"
}
#
# Fall-back, in case the user is very unclear about the bug
IF { $what == "unknown" } {
#
# Just try everything
#
MSG "Make sure you can reproduce the bug yourself"
SET symptom "crash"
SET symptom "own_message"
SET symptom "no_output"
}
IF { $crash_in_debugger } {
ASK place_of_crash_found "Does the debugger tell you where it happened?"
} ELSE {
MSG "Possible cause: uninitialised memory"
MSG "Use print-statements to locate the proper spot"
}
#
# Now the primary question ...
# Somewhat cumbersome, but otherwise the new lines of reasoning
# do not behave correctly
#
ASK what "How do you know there is a problem?" {
crash "System message or coredump appears"
own_message "A message from the program itself"
no_output "There is no message and no output"
unknown "The user says so, but is unable to tell any details"
}
IF { $what == "crash" } { SET symptom "crash" }
IF { $what == "own_message" } { SET symptom "own_message" }
IF { $what == "no_output" } { SET symptom "no_output" }
}
