Hailo - A pluggable Markov engine analogous to MegaHAL

    # Hailo requires Perl 5.10
    use 5.010;
    use Any::Moose;
    use Hailo;

    # Construct a new in-memory Hailo using the SQLite backend. See
    # backend documentation for other options.
    my $hailo = Hailo->new;

    # Various ways to learn
    my @train_this = ("I like big butts", "and I can not lie");
    $hailo->learn(\@train_this);
    $hailo->learn($_) for @train_this;

    # Heavy-duty training interface. Backends may drop some safety
    # features like journals or synchronous IO to train faster using
    # this mode.
    $hailo->train("megahal.trn");
    $hailo->train($filehandle);

    # Make the brain babble
    say $hailo->reply("hello good sir.");
    # Just say something at random
    say $hailo->reply();

package Hailo;
BEGIN {
  $Hailo::AUTHORITY = 'cpan:AVAR';
}
BEGIN {
  $Hailo::VERSION = '0.69';
}

use 5.010;
use autodie qw(open close);
use Any::Moose;
use Any::Moose 'X::StrictConstructor';
use File::Glob ':glob';
use Class::Load qw(try_load_class);
use Scalar::Util qw(blessed);
use List::Util qw(first);
use namespace::clean -except => 'meta';

use constant PLUGINS => [ qw[
    Hailo::Engine::Default
    Hailo::Engine::Scored
    Hailo::Storage::MySQL
    Hailo::Storage::PostgreSQL
    Hailo::Storage::SQLite
    Hailo::Tokenizer::Chars
    Hailo::Tokenizer::Words
    Hailo::UI::ReadLine
] ];

has brain => (
    isa => 'Str',
    is  => 'rw',
);

has order => (
    isa     => 'Int',
    is      => 'rw',
    default => 2,
    trigger => sub {
        my ($self, $order) = @_;
        $self->_custom_order(1);
    },
);

has _custom_order => (
    isa           => 'Bool',
    is            => 'rw',
    default       => 0,
    init_arg      => undef,
    documentation => "Here so we can differentiate between the default value of order being explictly set and being set by default",
);

has _custom_tokenizer_class => (
    isa           => 'Bool',
    is            => 'rw',
    default       => 0,
    init_arg      => undef,
    documentation => "Here so we can differentiate between the default value of tokenizer_class being explictly set and being set by default",
);

has save_on_exit => (
    isa     => 'Bool',
    is      => 'rw',
    default => 1,
);

has brain_resource => (
    documentation => "Alias for `brain' for backwards compatibility",
    isa           => 'Str',
    is            => 'rw',
    trigger       => sub {
        my ($self, $brain) = @_;
        $self->brain($brain);
    },
);

sub BUILD {
    my ($self) = @_;
    my $brain = $self->brain;
    return if !defined $brain;
    $self->brain(bsd_glob($brain));
    return;
}

my %has = (
    engine => {
        name => 'Engine',
        default => 'Default',
    },
    storage => {
        name => 'Storage',
        default => 'SQLite',
    },
    tokenizer => {
        name => 'Tokenizer',
        default => 'Words',
    },
    ui => {
        name => 'UI',
        default => 'ReadLine',
    },
);

for my $k (keys %has) {
    my $name          = $has{$k}->{name};
    my $default       = $has{$k}->{default};
    my $method_class  = "${k}_class";
    my $method_args   = "${k}_args";

    # working classes
    has "${k}_class" => (
        isa           => 'Str',
        is            => "rw",
        default       => $default,
        ($k ~~ 'tokenizer'
         ? (trigger => sub {
             my ($self, $class) = @_;
             $self->_custom_tokenizer_class(1);
         })
         : ())
    );

    # Object arguments
    has "${k}_args" => (
        documentation => "Arguments for the $name class",
        isa           => 'HashRef',
        is            => "ro",
        default       => sub { +{} },
    );

    # Working objects
    has "_${k}" => (
        does        => "Hailo::Role::$name",
        lazy_build  => 1,
        is          => 'ro',
        init_arg    => undef,
    );

    # Generate the object itself
    no strict 'refs';
    *{"_build__${k}"} = sub {
        my ($self) = @_;

        my $obj = $self->_new_class(
            $name,
            $self->$method_class,
            {
                arguments => $self->$method_args,
                ($k ~~ [ qw< engine storage > ]
                 ? (order     => $self->order)
                                  : ()),
                                ($k ~~ [ qw< engine > ]
                                  ? (storage   => $self->_storage)
                 : ()),
                (($k ~~ [ qw< storage > ] and defined $self->brain)
                 ? (
                     hailo => do {
                         require Scalar::Util;
                         Scalar::Util::weaken(my $s = $self);

                         my %callback = (
                             has_custom_order           => sub { $s->_custom_order },
                             has_custom_tokenizer_class => sub { $s->_custom_tokenizer_class },
                             set_order => sub {
                                 my ($db_order) = @_;
                                 $s->order($db_order);
                                 $s->_engine->order($db_order);
                             },
                             set_tokenizer_class => sub {
                                 my ($db_tokenizer_class) = @_;
                                 $s->tokenizer_class($db_tokenizer_class);
                             },
                         );

                         \%callback;
                     },
                     brain => $self->brain
                 )
                 : ()),
                (($k ~~ [ qw< storage > ]
                  ? (tokenizer_class => $self->tokenizer_class)
                                    : ()))
                        },
                );

                return $obj;
        };
}

