Browse files

[VRG]

- removed redundant stuff from VRG (we now have separate
  XClips project)

git-svn-id: http://svn.berlios.de/svnroot/repos/unisimu/VRG@896 625e195c-0704-0410-94f2-f261ee9f2fe7
  • Loading branch information...
1 parent 2b5b572 commit 6c5811c743bf7cbdedee5de681eee09f4ad6373b agent committed Dec 10, 2006
Showing with 0 additions and 503 deletions.
  1. +0 −183 grammar/xclips.grammar
  2. +0 −122 lib/XClips/Compiler.pm
  3. +0 −85 script/clips-cover.pl
  4. +0 −113 script/xclips.pl
View
183 grammar/xclips.grammar
@@ -1,183 +0,0 @@
-program : statement(s) eofile { join "\n\n", grep $_, @{ $item[1] } }
- | <error>
-
-comment : /\/\*(.*?)\*\//s ws { my $cmt = "; $1"; $cmt =~ s/\n(?=.)/;/g; $cmt }
-
-rule : disjunction '=>' <commit> new_facts '.'
-
- { $::count++;
- "; $::infile (line $thisline)\n".
- "(defrule $::module$::base-$thisline\n".
- " $item[1]\n".
- " =>\n".
- "$item[4])" } ws { $item[6] }
-
- | <error?> <reject>
-
-disjunction : conjunction ';' <commit> disjunction
-
- { "(or $item{conjunction} $item{disjunction})" }
-
- | conjunction
- | <error?> <reject>
-
-conjunction : clause ',' <commit> conjunction
-
- { "(and $item{clause} $item{conjunction})" }
-
- | '(' <commit> disjunction ')' { $item{disjunction} }
- | clause
- | <error?> <reject>
-
-clause : prefix <commit> atom
-
- { 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
-
- { "($item{postfix}$item{atom})" }
-
- | atom
- | <error?> <reject>
-
-prefix : { ::match_prefix($text) } <commit> { $::prefix{$item[1]} }
-
-atom : predicate
- | variable
- | literal
-
-predicate : identifier /\(\s*\)/ <commit> { "($item{identifier})" }
- | identifier '(' <commit> arguments ')' { "($item[1] $item{arguments})" }
- | <error?> <reject>
-
-eofile : /^\Z/
-
-statement : comment
- | directive
- | rule
- | facts '.' <commit> ws { '' }
- | <error>
-
-facts : fact ',' <commit> facts
- | fact
- | <error?> <reject>
-
-fact : clause { push @::facts, "; $::infile (line $thisline)",
- "$item{clause}\n"; '' }
-
-ws: /[\n\s]*/
-
-directive : 'module' <commit> identifier '.' ws
-
- { $::module = $item{identifier} . '::'; '' }
-
- | 'include' <commit> string /\.?/ ws
-
- { my $res = ::process_include(eval $item{string}, $thisline) }
-
- | 'define' <commit> predicate /\.?/ ws
-
- { $item{predicate} }
-
- | 'prefix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
-
- { $::prefix{$item{pattern}} = eval $item{target};
- @::prefix = sort { -($a cmp $b) } keys %::prefix; '' }
-
- | 'infix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
-
- { $::infix{$item{pattern}} = eval $item{target};
- @::infix = sort { -($a cmp $b) } keys %::infix; '' }
-
- | 'infix_prefix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
-
- { $::infix_prefix{$item{pattern}} = eval $item{target};
- @::infix_prefix = sort { -($a cmp $b) } keys %::infix_prefix; '' }
-
- | 'infix_circumfix:<' <commit> <skip:''> circum_pattern '>'
- <skip:'\s*'> target /\.?/ ws
-
- { my $pattern = $item{circum_pattern};
- #warn "~~~ @$pattern\n";
- $::infix_circumfix{$pattern->[0]} = eval $item{target};
- $::infix_circum_close{$pattern->[0]} = $pattern->[1];
- @::infix_circumfix = sort { -($a cmp $b) } keys %::infix_circumfix; '' }
-
- | <error?> <reject>
-
-target : identifier /\&?/ { $item[2] ? "'$item[1]'" : "'$item[1] '" }
- | string
-
-pattern : /\S+(?=>)/
-
-circum_pattern : /(\S+) (\S+)(?=>)/ <commit> { [$1, $2] }
-
-new_facts : new_fact ',' <commit> new_facts
-
- { $item{new_fact} . $item{new_facts} }
-
- | new_fact
- | <error?> <reject>
-
-new_fact : clause
-
- { $item[1] =~
- /(?x) ^ \( (?:bind|halt|printout|assert|format|open|read|close|exit) \b/ ?
- " $item[1]\n" : " (assert $item[1])\n" }
-
-general_infix : infix_circum_open <commit> general_infix
- { ::match_infix_circum_close($text, $item[1]) }
-
- { $::infix_circumfix{$item[1]} . $item{general_infix} }
-
- | infix_prefix <commit> general_infix { $item{infix_prefix} . $item{general_infix} }
- | infix
- | <error?> <reject>
-
-infix_circum_open : { ::match_infix_circum_open($text) }
-
-arguments : <leftop: clause ',' clause> <commit> { join ' ', @{ $item[1] } }
-
-variable : /\$?\?[A-Za-z_]([-\w])*/ <commit> { $item[1] . $item{identifier} }
- | /\$?\?/
-
-literal : identifier
- | number
- | string
- | <error>
-
-identifier : /[A-Za-z_]([-\w])*/
-
-number : /\d+(?:\.\d*)?/
- | /\.\d+/
-
-string : { extract_delimited($text, '"') }
- | { extract_delimited($text, "'") }
- | <error>
-
-infix_prefix : { ::match_infix_prefix($text) } <commit> { $::infix_prefix{$item[1]} }
-
-infix : variable <commit> { $item[1] . " " }
- | { ::match_infix($text) } <commit> { $::infix{$item[1]} }
-
-postfix : 'postfix'
-
-compound: <leftop: clause /([;,])/ clause>
-
- { "\n " . join "", (map { m/^[;,]$/ ? "$_\n " : $_ } @{ $item[1] }); }
-
- | <error>
View
122 lib/XClips/Compiler.pm
@@ -1,122 +0,0 @@
-package XClips::Compiler;
-
-use strict;
-use warnings;
-use File::Spec;
-
-use base 'XClips::Compiler::Base';
-
-#warn "Hi!!!";
-
-package main;
-
-use strict;
-use warnings;
-
-our $count;
-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);
-
-%prefix = (
- '~' => 'not ',
-);
-
-%infix = (
- '\=' => 'test (neq ',
- '==' => 'test (eq ',
- ':=' => 'bind ',
- '>=' => '>= ',
- '>' => '> ',
- '<=' => '<= ',
- '<' => "< ",
-);
-
-sub match_prefix {
- my @keys = @prefix;
- return match($_[0], \@keys);
-}
-
-sub match_infix {
- my @keys = @infix;
- return match($_[0], \@keys);
-}
-
-sub match_infix_prefix {
- my @keys = @infix_prefix;
- return match($_[0], \@keys);
-}
-
-sub match_infix_circum_open {
- my @keys = @infix_circumfix;
- #warn "infix_circum_open: @keys\n";
- return match($_[0], \@keys);
-}
-
-sub match_infix_circum_close {
- my $open = pop @_;
- my $close = $::infix_circum_close{$open};
- #warn "infix_circum_close: $close\n";
- return match($_[0], [$close]);
-}
-
-sub match {
- $_[0] =~ s/^\s+//;
- my $rkeys = pop;
- for my $key (@$rkeys) {
- #warn "$key => ", $::prefix{$key}, "\n";
- my $len = length($key);
- if (substr($_[0], 0, $len) eq $key) {
- #warn "!!! matched operator \"$key\"\n";
- $_[0] = substr($_[0], $len);
- return $key;
- }
- }
- return undef;
-}
-
-sub process_include {
- my ($fname, $linno) = @_;
- my $done;
- for my $dir (@Include) {
- my $file = File::Spec->catfile($dir, $fname);
- if (-f $file) {
- $fname = $file;
- $done = 1;
- last;
- }
- }
- if (!$done) {
- die "error: $::infile (line $linno): Can't find include file $fname ",
- "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;
- local $::infile = $fname;
-
- my ($base) = ($fname =~ /([\w-]+)\.\w+$/);
- $base = "f$base" if $base !~ /^[A-Za-z_]/;
- local $::base = $base;
-
- local $::count = 0;
-
- my $parser = XClips::Compiler->new;
- my $data = $parser->program($src);
- if (!defined $data) {
- die "error: $saved_infile (line $linno): can't include file $fname.\n";
- }
- #warn "$data!!!";
- $data;
-}
-
-1;
View
85 script/clips-cover.pl
@@ -1,85 +0,0 @@
-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 $hit;
-my @stats;
-while (my ($rule_name, $count) = each %rules) {
- push @stats, [$rule_name, $count];
- $hit++ if $count > 0;
-}
-@stats = sort {
- my $res = $a->[1] <=> $b->[1];
- ($res == 0) ? ($a->[0] cmp $b->[0]) : $res;
-} @stats;
-
-my $tb = Text::Table->new(
- "Rule", "Count"
-);
-
-$tb->load(@stats);
-print $tb->rule( '-' );
-print $tb->title;
-print $tb->rule( '-' );
-print $tb->body;
-printf("\nFor total %.02f%% of the rules have been fired.\n",
- "$hit.0"/scalar(keys %rules)*100);
-
-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++;
- }
- }
-}
View
113 script/xclips.pl
@@ -1,113 +0,0 @@
-use strict;
-use warnings;
-
-use Getopt::Long;
-use FindBin;
-use XClips::Compiler;
-use List::MoreUtils 'uniq';
-use File::Slurp;
-use Data::Dump::Streamer;
-
-GetOptions(
- 'I=s' => \@::Include,
- 'c' => \my $compile_only,
- 'trim' => \my $trim,
- 'debug' => \my $debug,
-) or help();
-
-sub help {
- die "usage: $0 [-I dir] infile\n";
-}
-
-my @infiles = map glob, @ARGV or help();
-
-my @outfiles;
-
-for my $infile (@infiles) {
- compile_file($infile);
-}
-
-if (!$compile_only) {
- run_clips();
-}
-
-sub compile_file {
- my $infile = shift;
- my $outfile;
-
- if ($infile !~ /\.clp$/i) {
- ($outfile = $infile) =~ s/\.xclp$/.clp/i;
- $outfile .= '.clp' if $outfile !~ /\.clp$/i;
-
- our ($base) = ($outfile =~ /([\w-]+)\.\w+$/);
- $base = "f$base" if $base !~ /^[A-Za-z_]/;
-
- my $source = read_file($infile);
-
- $::RD_HINT = 1;
- #$::RD_TRACE = 1;
- our $parser = XClips::Compiler->new;
- my $data = $parser->program($source);
- if (!defined $data) {
- die "abort.\n";
- }
- $data .= "\n" if $data and $data !~ /\n$/s;
- if (@::facts) {
- $data .= "(deffacts $base\n " . join("\n ", uniq @::facts). ")\n";
- }
- $data .= "\n" if $data and $data !~ /\n$/s;
-
- #my @elems = %infix_circumfix;
- #warn "\%infix_circumfix: @elems\n";
-
- #@elems = %infix_circum_close;
- #warn "\%infix_circum_close: @elems\n";
-
- if ($data) {
- write_file($outfile, $data);
- #print $data;
- }
- }
- push @outfiles, $outfile;
- #warn "OUT: @outfiles\n";
-}
-
-
-sub run_clips {
- if ($debug) {
- require Clips::Batch;
- require Clips::GraphViz;
- my $clips = Clips::Batch->new(@outfiles);
- $clips->watch('facts');
- $clips->watch('rules');
- $clips->reset;
- $clips->facts('*', \my $init_facts);
- $clips->rules('*', \my $rules);
- $clips->run(\my $run_log);
- $clips->eof;
- my $painter = Clips::GraphViz->new($init_facts, $run_log);
- my $outfile = 'a.png';
- $painter->draw(
- outfile => $outfile,
- trim => $trim,
- );
- warn "generating $outfile...\n";
-
- require YAML::Syck;
- my $db_dir = 'clips_cover_db';
- mkdir $db_dir if !-d $db_dir;
- my ($fname, $time);
- $time = time;
- while (my $rand = int rand 1000000) {
- $fname = "$db_dir/$time-$rand.yml";
- last if !-e $fname;
- }
- YAML::Syck::DumpFile($fname, [$rules, $run_log]);
- } else {
- require Clips::Batch;
- my $clips = Clips::Batch->new(@outfiles);
- $clips->reset;
- $clips->run(sub { print $_[0] if defined $_[0] });
- $clips->eof;
- }
-}

0 comments on commit 6c5811c

Please sign in to comment.