view release on metacpan or  search on metacpan

lib/ACME/THEDANIEL/Utils.pm  view on Meta::CPAN

=head2 sum

=cut

sub sum {
  my $sum;
  foreach my $num ( @_ ) {
    if ( !looks_like_number( $num ) ) {
      croak "Invalid input: $num"
    }

    $sum += $num;
  }
  return $sum;
}

=head1 AUTHOR

Daniel jones, C<< <dtj at someplace.com> >>

 view release on metacpan or  search on metacpan

examples/port-probe-multi.pl  view on Meta::CPAN

use Getopt::Long;

my $timeout = 1;

GetOptions (
	"timeout=s" => \$timeout,
	"help" => \&usage,
) or usage();

my @probe = map {
	/^(.*):(\d+)$/ or die "Expecting host:port. See $0 --help\n"; [$1, $2, $_];
} @ARGV;
usage() unless @probe;

# Real work
eval {
	ae_recv {
		tcp_connect $_->[0], $_->[1], ae_goal("$_->[0]:$_->[1]") for @probe;
	} $timeout;
};
die $@ if $@ and $@ !~ /^Timeout/;

my @offline = sort keys %{ AE::AdHoc->goals };
my (@alive, @reject);

my $results = AE::AdHoc->results;
foreach (keys %$results) {
	# tcp_connect will not feed any args if connect failed
	ref $results->{$_}->[0]
		? push @alive, $_
		: push @reject, $_;
};

print "Connected: @alive\n" if @alive;
print "Rejected: @reject\n" if @reject;
print "Timed out: @offline\n" if @offline;
# /Real work

sub usage {
	print <<"USAGE";
Probe tcp connection to several hosts at once
Usage: $0 [ options ] host:port host:port ...
Options may include:
	--timeout <seconds> - may be fractional as well
	--help - this message
USAGE
	exit 1;
};

 view release on metacpan or  search on metacpan

lib/AES128.pm  view on Meta::CPAN

# This allows declaration	use AES128 ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	AES128_CTR_encrypt AES128_CTR_decrypt	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);

our $VERSION = '0.02';

require XSLoader;

 view release on metacpan or  search on metacpan

examples/Meltdown.pl  view on Meta::CPAN

use blib;
use AFS::Monitor;

sub Usage {
	print STDERR "\n\n$progName: collect rxdebug stats on AFS process.\n";
	print STDERR "usage: $progName [options]\n";
	print STDERR "options:\n";
	print STDERR " -s <server>    (required parameter, no default).\n";
	print STDERR " -p <port>      (default: 7000).\n";
	print STDERR " -t <interval>  (default: 1200 seconds).\n";
	print STDERR " -C             \n";
	print STDERR " -h             (help: show this help message).\n\n";
	print STDERR "Example: $progName -s point -p 7000\n";
	print STDERR "Collect statistics on server point for port 7000\n";
	print STDERR "Refresh interval will default to 20 minutes (1200 seconds)\n\n";
	exit 0;
} # Usage

sub Check_data {
	#
	# If a value is going to overflow the field length,
	# then bump the field length to match the value.
	# It won't be pretty but we'll have valid data.
	#
	(length $wproc	> $Ln[0]) ? ($Ln[0] = length $wproc)	: "";
	(length $nobuf	> $Ln[1]) ? ($Ln[1] = length $nobuf)	: "";
	(length $wpack	> $Ln[2]) ? ($Ln[2] = length $wpack)	: "";
	(length $fpack	> $Ln[3]) ? ($Ln[3] = length $fpack)	: "";
	(length $calls	> $Ln[4]) ? ($Ln[4] = length $calls)	: "";
	(length $delta	> $Ln[5]) ? ($Ln[5] = length $delta)	: "";
	(length $data	> $Ln[6]) ? ($Ln[6] = length $data)	: "";
	(length $resend	> $Ln[7]) ? ($Ln[7] = length $resend)	: "";
	(length $idle	> $Ln[8]) ? ($Ln[8] = length $idle)	: "";
} # Check_data

sub Header {
    if ($csvmode != 1) {
    	print "\nhh:mm:ss wproc nobufs   wpack  fpack    calls     delta  data      resends  idle\n";
    } else { # assume CSV mode...
    	print "\nhh:mm:ss,wproc,nobufs,wpack,fpack,calls,delta,data,resends,idle\n";
    }
} # Header

#
# don't buffer the output
#

 view release on metacpan or  search on metacpan

example/lava_lamp.pl  view on Meta::CPAN

#!/usr/bin/perl 

=head1 NAME

   lava_lamp.pl --mode [watch|list|notify] --type [problem|recovery] \
                --name [AIN|switch name] --label <label> --debug \
                --config <path-to-perl-config>

=head1 DESCRIPTION

Simple example how to use L<"AHA"> for controlling AVM AHA switches. I.e. 
it is used for using a Lava Lamp as a Nagios Notification handler.

 view release on metacpan or  search on metacpan

examples/benchmark.pl  view on Meta::CPAN

#!/usr/bin/perl
use strict;
use warnings;
use Benchmark qw(:all);
use AI::ANN::Neuron;

my %data = (id => 1, inputs => [ 4*rand()-2, 4*rand()-2, 4*rand()-2,
								 4*rand()-2, 4*rand()-2 ],
					 neurons => [ 4*rand()-2, 4*rand()-2, 4*rand()-2, 
								  4*rand()-2, 4*rand()-2 ]);
my $object1 = new AI::ANN::Neuron ( %data, inline_c => 0 );
my $object2 = new AI::ANN::Neuron ( %data, inline_c => 1 );
my @data = ( [ 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2 ],
			 [ 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2, 4*rand()-2 ]);
cmpthese( -1, { 'pure_perl' => sub{$object1->execute(@data)},
				'inline_c'  => sub{$object2->execute(@data)} });

use Math::Libm qw(erf M_PI);
use Inline C => <<'END_C';
#include <math.h>
double afunc[4001];	
double dafunc[4001];
void generate_globals() {
	int i;
	for (i=0;i<=4000;i++) {
		afunc[i] = 2 * (erf(i/1000.0-2));
		dafunc[i] = 4 / sqrt(M_PI) * pow(exp(-1 * ((i/1000.0-2))), 2);
	}
}
double afunc_c (float input) {
	return afunc[(int) floor((input)*1000)+2000];
}
double dafunc_c (float input) {
	return dafunc[(int) floor((input)*1000)+2000];
}
END_C

timethis(-1, 'generate_globals()');

sub afunc_pp {
	return 2 * erf(int((shift)*1000)/1000);
}
sub dafunc_pp {
	return 4 / sqrt(M_PI) * exp( -1 * ((int((shift)*1000)/1000) ** 2) );
}

cmpthese( -1, { 'afunc_c'  => sub{afunc_c(4*rand()-2)},
				'afunc_pp' => sub{afunc_pp(4*rand()-2)} });

cmpthese( -1, { 'dafunc_c'  => sub{dafunc_c(4*rand()-2)},
				'dafunc_pp' => sub{dafunc_pp(4*rand()-2)} });

 view release on metacpan or  search on metacpan

lib/AI/CBR.pm  view on Meta::CPAN

our $VERSION = '0.02';


=head1 SYNOPSIS

    use AI::CBR::Sim qw(sim_eq ...);
    use AI::CBR::Case;
    use AI::CBR::Retrieval;

    my $case = AI::CBR::Case->new(...);
    my $r = AI::CBR::Retrieval->new($case, \@case_base);
    ...


=head1 DESCRIPTION

Framework for Case-Based Reasoning in Perl.

 view release on metacpan or  search on metacpan

lib/AI/Calibrate.pm  view on Meta::CPAN

# This allows declaration:
#	use AI::Calibrate ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = (
    'all' => [
        qw(
              calibrate
              score_prob
              print_mapping
            )
    ]
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( );

 view release on metacpan or  search on metacpan

eg/demo.pl  view on Meta::CPAN

use AI::Categorizer::Collection::Files;
use AI::Categorizer::Learner::NaiveBayes;
use File::Spec;

die("Usage: $0 <corpus>\n".
    "  A sample corpus (data set) can be downloaded from\n".
    "     http://www.cpan.org/authors/Ken_Williams/data/reuters-21578.tar.gz\n".
    "  or http://www.limnus.com/~ken/reuters-21578.tar.gz\n")
  unless @ARGV == 1;