sub _new_class {
        my ($self, $type, $class, $args) = @_;

        my $pkg;
        if ($class =~ m[^\+(?<custom_plugin>.+)$]) {
        $pkg = $+{custom_plugin};
    } else {
        my @plugins = @{ $self->PLUGINS };
        # Be fuzzy about includes, e.g. DBD::SQLite or SQLite or sqlite will go
        $pkg = first { / $type : .* : $class /ix }
               sort { length $a <=> length $b }
               @plugins;

        unless ($pkg) {
            local $" = ', ';
            my @p = grep { /$type/ } @plugins;
            die "Couldn't find a class name matching '$class' in plugins '@p'";
        }
    }

    my ($success, $error) = try_load_class($pkg);
    die $error if !$success;

    return $pkg->new(%$args);
}

sub save {
    my ($self, @args) = @_;
    $self->_storage->save(@args);
    return;
}

sub train {
    my ($self, $input, $fast) = @_;

    $self->_storage->start_training();

    given ($input) {
        # With STDIN
        when (not ref and defined and $_ eq '-') {
            die "You must provide STDIN when training from '-'" if $self->_is_interactive(*STDIN);
            $self->_train_fh(*STDIN, $fast);
        }
        # With a filehandle
        when (ref eq 'GLOB') {
            $self->_train_fh($input, $fast);
        }
        # With a file
        when (not ref) {
            open my $fh, '<:encoding(utf8)', $input;
            $self->_train_fh($fh, $fast, $input);
        }
        # With an Array
        when (ref eq 'ARRAY') {
            for my $line (@$input) {
                $self->_learn_one($line, $fast);
                $self->_engine->flush_cache if !$fast;
            }
            $self->_engine->flush_cache if $fast;
        }
        # With something naughty
        default {
            die "Unknown input: $input";
        }
    }

    $self->_storage->stop_training();

    return;
}

sub _train_fh {
    my ($self, $fh, $fast) = @_;

    while (my $line = <$fh>) {
        chomp $line;
        $self->_learn_one($line, $fast);
        $self->_engine->flush_cache if !$fast;
    }
    $self->_engine->flush_cache if $fast;

    return;
}

sub learn {
    my ($self, $input) = @_;
    my $inputs;

    given ($input) {
        when (not defined) {
            die "Cannot learn from undef input";
        }
        when (not ref) {
            $inputs = [$input];            
        }
        # With an Array
        when (ref eq 'ARRAY') {
            $inputs = $input
        }
        default {
            die "Unknown input: $input";
        }
    }

    my $storage = $self->_storage;

    $storage->start_learning();
    $self->_learn_one($_) for @$inputs;
    $storage->stop_learning();
    return;
}

sub _learn_one {
    my ($self, $input, $fast) = @_;
    my $engine  = $self->_engine;

    my $tokens = $self->_tokenizer->make_tokens($input);
    $fast ? $engine->learn_cached($tokens) : $engine->learn($tokens);

    return;
}

sub learn_reply {
    my ($self, $input) = @_;
    $self->learn($input);
    return $self->reply($input);
}

sub reply {
    my ($self, $input) = @_;

    my $storage   = $self->_storage;
    # start_training() hasn't been called so we can't guarentee that
    # the storage has been engaged at this point. This must be called
    # before ->_engine() is called anywhere to ensure that the
    # lazy-loading in the engine works.
    $storage->_engage() unless $storage->_engaged;

    my $engine    = $self->_engine;
    my $tokenizer = $self->_tokenizer;

    my $reply;
    if (defined $input) {
        my $tokens = $tokenizer->make_tokens($input);
        $reply = $engine->reply($tokens);
    }
    else {
        $reply = $engine->reply();
    }

    return unless defined $reply;
    return $tokenizer->make_output($reply);
}

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

    return $self->_storage->totals();
}

sub DEMOLISH {
    my ($self) = @_;
    $self->save() if blessed $self->{_storage} and $self->save_on_exit;
    return;
}

sub _is_interactive {
    require IO::Interactive;
    return IO::Interactive::is_interactive();
}

__PACKAGE__->meta->make_immutable;