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

=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 resitance 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 inide the C<cf::> namespace
(that is, any deliatra 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 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
}

if (0) {
   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.2
Committed:	Sat Oct 10 05:17:46 2009 UTC (14 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.1:	+63 -7 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			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	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			Example: match an acid resitance higher than 30.
204
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			Example: match an object with name "schnops" that has a value > 10.
224
225			name="schnops" and value > 10
226
227			=item uppercase constant names
228
229			Any uppercase word that exists as constant inide the C<cf::> namespace
230			(that is, any deliatra constant) can also be used as-is, but needs to be
231			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			Number of matching inventory objects.
255
256			=back
257
258			=cut
259
260
261			package cf::match;
262
263			use common::sense;
264
265			use List::Util ();
266
267			# parser state
268			# $_ # string to be parsed
269			our $all; # find all, or just the first matching object
270
271			{
272			package cf::match::exec;
273
274			our @ctx; # root object(s)
275
276			use List::Util qw(first);
277
278			sub env_chain {
279			my @res;
280			push @res, $_
281			while $_ = $_->env;
282			@res
283			}
284
285			package cf::match::parser;
286
287			use common::sense;
288
289			sub ws {
290			/\G\s+/gc;
291			}
292
293			our %func = (
294			has => sub {
295			'first { ' . &match . ' } $_->inv'
296			},
297			count => sub {
298			local $all = 1;
299			'(scalar ' . &select . ')'
300			},
301			);
302
303			our %special = (
304			any => sub {
305			1
306			},
307			);
308
309			sub constant {
310			ws;
311
312			return $1 if /\G([\-\+0-9\.]+)/gc;
313			return "cf::$1" if /\G([A-Z0-9_]+)/gc;
314
315			#TODO better string parsing, also include ''
316			return $1 if /\G("[^"]+")/gc;
317
318			die "number, string or uppercase constant name expected\n";
319			}
320
321			our $flag = $cf::REFLECT{object}{flags};
322			our $sattr = $cf::REFLECT{object}{scalars};
323			our $aattr = $cf::REFLECT{object}{arrays};
324
325			sub expr {
326			# ws done by factor
327			my $res;
328
329			if (/\G ( \{ (?: (?> [^{}]+ ) \| (?-1) )* \} ) /gcx) {
330			# perl
331
332			my $expr = $1;
333
334			$res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";
335
336			} elsif (/\G([A-Za-z0-9_]+)/gc) {
337
338			if (my $func = $func{$1}) {
339			/\G\s*\(/gc
340			or die "'(' expected after function name\n";
341
342			$res .= $func->();
343
344			/\G\s*\)/gc
345			or die "')' expected after function arguments\n";
346
347			} elsif (my $func = $special{$1}) {
348			$res .= $func->();
349
350			} elsif (exists $flag->{lc $1}) {
351			$res .= "\$_->flag (cf::FLAG_\U$1)";
352
353			} elsif (exists $sattr->{$1}) {
354			$res .= "\$_->$1";
355
356			} elsif (exists $aattr->{$1}) {
357
358			$res .= "\$_->$1";
359
360			/\G\s*\[/gc
361			or die "'[' expected after array name\n";
362
363			$res .= "(" . constant . ")";
364
365			/\G\s*\]/gc
366			or die "']' expected after array index\n";
367
368			} else {
369			$res .= constant;
370			}
371
372			} else {
373			die "expr expected\n";
374			}
375
376			$res
377			}
378
379			our %stringop = (
380			"==" => "eq",
381			"!=" => "ne",
382			"<=" => "le",
383			">=" => "ge",
384			"<" => "lt",
385			">" => "gt",
386			);
387
388			sub factor {
389			ws;
390
391			my $res;
392
393			if (/\Gnot\b\s*/gc) {
394			$res .= "!";
395			}
396
397			if (/\G\(/gc) {
398			# ()
399			$res .= &match;
400			ws;
401			/\G\)/gc or die "')' expected\n";
402
403			} else {
404			my $expr = expr;
405
406			$res .= $expr;
407
408			if (/\G\s*([=!<>]=?)/gc) {
409			my $op = $1;
410
411			$op = "==" if $op eq "=";
412			my $const = constant;
413			$op = $stringop{$op} if $const =~ /^"/;
414
415			$res .= " $op $const";
416			}
417			}
418
419			"($res)"
420			}
421
422			sub match {
423			my $res = factor;
424
425			while () {
426			ws;
427			if (/\G(?=also\b\|in\b\|\)\|$)/gc) {
428			# early stop => faster and requires no backtracking
429			last;
430			} elsif (/\Gor\b/gc) {
431			$res .= " \|\| ";
432			} else {
433			/\Gand\b/gc;
434			$res .= " && ";
435			}
436			$res .= factor;
437			}
438
439			$res
440			}
441
442			sub select {
443			my $res;
444
445			my $also; # undef means first iteration
446			while () {
447			if (/\G\s*(inv\|env\|map)\b/gc) {
448			if ($1 eq "inv") {
449			$res .= " map+(${also}\$_->inv),";
450			} elsif ($1 eq "env") {
451			$res .= " map+(${also}env_chain), ";
452			} elsif ($1 eq "map") {
453			$res .= " map+(${also}\$_->map->at (\$_->x, \$_->y)),";
454			}
455			last unless /\G\s*in\b/gc;
456			} else {
457			$res .= " map+($also\$_->inv)," if defined $also;
458			$res .= $all ? " grep { " : " first {";
459			$res .= match;
460			$res .= "}";
461
462			$also = /\G\s*also\b/gc ? '$_, ' : '';
463			last unless /\G\s*in\b/gc;
464			}
465			}
466
467			"$res \@ctx"
468			}
469
470			}
471
472			sub parse($;$) {
473			local $_ = shift;
474			local $all = shift;
475
476			my $res = "package cf::match::exec;\n"
477			. eval { cf::match::parser::select };
478
479			if ($@) {
480			my $ctx = 20;
481			my $str = substr $_, (List::Util::max 0, (pos) - $ctx), $ctx * 2;
482			substr $str, (List::Util::min $ctx, pos), 0, "<-- HERE -->";
483
484			chomp $@;
485			die "$@ ($str)\n";
486			}
487
488			$res
489			}
490
491	root	1.2	if (0) {
492			my $perl = parse 'flag(SEE_IN_DARK) in inv', 0;
493	root	1.1
494	root	1.2	warn $perl, "\n";#d#
495			$perl = eval "no warnings; no feature; sub { $perl }"; die if $@;
496			use B::Deparse;
497			warn B::Deparse->new->coderef2text ($perl);
498			exit 0;
499			}
500	root	1.1
501			1;
502