Result:
found more than 191 distributions - search limited to the first 2001 files matching your query
( run in 1.296 )
ACME-YAPC-NA-2012
view release on metacpan or search on metacpan
lib/ACME/YAPC/NA/2012.pm view on Meta::CPAN
=head2 function1
=cut
sub function1 {
}
=head2 function2
=cut
sub function2 {
}
=head1 AUTHOR
Jacinta Richardson, C<< <jarich at cpan.org> >>
ACME-ltharris
view release on metacpan or search on metacpan
lib/ACME/ltharris.pm view on Meta::CPAN
=head2 function1
=cut
sub function1 {
}
=head2 function2
=cut
sub function2 {
}
=head1 AUTHOR
L.T. Harris, C<< <lth at ltharris.com> >>
ADAMK-Release
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
inc/Module/Install.pm view on Meta::CPAN
#-------------------------------------------------------------
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
foreach my $key (keys %INC) {
inc/Module/Install.pm view on Meta::CPAN
local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{'inc/Module/Install.pm'};
delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
return 1;
}
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 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 ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
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) = @_;
my $should_reload = 0;
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});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
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);
inc/Module/Install.pm view on Meta::CPAN
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_OLD
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;
inc/Module/Install.pm view on Meta::CPAN
return $string;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
inc/Module/Install.pm view on Meta::CPAN
}
END_OLD
# _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($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
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
PERL_MAGIC_regex_global|5.007002||p
PERL_MAGIC_shared_scalar|5.007003||p
PERL_MAGIC_shared|5.007003||p
PERL_MAGIC_sigelem|5.007002||p
PERL_MAGIC_sig|5.007002||p
PERL_MAGIC_substr|5.007002||p
PERL_MAGIC_sv|5.007002||p
PERL_MAGIC_taint|5.007002||p
PERL_MAGIC_tiedelem|5.007002||p
PERL_MAGIC_tiedscalar|5.007002||p
PERL_MAGIC_tied|5.007002||p
PERL_USHORT_MAX|5.003070||p
PERL_USHORT_MIN|5.003070||p
PERL_VERSION|5.006000||p
PL_DBsignal|5.005000||p
PL_DBsingle|||pn
PL_DBsub|||pn
PL_DBtrace|||pn
PL_Sv|5.005000||p
PL_bufend|5.024000||p
PL_bufptr|5.024000||p
PL_check||5.006000|
_invlist_intersection|||
_invlist_invert|||
_invlist_len|||n
_invlist_populate_swatch|||n
_invlist_search|||n
_invlist_subtract|||
_invlist_union_maybe_complement_2nd|||
_invlist_union|||
_is_cur_LC_category_utf8|||
_is_in_locale_category||5.021001|
_is_uni_FOO||5.017008|
check_type_and_open|||
check_uni|||
check_utf8_print|||
checkcomma|||
ckWARN|5.006000||p
ck_entersub_args_core|||
ck_entersub_args_list||5.013006|
ck_entersub_args_proto_or_list||5.013006|
ck_entersub_args_proto||5.013006|
ck_warner_d||5.011001|v
ck_warner||5.011001|v
ckwarn_common|||
ckwarn_d||5.009003|
ckwarn||5.009003|
cophh_store_pvn||5.013007|
cophh_store_pvs||5.013007|
cophh_store_pv||5.013007|
cophh_store_sv||5.013007|
core_prototype|||
coresub_op|||
cr_textfilter|||
create_eval_scope|||
croak_memory_wrap||5.019003|n
croak_no_mem|||n
croak_no_modify||5.013003|n
cx_popblock||5.023008|
cx_popeval||5.023008|
cx_popformat||5.023008|
cx_popgiven||5.023008|
cx_poploop||5.023008|
cx_popsub_args||5.023008|
cx_popsub_common||5.023008|
cx_popsub||5.023008|
cx_popwhen||5.023008|
cx_pushblock||5.023008|
cx_pusheval||5.023008|
cx_pushformat||5.023008|
cx_pushgiven||5.023008|
cx_pushloop_for||5.023008|
cx_pushloop_plain||5.023008|
cx_pushsub||5.023008|
cx_pushwhen||5.023008|
cx_topblock||5.023008|
cxinc|||
dAXMARK|5.009003||p
dAX|5.007002||p
doparseform|||
dopoptoeval|||
dopoptogivenfor|||
dopoptolabel|||
dopoptoloop|||
dopoptosub_at|||
dopoptowhen|||
doref||5.009003|
dounwind|||
dowantarray|||
drand48_init_r|||n
dump_eval||5.006000|
dump_exec_pos|||
dump_form||5.006000|
dump_indent||5.006000|v
dump_mstats|||
dump_packsubs_perl|||
dump_packsubs||5.006000|
dump_sub_perl|||
dump_sub||5.006000|
dump_sv_child|||
dump_trie_interim_list|||
dump_trie_interim_table|||
dump_trie|||
dump_vindent||5.006000|
filter_gets|||
filter_read|||
finalize_optree|||
finalize_op|||
find_and_forget_pmops|||
find_array_subscript|||
find_beginning|||
find_byclass|||
find_default_stash|||
find_hash_subscript|||
find_in_my_stash|||
find_lexical_cv|||
find_runcv_where|||
find_runcv||5.008001|
find_rundefsvoffset||5.009002|
get_c_backtrace|||
get_context||5.006000|n
get_cvn_flags|||
get_cvs|5.011000||p
get_cv|5.006000||p
get_db_sub|||
get_debug_opts|||
get_hash_seed|||
get_hv|5.006000||p
get_invlist_iter_addr|||n
get_invlist_offset_addr|||n
isXDIGIT|5.006000||p
is_an_int|||
is_ascii_string||5.011000|
is_handle_constructor|||n
is_invariant_string||5.021007|n
is_lvalue_sub||5.007001|
is_safe_syscall||5.019004|
is_ssc_worth_it|||n
is_uni_alnum_lc||5.006000|
is_uni_alnumc_lc||5.017007|
is_uni_alnumc||5.017007|
magic_getdefelem|||
magic_getnkeys|||
magic_getpack|||
magic_getpos|||
magic_getsig|||
magic_getsubstr|||
magic_gettaint|||
magic_getuvar|||
magic_getvec|||
magic_get|||
magic_killbackrefs|||
magic_setnkeys|||
magic_setpack|||
magic_setpos|||
magic_setregexp|||
magic_setsig|||
magic_setsubstr|||
magic_settaint|||
magic_setutf8|||
magic_setuvar|||
magic_setvec|||
magic_set|||
parse_ident|||
parse_label||5.013007|
parse_listexpr||5.013008|
parse_lparen_question_flags|||
parse_stmtseq||5.013006|
parse_subsignature|||
parse_termexpr||5.013008|
parse_unicode_opts|||
parser_dup|||
parser_free_nexttoke_ops|||
parser_free|||
scan_inputsymbol|||
scan_num||5.007001|
scan_oct|||
scan_pat|||
scan_str|||
scan_subst|||
scan_trans|||
scan_version||5.009001|
scan_vstring||5.009005|
scan_word|||
search_const|||
simplify_sort|||
skip_to_be_ignored_text|||
skipspace_flags|||
softref2xv|||
sortcv_stacked|||
sortcv_xsub|||
sortcv|||
sortsv_flags||5.009003|
sortsv||5.007003|
space_join_names_mortal|||
ss_dup|||
ssc_is_cp_posixl_init|||n
ssc_or|||
ssc_union|||
stack_grow|||
start_glob|||
start_subparse||5.004000|
stdize_locale|||
strEQ|||
strGE|||
strGT|||
strLE|||
str_to_version||5.006000|
strip_return|||
strnEQ|||
strnNE|||
study_chunk|||
sub_crush_depth|||
sublex_done|||
sublex_push|||
sublex_start|||
sv_2bool_flags||5.013006|
sv_2bool|||
sv_2cv|||
sv_2io|||
sv_2iuv_common|||
toTITLE_uvchr||5.023009|
toTITLE||5.019001|
toUPPER_utf8||5.015007|
toUPPER_uvchr||5.023009|
toUPPER|||
to_byte_substr|||
to_lower_latin1|||n
to_uni_fold||5.007003|
to_uni_lower_lc||5.006000|
to_uni_lower||5.007003|
to_uni_title_lc||5.006000|
to_uni_upper_lc||5.006000|
to_uni_upper||5.007003|
to_utf8_case||5.007003|
to_utf8_fold||5.015007|
to_utf8_lower||5.015007|
to_utf8_substr|||
to_utf8_title||5.015007|
to_utf8_upper||5.015007|
tokenize_use|||
tokeq|||
tokereport|||
too_few_arguments_pv|||
too_many_arguments_pv|||
translate_substr_offsets|||n
try_amagic_bin|||
try_amagic_un|||
uiv_2buf|||n
unlnk|||
unpack_rec|||
warn_nocontext|||vn
warn_sv||5.013001|
warner_nocontext|||vn
warner|5.006000|5.004000|pv
warn|||v
was_lvalue_sub|||
watch|||
whichsig_pvn||5.015004|
whichsig_pv||5.015004|
whichsig_sv||5.015004|
whichsig|||
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
const line_t ocopline = PL_copline;
COP * const ocurcop = PL_curcop;
const int oexpect = PL_expect;
#if (PERL_BCDVERSION >= 0x5004000)
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
#elif (PERL_BCDVERSION > 0x5003000)
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
veop, modname, imop);
#else
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
modname, imop);
#endif
PL_expect = oexpect;
PL_copline = ocopline;
PL_curcop = ocurcop;
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if (PERL_BCDVERSION < 0x5003022)
start_subparse(),
#elif (PERL_BCDVERSION == 0x5003022)
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
#ifndef PERL_MAGIC_utf8
# define PERL_MAGIC_utf8 'w'
#endif
#ifndef PERL_MAGIC_substr
# define PERL_MAGIC_substr 'x'
#endif
#ifndef PERL_MAGIC_defelem
# define PERL_MAGIC_defelem 'y'
#endif
#if (PERL_BCDVERSION >= 0x5006000)
#ifndef caller_cx
# if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
static I32
DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
{
I32 i;
for (i = startingblock; i >= 0; i--) {
register const PERL_CONTEXT * const cx = &cxstk[i];
#if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
const PERL_CONTEXT *
DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
{
register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
register const PERL_CONTEXT *cx;
register const PERL_CONTEXT *ccstack = cxstack;
const PERL_SI *top_si = PL_curstackinfo;
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
top_si = top_si->si_prev;
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);
}
cx = &ccstack[cxix];
if (dbcxp) *dbcxp = cx;
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;
}
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
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
lib/AFS/PAG.pm view on Meta::CPAN
# The Board of Trustees of the Leland Stanford Junior University
#
# Permission is hereby granted, free of charge, to any person obtaining a
# copy of this software and associated documentation files (the "Software"),
# to deal in the Software without restriction, including without limitation
# the rights to use, copy, modify, merge, publish, distribute, sublicense,
# and/or sell copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
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
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];
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)} });
cmpthese( -1, { 'dafunc_c' => sub{dafunc_c(4*rand()-2)},
'dafunc_pp' => sub{dafunc_pp(4*rand()-2)} });
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
#!/usr/bin/perl
# This script is a fairly simple demonstration of how AI::Categorizer
# can be used. There are lots of other less-simple demonstrations
# (actually, they're doing much simpler things, but are probably
# harder to follow) in the tests in the t/ subdirectory. The
# eg/categorizer script can also be a good example if you're willing
# to figure out a bit how it works.
#
# This script reads a training corpus from a directory of plain-text
# documents, trains a Naive Bayes categorizer on it, then tests the
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
# object manually. Or you could let the KnowledgeSet create the
# Collection objects for you.
$training = AI::Categorizer::Collection::Files->new( path => $training, %params );
$test = AI::Categorizer::Collection::Files->new( path => $test, %params );
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
# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
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
}
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
# Save to the singleton
$MAIN = $self;
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
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});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
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;
lib/AI/ExpertSystem/Simple.pm view on Meta::CPAN
=head2 Overview
This class is where all the work is being done and the other three classes are only
there for support. At present there is little you can do with it other than run it. Future
version will make subclassing of this class feasable and features like logging will be introduced.
To see how to use this class there is a simple shell in the bin directory which allows you
to consult the example knowledge bases and more extensive documemtation in the docs directory.
There is a Ruby version that reads the same XML knowledge bases, if you are interested.
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) {
lib/AI/FANN.pm view on Meta::CPAN
use AI::FANN ':all';
# or individual constants...
use AI::FANN qw(FANN_TRAIN_INCREMENTAL FANN_GAUSSIAN);
The values returned from this constant subs yield the integer value on
numerical context and the constant name when used as strings.
The constants available are:
# enum fann_train_enum:
lib/AI/FANN.pm view on Meta::CPAN
=item $train->scale($new_min, $new_max)
-
=item $train->subset($pos, $length)
-
=item $train->num_inputs
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.
lib/AI/FuzzyEngine.pm view on Meta::CPAN
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
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}}) {
FuzzyInference.pm view on Meta::CPAN
Example:
$obj->compute(x => 5,
y => 24);
Note that any subsequent call to C<compute()> will implicitly clear out
the old computed values before recomputing the new ones. This is done
through a call to the C<reset()> method below.
=item value()
( run in 1.296 second using v1.01-cache-2.11-cpan-7add2cbd662 )