lib/cf/match.pm

=head1 NAME

cf::match - object matching language

=head1 DESCRIPTION

This module implements a simple object matching language. It can be asked
to find any (boolean context), or all (list context), matching objects.

=head1 MATCH EXAMPLES

Match the object if it has a slaying field of C<key1>:

   slaying = "key1"

Match the object if it has an object with name C<force> and 
slaying C<poison> in it's inventory:

   has (name = "force" and slaying = "poison")

Find all inventory objects with value > 10, which are not invisible:

   value > 10 and not invisible in inv

Find all potions with spell objects inside them in someones inventory:

   type=SPELL in type=POTION in inv

Find all potions inside someones inventory, or inside applied containers:

   type=POTION also in type=CONTAINER in inv

=head1 LANGUAGE

   # object selection

   select   = set
            | select also rep 'in' set
   also     = nothing | 'also'
   rep      = nothing | 'rep' | 'repeatedly'

   set      = 'inv' | 'env' | 'map'

   empty    =

   # object matching

   match    = factor
            | factor 'and'? match
            | factor 'or'   match

   factor   = 'not' factor
            | '(' match ')'
            | expr
            | expr operator constant

   operator = '=' | '!=' | '>' | '<' | '<=' | '>='

   expr     = flag
            | sattr
            | aattr '[' <constant> ']'
            | special
            | func '(' args ')'
            | '{' perl code block '}'

   func     = <any function name>
   sattr    = <any scalar object attribute>
   aattr    = <any array object attribute>
   flag     = <any object flag>
   special  = <any ()-less "function">

   constant = <number> | '"' <string> '"' | <uppercase cf::XXX name>
   args     = <depends on function>

   TODO: repeatedly, env

=head2 STRUCTURE

The two main structures are the C<select>, which selects objects matching
various criteria, and the C<match>, which determines if an object matches
some desired properties.

A C<select> is passed a set of "context objects" that it is applied
to. This is initially just one object - for altars, it is the object
dropped on it, for pedestals, the object on top of it and so on.

This set of context objects can be modified in various ways, for example
by replacing it with the inventories of all objects, or all objects on the
same mapspace, and so on, by using the C<in> operator.

Once the set of context objects has been established, each objetc is
matched against the C<match> expression. Sometimes the server is only
interested in knowing whether I<anything> matches, and sometimes the
server is interested in I<all> objects that match.

=head2 OPERATORS

=over 4

=item and, or, not, ()

Match expressions can be combined with C<and> or C<or> to build larger
expressions. C<not> negates the expression, and parentheses can be used to
group match expressions.

Example: match applied weapons.

   type=WEAPON and applied

Example: match horns or rods.

   type=HORN or type=ROD

=item in ...

The in operator takes the context set and modifies it in various ways.

=over 4

=item in inv

Replaces all objects by their inventory.

Example: find all spell objects inside the object to be matched.

   type=SPELL in inv

=item in env

Replaces all objects by their containing object, if they have one.

=item in map

Replaces all objects by the objects that are on the same mapspace as them.

=item in <match>

Finds all context objects matching the match expression, and then puts
their inventories into the context set.

Note that C<in inv> is simply a special case of an C<< in <match> >> that
matches any object.

Example: find all spells inside potions inside the inventory of the context
object(s).

   type=SPELL in type=POTION in inv

=item also in ...

Instead of replacing the context set with something new, the new objects
are added to the existing set.

Example: check if the context object I<is> a spell, or I<contains> a spell.

   type=SPELL also in inv

=item repeatedly in ...

Repeats the operation as many times as possible. This can be used to
recursively look into objects.

=item also repeatedly in ...

C<also> and C<repeatedly> can be combined.

Example: check if there are any unpaid items in an inventory,
or in the inventories of the inventory objects, and so on.

   unpaid also repeatedly in inv

Example: check if a object is inside a player.

   type=PLAYER also repeatedly in env

=back

=back

=head2 EXPRESSIONS

Match expressions usually consist of simple boolean checks (flag XYZ is
set) or simple comparisons.

=over 4

=back

=head2 FUNCTIONS

=over 4

=item has(match)