my $corpus = shift;

my $training  = File::Spec->catfile( $corpus, 'training' );
my $test      = File::Spec->catfile( $corpus, 'test' );
my $cats      = File::Spec->catfile( $corpus, 'cats.txt' );
my $stopwords = File::Spec->catfile( $corpus, 'stopwords' );

my %params;
if (-e $stopwords) {
  $params{stopword_file} = $stopwords;
} else {
  warn "$stopwords not found - no stopwords will be used.\n";
}

if (-e $cats) {
  $params{category_file} = $cats;
} else {
  die "$cats not found - can't proceed without category information.\n";
}


# In a real-world application these Collection objects could be of any
# type (any Collection subclass).  Or you could create each Document

 view release on metacpan or  search on metacpan

lib/AI/Classifier/Japanese.pm  view on Meta::CPAN

use Algorithm::NaiveBayes;

my $nb = Algorithm::NaiveBayes->new;

sub add_training_text {
  my ($self, $text, $category) = @_;

  my $words_freq_ref = &_convert_text_to_bow($text);
  $nb->add_instance(
    attributes => $words_freq_ref,
    label      => $category
  );
}

sub train {
  $nb->train;
}

sub labels {
  $nb->labels;
}

sub predict {
  my ($self, $text) = @_;

  my $words_freq_ref = &_convert_text_to_bow($text);
  my $result_ref = $nb->predict(
    attributes => $words_freq_ref
  );
}

sub _convert_text_to_bow {
  my $text = shift;

  my $words_ref = &_parse_text($text);
  my $words_freq_ref = {};
  foreach (@$words_ref) {
    $words_freq_ref->{$_}++;
  }
  return $words_freq_ref;
}

sub _parse_text {
  my $text = shift;

  my $mecab = Text::MeCab->new();
  my $node = $mecab->parse($text);
  my $words_ref = [];

  while ($node) {
    if (&_is_keyword($node->posid)) {
      push @$words_ref, $node->surface;
    }
    $node = $node->next;
  }
  return $words_ref;
}

sub save_state {
  my ($self, $path) = @_;
  $nb->save_state($path);
}

sub restore_state {
  my ($self, $path) = @_;
  $nb = Algorithm::NaiveBayes->restore_state($path);
}

sub _is_keyword {
  my $posid = shift;

  return &_is_noun($posid) || &_is_verb($posid) || &_is_adj($posid);
}

# See: http://mecab.googlecode.com/svn/trunk/mecab/doc/posid.html
sub _is_interjection {
  return $_[0] == 2;
}
sub _is_adj {
  return 10 <= $_[0] && $_[0] < 13;
}
sub _is_aux {
  return $_[0] == 25;
}
sub _is_conjunction {
  return $_[0] == 26;
}
sub _is_particls {
  return 27 <= $_[0] && $_[0] < 31;
}
sub _is_verb {
  return 31 <= $_[0] && $_[0] < 34;
}
sub _is_noun {
  return 36 <= $_[0] && $_[0] < 68;
}
sub _is_prenominal_adj {
  return $_[0] == 68;
}

__PACKAGE__->meta->make_immutable();

1;

 view release on metacpan or  search on metacpan

lib/AI/CleverbotIO.pm  view on Meta::CPAN

use Log::Any ();
use Data::Dumper;
use JSON::PP qw< decode_json >;

has endpoints => (
   is      => 'ro',
   default => sub {
      return {
         ask    => 'https://cleverbot.io/1.0/ask',
         create => 'https://cleverbot.io/1.0/create',
      };
   },
);

has key => (
   is       => 'ro',
   required => 1,
);

has logger => (
   is      => 'ro',
   lazy    => 1,
   builder => 'BUILD_logger',
);

has nick => (
   is        => 'rw',
   lazy      => 1,
   predicate => 1,
);

has user => (
   is       => 'ro',
   required => 1,
);

has ua => (
   is      => 'ro',
   lazy    => 1,
   builder => 'BUILD_ua',
);

sub BUILD_logger {
   return Log::Any->get_logger;
}

sub BUILD_ua {
   my $self = shift;
   require HTTP::Tiny;
   return HTTP::Tiny->new;
}

sub ask {
   my ($self, $question) = @_;
   my %ps = (
      key  => $self->key,
      text => $question,
      user => $self->user,
   );
   $ps{nick} = $self->nick if $self->has_nick;
   return $self->_parse_response(
      $self->ua->post_form($self->endpoints->{ask}, \%ps));
}

sub create {
   my $self = shift;
   $self->nick(shift) if @_;

   # build request parameters
   my %ps = (
      key  => $self->key,
      user => $self->user,
   );
   $ps{nick} = $self->nick if $self->has_nick && length $self->nick;

   my $data =
     $self->_parse_response(
      $self->ua->post_form($self->endpoints->{create}, \%ps));

   $self->nick($data->{nick}) if exists($data->{nick});

   return $data;
}

sub _parse_response {
   my ($self, $response) = @_;

   {
      local $Data::Dumper::Indent = 1;
      $self->logger->debug('got response: ' . Dumper($response));
   }

   ouch 500, 'no response (possible bug in HTTP::Tiny though?)'
     unless ref($response) eq 'HASH';

   my $status = $response->{status};
   ouch $status, $response->{reason}
      if ($status != 200) && ($status != 400);

   my $data = __decode_content($response);
   return $data if $response->{success};
   ouch 400, $data->{status};
} ## end sub _parse_response

sub __decode_content {
   my $response = shift;
   my $encoded  = $response->{content};
   if (!$encoded) {
      my $url = $response->{url} // '*unknown url, check HTTP::Tiny*';
      ouch 500, "response status $response->{status}, nothing from $url)";
   }
   my $decoded = eval { decode_json($encoded) }
     or ouch 500, "response status $response->{status}, exception: $@";
   return $decoded;
} ## end sub __decode_content

1;

 view release on metacpan or  search on metacpan

lib/AI/ConfusionMatrix.pm  view on Meta::CPAN

use Tie::File;

# ABSTRACT: Make a confusion matrix

sub makeConfusionMatrix {
    my ($matrix, $file, $delem) = @_;
    unless(defined $delem) {
        $delem = ',';
    }

    carp ('First argument must be a hash reference') if ref($matrix) ne 'HASH';

    my %cmData = genConfusionMatrixData($matrix);
    # This ties @output_array to the output file. Each output_array item represents a line in the output file
    tie my @output_array, 'Tie::File', $file or carp "$!";
    # Empty the file
    @output_array = ();

    my @columns = @{$cmData{columns}};
    map {$output_array[0] .= $delem . $_} join $delem, (@columns, 'TOTAL', 'TP', 'FP', 'FN', 'SENS', 'ACC');
    my $line = 1;
    my @expected = sort keys %{$matrix};
    for my $expected (@expected) {
        $output_array[$line] = $expected;
        my $lastIndex = 0;
        my $index;
        for my $predicted (sort keys %{$matrix->{$expected}}) {
            # Calculate the index of the label in the output_array of columns
            $index = _findIndex($predicted, \@columns);
            # Print some of the delimiter to get to the column of the next value predicted
            $output_array[$line] .= $delem x ($index - $lastIndex) . $matrix->{$expected}{$predicted};
            $lastIndex = $index;
        }

        # Get to the columns of the stats
        $output_array[$line] .= $delem x (scalar(@columns) - $lastIndex + 1);
        $output_array[$line] .= join $delem, (
                                    $cmData{stats}{$expected}{'total'},
                                    $cmData{stats}{$expected}{'tp'},
                                    $cmData{stats}{$expected}{'fp'},
                                    $cmData{stats}{$expected}{'fn'},
                                    sprintf('%.2f%%', $cmData{stats}{$expected}{'sensitivity'}),
                                    sprintf('%.2f%%', $cmData{stats}{$expected}{'acc'})
                                   );
        ++$line;
    }
    # Print the TOTAL row to the csv file
    $output_array[$line] = 'TOTAL' . $delem;
    map {$output_array[$line] .= $cmData{totals}{$_} . $delem} (@columns);
    $output_array[$line] .= join $delem, (
                                $cmData{totals}{'total'},
                                $cmData{totals}{'tp'},
                                $cmData{totals}{'fp'},
                                $cmData{totals}{'fn'},
                                sprintf('%.2f%%', $cmData{totals}{'sensitivity'}),
                                sprintf('%.2f%%', $cmData{totals}{'acc'})
                            );

    untie @output_array;
}

