[VRG]

- implemented %Include in XClips::Compiler so as to
  prevent xclp file to be included recursively or
  more than once.
- added script/clips-cover.pl which can generate 
  rule coverage report from the yml data generated
  by script/vrg-run.pl
- added VRG::GraphViz to draw Vector Relation Graphs
- updated script/vrg-run.pl to generate *.vrg1.png
  and *.vrg2.png.
- added knowledge/goal-match.xclp to implement
  powerful postprocessing capability.


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

Makefile

@@ -13,7 +13,8 @@ mv_f = perl -MExtUtils::Command -e mv
 xpro_files := $(wildcard xprolog/*.xpro)
 pro_files  := $(patsubst %.xpro,%.pro, $(xpro_files))
 
-clp_files  := $(patsubst %,knowledge/%,vectorize.clp vector-eval.clp anti-vectorize.clp)
+clp_files  := $(patsubst %,knowledge/%,vectorize.clp vector-eval.clp \
+	anti-vectorize.clp goal-match.clp)
 
 vpath %.xclp knowledge
 vpath %.grammar grammar
@@ -54,6 +55,7 @@ test: clips_all
 clean:
 	$(rm_f) xprolog/*.pro xprolog/0*.xpro 0*.xclp *.clp *.vrg \
 		sample/*.clp sample/*.xclp *.png
+	perl script/clips-cover.pl -d
 
 veryclean: clean
 	$(rm_f) lib/XClips/Compiler/Base.pm lib/VRG/Compiler.pm \

TODO

@@ -1,7 +1,6 @@
-* prevent xclp file to be included recursively or more than once.
-* multiple goals support in the VRG script.
 * user-defined predicates support in VRG script.
-* generate VRG images.
 * abstract away the defmodule CLIPS directives in XClips
-* add space relations == and \= to solve the deep bug found by the
-  (now-commented-out) assertion in anti-vectorize.xclp
+* more detailed info in contradiction report
+* total coverage info by clips-cover.pl
+* more detailed info in vrg-run.pl's outputs
+

grammar/xclips.grammar

@@ -7,7 +7,7 @@ rule : disjunction '=>' <commit> new_facts '.'
 
         { $::count++;
           "; $::infile (line $thisline)\n".
-          "(defrule $::module$::base-$::count\n".
+          "(defrule $::module$::base-$thisline\n".
           "    $item[1]\n".
           "    =>\n".
           "$item[4])" } ws { $item[6] }

knowledge/goal-match.xclp

@@ -0,0 +1,19 @@
+define defmodule(GoalMatch,
+    import(Vectorize, deftemplate, space-relation, goal, contradiction),
+    import(MAIN, deftemplate, initial-fact)
+)
+
+/* goal matching rules */
+
+include "vrg-sugar.xclp"
+
+module GoalMatch.
+
+?a *[?R] ?b, ?a [?R] ?b
+=> solved(space-relation, ?R, ?a, ?b).
+
+?a *[?R] ?b, ~exists(?a [?R] ?b)
+=> pending(space-relation, ?R, ?a, ?b).
+
+pending(space-relation, ?, ?a, ?b), ?a [?R] ?b
+=> hint(space-relation, ?R, ?a, ?b).

knowledge/vector-eval.xclp

@@ -2,8 +2,7 @@
 
 define defmodule(
     Eval,
-    import(Vectorize, deftemplate, vector-relation),
-    import(Vectorize, deftemplate, contradiction)
+    import(Vectorize, deftemplate, vector-relation, contradiction)
 )
 
 module Eval.

lib/Clips/Batch.pm

@@ -45,7 +45,7 @@ sub eof {
     my @callbacks = $self->_callbacks;
     my $opts = $self->{opts};
     my $tempfile = mktemp("clips_cache_XXXXXXX");
-    my $cmd = "clips $opts > $tempfile 2>&1";
+    my $cmd = "clips $opts > $tempfile";
     #warn "$cmd";
     open my $out, "| $cmd" or
         die "can't spawn clips: $!";

lib/VRG/GraphViz.pm

@@ -0,0 +1,107 @@
+package VRG::GraphViz;
+
+use strict;
+use warnings;
+use GraphViz;
+
+my %format_rel = (
+    parallel     => '//',
+    orthogonal   => 'T',
+    cross        => 'X',
+);
+
+my %NodeStyle =
+(
+    shape => 'ellipse',
+    style => 'filled',
+    fillcolor => '#f5f694',
+);
+
+my %EdgeStyle =
+(
+    dir   => 'none',
+    color => 'grey',
+    #style => 'bold',
+);
+
+my %InitArgs = (
+    layout => 'circo',
+    node => \%NodeStyle,
+    edge => \%EdgeStyle,
+);
+
+sub new ($$) {
+    my $class = ref $_[0] ? ref shift : shift;
+    my $facts = shift;
+    open my $in, '<', \$facts or die;
+    my (%nodes, %edges);
+    while (<$in>) {
+        if (/(?x) ^ f-\d+ \s+ \(vector-relation \s+ (\S+) \s+ (\S+) \s+ (\S+) \)$/) {
+            my $rel = $1;
+            my ($a, $b) = sort $2, $3;
+            $rel = format_rel($rel);
+            #warn "$a $rel $b\n";
+            my $key = join ' ', $a, $b;
+            if (my $prev_rel = $edges{$key}) {
+                if ($rel ne $prev_rel and $rel =~ m{^(?:T|//|X)$}) {
+                    #warn "  replace ($prev_rel $key) with ($rel $key)...\n";
+                    $edges{$key} = $rel;
+                } else {
+                    #warn "  ignoring ($rel $key) due to ($prev_rel $key).\n";
+                }
+            } else {
+                #warn "adding ($rel $key)...\n";
+                $nodes{$a} = $nodes{$b} = 1;
+                $edges{$key} = $rel;
+            }
+        }
+    }
+    my @edges;
+    while (my ($key, $val) = each %edges) {
+        my ($a, $b) = split ' ', $key;
+        push @edges, [$val, $a, $b];
+    }
+    close $in;
+    bless {
+        nodes => [keys %nodes],
+        edges => \@edges,
+    }, $class;
+}
+
+sub as_png ($$) {
+    my ($self, $fname) = @_;
+    my @nodes = @{ $self->{nodes} };
+    my @edges = @{ $self->{edges} };
+    my $gv = GraphViz->new(%InitArgs);
+    for my $node (@nodes) {
+        $gv->add_node($node);
+    }
+    for my $edge (@edges) {
+        my ($rel, $a, $b) = @$edge;
+        my %style;
+        if ($rel eq '~//') {
+            %style = (color => 'red', style => 'dashed');
+        } elsif ($rel eq 'T') {
+            %style = (color => 'black');
+        } elsif ($rel eq '//') {
+            %style = (color => 'red');
+        } elsif ($rel eq 'X') {
+            %style = (color => 'black', style => 'dashed');
+        } else {
+            %style = (label => $rel);
+        }
+        $gv->add_edge($a => $b, %style);
+    }
+    $gv->as_png($fname);
+}
+
+sub format_rel ($) {
+    my $s = shift;
+    my $retval;
+    if ($s =~ s/^not_//) {
+        $retval = '~';
+    }
+    $retval .= $format_rel{$s};
+}
+
+1;

lib/XClips/Compiler.pm

@@ -18,6 +18,7 @@ our @facts;
 our $rel_type;
 our $module;
 our @Include = '.';
+our %Include;
 
 our (%prefix, %infix, %infix_prefix, %infix_circumfix, %infix_circum_close);
 our (@prefix, @infix, @infix_prefix, @infix_circumfix);
@@ -84,8 +85,12 @@ sub process_include {
     }
     if (!$done) {
         die "error: $::infile (line $linno): Can't find include file $fname ",
-            "in \@INC.\n\t(\@INC contains: @Include)\n";
+            "in \@Include.\n\t(\@Include contains: @Include)\n";
     }
+
+    my $path = File::Spec->rel2abs($fname);
+    return "" if $Include{$path};
+    $Include{$path} = 1;
     #warn "including file $fname...";
     my $src = read_file($fname);
     my $saved_infile = $::infile;

script/clips-cover.pl

@@ -0,0 +1,82 @@
+use strict;
+use warnings;
+
+use Getopt::Std;
+use Text::Table;
+use YAML::Syck;
+
+my %opts;
+getopts('d', \%opts);
+
+my $db_dir = 'clips_cover_db';
+
+if ($opts{d}) {
+    my @files = glob "$db_dir/*.yml";
+    for (@files) {
+        unlink($_);
+    }
+    rmdir $db_dir;
+    exit(0);
+}
+
+my $total_fires;
+my %rules;
+
+if (!-d $db_dir) {
+    die "No Coverage Database found.\n";
+}
+opendir my $dh, $db_dir or
+    die "error: Can't open $db_dir for reading: $!";
+while (my $entry = readdir($dh)) {
+    next if -d $entry or $entry !~ /\.yml$/i;
+    my $data = LoadFile("$db_dir/$entry");
+    #warn $data;
+    my ($rules, $fires) = @$data;
+    parse_rule_list($rules);
+    parse_fire_list($fires);
+}
+closedir $dh;
+
+my @stats;
+while (my ($rule_name, $count) = each %rules) {
+    my $ratio = sprintf("%.02f%%", "$count.0"/$total_fires*100);
+    push @stats, [$rule_name, $count, $ratio];
+}
+@stats = sort {
+    my $res = $a->[1] <=> $b->[1];
+    ($res == 0) ? ($a->[0] cmp $b->[0]) : $res;
+} @stats;
+
+my $tb = Text::Table->new(
+        "Rule", "Count", "Ratio"
+);
+
+$tb->load(@stats);
+print $tb->rule( '-' );
+print $tb->title;
+print $tb->rule( '-' );
+print $tb->body;
+
+sub parse_rule_list {
+    my $log = shift;
+    open my $in, '<', \$log or die;
+    while (<$in>) {
+        if (/^\s+(\S+)$/) {
+            my $rule_name = $1;
+            $rules{$rule_name} = 0 if !exists $rules{$rule_name};
+        }
+    }
+    close $in;
+}
+
+sub parse_fire_list {
+    my $log = shift;
+    open my $in, '<', \$log or die;
+    while (<$in>) {
+        if (/(?x) ^ FIRE \s+ \d+ \s+ (\S+):/) {
+            my $rule_name = $1;
+            $rules{$rule_name}++;
+            $total_fires++;
+        }
+    }
+}