True iff the object has a matching inventory object.

=item count(select)

Number of matching inventory objects.

=back

=cut


package cf::match;

use common::sense;

use List::Util ();

# parser state
#   $_    # string to be parsed
our $all; # find all, or just the first matching object

{
   package cf::match::exec;

   our @ctx; # root object(s)

   use List::Util qw(first);

   sub env_chain {
      my @res;
      push @res, $_
         while $_ = $_->env;
      @res
   }

   package cf::match::parser;

   use common::sense;

   sub ws {
      /\G\s+/gc;
   }

   our %func = (
      has => sub {
         'first { ' . &match . ' } $_->inv'
      },
      count => sub {
         local $all = 1;
         '(scalar ' . &select . ')'
      },
   );

   our %special = (
      any => sub {
         1
      },
   );

   sub constant {
      ws;

      return $1       if /\G([\-\+0-9\.]+)/gc;
      return "cf::$1" if /\G([A-Z0-9_]+)/gc;

      #TODO better string parsing, also include ''
      return $1       if /\G("[^"]+")/gc;

      die "number, string or uppercase constant name expected\n";
   }

   our $flag  = $cf::REFLECT{object}{flags};
   our $sattr = $cf::REFLECT{object}{scalars};
   our $aattr = $cf::REFLECT{object}{arrays};

   sub expr {
      # ws done by factor
      my $res;

      if (/\G ( \{ (?: (?> [^{}]+ ) | (?-1) )* \} ) /gcx) {
         # perl

         my $expr = $1;

         $res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";

      } elsif (/\G([A-Za-z0-9_]+)/gc) {

         if (my $func = $func{$1}) {
            /\G\s*\(/gc
               or die "'(' expected after function name\n";

            $res .= $func->();

            /\G\s*\)/gc
               or die "')' expected after function arguments\n";

         } elsif (my $func = $special{$1}) {
            $res .= $func->();

         } elsif (exists $flag->{lc $1}) {
            $res .= "\$_->flag (cf::FLAG_\U$1)";

         } elsif (exists $sattr->{$1}) {
            $res .= "\$_->$1";

         } elsif (exists $aattr->{$1}) {

            $res .= "\$_->$1";

            /\G\s*\[/gc
               or die "'[' expected after array name\n";

            $res .= "(" . constant . ")";

            /\G\s*\]/gc
               or die "']' expected after array index\n";

         } else {
            $res .= constant;
         }

      } else {
         die "expr expected\n";
      }

      $res
   }

   our %stringop = (
      "==" => "eq",
      "!=" => "ne",
      "<=" => "le",
      ">=" => "ge",
      "<"  => "lt",
      ">"  => "gt",
   );

   sub factor {
      ws;

      my $res;

      if (/\Gnot\b\s*/gc) {
         $res .= "!";
      }

      if (/\G\(/gc) {
         # ()
         $res .= &match;
         ws;
         /\G\)/gc or die "')' expected\n";

      } else {
         my $expr = expr;

         $res .= $expr;

         if (/\G\s*([=!<>]=?)/gc) {
            my $op = $1;

            $op = "==" if $op eq "=";
            my $const = constant;
            $op = $stringop{$op} if $const =~ /^"/;

            $res .= " $op $const";
         }
      }

      "($res)"
   }

   sub match {
      my $res = factor;

      while () {
         ws;
         if (/\G(?=also\b|in\b|\)|$)/gc) {
            # early stop => faster and requires no backtracking
            last;
         } elsif (/\Gor\b/gc) {
            $res .= " || ";
         } else {
            /\Gand\b/gc;
            $res .= " && ";
         }
         $res .= factor;
      }

      $res
   }

   sub select {
      my $res;

      my $also; # undef means first iteration
      while () {
         if (/\G\s*(inv|env|map)\b/gc) {
            if ($1 eq "inv") {
               $res .= " map+(${also}\$_->inv),";
            } elsif ($1 eq "env") {
               $res .= " map+(${also}env_chain), ";
            } elsif ($1 eq "map") {
               $res .= " map+(${also}\$_->map->at (\$_->x, \$_->y)),";
            }
            last unless /\G\s*in\b/gc;
         } else {
            $res .= " map+($also\$_->inv)," if defined $also;
            $res .= $all ? " grep { " : " first {";
            $res .= match;
            $res .= "}";

            $also = /\G\s*also\b/gc ? '$_, ' : '';
            last unless /\G\s*in\b/gc;
         }
      }

      "$res \@ctx"
   }

}

