Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

[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...
commit 6c5811c743bf7cbdedee5de681eee09f4ad6373b 1 parent 2b5b572
agent authored
183 grammar/xclips.grammar
... ... @@ -1,183 +0,0 @@
1   -program : statement(s) eofile { join "\n\n", grep $_, @{ $item[1] } }
2   - | <error>
3   -
4   -comment : /\/\*(.*?)\*\//s ws { my $cmt = "; $1"; $cmt =~ s/\n(?=.)/;/g; $cmt }
5   -
6   -rule : disjunction '=>' <commit> new_facts '.'
7   -
8   - { $::count++;
9   - "; $::infile (line $thisline)\n".
10   - "(defrule $::module$::base-$thisline\n".
11   - " $item[1]\n".
12   - " =>\n".
13   - "$item[4])" } ws { $item[6] }
14   -
15   - | <error?> <reject>
16   -
17   -disjunction : conjunction ';' <commit> disjunction
18   -
19   - { "(or $item{conjunction} $item{disjunction})" }
20   -
21   - | conjunction
22   - | <error?> <reject>
23   -
24   -conjunction : clause ',' <commit> conjunction
25   -
26   - { "(and $item{clause} $item{conjunction})" }
27   -
28   - | '(' <commit> disjunction ')' { $item{disjunction} }
29   - | clause
30   - | <error?> <reject>
31   -
32   -clause : prefix <commit> atom
33   -
34   - { my $s = $item{prefix};
35   - my ($open, $close) = (0, 0);
36   - $open++ while $s =~ /\(/g;
37   - $close++ while $s =~ /\)/g;
38   - "($s$item{atom})" . (')' x ($open - $close))
39   - }
40   -
41   - | atom <skip:''> /\s+/ general_infix /\s+/ <commit> <skip:'\s*'> atom
42   -
43   - { my $s = $item{general_infix};
44   - my ($open, $close) = (0, 0);
45   - $open++ while $s =~ /\(/g;
46   - $close++ while $s =~ /\)/g;
47   - "($s$item[1] $item[8])" . (')' x ($open - $close))
48   - }
49   -
50   - | atom <skip:''> postfix
51   -
52   - { "($item{postfix}$item{atom})" }
53   -
54   - | atom
55   - | <error?> <reject>
56   -
57   -prefix : { ::match_prefix($text) } <commit> { $::prefix{$item[1]} }
58   -
59   -atom : predicate
60   - | variable
61   - | literal
62   -
63   -predicate : identifier /\(\s*\)/ <commit> { "($item{identifier})" }
64   - | identifier '(' <commit> arguments ')' { "($item[1] $item{arguments})" }
65   - | <error?> <reject>
66   -
67   -eofile : /^\Z/
68   -
69   -statement : comment
70   - | directive
71   - | rule
72   - | facts '.' <commit> ws { '' }
73   - | <error>
74   -
75   -facts : fact ',' <commit> facts
76   - | fact
77   - | <error?> <reject>
78   -
79   -fact : clause { push @::facts, "; $::infile (line $thisline)",
80   - "$item{clause}\n"; '' }
81   -
82   -ws: /[\n\s]*/
83   -
84   -directive : 'module' <commit> identifier '.' ws
85   -
86   - { $::module = $item{identifier} . '::'; '' }
87   -
88   - | 'include' <commit> string /\.?/ ws
89   -
90   - { my $res = ::process_include(eval $item{string}, $thisline) }
91   -
92   - | 'define' <commit> predicate /\.?/ ws
93   -
94   - { $item{predicate} }
95   -
96   - | 'prefix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
97   -
98   - { $::prefix{$item{pattern}} = eval $item{target};
99   - @::prefix = sort { -($a cmp $b) } keys %::prefix; '' }
100   -
101   - | 'infix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
102   -
103   - { $::infix{$item{pattern}} = eval $item{target};
104   - @::infix = sort { -($a cmp $b) } keys %::infix; '' }
105   -
106   - | 'infix_prefix:<' <commit> <skip:''> pattern '>' <skip:'\s*'> target /\.?/ ws
107   -
108   - { $::infix_prefix{$item{pattern}} = eval $item{target};
109   - @::infix_prefix = sort { -($a cmp $b) } keys %::infix_prefix; '' }
110   -
111   - | 'infix_circumfix:<' <commit> <skip:''> circum_pattern '>'
112   - <skip:'\s*'> target /\.?/ ws
113   -
114   - { my $pattern = $item{circum_pattern};
115   - #warn "~~~ @$pattern\n";
116   - $::infix_circumfix{$pattern->[0]} = eval $item{target};
117   - $::infix_circum_close{$pattern->[0]} = $pattern->[1];
118   - @::infix_circumfix = sort { -($a cmp $b) } keys %::infix_circumfix; '' }
119   -
120   - | <error?> <reject>
121   -
122   -target : identifier /\&?/ { $item[2] ? "'$item[1]'" : "'$item[1] '" }
123   - | string
124   -
125   -pattern : /\S+(?=>)/
126   -
127   -circum_pattern : /(\S+) (\S+)(?=>)/ <commit> { [$1, $2] }
128   -
129   -new_facts : new_fact ',' <commit> new_facts
130   -
131   - { $item{new_fact} . $item{new_facts} }
132   -
133   - | new_fact
134   - | <error?> <reject>
135   -
136   -new_fact : clause
137   -
138   - { $item[1] =~
139   - /(?x) ^ \( (?:bind|halt|printout|assert|format|open|read|close|exit) \b/ ?
140   - " $item[1]\n" : " (assert $item[1])\n" }
141   -
142   -general_infix : infix_circum_open <commit> general_infix
143   - { ::match_infix_circum_close($text, $item[1]) }
144   -
145   - { $::infix_circumfix{$item[1]} . $item{general_infix} }
146   -
147   - | infix_prefix <commit> general_infix { $item{infix_prefix} . $item{general_infix} }
148   - | infix
149   - | <error?> <reject>
150   -
151   -infix_circum_open : { ::match_infix_circum_open($text) }
152   -
153   -arguments : <leftop: clause ',' clause> <commit> { join ' ', @{ $item[1] } }
154   -
155   -variable : /\$?\?[A-Za-z_]([-\w])*/ <commit> { $item[1] . $item{identifier} }
156   - | /\$?\?/
157   -
158   -literal : identifier
159   - | number
160   - | string
161   - | <error>
162   -
163   -identifier : /[A-Za-z_]([-\w])*/
164   -
165   -number : /\d+(?:\.\d*)?/
166   - | /\.\d+/
167   -
168   -string : { extract_delimited($text, '"') }
169   - | { extract_delimited($text, "'") }
170   - | <error>
171   -
172   -infix_prefix : { ::match_infix_prefix($text) } <commit> { $::infix_prefix{$item[1]} }
173   -
174   -infix : variable <commit> { $item[1] . " " }
175   - | { ::match_infix($text) } <commit> { $::infix{$item[1]} }
176   -
177   -postfix : 'postfix'
178   -
179   -compound: <leftop: clause /([;,])/ clause>
180   -
181   - { "\n " . join "", (map { m/^[;,]$/ ? "$_\n " : $_ } @{ $item[1] }); }
182   -
183   - | <error>
122 lib/XClips/Compiler.pm
... ... @@ -1,122 +0,0 @@
1   -package XClips::Compiler;
2   -
3   -use strict;
4   -use warnings;
5   -use File::Spec;
6   -
7   -use base 'XClips::Compiler::Base';
8   -
9   -#warn "Hi!!!";
10   -
11   -package main;
12   -
13   -use strict;
14   -use warnings;
15   -
16   -our $count;
17   -our @facts;
18   -our $rel_type;
19   -our $module;
20   -our @Include = '.';
21   -our %Include;
22   -
23   -our (%prefix, %infix, %infix_prefix, %infix_circumfix, %infix_circum_close);
24   -our (@prefix, @infix, @infix_prefix, @infix_circumfix);
25   -
26   -%prefix = (
27   - '~' => 'not ',
28   -);
29   -
30   -%infix = (
31   - '\=' => 'test (neq ',
32   - '==' => 'test (eq ',
33   - ':=' => 'bind ',
34   - '>=' => '>= ',
35   - '>' => '> ',
36   - '<=' => '<= ',
37   - '<' => "< ",
38   -);
39   -
40   -sub match_prefix {
41   - my @keys = @prefix;
42   - return match($_[0], \@keys);
43   -}
44   -
45   -sub match_infix {
46   - my @keys = @infix;
47   - return match($_[0], \@keys);
48   -}
49   -
50   -sub match_infix_prefix {
51   - my @keys = @infix_prefix;
52   - return match($_[0], \@keys);
53   -}
54   -
55   -sub match_infix_circum_open {
56   - my @keys = @infix_circumfix;
57   - #warn "infix_circum_open: @keys\n";
58   - return match($_[0], \@keys);
59   -}
60   -
61   -sub match_infix_circum_close {
62   - my $open = pop @_;
63   - my $close = $::infix_circum_close{$open};
64   - #warn "infix_circum_close: $close\n";
65   - return match($_[0], [$close]);
66   -}
67   -
68   -sub match {
69   - $_[0] =~ s/^\s+//;
70   - my $rkeys = pop;
71   - for my $key (@$rkeys) {
72   - #warn "$key => ", $::prefix{$key}, "\n";
73   - my $len = length($key);
74   - if (substr($_[0], 0, $len) eq $key) {
75   - #warn "!!! matched operator \"$key\"\n";
76   - $_[0] = substr($_[0], $len);
77   - return $key;
78   - }
79   - }
80   - return undef;
81   -}
82   -
83   -sub process_include {
84   - my ($fname, $linno) = @_;
85   - my $done;
86   - for my $dir (@Include) {
87   - my $file = File::Spec->catfile($dir, $fname);
88   - if (-f $file) {
89   - $fname = $file;
90   - $done = 1;
91   - last;
92   - }
93   - }
94   - if (!$done) {
95   - die "error: $::infile (line $linno): Can't find include file $fname ",
96   - "in \@Include.\n\t(\@Include contains: @Include)\n";
97   - }
98   -
99   - my $path = File::Spec->rel2abs($fname);
100   - return "" if $Include{$path};
101   - $Include{$path} = 1;
102   - #warn "including file $fname...";
103   - my $src = read_file($fname);
104   - my $saved_infile = $::infile;
105   - local $::infile = $fname;
106   -
107   - my ($base) = ($fname =~ /([\w-]+)\.\w+$/);
108   - $base = "f$base" if $base !~ /^[A-Za-z_]/;
109   - local $::base = $base;
110   -
111   - local $::count = 0;
112   -
113   - my $parser = XClips::Compiler->new;
114   - my $data = $parser->program($src);
115   - if (!defined $data) {
116   - die "error: $saved_infile (line $linno): can't include file $fname.\n";
117   - }
118   - #warn "$data!!!";
119   - $data;
120   -}
121   -
122   -1;
85 script/clips-cover.pl
... ... @@ -1,85 +0,0 @@
1   -use strict;
2   -use warnings;
3   -
4   -use Getopt::Std;
5   -use Text::Table;
6   -use YAML::Syck;
7   -
8   -my %opts;
9   -getopts('d', \%opts);
10   -
11   -my $db_dir = 'clips_cover_db';
12   -
13   -if ($opts{d}) {
14   - my @files = glob "$db_dir/*.yml";
15   - for (@files) {
16   - unlink($_);
17   - }
18   - rmdir $db_dir;
19   - exit(0);
20   -}
21   -
22   -my $total_fires;
23   -my %rules;
24   -
25   -if (!-d $db_dir) {
26   - die "No Coverage Database found.\n";
27   -}
28   -opendir my $dh, $db_dir or
29   - die "error: Can't open $db_dir for reading: $!";
30   -while (my $entry = readdir($dh)) {
31   - next if -d $entry or $entry !~ /\.yml$/i;
32   - my $data = LoadFile("$db_dir/$entry");
33   - #warn $data;
34   - my ($rules, $fires) = @$data;
35   - parse_rule_list($rules);
36   - parse_fire_list($fires);
37   -}
38   -closedir $dh;
39   -
40   -my $hit;
41   -my @stats;
42   -while (my ($rule_name, $count) = each %rules) {
43   - push @stats, [$rule_name, $count];
44   - $hit++ if $count > 0;
45   -}
46   -@stats = sort {
47   - my $res = $a->[1] <=> $b->[1];
48   - ($res == 0) ? ($a->[0] cmp $b->[0]) : $res;
49   -} @stats;
50   -
51   -my $tb = Text::Table->new(
52   - "Rule", "Count"
53   -);
54   -
55   -$tb->load(@stats);
56   -print $tb->rule( '-' );
57   -print $tb->title;
58   -print $tb->rule( '-' );
59   -print $tb->body;
60   -printf("\nFor total %.02f%% of the rules have been fired.\n",
61   - "$hit.0"/scalar(keys %rules)*100);
62   -
63   -sub parse_rule_list {
64   - my $log = shift;
65   - open my $in, '<', \$log or die;
66   - while (<$in>) {
67   - if (/^\s+(\S+)$/) {
68   - my $rule_name = $1;
69   - $rules{$rule_name} = 0 if !exists $rules{$rule_name};
70   - }
71   - }
72   - close $in;
73   -}
74   -
75   -sub parse_fire_list {
76   - my $log = shift;
77   - open my $in, '<', \$log or die;
78   - while (<$in>) {
79   - if (/(?x) ^ FIRE \s+ \d+ \s+ (\S+):/) {
80   - my $rule_name = $1;
81   - $rules{$rule_name}++;
82   - $total_fires++;
83   - }
84   - }
85   -}
113 script/xclips.pl
... ... @@ -1,113 +0,0 @@
1   -use strict;
2   -use warnings;
3   -
4   -use Getopt::Long;
5   -use FindBin;
6   -use XClips::Compiler;
7   -use List::MoreUtils 'uniq';
8   -use File::Slurp;
9   -use Data::Dump::Streamer;
10   -
11   -GetOptions(
12   - 'I=s' => \@::Include,
13   - 'c' => \my $compile_only,
14   - 'trim' => \my $trim,
15   - 'debug' => \my $debug,
16   -) or help();
17   -
18   -sub help {
19   - die "usage: $0 [-I dir] infile\n";
20   -}
21   -
22   -my @infiles = map glob, @ARGV or help();
23   -
24   -my @outfiles;
25   -
26   -for my $infile (@infiles) {
27   - compile_file($infile);
28   -}
29   -
30   -if (!$compile_only) {
31   - run_clips();
32   -}
33   -
34   -sub compile_file {
35   - my $infile = shift;
36   - my $outfile;
37   -
38   - if ($infile !~ /\.clp$/i) {
39   - ($outfile = $infile) =~ s/\.xclp$/.clp/i;
40   - $outfile .= '.clp' if $outfile !~ /\.clp$/i;
41   -
42   - our ($base) = ($outfile =~ /([\w-]+)\.\w+$/);
43   - $base = "f$base" if $base !~ /^[A-Za-z_]/;
44   -
45   - my $source = read_file($infile);
46   -
47   - $::RD_HINT = 1;
48   - #$::RD_TRACE = 1;
49   - our $parser = XClips::Compiler->new;
50   - my $data = $parser->program($source);
51   - if (!defined $data) {
52   - die "abort.\n";
53   - }
54   - $data .= "\n" if $data and $data !~ /\n$/s;
55   - if (@::facts) {
56   - $data .= "(deffacts $base\n " . join("\n ", uniq @::facts). ")\n";
57   - }
58   - $data .= "\n" if $data and $data !~ /\n$/s;
59   -
60   - #my @elems = %infix_circumfix;
61   - #warn "\%infix_circumfix: @elems\n";
62   -
63   - #@elems = %infix_circum_close;
64   - #warn "\%infix_circum_close: @elems\n";
65   -
66   - if ($data) {
67   - write_file($outfile, $data);
68   - #print $data;
69   - }
70   - }
71   - push @outfiles, $outfile;
72   - #warn "OUT: @outfiles\n";
73   -}
74   -
75   -
76   -sub run_clips {
77   - if ($debug) {
78   - require Clips::Batch;
79   - require Clips::GraphViz;
80   - my $clips = Clips::Batch->new(@outfiles);
81   - $clips->watch('facts');
82   - $clips->watch('rules');
83   - $clips->reset;
84   - $clips->facts('*', \my $init_facts);
85   - $clips->rules('*', \my $rules);
86   - $clips->run(\my $run_log);
87   - $clips->eof;
88   - my $painter = Clips::GraphViz->new($init_facts, $run_log);
89   - my $outfile = 'a.png';
90   - $painter->draw(
91   - outfile => $outfile,
92   - trim => $trim,
93   - );
94   - warn "generating $outfile...\n";
95   -
96   - require YAML::Syck;
97   - my $db_dir = 'clips_cover_db';
98   - mkdir $db_dir if !-d $db_dir;
99   - my ($fname, $time);
100   - $time = time;
101   - while (my $rand = int rand 1000000) {
102   - $fname = "$db_dir/$time-$rand.yml";
103   - last if !-e $fname;
104   - }
105   - YAML::Syck::DumpFile($fname, [$rules, $run_log]);
106   - } else {
107   - require Clips::Batch;
108   - my $clips = Clips::Batch->new(@outfiles);
109   - $clips->reset;
110   - $clips->run(sub { print $_[0] if defined $_[0] });
111   - $clips->eof;
112   - }
113   -}

0 comments on commit 6c5811c

Please sign in to comment.
Something went wrong with that request. Please try again.