sub getConfusionMatrix {
    my ($matrix) = @_;

    carp ('First argument must be a hash reference') if ref($matrix) ne 'HASH';
    return genConfusionMatrixData($matrix);
}

sub genConfusionMatrixData {
    my $matrix = shift;
    my @expected = sort keys %{$matrix};
    my %stats;
    my %totals;
    my @columns;
    for my $expected (@expected) {
        $stats{$expected}{'fn'} = 0;
        $stats{$expected}{'tp'} = 0;
        # Ensure that the False Positive counter is defined to be able to compute the total later
        unless(defined $stats{$expected}{'fp'}) {
            $stats{$expected}{'fp'} = 0;
        }
        for my $predicted (keys %{$matrix->{$expected}}) {
            $stats{$expected}{'total'} += $matrix->{$expected}->{$predicted};
            $stats{$expected}{'tp'} += $matrix->{$expected}->{$predicted} if $expected eq $predicted;
            if ($expected ne $predicted) {
                $stats{$expected}{'fn'} += $matrix->{$expected}->{$predicted};
                $stats{$predicted}{'fp'} += $matrix->{$expected}->{$predicted};
            }
            $totals{$predicted} += $matrix->{$expected}->{$predicted};
            # Add the label to the array of columns if it does not contain it already
            push @columns, $predicted unless _findIndex($predicted, \@columns);
        }

        $stats{$expected}{'acc'} = ($stats{$expected}{'tp'} * 100) / $stats{$expected}{'total'};
    }

    for my $expected (@expected) {
        $totals{'total'} += $stats{$expected}{'total'};
        $totals{'tp'}    += $stats{$expected}{'tp'};
        $totals{'fn'}    += $stats{$expected}{'fn'};
        $totals{'fp'}    += $stats{$expected}{'fp'};
        $stats{$expected}{'sensitivity'} = ($stats{$expected}{'tp'} * 100) / ($stats{$expected}{'tp'} + $stats{$expected}{'fp'});
    }

    $totals{'acc'} = ($totals{'tp'} * 100) / $totals{'total'};
    $totals{'sensitivity'} = ($totals{'tp'} * 100) / ($totals{'tp'} + $totals{'fp'});

    return (
        columns => [sort @columns],
        stats   => \%stats,
        totals  => \%totals
    );
}

sub _findIndex {
    my ($string, $array) = @_;
    for (0 .. @$array - 1) {
        return $_ + 1 if ($string eq @{$array}[$_]);
    }
}

=head1 NAME

AI::ConfusionMatrix - make a confusion matrix

=head1 SYNOPSIS

    my %matrix;

    # Loop over your predictions
    # [...]

    $matrix{$expected}{$predicted} += 1;

    # [...]

    makeConfusionMatrix(\%matrix, 'output.csv');


=head1 DESCRIPTION

This module prints a L<confusion matrix|https://en.wikipedia.org/wiki/Confusion_matrix> from a hash reference. This module tries to be generic enough to be used within a lot of machine learning projects.

 view release on metacpan or  search on metacpan

Instance/Instance.pm  view on Meta::CPAN

AI::DecisionTree::Instance - C-struct wrapper for training instances

=head1 SYNOPSIS

  use AI::DecisionTree::Instance;
  
  my $i = new AI::DecisionTree::Instance([3,5], 7, 'this_instance');
  $i->value_int(0) == 3;
  $i->value_int(1) == 5;
  $i->result_int == 7;

=head1 DESCRIPTION

This class is just a simple Perl wrapper around a C struct embodying a
single training instance.  Its purpose is to reduce memory usage.  In

 view release on metacpan or  search on metacpan

lib/AI/Embedding.pm  view on Meta::CPAN

package AI::Embedding;

use strict;
use warnings;

use HTTP::Tiny;
use JSON::PP;
use Data::CosineSimilarity;

our $VERSION = '1.11';
$VERSION = eval $VERSION;

my $http = HTTP::Tiny->new;

# Create Embedding object
sub new {
    my $class = shift;
    my %attr  = @_;

    $attr{'error'}      = '';

    $attr{'api'}        = 'OpenAI' unless $attr{'api'};
    $attr{'error'}      = 'Invalid API' unless $attr{'api'} eq 'OpenAI';
    $attr{'error'}      = 'API Key missing' unless $attr{'key'};

    $attr{'model'}      = 'text-embedding-ada-002' unless $attr{'model'};

    return bless \%attr, $class;
}

# Define endpoints for APIs
my %url    = (
    'OpenAI' => 'https://api.openai.com/v1/embeddings',
);

# Define HTTP Headers for APIs
my %header = (
    'OpenAI' => &_get_header_openai,
);

# Returns true if last operation was success
sub success {
    my $self = shift;
    return !$self->{'error'};
}

# Returns error if last operation failed
sub error {
    my $self = shift;
    return $self->{'error'};
}

# Header for calling OpenAI
sub _get_header_openai {
    my $self = shift;
    $self->{'key'} = '' unless defined $self->{'key'};
    return {
         'Authorization' => 'Bearer ' . $self->{'key'},
         'Content-type'  => 'application/json'
     };
 }

 # Fetch Embedding response
 sub _get_embedding {
     my ($self, $text) = @_;

     my $response = $http->post($url{$self->{'api'}}, {
         'headers' => {
             'Authorization' => 'Bearer ' . $self->{'key'},
             'Content-type'  => 'application/json'
         },
         content => encode_json {
             input  => $text,
             model  => $self->{'model'},
         }
     });
     if ($response->{'content'} =~ 'invalid_api_key') {
         die 'Incorrect API Key - check your API Key is correct';
     }
     return $response;
 }

 # TODO:
 # Make 'headers' use $header{$self->{'api'}}
 # Currently hard coded to OpenAI

 # Added purely for testing - IGNORE!
 sub _test {
     my $self = shift;
#    return $self->{'api'};
     return $header{$self->{'api'}};
 }

 # Return Embedding as a CSV string
 sub embedding {
     my ($self, $text, $verbose) = @_;

     my $response = $self->_get_embedding($text);
     if ($response->{'success'}) {
         my $embedding = decode_json($response->{'content'});
         return join (',', @{$embedding->{'data'}[0]->{'embedding'}});
     }
     $self->{'error'} = 'HTTP Error - ' . $response->{'reason'};
     return $response if defined $verbose;
     return undef;
 }

 # Return Embedding as an array
 sub raw_embedding {
     my ($self, $text, $verbose) = @_;

     my $response = $self->_get_embedding($text);
     if ($response->{'success'}) {
         my $embedding = decode_json($response->{'content'});
         return @{$embedding->{'data'}[0]->{'embedding'}};
     }
     $self->{'error'} = 'HTTP Error - ' . $response->{'reason'};
     return $response if defined $verbose;
     return undef;
 }

 # Return Test Embedding
 sub test_embedding {
     my ($self, $text, $dimension) = @_;
     $self->{'error'} = '';

     $dimension = 1536 unless defined $dimension;

     if ($text) {
         srand scalar split /\s+/, $text;
     }

     my @vector;
     for (1...$dimension) {
         push @vector, rand(2) - 1;
     }
     return join ',', @vector;
 }

# Convert a CSV Embedding into a hashref
sub _make_vector {
    my ($self, $embed_string) = @_;

    if (!defined $embed_string) {
        $self->{'error'} = 'Nothing to compare!';
        return;
    }

    my %vector;
    my @embed = split /,/, $embed_string;
    for (my $i = 0; $i < @embed; $i++) {
       $vector{'feature' . $i} = $embed[$i];
   }
   return \%vector;
}

# Return a comparator to compare to a set vector
sub comparator {
    my($self, $embed) = @_;
    $self->{'error'} = '';

    my $vector1 = $self->_make_vector($embed);
    return sub {
        my($embed2) = @_;
        my $vector2 = $self->_make_vector($embed2);
        return $self->_compare_vector($vector1, $vector2);
    };
}