sub parse($;$) {
   local $_   = shift;
   local $all = shift;

   my $res = "package cf::match::exec;\n"
           .  eval { cf::match::parser::select };

   if ($@) {
      my $ctx = 20;
      my $str = substr $_, (List::Util::max 0, (pos) - $ctx), $ctx * 2;
      substr $str, (List::Util::min $ctx, pos), 0, "<-- HERE -->";

      chomp $@;
      die "$@ ($str)\n";
   }

   $res
}

my $perl = parse 'flag(SEE_IN_DARK) in inv', 0;

warn $perl, "\n";#d#
$perl = eval "no warnings; no feature; sub { $perl }"; die if $@;
use B::Deparse;
warn  B::Deparse->new->coderef2text ($perl);

exit 0;

1;

Revision:	1.1
Committed:	Sat Oct 10 05:07:50 2009 UTC (14 years, 8 months ago) by root
Branch:	MAIN
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	cf::match - object matching language
4
5	=head1 DESCRIPTION
6
7	This module implements a simple object matching language. It can be asked
8	to find any (boolean context), or all (list context), matching objects.
9
10	=head1 MATCH EXAMPLES
11
12	Match the object if it has a slaying field of C<key1>:
13
14	slaying = "key1"
15
16	Match the object if it has an object with name C<force> and
17	slaying C<poison> in it's inventory:
18
19	has (name = "force" and slaying = "poison")
20
21	Find all inventory objects with value > 10, which are not invisible:
22
23	value > 10 and not invisible in inv
24
25	Find all potions with spell objects inside them in someones inventory:
26
27	type=SPELL in type=POTION in inv
28
29	Find all potions inside someones inventory, or inside applied containers:
30
31	type=POTION also in type=CONTAINER in inv
32
33	=head1 LANGUAGE
34
35	# object selection
36
37	select = set
38	\| select also rep 'in' set
39	also = nothing \| 'also'
40	rep = nothing \| 'rep' \| 'repeatedly'
41
42	set = 'inv' \| 'env' \| 'map'
43
44	empty =
45
46	# object matching
47
48	match = factor
49	\| factor 'and'? match
50	\| factor 'or' match
51
52	factor = 'not' factor
53	\| '(' match ')'
54	\| expr
55	\| expr operator constant
56
57	operator = '=' \| '!=' \| '>' \| '<' \| '<=' \| '>='
58
59	expr = flag
60	\| sattr
61	\| aattr '[' <constant> ']'
62	\| special
63	\| func '(' args ')'
64	\| '{' perl code block '}'
65
66	func = <any function name>
67	sattr = <any scalar object attribute>
68	aattr = <any array object attribute>
69	flag = <any object flag>
70	special = <any ()-less "function">
71
72	constant = <number> \| '"' <string> '"' \| <uppercase cf::XXX name>
73	args = <depends on function>
74
75	TODO: repeatedly, env
76
77	=head2 STRUCTURE
78
79	The two main structures are the C<select>, which selects objects matching
80	various criteria, and the C<match>, which determines if an object matches
81	some desired properties.
82
83	A C<select> is passed a set of "context objects" that it is applied
84	to. This is initially just one object - for altars, it is the object
85	dropped on it, for pedestals, the object on top of it and so on.
86
87	This set of context objects can be modified in various ways, for example
88	by replacing it with the inventories of all objects, or all objects on the
89	same mapspace, and so on, by using the C<in> operator.
90
91	Once the set of context objects has been established, each objetc is
92	matched against the C<match> expression. Sometimes the server is only
93	interested in knowing whether I<anything> matches, and sometimes the
94	server is interested in I<all> objects that match.
95
96	=head2 OPERATORS
97
98	=over 4
99
100	=item and, or, not, ()
101
102	Match expressions can be combined with C<and> or C<or> to build larger
103	expressions. C<not> negates the expression, and parentheses can be used to
104	group match expressions.
105
106	Example: match applied weapons.
107
108	type=WEAPON and applied
109
110	Example: match horns or rods.
111
112	type=HORN or type=ROD
113
114	=item in ...
115
116	The in operator takes the context set and modifies it in various ways.
117
118	=over 4
119
120	=item in inv
121
122	Replaces all objects by their inventory.
123
124	Example: find all spell objects inside the object to be matched.
125
126	type=SPELL in inv
127
128	=item in env
129
130	Replaces all objects by their containing object, if they have one.
131
132	=item in map
133
134	Replaces all objects by the objects that are on the same mapspace as them.
135
136	=item in <match>
137
138	Finds all context objects matching the match expression, and then puts
139	their inventories into the context set.
140
141	Note that C<in inv> is simply a special case of an C<< in <match> >> that
142	matches any object.
143
144	Example: find all spells inside potions inside the inventory of the context
145	object(s).
146
147	type=SPELL in type=POTION in inv
148
149	=item also in ...
150
151	Instead of replacing the context set with something new, the new objects
152	are added to the existing set.
153
154	Example: check if the context object I<is> a spell, or I<contains> a spell.
155
156	type=SPELL also in inv
157
158	=item repeatedly in ...
159
160	Repeats the operation as many times as possible. This can be used to
161	recursively look into objects.
162
163	=item also repeatedly in ...
164
165	C<also> and C<repeatedly> can be combined.
166
167	Example: check if there are any unpaid items in an inventory,
168	or in the inventories of the inventory objects, and so on.
169
170	unpaid also repeatedly in inv
171
172	Example: check if a object is inside a player.
173
174	type=PLAYER also repeatedly in env
175
176	=back
177
178	=back
179
180	=head2 EXPRESSIONS
181
182	Match expressions usually consist of simple boolean checks (flag XYZ is
183	set) or simple comparisons.
184
185	=over 4
186
187	=back
188
189	=head2 FUNCTIONS
190
191	=over 4
192
193	=item has(match)
194
195	True iff the object has a matching inventory object.
196
197	=item count(select)
198
199	Number of matching inventory objects.
200
201	=back
202
203	=cut
204
205
206	package cf::match;
207
208	use common::sense;
209
210	use List::Util ();
211
212	# parser state
213	# $_ # string to be parsed
214	our $all; # find all, or just the first matching object
215
216	{
217	package cf::match::exec;
218
219	our @ctx; # root object(s)
220
221	use List::Util qw(first);
222
223	sub env_chain {
224	my @res;
225	push @res, $_
226	while $_ = $_->env;
227	@res
228	}
229
230	package cf::match::parser;
231
232	use common::sense;
233
234	sub ws {
235	/\G\s+/gc;
236	}
237
238	our %func = (
239	has => sub {
240	'first { ' . &match . ' } $_->inv'
241	},
242	count => sub {
243	local $all = 1;
244	'(scalar ' . &select . ')'
245	},
246	);
247
248	our %special = (
249	any => sub {
250	1
251	},
252	);
253
254	sub constant {
255	ws;
256
257	return $1 if /\G([\-\+0-9\.]+)/gc;
258	return "cf::$1" if /\G([A-Z0-9_]+)/gc;
259
260	#TODO better string parsing, also include ''
261	return $1 if /\G("[^"]+")/gc;
262
263	die "number, string or uppercase constant name expected\n";
264	}
265
266	our $flag = $cf::REFLECT{object}{flags};
267	our $sattr = $cf::REFLECT{object}{scalars};
268	our $aattr = $cf::REFLECT{object}{arrays};
269
270	sub expr {
271	# ws done by factor
272	my $res;
273
274	if (/\G ( \{ (?: (?> [^{}]+ ) \| (?-1) )* \} ) /gcx) {
275	# perl
276
277	my $expr = $1;
278
279	$res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";
280
281	} elsif (/\G([A-Za-z0-9_]+)/gc) {
282
283	if (my $func = $func{$1}) {
284	/\G\s*\(/gc
285	or die "'(' expected after function name\n";
286
287	$res .= $func->();
288
289	/\G\s*\)/gc
290	or die "')' expected after function arguments\n";
291
292	} elsif (my $func = $special{$1}) {
293	$res .= $func->();
294
295	} elsif (exists $flag->{lc $1}) {
296	$res .= "\$_->flag (cf::FLAG_\U$1)";
297
298	} elsif (exists $sattr->{$1}) {
299	$res .= "\$_->$1";
300
301	} elsif (exists $aattr->{$1}) {
302
303	$res .= "\$_->$1";
304
305	/\G\s*\[/gc
306	or die "'[' expected after array name\n";
307
308	$res .= "(" . constant . ")";
309
310	/\G\s*\]/gc
311	or die "']' expected after array index\n";
312
313	} else {
314	$res .= constant;
315	}
316
317	} else {
318	die "expr expected\n";
319	}
320
321	$res
322	}
323
324	our %stringop = (
325	"==" => "eq",
326	"!=" => "ne",
327	"<=" => "le",
328	">=" => "ge",
329	"<" => "lt",
330	">" => "gt",
331	);
332
333	sub factor {
334	ws;
335
336	my $res;
337
338	if (/\Gnot\b\s*/gc) {
339	$res .= "!";
340	}
341
342	if (/\G\(/gc) {
343	# ()
344	$res .= &match;
345	ws;
346	/\G\)/gc or die "')' expected\n";
347
348	} else {
349	my $expr = expr;
350
351	$res .= $expr;
352
353	if (/\G\s*([=!<>]=?)/gc) {
354	my $op = $1;
355
356	$op = "==" if $op eq "=";
357	my $const = constant;
358	$op = $stringop{$op} if $const =~ /^"/;
359
360	$res .= " $op $const";
361	}
362	}
363
364	"($res)"
365	}
366
367	sub match {
368	my $res = factor;
369
370	while () {
371	ws;
372	if (/\G(?=also\b\|in\b\|\)\|$)/gc) {
373	# early stop => faster and requires no backtracking
374	last;
375	} elsif (/\Gor\b/gc) {
376	$res .= " \|\| ";
377	} else {
378	/\Gand\b/gc;
379	$res .= " && ";
380	}
381	$res .= factor;
382	}
383
384	$res
385	}
386
387	sub select {
388	my $res;
389
390	my $also; # undef means first iteration
391	while () {
392	if (/\G\s*(inv\|env\|map)\b/gc) {
393	if ($1 eq "inv") {
394	$res .= " map+(${also}\$_->inv),";
395	} elsif ($1 eq "env") {
396	$res .= " map+(${also}env_chain), ";
397	} elsif ($1 eq "map") {
398	$res .= " map+(${also}\$_->map->at (\$_->x, \$_->y)),";
399	}
400	last unless /\G\s*in\b/gc;
401	} else {
402	$res .= " map+($also\$_->inv)," if defined $also;
403	$res .= $all ? " grep { " : " first {";
404	$res .= match;
405	$res .= "}";
406
407	$also = /\G\s*also\b/gc ? '$_, ' : '';
408	last unless /\G\s*in\b/gc;
409	}
410	}
411
412	"$res \@ctx"
413	}
414
415	}
416
417	sub parse($;$) {
418	local $_ = shift;
419	local $all = shift;
420
421	my $res = "package cf::match::exec;\n"
422	. eval { cf::match::parser::select };
423
424	if ($@) {
425	my $ctx = 20;
426	my $str = substr $_, (List::Util::max 0, (pos) - $ctx), $ctx * 2;
427	substr $str, (List::Util::min $ctx, pos), 0, "<-- HERE -->";
428
429	chomp $@;
430	die "$@ ($str)\n";
431	}
432
433	$res
434	}
435
436	my $perl = parse 'flag(SEE_IN_DARK) in inv', 0;
437
438	warn $perl, "\n";#d#
439	$perl = eval "no warnings; no feature; sub { $perl }"; die if $@;
440	use B::Deparse;
441	warn B::Deparse->new->coderef2text ($perl);
442
443	exit 0;
444
445	1;
446