Arjen Markus (11 february 2003) Just to experiment a little with expert systems, to get some feeling for what they are all about, I decided to model CLIPS in pure Tcl. Well, not the whole set of commands, but just a few to see if I understand the principle.
There is a proper Tcl extension for CLIPS, so for serious work one should look at that, but doing some of the basics in pure Tcl is not too difficult.
The principle is straightforward:
So, the script below mimicks a very small expert system: conclude from the colour of a traffic light what we should do, stop or go?
In any real system improper data would trigger a new question. I have not found a way to deal with this situation in the very simple script below.
Here are some remarks that may be worthwhile for building an actual expert system:
}
Also: the script is very raw - it contains some constructs that resulted from thought experiments with ways to store the data (in a long list, rather than an array) for instance.
NEM - Nice. Of course, CLIPS and other expert system shells (such as Jess) actually store their rule patterns in a complex data structure called a Rete (latin for network IIRC, SS and Italian for network too FWIW). This data structure allows extremely efficient matching for the many-pattern, many-object case (there are usually a large number of rules, and a large number of asserted facts at any time). The data structure takes advantage of some simple observation about this kind of system - namely that few facts change with each cycle and these typically affect only a very few rules. There are other variations on this data structure, the main other being Treat (which uses less memory).
An important part of a production system such as this, is the conflict resolution. During one cycle, many rules may become activated due to the assertion of new rules. All the currently active rules are held in a conflict set (or agenda in CLIPS). At the end of the cycle a conflict resolution strategy is run on the conflict set to produce a single rule to run. There are many schemes for conflict resolution.
If anyone is interested in this technology, I am currently implementing a very lightweight rule interpreter for my dissertation.
AM Update dd 14 february 2003:
I have been working on a further enhancement, because for an "actual" practical usage I needed the ability to work with variables (in the CLIPS sense). This turns out to have severe consequences for the matching procedure: the variables are bound to corresponding values in the facts, as you go along with the matching, but that means that they must be "unbound" if the matching fails. Hence the logic is much more complex.
Luckily, my "practical" application is to be part of a small user-interface where the user will be the limiting factor as far as performance is concerned. But these little experiments do give me insight in what expert systems are all about (which was my goal to start with).
# playclips.tcl --
# Experiments with an expert system a la CLIPS
#
# expertsys --
# Namespace for procedures and private variables dealing with
# facts and rules
#
namespace eval ::expertsys:: {
variable factIndex 0
variable ruleIndex 0
variable facts
variable rules
namespace export assert defrule run facts
}
# assert --
# Register a fact
#
# Arguments:
# fact List of data, where the first is the name of the relation
# and all others are the specific data
#
# Result:
# Index identifying the fact
#
# Side effect:
# The fact is stored in the facts array
#
proc ::expertsys::assert {fact} {
variable factIndex
variable facts
set facts($factIndex) [list [lindex $fact 0] [lrange $fact 1 end]]
set curIndex $factIndex
incr factIndex
return $curIndex
}
# facts --
# Print the known facts
#
# Arguments:
# None
#
# Result:
# None
#
# Side effect:
# All known facts are listed
#
proc ::expertsys::facts {} {
variable factIndex
variable facts
for { set i 0 } { $i < $factIndex } { incr i } {
if { [info exists facts($i)] } {
puts "Fact $i: $facts($i)"
} elseif { [info exists facts($i,old)] } {
puts "Fact $i: $facts($i,old)"
}
}
}
# defrule --
# Register a rule
#
# Arguments:
# name Name of the rule
# conditions List of conditions (raw facts)
# actions Actions to take (if the rule triggers)
#
# Result:
# Index identifying the rule
#
# Side effect:
# The rule is stored in the rules array
#
proc ::expertsys::defrule {name conditions actions} {
variable ruleIndex
variable rules
set rules($ruleIndex,name) $name
set rules($ruleIndex,conditions) $conditions
set rules($ruleIndex,actions) $actions
set curIndex $ruleIndex
incr ruleIndex
return $curIndex
}
# run --
# Run the expert system - see if any rules apply
#
# Arguments:
# None
#
# Result:
# None
#
# Side effect:
# Rules are executed and new facts are formed
#
proc ::expertsys::run {} {
variable ruleIndex
variable factIndex
variable facts
variable rules
set end 0
while { ! $end } {
set end 1 ;# If no rule has been invoked, then we quit
for { set i 0 } { $i < $ruleIndex } { incr i } {
if { [CanRuleBeActive $i] } {
InvokeRule $i
set end 0
}
}
}
}
# CanRuleBeActive --
# Check that the rule can be invoked
#
# Arguments:
# idx Rule index
#
# Result:
# 1 if it can be invoked, 0 if not
#
proc ::expertsys::CanRuleBeActive { idx } {
variable factIndex
variable facts
variable rules
set answer 0
foreach cond $rules($idx,conditions) {
set required [list [lindex $cond 0] [lrange $cond 1 end]]
for { set i 0 } { $i < $factIndex } { incr i } {
if { [info exists facts($i)] } {
if { $required == $facts($i) } {
set answer 1
break
}
}
}
if { $answer == 0 } {
break
}
}
return $answer
}
# InvokeRule --
# Invoke the rule
#
# Arguments:
# idx Rule index
#
# Result:
# None
#
# Side effects:
# The facts that are used are moved to the "old" bin,
# new facts may be generated
#
proc ::expertsys::InvokeRule { idx } {
variable factIndex
variable facts
variable rules
foreach cond $rules($idx,conditions) {
set required [list [lindex $cond 0] [lrange $cond 1 end]]
for { set i 0 } { $i < $factIndex } { incr i } {
if { [info exists facts($i)] } {
if { $required == $facts($i) } {
set facts($i,old) $facts($i)
unset facts($i)
break
}
}
}
}
foreach action [split $rules($idx,actions) "\n"] {
eval $action
}
}
# main --
# A small example
#
namespace import ::expertsys::*
catch {console show}
assert {start 1}
defrule Stop {{light red}} {puts "===> Stop" }
defrule Go {{light green}} {puts "===> Go" }
defrule Colour? {{start 1}} {
puts "What colour?"
gets stdin colour
assert [list light $colour]
}
run
puts ""
facts