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 and applied 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, contains, possbly matches

=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 object 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

=item flags

Flag names (without the leading C<FLAG_>) can be used as-is, in which case
their corresponding flag value is used.

=item scalar object attributes

Object attributes that consist of a single value (C<name>, C<title>,
C<value> and so on) can be specified by simply using their name, in which
acse their corresponding value is used.

=item array objects attributes

The C<resist> array can be accessed by specifying C<< resist [ ATNR_type ]
>>.

Example: match an acid resistance higher than 30.

   resist[ATNR_ACID] > 30

=item functions

Some additional functions with or without arguments in parentheses are
available.

=item { BLOCK }

You can specify perl code to execute by putting it inside curly
braces. The last expression evaluated inside will become the result.

=item comparisons, <, <=, ==, =, !=, =>, >

You can compare expressions against constants via any of these
operators. If the constant is a string, then a string compare will be
done, otherwise a numerical comparison is used.

Example: match an object with name "schnops" that has a value >= 10.

   name="schnops" and value >= 10

=item uppercase constant names

Any uppercase word that exists as constant inside the C<cf::> namespace
(that is, any deliantra constant) can also be used as-is, but needs to be
specified in uppercase.

Example: match a type of POTION (using C<cf::POTION>).

   type=POTION

=back

=head2 FUNCTIONS

=over 4

=item any

This simply evaluates to true, and simply makes matching I<any> object a
bit easier to read.

=item has(match)

True iff the object has a matching inventory object.

=item count(select)

Number of matching objects - the context object for the C<select> are the
original context objects for the overall C<select>. # TODO bullshit

=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;

   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), "; # TODO
            } 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 = 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
}

if (0) {
   my $perl = parse '{ {1}}', 0;

   warn $perl, "\n";#d#
   $perl = eval "package cf::match::exec; no warnings; no feature; our \@ctx; sub { $perl }"; die if $@;
   use B::Deparse;
   warn  B::Deparse->new->coderef2text ($perl);
   exit 0;
}

1;

