AI-ExpertSystem-Simple
view release on metacpan or search on metacpan
AI::ExpertSystem::Simple - A class implementing an expert system
This is release V1.2 of AI::ExpertSystem::Simple. The class
implements a simple expert system that reads its knowledge base
(set of IF .. THEN rules) from an XML file.
Three sample knowledge bases are provided along with a command line shell
that allows the knowledge bases to be consulted.
There is a Tcl/Tk based shell in which you can run a consultation, I
was going to write this in Perl/Tk as would seem obvious but this is
less than simple under OSX, infact I never got it to work. However there
was an OSX based version of Tcl/Tk and it would be easier to write the
shell in that which is much more portable (just install ActiveTcl on
Windows, Aqua Tcl/Tk on OSX and use what you have on Linux - ideal).
This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.
CHANGES IN THIS RELEASE
V1.02:
- The explain method now works
V1.01:
- Implemented the reset method
- Simpleshell now works with the consult the Tcl/Tk shell
- Included a copy of the Tcl/Tk shell
V1.00:
- First release to CPAN
bin/consult view on Meta::CPAN
# -----
# Save defaults for program to run, text colour etc
################################################################################
package require cmdline
################################################################################
# Some global variables
################################################################################
set display_information 1
set filehandle ""
set filename ""
set program "simpleshell"
set error ""
set choice ""
toplevel .askme
wm withdraw .askme
################################################################################
# The question asking dialog
################################################################################
proc ask_the_user {message argv} {
# Restore the toplevel item so that we can
bin/consult view on Meta::CPAN
wm deiconify .askme
wm title .askme "What I want to know is?"
# Set the question text
label .askme.l -text $message -padx 10 -pady 10 -wraplength 300
pack .askme.l -side top -anchor n
# The is where the users choice will go
global choice
set choice ""
# Set up each button
set counter 1
foreach option $argv {
button .askme.$counter -text $option -command [list set choice $counter]
pack .askme.$counter -side top -anchor n -fill x
incr counter
}
vwait choice
# Our option has been set, now dismantel the
# contents of the toplevel so we can build it
# up again from scratch next time.
wm withdraw .askme
destroy .askme.l
set counter 1
foreach option $argv {
destroy .askme.$counter
incr counter
}
return $choice
}
################################################################################
# Setting up the window
bin/consult view on Meta::CPAN
frame .top
button .load -text "Load..." -command "do_load" -width 8
button .run -text "Run" -command "do_run" -width 8 -state disabled
button .save -text "Save..." -command "do_save" -width 8 -state disabled
checkbutton .display -text "Display 'information' messages" -variable display_information -onvalue 1 -offvalue 0
pack .load .run .save .display -side left -anchor n -in .top
pack .top -anchor nw
# A log of the output is written here
text .text -yscrollcommand {.textscroll set}
scrollbar .textscroll -orient vertical -command {.text yview}
pack .text -side top -anchor w -fill both -expand 1
pack .textscroll -side right -fill y -in .text
# Define some colours
.text tag config is_status -foreground blue
.text tag config is_question -foreground red
.text tag config is_response -foreground cyan
.text tag config is_answer -foreground green
bin/consult view on Meta::CPAN
}
}
################################################################################
# Code to handle the buttons
################################################################################
proc do_load {} {
status "Load a file..."
set types {{{XML Files} {.xml}} {{All Files} *}}
global filename
set filename [tk_getOpenFile -filetypes $types -title "Load a knowledge base"]
if {$filename != ""} {
load_a_file $filename
} {
status "No file was selected"
}
}
proc load_a_file {filename} {
if {[file isfile $filename] == 0} {
bin/consult view on Meta::CPAN
}
proc do_run {} {
status "Run the file..."
status "This may take a few moments to get started..."
.save configure -state normal
.run configure -state disabled
global filename
global program
set filehandle [open "|$program -t $filename" "r+"]
set question ''
set responses [list]
.text delete 0.1 end
while {![eof $filehandle]} {
set text [gets $filehandle]
if {[regexp {^status:(.*)} $text match newtext]} {
status $newtext
} elseif {[regexp {^question:(.*)} $text match newtext]} {
set question $newtext
set responses [list]
question $newtext
} elseif {[regexp {^response:(.*)} $text match newtext]} {
if {$newtext != "*"} {
lappend responses "$newtext"
response "One possible answer is => $newtext"
} else {
set is [ask_the_user $question $responses]
puts $filehandle $is
flush $filehandle
incr is -1
set word [lindex $responses $is]
answer "Your answer is => $word"
}
} elseif {[regexp {^information:(.*)} $text match newtext]} {
information $newtext
} elseif {[regexp {^explaination:(.*)} $text match newtext]} {
status $newtext
} else {
status $text
}
}
.run configure -state normal
}
proc do_save {} {
status "Save the output..."
set types { {{Text Files} {.txt} } {{All Files} * } }
set filename [tk_getSaveFile -filetypes $types -title "Save the results of a run" -initialfile "Results.txt"]
if {$filename != ""} {
if {[file isfile $filename] == 0} {
status "The file you selected is not really a file"
} elseif {[file writeable $filename] == 0} {
status "The file you selected in not writeable"
} else {
status "Saving the output to $filename"
set handle [open $filename "w"]
puts $handle [.text get 0.1 end]
close $handle
}
} {
status "No file was selected"
}
}
################################################################################
# Utility functions
bin/consult view on Meta::CPAN
.text see end
update
}
################################################################################
# The program starts here
################################################################################
# Was there a filename on the command line
set p_count 0
while {[set err [cmdline::getopt argv {f.arg p.arg} opt val]] > 0} {
switch -- $opt {
f {
if {$filename == ""} {
set filename $val
} {
set error "The $opt switch should only be used once"
}
}
p {
if {$p_count == 0} {
set program $val
incr p_count
if {[file executable $program] != 1} {
set error "The program '$program' is not runable"
}
} {
set error "The $opt switch should only be used once"
}
}
}
}
if {$err < 0} {
puts "There was an error: $val"
exit
}\
elseif {$error != ""} {
bin/simpleshell view on Meta::CPAN
elsif ( $r eq 'failed' ) {
say_status("Unable to answer your question");
$running = undef;
}
}
if($tkinterface) {
$continue = 'no';
} 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 ) = @_;
examples/test.xml view on Meta::CPAN
<?xml version="1.0" encoding="utf-8" ?>
<!DOCTYPE knowledgebase SYSTEM "sie-1.0.dtd">
<knowledgebase>
<goal>
<attribute>thegoal</attribute>
<text>You have set the goal to thegoal</text>
</goal>
<rules>
<rule>
<name>1</name>
<conditions>
<condition>
<attribute>one</attribute>
<value>yes</value>
</condition>
</conditions>
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) = @_;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$text = $x->text();
foreach $x ($node->children('response')) {
push(@responses, $x->text());
}
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';
}
if($self->{_ask_about}) {
my %answers = ();
$answers{$self->{_ask_about}}->{value} = $self->{_told_about};
$answers{$self->{_ask_about}}->{setter} = '';
$self->{_ask_about} = undef;
$self->{_told_about} = undef;
while(%answers) {
my %old_answers = %answers;
%answers = ();
foreach my $answer (keys(%old_answers)) {
my $n = $answer;
my $v = $old_answers{$answer}->{value};
my $s = $old_answers{$answer}->{setter};
$self->_add_to_log( "Setting '$n' to '$v'" );
$self->{_knowledge}->{$n}->set_value($v,$s);
foreach my $key (keys(%{$self->{_rules}})) {
if($self->{_rules}->{$key}->state() eq 'active') {
my $state = $self->{_rules}->{$key}->given($n, $v);
if($state eq 'completed') {
$self->_add_to_log( "Rule '$key' has completed" );
my %y = $self->{_rules}->{$key}->actions();
foreach my $k (keys(%y)) {
$self->_add_to_log( "Rule '$key' is setting '$k' to '$y{$k}'" );
$answers{$k}->{value} = $y{$k};
$answers{$k}->{setter} = $key;
}
} elsif($state eq 'invalid') {
$self->_add_to_log( "Rule '$key' is now inactive" );
}
}
}
}
}
return 'continue';
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
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) {
my $value = $conditions{$name};
my $setter = $self->{_knowledge}->{$name}->get_setter();
my $x = "$depth Condition '$name' was set to '$value' by " . ($setter ? "rule '$setter'" : 'asking a question' );
$self->_add_to_log( $x );
if($setter) {
unless($dont_do_these{$setter}) {
$dont_do_these{$setter} = 1;
push( @check_these_rules, $setter );
}
}
}
my %actions = $self->{_rules}->{$rule}->actions();
foreach my $name (sort keys %actions) {
my $value = $actions{$name};
my $x = "$depth Action set '$name' to '$value'";
$self->_add_to_log( $x );
}
@processed_rules = keys %dont_do_these;
foreach my $x ( @check_these_rules ) {
push( @processed_rules, $self->_explain_this( $x, "$depth ", keys %dont_do_these ) );
}
return @processed_rules;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
=item new( )
The constructor takes no arguments and just initialises a few basic variables.
=back
=head2 Public methods
=over 4
=item reset( )
Resets the system back to its initial state so that a new consoltation can be run
=item load( FILENAME )
This method takes the FILENAME of an XML knowledgebase and attempts to parse it to set up the data structures
required for a consoltation.
=item process( )
Once the knowledgebase is loaded the consultation is run by repeatedly calling this method.
It returns four results:
=over 4
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
=back
=item get_question( )
If the process( ) method has returned "question" then this method will return the question to ask the user
and a list of valid responses.
=item answer( VALUE )
The user has been presented with the question from the get_question( ) method along with a set of
valid responses and the users selection is returned by this method.
=item get_answer( )
If the process( ) method has returned "finished" then the answer to the users query will be
returned by this method.
=item log( )
Returns a list of the actions undertaken so far and clears the log.
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
=item _question
A private method to get the question data from the knowledgebase.
=item _add_to_log
A private method to add a message to the log.
=item _explain_this
A private method to explain how a single attribute was set.
=back
=head1 ENVIRONMENT
None
=head1 DIAGNOSTICS
=over 4
=item Simple->new() takes no arguments
When the constructor is initialised it requires no arguments. This message is given if
some arguments were supplied.
=item Simple->reset() takes no arguments
When the method is called it requires no arguments. This message is given if
some arguments were supplied.
=item Simple->load() takes 1 argument
When the method is called it requires one argument. This message is given if more or
less arguments were supplied.
=item Simple->load() argument 1 (FILENAME) is undefined
lib/AI/ExpertSystem/Simple/Goal.pm view on Meta::CPAN
=head2 Overview
This is a utility class for AI::ExpertSystem::Simple
=head2 Constructors and initialisation
=over 4
=item new( NAME, MESSAGE )
The constructor takes two arguments. The first, NAME, is the name of the attribute that when set will
trigger the end of the consoltation. The second argument, MESSAGE, is the text that will be interpolated
as the answer for the consoltation.
=back
=head2 Public methods
=over 4
=item is_goal( NAME )
This method compares the given NAME with that of the attribute name given when the object was constructed and
returns true if they are the same or false if not.
=item name( )
This method return the value of the NAME argument that was set when the object was constructed.
=item answer( VALUE )
This method take VALUE to be the value of the goal attribute and will use it to interpolate and return the MESSAGE that was given
when the object was constructed.
=back
=head2 Private methods
lib/AI/ExpertSystem/Simple/Knowledge.pm view on Meta::CPAN
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;
lib/AI/ExpertSystem/Simple/Knowledge.pm view on Meta::CPAN
AI::ExpertSystem::Simple::Knowledge - Utility class for a simple expert system
=head1 VERSION
This document refers to verion 1.2 of AI::ExpertSystem::Simple::Knowledge, released June 10, 2003
=head1 SYNOPSIS
This class handles the attributes and their values within the expert system along with the optional question that
can be asked of the user to set the value of the attribute. The valid responses to the optional question are also held.
=head1 DESCRIPTION
=head2 Overview
This is a utility class for AI::ExpertSystem::Simple
=head2 Constructors and initialisation
=over 4
=item new( NAME )
The constructor sets up the basic attribute name / value pairing. In the base case an attribute has a name with no value.
Optional questions and the valid responses can be set later and the value of the attribute is set during the consultation.
=back
=head2 Public methods
=over 4
=item reset( )
Resets the state of knowledge back to what it was when the object was created
=item set_value( VALUE, SETTER )
During the consultation process the VALUE for an attribute can be set by either asking the user a question or by deduction. The value is then recorded along with the rule that set the value (or blank it if was a question).
=item get_value( )
Returns the current value of the attribute.
=item get_setter( )
Returns the current setter of the attribute.
=item is_value_set( )
Returns true if the value of the attribute is set or false if not.
=item set_question( QUESTION, RESPONSES )
Allows a question to ask of the user to set the value of the attribute. QUESTION is the text that will be displayed to the user and RESPONSES is a list of valid responses that the user may select from.
=item get_question( )
Returns the QUESTION and list of valid RESPONSES for the attribute.
=item has_question( )
Returns true if the attribute has a question to ask the user if the VALUE of the attribute has not already been set.
=item name( )
This method returns the value of the NAME argument that was set when the object was constructed.
=back
=head2 Private methods
None
=head1 ENVIRONMENT
None
lib/AI/ExpertSystem/Simple/Knowledge.pm view on Meta::CPAN
=over 4
=item Knowledge->new() takes 1 argument
When the constructor is initialised it requires one argument. This message is given if more of less arguments are given.
=item Knowledge->new() argument 1, (NAME) is undefined
The correct number of arguments were supplied to the constructor, however the first argument, NAME, was undefined.
=item Knowledge->reset() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->set_value() takes 2 argument
When the method is called it requires two arguments. This message is given if more of less arguments are given.
=item Knowledge->set_value() argument 1, (VALUE) is undefined
The correct number of arguments were supplied to the method call, however the first argument, VALUE, was undefined.
=item Knowledge->set_value() argument 2, (SETTER) is undefined
The correct number of arguments were supplied to the method call, however the second argument, SETTER, was undefined.
=item Knowledge->set_value() has already been set
This method has already been called and the value set. It cannot be called twice.
=item Knowledge->get_value() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->get_setter() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->is_value_set() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->set_question() takes 2 arguments
When the method is called it requires two arguments. This message is given if more of less arguments are given.
=item Knowledge->set_question() argument 1, (QUESTION) is undefined
The correct number of arguments were supplied to the method call, however the first argument, QUESTION, was undefined.
=item Knowledge->set_question() has already been set
This method has already been called and the value set. It cannot be called twice.
=item Knowledge->get_question() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->get_question() has not been set
The value has not been set by Knowledge->set_question() and, therefore, cannot be retrieved.
=item Knowledge->has_question() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=item Knowledge->name() takes no arguments
When the method is called it requires no arguments. This message is given if some where supplied.
=back
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
$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);
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
=item new( NAME )
The constructor takes one argument, the NAME of the rule. The consition and actions are added later.
=back
=head2 Public methods
=over 4
=item reset( )
Resets the state of the rule back to active and all the condition attributes to untested.
=item add_condition( NAME, VALUE )
This adds a condition attribute name / value pair.
=item add_action( NAME, VALUE )
This adds an action attribute name / value pair.
=item name( )
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
Returns the current state of the rule.
=item given( NAME, VALUE )
The NAME / VALUE attribute pair is checked against the rule's conditions to see if a condition is met and the state of the rule
is changed in light of the result.
=item actions( )
Returns a list of the actions set in the rule.
=item conditions( )
Returns a list of the conditions matched in the rule.
=item unresolved( )
Returns a list of all the unresolved condition of the rule.
=back
lib/AI/ExpertSystem/Simple/Rule.pm view on Meta::CPAN
=over 4
=item Rule->new() takes 1 argument
When the constructor is initialised it requires one argument. This message is given if more or less arguments were supplied.
=item Rule->new() argument 1 (NAME) is undefined
The corrct number of arguments were supplied to the constructor, however the first argument, NAME, was undefined.
=item Rule->reset() takes no arguments
When the method is called it requires no arguments. This message is given if more or less arguments were supplied.
=item Rule->add_condition() takes 2 arguments
When the method is called it requires two arguments. This message is given if more or less arguments were supplied.
=item Rule->add_condition() argument 1 (NAME) is undefined
The corrct number of arguments were supplied with the method call, however the first argument, NAME, was undefined.
=item Rule->add_condition() argument 2 (VALUE) is undefined
The corrct number of arguments were supplied with the method call, however the second argument, VALUE, was undefined.
=item Rule->add_condition() has already been set
This method has already been called and the value set. It cannot be called twice.
=item Rule->add_action() takes 2 arguments
When the method is called it requires two arguments. This message is given if more or less arguments were supplied.
=item Rule->add_action() argument 1 (NAME) is undefined
The corrct number of arguments were supplied with the method call, however the first argument, NAME, was undefined.
=item Rule->add_action() argument 2 (VALUE) is undefined
The corrct number of arguments were supplied with the method call, however the second argument, VALUE, was undefined.
=item Rule->add_action() has already been set
This method has already been called and the value set. It cannot be called twice.
=item Rule->name() takes no arguments
When the method is called it requires no arguments. This message is given if more or less arguments were supplied.
=item Rule->state() takes no arguments
When the method is called it requires no arguments. This message is given if more or less arguments were supplied.
=item Rule->given() takes 2 arguments
t/Knowledge.t view on Meta::CPAN
is($x->name(), 'fred', 'Checking the name');
################################################################################
# Check the question attribute
################################################################################
eval { $x->has_question(1); };
like($@, qr/^Knowledge->has_question\(\) takes no arguments /, 'Too many arguments');
eval { $x->set_question(1); };
like($@, qr/^Knowledge->set_question\(\) takes 2 arguments /, 'Too few arguments');
eval { $x->set_question(undef,2); };
like($@, qr/^Knowledge->set_question\(\) argument 1, \(QUESTION\) is undefined /, 'Question is undefined');
eval { $x->get_question(); };
like($@, qr/^Knowledge->set_question\(\) has not been set /, 'Question not set');
is($x->has_question(), '', 'No question has been set');
$x->set_question('to be or not to be', ('be', 'not'));
is($x->has_question(), '1', 'The question is now set');
eval { $x->set_question('fredfred', (1,2)); };
like($@, qr/^Knowledge->set_question\(\) has already been set /, 'Is already set');
################################################################################
# Check the question attribute
################################################################################
is($x->get_value(), undef, 'The value is unset');
is($x->has_question(), '1', 'The question has not been answered');
eval { $x->set_value(); };
like($@, qr/^Knowledge->set_value\(\) takes 2 argument /, 'Too few arguments');
eval { $x->set_value(1); };
like($@, qr/^Knowledge->set_value\(\) takes 2 argument /, 'Too few arguments');
eval { $x->set_value(1,2,3); };
like($@, qr/^Knowledge->set_value\(\) takes 2 argument /, 'Too many arguments');
eval { $x->set_value(undef,2); };
like($@, qr/^Knowledge->set_value\(\) argument 1, \(VALUE\) is undefined /, 'Value is undefined');
eval { $x->set_value(1,undef); };
like($@, qr/^Knowledge->set_value\(\) argument 2, \(SETTER\) is undefined /, 'Value is undefined');
eval { $x->is_value_set(1); };
like($@, qr/^Knowledge->is_value_set\(\) takes no arguments /, 'Too many arguments');
is($x->is_value_set(), '', 'Value is not set');
$x->set_value('fred', 'banana');
is($x->is_value_set(), '1', 'Value is set');
eval { $x->set_value('fredfred', 'banana'); };
like($@, qr/^Knowledge->set_value\(\) has already been set /, 'Is already set');
eval { $x->get_value(1); };
like($@, qr/^Knowledge->get_value\(\) takes no arguments /, 'Too many arguments');
eval { $x->get_setter(1); };
like($@, qr/^Knowledge->get_setter\(\) takes no arguments /, 'Too many arguments');
is($x->get_value(), 'fred', 'The value is set');
is($x->get_setter(), 'banana', 'The value is set');
is($x->has_question(), '', 'The question has been answered');
################################################################################
# Check the question
################################################################################
eval { $x->get_question(1); };
like($@, qr/^Knowledge->get_question\(\) takes no arguments /, 'Too many arguments');
my ($y, @z) = $x->get_question();
is($y, 'to be or not to be', 'Get the question back');
is(scalar(@z), 2, 'Get the responses back');
is($z[0], 'be', 'Checking response');
is($z[1], 'not', 'Checking response');
################################################################################
# Check the reset method for the value part
################################################################################
eval { $x->reset(1); };
like($@, qr/^Knowledge->reset\(\) takes no arguments /, 'Too many arguments');
$x->reset();
is($x->is_value_set(), '', 'Value is not set');
$x->set_value('fred', '');
is($x->is_value_set(), '1', 'Value is set');
$x->reset();
is($x->is_value_set(), '', 'Value is not set');
################################################################################
# Check the reset method for both parts
################################################################################
$x->reset();
is($x->has_question(), '1', 'The question has been set');
is($x->is_value_set(), '', 'Value is not set');
$x->set_value('fred', '');
is($x->is_value_set(), '1', 'Value is set');
is($x->has_question(), '', 'The question has been answered');
eval { $x->add_condition(undef, 2); };
like($@, qr/^Rule->add_condition\(\) argument 1 \(NAME\) is undefined /, 'Name is undefined');
eval { $x->add_condition(1, undef); };
like($@, qr/^Rule->add_condition\(\) argument 2 \(VALUE\) is undefined /, 'Value is undefined');
$x->add_condition('a', 1);
eval { $x->add_condition('a', 1); };
like($@, qr/^Rule->add_condition\(\) has already been set /, 'Is already set');
$x->add_condition('b', 2);
eval { $x->add_action(1); };
like($@, qr/^Rule->add_action\(\) takes 2 arguments /, 'Too few arguments');
eval { $x->add_action(1, 2, 3); };
like($@, qr/^Rule->add_action\(\) takes 2 arguments /, 'Too many arguments');
eval { $x->add_action(undef, 2); };
like($@, qr/^Rule->add_action\(\) argument 1 \(NAME\) is undefined /, 'Name is undefined');
eval { $x->add_action(1, undef); };
like($@, qr/^Rule->add_action\(\) argument 2 \(VALUE\) is undefined /, 'Value is undefined');
$x->add_action('c', 3);
eval { $x->add_action('c', 3); };
like($@, qr/^Rule->add_action\(\) has already been set /, 'Is already set');
eval { $x->state(1); };
like($@, qr/^Rule->state\(\) takes no arguments /, 'Too many arguments');
is($x->state(), 'active', 'Is the rule active');
eval { $x->unresolved(1); };
like($@, qr/^Rule->unresolved\(\) takes no arguments /, 'Too many arguments');
is(scalar($x->unresolved()), 2, 'Unresolved list');
is($x->given('b', 2), 'active', 'Is the rule still active');
is(scalar($x->unresolved()), 1, 'Unresolved list');
is($x->given('a', 1), 'completed', 'Is the rule now complete');
is(scalar($x->unresolved()), 0, 'Unresolved list');
################################################################################
# Reset the rule and start again
################################################################################
eval { $x->reset(1); };
like($@, qr/^Rule->reset\(\) takes no arguments /, 'Too many arguments');
$x->reset();
is($x->state(), 'active', 'Is the rule active');
is($x->given('b', 1), 'invalid', 'Is the rule now invalid');
################################################################################
# Check the results
################################################################################
eval { $x->actions(1); };
like($@, qr/^Simple->answer\(\) argument 1 \(VALUE\) is undefined /, 'Value is undefined');
$x->answer('yes');
is($x->process(), 'continue', 'Carry on');
is($x->process(), 'finished', 'Thats all folks');
eval { $x->get_answer(1); };
like($@, qr/^Simple->get_answer\(\) takes no arguments /, 'Too many arguments');
is($x->get_answer(), 'You have set the goal to pretzel', 'Got the answer');
################################################################################
# Reset and do it all again
################################################################################
eval { $x->reset(1); };
like($@, qr/^Simple->reset\(\) takes no arguments /, 'Too many arguments');
$x->reset();
is($x->process(), 'question', 'We have a question to answer');
($t, $r) = $x->get_question();
$x->answer('yes');
is($x->process(), 'continue', 'Carry on');
is($x->process(), 'finished', 'Thats all folks');
is($x->get_answer(), 'You have set the goal to pretzel', 'Got the answer');
my @log = $x->log();
isnt(scalar @log, 0, 'The log has data');
@log = $x->log();
is(scalar @log, 0, 'The log is empty');
eval { $x->explain(1); };
<?xml version="1.0" encoding="utf-8" ?>
<!DOCTYPE knowledgebase SYSTEM "sie-1.0.dtd">
<knowledgebase>
<goal>
<attribute>thegoal</attribute>
<text>You have set the goal to thegoal</text>
</goal>
<rules>
<rule>
<name>1</name>
<conditions>
<condition>
<attribute>one</attribute>
<value>yes</value>
</condition>
</conditions>
( run in 0.810 second using v1.01-cache-2.11-cpan-49f99fa48dc )