File Coverage

blib/lib/Language/Prolog/Yaswi.pm

Criterion	Covered	Total	%
statement	70	84	83.3
branch	14	36	38.8
condition			n/a
subroutine	20	28	71.4
pod	20	20	100.0
total	124	168	73.8

package Language::Prolog::Yaswi;

our $VERSION = '0.22_01'; # TRIAL
$VERSION =~ tr/_//d;

use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'query' => [ qw( swi_set_query
				      swi_set_query_module
				      swi_result
				      swi_next
				      swi_var
				      swi_vars
				      swi_query
				      swi_cut
				      swi_find_all
				      swi_find_one
				      swi_call
				      swi_parse
				      swi_eval )],
		     'load' => [ qw( swi_inline
				     swi_inline_module
				     swi_consult
				     swi_use_modules )],
		     'assert' => [ qw( swi_assert
				       swi_asserta
				       swi_assertz
				       swi_facts
                                       swi_retractall )],
		     'interactive' => [ qw( swi_toplevel )],
		     'context' => [ qw( *swi_module
					*swi_temp_dir
					*swi_converter) ],
		     'run' => [ qw( swi_init
				    swi_cleanup )] );

our @EXPORT_OK = ( @{$EXPORT_TAGS{query}},
		   @{$EXPORT_TAGS{assert}},
		   @{$EXPORT_TAGS{interactive}},
		   @{$EXPORT_TAGS{context}},
		   @{$EXPORT_TAGS{run}},
		   @{$EXPORT_TAGS{load}});

our @EXPORT = qw();

use Carp;
our @CARP_NOT=qw( Prolog::Language::Yaswi::Low
		  Prolog::Language::Types );

use File::Temp;
use Language::Prolog::Types qw(:util F L C V isF isL isV isN);
use Language::Prolog::Yaswi::Low;


our $swi_module = undef;
our $swi_temp_dir = undef;
our $swi_debug = undef;


sub swi_init;
*swi_init=\&init;

sub swi_cleanup();
*swi_cleanup=\&cleanup;

sub swi_toplevel();
*swi_toplevel=\&toplevel;

*swi_converter=*converter;

sub swi_set_query_module {
    @{&openquery(@_)}
}

sub swi_cut();
*swi_cut=\&cutquery;


sub swi_set_query {
    return swi_set_query_module(C(',', @_),
				$swi_module);
}

sub swi_next() {
    package main;
    Language::Prolog::Yaswi::Low::nextsolution();
}

sub swi_query {
    testquery();
    getquery();
}

sub swi_var($) {
    testquery();
    getvar($_[0]);
}

sub swi_result() {
    testquery();
    getallvars();
}

sub swi_vars {
    testquery();
    my @res=map {
	isV($_)     ? getvar($_) :
        isL($_)     ? L(swi_vars(prolog_list2perl_list($_))) :
	isF($_)     ? F($_->functor => swi_vars($_->fargs)) :
        ($_ eq '*') ? getquery() :
	isN($_)     ? $_ :
	(ref($_) eq '') ? $_ :
	croak "invalid mapping '$_'";
    } @_;
    wantarray ? @res : $res[0]
}

sub swi_find_all ($;@) {
    my @r;
    swi_set_query(shift);
    while (swi_next) {
	# warn "new solution found\n";
	push @r, swi_vars(@_);
    }
    return wantarray ? @r : $r[0]
}

sub swi_find_one ($;@) {
    swi_set_query(shift);
    if (swi_next) {
	my @r=swi_vars(@_);
	swi_cut;
	return wantarray ? @r : $r[0];
    }
    return ();
}

sub swi_call {
    swi_set_query(@_);
    if (swi_next) {
	swi_cut;
	return 1;
    }
    return undef;
}

sub swi_assertz {
    my $head=shift;
    defined $head or croak "swi_assertz called without head";
    swi_call F(assertz => C(':-' => $head, C(',', @_)))
}

*swi_assert=\&swi_assertz;

sub swi_asserta {
    my $head=shift;
    defined $head or croak "swi_asserta called without head";
    swi_call F(asserta => C(':-' => $head, C(',', @_)))
}

sub swi_retractall {
    for my $head (@_) {
        swi_call F(retractall => $head);
    }
}

sub swi_facts {
    return swi_call C(',', (map { F(assertz => $_) } @_));
}

sub swi_consult {
    return swi_call([@_]);
}

sub swi_use_modules {
    swi_call F(use_module => $_) for @_
}

sub swi_parse {
    my @r;
    for my $atom (@_) {
	my ($t, $b) = swi_find_one(F(atom_to_term => $atom, V('T'), V('B')),
				   V('T'), V('B'));
	if (isL $b) {
	    for my $pair (@{$b}) {
		my $var = $pair->farg(1);
		$var->rename($pair->farg(0))
	    }
	}
	push @r, $t
    }
    return wantarray ? @r : $r[0]
}

sub swi_eval {
    swi_call(C(',' => swi_parse(@_)))
}

sub swi_inline {
    _swi_inline(load_files => @_)
}

sub swi_inline_module {
    _swi_inline(use_module => @_)
}

sub _swi_inline {
    my $action = shift;
    my $tmp=File::Temp->new(TEMPLATE => 'swi_inline_XXXXXXXX', SUFFIX => '.swi',
			    ((defined $swi_temp_dir) ?
			     (DIR => $swi_temp_dir) : ()));
    defined ($tmp) or croak "unable to create temporal prolog source file";
    my $fn=$tmp->filename;

    $tmp->print(@_, "\n");
    $tmp->close;

    eval { swi_call F($action => $fn) };
    unlink $fn;
    die $@ if $@;
}


package Language::Prolog::Yaswi::HASH;
our @ISA=qw(Language::Prolog::Types::Opaque::Auto);

sub new { return bless {}; }


1;
__END__