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;

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