[VRG]

- renamed vectorize-run.pl to vrg-run.pl (the old one
  is overridden)
- added builtin infix operators "eq", "neq", and ":=" to
  xclips.

git-svn-id: http://svn.berlios.de/svnroot/repos/unisimu/VRG@815 625e195c-0704-0410-94f2-f261ee9f2fe7

preprocess.xclp

@@ -8,15 +8,15 @@ module Vectorize.
 
 \?a, \?b, meet(?a, ?b, ?)
 =>
-    bind(?A, gensym()), #?A,
+    ?A := gensym(), #?A,
     ?a [on] ?A, ?b [on] ?A,
     ?a [~//] ?b.
 
 \?a, #?A, meet(?a, ?A, ?) => ?a [~//] ?A, ?a [~on] ?A.
 
 \?a, #?alpha, \?b, project(?a, ?alpha, ?b)
 =>
-    bind(?theta, gensym()), #?theta,
+    ?theta := gensym(), #?theta,
     ?a [X] ?alpha, ?a [on] ?theta,
     meet(?theta, ?alpha, ?b),
     ?theta [T] ?alpha.

sanity2.t

@@ -17,12 +17,12 @@ run {
     ok system(split(/\s+/, $xclips), "$id.xclp") == 0, "$name - invoking $xclips ok";
     my ($stdout, $stderr);
     ok run3(
-            [$^X, 'vectorize-run.pl', "$id.clp"],
+            [$^X, 'vrg-run.pl', "$id.clp"],
             \undef,
             \$stdout,
             \$stderr,
         ),
-        "$name - vectorize-run.pl ok";
+        "$name - vrg-run.pl ok";
     warn $stderr if $stderr;
     my $got = sort_list($stdout);
     my $expected = sort_list($block->vectorized);

vector-eval.xclp

@@ -3,17 +3,18 @@
 define defmodule(
     Eval,
     import(Vectorize, deftemplate, vector-relation)
-).
+)
 
 module Eval.
 
 include "vrg-sugar.xclp".
 
-?a <//> ?b, ?a <?R> ?b => ?a <//> ?b.
+?a <//> ?b, ?a <?R> ?c, ?b neq ?c
+=> ?a <?R> ?c.
 
 ?a <T> ?b; ?a <X> ?b => ?a <~//> ?b.
 
-?a <T> ?b, ?b <T> ?c, ?c <T> ?d, ?d <T> ?a, ?a <~//> ?c
+?a <T> ?b, ?b <T> ?c, ?c <T> ?d, ?d <T> ?a, ?a <~//> ?c, ?b neq ?d
 => ?b <//> ?d.
 
 ?a <?R> ?b => ?b <?R> ?a.

vrg-run.pl

@@ -1,15 +1,85 @@
 use strict;
 use warnings;
 
-my $profile = shift;
-my $data = `$^X pro.pl -s $profile -g go -t halt -q`;
-my $pro_src = "(deffacts vector_facts \"$profile\"\n";
-open my $in, '<', \$data;
-while (<$in>) {
-    next if !/^\S+ \S+ \S+$/;
-    chomp;
-    $pro_src .= "    ($_)\n";
-}
-$pro_src .= ")\n";
-close $in;
-print $pro_src;
+use CLIPS_Visualize;
+use Getopt::Std;
+use CLIPS;
+
+my %opts;
+getopts('v', \%opts) or help();
+$CLIPS::Verbose = $opts{v};
+
+my %infix = (
+    'parallel'   => '//',
+    'orthogonal' => 'T',
+    'cross'      => 'X',
+    'on'         => 'on',
+);
+
+my %prefix = (
+    'line'  => '\\\\',
+    'plane' => '\\#',
+);
+
+my $infile = shift or help();;
+my $clips = CLIPS->new('vectorize.clp', $infile, 'vector-eval.clp');
+$clips->watch('rules');
+$clips->watch('facts');
+$clips->reset;
+$clips->focus('Vectorize');
+$clips->rules if $opts{v};
+$clips->facts('*', \my $init_facts);
+$clips->get_current_module;
+$clips->agenda;
+$clips->run(\my $run_log);
+$clips->facts('Eval', \my $facts);
+$clips->focus('Eval');
+$clips->facts('*', \$init_facts);
+$clips->run(\$run_log);
+$clips->eof;
+#warn "FACTS: ", $facts;
+while ($facts =~ /\(vector-relation ([^\)]+)\)/g) {
+    print "$1\n";
+}
+
+if ($opts{v}) {
+    my $painter = CLIPS::Visualize->new($init_facts, $run_log);
+    $painter->draw(
+        outfile     => "a.png",
+        fact_filter => \&format_fact,
+        trim => 1,
+    );
+}
+
+sub help {
+    die "usage: $0 [-v] infile\n";
+}
+
+sub format_fact {
+    my $clips = $_[0];
+    if ($clips =~ /(?x) ^ \( (space|vector)-relation \s+ (\S+) \s+ (\S+) \s+ (\S+) \) $/) {
+        #warn "$1, $2, $3";
+        my ($type, $rel, $a, $b) = ($1, $2, $3, $4);
+        my $prefix = '';
+        if ($rel =~ s/^not_//) {
+            $prefix = '~';
+        }
+        my $infix = $infix{$rel};
+        if ($infix) {
+            return $type eq 'space' ? "$a [$prefix$infix] $b" : "$a <$prefix$infix> $b";
+        }
+    }
+    elsif ($clips =~ /(?x) ^ \( (line|plane) \s+ (\S+) \) $/) {
+        #warn "$1, $2";
+        my ($type, $a) = ($1, $2);
+        my $prefix = $prefix{$type};
+        return "$prefix $a";
+    }
+    elsif ($clips =~ /(?x) ^ \( (\S+) ((?:\s+ \S+)*) \) $/) {
+        my ($func, $args) = ($1, $2);
+        $args =~ s/^\s+//g;
+        my @args = split /\s+/, $args;
+        return "$func(" . join(',', @args) . ')';
+    }
+    $clips;
+}

xclips.grammar

@@ -30,11 +30,21 @@ conjunction : clause ',' <commit> conjunction
 
 clause : prefix <commit> atom
 
-            { "($item{prefix}$item{atom})" }
-
-       | atom <skip:''> /\s+/ general_infix <commit> <skip:'\s*'> atom
-
-            { "($item{general_infix}$item[1] $item[7])" }
+            { my $s = $item{prefix};
+              my ($open, $close) = (0, 0);
+              $open++ while $s =~ /\(/g;
+              $close++ while $s =~ /\)/g;
+              "($s$item{atom})" . (')' x ($open - $close))
+            }
+
+       | atom <skip:''> /\s+/ general_infix /\s+/ <commit> <skip:'\s*'> atom
+
+            { my $s = $item{general_infix};
+              my ($open, $close) = (0, 0);
+              $open++ while $s =~ /\(/g;
+              $close++ while $s =~ /\)/g;
+              "($s$item[1] $item[8])" . (')' x ($open - $close))
+            }
 
        | atom <skip:''> postfix
 

xclips.pl

@@ -24,6 +24,12 @@
 
 our (%prefix, %infix, %infix_prefix, %infix_circumfix, %infix_circum_close);
 
+%infix = (
+    'neq'  => "test (neq ",
+    'eq'   => "test (eq ",
+    ':='  => "bind ",
+);
+
 $::RD_HINT = 1;
 #$::RD_TRACE = 1;
 our $parser = CLIPSx->new;