File Coverage

blib/lib/AI/ExpertSystem/Simple.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package AI::ExpertSystem::Simple;
2              
3 1     1   983 use strict;
  1         2  
  1         42  
4 1     1   6 use warnings;
  1         2  
  1         44  
5              
6 1     1   440 use XML::Twig;
  0            
  0            
7              
8             use AI::ExpertSystem::Simple::Rule;
9             use AI::ExpertSystem::Simple::Knowledge;
10             use AI::ExpertSystem::Simple::Goal;
11              
12             our $VERSION = '1.2';
13              
14             sub new {
15             my ($class) = @_;
16              
17             die "Simple->new() takes no arguments" if scalar(@_) != 1;
18              
19             my $self = {};
20              
21             $self->{_rules} = ();
22             $self->{_knowledge} = ();
23             $self->{_goal} = undef;
24             $self->{_filename} = undef;
25              
26             $self->{_ask_about} = undef;
27             $self->{_told_about} = undef;
28              
29             $self->{_log} = ();
30              
31             $self->{_number_of_rules} = 0;
32             $self->{_number_of_attributes} = 0;
33             $self->{_number_of_questions} = 0;
34              
35             return bless $self, $class;
36             }
37              
38             sub reset {
39             my ($self) = @_;
40              
41             die "Simple->reset() takes no arguments" if scalar(@_) != 1;
42              
43             foreach my $name (keys %{$self->{_rules}}) {
44             $self->{_rules}->{$name}->reset();
45             }
46              
47             foreach my $name (keys %{$self->{_knowledge}}) {
48             $self->{_knowledge}->{$name}->reset();
49             }
50              
51             $self->{_ask_about} = undef;
52             $self->{_told_about} = undef;
53             $self->{_log} = ();
54             }
55              
56             sub load {
57             my ($self, $filename) = @_;
58              
59             die "Simple->load() takes 1 argument" if scalar(@_) != 2;
60             die "Simple->load() argument 1 (FILENAME) is undefined" if !defined($filename);
61              
62             if(-f $filename and -r $filename) {
63             my $twig = XML::Twig->new(
64             twig_handlers => { goal => sub { $self->_goal(@_) },
65             rule => sub { $self->_rule(@_) },
66             question => sub { $self->_question(@_) } }
67             );
68              
69             $twig->safe_parsefile($filename);
70              
71             die "Simple->load() XML parse failed: $@" if $@;
72              
73             $self->{_filename} = $filename;
74              
75             $self->_add_to_log( "Read in $filename" );
76             $self->_add_to_log( "There are " . $self->{_number_of_rules} . " rules" );
77             $self->_add_to_log( "There are " . $self->{_number_of_attributes} . " attributes" );
78             $self->_add_to_log( "There are " . $self->{_number_of_questions} . " questions" );
79             $self->_add_to_log( "The goal attibutes is " . $self->{_goal}->name() );
80             return 1;
81             } else {
82             die "Simple->load() unable to use file";
83             }
84             }
85              
86             sub _goal {
87             my ($self, $t, $node) = @_;
88              
89             my $attribute = undef;
90             my $text = undef;
91              
92             my $x = ($node->children('attribute'))[0];
93             $attribute = $x->text();
94              
95             $x = ($node->children('text'))[0];
96             $text = $x->text();
97              
98             $self->{_goal} = AI::ExpertSystem::Simple::Goal->new($attribute, $text);
99              
100             eval { $t->purge(); }
101             }
102              
103             sub _rule {
104             my ($self, $t, $node) = @_;
105              
106             my $name = undef;
107              
108             my $x = ($node->children('name'))[0];
109             $name = $x->text();
110              
111             if(!defined($self->{_rules}->{$name})) {
112             $self->{_rules}->{$name} = AI::ExpertSystem::Simple::Rule->new($name);
113             $self->{_number_of_rules}++;
114             }
115              
116             foreach $x ($node->get_xpath('//condition')) {
117             my $attribute = undef;
118             my $value = undef;
119              
120             my $y = ($x->children('attribute'))[0];
121             $attribute = $y->text();
122              
123             $y = ($x->children('value'))[0];
124             $value = $y->text();
125              
126             $self->{_rules}->{$name}->add_condition($attribute, $value);
127              
128             if(!defined($self->{_knowledge}->{$attribute})) {
129             $self->{_number_of_attributes}++;
130             $self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
131             }
132             }
133              
134             foreach $x ($node->get_xpath('//action')) {
135             my $attribute = undef;
136             my $value = undef;
137              
138             my $y = ($x->children('attribute'))[0];
139             $attribute = $y->text();
140              
141             $y = ($x->children('value'))[0];
142             $value = $y->text();
143              
144             $self->{_rules}->{$name}->add_action($attribute, $value);
145              
146             if(!defined($self->{_knowledge}->{$attribute})) {
147             $self->{_number_of_attributes}++;
148             $self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
149             }
150             }
151              
152             eval { $t->purge(); }
153             }
154              
155             sub _question {
156             my ($self, $t, $node) = @_;
157              
158             my $attribute = undef;
159             my $text = undef;
160             my @responses = ();
161              
162             $self->{_number_of_questions}++;
163              
164             my $x = ($node->children('attribute'))[0];
165             $attribute = $x->text();
166              
167             $x = ($node->children('text'))[0];
168             $text = $x->text();
169              
170             foreach $x ($node->children('response')) {
171             push(@responses, $x->text());
172             }
173              
174             if(!defined($self->{_knowledge}->{$attribute})) {
175             $self->{_number_of_attributes}++;
176             $self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
177             }
178             $self->{_knowledge}->{$attribute}->set_question($text, @responses);
179              
180             eval { $t->purge(); }
181             }
182              
183             sub process {
184             my ($self) = @_;
185              
186             die "Simple->process() takes no arguments" if scalar(@_) != 1;
187              
188             my $n = $self->{_goal}->name();
189              
190             if($self->{_knowledge}->{$n}->is_value_set()) {
191             return 'finished';
192             }
193              
194             if($self->{_ask_about}) {
195             my %answers = ();
196              
197             $answers{$self->{_ask_about}}->{value} = $self->{_told_about};
198             $answers{$self->{_ask_about}}->{setter} = '';
199              
200             $self->{_ask_about} = undef;
201             $self->{_told_about} = undef;
202              
203             while(%answers) {
204             my %old_answers = %answers;
205             %answers = ();
206              
207             foreach my $answer (keys(%old_answers)) {
208             my $n = $answer;
209             my $v = $old_answers{$answer}->{value};
210             my $s = $old_answers{$answer}->{setter};
211              
212             $self->_add_to_log( "Setting '$n' to '$v'" );
213              
214             $self->{_knowledge}->{$n}->set_value($v,$s);
215              
216             foreach my $key (keys(%{$self->{_rules}})) {
217             if($self->{_rules}->{$key}->state() eq 'active') {
218             my $state = $self->{_rules}->{$key}->given($n, $v);
219             if($state eq 'completed') {
220             $self->_add_to_log( "Rule '$key' has completed" );
221             my %y = $self->{_rules}->{$key}->actions();
222             foreach my $k (keys(%y)) {
223             $self->_add_to_log( "Rule '$key' is setting '$k' to '$y{$k}'" );
224             $answers{$k}->{value} = $y{$k};
225             $answers{$k}->{setter} = $key;
226             }
227             } elsif($state eq 'invalid') {
228             $self->_add_to_log( "Rule '$key' is now inactive" );
229             }
230             }
231             }
232             }
233             }
234              
235             return 'continue';
236             } else {
237             my %scoreboard = ();
238              
239             foreach my $rule (keys(%{$self->{_rules}})) {
240             if($self->{_rules}->{$rule}->state() eq 'active') {
241             my @listofquestions = $self->{_rules}->{$rule}->unresolved();
242             my $ok = 1;
243             my @questionstoask = ();
244             foreach my $name (@listofquestions) {
245             if($self->{_knowledge}->{$name}->has_question()) {
246             push(@questionstoask, $name);
247             } else {
248             $ok = 0;
249             }
250             }
251              
252             if($ok == 1) {
253             foreach my $name (@questionstoask) {
254             $scoreboard{$name}++;
255             }
256             }
257             }
258             }
259              
260             my $max_value = 0;
261              
262             foreach my $name (keys(%scoreboard)) {
263             if($scoreboard{$name} > $max_value) {
264             $max_value = $scoreboard{$name};
265             $self->{_ask_about} = $name;
266             }
267             }
268              
269             return $self->{_ask_about} ? 'question' : 'failed';
270             }
271             }
272              
273             sub get_question {
274             my ($self) = @_;
275              
276             die "Simple->get_question() takes no arguments" if scalar(@_) != 1;
277              
278             return $self->{_knowledge}->{$self->{_ask_about}}->get_question();
279             }
280              
281             sub answer {
282             my ($self, $value) = @_;
283              
284             die "Simple->answer() takes 1 argument" if scalar(@_) != 2;
285             die "Simple->answer() argument 1 (VALUE) is undefined" if ! defined($value);
286              
287             $self->{_told_about} = $value;
288             }
289              
290             sub get_answer {
291             my ($self) = @_;
292              
293             die "Simple->get_answer() takes no arguments" if scalar(@_) != 1;
294              
295             my $n = $self->{_goal}->name();
296              
297             return $self->{_goal}->answer($self->{_knowledge}->{$n}->get_value());
298             }
299              
300             sub log {
301             my ($self) = @_;
302              
303             die "Simple->log() takes no arguments" if scalar(@_) != 1;
304              
305             my @return = ();
306             @return = @{$self->{_log}} if defined @{$self->{_log}};
307              
308             $self->{_log} = ();
309              
310             return @return;
311             }
312              
313             sub _add_to_log {
314             my ($self, $message) = @_;
315              
316             push( @{$self->{_log}}, $message );
317             }
318              
319             sub explain {
320             my ($self) = @_;
321              
322             die "Simple->explain() takes no arguments" if scalar(@_) != 1;
323              
324             my $name = $self->{_goal}->name();
325             my $rule = $self->{_knowledge}->{$name}->get_setter();
326             my $value = $self->{_knowledge}->{$name}->get_value();
327              
328             my $x = "The goal '$name' was set to '$value' by " . ($rule ? "rule '$rule'" : 'asking a question' );
329             $self->_add_to_log( $x );
330              
331             my @processed_rules;
332             push( @processed_rules, $rule ) if $rule;
333              
334             $self->_explain_this( $rule, '', @processed_rules );
335             }
336              
337             sub _explain_this {
338             my ($self, $rule, $depth, @processed_rules) = @_;
339              
340             $self->_add_to_log( "${depth}Explaining rule '$rule'" );
341              
342             my %dont_do_these = map{ $_ => 1 } @processed_rules;
343              
344             my @check_these_rules = ();
345              
346             my %conditions = $self->{_rules}->{$rule}->conditions();
347             foreach my $name (sort keys %conditions) {
348             my $value = $conditions{$name};
349             my $setter = $self->{_knowledge}->{$name}->get_setter();
350              
351             my $x = "$depth Condition '$name' was set to '$value' by " . ($setter ? "rule '$setter'" : 'asking a question' );
352             $self->_add_to_log( $x );
353              
354             if($setter) {
355             unless($dont_do_these{$setter}) {
356             $dont_do_these{$setter} = 1;
357             push( @check_these_rules, $setter );
358             }
359             }
360             }
361              
362             my %actions = $self->{_rules}->{$rule}->actions();
363             foreach my $name (sort keys %actions) {
364             my $value = $actions{$name};
365              
366             my $x = "$depth Action set '$name' to '$value'";
367             $self->_add_to_log( $x );
368             }
369              
370             @processed_rules = keys %dont_do_these;
371              
372             foreach my $x ( @check_these_rules ) {
373             push( @processed_rules, $self->_explain_this( $x, "$depth ", keys %dont_do_these ) );
374             }
375              
376             return @processed_rules;
377             }
378              
379             1;
380              
381             =head1 NAME
382              
383             AI::ExpertSystem::Simple - A simple expert system shell
384              
385             =head1 VERSION
386              
387             This document refers to verion 1.2 of AI::ExpertSystem::Simple, released June 10, 2003
388              
389             =head1 SYNOPSIS
390              
391             This class implements a simple expert system shell that reads the rules from an XML
392             knowledge base and questions the user as it attempts to arrive at a conclusion.
393              
394             =head1 DESCRIPTION
395              
396             =head2 Overview
397              
398             This class is where all the work is being done and the other three classes are only
399             there for support. At present there is little you can do with it other than run it. Future
400             version will make subclassing of this class feasable and features like logging will be introduced.
401              
402             To see how to use this class there is a simple shell in the bin directory which allows you
403             to consult the example knowledge bases and more extensive documemtation in the docs directory.
404              
405             There is a Ruby version that reads the same XML knowledge bases, if you are interested.
406              
407             =head2 Constructors and initialisation
408              
409             =over 4
410              
411             =item new( )
412              
413             The constructor takes no arguments and just initialises a few basic variables.
414              
415             =back
416              
417             =head2 Public methods
418              
419             =over 4
420              
421             =item reset( )
422              
423             Resets the system back to its initial state so that a new consoltation can be run
424              
425             =item load( FILENAME )
426              
427             This method takes the FILENAME of an XML knowledgebase and attempts to parse it to set up the data structures
428             required for a consoltation.
429              
430             =item process( )
431              
432             Once the knowledgebase is loaded the consultation is run by repeatedly calling this method.
433              
434             It returns four results:
435              
436             =over 4
437              
438             =item "question"
439              
440             The system has a question to ask of the user.
441              
442             The question and list of valid responses is available from the get_question( ) method and the users response should be returned via the answer( ) method.
443              
444             Then simply call the process( ) method again.
445              
446             =item "continue"
447              
448             The system has calculated some data but has nothing to ask the user but has still not finished.
449              
450             This response will be removed in future versions.
451              
452             Simply call the process( ) method again.
453              
454             =item "finished"
455              
456             The consoltation has finished and the system has an answer for the user which is available from the answer( ) method.
457              
458             =item "failed"
459              
460             The consoltation has finished and the system has failed to find an answer for the user. It happens.
461              
462             =back
463              
464             =item get_question( )
465              
466             If the process( ) method has returned "question" then this method will return the question to ask the user
467             and a list of valid responses.
468              
469             =item answer( VALUE )
470              
471             The user has been presented with the question from the get_question( ) method along with a set of
472             valid responses and the users selection is returned by this method.
473              
474             =item get_answer( )
475              
476             If the process( ) method has returned "finished" then the answer to the users query will be
477             returned by this method.
478              
479             =item log( )
480              
481             Returns a list of the actions undertaken so far and clears the log.
482              
483             =item explain( )
484              
485             Explain how the given answer was arrived at. The explanation is added to the log.
486              
487             =back
488              
489             =head2 Private methods
490              
491             =over 4
492              
493             =item _goal
494              
495             A private method to get the goal data from the knowledgebase.
496              
497             =item _rule
498              
499             A private method to get the rule data from the knowledgebase.
500              
501             =item _question
502              
503             A private method to get the question data from the knowledgebase.
504              
505             =item _add_to_log
506              
507             A private method to add a message to the log.
508              
509             =item _explain_this
510              
511             A private method to explain how a single attribute was set.
512              
513             =back
514              
515             =head1 ENVIRONMENT
516              
517             None
518              
519             =head1 DIAGNOSTICS
520              
521             =over 4
522              
523             =item Simple->new() takes no arguments
524              
525             When the constructor is initialised it requires no arguments. This message is given if
526             some arguments were supplied.
527              
528             =item Simple->reset() takes no arguments
529              
530             When the method is called it requires no arguments. This message is given if
531             some arguments were supplied.
532              
533             =item Simple->load() takes 1 argument
534              
535             When the method is called it requires one argument. This message is given if more or
536             less arguments were supplied.
537              
538             =item Simple->load() argument 1 (FILENAME) is undefined
539              
540             The corrct number of arguments were supplied with the method call, however the first
541             argument, FILENAME, was undefined.
542              
543             =item Simple->load() XML parse failed
544              
545             XML Twig encountered some errors when trying to parse the XML knowledgebase.
546              
547             =item Simple->load() unable to use file
548              
549             The file supplied to the load( ) method could not be used as it was either not a file
550             or not readable.
551              
552             =item Simple->process() takes no arguments
553              
554             When the method is called it requires no arguments. This message is given if
555             some arguments were supplied.
556              
557             =item Simple->get_question() takes no arguments
558              
559             When the method is called it requires no arguments. This message is given if
560             some arguments were supplied.
561              
562             =item Simple->answer() takes 1 argument
563              
564             When the method is called it requires one argument. This message is given if more or
565             less arguments were supplied.
566              
567             =item Simple->answer() argument 1 (VALUE) is undefined
568              
569             The corrct number of arguments were supplied with the method call, however the first
570             argument, VALUE, was undefined.
571              
572             =item Simple->get_answer() takes no arguments
573              
574             When the method is called it requires no arguments. This message is given if
575             some arguments were supplied.
576              
577             =item Simple->log() takes no arguments
578              
579             When the method is called it requires no arguments. This message is given if
580             some arguments were supplied.
581              
582             =item Simple->explain() takes no arguments
583              
584             When the method is called it requires no arguments. This message is given if
585             some arguments were supplied.
586              
587             =back
588              
589             =head1 BUGS
590              
591             None
592              
593             =head1 FILES
594              
595             See the Simple.t file in the test directory and simpleshell in the bin directory.
596              
597             =head1 SEE ALSO
598              
599             AI::ExpertSystem::Simple::Goal - A utility class
600              
601             AI::ExpertSystem::Simple::Knowledge - A utility class
602              
603             AI::ExpertSystem::Simple::Rule - A utility class
604              
605             =head1 AUTHORS
606              
607             Peter Hickman (peterhi@ntlworld.com)
608              
609             =head1 COPYRIGHT
610              
611             Copyright (c) 2003, Peter Hickman. All rights reserved.
612              
613             This module is free software. It may be used, redistributed and/or
614             modified under the same terms as Perl itself.