# Compare 2 Embeddings
sub compare {
    my ($self, $embed1, $embed2) = @_;

    my $vector1 = $self->_make_vector($embed1);
    my $vector2;
    if (defined $embed2) {
        $vector2 = $self->_make_vector($embed2);
    } else {
        $vector2 = $self->{'comparator'};
    }

    if (!defined $vector2) {
        $self->{'error'} = 'Nothing to compare!';
        return;
    }

    if (scalar keys %$vector1 != scalar keys %$vector2) {
        $self->{'error'} = 'Embeds are unequal length';
        return;
    }

    return $self->_compare_vector($vector1, $vector2);
}

# Compare 2 Vectors
sub _compare_vector {
    my ($self, $vector1, $vector2) = @_;
    my $cs = Data::CosineSimilarity->new;
    $cs->add( label1 => $vector1 );
    $cs->add( label2 => $vector2 );
    return $cs->similarity('label1', 'label2')->cosine;
}

1;

__END__

=encoding utf8

=head1 NAME

AI::Embedding - Perl module for working with text embeddings using various APIs

=head1 VERSION

Version 1.11

=head1 SYNOPSIS

    use AI::Embedding;

    my $embedding = AI::Embedding->new(
        api => 'OpenAI',
        key => 'your-api-key'
    );

    my $csv_embedding  = $embedding->embedding('Some sample text');
    my $test_embedding = $embedding->test_embedding('Some sample text');
    my @raw_embedding  = $embedding->raw_embedding('Some sample text');

    my $cmp = $embedding->comparator($csv_embedding2);

    my $similarity = $cmp->($csv_embedding1);
    my $similarity_with_other_embedding = $embedding->compare($csv_embedding1, $csv_embedding2);

=head1 DESCRIPTION

The L<AI::Embedding> module provides an interface for working with text embeddings using various APIs. It currently supports the L<OpenAI|https://www.openai.com> L<Embeddings API|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>...

Embeddings allow the meaning of passages of text to be compared for similarity.  This is more natural and useful to humans than using traditional keyword based comparisons.