Revision:	1.7
Committed:	Sat Oct 10 05:39:48 2009 UTC (17 years ago) by root
Branch:	MAIN
Changes since 1.6:	+2 -5 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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	root	1.4	Find all inventory objects with value >= 10, which are not invisible:
22	root	1.1
23	root	1.4	value >= 10 and not invisible in inv
24	root	1.1
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	root	1.3	type=POTION also in type=CONTAINER and applied in inv
32	root	1.1
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	root	1.4	operator = '=' \| '==' \| '!=' \| '<' \| '<=' \| '>' \| '>='
58	root	1.1
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	root	1.4	TODO: repeatedly, env, contains, possbly matches
76	root	1.1
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	root	1.4	Once the set of context objects has been established, each object is
92	root	1.1	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	root	1.2	=item flags
188
189			Flag names (without the leading C<FLAG_>) can be used as-is, in which case
190			their corresponding flag value is used.
191
192			=item scalar object attributes
193
194			Object attributes that consist of a single value (C<name>, C<title>,
195			C<value> and so on) can be specified by simply using their name, in which
196			acse their corresponding value is used.
197
198			=item array objects attributes
199
200			The C<resist> array can be accessed by specifying C<< resist [ ATNR_type ]
201			>>.
202
203	root	1.4	Example: match an acid resistance higher than 30.
204	root	1.2
205			resist[ATNR_ACID] > 30
206
207			=item functions
208
209			Some additional functions with or without arguments in parentheses are
210			available.
211
212			=item { BLOCK }
213
214			You can specify perl code to execute by putting it inside curly
215			braces. The last expression evaluated inside will become the result.
216
217			=item comparisons, <, <=, ==, =, !=, =>, >
218
219			You can compare expressions against constants via any of these
220			operators. If the constant is a string, then a string compare will be
221			done, otherwise a numerical comparison is used.
222
223	root	1.4	Example: match an object with name "schnops" that has a value >= 10.
224	root	1.2
225	root	1.4	name="schnops" and value >= 10
226	root	1.2
227			=item uppercase constant names
228
229	root	1.4	Any uppercase word that exists as constant inside the C<cf::> namespace
230			(that is, any deliantra constant) can also be used as-is, but needs to be
231	root	1.2	specified in uppercase.
232
233			Example: match a type of POTION (using C<cf::POTION>).
234
235			type=POTION
236
237	root	1.1	=back
238
239			=head2 FUNCTIONS
240
241			=over 4
242
243	root	1.2	=item any
244
245			This simply evaluates to true, and simply makes matching I<any> object a
246			bit easier to read.
247
248	root	1.1	=item has(match)
249
250			True iff the object has a matching inventory object.
251
252			=item count(select)
253
254	root	1.4	Number of matching objects - the context object for the C<select> are the
255			original context objects for the overall C<select>. # TODO bullshit
256	root	1.1
257			=back
258
259			=cut
260
261
262			package cf::match;
263
264			use common::sense;
265
266			use List::Util ();
267
268			# parser state
269			# $_ # string to be parsed
270			our $all; # find all, or just the first matching object
271
272			{
273			package cf::match::exec;
274
275			use List::Util qw(first);
276
277			sub env_chain {
278			my @res;
279			push @res, $_
280			while $_ = $_->env;
281			@res
282			}
283
284			package cf::match::parser;
285
286			use common::sense;
287
288			sub ws {
289			/\G\s+/gc;
290			}
291
292			our %func = (
293			has => sub {
294			'first { ' . &match . ' } $_->inv'
295			},
296			count => sub {
297			local $all = 1;
298			'(scalar ' . &select . ')'
299			},
300			);
301
302			our %special = (
303			any => sub {
304			1
305			},
306			);
307
308			sub constant {
309			ws;
310
311			return $1 if /\G([\-\+0-9\.]+)/gc;
312			return "cf::$1" if /\G([A-Z0-9_]+)/gc;
313
314			#TODO better string parsing, also include ''
315			return $1 if /\G("[^"]+")/gc;
316
317			die "number, string or uppercase constant name expected\n";
318			}
319
320			our $flag = $cf::REFLECT{object}{flags};
321			our $sattr = $cf::REFLECT{object}{scalars};
322			our $aattr = $cf::REFLECT{object}{arrays};
323
324			sub expr {
325			# ws done by factor
326			my $res;
327
328			if (/\G ( \{ (?: (?> [^{}]+ ) \| (?-1) )* \} ) /gcx) {
329			# perl
330
331			my $expr = $1;
332
333			$res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";
334
335			} elsif (/\G([A-Za-z0-9_]+)/gc) {
336
337			if (my $func = $func{$1}) {
338			/\G\s*\(/gc
339			or die "'(' expected after function name\n";
340
341			$res .= $func->();
342
343			/\G\s*\)/gc
344			or die "')' expected after function arguments\n";
345
346			} elsif (my $func = $special{$1}) {
347			$res .= $func->();
348
349			} elsif (exists $flag->{lc $1}) {
350			$res .= "\$_->flag (cf::FLAG_\U$1)";
351
352			} elsif (exists $sattr->{$1}) {
353			$res .= "\$_->$1";
354
355			} elsif (exists $aattr->{$1}) {
356
357			$res .= "\$_->$1";
358
359			/\G\s*\[/gc
360			or die "'[' expected after array name\n";
361
362			$res .= "(" . constant . ")";
363
364			/\G\s*\]/gc
365			or die "']' expected after array index\n";
366
367			} else {
368			$res .= constant;
369			}
370
371			} else {
372			die "expr expected\n";
373			}
374
375			$res
376			}
377
378			our %stringop = (
379			"==" => "eq",
380			"!=" => "ne",
381			"<=" => "le",
382			">=" => "ge",
383			"<" => "lt",
384			">" => "gt",
385			);
386
387			sub factor {
388			ws;
389
390			my $res;
391
392			if (/\Gnot\b\s*/gc) {
393			$res .= "!";
394			}
395
396			if (/\G\(/gc) {
397			# ()
398			$res .= &match;
399			ws;
400			/\G\)/gc or die "')' expected\n";
401
402			} else {
403			my $expr = expr;
404
405			$res .= $expr;
406
407			if (/\G\s*([=!<>]=?)/gc) {
408			my $op = $1;
409
410			$op = "==" if $op eq "=";
411			my $const = constant;
412			$op = $stringop{$op} if $const =~ /^"/;
413
414			$res .= " $op $const";
415			}
416			}
417
418			"($res)"
419			}
420
421			sub match {
422			my $res = factor;
423
424			while () {
425			ws;
426			if (/\G(?=also\b\|in\b\|\)\|$)/gc) {
427			# early stop => faster and requires no backtracking
428			last;
429			} elsif (/\Gor\b/gc) {
430			$res .= " \|\| ";
431			} else {
432			/\Gand\b/gc;
433			$res .= " && ";
434			}
435			$res .= factor;
436			}
437
438			$res
439			}
440
441			sub select {
442			my $res;
443
444			my $also; # undef means first iteration
445			while () {
446			if (/\G\s*(inv\|env\|map)\b/gc) {
447			if ($1 eq "inv") {
448			$res .= " map+(${also}\$_->inv),";
449			} elsif ($1 eq "env") {
450	root	1.4	$res .= " map+(${also}env_chain), "; # TODO
451	root	1.1	} elsif ($1 eq "map") {
452			$res .= " map+(${also}\$_->map->at (\$_->x, \$_->y)),";
453			}
454			last unless /\G\s*in\b/gc;
455			} else {
456			$res .= " map+($also\$_->inv)," if defined $also;
457			$res .= $all ? " grep { " : " first {";
458			$res .= match;
459			$res .= "}";
460
461			$also = /\G\s*also\b/gc ? '$_, ' : '';
462			last unless /\G\s*in\b/gc;
463			}
464			}
465
466			"$res \@ctx"
467			}
468
469			}
470
471			sub parse($;$) {
472			local $_ = shift;
473			local $all = shift;
474
475	root	1.7	my $res = cf::match::parser::select;
476	root	1.1
477			if ($@) {
478			my $ctx = 20;
479			my $str = substr $_, (List::Util::max 0, (pos) - $ctx), $ctx * 2;
480			substr $str, (List::Util::min $ctx, pos), 0, "<-- HERE -->";
481
482			chomp $@;
483			die "$@ ($str)\n";
484			}
485
486			$res
487			}
488
489	root	1.6	if (0) {
490	root	1.5	my $perl = parse '{ {1}}', 0;
491	root	1.1
492	root	1.2	warn $perl, "\n";#d#
493	root	1.7	$perl = eval "package cf::match::exec; no warnings; no feature; our \@ctx; sub { $perl }"; die if $@;
494	root	1.2	use B::Deparse;
495			warn B::Deparse->new->coderef2text ($perl);
496			exit 0;
497			}
498	root	1.1
499			1;
500