AI-ExpertSystem-Advanced
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
AI-ExpertSystem-Advanced-0.02.tar.gz
examples/backward.pl
examples/example.pl
examples/forward.pl
examples/knowledge_db_one.yaml
examples/mixed.pl
inc/Module/Install.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/AI/ExpertSystem/Advanced.pm
lib/AI/ExpertSystem/Advanced/Dictionary.pm
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Factory.pm
lib/AI/ExpertSystem/Advanced/KnowledgeDB/YAML.pm
lib/AI/ExpertSystem/Advanced/Viewer/Base.pm
lib/AI/ExpertSystem/Advanced/Viewer/Factory.pm
lib/AI/ExpertSystem/Advanced/Viewer/Terminal.pm
Makefile.PL
MANIFEST This list of files
META.yml
README
---
abstract: 'Expert System with backward, forward and mixed algorithms'
author:
- 'Pablo Fischer (pablo@pablo.com.mx).'
build_requires:
ExtUtils::MakeMaker: 6.42
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
generated_by: 'Module::Install version 0.91'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: AI-ExpertSystem-Advanced
no_index:
directory:
- examples
- inc
requires:
Class::Factory: 1.05
List::MoreUtils: 0.22
Moose: 0.87
YAML::Syck: 1.07
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/pfischer/AI-ExpertSystem-Advanced
version: 0.03
Makefile.PL view on Meta::CPAN
use inc::Module::Install;
# Define metadata
name 'AI-ExpertSystem-Advanced';
all_from 'lib/AI/ExpertSystem/Advanced.pm';
# Specific dependencies
requires 'Moose' => '0.87';
requires 'YAML::Syck' => '1.07';
requires 'List::MoreUtils' => '0.22';
requires 'Class::Factory' => '1.05';
no_index directory => 'examples';
repository 'http://github.com/pfischer/AI-ExpertSystem-Advanced';
WriteAll;
NAME
AI::ExpertSystem::Advanced - Expert System with backward, forward and
mixed algorithms
DESCRIPTION
Inspired in AI::ExpertSystem::Simple but with additional features:
* Uses backward, forward and mixed algorithms.
* Offers different views, so user can interact with the expert system
via a terminal or with a friendly user interface.
* The knowledge database can be stored in any format such as YAML, XML
or databases. You just need to choose what driver to use and you are
done.
* Uses certainty factors.
SYNOPSIS
An example of the mixed algorithm:
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I'],
verbose => 1);
$ai->mixed();
$ai->summary();
Attributes
initial_facts
A list/set of initial facts the algorithms start using.
During the forward algorithm the task is to find a list of goals
caused by these initial facts (the only data we have in that
moment).
Lets imagine your knowledge database is about symptoms and diseases.
You need to find what diseases are caused by the symptoms of a
patient, these first symptons are the initial facts.
Initial facts as also asked and inference facts can be negative or
positive. By default the initial facts are positive.
Keep in mind that the data contained in this array can be the IDs or
the name of the fact.
This array will be converted to initial_facts_dict. And all the data
(ids or or names) will be made of only IDs.
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I', ['F', '-'], ['G', '+']);
As you can see if you want to provide the sign of a fact, just
*encapsulate* it in an array, the first item should be the fact and
the second one the sign.
initial_facts_dict
This dictionary (see AI::ExpertSystem::Advanced::Dictionary has the
sasme data of initial_facts but with the additional feature(s) of
proviing iterators and a quick way to find elements.
goals_to_check
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
When doing the backward() algorithm it's required to have at least
one goal (aka hypothesis).
This could be pretty similar to initial_facts, with the difference
that the initial facts are used more with the causes of the rules
and this one with the goals (usually one in a well defined knowledge
database).
The same rule of initial_facts apply here, you can provide the sign
of the facts and you can provide the id or the name of them.
From our example of symptoms and diseases lets imagine we have the
hypothesis that a patient has flu, we don't know the symptoms it
has, we want the expert system to keep asking us for them to make
sure that our hypothesis is correct (or incorrect in case there's
not enough information).
goals_to_check_dict
Very similar to goals_to_check (and indeed of initial_facts_dict).
We want to make the job easier.
It will be a dictionary made of the data of goals_to_check.
inference_facts
Inference facts are basically the core of an expert system. These
are facts that are found and copied when a set of facts (initial,
inference or asked) match with the causes of a goal.
inference_facts is a AI::ExpertSystem::Advanced::Dictionary, it will
store the name of the fact, the rule that caused these facts to be
copied to this dictionary, the sign and the algorithm that triggered
it.
knowledge_db
The object reference of the knowledge database
AI::ExpertSystem::Advanced is using.
asked_facts
During the backward() algorithm there will be cases when there's no
clarity if a fact exists. In these cases the backward() will be
asking the user (via automation or real questions) if a fact exists.
Going back to the initial_facts example of symptoms and diseases.
Imagine the algorithm is checking a rule, some of the facts of the
rule make a match with the ones of initial_facts or inference_facts
but some wont, for these *unsure* facts the backward() will ask the
user if a symptom (a fact) exists. All these asked facts will be
stored here.
visited_rules
Keeps a record of all the rules the algorithms have visited and also
the number of causes each rule has.
verbose
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I'],
verbose => 1);
By default this is turned off. If you want to know what happens
behind the scenes turn this on.
Everything that needs to be debugged will be passed to the debug()
method of your viewer.
viewer
Is the object AI::ExpertSystem::Advanced will be using for printing
what is happening and for interacting with the user (such as asking
the asked_facts).
This is practical if you want to use a viewer object that is not
provided by AI::ExpertSystem::Advanced::Viewer::Factory.
viewer_class
Is the the class name of the viewer.
You can decide to use the viewers
AI::ExpertSystem::Advanced::Viewer::Factory offers, in this case you
can pass the object or only the name of your favorite viewer.
found_factor
In your knowledge database you can give different *weights* to the
facts of each rule (eg to define what facts have more *priority*).
During the mixed() algorithm it will be checking what causes are
found in the inference_facts and in the asked_facts dictionaries,
then the total number of matches (or total number of certainity
factors of each rule) will be compared versus the value of this
factor, if it's higher or equal then the rule will be triggered.
You can read the documentation of the mixed() algorithm to know the
two ways this factor can be used.
shot_rules
All the rules that are shot are stored here. This is a hash, the key
of each item is the rule id while its value is the precision time
when the rule was shot.
The precision time is useful for knowing when a rule was shot and
based on that you can know what steps it followed so you can compare
(or reproduce) them.
Constants
* FACT_SIGN_NEGATIVE
Used when a fact is negative, aka, a fact doesn't happen.
* FACT_SIGN_POSITIVE
Used for those facts that happen.
* FACT_SIGN_UNSURE
Used when there's no straight answer of a fact, eg, we don't know if
an answer will change the result.
Methods
shoot($rule, $algorithm)
Shoots the given rule. It will do the following verifications:
* Each of the facts (causes) will be compared against the
initial_facts_dict, inference_facts and asked_facts (in this order).
* If any initial, inference or asked fact matches with a cause but
it's negative then all of its goals (usually only one by rule) will
be copied to the inference_facts with a negative sign, otherwise a
positive sign will be used.
* Will add the rule to the shot_rules hash.
is_rule_shot($rule)
Verifies if the given $rule has been shot.
get_goals_by_rule($rule)
Will ask the knowledge_db for the goals of the given $rule.
A AI::ExpertSystem::Advanced::Dictionary will be returned.
get_causes_by_rule($rule)
Will ask the knowledge_db for the causes of the given $rule.
A AI::ExpertSystem::Advanced::Dictionary will be returned.
is_fact_negative($dict_name, $fact)
Will check if the given $fact of the given dictionary ($dict_name) is
negative.
copy_to_inference_facts($facts, $sign, $algorithm, $rule)
Copies the given $facts (a dictionary, usually goal(s) of a rule) to the
inference_facts dictionary. All the given goals will be copied with the
given $sign.
Additionally it will add the given $algorithm and $rule to the inference
facts. So later we can know how we got to a certain inference fact.
compare_causes_with_facts($rule)
Compares the causes of the given $rule with:
* Initial facts
* Inference facts
* Asked facts
It will be couting the matches of all of the above dictionaries, so for
example if we have four causes, two make match with initial facts, other
with inference and the remaining one with the asked facts, then it will
evaluate to true since we have a match of the four causes.
get_causes_match_factor($rule)
Similar to compare_causes_with_facts() but with the difference that it
will count the "match factor" of each matched cause and return the total
of this weight.
The match factor is used by the mixed() algorithm and is useful to know
if a certain rule should be shoot or not even if not all of the causes
exist in our facts.
The *match factor* is calculated in two ways:
* Will do a sum of the weight for each matched cause. Please note that
if only one cause of a rule has a specified weight then the
remaining causes will default to the total weight minus 1 and then
divided with the total number of causes (matched or not) that don't
have a weight.
* If no weight is found with all the causes of the given rule, then
the total number of matches will be divided by the total number of
causes.
is_goal_in_our_facts($goal)
Checks if the given $goal is in:
1 The initial facts
2 The inference facts
3 The asked facts
remove_last_ivisited_rule()
Removes the last visited rule and return its number.
visit_rule($rule, $total_causes)
Adds the given $rule to the end of the visited_rules.
copy_to_goals_to_check($rule, $facts)
Copies a list of facts (usually a list of causes of a rule) to
goals_to_check_dict.
The rule ID of the goals that are being copied is also stored in the
hahs.
ask_about($fact)
Uses viewer to ask the user for the existence of the given $fact.
The valid answers are:
+ or FACT_SIGN_POSITIVE
In case user knows of it.
- or FACT_SIGN_NEGATIVE
In case user doesn't knows of it.
~ or FACT_SIGN_UNSURE
In case user doesn't have any clue about the given fact.
get_rule_by_goal($goal)
Looks in the knowledge_db for the rule that has the given goal. If a
rule is found its number is returned, otherwise undef.
forward()
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['F', 'J']);
$ai->forward();
$ai->summary();
The forward chaining algorithm is one of the main methods used in Expert
Systems. It starts with a set of variables (known as initial facts) and
reads the available rules.
It will be reading rule by rule and for each one it will compare its
causes with the initial, inference and asked facts. If all of these
causes are in the facts then the rule will be shoot and all of its goals
will be copied/converted to inference facts and will restart reading
from the first rule.
backward()
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
$ai->backward();
$ai->summary();
The backward algorithm starts with a set of *assumed* goals (facts). It
will start reading goal by goal. For each goal it will check if it
exists in the initial, inference and asked facts (see
is_goal_in_our_facts()) for more information).
* If the goal exist then it will be removed from the dictionary, it
will also verify if there are more visited rules to shoot.
If there are still more visited rules to shoot then it will check
from what rule the goal comes from, if it was copied from a rule
then this data will exist. With this information then it will see
how many of the causes of this given rule are still in the
goals_to_check_dict.
In case there are still causes of this rule in goals_to_check_dict
then the amount of causes pending will be reduced by one. Otherwise
(if the amount is 0) then the rule of this last removed goal will be
shoot.
* If the goal doesn't exist in the mentioned facts then the goal will
be searched in the goals of every rule.
In case it finds the rule that has the goal, this rule will be
marked (added) to the list of visited rules (visited_rules) and also
all of its causes will be added to the top of the
goals_to_check_dict and it will start reading again all the goals.
If there's the case where the goal doesn't exist as a goal in the
rules then it will ask the user (via ask_about()) for the existence
of it. If user is not sure about it then the algorithm ends.
mixed()
As its name says, it's a mix of forward() and backward() algorithms, it
requires to have at least one initial fact.
The first thing it does is to run the forward() algorithm (hence the
need of at least one initial fact). If the algorithm fails then the
mixed algorithm also ends unsuccessfully.
Once the first *run* of forward() algorithm happens it starts looking
for any positive inference fact, if only one is found then this ends the
algorithm with the assumption it knows what's happening.
In case no positive inference fact is found then it will start reading
the rules and creating a list of intuitive facts.
For each rule it will get a *certainty factor* of its causes versus the
initial, inference and asked facts. In case the certainity factor is
greater or equal than found_factor then all of its goals will be copied
to the intuitive facts (eg, read it as: it assumes the goals have
something to do with our first initial facts).
Once all the rules are read then it verifies if there are intuitive
facts, if no facts are found then it ends with the intuition, otherwise
it will run the backward() algorithm for each one of these facts (eg,
each fact will be converted to a goal). After each *run* of the
backward() algorithm it will verify for any positive inference fact, if
just one is found then the algorithm ends.
At the end (if there are still no positive inference facts) it will run
the forward() algorithm and restart (by looking again for any positive
inference fact).
A good example to understand how this algorithm is useful is: imagine
you are a doctor and know some of the symptoms of a patient. Probably
with the first symptoms you have you can get to a positive conclusion
(eg that a patient has *X* disease). However in case there's still no
clue, then a set of questions (done by the call of backward()) of
symptons related to the initial symptoms will be asked to the user. For
example, we know that that the patient has a headache but that doesn't
give us any positive answer, what if the patient has flu or another
disease? Then a set of these *related* symptons will be asked to the
user.
summary($return)
The main purpose of any expert system is the ability to explain: what is
happening, how it got to a result, what assumption(s) it required to
make, the fatcs that were excluded and the ones that were used.
This method will use the viewer (or return the result) in YAML format of
all the rules that were shot. It will explain how it got to each one of
the causes so a better explanation can be done by the viewer.
If $return is defined (eg, it got any parameter) then the result wont be
passed to the viewer, instead it will be returned as a string.
SEE ALSO
Take a look AI::ExpertSystem::Simple too.
AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
examples/backward.pl view on Meta::CPAN
#!/usr/bin/perl
#
# backward.pl
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:20:43 PST 15:20:43
use strict;
use warnings;
use Data::Dumper;
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
$ai->backward();
$ai->summary();
examples/example.pl view on Meta::CPAN
#!/usr/bin/perl
#
# example.pl
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:20:43 PST 15:20:43
use strict;
use warnings;
use Data::Dumper;
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['H']);
$ai->backward();
$ai->summary();
examples/forward.pl view on Meta::CPAN
#!/usr/bin/perl
#
# forward.pl
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:20:43 PST 15:20:43
use strict;
use warnings;
use Data::Dumper;
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['F', 'J']);
$ai->forward();
$ai->summary();
examples/knowledge_db_one.yaml view on Meta::CPAN
rules:
-
causes:
-
name: K
-
name: L
goals:
-
name: J
-
causes:
-
name: F
-
name: J
goals:
-
name: M
-
causes:
-
name: F
goals:
-
name: I
-
causes:
-
name: L
-
name: I
goals:
-
name: N
-
causes:
-
name: N
goals:
-
name: G
-
causes:
-
name: M
goals:
-
name: G
-
causes:
-
name: G
goals:
-
name: H
examples/mixed.pl view on Meta::CPAN
#!/usr/bin/perl
#
# forward.pl
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:20:43 PST 15:20:43
use strict;
use warnings;
use Data::Dumper;
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I'],
verbose => 1);
$ai->mixed();
$ai->summary();
inc/Module/Install.pm view on Meta::CPAN
#line 1
package Module::Install;
# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
# 3. The installed version of inc::Module::Install loads
# 4. inc::Module::Install calls "require Module::Install"
# 5. The ./inc/ version of Module::Install loads
# } ELSE {
# 1. Makefile.PL calls "use inc::Module::Install"
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
# 3. The ./inc/ version of Module::Install loads
# }
use 5.005;
use strict 'vars';
use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
# different versions of modules.
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
$VERSION = '0.91';
# Storage for the pseudo-singleton
$MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
END_DIE
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
my $t = time;
if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
}
# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
It was impossible to maintain duel backends, and has been deprecated.
Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
return;
} elsif ( $method =~ /^_/ and $self->can($method) ) {
# Dispatch to the root M:I class
return $self->$method(@_);
}
# Dispatch to the appropriate plugin
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
$self->{admin}->init;
@_ = ($class, _self => $self);
goto &{"$self->{name}::import"};
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
}
my @exts = @{$self->{extensions}};
unless ( @exts ) {
@exts = $self->{admin}->load_all_extensions;
}
my %seen;
foreach my $obj ( @exts ) {
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
next unless $obj->can($method);
next if $method =~ /^_/;
next if $method eq uc($method);
$seen{$method}++;
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
$args{prefix} ||= 'inc';
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
$args{bundle} ||= 'inc/BUNDLES';
$args{base} ||= $base_path;
$class =~ s/^\Q$args{prefix}\E:://;
$args{name} ||= $class;
$args{version} ||= $class->VERSION;
unless ( $args{path} ) {
$args{path} = $args{name};
$args{path} =~ s!::!/!g;
}
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
foreach my $obj (@{$self->{extensions}}) {
return $obj if $obj->can($method);
}
my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
my $obj = $admin->load($method, 1);
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
foreach my $rv ( $self->find_extensions($path) ) {
my ($file, $pkg) = @{$rv};
next if $self->{pathnames}{$pkg};
local $@;
my $new = eval { require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
$self->{pathnames}{$pkg} = delete $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
$pkg = $1;
last;
}
}
}
push @found, [ $file, $pkg ];
}, $path ) if -d $path;
@found;
}
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
$string =~ s/^\n+//s;
return $string;
}
sub _write {
local *FH;
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map {
$_ . '0' x (3 - length $_)
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp ($$) {
_version($_[0]) <=> _version($_[1]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
# Copyright 2008 - 2009 Adam Kennedy.
inc/Module/Install/Base.pm view on Meta::CPAN
#line 1
package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
$VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
BEGIN {
my $w = $SIG{__WARN__};
$SIG{__WARN__} = sub { $w };
}
#line 42
sub new {
my $class = shift;
unless ( defined &{"${class}::call"} ) {
*{"${class}::call"} = sub { shift->_top->call(@_) };
}
unless ( defined &{"${class}::load"} ) {
*{"${class}::load"} = sub { shift->_top->load(@_) };
}
bless { @_ }, $class;
}
#line 61
sub AUTOLOAD {
local $@;
my $func = eval { shift->_top->autoload } or return;
goto &$func;
}
#line 75
sub _top {
$_[0]->{_top};
}
#line 90
sub admin {
$_[0]->_top->{admin}
or
Module::Install::Base::FakeAdmin->new;
}
#line 106
sub is_admin {
$_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
my $fake;
sub new {
$fake ||= bless(\@_, $_[0]);
}
sub AUTOLOAD {}
sub DESTROY {}
# Restore warning handler
BEGIN {
$SIG{__WARN__} = $SIG{__WARN__}->();
}
1;
#line 154
inc/Module/Install/Can.pm view on Meta::CPAN
#line 1
package Module::Install::Can;
use strict;
use Config ();
use File::Spec ();
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
my ($self, $mod, $ver) = @_;
$mod =~ s{::|\\}{/}g;
$mod .= '.pm' unless $mod =~ /\.pm$/i;
my $pkg = $mod;
$pkg =~ s{/}{::}g;
$pkg =~ s{\.pm$}{}i;
local $@;
eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}
# check if we can run some command
sub can_run {
my ($self, $cmd) = @_;
my $_cmd = $cmd;
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
next if $dir eq '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
return;
}
# can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
}
return;
}
# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
require ExtUtils::MM_Cygwin;
require ExtUtils::MM_Win32;
if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
*ExtUtils::MM_Cygwin::maybe_command = sub {
my ($self, $file) = @_;
if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
ExtUtils::MM_Win32->maybe_command($file);
} else {
ExtUtils::MM_Unix->maybe_command($file);
}
}
}
}
1;
__END__
#line 156
inc/Module/Install/Fetch.pm view on Meta::CPAN
#line 1
package Module::Install::Fetch;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub get_file {
my ($self, %args) = @_;
my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
LWP::Simple::mirror($args{url}, $file);
}
elsif (eval { require Net::FTP; 1 }) { eval {
# use Net::FTP to get past firewall
my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
$ftp->login("anonymous", 'anonymous@example.com');
$ftp->cwd($path);
$ftp->binary;
$ftp->get($file) or (warn("$!\n"), return);
$ftp->quit;
} }
elsif (my $ftp = $self->can_run('ftp')) { eval {
# no Net::FTP, fallback to ftp.exe
require FileHandle;
my $fh = FileHandle->new;
local $SIG{CHLD} = 'IGNORE';
unless ($fh->open("|$ftp -n")) {
warn "Couldn't open ftp: $!\n";
chdir $dir; return;
}
my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
foreach (@dialog) { $fh->print("$_\n") }
$fh->close;
} }
else {
warn "No working 'ftp' program available!\n";
chdir $dir; return;
}
unless (-f $file) {
warn "Fetching failed: $@\n";
chdir $dir; return;
}
return if exists $args{size} and -s $file != $args{size};
system($args{run}) if exists $args{run};
unlink($file) if $args{remove};
print(((!exists $args{check_for} or -e $args{check_for})
? "done!" : "failed! ($!)"), "\n");
chdir $dir; return !$?;
}
1;
inc/Module/Install/Makefile.pm view on Meta::CPAN
#line 1
package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
sub Makefile { $_[0] }
my %seen = ();
sub prompt {
shift;
# Infinite loop protection
my @c = caller();
if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
# In automated testing, always use defaults
if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
goto &ExtUtils::MakeMaker::prompt;
}
}
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
%$args = ( %$args, @_ );
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
my $self = sShift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
? join( ' ', $args->{name}, @_ )
: join( ' ', @_ );
}
sub build_subdirs {
my $self = shift;
my $subdirs = $self->makemaker_args->{DIR} ||= [];
for my $subdir (@_) {
push @$subdirs, $subdir;
}
}
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
sub libs {
my $self = shift;
my $libs = ref $_[0] ? shift : [ shift ];
$self->makemaker_args( LIBS => $libs );
}
sub inc {
my $self = shift;
$self->makemaker_args( INC => shift );
}
my %test_dir = ();
sub _wanted_t {
/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
if ( $self->tests ) {
die "tests_recursive will not work if tests are already defined";
}
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
%test_dir = ();
require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
# Check the current Perl version
my $perl_version = $self->perl_version;
if ( $perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
# Make sure we have a new enough MakeMaker
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# MakeMaker can complain about module versions that include
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
$self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
$args->{NO_META} = 1;
}
if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
# Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires, $self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# merge both kinds of requires into prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
delete $prereq->{$file};
}
}
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
}
$args->{INSTALLDIRS} = $self->installdirs;
my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
my $self = shift;
my $makefile_name = shift;
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
my $postamble = "# Postamble by $top_class $top_version\n"
. ($self->postamble || '');
local *MAKEFILE;
open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
my $makefile = do { local $/; <MAKEFILE> };
close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
# Module::Install will never be used to build the Core Perl
# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
1;
}
sub preamble {
my ($self, $text) = @_;
$self->{preamble} = $text . $self->{preamble} if defined $text;
$self->{preamble};
}
sub postamble {
my ($self, $text) = @_;
$self->{postamble} ||= $self->admin->postamble;
$self->{postamble} .= $text if defined $text;
$self->{postamble}
}
1;
__END__
#line 394
inc/Module/Install/Metadata.pm view on Meta::CPAN
#line 1
package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
};
my @scalar_keys = qw{
name
module_name
abstract
author
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
};
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
};
}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} = shift;
return $self;
};
}
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
# Normalize the version
$version = $self->_perl_version($version);
# We don't support the reall old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
$self->{values}->{perl_version} = $version;
}
#Stolen from M::B
my %license_urls = (
perl => 'http://dev.perl.org/licenses/',
apache => 'http://apache.org/licenses/LICENSE-2.0',
artistic => 'http://opensource.org/licenses/artistic-license.php',
artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
my $name = $self->name or die(
"all_from called with no args without setting name() first"
);
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
unless ( -e $file ) {
die("all_from cannot find $file from $name");
}
}
unless ( -f $file ) {
die("The path '$file' does not exist, or is not a file");
}
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
$pod =~ s/\.pm$/.pod/i;
$pod = $file unless -e $pod;
# Pull the different values
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
$self->author_from($pod) unless $self->author;
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
return 1;
}
sub provides {
my $self = shift;
my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
sub auto_provides {
my $self = shift;
return $self unless $self->is_admin;
unless (-e 'MANIFEST') {
warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
return $self;
}
# Avoid spurious warnings as we are not checking manifest here.
local $SIG{__WARN__} = sub {1};
require ExtUtils::Manifest;
local *ExtUtils::Manifest::manicheck = sub { return };
require Module::Build;
my $build = Module::Build->new(
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
sub read {
my $self = shift;
$self->include_deps( 'YAML::Tiny', 0 );
require YAML::Tiny;
my $data = YAML::Tiny::LoadFile('META.yml');
# Call methods explicitly in case user has already set some values.
while ( my ( $key, $value ) = each %$data ) {
next unless $self->can($key);
if ( ref $value eq 'HASH' ) {
while ( my ( $module, $version ) = each %$value ) {
$self->can($key)->($self, $module => $version );
}
} else {
$self->can($key)->($self, $value);
}
}
return $self;
}
sub write {
my $self = shift;
return $self unless $self->is_admin;
$self->admin->write_meta;
return $self;
}
sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->abstract(
bless(
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
);
}
# Add both distribution and module name
sub name_from {
my ($self, $file) = @_;
if (
Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
\s* ;
/ixms
) {
my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
unless ( $self->module_name ) {
$self->module_name($module_name);
}
} else {
die("Cannot determine name from $file\n");
}
}
sub perl_version_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
^
(?:use|require) \s*
v?
([\d_\.]+)
\s* ;
/ixms
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
return;
}
}
sub author_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
if ($content =~ m/
=head \d \s+ (?:authors?)\b \s*
([^\n]*)
|
=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
([^\n]*)
/ixms) {
my $author = $1 || $2;
$author =~ s{E<lt>}{<}g;
$author =~ s{E<gt>}{>}g;
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
sub license_from {
my $self = shift;
if (
Module::Install::_read($_[0]) =~ m/
(
=head \d \s+
(?:licen[cs]e|licensing|copyright|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
\z
/ixms ) {
my $license_text = $1;
my @phrases = (
'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'BSD license' => 'bsd', 1,
'Artistic license' => 'artistic', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
$self->license($license);
return 1;
}
}
}
warn "Cannot determine license info from $_[0]\n";
return 'unknown';
}
sub _extract_bugtracker {
my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
my %links;
@links{@links}=();
@links=keys %links;
return @links;
}
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
}
if ( @links > 1 ) {
warn "Found more than on rt.cpan.org link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
# Numify
$v = $v + 0;
}
return $v;
}
######################################################################
# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
sub write_mymeta_yaml {
my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
sub write_mymeta_json {
my $self = shift;
# We need JSON to write the MYMETA.json file
unless ( eval { require JSON; 1; } ) {
return 1;
}
# Generate the data
my $meta = $self->_write_mymeta_data or return 1;
# Save as the MYMETA.yml file
print "Writing MYMETA.json\n";
Module::Install::_write(
'MYMETA.json',
JSON->new->pretty(1)->canonical->encode($meta),
);
}
sub _write_mymeta_data {
my $self = shift;
# If there's no existing META.yml there is nothing we can do
return undef unless -f 'META.yml';
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
inc/Module/Install/Win32.pm view on Meta::CPAN
#line 1
package Module::Install::Win32;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
require Config;
return unless (
$^O eq 'MSWin32' and
$Config::Config{make} and
$Config::Config{make} =~ /^nmake\b/i and
! $self->can_run('nmake')
);
print "The required 'nmake' executable not found, fetching it...\n";
require File::Basename;
my $rv = $self->get_file(
url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
local_dir => File::Basename::dirname($^X),
size => 51928,
run => 'Nmake15.exe /o > nul',
check_for => 'Nmake.exe',
remove => 1,
);
die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
inc/Module/Install/WriteAll.pm view on Meta::CPAN
#line 1
package Module::Install::WriteAll;
use strict;
use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
$VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
sub WriteAll {
my $self = shift;
my %args = (
meta => 1,
sign => 0,
inline => 0,
check_nmake => 1,
@_,
);
$self->sign(1) if $args{sign};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
$self->makemaker_args( PL_FILES => {} );
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
# we clean it up properly ourself.
$self->realclean_files('MYMETA.yml');
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
if ( $args{meta} ) {
$self->Meta->write;
}
# Experimental support for MYMETA
if ( $ENV{X_MYMETA} ) {
if ( $ENV{X_MYMETA} eq 'JSON' ) {
$self->Meta->write_mymeta_json;
} else {
$self->Meta->write_mymeta_yaml;
}
}
return 1;
}
1;
lib/AI/ExpertSystem/Advanced.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 11/29/2009 18:28:30 CST 18:28:30
package AI::ExpertSystem::Advanced;
=head1 NAME
AI::ExpertSystem::Advanced - Expert System with backward, forward and mixed algorithms
=head1 DESCRIPTION
Inspired in L<AI::ExpertSystem::Simple> but with additional features:
=over 4
=item *
Uses backward, forward and mixed algorithms.
=item *
Offers different views, so user can interact with the expert system via a
terminal or with a friendly user interface.
=item *
The knowledge database can be stored in any format such as YAML, XML or
databases. You just need to choose what driver to use and you are done.
=item *
Uses certainty factors.
=back
=head1 SYNOPSIS
An example of the mixed algorithm:
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I'],
verbose => 1);
$ai->mixed();
$ai->summary();
=cut
use Moose;
use AI::ExpertSystem::Advanced::KnowledgeDB::Base;
use AI::ExpertSystem::Advanced::Viewer::Base;
use AI::ExpertSystem::Advanced::Viewer::Factory;
use AI::ExpertSystem::Advanced::Dictionary;
use Time::HiRes qw(gettimeofday);
use YAML::Syck qw(Dump);
our $VERSION = '0.03';
=head1 Attributes
=over 4
=item B<initial_facts>
A list/set of initial facts the algorithms start using.
During the forward algorithm the task is to find a list of goals caused
by these initial facts (the only data we have in that moment).
Lets imagine your knowledge database is about symptoms and diseases. You need
to find what diseases are caused by the symptoms of a patient, these first
symptons are the initial facts.
Initial facts as also asked and inference facts can be negative or positive. By
default the initial facts are positive.
Keep in mind that the data contained in this array can be the IDs or the name
of the fact.
This array will be converted to L<initial_facts_dict>. And all the data (ids or
or names) will be made of only IDs.
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I', ['F', '-'], ['G', '+']);
As you can see if you want to provide the sign of a fact, just I<encapsulate>
it in an array, the first item should be the fact and the second one the
sign.
=cut
has 'initial_facts' => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub { return []; });
=item B<initial_facts_dict>
This dictionary (see L<AI::ExpertSystem::Advanced::Dictionary> has the sasme
data of L<initial_facts> but with the additional feature(s) of proviing
iterators and a quick way to find elements.
=cut
has 'initial_facts_dict' => (
is => 'ro',
isa => 'AI::ExpertSystem::Advanced::Dictionary');
=item B<goals_to_check>
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
When doing the L<backward()> algorithm it's required to have at least one goal
(aka hypothesis).
This could be pretty similar to L<initial_facts>, with the difference that the
initial facts are used more with the causes of the rules and this one with
the goals (usually one in a well defined knowledge database).
The same rule of L<initial_facts> apply here, you can provide the sign of the
facts and you can provide the id or the name of them.
From our example of symptoms and diseases lets imagine we have the hypothesis
that a patient has flu, we don't know the symptoms it has, we want the
expert system to keep asking us for them to make sure that our hypothesis
is correct (or incorrect in case there's not enough information).
=cut
has 'goals_to_check' => (
is => 'rw',
isa => 'ArrayRef[Str]',
default => sub { return []; });
=item B<goals_to_check_dict>
Very similar to L<goals_to_check> (and indeed of L<initial_facts_dict>). We
want to make the job easier.
It will be a dictionary made of the data of L<goals_to_check>.
=cut
has 'goals_to_check_dict' => (
is => 'ro',
isa => 'AI::ExpertSystem::Advanced::Dictionary');
=item B<inference_facts>
Inference facts are basically the core of an expert system. These are facts
that are found and copied when a set of facts (initial, inference or asked)
match with the causes of a goal.
L<inference_facts> is a L<AI::ExpertSystem::Advanced::Dictionary>, it will
store the name of the fact, the rule that caused these facts to be copied to
this dictionary, the sign and the algorithm that triggered it.
=cut
has 'inference_facts' => (
is => 'ro',
isa => 'AI::ExpertSystem::Advanced::Dictionary');
=item B<knowledge_db>
The object reference of the knowledge database L<AI::ExpertSystem::Advanced> is
using.
=cut
has 'knowledge_db' => (
is => 'rw',
isa => 'AI::ExpertSystem::Advanced::KnowledgeDB::Base',
required => 1);
=item B<asked_facts>
During the L<backward()> algorithm there will be cases when there's no clarity
if a fact exists. In these cases the L<backward()> will be asking the user
(via automation or real questions) if a fact exists.
Going back to the L<initial_facts> example of symptoms and diseases. Imagine
the algorithm is checking a rule, some of the facts of the rule make a match
with the ones of L<initial_facts> or L<inference_facts> but some wont, for
these I<unsure> facts the L<backward()> will ask the user if a symptom (a fact)
exists. All these asked facts will be stored here.
=cut
has 'asked_facts' => (
is => 'ro',
isa => 'AI::ExpertSystem::Advanced::Dictionary');
=item B<visited_rules>
Keeps a record of all the rules the algorithms have visited and also the number
of causes each rule has.
=cut
has 'visited_rules' => (
is => 'ro',
isa => 'AI::ExpertSystem::Advanced::Dictionary');
=item B<verbose>
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['I'],
verbose => 1);
By default this is turned off. If you want to know what happens behind the
scenes turn this on.
Everything that needs to be debugged will be passed to the L<debug()> method
of your L<viewer>.
=cut
has 'verbose' => (
is => 'rw',
isa => 'Bool',
default => 0);
=item B<viewer>
Is the object L<AI::ExpertSystem::Advanced> will be using for printing what is
happening and for interacting with the user (such as asking the
L<asked_facts>).
This is practical if you want to use a viewer object that is not provided by
L<AI::ExpertSystem::Advanced::Viewer::Factory>.
=cut
has 'viewer' => (
is => 'rw',
isa => 'AI::ExpertSystem::Advanced::Viewer::Base');
=item B<viewer_class>
Is the the class name of the L<viewer>.
You can decide to use the viewers L<AI::ExpertSystem::Advanced::Viewer::Factory>
offers, in this case you can pass the object or only the name of your favorite
viewer.
=cut
has 'viewer_class' => (
is => 'rw',
isa => 'Str',
default => 'terminal');
=item B<found_factor>
In your knowledge database you can give different I<weights> to the facts of
each rule (eg to define what facts have more I<priority>). During the
L<mixed()> algorithm it will be checking what causes are found in the
L<inference_facts> and in the L<asked_facts> dictionaries, then the total
number of matches (or total number of certainity factors of each rule) will
be compared versus the value of this factor, if it's higher or equal then the
rule will be triggered.
You can read the documentation of the L<mixed()> algorithm to know the two
ways this factor can be used.
=cut
has 'found_factor' => (
is => 'rw',
isa => 'Num',
default => '0.5');
=item B<shot_rules>
All the rules that are shot are stored here. This is a hash, the key of each
item is the rule id while its value is the precision time when the rule was
shot.
The precision time is useful for knowing when a rule was shot and based on that
you can know what steps it followed so you can compare (or reproduce) them.
=back
=cut
has 'shot_rules' => (
is => 'ro',
isa => 'HashRef[Str]');
=head1 Constants
=over 4
=item * B<FACT_SIGN_NEGATIVE>
Used when a fact is negative, aka, a fact doesn't happen.
=cut
use constant FACT_SIGN_NEGATIVE => '-';
=item * B<FACT_SIGN_POSITIVE>
Used for those facts that happen.
=cut
use constant FACT_SIGN_POSITIVE => '+';
=item * B<FACT_SIGN_UNSURE>
Used when there's no straight answer of a fact, eg, we don't know if an answer
will change the result.
=back
=cut
use constant FACT_SIGN_UNSURE => '~';
=head1 Methods
=head2 B<shoot($rule, $algorithm)>
Shoots the given rule. It will do the following verifications:
=over 4
=item *
Each of the facts (causes) will be compared against the L<initial_facts_dict>,
L<inference_facts> and L<asked_facts> (in this order).
=item *
If any initial, inference or asked fact matches with a cause but it's negative
then all of its goals (usually only one by rule) will be copied to the
L<inference_facts> with a negative sign, otherwise a positive sign will be
used.
=item *
Will add the rule to the L<shot_rules> hash.
=back
=cut
sub shoot {
my ($self, $rule, $algorithm) = @_;
$self->{'shot_rules'}->{$rule} = gettimeofday;
my $rule_causes = $self->get_causes_by_rule($rule);
my $rule_goals = $self->get_goals_by_rule($rule);
my $any_negation = 0;
$rule_causes->populate_iterable_array();
while(my $caused_fact = $rule_causes->iterate) {
# Now, from the current rule fact, any of the facts were marked
# as *negative* from the initial facts, inference or asked facts?
$any_negation = 0;
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
# Also make sure we are going to read from position 0 in our dicts
$self->{$dict}->populate_iterable_array();
while(my $dict_fact = $self->{$dict}->iterate) {
if ($dict_fact eq $caused_fact) {
if ($self->is_fact_negative(
$dict,
$dict_fact)) {
$any_negation = 1;
last;
}
}
}
}
# anything negative?
if ($any_negation) {
last;
}
}
my $sign = ($any_negation) ? FACT_SIGN_NEGATIVE : FACT_SIGN_POSITIVE;
# Copy the goal(s) of this rule to our "initial facts"
$self->copy_to_inference_facts($rule_goals, $sign, $algorithm, $rule);
}
=head2 B<is_rule_shot($rule)>
Verifies if the given C<$rule> has been shot.
=cut
sub is_rule_shot {
my ($self, $rule) = @_;
return defined $self->{'shot_rules'}->{$rule};
}
=head2 B<get_goals_by_rule($rule)>
Will ask the L<knowledge_db> for the goals of the given C<$rule>.
A L<AI::ExpertSystem::Advanced::Dictionary> will be returned.
=cut
sub get_goals_by_rule {
my ($self, $rule) = @_;
return $self->{'knowledge_db'}->rule_goals($rule);
}
=head2 B<get_causes_by_rule($rule)>
Will ask the L<knowledge_db> for the causes of the given C<$rule>.
A L<AI::ExpertSystem::Advanced::Dictionary> will be returned.
=cut
sub get_causes_by_rule {
my ($self, $rule) = @_;
return $self->{'knowledge_db'}->rule_causes($rule);
}
=head2 B<is_fact_negative($dict_name, $fact)>
Will check if the given C<$fact> of the given dictionary (C<$dict_name>) is
negative.
=cut
sub is_fact_negative {
my ($self, $dict_name, $fact) = @_;
my $sign = $self->{$dict_name}->get_value($fact, 'sign');
if (!defined $sign) {
confess "This fact ($fact) does not exists!";
}
return $sign eq FACT_SIGN_NEGATIVE;
}
=head2 B<copy_to_inference_facts($facts, $sign, $algorithm, $rule)>
Copies the given C<$facts> (a dictionary, usually goal(s) of a rule) to the
L<inference_facts> dictionary. All the given goals will be copied with the
given C<$sign>.
Additionally it will add the given C<$algorithm> and C<$rule> to the inference
facts. So later we can know how we got to a certain inference fact.
=cut
sub copy_to_inference_facts {
my ($self, $facts, $sign, $algorithm, $rule) = @_;
while(my $fact = $facts->iterate) {
$self->{'inference_facts'}->append(
$fact,
{
name => $fact,
sign => $sign,
factor => 0.0,
algorithm => $algorithm,
rule => $rule
});
}
}
=head2 B<compare_causes_with_facts($rule)>
Compares the causes of the given C<$rule> with:
=over 4
=item *
Initial facts
=item *
Inference facts
=item *
Asked facts
=back
It will be couting the matches of all of the above dictionaries, so for example
if we have four causes, two make match with initial facts, other with inference
and the remaining one with the asked facts, then it will evaluate to true since
we have a match of the four causes.
=cut
sub compare_causes_with_facts {
my ($self, $rule) = @_;
my $causes = $self->get_causes_by_rule($rule);
my $match_counter = 0;
my $causes_total = $causes->size();
while (my $cause = $causes->iterate) {
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
if ($self->{$dict}->find($cause)) {
$match_counter++;
}
}
}
return $match_counter eq $causes_total;
}
=head2 B<get_causes_match_factor($rule)>
Similar to L<compare_causes_with_facts()> but with the difference that it will
count the L<match factor> of each matched cause and return the total of this
weight.
The match factor is used by the L<mixed()> algorithm and is useful to know if
a certain rule should be shoot or not even if not all of the causes exist
in our facts.
The I<match factor> is calculated in two ways:
=over 4
=item *
Will do a sum of the weight for each matched cause. Please note that if only
one cause of a rule has a specified weight then the remaining causes will
default to the total weight minus 1 and then divided with the total number
of causes (matched or not) that don't have a weight.
=item *
If no weight is found with all the causes of the given rule, then the total
number of matches will be divided by the total number of causes.
=back
=cut
sub get_causes_match_factor {
my ($self, $rule) = @_;
my $causes = $self->get_causes_by_rule($rule);
my $causes_total = $causes->size();
my ($factor_counter, $missing_factor, $match_counter, $nonfactor_match) =
(0, 0, 0, 0);
while (my $cause = $causes->iterate) {
my $factor = $causes->get_value($cause, 'factor');
if (!defined $factor) {
$missing_factor++;
}
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
if ($self->{$dict}->find($cause)) {
$match_counter++;
if (defined $factor) {
$factor_counter = $factor_counter + $factor;
} else {
$nonfactor_match++;
}
}
}
}
# No matches?
if ($match_counter eq 0) {
return 0;
}
# None of the causes (matched or not) have a factor
if ($causes_total eq $missing_factor) {
return $match_counter / $causes_total;
} else { # Some factors found
if ($missing_factor) { # Oh, but some causes don't have it
return $factor_counter + ($nonfactor_match / $causes_total);
} else {
return $factor_counter;
}
}
}
=head2 B<is_goal_in_our_facts($goal)>
Checks if the given C<$goal> is in:
=over 4
=item 1
The initial facts
=item 2
The inference facts
=item 3
The asked facts
=back
=cut
sub is_goal_in_our_facts {
my ($self, $goal) = @_;
foreach my $dict (qw(initial_facts_dict inference_facts asked_facts)) {
if ($self->{$dict}->find($goal)) {
return 1;
}
}
return undef;
}
=head2 B<remove_last_ivisited_rule()>
Removes the last visited rule and return its number.
=cut
sub remove_last_visited_rule {
my ($self) = @_;
my $last = $self->{'visited_rules'}->iterate;
if (defined $last) {
$self->{'visited_rules'}->remove($last);
$self->{'visited_rules'}->populate_iterable_array();
}
return $last;
}
=head2 B<visit_rule($rule, $total_causes)>
Adds the given C<$rule> to the end of the L<visited_rules>.
=cut
sub visit_rule {
my ($self, $rule, $total_causes) = @_;
$self->{'visited_rules'}->prepend($rule,
{
causes_total => $total_causes,
causes_pending => $total_causes
});
$self->{'visited_rules'}->populate_iterable_array();
}
=head2 B<copy_to_goals_to_check($rule, $facts)>
Copies a list of facts (usually a list of causes of a rule) to
L<goals_to_check_dict>.
The rule ID of the goals that are being copied is also stored in the hahs.
=cut
sub copy_to_goals_to_check {
my ($self, $rule, $facts) = @_;
while(my $fact = $facts->iterate_reverse) {
$self->{'goals_to_check_dict'}->prepend(
$fact,
{
name => $fact,
sign => $facts->get_value($fact, 'sign'),
rule => $rule
});
}
}
=head2 B<ask_about($fact)>
Uses L<viewer> to ask the user for the existence of the given C<$fact>.
The valid answers are:
=over 4
=item B<+> or L<FACT_SIGN_POSITIVE>
In case user knows of it.
=item B<-> or L<FACT_SIGN_NEGATIVE>
In case user doesn't knows of it.
=item B<~> or L<FACT_SIGN_UNSURE>
In case user doesn't have any clue about the given fact.
=back
=cut
sub ask_about {
my ($self, $fact) = @_;
# The knowledge db has questions for this fact?
my $question = $self->{'knowledge_db'}->get_question($fact);
if (!defined $question) {
$question = "Do you have $fact?";
}
my @options = qw(Y N U);
my $answer = $self->{'viewer'}->ask($question, @options);
return $answer;
}
=head2 B<get_rule_by_goal($goal)>
Looks in the L<knowledge_db> for the rule that has the given goal. If a rule
is found its number is returned, otherwise undef.
=cut
sub get_rule_by_goal {
my ($self, $goal) = @_;
return $self->{'knowledge_db'}->find_rule_by_goal($goal);
}
=head2 B<forward()>
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
initial_facts => ['F', 'J']);
$ai->forward();
$ai->summary();
The forward chaining algorithm is one of the main methods used in Expert
Systems. It starts with a set of variables (known as initial facts) and reads
the available rules.
It will be reading rule by rule and for each one it will compare its causes
with the initial, inference and asked facts. If all of these causes are in the
facts then the rule will be shoot and all of its goals will be copied/converted
to inference facts and will restart reading from the first rule.
=cut
sub forward {
my ($self) = @_;
confess "Can't do forward algorithm with no initial facts" unless
$self->{'initial_facts_dict'};
my ($more_rules, $current_rule) = (1, undef);
while($more_rules) {
$current_rule = $self->{'knowledge_db'}->get_next_rule($current_rule);
# No more rules?
if (!defined $current_rule) {
$self->{'viewer'}->debug("We are done with all the rules, bye")
if $self->{'verbose'};
$more_rules = 0;
last;
}
$self->{'viewer'}->debug("Checking rule: $current_rule") if
$self->{'verbose'};
if ($self->is_rule_shot($current_rule)) {
$self->{'viewer'}->debug("We already shot rule: $current_rule")
if $self->{'verbose'};
next;
}
$self->{'viewer'}->debug("Reading rule $current_rule")
if $self->{'verbose'};
$self->{'viewer'}->debug("More rules to check, checking...")
if $self->{'verbose'};
my $rule_causes = $self->get_causes_by_rule($current_rule);
# any of our rule facts match with our facts to check?
if ($self->compare_causes_with_facts($current_rule)) {
# shoot and start again
$self->shoot($current_rule, 'forward');
# Undef to start reading from the first rule.
$current_rule = undef;
next;
}
}
return 1;
}
=head2 B<backward()>
use AI::ExpertSystem::Advanced;
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
my $ai = AI::ExpertSystem::Advanced->new(
viewer_class => 'terminal',
knowledge_db => $yaml_kdb,
goals_to_check => ['J']);
$ai->backward();
$ai->summary();
The backward algorithm starts with a set of I<assumed> goals (facts). It will
start reading goal by goal. For each goal it will check if it exists in the
initial, inference and asked facts (see L<is_goal_in_our_facts()>) for more
information).
=over 4
=item *
If the goal exist then it will be removed from the dictionary, it will also
verify if there are more visited rules to shoot.
If there are still more visited rules to shoot then it will check from what
rule the goal comes from, if it was copied from a rule then this data will
exist. With this information then it will see how many of the causes of this
given rule are still in the L<goals_to_check_dict>.
In case there are still causes of this rule in L<goals_to_check_dict> then the
amount of causes pending will be reduced by one. Otherwise (if the amount is
0) then the rule of this last removed goal will be shoot.
=item *
If the goal doesn't exist in the mentioned facts then the goal will be searched
in the goals of every rule.
In case it finds the rule that has the goal, this rule will be marked (added)
to the list of visited rules (L<visited_rules>) and also all of its causes
will be added to the top of the L<goals_to_check_dict> and it will start
reading again all the goals.
If there's the case where the goal doesn't exist as a goal in the rules then
it will ask the user (via L<ask_about()>) for the existence of it. If user is
not sure about it then the algorithm ends.
=back
=cut
sub backward {
my ($self) = @_;
my ($more_goals, $current_goal, $total_goals) = (
1,
0,
scalar(@{$self->{'goals_to_check'}}));
WAIT_FOR_MORE_GOALS: while($more_goals) {
READ_GOAL: while(my $goal = $self->{'goals_to_check_dict'}->iterate) {
if ($self->is_goal_in_our_facts($goal)) {
$self->{'viewer'}->debug("The goal $goal is in our facts")
if $self->{'debug'};
# Matches with any visiited rule?
my $rule_no = $self->{'goals_to_check_dict'}->get_value(
$goal, 'rule');
# Take out this goal so we don't end with an infinite loop
$self->{'viwer'}->debug("Removing $goal from goals to check")
if $self->{'debug'};
$self->{'goals_to_check_dict'}->remove($goal);
# Update the iterator
$self->{'goals_to_check_dict'}->populate_iterable_array();
# no more goals, what about rules?
if ($self->{'visited_rules'}->size() eq 0) {
$self->{'viewer'}->debug("No more goals to read")
if $self->{'verbose'};
$more_goals = 0;
next WAIT_FOR_MORE_GOALS;
}
if (defined $rule_no) {
my $causes_total = $self->{'visited_rules'}->get_value(
$rule_no, 'causes_total');
my $causes_pending = $self->{'visited_rules'}->get_value(
$rule_no, 'causes_pending');
if (defined $causes_total and defined $causes_pending) {
# No more pending causes for this rule, lets shoot it
if ($causes_pending-1 le 0) {
my $last_rule = $self->remove_last_visited_rule();
if ($last_rule eq $rule_no) {
$self->{'viewer'}->debug("Going to shoot $last_rule")
if $self->{'debug'};
$self->shoot($last_rule, 'backward');
} else {
$self->{'viewer'}->print_error(
"Seems the rule ($rule_no) of goal " .
"$goal is not the same as the last " .
"visited rule ($last_rule)");
$more_goals = 0;
next WAIT_FOR_MORE_GOALS;
}
} else {
$self->{'visited_rules'}->update($rule_no,
{
causes_pending => $causes_pending-1
});
}
}
}
# How many objetives we have? if we are zero then we are done
if ($self->{'goals_to_check_dict'}->size() lt 0) {
$more_goals = 0;
} else {
$more_goals = 1;
}
# Re verify if there are more goals to check
next WAIT_FOR_MORE_GOALS;
} else {
# Ugh, the fact is not in our inference facts or asked facts,
# well, lets find the rule where this fact belongs
my $rule_of_goal = $self->get_rule_by_goal($goal);
if (defined $rule_of_goal) {
$self->{'viewer'}->debug("Found a rule with $goal as a goal")
if $self->{'debug'};
# Causes of this rule
my $rule_causes = $self->get_causes_by_rule($rule_of_goal);
# Copy the causes of this rule to our goals to check
$self->copy_to_goals_to_check($rule_of_goal, $rule_causes);
# We just *visited* this rule, lets check it
$self->visit_rule($rule_of_goal, $rule_causes->size());
# and yes.. we have more goals to check!
$self->{'goals_to_check_dict'}->populate_iterable_array();
$more_goals = 1;
next WAIT_FOR_MORE_GOALS;
} else {
# Ooops, lets ask about this
# We usually get to this case when any of the copied causes
# does not exists as a goal in any of the rules
my $answer = $self->ask_about($goal);
if (
$answer eq FACT_SIGN_POSITIVE or
$answer eq FACT_SIGN_NEGATIVE) {
$self->{'asked_facts'}->append($goal,
{
name => $goal,
sign => $answer,
algorithm => 'backward'
});
} else {
$self->{'viewer'}->debug(
"Don't know of $goal, nothing else to check"
);
return 0;
}
$self->{'goals_to_check_dict'}->populate_iterable_array();
$more_goals = 1;
next WAIT_FOR_MORE_GOALS;
}
}
}
}
return 1;
}
=head2 B<mixed()>
As its name says, it's a mix of L<forward()> and L<backward()> algorithms, it
requires to have at least one initial fact.
The first thing it does is to run the L<forward()> algorithm (hence the need of
at least one initial fact). If the algorithm fails then the mixed algorithm
also ends unsuccessfully.
Once the first I<run> of L<forward()> algorithm happens it starts looking for
any positive inference fact, if only one is found then this ends the algorithm
with the assumption it knows what's happening.
In case no positive inference fact is found then it will start reading the
rules and creating a list of intuitive facts.
For each rule it will get a I<certainty factor> of its causes versus the
initial, inference and asked facts. In case the certainity factor is greater or
equal than L<found_factor> then all of its goals will be copied to the
intuitive facts (eg, read it as: it assumes the goals have something to do with
our first initial facts).
Once all the rules are read then it verifies if there are intuitive facts, if
no facts are found then it ends with the intuition, otherwise it will run the
L<backward()> algorithm for each one of these facts (eg, each fact will be
converted to a goal). After each I<run> of the L<backward()> algorithm it will
verify for any positive inference fact, if just one is found then the algorithm
ends.
At the end (if there are still no positive inference facts) it will run the
L<forward()> algorithm and restart (by looking again for any positive inference
fact).
A good example to understand how this algorithm is useful is: imagine you are
a doctor and know some of the symptoms of a patient. Probably with the first
symptoms you have you can get to a positive conclusion (eg that a patient has
I<X> disease). However in case there's still no clue, then a set of questions
(done by the call of L<backward()>) of symptons related to the initial symptoms
will be asked to the user. For example, we know that that the patient has a
headache but that doesn't give us any positive answer, what if the patient has
flu or another disease? Then a set of these I<related> symptons will be asked
to the user.
=cut
sub mixed {
my ($self) = @_;
if (!$self->forward()) {
$self->{'viewer'}->print_error("The first execution of forward failed");
return 0;
}
use Data::Dumper;
while(1) {
# We are satisfied if only one inference fact is positive (eg, means we
# got to our result)
while(my $fact = $self->{'inference_facts'}->iterate) {
my $sign = $self->{'inference_facts'}->get_value($fact, 'sign');
if ($sign eq FACT_SIGN_POSITIVE) {
$self->{'viewer'}->debug(
"We are done, a positive fact was found"
);
return 1;
}
}
my $intuitive_facts = AI::ExpertSystem::Advanced::Dictionary->new(
stack => []);
my ($more_rules, $current_rule) = (1, undef);
while($more_rules) {
$current_rule = $self->{'knowledge_db'}->get_next_rule($current_rule);
# No more rules?
if (!defined $current_rule) {
$self->{'viewer'}->debug("We are done with all the rules, bye")
if $self->{'verbose'};
$more_rules = 0;
last;
}
# Wait, we already shot this rule?
if ($self->is_rule_shot($current_rule)) {
$self->{'viewer'}->debug("We already shot rule: $current_rule")
if $self->{'verbose'};
next;
}
my $factor = $self->get_causes_match_factor($current_rule);
if ($factor ge $self->{'found_factor'} && $factor lt 1.0) {
# Copy all of the goals (usually only one) of the current rule to
# the intuitive facts
my $goals = $self->get_goals_by_rule($current_rule);
while(my $goal = $goals->iterate_reverse) {
$intuitive_facts->append($goal,
{
name => $goal,
sign => $goals->get_value($goal, 'sign')
});
}
}
}
if ($intuitive_facts->size() eq 0) {
$self->{'viewer'}->debug("Done with intuition") if
$self->{'verbose'};
return 1;
}
$intuitive_facts->populate_iterable_array();
# now each intuitive fact will be a goal
while(my $fact = $intuitive_facts->iterate) {
$self->{'goals_to_check_dict'}->append(
$fact,
{
name => $fact,
sign => $intuitive_facts->get_value($fact, 'sign')
});
$self->{'goals_to_check_dict'}->populate_iterable_array();
print "Running backward for $fact\n";
if (!$self->backward()) {
$self->{'viewer'}->debug("Backward exited");
return 1;
}
# Now we have inference facts, anything positive?
$self->{'inference_facts'}->populate_iterable_array();
while(my $inference_fact = $self->{'inference_facts'}->iterate) {
my $sign = $self->{'inference_facts'}->get_value(
$inference_fact, 'sign');
if ($sign eq FACT_SIGN_POSITIVE) {
$self->{'viewer'}->print(
"Done, a positive inference fact found"
);
return 1;
}
}
}
$self->forward();
}
}
=head2 B<summary($return)>
The main purpose of any expert system is the ability to explain: what is
happening, how it got to a result, what assumption(s) it required to make,
the fatcs that were excluded and the ones that were used.
This method will use the L<viewer> (or return the result) in YAML format of all
the rules that were shot. It will explain how it got to each one of the causes
so a better explanation can be done by the L<viewer>.
If C<$return> is defined (eg, it got any parameter) then the result wont be
passed to the L<viewer>, instead it will be returned as a string.
=cut
sub summary {
my ($self, $return) = @_;
# any facts we found via inference?
if (scalar @{$self->{'inference_facts'}->{'stack'}} eq 0) {
$self->{'viewer'}->print_error("No inference was possible");
} else {
my $summary = {};
# How the rules started being shot?
my $order = 1;
# So, what rules we shot?
foreach my $shot_rule (sort(keys %{$self->{'shot_rules'}})) {
$summary->{'rules'}->{$shot_rule} = {
order => $order,
};
$order++;
# Get the causes and goals of this rule
my $causes = $self->get_causes_by_rule($shot_rule);
$causes->populate_iterable_array();
while(my $cause = $causes->iterate) {
# How we got to this cause? Is it an initial fact,
# an inference fact? or by forward algorithm?
my ($method, $sign, $algorithm);
if ($self->{'asked_facts'}->find($cause)) {
$method = 'Question';
$sign = $self->{'asked_facts'}->get_value($cause, 'sign');
$algorithm = $self->{'asked_facts'}->get_value($cause, 'algorithm');
} elsif ($self->{'inference_facts'}->find($cause)) {
$method = 'Inference';
$sign = $self->{'inference_facts'}->get_value($cause, 'sign');
$algorithm = $self->{'inference_facts'}->get_value($cause, 'algorithm');
} elsif ($self->{'initial_facts_dict'}->find($cause)) {
$method = 'Initial';
$sign = $self->{'initial_facts_dict'}->get_value($cause, 'sign');
} else {
$method = 'Forward';
$sign = $causes->get_value($cause, 'sign');
}
$summary->{'rules'}->{$shot_rule}->{'causes'}->{$cause} = {
method => $method,
sign => $sign,
algorithm => $algorithm,
};
}
my $goals = $self->get_goals_by_rule($shot_rule);
$goals->populate_iterable_array();
while(my $goal = $goals->iterate) {
# We got to this goal by asking the user of it? or by
# "natural" backward algorithm?
my ($method, $sign, $algorithm);
if ($self->{'asked_facts'}->find($goal)) {
$method = 'Question';
$sign = $self->{'asked_facts'}->get_value($goal, 'sign');
} elsif ($self->{'inference_facts'}->find($goal)) {
$method = 'Inference';
$sign = $self->{'inference_facts'}->get_value($goal, 'sign');
$algorithm = $self->{'inference_facts'}->get_value($goal, 'algorithm');
} else {
$method = 'Backward';
$sign = $goals->get_value($goal, 'sign');
}
$summary->{'rules'}->{$shot_rule}->{'goals'}->{$goal} = {
method => $method,
sign => $sign,
algorithm => $algorithm,
}
}
}
my $yaml_summary = Dump($summary);
if (defined $return) {
return $yaml_summary;
} else {
$self->{'viewer'}->explain($yaml_summary);
}
}
}
# No need to document this, this is an *internal* Moose method, used when an
# instance of the class has been created and all the verifications (of valid
# parameters) have been done.
sub BUILD {
my ($self) = @_;
if (!defined $self->{'viewer'}) {
if (defined $self->{'viewer_class'}) {
$self->{'viewer'} = AI::ExpertSystem::Advanced::Viewer::Factory->new(
$self->{'viewer_class'});
} else {
confess "Sorry, provide a viewer or a viewer_class";
}
}
$self->{'initial_facts_dict'} = AI::ExpertSystem::Advanced::Dictionary->new(
stack => $self->{'initial_facts'});
$self->{'inference_facts'} = AI::ExpertSystem::Advanced::Dictionary->new;
$self->{'asked_facts'} = AI::ExpertSystem::Advanced::Dictionary->new;
$self->{'goals_to_check_dict'} = AI::ExpertSystem::Advanced::Dictionary->new(
stack => $self->{'goals_to_check'});
$self->{'visited_rules'} = AI::ExpertSystem::Advanced::Dictionary->new(
stack => []);
}
=head1 SEE ALSO
Take a look L<AI::ExpertSystem::Simple> too.
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/Dictionary.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::Dictionary
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 11/29/2009 20:06:22 CST 20:06:22
package AI::ExpertSystem::Advanced::Dictionary;
=head1 NAME
AI::ExpertSystem::Advanced::Dictionary - Array/hash dictionary
=head1 DESCRIPTION
The dictionary offers a unified interface for:
=over 4
=item 1
Reading through a list of items with a minimal use of memory since it offers an
iterator that works with a stack. So everytime it gets asked for the next
element it I<drops> the first or last element of the stack.
=item 2
Finding an element in the stack.
=item 3
Adding or removing elements from the stack.
=back
=cut
use Moose;
use List::MoreUtils qw(firstidx);
our $VERSION = '0.03';
=head1 Attributes
=over 4
=item B<stack>
An array with all the keys of C<stack_hash>. Useful for creating the
C<iterable_array> and for knowing the order of the items as they get added or
removed.
=cut
has 'stack' => (
is => 'rw',
isa => 'ArrayRef');
=item B<stack_hash>
The original hash, has all the elements with all their properties (eg extra
keys). The I<disadvantage> of it is that it doesn't keeps the order of the
elements, hence the need of C<stack>.
=cut
has 'stack_hash' => (
is => 'ro',
isa => 'HashRef[Str]');
=item B<iterable_array>
Used by the C<iterate()> and C<iterate_reverse()> methods. It starts as a copy
of C<stack> and as the iterate methods start running this array starts getting
I<reduced> until it gets to an empty list.
=back
=cut
has 'iterable_array' => (
is => 'ro',
isa => 'ArrayRef');
=head1 Methods
=head2 B<find($look_for, $find_by)>
Looks for a given value (C<$look_for>). By default it will look for the value
by reading the C<id> of each item, however this can be changed by passing
a different hash key (C<$find_by>).
In case there's no match C<undef> is returned.
=cut
sub find {
my ($self, $look_for, $find_by) = @_;
if (!defined($find_by)) {
if (defined $self->{'stack_hash'}->{$look_for}) {
return $look_for;
}
return undef;
}
foreach my $key (keys %{$self->{'stack_hash'}}) {
if ($self->{'stack_hash'}->{$key}->{$find_by} eq $look_for) {
return $key;
}
}
return undef;
}
=head2 B<get_value($id, $key)>
The L<AI::ExpertSystem::Advanced::Dictionary> consists of a hash of elements,
each element has its own properties (eg, extra keys).
This method looks for the value of the given C<$key> of a given element C<id>.
It will return the value, but if element doesn't have the given C<$key> then
C<undef> will be returned.
=cut
sub get_value {
my ($self, $id, $key) = @_;
if (!defined $self->{'stack_hash'}->{$id}) {
return undef;
}
if (defined $self->{'stack_hash'}->{$id}->{$key}) {
return $self->{'stack_hash'}->{$id}->{$key};
} else {
return undef;
}
}
=head2 B<append($id, %extra_keys)>
Adds a new element to the C<stack_hash> and C<stack>. The element gets added to
the end of C<stack>.
The C<$id> parameter specifies the id of the new element and the next parameter
is a stack of I<extra> keys.
=cut
sub append {
my $self = shift;
my $id = shift;
return $self->_add($id, undef, @_);
}
=head2 B<prepend($id, %extra_keys)>
Same as C<append()>, but the element gets added to the top of the C<stack>.
=cut
sub prepend {
my $self = shift;
my $id = shift;
return $self->_add($id, 1, @_);
}
=head2 B<update($id, %extra_keys)>
Updates the I<extra> keys of the element that matches the given C<$id>.
Please note that it will only update or add new keys. So if the given element
already has a key and this is not provided in C<%extra_keys> then it wont
be modified.
=cut
sub update {
my ($self, $id, $properties) = @_;
if (defined $self->{'stack_hash'}->{$id}) {
foreach my $key (keys %$properties) {
$self->{'stack_hash'}->{$id}->{$key} = $properties->{$key};
}
} else {
warn "Not updating $id, does not exist!";
}
}
=head2 B<remove($id)>
Removes the element that matches the given C<$id> from C<stack_hash> and
C<stack>.
Returns true if the removal is successful, otherwise false is returned.
=cut
sub remove {
my ($self, $id) = @_;
if (defined $self->{'stack_hash'}->{$id}) {
delete($self->{'stack_hash'}->{$id});
# Find the index in the array, lets suppose our arrays are big
my $index = List::MoreUtils::first_index {
defined $_ and $_ eq $id
} @{$self->{'stack'}};
splice(@{$self->{'stack'}}, $index, 1);
return 1;
}
return 0;
}
=head2 B<size()>
Returns the size of C<stack>.
=cut
sub size {
my ($self) = @_;
return scalar(@{$self->{'stack'}});
}
=head2 B<iterate()>
Returns the first element of the C<iterable_array> and C<iterable_array> is
reduced by one.
If no more items are found in C<iterable_array> then C<undef> is returned.
=cut
sub iterate {
my ($self) = @_;
return shift(@{$self->{'iterable_array'}});
}
=head2 B<iterate_reverse()>
Same as C<iterate()>, but instead of returning the first element, it returns
the last element of C<iterable_array>.
=cut
sub iterate_reverse {
my ($self) = @_;
return pop(@{$self->{'iterable_array'}});
}
=head2 B<populate_iterable_array()>
The C<iterable_array> gets populated when a dictionary instance is created,
however if new items are added or removed then it's B<extremely> needed to call
this method so C<iterable_array> gets populated again.
=cut
sub populate_iterable_array {
my ($self) = @_;
@{$self->{'iterable_array'}} = @{$self->{'stack'}};
}
# No need to document it, used by L<Moose>.
sub BUILD {
my ($self) = @_;
foreach (@{$self->{'stack'}}) {
if (ref($_) eq 'ARRAY') {
$self->{'stack_hash'}->{$_->[0]} = {
name => $_->[0],
sign => $_->[1]
};
} else {
$self->{'stack_hash'}->{$_} = {
name => $_,
sign => '+'
};
}
}
$self->populate_iterable_array();
}
################# Private methods ######################
sub _add {
my ($self, $id, $prepend, $properties) = @_;
$self->{'stack_hash'}->{$id} = $properties;
if ($prepend) {
unshift(@{$self->{'stack'}}, $id);
} else {
push(@{$self->{'stack'}}, $id);
}
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Base.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::KnowledgeDB::Base
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 11/29/2009 19:14:28 PST 19:14:28
package AI::ExpertSystem::Advanced::KnowledgeDB::Base;
=head1 NAME
AI::ExpertSystem::Advanced::KnowledgeDB::Base - Base class for knowledge DBs.
=head1 DESCRIPTION
All knowledge databases that L<AI::ExpertSystem::Advanced> uses should extend
from this class.
This base class implements the basic methods required for extracting the rules,
causes, goals and questions from the a plain text knowledge database, eg, all
the records remain in the application memory instead of a database engine such
as MySQL or SQLite.
=cut
use Moose;
use AI::ExpertSystem::Advanced::Dictionary;
our $VERSION = '0.03';
=head1 Attributes
=over 4
=item B<rules>
This hash has the rules contained in the knowledge database. It's populated
when an instance of L<AI::ExpertSystem::Advanced::KnowledgeDB::Base> is
created.
B<TIP>: There's no sense in filling this hash if you are going to be using a
database engine such as MySQL, SQLite or others. The hash is useful if your
knowledge database will remain in application memory.
=cut
has 'rules' => (
is => 'ro',
isa => 'HashRef');
=item B<questions>
Similar and same concept of C<rules>, but this will have a list (if available)
of what questions should be done to certain facts.
=back
=cut
has 'questions' => (
is => 'ro',
isa => 'HashRef',
default => sub { return {}; });
=head1 Methods
=head2 B<read()>
This method reads the knowledge database. This is the only method you need to
define even if you are going to load the database in memory or if you are
going to query it.
=cut
sub read {
confess "You can't call KnowedgeDB::Base! (abstract method)";
}
=head2 B<rule_goals($rule)>
Returns all the goals (usually only one) of the given C<$rule>.
The goals B<should> be returned as a L<AI::ExpertSystem::Advanced::Dictionary>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub rule_goals {
my ($self, $rule) = @_;
if (!defined $self->{'rules'}->[$rule]) {
confess "Rule $rule does not exist";
}
my @facts;
# Get all the facts of this goal (usually only one)
foreach (@{$self->{'rules'}->[$rule]->{'goals'}}) {
my $id;
# it has an ID?
if (defined $_->{'id'}) {
$id = $_->{'id'};
} elsif (defined $_->{'name'}) { # or a name?
$id = $_->{'name'};
}
if (defined $id) {
push(@facts, $id);
} else {
confess "Seems rule $rule does not have an id or name key";
}
}
my $goals_dict = AI::ExpertSystem::Advanced::Dictionary->new(
stack => \@facts);
return $goals_dict;
}
=head2 B<rule_causes($rule)>
Returns all the causes of the given C<$rule>.
Same as C<rule_goals()>, the causes should be returned as a
L<AI::ExpertSystem::Advanced::Dictionary>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub rule_causes {
my ($self, $rule) = @_;
if (!defined $self->{'rules'}->[$rule]) {
confess "Rule $rule does not exist";
}
my @facts;
# Get all the facts of this cause
foreach (@{$self->{'rules'}->[$rule]->{'causes'}}) {
my $id;
# it has an ID?
if (defined $_->{'id'}) {
$id = $_->{'id'};
} elsif (defined $_->{'name'}) { # or a name?
$id = $_->{'name'};
}
if (defined $id) {
push(@facts, $id);
} else {
confess "Seems rule $rule does not have an id or name key";
}
}
my $causes_dict = AI::ExpertSystem::Advanced::Dictionary->new(
stack => \@facts);
return $causes_dict;
}
=head2 B<find_rule_by_goal($goal)>
Looks for the first rule that has the given C<goal> in its goals.
If a rule is found then its number is returned, otherwise C<undef> is
returned.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub find_rule_by_goal {
my ($self, $goal) = @_;
my $rule_counter = 0;
foreach my $rule (@{$self->{'rules'}}) {
foreach my $rule_goal (@{$rule->{'goals'}}) {
# Look in id and name for the match
foreach my $look_in (qw(id name)) {
if (defined $rule_goal->{$look_in}) {
if ($rule_goal->{$look_in} eq $goal) {
return $rule_counter;
}
}
}
}
$rule_counter++;
}
return undef;
}
=head2 B<get_question($fact)>
Looks for a question about the given C<$fact>. If a question exists then this is
returned, otherwise C<undef> is returned.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub get_question {
my ($self, $fact) = @_;
if (defined $self->{'questions'}->{$fact}) {
return $self->{'questions'}->{$fact};
}
return undef;
}
=head2 B<get_next_rule($current_rule)>
Returns the ID of the next rule. When there are no more rules to work then
C<undef> should be returned.
When it starts looking for the first rule, C<$current_rule> value will
be C<undef>.
B<NOTE>: Rewrite this method if you are not going to use the C<rules> hash (eg,
you will use a database engine).
=cut
sub get_next_rule {
my ($self, $current_rule) = @_;
my $next_rule;
if (defined $current_rule) {
$next_rule = $current_rule+1;
} else {
$next_rule = 0;
}
if (defined $self->{'rules'}->[$next_rule]) {
return $next_rule;
} else {
return undef;
}
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/KnowledgeDB/Factory.pm view on Meta::CPAN
#
# AI::ExpertSystem::KnowledgeDB::Factory
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 11/29/2009 19:12:25 PST 19:12:25
package AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
=head1 NAME
AI::ExpertSystem::Advanced::KnowledgeDB::Factory - Knowledge DB driver factory
=head1 DESCRIPTION
Uses the factory pattern to create instances of knowledge database drivers.
=head1 SYNOPSIS
use AI::ExpertSystem::Advanced::KnowledgeDB::Factory;
my $yaml_kdb = AI::ExpertSystem::Advanced::KnowledgeDB::Factory->new('yaml',
{
filename => 'examples/knowledge_db_one.yaml'
});
=cut
use strict;
use warnings;
use Class::Factory;
use base qw(Class::Factory);
our $VERSION = '0.02';
sub new {
my ($pkg, $type, @params) = @_;
my $class = $pkg->get_factory_class($type);
return undef unless ($class);
my $self = "$class"->new(@params);
return $self;
}
__PACKAGE__->register_factory_type(yaml =>
'AI::ExpertSystem::Advanced::KnowledgeDB::YAML');
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/KnowledgeDB/YAML.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::KnowledgeDB::YAML
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 16:12:43 PST 16:12:43
package AI::ExpertSystem::Advanced::KnowledgeDB::YAML;
=head1 NAME
AI::ExpertSystem::Advanced::KnowledgeDB::YAML - YAML Knowledge DB driver
=head1 DESCRIPTION
A YAML knowledge database driver.
It reads a given YAML file and looks for the I<rules> hash key. All of the
elements of C<rules> (causes and goals) are copied to the C<rules> hash
key of L<AI::ExpertSystem::Advanced::KnowledgeDB::Base>.
If no rules are found then it ends unsuccessfully.
It also looks for any available questions under the I<questions> hash key,
however if no questions are found then they are not copied :-)
=cut
use Moose;
use YAML::Syck;
extends 'AI::ExpertSystem::Advanced::KnowledgeDB::Base';
our $VERSION = '0.01';
=head1 Attributes
=over 4
=item B<filename>
YAML file path to read
=back
=cut
has 'filename' => (
is => 'rw',
isa => 'Str',
required => 1);
# Called when the object gets created
sub BUILD {
my ($self) = @_;
my $data = LoadFile($self->{'filename'});
if (defined $data->{'rules'}) {
$self->{'rules'} = $data->{'rules'}
} else {
confess "Couldn't find any rules in $self->{'filename'}";
}
if (defined $data->{'questions'}) {
$self->{'questions'} = $data->{'questions'};
}
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/Viewer/Base.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::Viewer::Base
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:23:47 PST 15:23:47
package AI::ExpertSystem::Advanced::Viewer::Base;
=head1 NAME
AI::ExpertSystem::Advanced::Viewer::Base - Base class for all views.
=head1 DESCRIPTION
All views that L<AI::ExpertSystem::Advanced> can use should extend from this
class (or from parents that extend from it).
Please note that the methods of this class should not be called in an abstract
context cause otherwise L<AI::ExpertSystem::Advanced> will die.
=cut
use Moose;
our $VERSION = '0.02';
use constant NO_ABSTRACT_CLASS_MSG =>
qq#Sorry, you can't call the abstract class!#;
=head2 B<debug($msg)>
Will be used to debug any task done by L<AI::ExpertSystem::Advanced>. It only
receives one parameter that is the message to print.
=cut
sub debug {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<print($msg)>
Will be used to print anything that is not a debug messages. It only receives
one parameter that is the message to print.
=cut
sub print {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<print_error($msg)>
Will be used to print any error of L<AI::ExpertSystem::Advanced>. It only
receives one parameter that is the message to print.
=cut
sub print_error {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<ask($message, @options)>
Will be used to ask the user for some information. It will receive a string,
the question to ask and an array of all the possible options.
Please return only one option and this should be any of the ones listed in
C<@options> cause otherwise L<AI::ExpertSystem::Advanced> will die.
=cut
sub ask {
confess NO_ABSTRACT_CLASS_MSG;
}
=head2 B<explain($yaml_summary)>
Used to explain what happened. The passed argument is a YAML string that has
all the information required to make a good explanation.
=cut
sub explain {
confess NO_ABSTRACT_CLASS_MSG;
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/Viewer/Factory.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::Viewer::Factory
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 11/29/2009 19:12:25 PST 19:12:25
package AI::ExpertSystem::Advanced::Viewer::Factory;
=head1 NAME
AI::ExpertSystem::Advanced::Viewer::Factory - Viewer factory
=head1 DESCRIPTION
Uses the factory pattern to create viewer instances. The viewer instances are
useful (and required) to show data to the user.
=cut
use strict;
use warnings;
use Class::Factory;
use base qw(Class::Factory);
our $VERSION = '0.01';
sub new {
my ($pkg, $type, @params) = @_;
my $class = $pkg->get_factory_class($type);
return undef unless ($class);
my $self = "$class"->new(@params);
return $self;
}
__PACKAGE__->register_factory_type(terminal =>
'AI::ExpertSystem::Advanced::Viewer::Terminal');
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
lib/AI/ExpertSystem/Advanced/Viewer/Terminal.pm view on Meta::CPAN
#
# AI::ExpertSystem::Advanced::Viewer::Terminal
#
# Author(s): Pablo Fischer (pfischer@cpan.org)
# Created: 12/13/2009 15:44:23 PST 15:44:23
package AI::ExpertSystem::Advanced::Viewer::Terminal;
=head1 NAME
AI::ExpertSystem::Advanced::Viewer::Terminal - Viewer for terminal
=head1 DESCRIPTION
Extends from L<AI::ExpertSystem::Advanced::Viewer::Base> and its main purpose is
to interact with a (console) terminal.
=cut
use Moose;
use Term::UI;
use Term::ReadLine;
extends 'AI::ExpertSystem::Advanced::Viewer::Base';
our $VERSION = '0.02';
=head1 Attribtes
=over 4
=item B<readline>
A L<Term::ReadLine> instance.
=back
=cut
has 'readline' => (
is => 'ro',
isa => 'Term::ReadLine');
=head1 Methods
=head2 B<debug($msg)>
Basically just prints the given C<$msg> but prepends the "DEBUG" string to it.
=cut
sub debug {
my ($self, $msg) = @_;
print "DEBUG: $msg\n";
}
=head2 B<print($msg)>
Simply prints the given C<$msg>.
=cut
sub print {
my ($self, $msg) = @_;
print "$msg\n";
}
=head2 B<print_error($msg)>
Will prepend the "ERROR:" word to the given message and then will call
C<print()>.
=cut
sub print_error {
my ($self, $msg) = @_;
$self->print("ERROR: $msg");
}
=head2 B<ask($message, @options)>
Will be used to ask the user for some information. It will receive a string,
the question to ask and an array of all the possible options.
=cut
sub ask {
my ($self, $msg, $options) = @_;
my %valid_choices = (
'Y' => '+',
'N' => '-',
'U' => '~');
my $reply = $self->{'readline'}->get_reply(
prompt => $msg . ' ',
choices => [qw|Y N U|]);
return $valid_choices{$reply};
}
=head2 B<explain($yaml_summary)>
Explains what happened.
=cut
sub explain {
my ($self, $summary) = @_;
print $summary;
}
# Called when the object is created
sub BUILD {
my ($self) = @_;
$self->{'readline'} = Term::ReadLine->new('questions');
}
=head1 AUTHOR
Pablo Fischer (pablo@pablo.com.mx).
=head1 COPYRIGHT
Copyright (C) 2010 by Pablo Fischer.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
view release on metacpan - search on metacpan
( run in 2.140 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-72ae3ad1e6da )