view release on metacpan or  search on metacpan

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

    }
    $LINENUM;
}

sub advance_linenum {
    my $self = shift;
    $LINENUM++;
}

# Move a character forward
sub advance {
    my $self = shift;

    # print $self->current; # XXX
    $self->{_posn}++ unless $self->{_posn} >= length $self->{_str};
    $self->advance_linenum if $self->current =~ /[\r\n]/;
}

# all three get methods must be called before advance
# recognize a name (sequence of alphanumerics)
# XXX the java methods do not directly translate, so
#     we need to revisit this if it breaks
# XXX Update:  There was a subtle bug.  I think
#     I've nailed it, though.  The string index was off by one
sub getname {
    my $self = shift;

    $self->{_start} = $self->{_posn};
    my $getname;
    if ( $self->current =~ /['"]/ ) {

     # Normally, Prolog distinguishes between single and double quoted strings
        my $string = substr $self->{_str} => $self->{_start};
        $getname = extract_delimited($string);
        $self->{_posn} += length $getname;
        return substr $getname => 1, length($getname) - 2;  # strip the quotes
    }
    else {
        my $string = substr $self->{_str} => $self->{_start};
        ($getname) = $string =~ /^($ATOM)/;
        $self->{_posn} += length $getname;
        return $getname;
    }
}

# recognize a number
# XXX same issues as getname
sub getnum {
    my $self = shift;

    $self->{_start} = $self->{_posn};
    my $string = substr $self->{_str} => $self->{_start};
    my ($getnum) = $string =~ /^($RE{num}{real})/;
    if ( '.' eq substr $getnum => -1, 1 ) {
        $getnum = substr $getnum => 0, length($getnum) - 1;
    }
    $self->{_posn} += length $getnum;
    return $getnum;
}

# get the term corresponding to a name.
# if the name is new, create a new variable
sub getvar {
    my $self   = shift;
    my $string = $self->getname;
    my $term   = $self->{_vardict}{$string};
    unless ($term) {
        $term = Term->new( $self->{_varnum}++ );    # XXX wrong _varnum?
        $self->{_vardict}{$string} = $term;
    }
    return ( $term, $string );
}

my $ANON = 'a';

sub get_anon {
    my $self = shift;

    # HACK!!!
    my $string = '___' . $ANON++;
    $self->advance;
    my $term = $self->{_vardict}{$string};
    unless ($term) {
        $term = Term->new( $self->{_varnum}++ );    # XXX wrong _varnum?
        $self->{_vardict}{$string} = $term;
    }
    return ( $term, $string );
}

# handle errors in one place
sub parseerror {
    my ( $self, $character ) = @_;
    my $linenum = $self->linenum;
    croak "Unexpected character: ($character) at line number $linenum";
}

# skips whitespace and prolog comments
sub skipspace {
    my $self = shift;
    $self->advance while $self->current =~ /[[:space:]]/;
    _skipcomment($self);
}

# XXX Other subtle differences
sub _skipcomment {
    my $self = shift;
    if ( $self->current eq '%' ) {
        while ( $self->current ne "\n" && $self->current ne "#" ) {
            $self->advance;
        }
        $self->skipspace;
    }
    if ( $self->current eq "/" ) {
        $self->advance;
        if ( $self->current ne "*" ) {
            $self->parseerror("Expecting '*' after '/'");
        }
        $self->advance;
        while ( $self->current ne "*" && $self->current ne "#" ) {
            $self->advance;
        }
        $self->advance;
        if ( $self->current ne "/" ) {
            $self->parseerror("Expecting terminating '/' on comment");
        }
        $self->advance;
        $self->skipspace;
    }
}

# reset the variable dictionary
sub nextclause {
    my $self = shift;
    $self->{_vardict} = {};
    $self->{_varnum}  = 0;
}

# takes a hash and extends it with the clauses in the string
# $program is a string representing a prolog program
# $db is an initial program that will be augmented with the
# clauses parsed.
# class method, not an instance method
sub consult {
    my ( $class, $program, $db ) = @_;
    $db ||= KnowledgeBase->new;
    my $self = $class->new($program);
    $self->linenum(1);
    $self->skipspace;

    until ( $self->empty ) {
        my $termlist = $self->_termlist;

        my $head = $termlist->term;
        my $body = $termlist->next;

        my $is_primitive = $body && $body->isa(Primitive);
        unless ($is_primitive) {
            my $predicate = $head->predicate;
            $is_primitive = exists $db->{primitives}{$predicate};
        }
        my $add = $is_primitive ? 'add_primitive' : 'add_clause';
        my $clause = Clause->new( $head, $body );
        my $adding_builtins = Engine->_adding_builtins;
        $clause->is_builtin(1) if $adding_builtins;
        $db->$add( $clause, $adding_builtins );
        $self->skipspace;
        $self->nextclause;    # new set of vars
    }
    return $db;
}

sub resolve {
    my ( $class, $db ) = @_;
    foreach my $termlist ( values %{ $db->ht } ) {
        $termlist->resolve($db);
    }
}

sub _termlist {
    my ($self)   = @_;
    my $termlist = TermList->new;
    my @ts       = $self->_term;
    $self->skipspace;

    if ( $self->current eq ':' ) {
        $self->advance;

        if ( $self->current eq '=' ) {

            # we're parsing a primitive
            $self->advance;
            $self->skipspace;
            my $id = $self->getnum;
            $self->skipspace;
            $termlist->{term} = $ts[0];
            $termlist->{next} = Primitive->new($id);
        }
        elsif ( $self->current ne '-' ) {
            $self->parseerror("Expected '-' after ':'");
        }
        else {
            $self->advance;
            $self->skipspace;

            push @ts => $self->_term;
            $self->skipspace;

            while ( $self->current eq ',' ) {
                $self->advance;
                $self->skipspace;
                push @ts => $self->_term;
                $self->skipspace;
            }

            my @tsl;
            for my $j ( reverse 1 .. $#ts ) {
                $tsl[$j] = $termlist->new( $ts[$j], $tsl[ $j + 1 ] );
            }

            $termlist->{term} = $ts[0];
            $termlist->{next} = $tsl[1];
        }
    }
    else {
        $termlist->{term} = $ts[0];
        $termlist->{next} = undef;
    }

    if ( $self->current ne '.' ) {
        $self->parseerror("Expected '.' Got '@{[$self->current]}'");
    }
    $self->advance;
    return $termlist;
}