AI-ExpertSystem-Simple
view release on metacpan or search on metacpan
bin/simpleshell view on Meta::CPAN
} else {
$continue = ask_question( 'Another consoltation', 'yes', 'no' );
$s->reset();
}
}
######################################################################
# Ask a question of the user showing the available responses
######################################################################
sub ask_question {
my ( $text, @responses ) = @_;
my $number = scalar(@responses);
my $x = 0;
while ( $x < 1 or $x > $number ) {
say_question($text);
for ( my $y = 1 ; $y <= $number ; $y++ ) {
say_something('response', " $y : ", $responses[$y - 1]);
bin/simpleshell view on Meta::CPAN
$x = 0 if $x !~ m#^[0-9]+$#;
}
return $responses[ $x - 1 ];
}
######################################################################
# The various ways of printing out a message
######################################################################
sub say_status { say_something('status', '>> ', shift) }
sub say_question { say_something('question', '', shift) }
sub say_something {
my ($tag1, $tag2, $text) = @_;
if($tkinterface) {
print "$tag1:$text\n";
} else {
print "$tag2$text\n";
}
}
######################################################################
# The various ways of printing out a message
######################################################################
sub process_log {
my ($prefix, $override) = @_;
$prefix = 'information' unless $prefix;
my @log = $s->log();
if($tkinterface or $override) {
foreach my $line (@log) {
say_something($prefix, '', $line);
}
examples/Animal.xml view on Meta::CPAN
<attribute>nearly.hairless</attribute>
<value>no</value>
</condition>
<condition>
<attribute>species</attribute>
<value>notail</value>
</condition>
</conditions>
<actions>
<action>
<attribute>subspecies</attribute>
<value>hair</value>
</action>
</actions>
</rule>
<rule>
<name>67</name>
<conditions>
<condition>
<attribute>species</attribute>
<value>400</value>
examples/Animal.xml view on Meta::CPAN
<attribute>one.horn</attribute>
<value>no</value>
</condition>
<condition>
<attribute>species</attribute>
<value>horns</value>
</condition>
</conditions>
<actions>
<action>
<attribute>subspecies</attribute>
<value>nohorn</value>
</action>
</actions>
</rule>
<rule>
<name>73</name>
<conditions>
<condition>
<attribute>lives.in.desert</attribute>
<value>yes</value>
examples/Animal.xml view on Meta::CPAN
</actions>
</rule>
<rule>
<name>79</name>
<conditions>
<condition>
<attribute>long.powerful.arms</attribute>
<value>yes</value>
</condition>
<condition>
<attribute>subspecies</attribute>
<value>hair</value>
</condition>
</conditions>
<actions>
<action>
<attribute>type.animal</attribute>
<value>orangutan/gorilla/chimpanzie</value>
</action>
</actions>
</rule>
<rule>
<name>80</name>
<conditions>
<condition>
<attribute>long.powerful.arms</attribute>
<value>no</value>
</condition>
<condition>
<attribute>subspecies</attribute>
<value>hair</value>
</condition>
</conditions>
<actions>
<action>
<attribute>type.animal</attribute>
<value>baboon</value>
</action>
</actions>
</rule>
<rule>
<name>81</name>
<conditions>
<condition>
<attribute>fleece</attribute>
<value>yes</value>
</condition>
<condition>
<attribute>subspecies</attribute>
<value>nohorn</value>
</condition>
</conditions>
<actions>
<action>
<attribute>type.animal</attribute>
<value>sheep/goat</value>
</action>
</actions>
</rule>
<rule>
<name>82</name>
<conditions>
<condition>
<attribute>fleece</attribute>
<value>no</value>
</condition>
<condition>
<attribute>subspecies</attribute>
<value>nohorn</value>
</condition>
</conditions>
<actions>
<action>
<attribute>subsubspecies</attribute>
<value>nofleece</value>
</action>
</actions>
</rule>
<rule>
<name>83</name>
<conditions>
<condition>
<attribute>domesticated</attribute>
<value>yes</value>
</condition>
<condition>
<attribute>subsubspecies</attribute>
<value>nofleece</value>
</condition>
</conditions>
<actions>
<action>
<attribute>type.animal</attribute>
<value>cow</value>
</action>
</actions>
</rule>
<rule>
<name>84</name>
<conditions>
<condition>
<attribute>domesticated</attribute>
<value>no</value>
</condition>
<condition>
<attribute>subsubspecies</attribute>
<value>nofleece</value>
</condition>
</conditions>
<actions>
<action>
<attribute>type.animal</attribute>
<value>deer/moose/antelope</value>
</action>
</actions>
</rule>
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
use warnings;
use XML::Twig;
use AI::ExpertSystem::Simple::Rule;
use AI::ExpertSystem::Simple::Knowledge;
use AI::ExpertSystem::Simple::Goal;
our $VERSION = '1.2';
sub new {
my ($class) = @_;
die "Simple->new() takes no arguments" if scalar(@_) != 1;
my $self = {};
$self->{_rules} = ();
$self->{_knowledge} = ();
$self->{_goal} = undef;
$self->{_filename} = undef;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$self->{_log} = ();
$self->{_number_of_rules} = 0;
$self->{_number_of_attributes} = 0;
$self->{_number_of_questions} = 0;
return bless $self, $class;
}
sub reset {
my ($self) = @_;
die "Simple->reset() takes no arguments" if scalar(@_) != 1;
foreach my $name (keys %{$self->{_rules}}) {
$self->{_rules}->{$name}->reset();
}
foreach my $name (keys %{$self->{_knowledge}}) {
$self->{_knowledge}->{$name}->reset();
}
$self->{_ask_about} = undef;
$self->{_told_about} = undef;
$self->{_log} = ();
}
sub load {
my ($self, $filename) = @_;
die "Simple->load() takes 1 argument" if scalar(@_) != 2;
die "Simple->load() argument 1 (FILENAME) is undefined" if !defined($filename);
if(-f $filename and -r $filename) {
my $twig = XML::Twig->new(
twig_handlers => { goal => sub { $self->_goal(@_) },
rule => sub { $self->_rule(@_) },
question => sub { $self->_question(@_) } }
);
$twig->safe_parsefile($filename);
die "Simple->load() XML parse failed: $@" if $@;
$self->{_filename} = $filename;
$self->_add_to_log( "Read in $filename" );
$self->_add_to_log( "There are " . $self->{_number_of_rules} . " rules" );
$self->_add_to_log( "There are " . $self->{_number_of_attributes} . " attributes" );
$self->_add_to_log( "There are " . $self->{_number_of_questions} . " questions" );
$self->_add_to_log( "The goal attibutes is " . $self->{_goal}->name() );
return 1;
} else {
die "Simple->load() unable to use file";
}
}
sub _goal {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
my $x = ($node->children('attribute'))[0];
$attribute = $x->text();
$x = ($node->children('text'))[0];
$text = $x->text();
$self->{_goal} = AI::ExpertSystem::Simple::Goal->new($attribute, $text);
eval { $t->purge(); }
}
sub _rule {
my ($self, $t, $node) = @_;
my $name = undef;
my $x = ($node->children('name'))[0];
$name = $x->text();
if(!defined($self->{_rules}->{$name})) {
$self->{_rules}->{$name} = AI::ExpertSystem::Simple::Rule->new($name);
$self->{_number_of_rules}++;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
if(!defined($self->{_knowledge}->{$attribute})) {
$self->{_number_of_attributes}++;
$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
}
}
eval { $t->purge(); }
}
sub _question {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
my @responses = ();
$self->{_number_of_questions}++;
my $x = ($node->children('attribute'))[0];
$attribute = $x->text();
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
if(!defined($self->{_knowledge}->{$attribute})) {
$self->{_number_of_attributes}++;
$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
}
$self->{_knowledge}->{$attribute}->set_question($text, @responses);
eval { $t->purge(); }
}
sub process {
my ($self) = @_;
die "Simple->process() takes no arguments" if scalar(@_) != 1;
my $n = $self->{_goal}->name();
if($self->{_knowledge}->{$n}->is_value_set()) {
return 'finished';
}
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
if($scoreboard{$name} > $max_value) {
$max_value = $scoreboard{$name};
$self->{_ask_about} = $name;
}
}
return $self->{_ask_about} ? 'question' : 'failed';
}
}
sub get_question {
my ($self) = @_;
die "Simple->get_question() takes no arguments" if scalar(@_) != 1;
return $self->{_knowledge}->{$self->{_ask_about}}->get_question();
}
sub answer {
my ($self, $value) = @_;
die "Simple->answer() takes 1 argument" if scalar(@_) != 2;
die "Simple->answer() argument 1 (VALUE) is undefined" if ! defined($value);
$self->{_told_about} = $value;
}
sub get_answer {
my ($self) = @_;
die "Simple->get_answer() takes no arguments" if scalar(@_) != 1;
my $n = $self->{_goal}->name();
return $self->{_goal}->answer($self->{_knowledge}->{$n}->get_value());
}
sub log {
my ($self) = @_;
die "Simple->log() takes no arguments" if scalar(@_) != 1;
my @return = ();
@return = @{$self->{_log}} if defined @{$self->{_log}};
$self->{_log} = ();
return @return;
}
sub _add_to_log {
my ($self, $message) = @_;
push( @{$self->{_log}}, $message );
}
sub explain {
my ($self) = @_;
die "Simple->explain() takes no arguments" if scalar(@_) != 1;
my $name = $self->{_goal}->name();
my $rule = $self->{_knowledge}->{$name}->get_setter();
my $value = $self->{_knowledge}->{$name}->get_value();
my $x = "The goal '$name' was set to '$value' by " . ($rule ? "rule '$rule'" : 'asking a question' );
$self->_add_to_log( $x );
my @processed_rules;
push( @processed_rules, $rule ) if $rule;
$self->_explain_this( $rule, '', @processed_rules );
}
sub _explain_this {
my ($self, $rule, $depth, @processed_rules) = @_;
$self->_add_to_log( "${depth}Explaining rule '$rule'" );
my %dont_do_these = map{ $_ => 1 } @processed_rules;
my @check_these_rules = ();
my %conditions = $self->{_rules}->{$rule}->conditions();
foreach my $name (sort keys %conditions) {
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
This class implements a simple expert system shell that reads the rules from an XML
knowledge base and questions the user as it attempts to arrive at a conclusion.
=head1 DESCRIPTION
=head2 Overview
This class is where all the work is being done and the other three classes are only
there for support. At present there is little you can do with it other than run it. Future
version will make subclassing of this class feasable and features like logging will be introduced.
To see how to use this class there is a simple shell in the bin directory which allows you
to consult the example knowledge bases and more extensive documemtation in the docs directory.
There is a Ruby version that reads the same XML knowledge bases, if you are interested.
=head2 Constructors and initialisation
=over 4
lib/AI/ExpertSystem/Simple/Goal.pm view on Meta::CPAN
package AI::ExpertSystem::Simple::Goal;
use strict;
use warnings;
our $VERSION = '1.0';
sub new {
my ($class, $name, $message) = @_;
# Check the input
die "Goal->new() takes 2 arguments" if scalar(@_) != 3;
die "Goal->new() argument 1 (NAME) is undefined" if ! defined($name);
die "Goal->new() argument 2 (MESSAGE) is undefined" if ! defined($message);
# All OK, create the object
my $self = {};
$self->{_name} = $name;
$self->{_message} = $message;
return bless $self, $class;
}
sub is_goal {
my ($self, $name) = @_;
# Check the input
die "Goal->is_goal() takes 1 argument" if scalar(@_) != 2;
die "Goal->is_goal() argument 1 (NAME) is undefined" if ! defined($name);
# All OK, do the stuff
return $self->{_name} eq $name;
}
sub name {
my ($self) = @_;
# Check the input
die "Goal->name() takes no arguments" if scalar(@_) != 1;
# All OK, do the stuff
return $self->{_name};
}
sub answer {
my ($self, $value) = @_;
# Check the input
die "Goal->answer() takes 1 argument" if scalar(@_) != 2;
die "Goal->answer() argument 1 (VALUE) is undefined" if ! defined($value);
# All OK, do the stuff
my @text = ();
lib/AI/ExpertSystem/Simple/Knowledge.pm view on Meta::CPAN
package AI::ExpertSystem::Simple::Knowledge;
use strict;
use warnings;
our $VERSION = '1.2';
sub new {
my ($class, $name) = @_;
die "Knowledge->new() takes 1 argument" if scalar(@_) != 2;
die "Knowledge->new() argument 1, (NAME) is undefined" if ! defined($name);
my $self = {};
$self->{_name} = $name;
$self->{_value} = undef;
$self->{_setter} = undef;
$self->{_question} = undef;
$self->{_responses} = ();
return bless $self, $class;
}
sub reset {
my ($self) = @_;
die "Knowledge->reset() takes no arguments" if scalar(@_) != 1;
$self->{_value} = undef;
$self->{_setter} = undef;
}
sub set_value {
my ($self, $value, $setter) = @_;
die "Knowledge->set_value() takes 2 argument" if scalar(@_) != 3;
die "Knowledge->set_value() argument 1, (VALUE) is undefined" if ! defined($value);
die "Knowledge->set_value() argument 2, (SETTER) is undefined" if ! defined($setter);
if(defined($self->{_value})) {
die "Knowledge->set_value() has already been set";
}
$self->{_value} = $value;
$self->{_setter} = $setter;
}
sub get_value {
my ($self) = @_;
die "Knowledge->get_value() takes no arguments" if scalar(@_) != 1;
return $self->{_value};
}
sub get_setter {
my ($self) = @_;
die "Knowledge->get_setter() takes no arguments" if scalar(@_) != 1;
return $self->{_setter};
}
sub is_value_set {
my($self) = @_;
die "Knowledge->is_value_set() takes no arguments" if scalar(@_) != 1;
return defined($self->{_value});
}
sub set_question {
my ($self, $question, @responses) = @_;
if(defined($self->{_question})) {
die "Knowledge->set_question() has already been set";
}
die "Knowledge->set_question() takes 2 arguments" if scalar(@_) < 3;
die "Knowledge->set_question() argument 1, (QUESTION) is undefined" if ! defined($question);
# This test just doesnt work for a list
# die "Knowledge->set_question() argument 2, (RESPONSES) is undefined" if scalar(@responses) == 0;
$self->{_question} = $question;
push(@{$self->{_responses}}, @responses);
}
sub get_question {
my ($self) = @_;
die "Knowledge->get_question() takes no arguments" if scalar(@_) != 1;
if(!defined($self->{_question})) {
die "Knowledge->set_question() has not been set";
}
return ($self->{_question}, @{$self->{_responses}});
}
sub has_question {
my ($self) = @_;
die "Knowledge->has_question() takes no arguments" if scalar(@_) != 1;
return (defined($self->{_question}) and !defined($self->{_value}));
}
sub name {
my ($self) = @_;
die "Knowledge->name() takes no arguments" if scalar(@_) != 1;
return $self->{_name};
}
1;
=head1 NAME
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
package AI::ExpertSystem::Simple::Rule;
use strict;
use warnings;
our $VERSION = '1.2';
sub new {
my ($class, $name) = @_;
die "Rule->new() takes 1 argument" if(scalar(@_) != 2);
die "Rule->new() argument 1 (NAME) is undefined" if(!defined($name));
my $self = {};
$self->{_name} = $name;
$self->{_conditions} = ();
$self->{_tested} = ();
$self->{_counter} = 0;
$self->{_actions} = ();
$self->{_state} = 'active';
return bless $self, $class;
}
sub reset {
my ($self) = @_;
# Check the input
die "Rule->reset() takes no arguments" if scalar(@_) != 1;
$self->{_state} = 'active';
$self->{_counter} = 0;
foreach my $name (keys %{$self->{_tested}}) {
$self->{_tested}->{$name} = 0;
$self->{_counter}++;
}
}
sub add_condition {
my ($self, $name, $value) = @_;
die "Rule->add_condition() takes 2 arguments" if(scalar(@_) != 3);
die "Rule->add_condition() argument 1 (NAME) is undefined" if(!defined($name));
die "Rule->add_condition() argument 2 (VALUE) is undefined" if(!defined($value));
if(defined($self->{_conditions}->{$name})) {
die "Rule->add_condition() has already been set";
}
$self->{_conditions}->{$name} = $value;
$self->{_tested}->{$name} = 0;
$self->{_counter}++;
}
sub add_action {
my ($self, $name, $value) = @_;
die "Rule->add_action() takes 2 arguments" if(scalar(@_) != 3);
die "Rule->add_action() argument 1 (NAME) is undefined" if(!defined($name));
die "Rule->add_action() argument 2 (VALUE) is undefined" if(!defined($value));
if(defined($self->{_actions}->{$name})) {
die "Rule->add_action() has already been set";
}
$self->{_actions}->{$name} = $value;
}
sub name {
my ($self) = @_;
die "Rule->name() takes no arguments" if(scalar(@_) != 1);
return $self->{_name};
}
sub state {
my ($self) = @_;
die "Rule->state() takes no arguments" if(scalar(@_) != 1);
return $self->{_state};
}
sub given {
my ($self, $name, $value) = @_;
die "Rule->given() takes 2 arguments" if(scalar(@_) != 3);
die "Rule->given() argument 1 (NAME) is undefined" if(!defined($name));
die "Rule->given() argument 2 (VALUE) is undefined" if(!defined($value));
if(defined($self->{_conditions}->{$name})) {
if($self->{_tested}->{$name} == 1) {
# Already done this one
} elsif($self->{_conditions}->{$name} eq $value) {
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
$self->{_state} = 'completed';
}
} else {
$self->{_state} = 'invalid';
}
}
return $self->{_state};
}
sub actions {
my ($self) = @_;
die "Rule->actions() takes no arguments" if(scalar(@_) != 1);
return %{$self->{_actions}};
}
sub conditions {
my ($self) = @_;
die "Rule->conditions() takes no arguments" if(scalar(@_) != 1);
return %{$self->{_conditions}};
}
sub unresolved {
my ($self) = @_;
die "Rule->unresolved() takes no arguments" if(scalar(@_) != 1);
my @list = ();
foreach my $name (keys(%{$self->{_tested}})) {
if($self->{_tested}->{$name} == 0) {
push(@list, $name);
}
( run in 0.422 second using v1.01-cache-2.11-cpan-88abd93f124 )