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

 }