log results from the CPAN

AI-ExpertSystem-Simple

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43 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 
        # put the dialog box together
 
        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

bin/consult view on Meta::CPAN

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100 # The top frame holds the buttons
 
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

bin/simpleshell view on Meta::CPAN

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68 say_status("Consulting $filename");
 
my $continue = 'yes';
 
while($continue eq 'yes') {
        my $running = 1;
 
        while ($running) {
                my $r = $s->process();
 
                process_log();
 
                if ( $r eq 'question' ) {
                        $s->answer( ask_question( $s->get_question() ) );
                }
                elsif ( $r eq 'finished' ) {
                        say_status('The answer is : ' . $s->get_answer());
                        $s->explain();
                        process_log( 'explaination' , 1);
                        $running = undef;
                }
                elsif ( $r eq 'failed' ) {
                        say_status("Unable to answer your question");
                        $running = undef;
                }
        }
 
        if($tkinterface) {
                $continue = 'no';

bin/simpleshell view on Meta::CPAN

116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138                 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);
                }
        }
}

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39         my $self = {};
 
        $self->{_rules} = ();
        $self->{_knowledge} = ();
        $self->{_goal} = undef;
        $self->{_filename} = undef;
 
        $self->{_ask_about} = undef;
        $self->{_told_about} = undef;
 
        $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) = @_;

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63         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(

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89                                            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;

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237         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';
} else {
        my %scoreboard = ();

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377 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) {
                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

390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409  
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.pm view on Meta::CPAN

469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517 =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.
 
=item explain( )
 
Explain how the given answer was arrived at. The explanation is added to the log.
 
=back
 
=head2 Private methods
 
=over 4
 
=item _goal
 
A private method to get the goal data from the knowledgebase.
 
=item _rule
 
A private method to get the rule data from the knowledgebase.
 
=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

lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN

567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587 =item Simple->answer() argument 1 (VALUE) is undefined
 
The corrct number of arguments were supplied with the method call, however the first 
argument, VALUE, was undefined.
 
=item Simple->get_answer() takes no arguments
 
When the method is called it requires no arguments. This message is given if 
some arguments were supplied.
 
=item Simple->log() takes no arguments
 
When the method is called it requires no arguments. This message is given if 
some arguments were supplied.
 
=item Simple->explain() takes no arguments
 
When the method is called it requires no arguments. This message is given if 
some arguments were supplied.
 
=back

t/Simple.t view on Meta::CPAN

83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107  
($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); };
like($@, qr/^Simple->explain\(\) takes no arguments /, 'Too many arguments');
 
$x->explain();
@log = $x->log();
 
isnt(scalar @log, 0, 'The log has data');

( run in 0.712 second using v1.01-cache-2.11-cpan-87723dcf8b7 )