line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package AI::Prolog::Parser::PreProcessor::Math; |
2
|
|
|
|
|
|
|
$REVISION = '$Id: Math.pm,v 1.3 2005/08/06 23:28:40 ovid Exp $'; |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
$VERSION = '0.01'; |
5
|
14
|
|
|
14
|
|
50047
|
use strict; |
|
14
|
|
|
|
|
27
|
|
|
14
|
|
|
|
|
518
|
|
6
|
14
|
|
|
14
|
|
72
|
use warnings; |
|
14
|
|
|
|
|
30
|
|
|
14
|
|
|
|
|
417
|
|
7
|
14
|
|
|
14
|
|
79
|
use Carp qw( croak ); |
|
14
|
|
|
|
|
33
|
|
|
14
|
|
|
|
|
916
|
|
8
|
14
|
|
|
14
|
|
1155
|
use Regexp::Common; |
|
14
|
|
|
|
|
6383
|
|
|
14
|
|
|
|
|
136
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my $var = qr/[[:upper:]][[:alnum:]_]*/; |
11
|
|
|
|
|
|
|
my $num = $RE{num}{real}; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# ** must be before * |
14
|
|
|
|
|
|
|
my $op = qr{(?:\*\*|[-+*/%])}; |
15
|
|
|
|
|
|
|
my $compare = qr/(?:(?:\\|=)?=|is|[<>]=?)/; |
16
|
|
|
|
|
|
|
my $lparen = qr/\(/; |
17
|
|
|
|
|
|
|
my $rparen = qr/\)/; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# Having a word boundary prior to $num breaks the regex |
20
|
|
|
|
|
|
|
# when trying to match negative numbers |
21
|
|
|
|
|
|
|
my $simple_math_term = qr/(?!\.(?![0-9]))(?:$num\b|\b$var\b)/; |
22
|
|
|
|
|
|
|
my $simple_rhs = qr/ |
23
|
|
|
|
|
|
|
$simple_math_term |
24
|
|
|
|
|
|
|
(?: |
25
|
|
|
|
|
|
|
\s* |
26
|
|
|
|
|
|
|
$op |
27
|
|
|
|
|
|
|
\s* |
28
|
|
|
|
|
|
|
$simple_math_term |
29
|
|
|
|
|
|
|
)* |
30
|
|
|
|
|
|
|
/x; |
31
|
|
|
|
|
|
|
my $simple_group_term = qr/$lparen\s*$simple_rhs\s*$rparen/; |
32
|
|
|
|
|
|
|
my $math_term = qr/(?:$simple_math_term|$simple_group_term)/; |
33
|
|
|
|
|
|
|
my $complex_rhs = qr/ |
34
|
|
|
|
|
|
|
$math_term |
35
|
|
|
|
|
|
|
(?: |
36
|
|
|
|
|
|
|
\s* |
37
|
|
|
|
|
|
|
$op |
38
|
|
|
|
|
|
|
\s* |
39
|
|
|
|
|
|
|
$math_term |
40
|
|
|
|
|
|
|
)* |
41
|
|
|
|
|
|
|
/x; |
42
|
|
|
|
|
|
|
my $complex_group_term = qr/$lparen\s*$complex_rhs\s*$rparen/; |
43
|
|
|
|
|
|
|
my $final_math_term = qr/(?:$math_term|$complex_group_term)/; |
44
|
|
|
|
|
|
|
my $rhs = qr/ |
45
|
|
|
|
|
|
|
$final_math_term |
46
|
|
|
|
|
|
|
(?: |
47
|
|
|
|
|
|
|
\s* |
48
|
|
|
|
|
|
|
$op |
49
|
|
|
|
|
|
|
\s* |
50
|
|
|
|
|
|
|
$final_math_term |
51
|
|
|
|
|
|
|
)* |
52
|
|
|
|
|
|
|
/x; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
my $expression = qr/ |
55
|
|
|
|
|
|
|
( |
56
|
|
|
|
|
|
|
($simple_math_term) |
57
|
|
|
|
|
|
|
\s+ |
58
|
|
|
|
|
|
|
($compare) |
59
|
|
|
|
|
|
|
\s+ |
60
|
|
|
|
|
|
|
($rhs) |
61
|
|
|
|
|
|
|
) |
62
|
|
|
|
|
|
|
(?=[,.]) |
63
|
|
|
|
|
|
|
/x; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my %convert = ( |
66
|
|
|
|
|
|
|
qw{ |
67
|
|
|
|
|
|
|
is is |
68
|
|
|
|
|
|
|
= eq |
69
|
|
|
|
|
|
|
+ plus |
70
|
|
|
|
|
|
|
/ div |
71
|
|
|
|
|
|
|
- minus |
72
|
|
|
|
|
|
|
% mod |
73
|
|
|
|
|
|
|
* mult |
74
|
|
|
|
|
|
|
** pow |
75
|
|
|
|
|
|
|
< lt |
76
|
|
|
|
|
|
|
<= le |
77
|
|
|
|
|
|
|
> gt |
78
|
|
|
|
|
|
|
>= ge |
79
|
|
|
|
|
|
|
== eq |
80
|
|
|
|
|
|
|
\= ne |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub process { |
85
|
94
|
|
|
94
|
0
|
13483
|
my ( $class, $prolog ) = @_; |
86
|
94
|
|
|
|
|
8307
|
while ( $prolog =~ $expression ) { |
87
|
23
|
|
|
|
|
124
|
my ( $old_expression, $lhs, $comp, $rhs ) = ( $1, $2, $3, $4 ); |
88
|
23
|
|
|
|
|
69
|
my $new_rhs = $class->_parse( $class->_lex($rhs) ); |
89
|
23
|
|
|
|
|
102
|
my $new_expression = sprintf |
90
|
|
|
|
|
|
|
"%s(%s, %s)" => $convert{$comp}, |
91
|
|
|
|
|
|
|
$lhs, $new_rhs; |
92
|
23
|
|
|
|
|
1278
|
$prolog =~ s/\Q$old_expression\E/$new_expression/g; |
93
|
|
|
|
|
|
|
} |
94
|
94
|
|
|
|
|
462
|
return $prolog; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub _lex { |
98
|
32
|
|
|
32
|
|
1511
|
my ( $class, $rhs ) = @_; |
99
|
32
|
|
|
|
|
73
|
my $lexer = _lexer($rhs); |
100
|
32
|
|
|
|
|
55
|
my @tokens; |
101
|
32
|
|
|
|
|
66
|
while ( my $token = $lexer->() ) { |
102
|
184
|
|
|
|
|
600
|
push @tokens => $token; |
103
|
|
|
|
|
|
|
} |
104
|
32
|
|
|
|
|
401
|
return \@tokens; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub _lexer { |
108
|
32
|
|
|
32
|
|
111
|
my $rhs = shift; |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
# the entire "$prev_op" thing is to allow the lexer to be aware of '7 + -3' |
111
|
|
|
|
|
|
|
# $op_ok is false on the first pass because it can never be first, but we |
112
|
|
|
|
|
|
|
# might have '-7 * (-2 + 3)' |
113
|
32
|
|
|
|
|
264
|
my $op_ok = 0; |
114
|
|
|
|
|
|
|
return sub { |
115
|
314
|
100
|
100
|
|
|
1848
|
LEXER: { |
116
|
216
|
|
|
216
|
|
272
|
$op_ok = 0, return [ 'OP', $1 ] |
117
|
|
|
|
|
|
|
if $op_ok && $rhs =~ /\G ($op) /gcx; |
118
|
258
|
100
|
|
|
|
3720
|
$op_ok = 1, return [ 'ATOM', $1 ] |
119
|
|
|
|
|
|
|
if $rhs =~ /\G ($simple_math_term) /gcx; |
120
|
170
|
100
|
|
|
|
1129
|
$op_ok = 0, return [ 'LPAREN', '(' ] |
121
|
|
|
|
|
|
|
if $rhs =~ /\G $lparen /gcx; |
122
|
150
|
100
|
|
|
|
620
|
$op_ok = 1, return [ 'RPAREN', ')' ] |
123
|
|
|
|
|
|
|
if $rhs =~ /\G $rparen /gcx; |
124
|
130
|
100
|
|
|
|
850
|
redo LEXER if $rhs =~ /\G \s+ /gcx; |
125
|
|
|
|
|
|
|
} |
126
|
32
|
|
|
|
|
217
|
}; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub _parse { |
130
|
31
|
|
|
31
|
|
57
|
my ( $class, $tokens ) = @_; |
131
|
31
|
|
|
|
|
40
|
my $parens_left = 1; |
132
|
31
|
|
|
|
|
68
|
REDUCE: while ($parens_left) { |
133
|
46
|
|
|
|
|
57
|
my ( $first, $last ); |
134
|
46
|
|
|
|
|
113
|
for my $i ( 0 .. $#$tokens ) { |
135
|
222
|
|
|
|
|
269
|
my $token = $tokens->[$i]; |
136
|
222
|
50
|
|
|
|
416
|
next unless $token; |
137
|
222
|
100
|
|
|
|
343
|
if ( "(" eq _as_string($token) ) { |
138
|
19
|
|
|
|
|
24
|
$first = $i; |
139
|
|
|
|
|
|
|
} |
140
|
222
|
100
|
|
|
|
10833
|
if ( ")" eq _as_string($token) ) { |
141
|
15
|
50
|
|
|
|
32
|
unless ( defined $first ) { |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# XXX I should probably cache the string and show it. |
144
|
|
|
|
|
|
|
# XXX But it doesn't matter because that shouldn't happen here |
145
|
0
|
|
|
|
|
0
|
croak( |
146
|
|
|
|
|
|
|
"Parse error in math pre-processor. Mismatched parens" |
147
|
|
|
|
|
|
|
); |
148
|
|
|
|
|
|
|
} |
149
|
15
|
|
|
|
|
22
|
$last = $i; |
150
|
15
|
|
|
|
|
68
|
$tokens->[$first] = $class->_parse_group( |
151
|
15
|
|
|
|
|
34
|
[ @{$tokens}[ $first + 1 .. $last - 1 ] ] ); |
152
|
15
|
|
|
|
|
98
|
undef $tokens->[$_] for $first + 1 .. $last; |
153
|
15
|
|
|
|
|
79
|
@$tokens = grep $_ => @$tokens; |
154
|
15
|
|
|
|
|
24
|
undef $first; |
155
|
15
|
|
|
|
|
19
|
undef $last; |
156
|
15
|
|
|
|
|
39
|
redo REDUCE; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
31
|
50
|
|
|
|
122
|
$parens_left = 0 unless defined $first; |
160
|
|
|
|
|
|
|
} |
161
|
31
|
|
|
|
|
89
|
return _as_string( $class->_parse_group($tokens) ); |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
sub _parse_group { |
165
|
46
|
|
|
46
|
|
72
|
my ( $class, $tokens ) = @_; |
166
|
46
|
|
|
|
|
330
|
foreach my $op_re ( qr{(?:\*\*|[*/])}, qr{[+-]}, qr/\%/ ) { |
167
|
138
|
|
|
|
|
300
|
for my $i ( 0 .. $#$tokens ) { |
168
|
334
|
|
|
|
|
436
|
my $token = $tokens->[$i]; |
169
|
334
|
100
|
100
|
|
|
3988
|
if ( ref $token && "@$token" =~ /OP ($op_re)/ ) { |
170
|
53
|
|
|
|
|
104
|
my $curr_op = $1; |
171
|
53
|
|
|
|
|
104
|
my $prev = _prev_token( $tokens, $i ); |
172
|
53
|
|
|
|
|
102
|
my $next = _next_token( $tokens, $i ); |
173
|
53
|
|
|
|
|
153
|
$tokens->[$i] = sprintf |
174
|
|
|
|
|
|
|
"%s(%s, %s)" => $convert{$curr_op}, |
175
|
|
|
|
|
|
|
_as_string( $tokens->[$prev] ), |
176
|
|
|
|
|
|
|
_as_string( $tokens->[$next] ); |
177
|
53
|
|
|
|
|
103
|
undef $tokens->[$prev]; |
178
|
53
|
|
|
|
|
148
|
undef $tokens->[$next]; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
} |
181
|
138
|
|
|
|
|
551
|
@$tokens = grep $_ => @$tokens; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
#main::diag Dumper $tokens; |
185
|
46
|
|
|
|
|
197
|
return $tokens->[0]; # should never have more than on token left |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub _prev_token { |
189
|
53
|
|
|
53
|
|
101
|
my ( $tokens, $index ) = @_; |
190
|
53
|
|
|
|
|
112
|
for my $i ( reverse 0 .. $index - 1 ) { |
191
|
57
|
100
|
|
|
|
174
|
return $i if defined $tokens->[$i]; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub _next_token { |
196
|
53
|
|
|
53
|
|
70
|
my ( $tokens, $index ) = @_; |
197
|
53
|
|
|
|
|
136
|
for my $i ( $index + 1 .. $#$tokens ) { |
198
|
53
|
50
|
|
|
|
152
|
return $i if defined $tokens->[$i]; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
581
|
100
|
|
581
|
|
2450
|
sub _as_string { ref $_[0] ? $_[0][1] : $_[0] } |
203
|
|
|
|
|
|
|
|
204
|
0
|
|
|
0
|
0
|
0
|
sub match { shift; shift =~ $expression } |
|
0
|
|
|
|
|
0
|
|
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# The following are testing hooks |
207
|
|
|
|
|
|
|
|
208
|
8
|
|
|
8
|
|
3428
|
sub _compare { shift; shift =~ /^$compare$/ } |
|
8
|
|
|
|
|
153
|
|
209
|
10
|
|
|
10
|
|
3938
|
sub _op { shift; shift =~ /^$op$/ } |
|
10
|
|
|
|
|
106
|
|
210
|
12
|
|
|
12
|
|
5362
|
sub _simple_rhs { shift; shift =~ /^$simple_rhs$/ } |
|
12
|
|
|
|
|
417
|
|
211
|
10
|
|
|
10
|
|
4805
|
sub _simple_group_term { shift; shift =~ /^$simple_group_term$/ } |
|
10
|
|
|
|
|
394
|
|
212
|
15
|
|
|
15
|
|
5665
|
sub _simple_math_term { shift; shift =~ /^$simple_math_term$/ } |
|
15
|
|
|
|
|
340
|
|
213
|
15
|
|
|
15
|
|
7415
|
sub _math_term { shift; shift =~ /^$math_term$/ } |
|
15
|
|
|
|
|
591
|
|
214
|
15
|
|
|
15
|
|
7571
|
sub _complex_rhs { shift; shift =~ /^$complex_rhs$/ } |
|
15
|
|
|
|
|
2152
|
|
215
|
20
|
|
|
20
|
|
8892
|
sub _complex_group_term { shift; shift =~ /^$complex_group_term$/ } |
|
20
|
|
|
|
|
837
|
|
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
1; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
__END__ |