Updated 2012-09-18 14:43:15 by LkpPo

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"   }

 }