view release on metacpan or  search on metacpan

lib/AI/Prolog/Parser.pm  view on Meta::CPAN

package AI::Prolog::Parser;
$REVISION = '$Id: Parser.pm,v 1.9 2005/08/06 23:28:40 ovid Exp $';

$VERSION = '0.10';
use strict;
use warnings;
use Carp qw( confess croak );
use Regexp::Common;
use Hash::Util 'lock_keys';

# debugging stuff
use Clone;
use Text::Balanced qw/extract_quotelike extract_delimited/;

use aliased 'AI::Prolog::Engine';
use aliased 'AI::Prolog::KnowledgeBase';
use aliased 'AI::Prolog::Parser::PreProcessor';
use aliased 'AI::Prolog::Term';
use aliased 'AI::Prolog::Term::Number';
use aliased 'AI::Prolog::TermList';
use aliased 'AI::Prolog::TermList::Clause';
use aliased 'AI::Prolog::TermList::Primitive';

my $ATOM = qr/[[:alpha:]][[:alnum:]_]*/;

use constant NULL => 'null';

sub new {
    my ( $class, $string ) = @_;
    my $self = bless {
        _str      => PreProcessor->process($string),
        _posn     => 0,
        _start    => 0,
        _varnum   => 0,
        _internal => 0,
        _vardict  => {},
    } => $class;
    lock_keys %$self;
    return $self;
}

sub _vardict_to_string {
    my $self = shift;
    return "{"
        . (
        join ', ' => map { join '=' => $_->[0], $_->[1] }
            sort { $a->[2] <=> $b->[2] }
            map { [ $_, $self->_sortable_term( $self->{_vardict}{$_} ) ] }
            keys %{ $self->{_vardict} }
        ) . "}";
}

sub _sortable_term {
    my ( $self, $term ) = @_;
    my $string = $term->to_string;
    my $number = substr $string => 1;
    return $string, $number;
}

sub to_string {
    my $self   = shift;
    my $output = Clone::clone($self);
    $output->{_vardict} = $self->_vardict_to_string;
    return "{"
        . substr( $self->{_str}, 0, $self->{_posn} ) . " ^ "
        . substr( $self->{_str}, $self->{_posn} ) . " | "
        . $self->_vardict_to_string . " }";
}

sub _posn    { shift->{_posn} }
sub _str     { shift->{_str} }
sub _start   { shift->{_start} }
sub _varnum  { shift->{_varnum} }
sub _vardict { shift->{_vardict} }

sub _internal {
    my $self = shift;
    if (@_) {
        $self->{_internal} = shift;
        return $self;
    }
    return $self->{_internal};
}

# get the current character
sub current {
    my $self = shift;
    return '#' if $self->empty;
    return substr $self->{_str} => $self->{_posn}, 1;
}