Result:
found more than 263 distributions - search limited to the first 2001 files matching your query
( run in 0.439 )
AE-AdHoc
view release on metacpan or search on metacpan
examples/port-probe-multi.pl view on Meta::CPAN
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
AES128
view release on metacpan or search on metacpan
my(%replace, %need, %hints, %warnings, %depends);
my $replace = 0;
my($hint, $define, $function);
sub find_api
{
my $code = shift;
$code =~ s{
/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
| "[^"\\]*(?:\\.[^"\\]*)*"
}
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
close PATCH if $patch_opened;
exit 0;
sub try_use { eval "use @_;"; return $@ eq '' }
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
return () if $seen->{$func}++;
my %s;
grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
{
$opt{quiet} and return;
my $func = shift;
my $rv = 0;
if (exists $warnings{$func} && !$given_warnings{$func}++) {
print " --- hint for $func ---\n", $hint;
}
$rv;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
ENDUSAGE
exit 2;
}
sub strip
{
my $self = do { local(@ARGV,$/)=($0); <> };
my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
$copy =~ s/^(?=\S+)/ /gms;
$self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
#if (PERL_BCDVERSION <= 0x5004005)
/* Replace: 1 */
# define PL_DBsignal DBsignal
# define PL_DBsingle DBsingle
# define PL_DBsub DBsub
# define PL_DBtrace DBtrace
# define PL_Sv Sv
# define PL_bufend bufend
# define PL_bufptr bufptr
# define PL_compiling compiling
ccstack = top_si->si_cxstack;
cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
break;
cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
}
AFS-Command
view release on metacpan or search on metacpan
lib/AFS/Command/BOS.pm view on Meta::CPAN
use AFS::Object::Instance;
our @ISA = qw(AFS::Command::Base);
our $VERSION = '1.99';
sub getdate {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub getlog {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub getrestart {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub listhosts {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub listkeys {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
return if $errors;
return $result;
}
sub listusers {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
#
# XXX -- we might want to provide parsing of the bos salvage output,
# but for now, this is a non-parsed command.
#
# sub salvage {
# my $self = shift;
# my (%args) = @_;
# my $result = AFS::Object::BosServer->new();
lib/AFS/Command/BOS.pm view on Meta::CPAN
# return if $errors;
# return $result;
# }
sub status {
my $self = shift;
my (%args) = @_;
my $result = AFS::Object::BosServer->new();
AFS-Monitor
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";
examples/Meltdown.pl view on Meta::CPAN
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.
#
examples/Meltdown.pl view on Meta::CPAN
(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";
}
AFS-PAG
view release on metacpan or search on metacpan
t/lib/Test/RRA.pm view on Meta::CPAN
# Calls plan skip_all, which will terminate the program.
#
# $description - Short description of the tests
#
# Returns: undef
sub skip_unless_author {
my ($description) = @_;
if (!$ENV{AUTHOR_TESTING}) {
plan skip_all => "$description only run for author";
}
return;
t/lib/Test/RRA.pm view on Meta::CPAN
# plan skip_all, which will terminate the program.
#
# $description - Short description of the tests
#
# Returns: undef
sub skip_unless_automated {
my ($description) = @_;
for my $env (qw(AUTOMATED_TESTING RELEASE_TESTING AUTHOR_TESTING)) {
return if $ENV{$env};
}
plan skip_all => "$description normally skipped";
t/lib/Test/RRA.pm view on Meta::CPAN
#
# $module - Name of the module to load
# @imports - Any arguments to import, possibly including a version
#
# Returns: undef
sub use_prereq {
my ($module, @imports) = @_;
# If the first import looks like a version, pass it as a bare string.
my $version = q{};
if (@imports >= 1 && $imports[0] =~ m{ \A \d+ (?: [.][\d_]+ )* \z }xms) {
AFS
view release on metacpan or search on metacpan
src/ACL/ACL.pm view on Meta::CPAN
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub new {
my ($this, $class);
# this whole construct is to please the old version from Roland
if ($_[0] =~ /AFS::ACL/) {
$this = shift;
$class = ref($this) || $this;
src/ACL/ACL.pm view on Meta::CPAN
if (defined $neg_rights) { %{$self->[1]} = %$neg_rights; }
bless $self, $class;
}
sub copy {
my $self = shift;
my $class = ref($self) || $self;
my $new = [{}, {}];
%{$new->[0]} = %{$self->[0]};
%{$new->[1]} = %{$self->[1]};
bless $new, $class;
}
sub apply {
my $self = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::setacl($path, $self, $follow);
}
sub retrieve {
my $class = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::_getacl($path, $follow);
}
sub modifyacl {
my $self = shift;
my $path = shift;
my $follow = shift;
my $newacl;
src/ACL/ACL.pm view on Meta::CPAN
AFS::setacl($path, $newacl, $follow);
}
else { return 0; }
}
sub copyacl {
my $class = shift;
my $from = shift;
my $to = shift;
my $follow = shift;
src/ACL/ACL.pm view on Meta::CPAN
$follow = 1 unless defined $follow;
if ($acl = AFS::_getacl($from, $follow)) { AFS::setacl($to, $acl, $follow); }
else { return 0; }
}
sub cleanacl {
my $class = shift;
my $path = shift;
my $follow = shift;
my $acl;
src/ACL/ACL.pm view on Meta::CPAN
if (! defined ($acl = AFS::_getacl($path, $follow))) { return 0; }
if ($acl->is_clean) { return 1; }
AFS::setacl($path, $acl, $follow);
}
sub crights {
my $class = shift;
AFS::crights(@_);
}
sub ascii2rights {
my $class = shift;
AFS::ascii2rights(@_);
}
sub rights2ascii {
my $class = shift;
AFS::rights2ascii(@_);
}
# old form DEPRECATED !!!!
sub addacl {
my $self = shift;
my $macl = shift;
foreach my $key ($macl->keys) { $self->set($key, $macl->get($key)); }
foreach my $key ($macl->nkeys) { $self->nset($key, $macl->nget($key)); }
return $self;
}
sub add {
my $self = shift;
my $acl = shift;
foreach my $user ($acl->get_users) { $self->set($user, $acl->get_rights($user)); }
foreach my $user ($acl->nget_users) { $self->nset($user, $acl->nget_rights($user)); }
return $self;
}
sub is_clean {
my $self = shift;
foreach ($self->get_users, $self->nget_users) { return 0 if (m/^-?\d+$/); }
return 1;
}
# comment Roland Schemers: I hope I don't have to debug these :-)
sub empty { $_[0] = bless [ {},{} ]; }
sub get_users { CORE::keys %{$_[0]->[0]}; }
sub length { int(CORE::keys %{$_[0]->[0]}); }
sub get_rights { ${$_[0]->[0]}{$_[1]}; }
sub exists { CORE::exists ${$_[0]->[0]}{$_[1]}; }
sub set { ${$_[0]->[0]}{$_[1]} = $_[2]; }
sub remove { delete ${$_[0]->[0]}{$_[1]}; }
sub clear { $_[0]->[0] = {}; }
sub keys { CORE::keys %{$_[0]->[0]}; } # old form: DEPRECATED !!!!
sub get { ${$_[0]->[0]}{$_[1]}; } # old form: DEPRECATED !!!!
sub del { delete ${$_[0]->[0]}{$_[1]}; } # old form: DEPRECATED !!!!
# comment Roland Schemers: same for negative entries
sub nget_users { CORE::keys %{$_[0]->[1]}; }
sub nlength { int(CORE::keys %{$_[0]->[1]}); }
sub nget_rights { ${$_[0]->[1]}{$_[1]}; }
sub nexists { CORE::exists ${$_[0]->[1]}{$_[1]}; }
sub nset { ${$_[0]->[1]}{$_[1]} = $_[2]; }
sub nremove { delete ${$_[0]->[1]}{$_[1]}; }
sub nclear { $_[0]->[1] = {}; }
sub nkeys { CORE::keys %{$_[0]->[1]}; } # old form: DEPRECATED !!!!
sub nget { ${$_[0]->[1]}{$_[1]}; } # old form: DEPRECATED !!!!
sub ndel { delete ${$_[0]->[1]}{$_[1]}; } # old form: DEPRECATED !!!!
1;
AHA
view release on metacpan or search on metacpan
example/lava_lamp.pl view on Meta::CPAN
store_status($status);
# ================================================================================================
sub info {
if (open (F,">>$LOG_FILE")) {
print F scalar(localtime),": ",join("",@_),"\n";
close F;
}
}
# List the status file
sub list {
my $status = retrieve $STATUS_FILE;
my $hist_entries = $status->{hist};
for my $hist (@{$hist_entries}) {
print scalar(localtime($hist->[0])),": ",$hist->[1] ? "On " : "Off"," -- ",$hist->[2]," : ",$hist->[3],"\n";
}
print "Content: ",Dumper($status) if $DEBUG;
return 1;
}
# Create empty status file if necessary
sub init_status {
my $status = {};
$status->{hist} = [];
if (! -e $STATUS_FILE) {
store $status,$STATUS_FILE;
}
}
sub log_manual_switch {
my $status = shift;
my $is_on = shift;
my $last = get_last_entry($status);
if ($last && $is_on != $last->[1]) {
# Change has been manualy in between the interval. Add an approx history entry
update_status($status,$is_on,"manual",estimate_manual_time($status));
}
}
sub update_status {
my $status = shift;
my $is_on = shift;
my $mode = shift;
my $time = shift || time;
my $label = shift;
my $hist = $status->{hist};
push @{$hist},[ $time, $is_on, $mode, $label];
info($is_on ? "On " : "Off"," -- ",$mode, $label ? ": " . $label : "");
}
sub estimate_manual_time {
my $status = shift;
my $last_hist = get_last_entry($status);
if ($last_hist) {
my $now = time;
my $last = $last_hist->[0];
example/lava_lamp.pl view on Meta::CPAN
} else {
return time - $MANUAL_DELTA;
}
}
sub get_last_entry {
my $status = shift;
if ($status) {
my $hist = $status->{hist};
return $hist && @$hist ? $hist->[$#{$hist}] : undef;
}
return undef;
}
sub check_on_period {
my ($min,$hour,$wd) = (localtime)[1,2,6];
my $day = qw(Sun Mon Tue Wed Thu Fri Sat)[$wd];
my $periods = $LAMP_ON_TIME_TABLE->{$day};
for my $period (@$periods) {
my ($low,$high) = @$period;
example/lava_lamp.pl view on Meta::CPAN
return 1 if $m >= ($lh * 60 + $lm) && $m <= ($hh * 60 + $hm);
}
return 0;
}
sub lamp_on_for_too_long {
my $status = shift;
# Check if the lamp was on for more than max time in the duration now - max
# time + 1 hour
my $current = time;
example/lava_lamp.pl view on Meta::CPAN
} else {
return 0;
}
}
sub read_config_file {
my $file = shift;
open (F,$file) || die "Cannot read config file ",$file,": ",$!;
my $config = join "",<F>;
close F;
eval $config;
die "Error evaluating $config: ",$@ if $@;
}
sub delete_trigger {
my $status = shift;
delete $status->{trigger_mark};
delete $status->{trigger_label};
}
sub set_trigger {
my $status = shift;
my $label = shift;
$status->{trigger_mark} = 1;
$status->{trigger_label} = $label;
}
sub has_trigger {
return shift->{trigger_mark};
}
sub trigger_label {
return shift->{trigger_label};
}
# ====================================================
# Status file handling including locking
my $status_fh;
sub fetch_status {
open ($status_fh,"+<$STATUS_FILE") || die "Cannot open $STATUS_FILE: $!";
$status = fd_retrieve($status_fh) || die "Cannot read $STATUS_FILE: $!";
flock($status_fh,2);
return $status;
}
sub store_status {
my $status = shift;
# Truncate history if necessary
truncate_hist($status);
# Store status and unlock
seek($status_fh, 0, 0); truncate($status_fh, 0);
store_fd $status,$status_fh;
close $status_fh;
}
sub truncate_hist {
my $status = shift;
my $hist = $status->{hist};
my $len = scalar(@$hist);
splice @$hist,0,$len - $MAX_HISTORY_ENTRIES if $len > $MAX_HISTORY_ENTRIES;
example/lava_lamp.pl view on Meta::CPAN
}
# ==========================================================================
# Customize the following call and class in order to use a different
# switch than AVM AHA's
sub open_lamp {
my $config = shift;
my $name = shift || $config->{id};
return new Lamp($name,
$config->{host},
$config->{password},
$config->{user});
}
sub close_lamp {
my $lamp = shift;
$lamp->logout();
}
package Lamp;
use AHA;
sub new {
my $class = shift;
my $name = shift;
my $host = shift;
my $password = shift;
my $user = shift;
example/lava_lamp.pl view on Meta::CPAN
switch => $switch
};
return bless $self,$class;
}
sub is_on {
shift->{switch}->is_on();
}
sub on {
shift->{switch}->on();
}
sub off {
shift->{switch}->off();
}
sub logout {
shift->{aha}->logout();
}
=head1 LICENSE
AI-ANN
view release on metacpan or search on metacpan
examples/benchmark.pl view on Meta::CPAN
}
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)} });
AI-ActivationFunctions
view release on metacpan or search on metacpan
AI-ActivationFunctions-0.01/AI-ActivationFunctions-0.01/lib/AI/ActivationFunctions.pm view on Meta::CPAN
advanced => [qw(elu swish gelu)],
derivatives => [qw(relu_derivative sigmoid_derivative)],
);
# ReLU
sub relu {
my ($x) = @_;
return $x > 0 ? $x : 0;
}
# PReLU
sub prelu {
my ($x, $alpha) = @_;
$alpha //= 0.01;
return $x > 0 ? $x : $alpha * $x;
}
# Leaky ReLU
sub leaky_relu {
my ($x) = @_;
return prelu($x, 0.01);
}
# Sigmoid
sub sigmoid {
my ($x) = @_;
return 1 / (1 + exp(-$x));
}
# Tanh
sub tanh {
my ($x) = @_;
my $e2x = exp(2 * $x);
return ($e2x - 1) / ($e2x + 1);
}
# Softmax para array
sub softmax {
my ($array) = @_;
return undef unless ref($array) eq 'ARRAY';
# Encontrar máximo
AI-ActivationFunctions-0.01/AI-ActivationFunctions-0.01/lib/AI/ActivationFunctions.pm view on Meta::CPAN
# Normalizar
return [map { $_ / $sum } @exp_vals];
}
# ELU (Exponential Linear Unit)
sub elu {
my ($x, $alpha) = @_;
$alpha //= 1.0;
return $x > 0 ? $x : $alpha * (exp($x) - 1);
}
# Swish (Google)
sub swish {
my ($x) = @_;
return $x * sigmoid($x);
}
# GELU (Gaussian Error Linear Unit)
sub gelu {
my ($x) = @_;
return 0.5 * $x * (1 + tanh(sqrt(2/3.141592653589793) *
($x + 0.044715 * $x**3)));
}
# Derivada da ReLU
sub relu_derivative {
my ($x) = @_;
return $x > 0 ? 1 : 0;
}
# Derivada da Sigmoid
sub sigmoid_derivative {
my ($x) = @_;
my $s = sigmoid($x);
return $s * (1 - $s);
}
AI-Anthropic
view release on metacpan or search on metacpan
examples/basic.pl view on Meta::CPAN
$claude->chat(
messages => [
{ role => 'user', content => 'Count from 1 to 5, one number per line.' },
],
stream => sub {
my ($chunk) = @_;
print $chunk;
},
);
say "\n";
AI-CBR
view release on metacpan or search on metacpan
lib/AI/CBR/Case.pm view on Meta::CPAN
=back
=cut
sub new {
my ($class, %attributes) = @_;
# set default weights if unspecified
foreach (keys %attributes) {
$attributes{$_}->{weight} = $DEFAULT_WEIGHT unless defined $attributes{$_}->{weight};
lib/AI/CBR/Case.pm view on Meta::CPAN
This will overwrite existing values, and can thus be used as a faster method
for generating new cases with the same specification.
=cut
sub set_values {
my ($self, %values) = @_;
foreach (keys %values) {
$self->{$_}->{value} = $values{$_};
}
}
AI-CRM114
view release on metacpan or search on metacpan
lib/AI/CRM114.pm view on Meta::CPAN
our @ISA = qw();
our $VERSION = '0.01';
sub new {
my $class = shift;
my $self = { cmd => 'crm', @_ };
bless $self, $class;
return $self;
}
sub classify {
my ($self, $flags, $files, $text) = @_;
my $code = qq#-{
isolate (:stats:);
classify <@$flags> ( @$files ) (:stats:);
lib/AI/CRM114.pm view on Meta::CPAN
/Best match to file \S+ \((.*?)\) +prob: *([0-9.]+) +pR: *([0-9.-]+)/;
wantarray ? ($file, $prob, $pr) : $file;
}
sub learn {
my ($self, $flags, $file, $text) = @_;
my $code = qq#-{ learn <@$flags> ( $file ) }#;
my $o = "";
AI-Calibrate
view release on metacpan or search on metacpan
lib/AI/Calibrate.pm view on Meta::CPAN
how this structure is interpreted. You can pass this structure to the
B<score_prob> function, along with a new score, to get a probability.
=cut
sub calibrate {
my($data, $sorted) = @_;
if (DEBUG) {
print "Original data:\n";
for my $pair (@$data) {
lib/AI/Calibrate.pm view on Meta::CPAN
return \@result;
}
sub PAV {
my ( $result ) = @_;
for ( my $i = 0; $i < @$result - 1; $i++ ) {
if ( $result->[$i][PROB] < $result->[ $i + 1 ][PROB] ) {
$result->[$i][PROB] =
lib/AI/Calibrate.pm view on Meta::CPAN
}
}
}
}
sub print_vector {
my($vec) = @_;
for my $pair (@$vec) {
print join(", ", @$pair), "\n";
}
}
sub flatten {
my ( $vec, $start, $len ) = @_;
if (DEBUG) {
print "Flatten called on vec, $start, $len\n";
print "Vector before: \n";
print_vector($vec);
lib/AI/Calibrate.pm view on Meta::CPAN
print "Estimated probability: $prob\n";
}
=cut
sub score_prob {
my($calibrated, $score) = @_;
my $last_prob = 1.0;
for my $tuple (@$calibrated) {
lib/AI/Calibrate.pm view on Meta::CPAN
shows.
=back
=cut
sub print_mapping {
my($calibrated) = @_;
my $last_bound = 1.0;
for my $tuple (@$calibrated) {
my($bound, $prob) = @$tuple;
printf("%0.3f > SCORE >= %0.3f prob = %0.3f\n",
AI-Categorizer
view release on metacpan or search on metacpan
lib/AI/Categorizer.pm view on Meta::CPAN
delayed => 1 },
collection => { class => 'AI::Categorizer::Collection::Files',
delayed => 1 },
);
sub new {
my $package = shift;
my %args = @_;
my %defaults;
if (exists $args{data_root}) {
$defaults{training_set} = File::Spec->catfile($args{data_root}, 'training');
lib/AI/Categorizer.pm view on Meta::CPAN
}
return $package->SUPER::new(%defaults, %args);
}
#sub dump_parameters {
# my $p = shift()->SUPER::dump_parameters;
# delete $p->{stopwords} if $p->{stopword_file};
# return $p;
#}
sub knowledge_set { shift->{knowledge_set} }
sub learner { shift->{learner} }
# Combines several methods in one sub
sub run_experiment {
my $self = shift;
$self->scan_features;
$self->read_training_set;
$self->train;
$self->evaluate_test_set;
print $self->stats_table;
}
sub scan_features {
my $self = shift;
return unless $self->knowledge_set->scan_first;
$self->knowledge_set->scan_features( path => $self->{training_set} );
$self->knowledge_set->save_features( "$self->{progress_file}-01-features" );
}
sub read_training_set {
my $self = shift;
$self->knowledge_set->restore_features( "$self->{progress_file}-01-features" )
if -e "$self->{progress_file}-01-features";
$self->knowledge_set->read( path => $self->{training_set} );
$self->_save_progress( '02', 'knowledge_set' );
return $self->knowledge_set;
}
sub train {
my $self = shift;
$self->_load_progress( '02', 'knowledge_set' );
$self->learner->train( knowledge_set => $self->{knowledge_set} );
$self->_save_progress( '03', 'learner' );
return $self->learner;
}
sub evaluate_test_set {
my $self = shift;
$self->_load_progress( '03', 'learner' );
my $c = $self->create_delayed_object('collection', path => $self->{test_set} );
$self->{experiment} = $self->learner->categorize_collection( collection => $c );
$self->_save_progress( '04', 'experiment' );
return $self->{experiment};
}
sub stats_table {
my $self = shift;
$self->_load_progress( '04', 'experiment' );
return $self->{experiment}->stats_table;
}
sub progress_file {
shift->{progress_file};
}
sub verbose {
shift->{verbose};
}
sub _save_progress {
my ($self, $stage, $node) = @_;
return unless $self->{progress_file};
my $file = "$self->{progress_file}-$stage-$node";
warn "Saving to $file\n" if $self->{verbose};
$self->{$node}->save_state($file);
}
sub _load_progress {
my ($self, $stage, $node) = @_;
return unless $self->{progress_file};
my $file = "$self->{progress_file}-$stage-$node";
warn "Loading $file\n" if $self->{verbose};
$self->{$node} = $self->contained_class($node)->restore_state($file);
AI-Chat
view release on metacpan or search on metacpan
lib/AI/Chat.pm view on Meta::CPAN
$VERSION = eval $VERSION;
my $http = HTTP::Tiny->new;
# Create Chat object
sub new {
my $class = shift;
my %attr = @_;
$attr{'error'} = '';
lib/AI/Chat.pm view on Meta::CPAN
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'
};
}
# Get a reply from a single prompt
sub prompt {
my ($self, $prompt, $temperature) = @_;
$self->{'error'} = '';
unless ($prompt) {
$self->{'error'} = "Missing prompt calling 'prompt' method";
lib/AI/Chat.pm view on Meta::CPAN
return $self->chat(\@messages, $temperature);
}
# Get a reply from a full chat
sub chat {
my ($self, $chat, $temperature) = @_;
if (ref($chat) ne 'ARRAY') {
$self->{'error'} = 'chat method requires an arrayref';
return undef;
AI-Classifier-Japanese
view release on metacpan or search on metacpan
lib/AI/Classifier/Japanese.pm view on Meta::CPAN
use Text::MeCab;
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 = [];
lib/AI/Classifier/Japanese.pm view on Meta::CPAN
$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();
AI-Classifier
view release on metacpan or search on metacpan
lib/AI/Classifier/Text.pm view on Meta::CPAN
use 5.010;
use Moose;
use MooseX::Storage;
use AI::Classifier::Text::Analyzer;
use Module::Load (); # don't overwrite our sub load() with Module::Load::load()
with Storage(format => 'Storable', io => 'File');
has classifier => (is => 'ro', required => 1 );
has analyzer => ( is => 'ro', default => sub{ AI::Classifier::Text::Analyzer->new() } );
# for store/load only, don't touch unless you really know what you're doing
has classifier_class => (is => 'bare');
before store => sub {
my $self = shift;
$self->{classifier_class} = $self->classifier->meta->name;
};
around load => sub {
my ($orig, $class) = (shift, shift);
my $self = $class->$orig(@_);
Module::Load::load($self->{classifier_class});
return $self;
};
sub classify {
my( $self, $text, $features ) = @_;
return $self->classifier->classify( $self->analyzer->analyze( $text, $features ) );
}
__PACKAGE__->meta->make_immutable;
AI-CleverbotIO
view release on metacpan or search on metacpan
lib/AI/CleverbotIO.pm view on Meta::CPAN
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',
};
},
lib/AI/CleverbotIO.pm view on Meta::CPAN
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,
lib/AI/CleverbotIO.pm view on Meta::CPAN
$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 = (
lib/AI/CleverbotIO.pm view on Meta::CPAN
$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));
lib/AI/CleverbotIO.pm view on Meta::CPAN
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;
AI-ConfusionMatrix
view release on metacpan or search on metacpan
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
use strict;
use Tie::File;
# ABSTRACT: Make a confusion matrix
sub makeConfusionMatrix {
my ($matrix, $file, $delem) = @_;
unless(defined $delem) {
$delem = ',';
}
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
);
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;
lib/AI/ConfusionMatrix.pm view on Meta::CPAN
stats => \%stats,
totals => \%totals
);
}
sub _findIndex {
my ($string, $array) = @_;
for (0 .. @$array - 1) {
return $_ + 1 if ($string eq @{$array}[$_]);
}
}
AI-DecisionTree
view release on metacpan or search on metacpan
lib/AI/DecisionTree.pm view on Meta::CPAN
use AI::DecisionTree::Instance;
use Carp;
use vars qw(@ISA);
sub new {
my $package = shift;
return bless {
noise_mode => 'fatal',
prune => 1,
purge => 1,
lib/AI/DecisionTree.pm view on Meta::CPAN
instances => [],
name_gen => 0,
}, $package;
}
sub nodes { $_[0]->{nodes} }
sub noise_mode { $_[0]->{noise_mode} }
sub depth { $_[0]->{depth} }
sub add_instance {
my ($self, %args) = @_;
croak "Missing 'attributes' parameter" unless $args{attributes};
croak "Missing 'result' parameter" unless defined $args{result};
$args{name} = $self->{name_gen}++ unless exists $args{name};
lib/AI/DecisionTree.pm view on Meta::CPAN
$_ ||= 0 foreach @attributes;
push @{$self->{instances}}, AI::DecisionTree::Instance->new(\@attributes, _hlookup($self->{results}, $args{result}), $args{name});
}
sub _hlookup {
$_[0] ||= {}; # Autovivify as a hash
my ($hash, $key) = @_;
unless (exists $hash->{$key}) {
$hash->{$key} = 1 + keys %$hash;
}
return $hash->{$key};
}
sub _create_lookup_hashes {
my $self = shift;
my $h = $self->{results};
$self->{results_reverse} = [ undef, sort {$h->{$a} <=> $h->{$b}} keys %$h ];
foreach my $attr (keys %{$self->{attribute_values}}) {
my $h = $self->{attribute_values}{$attr};
$self->{attribute_values_reverse}{$attr} = [ undef, sort {$h->{$a} <=> $h->{$b}} keys %$h ];
}
}
sub train {
my ($self, %args) = @_;
if (not @{ $self->{instances} }) {
croak "Training data has been purged, can't re-train" if $self->{tree};
croak "Must add training instances before calling train()";
}
lib/AI/DecisionTree.pm view on Meta::CPAN
$self->prune_tree if $self->{prune};
$self->do_purge if $self->purge;
return 1;
}
sub do_purge {
my $self = shift;
delete @{$self}{qw(instances attribute_values attribute_values_reverse results results_reverse)};
}
sub copy_instances {
my ($self, %opt) = @_;
croak "Missing 'from' parameter to copy_instances()" unless exists $opt{from};
my $other = $opt{from};
croak "'from' parameter is not a decision tree" unless UNIVERSAL::isa($other, __PACKAGE__);
lib/AI/DecisionTree.pm view on Meta::CPAN
$self->{$_} = $other->{$_};
}
$self->_create_lookup_hashes;
}
sub set_results {
my ($self, $hashref) = @_;
foreach my $instance (@{$self->{instances}}) {
my $name = $instance->name;
croak "No result given for instance '$name'" unless exists $hashref->{$name};
$instance->set_result( $self->{results}{ $hashref->{$name} } );
}
}
sub instances { $_[0]->{instances} }
sub purge {
my $self = shift;
$self->{purge} = shift if @_;
return $self->{purge};
}
lib/AI/DecisionTree.pm view on Meta::CPAN
# $attr_value2 => $node2, ... }
# }
# or
# { result => $result }
sub _expand_node {
my ($self, %args) = @_;
my $instances = $args{instances};
print STDERR '.' if $self->{verbose};
$self->{depth} = $self->{curr_depth} if $self->{curr_depth} > $self->{depth};
lib/AI/DecisionTree.pm view on Meta::CPAN
}
return \%node;
}
sub best_attr {
my ($self, $instances) = @_;
# 0 is a perfect score, entropy(#instances) is the worst possible score
my ($best_score, $best_attr) = (@$instances * $self->entropy( map $_->result_int, @$instances ), undef);
lib/AI/DecisionTree.pm view on Meta::CPAN
}
return $best_attr;
}
sub entropy2 {
shift;
my ($counts, $total) = @_;
# Entropy is defined with log base 2 - we just divide by log(2) at the end to adjust.
my $sum = 0;
$sum += $_ * log($_) foreach values %$counts;
return +(log($total) - $sum/$total)/log(2);
}
sub entropy {
shift;
my %count;
$count{$_}++ foreach @_;
lib/AI/DecisionTree.pm view on Meta::CPAN
my $sum = 0;
$sum += $_ * log($_) foreach values %count;
return +(log(@_) - $sum/@_)/log(2);
}
sub prune_tree {
my $self = shift;
# We use a minimum-description-length approach. We calculate the
# score of each node:
# n = number of nodes below
lib/AI/DecisionTree.pm view on Meta::CPAN
my $r = keys %{ $self->{results} };
my $i = $self->{tree}{instances};
my $exception_cost = log($r) * log($i) / log(2)**2;
# Pruning can turn a branch into a leaf
my $maybe_prune = sub {
my ($self, $node) = @_;
return unless $node->{children}; # Can't prune leaves
my $nodes_below = $self->nodes_below($node);
my $tree_cost = 2 * $nodes_below - 1; # $edges_below == $nodes_below - 1
lib/AI/DecisionTree.pm view on Meta::CPAN
};
$self->_traverse($maybe_prune);
}
sub exceptions {
my ($self, $node) = @_;
return $node->{exceptions} if exists $node->{exeptions};
my $count = 0;
if ( exists $node->{result} ) {
lib/AI/DecisionTree.pm view on Meta::CPAN
}
return $node->{exceptions} = $count;
}
sub nodes_below {
my ($self, $node) = @_;
return $node->{nodes_below} if exists $node->{nodes_below};
my $count = 0;
$self->_traverse( sub {$count++}, $node );
return $node->{nodes_below} = $count - 1;
}
# This is *not* for external use, I may change it.
sub _traverse {
my ($self, $callback, $node, $parent, $node_name) = @_;
$node ||= $self->{tree};
ref($callback) ? $callback->($self, $node, $parent, $node_name) : $self->$callback($node, $parent, $node_name);
lib/AI/DecisionTree.pm view on Meta::CPAN
foreach my $child ( keys %{$node->{children}} ) {
$self->_traverse($callback, $node->{children}{$child}, $node, $child);
}
}
sub get_result {
my ($self, %args) = @_;
croak "Missing 'attributes' or 'callback' parameter" unless $args{attributes} or $args{callback};
$self->train unless $self->{tree};
my $tree = $self->{tree};
lib/AI/DecisionTree.pm view on Meta::CPAN
$tree = $tree->{children}{ $instance_val }
or return undef;
}
}
sub as_graphviz {
my ($self, %args) = @_;
my $colors = delete $args{leaf_colors} || {};
require GraphViz;
my $g = GraphViz->new(%args);
my $id = 1;
my $add_edge = sub {
my ($self, $node, $parent, $node_name) = @_;
# We use stringified reference names for node names, as a convenient hack.
if ($node->{split_on}) {
$g->add_node( "$node",
lib/AI/DecisionTree.pm view on Meta::CPAN
$self->_traverse( $add_edge );
return $g;
}
sub rule_tree {
my $self = shift;
my ($tree) = @_ ? @_ : $self->{tree};
# build tree:
# [ question, { results => [ question, { ... } ] } ]
lib/AI/DecisionTree.pm view on Meta::CPAN
map { $_ => $self->rule_tree($tree->{children}{$_}) } keys %{$tree->{children}},
}
];
}
sub rule_statements {
my $self = shift;
my ($stmt, $tree) = @_ ? @_ : ('', $self->{tree});
return("$stmt -> '$tree->{result}'") if exists $tree->{result};
my @out;
lib/AI/DecisionTree.pm view on Meta::CPAN
return @out;
}
### Some instance accessor stuff:
sub _result {
my ($self, $instance) = @_;
my $int = $instance->result_int;
return $self->{results_reverse}[$int];
}
sub _delete_value {
my ($self, $instance, $attr) = @_;
my $val = $self->_value($instance, $attr);
return unless defined $val;
$instance->set_value($self->{attributes}{$attr}, 0);
return $val;
}
sub _value {
my ($self, $instance, $attr) = @_;
return unless exists $self->{attributes}{$attr};
my $val_int = $instance->value_int($self->{attributes}{$attr});
return $self->{attribute_values_reverse}{$attr}[$val_int];
}
AI-Embedding
view release on metacpan or search on metacpan
lib/AI/Embedding.pm view on Meta::CPAN
$VERSION = eval $VERSION;
my $http = HTTP::Tiny->new;
# Create Embedding object
sub new {
my $class = shift;
my %attr = @_;
$attr{'error'} = '';
lib/AI/Embedding.pm view on Meta::CPAN
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'},
lib/AI/Embedding.pm view on Meta::CPAN
# 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'});
lib/AI/Embedding.pm view on Meta::CPAN
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'});
lib/AI/Embedding.pm view on Meta::CPAN
return $response if defined $verbose;
return undef;
}
# Return Test Embedding
sub test_embedding {
my ($self, $text, $dimension) = @_;
$self->{'error'} = '';
$dimension = 1536 unless defined $dimension;
lib/AI/Embedding.pm view on Meta::CPAN
}
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;
lib/AI/Embedding.pm view on Meta::CPAN
}
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) {
lib/AI/Embedding.pm view on Meta::CPAN
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;
AI-Evolve-Befunge
view release on metacpan or search on metacpan
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
id - assign it an id, default is to call new_popid() (see below).
host - the hostname, default is $ENV{HOST}.
=cut
sub new {
my $self = bless({}, shift);
my %args = @_;
my $usage = 'Usage: AI::Evolve::Befunge::Blueprint->new(code => "whatever", dimensions => 4, [, id => 2, host => "localhost", fitness => 5]);\n';
croak $usage unless exists $args{code};
croak $usage unless exists $args{dimensions};
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
object. The text representation was likely created by L</as_string>,
below.
=cut
sub new_from_string {
my ($package, $line) = @_;
return undef unless defined $line;
chomp $line;
if($line =~ /^\[I(-?\d+) D(\d+) F(\d+) H([^\]]+)\](.+)/) {
my ($id, $dimensions, $fitness, $host, $code) = ($1, $2, $3, $4, $5);
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
a results file (or a migration file), returns a Blueprint object.
Calls L</new_from_string> to do the dirty work.
=cut
sub new_from_file {
my ($package, $file) = @_;
return $package->new_from_string($file->getline);
}
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
sticking into a results file, or migrating to another node. See
L</new_from_string> above.
=cut
sub as_string {
my $self = shift;
my $rv =
"[I$$self{id} D$$self{dims} F$$self{fitness} H$$self{host}]";
$rv .= $$self{code};
$rv .= "\n";
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
Return a unique identifier.
=cut
sub new_popid :Export(:DEFAULT) {
$_popid = 0 unless defined $_popid;
return $_popid++;
}
lib/AI/Evolve/Befunge/Blueprint.pm view on Meta::CPAN
when a new process reads a results file, to keep node identifiers
unique across runs.
=cut
sub set_popid :Export(:DEFAULT) {
$_popid = shift;
}
}
new_popid();
AI-ExpertSystem-Advanced
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
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;
}
inc/Module/Install.pm view on Meta::CPAN
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
$MAIN = $self;
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
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 ) {
inc/Module/Install.pm view on Meta::CPAN
$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};
inc/Module/Install.pm view on Meta::CPAN
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};
}
inc/Module/Install.pm view on Meta::CPAN
}
$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});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# 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]): $!";
inc/Module/Install.pm view on Meta::CPAN
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]): $!";
inc/Module/Install.pm view on Meta::CPAN
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;
inc/Module/Install.pm view on Meta::CPAN
} $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
AI-ExpertSystem-Simple
view release on metacpan or search on metacpan
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
use AI::ExpertSystem::Simple::Knowledge;
use AI::ExpertSystem::Simple::Goal;
our $VERSION = '1.2';
sub new {
my ($class) = @_;
die "Simple->new() takes no arguments" if scalar(@_) != 1;
my $self = {};
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$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}}) {
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$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 $@;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
} else {
die "Simple->load() unable to use file";
}
}
sub _goal {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$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];
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
}
eval { $t->purge(); }
}
sub _question {
my ($self, $t, $node) = @_;
my $attribute = undef;
my $text = undef;
my @responses = ();
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$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();
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
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 = ();
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
$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();
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
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;
AI-FANN-Evolving
view release on metacpan or search on metacpan
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Constructor requires 'file', or 'data' and 'neurons' arguments. Optionally takes
'connection_rate' argument for sparse topologies. Returns a wrapper around L<AI::FANN>.
=cut
sub new {
my $class = shift;
my %args = @_;
my $self = {};
bless $self, $class;
$self->_init(%args);
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Uses the object as a template for the properties of the argument, e.g.
$ann1->template($ann2) applies the properties of $ann1 to $ann2
=cut
sub template {
my ( $self, $other ) = @_;
# copy over the simple properties
$log->debug("copying over simple properties");
my %scalar_properties = __PACKAGE__->_scalar_properties;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
$ann1->recombine($ann2,0.5) means that on average half of the object properties are
exchanged between $ann1 and $ann2
=cut
sub recombine {
my ( $self, $other, $rr ) = @_;
# recombine the simple properties
my %scalar_properties = __PACKAGE__->_scalar_properties;
for my $prop ( keys %scalar_properties ) {
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Mutates the object by the provided mutation rate
=cut
sub mutate {
my ( $self, $mu ) = @_;
$log->debug("going to mutate at rate $mu");
# mutate the simple properties
$log->debug("mutating scalar properties");
lib/AI/FANN/Evolving.pm view on Meta::CPAN
}
}
return $self;
}
sub _mutate_double {
my ( $value, $mu ) = @_;
my $scale = 1 + ( rand( 2 * $mu ) - $mu );
return $value * $scale;
}
sub _mutate_int {
my ( $value, $mu ) = @_;
if ( rand(1) < $mu ) {
my $inc = ( int(rand(2)) * 2 ) - 1;
while( ( $value < 0 ) xor ( ( $value + $inc ) < 0 ) ) {
$inc = ( int(rand(2)) * 2 ) - 1;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
return $value + $inc;
}
return $value;
}
sub _mutate_enum {
my ( $enum_name, $value, $mu ) = @_;
if ( rand(1) < $mu ) {
my ($newval) = shuffle grep { $_ != $value } values %{ $enum{$enum_name} };
$value = $newval if defined $newval;
}
return $value;
}
sub _list_properties {
(
# cascade_activation_functions => 'activationfunc',
cascade_activation_steepnesses => \&_mutate_double,
)
}
sub _layer_properties {
(
# neuron_activation_function => 'activationfunc',
# neuron_activation_steepness => \&_mutate_double,
)
}
sub _scalar_properties {
(
training_algorithm => 'train',
train_error_function => 'errorfunc',
train_stop_function => 'stopfunc',
learning_rate => \&_mutate_double,
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter to influence default ANN configuration
=cut
sub defaults {
my $self = shift;
my %args = @_;
for my $key ( keys %args ) {
$log->info("setting $key to $args{$key}");
if ( $key eq 'activation_function' ) {
lib/AI/FANN/Evolving.pm view on Meta::CPAN
$default{$key} = $args{$key};
}
return %default;
}
sub _init {
my $self = shift;
my %args = @_;
for ( qw(error epochs train_type epoch_printfreq neuron_printfreq neurons activation_function) ) {
$self->{$_} = $args{$_} // $default{$_};
}
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Clones the object
=cut
sub clone {
my $self = shift;
$log->debug("cloning...");
# we delete the reference here so we can use
# Algorithm::Genetic::Diploid::Base's cloning method, which
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Trains the AI on the provided data object
=cut
sub train {
my ( $self, $data ) = @_;
if ( $self->train_type eq 'cascade' ) {
$log->debug("cascade training");
# set learning curve
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the error rate. Default is 0.0001
=cut
sub error {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting error threshold to $value");
return $self->{'error'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the number of training epochs, default is 500000
=cut
sub epochs {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting training epochs to $value");
return $self->{'epochs'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the number of epochs after which progress is printed. default is 1000
=cut
sub epoch_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting epoch printfreq to $value");
return $self->{'epoch_printfreq'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the number of neurons. Default is 15
=cut
sub neurons {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neurons to $value");
return $self->{'neurons'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the number of cascading neurons after which progress is printed.
default is 10
=cut
sub neuron_printfreq {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting neuron printfreq to $value");
return $self->{'neuron_printfreq'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
Getter/setter for the training type: 'cascade' or 'ordinary'. Default is ordinary
=cut
sub train_type {
my $self = shift;
if ( @_ ) {
my $value = lc shift;
$log->debug("setting train type to $value");
return $self->{'train_type'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
=back
=cut
sub activation_function {
my $self = shift;
if ( @_ ) {
my $value = shift;
$log->debug("setting activation function to $value");
return $self->{'activation_function'} = $value;
lib/AI/FANN/Evolving.pm view on Meta::CPAN
# this is here so that we can trap method calls that need to be
# delegated to the FANN object. at this point we're not even
# going to care whether the FANN object implements these methods:
# if it doesn't we get the normal error for unknown methods, which
# the user then will have to resolve.
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
$method =~ s/.+://;
# ignore all caps methods
AI-FANN
view release on metacpan or search on metacpan
lib/AI/FANN.pm view on Meta::CPAN
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) {
AI-Fuzzy
view release on metacpan or search on metacpan
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
package AI::Fuzzy::Axis;
use AI::Fuzzy::Label;
## Container for Fuzzy Labels ####
sub new {
my ($class) = @_;
my $self = {};
$self->{labels} = {};
bless $self, $class;
return $self;
}
sub addlabel {
# adds a label for a range of values..
my ($self, $label, $low, $mid, $high) = @_;
if ($label->can("name") ) {
$self->{labels}->{$label->name} = $label;
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
return $self->{labels}->{$label};
}
sub applicability {
# this function should be called something else..
# calculates to what degree $label applies to a $value
my ($self, $value, $label) = @_;
my $membership = 0;
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
return $label->applicability($value) if ($label->can("applicability"));
return undef unless ( exists $self->{labels}->{$label} );
return $self->{labels}->{$label}->applicability($value);
}
sub label {
# returns a label associated with this text
my ($self, $name) = @_;
return $self->{labels}->{$name};
}
sub labelvalue {
# returns a label associated with this value
my ($self, $value) = @_;
my $label;
my %weight;
my $total_weight = 0;
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
return 0;
}
sub range {
# returns a list of sorted labels
my ($self) = @_;
my $l = $self->{labels};
return sort { $a <=> $b } values %{$l};
}
sub lessthan {
my ($self, $labela, $labelb) = @_;
if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
my $la = $self->{labels}->{$labela};
my $lb = $self->{labels}->{$labelb};
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
} else {
return undef;
}
}
sub lessequal {
my ($self, $labela, $labelb) = @_;
if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
my $la = $self->{labels}->{$labela};
my $lb = $self->{labels}->{$labelb};
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
} else {
return undef;
}
}
sub greaterthan {
my ($self, $labela, $labelb) = @_;
if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
my $la = $self->{labels}->{$labela};
my $lb = $self->{labels}->{$labelb};
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
return $la->greaterthan($lb);
} else {
return undef;
}
}
sub greaterequal {
my ($self, $labela, $labelb) = @_;
if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb} ) {
my $la = $self->{labels}->{$labela};
my $lb = $self->{labels}->{$labelb};
lib/AI/Fuzzy/Axis.pm view on Meta::CPAN
} else {
return undef;
}
}
sub between {
my ($self, $labela, $labelb, $labelc) = @_;
if ( exists $self->{labels}->{$labela} and exists $self->{labels}->{$labelb}
and exists $self->{labels}->{$labelc} ) {
my $la = $self->{labels}->{$labela};
AI-FuzzyEngine
view release on metacpan or search on metacpan
lib/AI/FuzzyEngine.pm view on Meta::CPAN
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.
AI-FuzzyInference
view release on metacpan or search on metacpan
FuzzyInference.pm view on Meta::CPAN
# this hash defines the possible interpretations of the
# standard fuzzy logic operations.
my %_operations = (
'&' => {
min => sub { (sort {$a <=> $b} @_)[0] },
product => sub { my $p = 1; $p *= $_ for @_; $p },
default => 'min',
},
'|' => {
max => sub { (sort {$a <=> $b} @_)[-1] },
sum => sub { my $s = 0; $s += $_ for @_; $s > 1 ? 1 : $s },
default => 'max',
},
'!' => {
complement => sub { 1 - $_[0] },
custom => sub {},
default => 'complement',
},
);
# this hash defines the currently implemented implication methods.
FuzzyInference.pm view on Meta::CPAN
my %_defuzzification = qw(
centroid 1
default centroid
);
# sub new() - constructor.
#
# doesn't take any arguments. Returns an initialized AI::FuzzyInference object.
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $obj = bless {} => $class;
$obj->_init;
return $obj;
}
# sub _init() - private method.
#
# no arguments. Initializes the data structures we will need.
# It also defines the default logic operations we might need.
sub _init {
my $self = shift;
$self->{SET} = new AI::FuzzyInference::Set;
$self->{INVARS} = {};
$self->{OUTVARS} = {};
FuzzyInference.pm view on Meta::CPAN
for my $op (qw/& | !/) {
$self->{OPERATIONS}{$op} = $_operations{$op}{default};
}
}
# sub implication() - public method.
#
# one optional argument: has to match one of the keys of the %_implication hash.
# used to query/set the implication method.
sub implication {
my ($self,
$new,
) = @_;
if (defined $new and exists $_implication{$new}) {
FuzzyInference.pm view on Meta::CPAN
}
return $self->{IMPLICATION};
}
# sub aggregation() - public method.
#
# one optional argument: has to match one of the keys of the %_aggregation hash.
# used to query/set the aggregation method.
sub aggregation {
my ($self,
$new,
) = @_;
if (defined $new and exists $_aggregation{$new}) {
FuzzyInference.pm view on Meta::CPAN
}
return $self->{AGGREGATION};
}
# sub defuzzification() - public method.
#
# one optional argument: has to match one of the keys of the %_defuzzification hash.
# used to query/set the defuzzification method.
sub defuzzification {
my ($self,
$new,
) = @_;
if (defined $new and exists $_defuzzification{$new}) {
FuzzyInference.pm view on Meta::CPAN
}
return $self->{DEFUZZIFICATION};
}
# sub operation() - public method.
#
# two arguments: first one mandatory and specifies the logic operation
# in question. Second one is optional and has to match one of the keys
# of the %{$_operations{$first_arg}} hash.
# Used to query/set the logic operations method.
sub operation {
my ($self,
$op,
$new,
) = @_;
FuzzyInference.pm view on Meta::CPAN
}
return $self->{OPERATIONS}{$op};
}
# sub inVar() - public method.
#
# 4 arguments or more : First is a name of a new input variable.
# Second and third are the min and max values of that variable.
# These define the universe of discourse for that variable.
# Additional argumets constitute a hash. The keys of the hash
FuzzyInference.pm view on Meta::CPAN
# 'tall' => [0, 0,
# 5, 1,
# 10,0],
# ....);
sub inVar {
my ($self,
$var,
$xmin,
$xmax,
@sets,
FuzzyInference.pm view on Meta::CPAN
$self->{SET}->add("$var:$s", $xmin, $xmax, @$c);
}
}
# sub outVar() - public method.
#
# 4 arguments or more : First is a name of a new output variable.
# Second and third are the min and max values of that variable.
# These define the universe of discourse for that variable.
# Additional argumets constitute a hash. The keys of the hash
# are term set names defined for the given variable. The values
# are the coordinates of the vertices of the term sets.
sub outVar {
my ($self,
$var,
$xmin,
$xmax,
@sets,
FuzzyInference.pm view on Meta::CPAN
$self->{SET}->add("$var:$s", $xmin, $xmax, @$c);
}
}
# sub addRule() - public method.
#
# Adds fuzzy if-then inference rules.
#
# $obj->addRule('x=medium' => 'z = slow',
# 'x=low & y=small' => 'z = fast',
# 'x=high & y=tiny' => 'z=veryfast');
# spaces are optional. The characters [&=|] are special.
sub addRule {
my ($self, %rules) = @_;
for my $k (keys %rules) {
my $v = $rules{$k};
s/\s+//g for $v, $k;
FuzzyInference.pm view on Meta::CPAN
}
return 1;
}
# sub show() - public method.
#
# This method displays the computed values of all
# output variables.
# It is ugly, and will be removed. Here for debugging.
sub show {
my $self = shift;
for my $var (keys %{$self->{RESULTS}}) {
print "Var $var = $self->{RESULTS}{$var}.\n";
}
}
# sub value() - public method.
#
# one argument: the name of an output variable.
# This method returns the computed value of a given output var.
sub value {
my ($self,
$var,
) = @_;
return undef unless exists $self->{RESULTS}{$var};
return $self->{RESULTS}{$var};
}
# sub reset() - public method
#
# cleans the data structures used.
sub reset {
my $self = shift;
my @list = $self->{SET}->listMatching(q|:implicated$|);
push @list => $self->{SET}->listMatching(q|:aggregated$|);
$self->{SET}->delete($_) for @list;
$self->{RESULTS} = {};
}
# sub compute() - public method
#
# This method takes as input crisp values for each
# of the input vars, and produces a crisp output value
# based on the application of the fuzzy if-then rules.
# ex.
# $z = $obj->compute(x => 5,
# y => 24);
sub compute {
my ($self,
%vars,
) = @_;
$self->reset();
FuzzyInference.pm view on Meta::CPAN
$self->_defuzzify;
return 1;
}
# sub _defuzzify() - private method.
#
# no arguments. This method applies the defuzzification technique
# to get a crisp value out of the aggregated set of each output
# var.
sub _defuzzify {
my $self = shift;
my $_defuzzification = $self->{DEFUZZIFICATION};
# iterate through all output vars.
FuzzyInference.pm view on Meta::CPAN
$self->{RESULTS}{$var} = $result;
}
}
# sub _aggregate() - private method.
#
# no arguments. This method applies the aggregation technique to get
# one fuzzy set out of the implicated sets of each output var.
sub _aggregate {
my $self = shift;
my $_aggregation = $self->{AGGREGATION};
# iterate through all output vars.
FuzzyInference.pm view on Meta::CPAN
$self->{SET}->delete("temp$j");
}
}
}
# sub _implicate() - private method.
#
# no arguments. This method applies the implication technique
# to all the fired rules to find a support value for each
# output variable.
sub _implicate {
my $self = shift;
my $_implication = $self->{IMPLICATION};
my %ind;
FuzzyInference.pm view on Meta::CPAN
$self->{SET}->add("$var:$ts:$ind{$var}{$ts}:implicated", @u, @c);
}
}
}
# sub _fuzzify() - private method.
#
# one argument: a hash. The keys are input variables. The
# values are the crisp values of the input variables (same arguments
# as compute()). It finds the degree of membership of each input
# variable in each of its term sets.
sub _fuzzify {
my ($self, %vars) = @_;
my %terms;
for my $var (keys %vars) {
FuzzyInference.pm view on Meta::CPAN
}
$self->{FUZZIFY} = \%terms;
}
# sub _infer() - private method.
#
# no arguments. This method applies the logic operations to combine
# multiple parts of the antecedent of a rule to get one crisp value
# that is the degree of support of that rule.
# Rules with positive support "fire".
sub _infer {
my $self = shift;
my @fired; # keep list of fired rules.
for my $i (0 .. $#{$self->{RULES}}) {
AI-Gene-Sequence
view release on metacpan or search on metacpan
AI/Gene/Sequence.pm view on Meta::CPAN
##
# calls mutation method at random
# 0: number of mutations to perform
# 1: ref to hash of probs to use (otherwise uses default mutations and probs)
sub mutate {
my $self = shift;
my $num_mutates = +$_[0] || 1;
my $rt = 0;
my ($hr_probs, $muts);
if (ref $_[1] eq 'HASH') { # use non standard mutations or probs
AI/Gene/Sequence.pm view on Meta::CPAN
##
# creates a normalised and cumulative prob distribution for the
# keys of the referenced hash
sub _normalise {
my $hr = $_[0];
my $h2 = {};
my $muts = [keys %{$hr}];
my $sum = 0;
foreach (values %{$hr}) {
AI/Gene/Sequence.pm view on Meta::CPAN
##
# inserts one element into the sequence
# 0: number to perform ( or 1)
# 1: position to mutate (undef for random)
sub mutate_insert {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
# removes element(s) from sequence
# 0: number of times to perform
# 1: position to affect (undef for rand)
# 2: length to affect, undef => 1, 0 => random length
sub mutate_remove {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
# 0: number to perform (or 1)
# 1: posn to copy from (undef for rand)
# 2: posn to splice in (undef for rand)
# 3: length (undef for 1, 0 for random)
sub mutate_duplicate {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
# 0: num to perform (or 1)
# 1: pos to get from (undef for rand)
# 2: pos to start replacement (undef for rand)
# 3: length to operate on (undef => 1, 0 => rand)
sub mutate_overwrite {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
AI/Gene/Sequence.pm view on Meta::CPAN
# Takes a run of tokens and reverses their order, is a noop with 1 item
# 0: number to perform
# 1: posn to start from (undef for rand)
# 2: length (undef=>1, 0=>rand)
sub mutate_reverse {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
AI/Gene/Sequence.pm view on Meta::CPAN
##
# Changes token into one of same type (ie. passes type to generate..)
# 0: number to perform
# 1: position to affect (undef for rand)
sub mutate_minor {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $pos = defined $_[1] ? $_[1] : int rand length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
##
# Changes one token into some other token
# 0: number to perform
# 1: position to affect (undef for random)
sub mutate_major {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
my $pos = defined $_[1] ? $_[1] : int rand length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
# 1: start of first sequence (undef for rand)
# 2: start of second sequence (undef for rand)
# 3: length of first sequence (undef for 1, 0 for rand)
# 4: length of second sequence (undef for 1, 0 for rand)
sub mutate_switch {
my $self = shift;
my $num = $_[0] || 1;
my $rt = 0;
for (1..$num) {
my $length = length $self->[0];
AI/Gene/Sequence.pm view on Meta::CPAN
# 0: number to perform
# 1: posn to get from (undef for rand)
# 2: posn to put (undef for rand)
# 3: length of sequence (undef for 1, 0 for rand)
sub mutate_shuffle {
my $self = shift;
my $num = +$_[0] || 1;
my $rt = 0;
for (1..$num) {
AI/Gene/Sequence.pm view on Meta::CPAN
# can be called with a token type to produce, or with none.
# if called with a token type, it will also be passed the original
# token as the second argument.
# should return a two element list of the token type followed by the token itself.
sub generate_token {
my $self = shift;
my $token_type = $_[0];
my $letter = ('a'..'z')[rand 25];
unless ($token_type) {
return ($letter) x2;
AI/Gene/Sequence.pm view on Meta::CPAN
}
# takes sting of token types to be checked for validity.
# If a mutation affects only one place, then the position of the
# mutation can be passed as a second argument.
sub valid_gene {1}
## You might also want to have methods like the following,
# they will not be called by the 'sequence' methods.
# Default constructor
sub new {
my $gene = ['',[]];
return bless $gene, ref $_[0] || $_[0];
}
# remember that clone method may require deep copying depending on
# your specific needs
sub clone {
my $self = shift;
my $new = [$self->[0]];
$new->[1] = [@{$self->[1]}];
return bless $new, ref $self;
}
# You need some way to use the gene you've made and mutated, but
# this will let you have a look, if it starts being odd.
sub render_gene {
my $self = shift;
my $return = "$self\n";
$return .= $self->[0] . "\n";
$return .= (join ',', @{$self->[1]}). "\n";
return $return;
}
# used for testing
sub _test_dump {
my $self = shift;
my @rt = ($self->[0], join('',@{$self->[1]}));
return @rt;
}
1;
AI/Gene/Sequence.pm view on Meta::CPAN
our @ISA = qw(AI::Gene::Sequence);
my %things = ( a => [qw(a1 a2 a3 a4 a5)],
b => [qw(b1 b2 b3 b4 b5)],);
sub generate_token {
my $self = shift;
my ($type, $prev) = @_;
if ($type) {
$prev = ${ $things{$type} }[rand @{ $things{$type} }];
}
AI/Gene/Sequence.pm view on Meta::CPAN
$prev = ${$things{$type}}[rand @{$things{$type}}];
}
return ($type, $prev);
}
sub valid_gene {
my $self = shift;
return 0 if $_[0] =~ /(.)\1/;
return 1;
}
sub seed {
my $self = shift;
$self->[0] = 'ababab';
@{$self->[1]} = qw(A1 B1 A2 B2 A3 B3);
}
sub render {
my $self = shift;
return join(' ', @{$self->[1]});
}
# elsewhere
( run in 0.439 second using v1.01-cache-2.11-cpan-5f4f29bf90f )