An Embedding is a multi-dimensional vector representing the meaning of a piece of text.  The Embedding vector is created by an AI Model.  The default model (OpenAI's C<text-embedding-ada-002>) produces a 1536 dimensional vector.  The resulting vector...

=head2 Comparator

Embeddings are used to compare similarity of meaning between two passages of text.  A typical work case is to store a number of pieces of text (e.g. articles or blogs) in a database and compare each one to some user supplied search text.  L<AI::Embed...

Alternatively, the C<comparator> method can be called with one Embedding.  The C<comparator> returns a reference to a method that takes a single Embedding to be compared to the Embedding from which the Comparator was created.

When comparing multiple Embeddings to the same Embedding (such as search text) it is faster to use a C<comparator>.

=head1 CONSTRUCTOR

=head2 new

    my $embedding = AI::Embedding->new(
        api         => 'OpenAI',
        key         => 'your-api-key',
        model       => 'text-embedding-ada-002',
    );

Creates a new AI::Embedding object. It requires the 'key' parameter. The 'key' parameter is the API key provided by the service provider and is required.

Parameters:

=over

=item *

C<key> - B<required> The API Key

=item *

C<api> - The API to use.  Currently only 'OpenAI' is supported and this is the default.

=item *

C<model> - The language model to use.  Defaults to C<text-embedding-ada-002> - see L<OpenAI docs|https://platform.openai.com/docs/guides/embeddings/what-are-embeddings>

=back

=head1 METHODS

=head2 success

Returns true if the last method call was successful

=head2 error

Returns the last error message or an empty string if B<success> returned true

=head2 embedding

    my $csv_embedding = $embedding->embedding('Some text passage', [$verbose]);

Generates an embedding for the given text and returns it as a comma-separated string. The C<embedding> method takes a single parameter, the text to generate the embedding for.

Returns a (rather long) string that can be stored in a C<TEXT> database field.

If the method call fails it sets the L</"error"> message and returns C<undef>.  If the optional C<verbose> parameter is true, the complete L<HTTP::Tiny> response object is also returned to aid with debugging issues when using this module.

=head2 raw_embedding

    my @raw_embedding = $embedding->raw_embedding('Some text passage', [$verbose]);

Generates an embedding for the given text and returns it as an array. The C<raw_embedding> method takes a single parameter, the text to generate the embedding for.

It is not normally necessary to use this method as the Embedding will almost always be used as a single homogeneous unit.

If the method call fails it sets the L</"error"> message and returns C<undef>.  If the optional C<verbose> parameter is true, the complete L<HTTP::Tiny> response object is also returned to aid with debugging issues when using this module.

=head2 test_embedding

    my $test_embedding = $embedding->test_embedding('Some text passage', $dimensions);

Used for testing code without making a chargeable call to the API.

Provides a CSV string of the same size and format as L<embedding> but with meaningless random data.

Returns a random embedding.  Both parameters are optional.  If a text string is provided, the returned embedding will always be the same random embedding otherwise it will be random and different every time.  The C<dimension> parameter controls the n...

=head2 comparator

    $embedding->comparator($csv_embedding2);

Sets a vector as a C<comparator> for future comparisons and returns a reference to a method for using the C<comparator>.

The B<comparator> method takes a single parameter, the comma-separated Embedding string to use as the comparator.

The following two are functionally equivalent.  However, where multiple Embeddings are to be compared to a single Embedding, using a L<Comparator> is significantly faster.

    my $similarity = $embedding->compare($csv_embedding1, $csv_embedding2);


    my $cmp = $embedding->comparator($csv_embedding2);
    my $similarity = $cmp->($csv_embedding1);

See L</"Comparator">

The returned method reference returns the cosine similarity between the Embedding used to call the C<comparator> method and the Embedding supplied to the method reference.  See L<compare> for an explanation of the cosine similarity.

=head2 compare

    my $similarity_with_other_embedding = $embedding->compare($csv_embedding1, $csv_embedding2);

Compares two embeddings and returns the cosine similarity between them. The B<compare> method takes two parameters: $csv_embedding1 and $csv_embedding2 (both comma-separated embedding strings).

Returns the cosine similarity as a floating-point number between -1 and 1, where 1 represents identical embeddings, 0 represents no similarity, and -1 represents opposite embeddings.

The absolute number is not usually relevant for text comparision.  It is usually sufficient to rank the comparison results in order of high to low to reflect the best match to the worse match.

=head1 SEE ALSO

L<https://openai.com> - OpenAI official website

=head1 AUTHOR

Ian Boddison <ian at boddison.com>

=head1 BUGS

Please report any bugs or feature requests to C<bug-ai-embedding at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=bug-ai-embedding>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc AI::Embedding

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=AI-Embedding>

=item * Search CPAN

L<https://metacpan.org/release/AI::Embedding>

=back

=head1 ACKNOWLEDGEMENTS

Thanks to the help and support provided by members of Perl Monks L<https://perlmonks.org/>.

Especially L<Ken Cotterill (KCOTT)|https://metacpan.org/author/KCOTT> for assistance with unit tests and L<Hugo van der Sanden (HVDS)|https://metacpan.org/author/HVDS> for suggesting the current C<comparator> implementaion.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2023 by Ian Boddison.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

 view release on metacpan or  search on metacpan

lib/AI/Evolve/Befunge.pm  view on Meta::CPAN

our $VERSION = "0.03";

=head1 NAME

    AI::Evolve::Befunge - practical evolution of Befunge AI programs


=head1 SYNOPSIS

    use aliased 'AI::Evolve::Befunge::Population' => 'Population';
    use AI::Evolve::Befunge::Util qw(v nonquiet);

    $pop = Population->new();

    while(1) {
        my $gen  = $pop->generation;
        nonquiet("generation $gen\n");
        $pop->fight();
        $pop->breed();
        $pop->migrate();
        $pop->save();
        $pop->generation($gen+1);
    }


=head1 DESCRIPTION

This software project provides all of the necessary tools to grow a

 view release on metacpan or  search on metacpan

examples/backward.pl  view on Meta::CPAN

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();

 view release on metacpan or  search on metacpan

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

use AI::ExpertSystem::Simple::Goal;

our $VERSION = '1.2';

sub new {
	my ($class) = @_;

	die "Simple->new() takes no arguments" if scalar(@_) != 1;

	my $self = {};

	$self->{_rules} = ();
	$self->{_knowledge} = ();
	$self->{_goal} = undef;
	$self->{_filename} = undef;

	$self->{_ask_about} = undef;
	$self->{_told_about} = undef;

	$self->{_log} = ();

	$self->{_number_of_rules} = 0;
	$self->{_number_of_attributes} = 0;
	$self->{_number_of_questions} = 0;

	return bless $self, $class;
}

sub reset {
	my ($self) = @_;

	die "Simple->reset() takes no arguments" if scalar(@_) != 1;

	foreach my $name (keys %{$self->{_rules}}) {
		$self->{_rules}->{$name}->reset();
	}

	foreach my $name (keys %{$self->{_knowledge}}) {
		$self->{_knowledge}->{$name}->reset();
	}

	$self->{_ask_about} = undef;
	$self->{_told_about} = undef;
	$self->{_log} = ();
}

sub load {
	my ($self, $filename) = @_;

	die "Simple->load() takes 1 argument" if scalar(@_) != 2;
	die "Simple->load() argument 1 (FILENAME) is undefined" if !defined($filename);

	if(-f $filename and -r $filename) {
		my $twig = XML::Twig->new(
			twig_handlers => { goal => sub { $self->_goal(@_) },
					   rule => sub { $self->_rule(@_) },
					   question => sub { $self->_question(@_) } }
		);

		$twig->safe_parsefile($filename);

		die "Simple->load() XML parse failed: $@" if $@;

		$self->{_filename} = $filename;

		$self->_add_to_log( "Read in $filename" );
		$self->_add_to_log( "There are " . $self->{_number_of_rules} . " rules" );
		$self->_add_to_log( "There are " . $self->{_number_of_attributes} . " attributes" );
		$self->_add_to_log( "There are " . $self->{_number_of_questions} . " questions" );
		$self->_add_to_log( "The goal attibutes is " . $self->{_goal}->name() );
		return 1;
	} else {
		die "Simple->load() unable to use file";
	}
}

sub _goal {
	my ($self, $t, $node) = @_;

	my $attribute = undef;
	my $text = undef;

	my $x = ($node->children('attribute'))[0];
	$attribute = $x->text();

	$x = ($node->children('text'))[0];
	$text = $x->text();

	$self->{_goal} = AI::ExpertSystem::Simple::Goal->new($attribute, $text);

	eval { $t->purge(); }
}

sub _rule {
	my ($self, $t, $node) = @_;

	my $name = undef;

	my $x = ($node->children('name'))[0];
	$name = $x->text();

	if(!defined($self->{_rules}->{$name})) {
		$self->{_rules}->{$name} = AI::ExpertSystem::Simple::Rule->new($name);
		$self->{_number_of_rules}++;
	}

	foreach $x ($node->get_xpath('//condition')) {
		my $attribute = undef;
		my $value = undef;

		my $y = ($x->children('attribute'))[0];
		$attribute = $y->text();

		$y = ($x->children('value'))[0];
		$value = $y->text();

		$self->{_rules}->{$name}->add_condition($attribute, $value);

		if(!defined($self->{_knowledge}->{$attribute})) {
			$self->{_number_of_attributes}++;
			$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
		}
	}

	foreach $x ($node->get_xpath('//action')) {
		my $attribute = undef;
		my $value = undef;

		my $y = ($x->children('attribute'))[0];
		$attribute = $y->text();

		$y = ($x->children('value'))[0];
		$value = $y->text();

		$self->{_rules}->{$name}->add_action($attribute, $value);

		if(!defined($self->{_knowledge}->{$attribute})) {
			$self->{_number_of_attributes}++;
			$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
		}
	}

	eval { $t->purge(); }
}

sub _question {
	my ($self, $t, $node) = @_;

	my $attribute = undef;
	my $text = undef;
	my @responses = ();

	$self->{_number_of_questions}++;

	my $x = ($node->children('attribute'))[0];
	$attribute = $x->text();

	$x = ($node->children('text'))[0];
	$text = $x->text();

	foreach $x ($node->children('response')) {
		push(@responses, $x->text());
	}

	if(!defined($self->{_knowledge}->{$attribute})) {
		$self->{_number_of_attributes}++;
		$self->{_knowledge}->{$attribute} = AI::ExpertSystem::Simple::Knowledge->new($attribute);
	}
	$self->{_knowledge}->{$attribute}->set_question($text, @responses);

	eval { $t->purge(); }
}

sub process {
	my ($self) = @_;

	die "Simple->process() takes no arguments" if scalar(@_) != 1;

	my $n = $self->{_goal}->name();

	if($self->{_knowledge}->{$n}->is_value_set()) {
		return 'finished';
	}

	if($self->{_ask_about}) {
		my %answers = ();

		$answers{$self->{_ask_about}}->{value} = $self->{_told_about};
		$answers{$self->{_ask_about}}->{setter} = '';

		$self->{_ask_about} = undef;
		$self->{_told_about} = undef;

		while(%answers) {
			my %old_answers = %answers;
			%answers = ();

			foreach my $answer (keys(%old_answers)) {
				my $n = $answer;
				my $v = $old_answers{$answer}->{value};
				my $s = $old_answers{$answer}->{setter};

				$self->_add_to_log( "Setting '$n' to '$v'" );

				$self->{_knowledge}->{$n}->set_value($v,$s);

				foreach my $key (keys(%{$self->{_rules}})) {
					if($self->{_rules}->{$key}->state() eq 'active') {
						my $state = $self->{_rules}->{$key}->given($n, $v);
						if($state eq 'completed') {
							$self->_add_to_log( "Rule '$key' has completed" );
							my %y = $self->{_rules}->{$key}->actions();
							foreach my $k (keys(%y)) {
								$self->_add_to_log( "Rule '$key' is setting '$k' to '$y{$k}'" );
								$answers{$k}->{value} = $y{$k};
								$answers{$k}->{setter} = $key;
							}
						} elsif($state eq 'invalid') {
							$self->_add_to_log( "Rule '$key' is now inactive" );
						}
					}
				}
			}
		}

		return 'continue';
	} else {
		my %scoreboard = ();

		foreach my $rule (keys(%{$self->{_rules}})) {
			if($self->{_rules}->{$rule}->state() eq 'active') {
				my @listofquestions = $self->{_rules}->{$rule}->unresolved();
				my $ok = 1;
				my @questionstoask = ();
				foreach my $name (@listofquestions) {
					if($self->{_knowledge}->{$name}->has_question()) {
						push(@questionstoask, $name);
					} else {
						$ok = 0;
					}
				}

				if($ok == 1) {
					foreach my $name (@questionstoask) {
						$scoreboard{$name}++;
					}
				}
			}
		}

		my $max_value = 0;

		foreach my $name (keys(%scoreboard)) {
			if($scoreboard{$name} > $max_value) {
				$max_value = $scoreboard{$name};
				$self->{_ask_about} = $name;
			}
		}

		return $self->{_ask_about} ? 'question' : 'failed';
	}
}

sub get_question {
	my ($self) = @_;

	die "Simple->get_question() takes no arguments" if scalar(@_) != 1;

	return $self->{_knowledge}->{$self->{_ask_about}}->get_question();
}

sub answer {
	my ($self, $value) = @_;

	die "Simple->answer() takes 1 argument" if scalar(@_) != 2;
	die "Simple->answer() argument 1 (VALUE) is undefined" if ! defined($value);

	$self->{_told_about} = $value;
}

sub get_answer {
	my ($self) = @_;

	die "Simple->get_answer() takes no arguments" if scalar(@_) != 1;

	my $n = $self->{_goal}->name();

	return $self->{_goal}->answer($self->{_knowledge}->{$n}->get_value());
}

sub log {
	my ($self) = @_;

	die "Simple->log() takes no arguments" if scalar(@_) != 1;

	my @return = ();
	@return = @{$self->{_log}} if defined @{$self->{_log}};

	$self->{_log} = ();

	return @return;
}

sub _add_to_log {
	my ($self, $message) = @_;

	push( @{$self->{_log}}, $message );
}

sub explain {
	my ($self) = @_;

	die "Simple->explain() takes no arguments" if scalar(@_) != 1;

	my $name  = $self->{_goal}->name();
	my $rule  = $self->{_knowledge}->{$name}->get_setter();
	my $value = $self->{_knowledge}->{$name}->get_value();

	my $x = "The goal '$name' was set to '$value' by " . ($rule ? "rule '$rule'" : 'asking a question' );
	$self->_add_to_log( $x );

	my @processed_rules;
	push( @processed_rules, $rule ) if $rule;

	$self->_explain_this( $rule, '', @processed_rules );
}

sub _explain_this {
	my ($self, $rule, $depth, @processed_rules) = @_;

	$self->_add_to_log( "${depth}Explaining rule '$rule'" );

	my %dont_do_these = map{ $_ => 1 } @processed_rules;

	my @check_these_rules = ();

	my %conditions = $self->{_rules}->{$rule}->conditions();
	foreach my $name (sort keys %conditions) {
		my $value = $conditions{$name};
		my $setter = $self->{_knowledge}->{$name}->get_setter();

		my $x = "$depth Condition '$name' was set to '$value' by " . ($setter ? "rule '$setter'" : 'asking a question' );
		$self->_add_to_log( $x );

		if($setter) {
			unless($dont_do_these{$setter}) {
				$dont_do_these{$setter} = 1;
				push( @check_these_rules, $setter );
			}
		}
	}

	my %actions = $self->{_rules}->{$rule}->actions();
	foreach my $name (sort keys %actions) {
		my $value = $actions{$name};

		my $x = "$depth Action set '$name' to '$value'";
		$self->_add_to_log( $x );
	}

	@processed_rules = keys %dont_do_these;

	foreach my $x ( @check_these_rules ) {
		push( @processed_rules, $self->_explain_this( $x, "$depth ", keys %dont_do_these ) );
	}

	return @processed_rules;
}

1;

=head1 NAME

 view release on metacpan or  search on metacpan

lib/AI/FANN/Evolving.pm  view on Meta::CPAN

our $VERSION = '0.4';
our $AUTOLOAD;
my $log = __PACKAGE__->logger;

my %enum = (
	'train' => {
#		'FANN_TRAIN_INCREMENTAL' => FANN_TRAIN_INCREMENTAL, # only want batch training
		'FANN_TRAIN_BATCH'       => FANN_TRAIN_BATCH,
		'FANN_TRAIN_RPROP'       => FANN_TRAIN_RPROP,
		'FANN_TRAIN_QUICKPROP'   => FANN_TRAIN_QUICKPROP,	
	},
	'activationfunc' => {
		'FANN_LINEAR'                     => FANN_LINEAR,
#		'FANN_THRESHOLD'                  => FANN_THRESHOLD, # can not be used during training
#		'FANN_THRESHOLD_SYMMETRIC'        => FANN_THRESHOLD_SYMMETRIC, # can not be used during training
#		'FANN_SIGMOID'                    => FANN_SIGMOID, # range is between 0 and 1
#		'FANN_SIGMOID_STEPWISE'           => FANN_SIGMOID_STEPWISE, # range is between 0 and 1
		'FANN_SIGMOID_SYMMETRIC'          => FANN_SIGMOID_SYMMETRIC,
		'FANN_SIGMOID_SYMMETRIC_STEPWISE' => FANN_SIGMOID_SYMMETRIC_STEPWISE,
#		'FANN_GAUSSIAN'                   => FANN_GAUSSIAN, # range is between 0 and 1
		'FANN_GAUSSIAN_SYMMETRIC'         => FANN_GAUSSIAN_SYMMETRIC,
		'FANN_GAUSSIAN_STEPWISE'          => FANN_GAUSSIAN_STEPWISE,
#		'FANN_ELLIOT'                     => FANN_ELLIOT, # range is between 0 and 1
		'FANN_ELLIOT_SYMMETRIC'           => FANN_ELLIOT_SYMMETRIC,
#		'FANN_LINEAR_PIECE'               => FANN_LINEAR_PIECE, # range is between 0 and 1
		'FANN_LINEAR_PIECE_SYMMETRIC'     => FANN_LINEAR_PIECE_SYMMETRIC,
		'FANN_SIN_SYMMETRIC'              => FANN_SIN_SYMMETRIC,
		'FANN_COS_SYMMETRIC'              => FANN_COS_SYMMETRIC,
#		'FANN_SIN'                        => FANN_SIN, # range is between 0 and 1
#		'FANN_COS'                        => FANN_COS, # range is between 0 and 1
	},
	'errorfunc' => {
		'FANN_ERRORFUNC_LINEAR' => FANN_ERRORFUNC_LINEAR,
		'FANN_ERRORFUNC_TANH'   => FANN_ERRORFUNC_TANH,	
	},
	'stopfunc' => {
		'FANN_STOPFUNC_MSE' => FANN_STOPFUNC_MSE,
#		'FANN_STOPFUNC_BIT' => FANN_STOPFUNC_BIT,
	}	
);

my %constant;
for my $hashref ( values %enum ) {
	while( my ( $k, $v ) = each %{ $hashref } ) {
		$constant{$k} = $v;
	}
}

my %default = (
	'error'               => 0.0001,
	'epochs'              => 5000,
	'train_type'          => 'ordinary',
	'epoch_printfreq'     => 100,
	'neuron_printfreq'    => 0,
	'neurons'             => 15,
	'activation_function' => FANN_SIGMOID_SYMMETRIC,
);

=head1 NAME

AI::FANN::Evolving - artificial neural network that evolves

 view release on metacpan or  search on metacpan

lib/AI/FANN.pm  view on Meta::CPAN

XSLoader::load('AI::FANN', $VERSION);

use Exporter qw(import);

{
    my @constants = _constants();

    our %EXPORT_TAGS = ( 'all' => [ @constants ] );
    our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

    require constant;
    for my $constant (@constants) {
        constant->import($constant, $constant);
    }
}

sub num_neurons {

    @_ == 1 or croak "Usage: AI::FANN::get_neurons(self)";

    my $self = shift;
    if (wantarray) {
        map { $self->layer_num_neurons($_) } (0 .. $self->num_layers - 1);
    }
    else {
        $self->total_neurons;
    }
}

1;
__END__

 view release on metacpan or  search on metacpan

Fuzzy.pm  view on Meta::CPAN

AI::Fuzzy - Perl extension for Fuzzy Logic

=head1 SYNOPSIS

  use AI::Fuzzy;

  my $f = new AI::Fuzzy::Axis;
  my $l = new AI::Fuzzy::Label("toddler",      1, 1.5, 3.5);

  $f->addlabel("baby",        -1,   1, 2.5);
  $f->addlabel($l);
  $f->addlabel("little kid",   2,   7,  12);
  $f->addlabel("kid",          6,  10,  14);
  $f->addlabel("teenager",    12,  16,  20);
  $f->addlabel("young adult", 18,  27,  35);
  $f->addlabel("adult",       25,  50,  75);
  $f->addlabel("senior",      60,  80, 110);
  $f->addlabel("relic",      100, 150, 200);


  for (my $x = 0; $x<50; $x+=4) {
      print "$x years old => " . $f->labelvalue($x) . "\n";
  }

  $a = new AI::Fuzzy::Set( x1 => .3, x2 => .5, x3 => .8, x4 => 0, x5 => 1);
  $b = new AI::Fuzzy::Set( x5 => .3, x6 => .5, x7 => .8, x8 => 0, x9 => 1);
  print "a is: " . $a->as_string . "\n"; 
  print "b is: " . $b->as_string . "\n"; 
  
  print "a is equal to b" if ($a->equal($b));
  
  my $c = $a->complement();
  print "complement of a is: " . $c->as_string . "\n"; 
  
  $c = $a->union($b);
  print "a union b is: " . $c->as_string . "\n"; 
  
  $c = $a->intersection($b);
  print "a intersection b is: " . $c->as_string . "\n"; 

__END__

=head1 DESCRIPTION

 view release on metacpan or  search on metacpan

lib/AI/FuzzyEngine.pm  view on Meta::CPAN

package AI::FuzzyEngine;

use 5.008009;
use version 0.77; our $VERSION = version->declare('v0.2.2');

use strict;
use warnings;
use Carp;
use Scalar::Util;
use List::Util;
use List::MoreUtils;

use AI::FuzzyEngine::Variable;

sub new {
    my ($class) = @_;
    my $self = bless {}, $class;

    $self->{_variables} = [];
    return $self;
}

sub variables { @{ shift->{_variables} } };

sub and {
    my ($self, @vals) = @_;

    # PDL awareness: any element is a piddle?
    return List::Util::min(@vals) if _non_is_a_piddle(@vals);

    _check_for_PDL();
    my $vals = $self->_cat_array_of_piddles(@vals);
    return $vals->mv(-1, 0)->minimum;
}

sub or {
    my ($self, @vals) = @_;

    # PDL awareness: any element is a piddle?
    return List::Util::max(@vals) if _non_is_a_piddle(@vals);

    _check_for_PDL();
    my $vals = $self->_cat_array_of_piddles(@vals);
    return $vals->mv(-1, 0)->maximum;
}

sub not {
    my ($self, $val) = @_;
    return 1-$val;
}

sub true  { return 1 }

sub false { return 0 }

sub new_variable {
    my ($self, @pars) = @_;

    my $variable_class = $self->_class_of_variable();
    my $var = $variable_class->new($self, @pars);
    push @{$self->{_variables}}, $var;
    Scalar::Util::weaken $self->{_variables}->[-1];
    return $var;
}

sub reset {
    my ($self) = @_;
    $_->reset() for $self->variables(); 
    return $self;
}

sub _class_of_variable { 'AI::FuzzyEngine::Variable' }

sub _non_is_a_piddle {
    return List::MoreUtils::none {ref $_ eq 'PDL'} @_;
}

my $_PDL_is_imported;
sub _check_for_PDL {
    return if $_PDL_is_imported;
    die "PDL not loaded"       unless $INC{'PDL.pm'};
    die "PDL::Core not loaded" unless $INC{'PDL/Core.pm'};
    $_PDL_is_imported = 1;
}

sub _cat_array_of_piddles {
    my ($class, @vals)  = @_;

    # TODO: Rapid return if @_ == 1 (isa piddle)
    # TODO: join "-", ndims -> Schnellcheck auf gleiche Dim.

    # All elements must get piddles
    my @pdls  = map { PDL::Core::topdl($_) } @vals;

    # Get size of wrapping piddle (using a trick)
    # applying valid expansion rules for element wise operations
    my $zeros = PDL->pdl(0);
    #        v-- does not work due to threading mechanisms :-((
    # $zeros += $_ for @pdls;
    # Avoid threading!
    for my $p (@pdls) {
        croak "Empty piddles are not allowed" if $p->isempty();
        eval { $zeros = $zeros + $p->zeros(); 1
            } or croak q{Can't expand piddles to same size};
    }

    # Now, cat 'em by expanding them on the fly
    my $vals = PDL::cat( map {$_ + $zeros} @pdls );
    return $vals;
};

1;

=pod

=head1 NAME

AI::FuzzyEngine - A Fuzzy Engine, PDL aware

=head1 SYNOPSIS

=head2 Regular Perl - without PDL

    use AI::FuzzyEngine;

    # Engine (or factory) provides fuzzy logical arithmetic
    my $fe = AI::FuzzyEngine->new();

    # Disjunction:
    my $a = $fe->or ( 0.2, 0.5, 0.8, 0.7 ); # 0.8
    # Conjunction:
    my $b = $fe->and( 0.2, 0.5, 0.8, 0.7 ); # 0.2
    # Negation:
    my $c = $fe->not( 0.4 );                # 0.6
    # Always true:
    my $t = $fe->true();                    # 1.0
    # Always false:
    my $f = $fe->false();                   # 0.0

    # These functions are constitutive for the operations
    # on the fuzzy sets of the fuzzy variables:

    # VARIABLES (AI::FuzzyEngine::Variable)

    # input variables need definition of membership functions of their sets
    my $flow = $fe->new_variable( 0 => 2000,
                        small => [0, 1,  500, 1, 1000, 0                  ],
                        med   => [       400, 0, 1000, 1, 1500, 0         ],
                        huge  => [               1000, 0, 1500, 1, 2000, 1],
                   );
    my $cap  = $fe->new_variable( 0 => 1800,
                        avg   => [0, 1, 1500, 1, 1700, 0         ],
                        high  => [      1500, 0, 1700, 1, 1800, 1],
                   );
    # internal variables need sets, but no membership functions
    my $saturation = $fe->new_variable( # from => to may be ommitted
                        low   => [],
                        crit  => [],
                        over  => [],
                   );
    # But output variables need membership functions for their sets:
    my $green = $fe->new_variable( -5 => 5,
                        decrease => [-5, 1, -2, 1, 0, 0            ],
                        ok       => [       -2, 0  0, 1, 2, 0      ],
                        increase => [              0, 0, 2, 1, 5, 1],
                   );

    # Reset FuzzyEngine (resets all variables)
    $fe->reset();

    # Reset a fuzzy variable directly
    $flow->reset;

    # Membership functions can be changed via the set's variable.
    # This might be useful during parameter identification algorithms
    # Changing a function resets the respective variable.
    $flow->change_set( med => [500, 0, 1000, 1, 1500, 0] );

    # Fuzzification of input variables
    $flow->fuzzify( 600 );
    $cap->fuzzify( 1000 );

    # Membership degrees of the respective sets are now available:
    my $flow_is_small = $flow->small(); # 0.8
    my $flow_is_med   = $flow->med();   # 0.2
    my $flow_is_huge  = $flow->huge();  # 0.0

    # RULES and their application

    # a) If necessary, calculate some internal variables first. 
    # They will not be defuzzified (in fact, $saturation can't)
    # Implicit application of 'and'
    # Multiple calls to a membership function
    # are similar to 'or' operations:
    $saturation->low( $flow->small(), $cap->avg()  );
    $saturation->low( $flow->small(), $cap->high() );
    $saturation->low( $flow->med(),   $cap->high() );

    # Explicite 'or', 'and' or 'not' possible:
    $saturation->crit( $fe->or( $fe->and( $flow->med(),  $cap->avg()  ),
                                $fe->and( $flow->huge(), $cap->high() ),
                       ),
                 );
    $saturation->over( $fe->not( $flow->small() ),
                       $fe->not( $flow->med()   ),
                       $flow->huge(),
                       $cap->high(),
                 );
    $saturation->over( $flow->huge(), $fe->not( $cap->high() ) );

    # b) deduce output variable(s) (here: from internal variable $saturation)
    $green->decrease( $saturation->low()  );
    $green->ok(       $saturation->crit() );
    $green->increase( $saturation->over() );

    # All sets provide their respective membership degrees: 
    my $saturation_is_over = $saturation->over(); # This is no defuzzification!
    my $green_is_ok        = $green->ok();

    # Defuzzification ( is a matter of the fuzzy variable )
    my $delta_green = $green->defuzzify(); # -5 ... 5

=head2 Using PDL and its threading capability

    use PDL;
    use AI::FuzzyEngine;

    # (Probably a stupide example)
    my $fe        = AI::FuzzyEngine->new();

    # Declare variables as usual
    my $severity  = $fe->new_variable( 0 => 10,
                          low  => [0, 1, 3, 1, 5, 0       ],
                          high => [      3, 0, 5, 1, 10, 1],
                        );

    my $threshold = $fe->new_variable( 0 => 1,
                           low  => [0, 1, 0.2, 1, 0.8, 0,     ],
                           high => [      0.2, 0, 0.8, 1, 1, 1],
                         );
    
    my $problem   = $fe->new_variable( -0.5 => 2,
                           no  => [-0.5, 0, 0, 1, 0.5, 0, 1, 0],
                           yes => [         0, 0, 0.5, 1, 1, 1, 1.5, 1, 2, 0],
                         );

    # Input data is a pdl of arbitrary dimension
    my $data = pdl( [0, 4, 6, 10] );
    $severity->fuzzify( $data );

    # Membership degrees are piddles now:
    print 'Severity is high: ', $severity->high, "\n";
    # [0 0.5 1 1]

    # Other variables might be piddles of other dimensions,
    # but all variables must be expandible to a common 'wrapping' piddle
    # ( in this case a 4x2 matrix with 4 colums and 2 rows)
    my $level = pdl( [0.6],
                     [0.2],
                   );
    $threshold->fuzzify( $level );

    print 'Threshold is low: ', $threshold->low(), "\n";
    # [
    #  [0.33333333]
    #  [         1]
    # ]

    # Apply some rules
    $problem->yes( $severity->high,  $threshold->low );
    $problem->no( $fe->not( $problem->yes )  );

    # Fuzzy results are represented by the membership degrees of sets 
    print 'Problem yes: ', $problem->yes,  "\n";
    # [
    #  [         0 0.33333333 0.33333333 0.33333333]
    #  [         0        0.5          1          1]
    # ]

    # Defuzzify the output variables
    # Caveat: This includes some non-threadable operations up to now
    my $problem_ratings = $problem->defuzzify();
    print 'Problems rated: ', $problem_ratings;
    # [
    #  [         0 0.60952381 0.60952381 0.60952381]
    #  [         0       0.75          1          1]
    # ]

=head1 EXPORT

Nothing is exported or exportable.

=head1 DESCRIPTION

This module is yet another implementation of a fuzzy inference system.
The aim was to  be able to code rules (no string parsing),
but avoid operator overloading,
and make it possible to split calculation into multiple steps.
All intermediate results (memberships of sets of variables)
should be available.

Beginning with v0.2.0 it is PDL aware,
meaning that it can handle piddles (PDL objects)
when running the fuzzy operations.
More information on PDL can be found at L<http://pdl.perl.org/>. 

Credits to Ala Qumsieh and his L<AI::FuzzyInference>,
that showed me that fuzzy is no magic.
I learned a lot by analyzing his code,
and he provides good information and links to learn more about Fuzzy Logics.

=head2 Fuzzy stuff

The L<AI::FuzzyEngine> object defines and provides
the elementary operations for fuzzy sets.
All membership degrees of sets are values from 0 to 1.
Up to now there is no choice with regard to how to operate on sets:

=over 2

=item C<< $fe->or( ... ) >> (Disjunction)

is I<Maximum> of membership degrees

=item C<< $fe->and( ... ) >> (Conjunction)

is I<Minimum> of membership degrees

=item C<< $fe->not( $var->$set ) >> (Negation)

is I<1-degree> of membership degree

=item Aggregation of rules (Disjunction)

is I<Maximum>

=item True C<< $fe->true() >> and false C<< $fe->false() >>

are provided for convenience.

=back

Defuzzification is based on

=over 2

=item Implication

I<Clip> membership function of a set according to membership degree,
before the implicated memberships of all sets of a variable are taken for defuzzification:

=item Defuzzification

I<Centroid> of aggregated (and clipped) membership functions

=back

=head2 Public functions

Creation of an C<AI::FuzzyEngine> object by

    my $fe = AI::FuzzyEngine->new();

This function has no parameters. It provides the fuzzy methods
C<or>, C<and> and C<not>, as listed above.
If needed, I will introduce alternative fuzzy operations,
they will be configured as arguments to C<new>. 

Once built, the engine can create fuzzy variables by C<new_variable>:

    my $var = $fe->new_variable( $from => $to,
                        $name_of_set1 => [$x11, $y11, $x12, $y12, ... ],
                        $name_of_set2 => [$x21, $y21, $x22, $y22, ... ],
                        ...
                   );

Result is an L<AI::FuzzyEngine::Variable>.
The name_of_set strings are taken to assign corresponding methods
for the respective fuzzy variables.
They must be valid function identifiers.
Same name_of_set can used for different variables without conflict.
Take care:
There is no check for conflicts with predefined class methods. 

Fuzzy variables provide a method to fuzzify input values:

    $var->fuzzify( $val );

according to the defined sets and their membership functions.

The memberships of the sets of C<$var> are accessible
by the respective functions:

    my $membership_degree = $var->$name_of_set();

Membership degrees can be assigned directly (within rules for example):

    $var->$name_of_set( $membership_degree );

If multiple membership_degrees are given, they are "anded":

    $var->$name_of_set( $degree1, $degree2, ... ); # "and"

By this, simple rules can be coded directly:

    my $var_3->zzz( $var_1->xxx, $var_2->yyy, ... ); # "and"

this implements the fuzzy implication

    if $var_1->xxx and $var_2->yyy and ... then $var_3->zzz

The membership degrees of a variable's sets can be reset to undef:

    $var->reset(); # resets a variable
    $fe->reset();  # resets all variables

The fuzzy engine C<$fe> has all variables registered
that have been created by its C<new_variable> method.

A variable can be defuzzified:

    my $out_value = $var->defuzzify();

Membership functions can be replaced via a set's variable:

    $var->change_set( $name_of_set => [$x11n, $y11n, $x12n, $y12n, ... ] );

The variable will be reset when replacing a membership function
of any of its sets.
Interdependencies with other variables are not checked
(it might happen that the results of any rules are no longer valid,
so it needs some recalculations).

Sometimes internal variables are used that need neither fuzzification
nor defuzzification.
They can be created by a simplified call to C<new_variable>:

    my $var_int = $fe->new_variable( $name_of_set1 => [],
                                     $name_of_set2 => [],
                                     ...
                       );

Hence, they can not use the methods C<fuzzify> or C<defuzzify>.

Fuzzy operations are simple operations on floating values between 0 and 1:

    my $conjunction = $fe->and( $var1->xxx, $var2->yyy, ... );
    my $disjunction = $fe->or(  $var1->xxx, $var2->yyy, ... );
    my $negated     = $fe->not( $var1->zzz );

There is no magic.

A sequence of rules for the same set can be implemented as follows: 

    $var_3->zzz( $var_1->xxx, $var_2->yyy, ... );
    $var_3->zzz( $var_4->aaa, $var_5->bbb, ... );

The subsequent application of C<< $var_3->zzz(...) >>
corresponds to "or" operations (aggregation of rules).

Only a reset can reset C<$var_3>. 

=head2 PDL awareness

Membership degrees of sets might be either scalars or piddles now.

    $var_a->memb_fun_a(        5  ); # degree of memb_fun_a is a scalar
    $var_a->memb_fun_b( pdl(7, 8) ); # degree of memb_fun_b is a piddle

Empty piddles are not allowed, behaviour with bad values is not tested.

Fuzzification (hence calculating degrees) accepts piddles:

    $var_b->fuzzify( pdl([1, 2], [3, 4]) );

Defuzzification returns a piddle if any of the membership
degrees of the function's sets is a piddle:

    my $val = $var_a->defuzzify(); # $var_a returns a 1dim piddle with two elements

So do the fuzzy operations as provided by the fuzzy engine C<$fe> itself.

Any operation on more then one piddle expands those to common
dimensions, if possible, or throws a PDL error otherwise. 

The way expansion is done is best explained by code
(see C<< AI::FuzzyEngine->_cat_array_of_piddles(@pdls) >>).
Assuming all piddles are in C<@pdls>,
calculation goes as follows:

    # Get the common dimensions
    my $zeros = PDL->pdl(0);
    # Note: $zeros += $_->zeros() for @pdls does not work here
    $zeros = $zeros + $_->zeros() for @pdls;

    # Expand all piddles
    @pdls = map {$_ + $zeros} @pdls;

Defuzzification uses some heavy non-threading code,
so there might be a performance penalty for big piddles. 

=head2 Todos

=over 2

=item Add optional alternative implementations of fuzzy operations

=item More checks on input arguments and allowed method calls

=item PDL awareness: Use threading in C<< $variable->defuzzify >>

=item Divide tests into API tests and test of internal functions

=back

=head1 CAVEATS / BUGS

This is my first module.
I'm happy about feedback that helps me to learn
and improve my contributions to the Perl ecosystem.

Please report any bugs or feature requests to
C<bug-ai-fuzzyengine at rt.cpan.org>, or through
the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-FuzzyEngine>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc AI::FuzzyEngine

=head1 AUTHOR

Juergen Mueck, jmueck@cpan.org

=head1 COPYRIGHT

Copyright (c) Juergen Mueck 2013.  All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut