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 ("check for a match"), or all ("find all objects") 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 scrolls inside someones inventory, or inside applied scroll
containers:

   type=SCROLL also in applied type=CONTAINER race="scroll" in inv

Find all unpaid items, anywhere, even deeply nested inside other items, in
the originator:

   unpaid also deep in inv of originator

=head1 MATCH EXPRESSIONS

=head2 STRUCTURE

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

   condition
   condition in set-modifier
   condition of root-object

A C<condition> receives a set of "context objects" that it is applied
to. This is initially just one object - by default, 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 items on the
same mapspace, and so on, by using the C<in> operator:

   condition in inv
   condition in map

Also, besides the default root object where all this begins, you can start
elsewhere, for example in the I<originator> (usually the player):

   condition in inv of originator

Once the final set of context objects has been established, each object
is matched against the C<condition>.

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, ()

Conditions 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 conditions.

Example: match applied weapons.

   applied type=WEAPON

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. As
a less technical description, think of the C<in> as being a I<look into>
or I<look at> operator - instead of looking at whatever was provided to
the match, the C<in> operator lets you look at other sets of objects, most
often the inventory.

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

Replaces all objects by their archetypes.

=item in map

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

=item in <cond>

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

Note that C<in inv> is simply a special case of an C<< in <cond> >> 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 deep in ...

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

=item also deep in ...

C<also> and C<deep> 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 deep in inv

Example: check if a object is inside a player.

   type=PLAYER also deep in env

=back

=item of ...

By default, all matches are applied to the "obviously appropriate" object,
such as the item dropped on a button or moving over a detector. This can
be changed to a number of other objects - not all of them are available
for each match (when not available, the match will simply fail).

An C<of> term ends a match, nothing is allowed to follow.

=over 4

=item of object

Starts with the default object - this is the object passed to the match to
match against by default. Matches have an explicit C<of object> appended,
but submatches start at the current object, and in this case C<of object>
can be used to start at the original object once more.

=item of source

Starts with the I<source> object - this object is sometimes passed to
matches and represents the object that is the source of the action, such
as a rod or a potion when it is applied. Often, the I<source> is the same
as the I<originator>.

=item of originator

Starts with the I<originator> - one step farther removed than the
I<source>, the I<originator> is sometimes passed to matches and represents
the original initiator of an action, most commonly a player or monster.

This object is often identical to the I<source> (e.g. when a player casts
a spell, the player is both source and originator).

=item of self

Starts with the object initiating/asking for the match - this is basically
always the object that the match expression is attached to.

=back

=head2 EXPRESSIONS

Expressions used in conditions 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.

The perlcode can access C<$_>, which rferes to the object currently being
matches, and the C<$object>, C<$self>, C<$source> and C<$originator>.

Example: check whether the slaying field consists of digits only.

   { $_->slaying =~ /^\d+$/ }

=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(condition)

True iff the object has a matching inventory object.

=item count(match)

Number of matching objects - the context object for the C<match> is the
currently tested object - you can override this with an C<in object> for
example.

=item match(match)

An independent match - semantics like C<count>, except it only matters
whether the match finds any object (which is faster).

=item dump()

Dumps the object to the server log when executed, and evaluates to true.

Note that logical operations are short-circuiting, so this only dumps
potions:

   type=POTION and dump()

=back

=head2 GRAMMAR

This is the grammar that was used to implement the matching language
module. It is meant to be easily readable by humans, not to implement it
exactly as-is.

   # object matching and selecting

   match     = chain
             | chain 'of' root
   root      = 'object' | 'self' | 'source' | 'originator'
   chain     = condition
             | chain also deep 'in' set
   also      = nothing | 'also'
   deep      = nothing | 'deep'
   set       = 'inv' | 'env' | 'arch' | 'map'

   empty     =

   # boolean matching condition

   condition = factor
             | factor 'and'? cond
             | factor 'or'   cond

   factor    = 'not' factor
             | '(' cond ')'
             | 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: contains, matches, query_name, selling_price, buying_price?

=cut

=head2 PERL FUNCTIONS

=over 4

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

   package cf::match::parser;

   use common::sense;

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

   our %func = (
      has => sub {
         'first { ' . &condition . ' } $_->inv'
      },
      count => sub {
         local $all = 1;
         '(scalar ' . &match ('$_') . ')'
      },
      match => sub {
         local $all = 0;
         '(scalar ' . &match ('$_') . ')'
      },
      dump => sub {
         'do {
            warn "cf::match::match dump:\n"
               . "self: " . eval { $self->name } . "\n"
               . $_->as_string;
            1
         }';
      },
   );

   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 .= &condition;
         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 condition {
      my $res = factor;

      while () {
         ws;

         # first check some stop-symbols, so we don't have to backtrack
         if (/\G(?=also\b|deep\b|in\b|of\b\)|\z)/gc) {
            pos = pos; # argh. the misop hits again. again. again. again. you die.
            last;

         } elsif (/\Gor\b/gc) {
            $res .= " || ";

         } else {
            /\Gand\b/gc;
            $res .= " && ";
         }
         $res .= factor;
      }

      $res
   }

   sub match {
      my $default = shift;

      my $res = ($all ? " grep { " : " first {") . condition . " }";

      while () {
         ws;

         my $also = /\Galso\s+/gc + 0;
         my $deep = /\Gdeep\s+/gc + 0;

         if (/\Gin\s+/gc) {
            my $expand;

            if (/\G(inv|env|map|arch)\b/gc) {
               if ($1 eq "inv") {
                  $expand = "map \$_->inv,";
               } elsif ($1 eq "env") {
                  $expand = "map \$_->env // (),";
               } elsif ($1 eq "arch") {
                  $expand = "map \$_->arch,";
               } elsif ($1 eq "map") {
                  $expand = "map \$_->map->at (\$_->x, \$_->y),";
               }
            } else {
               $expand = "map \$_->inv, grep { " . condition . " }";
            }

            if ($also || $deep) {
               $res .= " do {\n"
                     . "   my \@res;\n";
               $res .= "   while (\@_) {\n"       if $deep;
               $res .= "      push \@res, \@_;\n" if $also;
               $res .= "      \@_ = $expand \@_;\n";
               $res .= "   }\n"                   if $deep;
               $res .= "   (\@res, \@_)\n"
                     . "}";
            } else {
               $res .= " $expand";
            }
         } elsif (/\Gof\s+(self|object|source|originator)\b/gc) {
            $also || $deep
               and die "neither 'also' nor 'deep' can be used with 'of'\n";

            if ($1 eq "self") {
               return "$res \$self // ()";
            } elsif ($1 eq "object") {
               return "$res \$object";
            } elsif ($1 eq "source") {
               return "$res \$source // ()";
            } elsif ($1 eq "originator") {
               return "$res \$originator // \$source // ()";
            }
         } else {
            return "$res $default";
         }
      }
   }
}

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

   my $res;

   eval {
      $res = cf::match::parser::match "\$object";

      /\G$/gc
          or die "unexpected trailing characters after match\n";
   };

   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) {#d#
   die parse 'type=SPELL_EFFECT and match(name="bullet" in arch)', 1;
   exit 0;
}

=item cf::match::match $match, $object[, $self[, $source[, $originator]]]

Compiles (and caches) the C<$match> expression and matches it against
the C<$object>. C<$self> should be the object initiating the match (or
C<undef>), C<$source> should be the actor/source and C<$originator> the
object that initiated the action (such as the player). C<$originator>
defaults to C<$source> when not given.

In list context it finds and returns all matching objects, in scalar
context only a true or false value.

=cut

our %CACHE;

sub compile($$) {
   my ($match, $all) = @_;
   my $expr = parse $match, $all;
   warn "MATCH DEBUG $match,$all => $expr\n";#d#
   $expr = eval "
      package cf::match::exec;
      sub {
         my (\$object, \$self, \$source, \$originator) = \@_;
         $expr
      }
   ";
   die if $@;

   $expr
}

sub match($$;$$$) {
   my $match = shift;
   my $all = wantarray+0;

   &{
      $CACHE{"$all$match"} ||= compile $match, $all
   }
}

#d# $::schmorp=cf::player::find "schmorp"&
#d# cf::match::match '', $::schmorp->ob


=back

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

1;

Revision:	1.14
Committed:	Mon Oct 12 04:02:17 2009 UTC (14 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.13:	+20 -13 lines
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 ("check for a match"), or all ("find all objects") matching
9	objects.
10
11	=head1 MATCH EXAMPLES
12
13	Match the object if it has a slaying field of C<key1>:
14
15	slaying = "key1"
16
17	Match the object if it has an object with name C<force> and
18	slaying C<poison> in it's inventory:
19
20	has (name = "force" and slaying = "poison")
21
22	Find all inventory objects with value >= 10, which are not invisible:
23
24	value >= 10 and not invisible in inv
25
26	Find all potions with spell objects inside them in someones inventory:
27
28	type=SPELL in type=POTION in inv
29
30	Find all scrolls inside someones inventory, or inside applied scroll
31	containers:
32
33	type=SCROLL also in applied type=CONTAINER race="scroll" in inv
34
35	Find all unpaid items, anywhere, even deeply nested inside other items, in
36	the originator:
37
38	unpaid also deep in inv of originator
39
40	=head1 MATCH EXPRESSIONS
41
42	=head2 STRUCTURE
43
44	The two main structures are the C<match>, which selects objects matching
45	various criteria, and the C<condition, which determines if an object
46	matches some desired properties:
47
48	condition
49	condition in set-modifier
50	condition of root-object
51
52	A C<condition> receives a set of "context objects" that it is applied
53	to. This is initially just one object - by default, for altars, it is the
54	object dropped on it, for pedestals, the object on top of it and so on.
55
56	This set of context objects can be modified in various ways, for example
57	by replacing it with the inventories of all objects, or all items on the
58	same mapspace, and so on, by using the C<in> operator:
59
60	condition in inv
61	condition in map
62
63	Also, besides the default root object where all this begins, you can start
64	elsewhere, for example in the I<originator> (usually the player):
65
66	condition in inv of originator
67
68	Once the final set of context objects has been established, each object
69	is matched against the C<condition>.
70
71	Sometimes the server is only interested in knowing whether I<anything>
72	matches, and sometimes the server is interested in I<all> objects that
73	match.
74
75	=head2 OPERATORS
76
77	=over 4
78
79	=item and, or, not, ()
80
81	Conditions can be combined with C<and> or C<or> to build larger
82	expressions. C<not> negates the expression, and parentheses can be used to
83	group conditions.
84
85	Example: match applied weapons.
86
87	applied type=WEAPON
88
89	Example: match horns or rods.
90
91	type=HORN or type=ROD
92
93	=item in ...
94
95	The in operator takes the context set and modifies it in various ways. As
96	a less technical description, think of the C<in> as being a I<look into>
97	or I<look at> operator - instead of looking at whatever was provided to
98	the match, the C<in> operator lets you look at other sets of objects, most
99	often the inventory.
100
101	=over 4
102
103	=item in inv
104
105	Replaces all objects by their inventory.
106
107	Example: find all spell objects inside the object to be matched.
108
109	type=SPELL in inv
110
111	=item in env
112
113	Replaces all objects by their containing object, if they have one.
114
115	=item in arch
116
117	Replaces all objects by their archetypes.
118
119	=item in map
120
121	Replaces all objects by the objects that are on the same mapspace as them.
122
123	=item in <cond>
124
125	Finds all context objects matching the condition, and then puts their
126	inventories into the context set.
127
128	Note that C<in inv> is simply a special case of an C<< in <cond> >> that
129	matches any object.
130
131	Example: find all spells inside potions inside the inventory of the context
132	object(s).
133
134	type=SPELL in type=POTION in inv
135
136	=item also in ...
137
138	Instead of replacing the context set with something new, the new objects
139	are added to the existing set.
140
141	Example: check if the context object I<is> a spell, or I<contains> a spell.
142
143	type=SPELL also in inv
144
145	=item deep in ...
146
147	Repeats the operation as many times as possible. This can be used to
148	recursively look into objects.
149
150	=item also deep in ...
151
152	C<also> and C<deep> can be combined.
153
154	Example: check if there are any unpaid items in an inventory,
155	or in the inventories of the inventory objects, and so on.
156
157	unpaid also deep in inv
158
159	Example: check if a object is inside a player.
160
161	type=PLAYER also deep in env
162
163	=back
164
165	=item of ...
166
167	By default, all matches are applied to the "obviously appropriate" object,
168	such as the item dropped on a button or moving over a detector. This can
169	be changed to a number of other objects - not all of them are available
170	for each match (when not available, the match will simply fail).
171
172	An C<of> term ends a match, nothing is allowed to follow.
173
174	=over 4
175
176	=item of object
177
178	Starts with the default object - this is the object passed to the match to
179	match against by default. Matches have an explicit C<of object> appended,
180	but submatches start at the current object, and in this case C<of object>
181	can be used to start at the original object once more.
182
183	=item of source
184
185	Starts with the I<source> object - this object is sometimes passed to
186	matches and represents the object that is the source of the action, such
187	as a rod or a potion when it is applied. Often, the I<source> is the same
188	as the I<originator>.
189
190	=item of originator
191
192	Starts with the I<originator> - one step farther removed than the
193	I<source>, the I<originator> is sometimes passed to matches and represents
194	the original initiator of an action, most commonly a player or monster.
195
196	This object is often identical to the I<source> (e.g. when a player casts
197	a spell, the player is both source and originator).
198
199	=item of self
200
201	Starts with the object initiating/asking for the match - this is basically
202	always the object that the match expression is attached to.
203
204	=back
205
206	=head2 EXPRESSIONS
207
208	Expressions used in conditions usually consist of simple boolean checks
209	(flag XYZ is set) or simple comparisons.
210
211	=over 4
212
213	=item flags
214
215	Flag names (without the leading C<FLAG_>) can be used as-is, in which case
216	their corresponding flag value is used.
217
218	=item scalar object attributes
219
220	Object attributes that consist of a single value (C<name>, C<title>,
221	C<value> and so on) can be specified by simply using their name, in which
222	acse their corresponding value is used.
223
224	=item array objects attributes
225
226	The C<resist> array can be accessed by specifying C<< resist [ ATNR_type ]
227	>>.
228
229	Example: match an acid resistance higher than 30.
230
231	resist[ATNR_ACID] > 30
232
233	=item functions
234
235	Some additional functions with or without arguments in parentheses are
236	available.
237
238	=item { BLOCK }
239
240	You can specify perl code to execute by putting it inside curly
241	braces. The last expression evaluated inside will become the result.
242
243	The perlcode can access C<$_>, which rferes to the object currently being
244	matches, and the C<$object>, C<$self>, C<$source> and C<$originator>.
245
246	Example: check whether the slaying field consists of digits only.
247
248	{ $_->slaying =~ /^\d+$/ }
249
250	=item comparisons, <, <=, ==, =, !=, =>, >
251
252	You can compare expressions against constants via any of these
253	operators. If the constant is a string, then a string compare will be
254	done, otherwise a numerical comparison is used.
255
256	Example: match an object with name "schnops" that has a value >= 10.
257
258	name="schnops" and value >= 10
259
260	=item uppercase constant names
261
262	Any uppercase word that exists as constant inside the C<cf::> namespace
263	(that is, any deliantra constant) can also be used as-is, but needs to be
264	specified in uppercase.
265
266	Example: match a type of POTION (using C<cf::POTION>).
267
268	type=POTION
269
270	=back
271
272	=head2 FUNCTIONS
273
274	=over 4
275
276	=item any
277
278	This simply evaluates to true, and simply makes matching I<any> object a
279	bit easier to read.
280
281	=item has(condition)
282
283	True iff the object has a matching inventory object.
284
285	=item count(match)
286
287	Number of matching objects - the context object for the C<match> is the
288	currently tested object - you can override this with an C<in object> for
289	example.
290
291	=item match(match)
292
293	An independent match - semantics like C<count>, except it only matters
294	whether the match finds any object (which is faster).
295
296	=item dump()
297
298	Dumps the object to the server log when executed, and evaluates to true.
299
300	Note that logical operations are short-circuiting, so this only dumps
301	potions:
302
303	type=POTION and dump()
304
305	=back
306
307	=head2 GRAMMAR
308
309	This is the grammar that was used to implement the matching language
310	module. It is meant to be easily readable by humans, not to implement it
311	exactly as-is.
312
313	# object matching and selecting
314
315	match = chain
316	\| chain 'of' root
317	root = 'object' \| 'self' \| 'source' \| 'originator'
318	chain = condition
319	\| chain also deep 'in' set
320	also = nothing \| 'also'
321	deep = nothing \| 'deep'
322	set = 'inv' \| 'env' \| 'arch' \| 'map'
323
324	empty =
325
326	# boolean matching condition
327
328	condition = factor
329	\| factor 'and'? cond
330	\| factor 'or' cond
331
332	factor = 'not' factor
333	\| '(' cond ')'
334	\| expr
335	\| expr operator constant
336
337	operator = '=' \| '==' \| '!=' \| '<' \| '<=' \| '>' \| '>='
338
339	expr = flag
340	\| sattr
341	\| aattr '[' <constant> ']'
342	\| special
343	\| func '(' args ')'
344	\| '{' perl code block '}'
345
346	func = <any function name>
347	sattr = <any scalar object attribute>
348	aattr = <any array object attribute>
349	flag = <any object flag>
350	special = <any ()-less "function">
351
352	constant = <number> \| '"' <string> '"' \| <uppercase cf::XXX name>
353	args = <depends on function>
354
355	TODO: contains, matches, query_name, selling_price, buying_price?
356
357	=cut
358
359	=head2 PERL FUNCTIONS
360
361	=over 4
362
363	=cut
364
365	package cf::match;
366
367	use common::sense;
368
369	use List::Util ();
370
371	# parser state
372	# $_ # string to be parsed
373	our $all; # find all, or just the first matching object
374
375	{
376	package cf::match::exec;
377
378	use List::Util qw(first);
379
380	package cf::match::parser;
381
382	use common::sense;
383
384	sub ws {
385	/\G\s+/gc;
386	}
387
388	our %func = (
389	has => sub {
390	'first { ' . &condition . ' } $_->inv'
391	},
392	count => sub {
393	local $all = 1;
394	'(scalar ' . &match ('$_') . ')'
395	},
396	match => sub {
397	local $all = 0;
398	'(scalar ' . &match ('$_') . ')'
399	},
400	dump => sub {
401	'do {
402	warn "cf::match::match dump:\n"
403	. "self: " . eval { $self->name } . "\n"
404	. $_->as_string;
405	1
406	}';
407	},
408	);
409
410	our %special = (
411	any => sub {
412	1
413	},
414	);
415
416	sub constant {
417	ws;
418
419	return $1 if /\G([\-\+0-9\.]+)/gc;
420	return "cf::$1" if /\G([A-Z0-9_]+)/gc;
421
422	#TODO better string parsing, also include ''
423	return $1 if /\G("[^"]+")/gc;
424
425	die "number, string or uppercase constant name expected\n";
426	}
427
428	our $flag = $cf::REFLECT{object}{flags};
429	our $sattr = $cf::REFLECT{object}{scalars};
430	our $aattr = $cf::REFLECT{object}{arrays};
431
432	sub expr {
433	# ws done by factor
434	my $res;
435
436	if (/\G ( \{ (?: (?> [^{}]+ ) \| (?-1) )* \} ) /gcx) {
437	# perl
438
439	my $expr = $1;
440
441	$res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";
442
443	} elsif (/\G([A-Za-z0-9_]+)/gc) {
444
445	if (my $func = $func{$1}) {
446	/\G\s*\(/gc
447	or die "'(' expected after function name\n";
448
449	$res .= $func->();
450
451	/\G\s*\)/gc
452	or die "')' expected after function arguments\n";
453
454	} elsif (my $func = $special{$1}) {
455	$res .= $func->();
456
457	} elsif (exists $flag->{lc $1}) {
458	$res .= "\$_->flag (cf::FLAG_\U$1)";
459
460	} elsif (exists $sattr->{$1}) {
461	$res .= "\$_->$1";
462
463	} elsif (exists $aattr->{$1}) {
464
465	$res .= "\$_->$1";
466
467	/\G\s*\[/gc
468	or die "'[' expected after array name\n";
469
470	$res .= "(" . constant . ")";
471
472	/\G\s*\]/gc
473	or die "']' expected after array index\n";
474
475	} else {
476	$res .= constant;
477	}
478
479	} else {
480	die "expr expected\n";
481	}
482
483	$res
484	}
485
486	our %stringop = (
487	"==" => "eq",
488	"!=" => "ne",
489	"<=" => "le",
490	">=" => "ge",
491	"<" => "lt",
492	">" => "gt",
493	);
494
495	sub factor {
496	ws;
497
498	my $res;
499
500	if (/\Gnot\b\s*/gc) {
501	$res .= "!";
502	}
503
504	if (/\G\(/gc) {
505	# ()
506	$res .= &condition;
507	ws;
508	/\G\)/gc or die "')' expected\n";
509
510	} else {
511	my $expr = expr;
512
513	$res .= $expr;
514
515	if (/\G\s*([=!<>]=?)/gc) {
516	my $op = $1;
517
518	$op = "==" if $op eq "=";
519	my $const = constant;
520	$op = $stringop{$op} if $const =~ /^"/;
521
522	$res .= " $op $const";
523	}
524	}
525
526	"($res)"
527	}
528
529	sub condition {
530	my $res = factor;
531
532	while () {
533	ws;
534
535	# first check some stop-symbols, so we don't have to backtrack
536	if (/\G(?=also\b\|deep\b\|in\b\|of\b\)\|\z)/gc) {
537	pos = pos; # argh. the misop hits again. again. again. again. you die.
538	last;
539
540	} elsif (/\Gor\b/gc) {
541	$res .= " \|\| ";
542
543	} else {
544	/\Gand\b/gc;
545	$res .= " && ";
546	}
547	$res .= factor;
548	}
549
550	$res
551	}
552
553	sub match {
554	my $default = shift;
555
556	my $res = ($all ? " grep { " : " first {") . condition . " }";
557
558	while () {
559	ws;
560
561	my $also = /\Galso\s+/gc + 0;
562	my $deep = /\Gdeep\s+/gc + 0;
563
564	if (/\Gin\s+/gc) {
565	my $expand;
566
567	if (/\G(inv\|env\|map\|arch)\b/gc) {
568	if ($1 eq "inv") {
569	$expand = "map \$_->inv,";
570	} elsif ($1 eq "env") {
571	$expand = "map \$_->env // (),";
572	} elsif ($1 eq "arch") {
573	$expand = "map \$_->arch,";
574	} elsif ($1 eq "map") {
575	$expand = "map \$_->map->at (\$_->x, \$_->y),";
576	}
577	} else {
578	$expand = "map \$_->inv, grep { " . condition . " }";
579	}
580
581	if ($also \|\| $deep) {
582	$res .= " do {\n"
583	. " my \@res;\n";
584	$res .= " while (\@_) {\n" if $deep;
585	$res .= " push \@res, \@_;\n" if $also;
586	$res .= " \@_ = $expand \@_;\n";
587	$res .= " }\n" if $deep;
588	$res .= " (\@res, \@_)\n"
589	. "}";
590	} else {
591	$res .= " $expand";
592	}
593	} elsif (/\Gof\s+(self\|object\|source\|originator)\b/gc) {
594	$also \|\| $deep
595	and die "neither 'also' nor 'deep' can be used with 'of'\n";
596
597	if ($1 eq "self") {
598	return "$res \$self // ()";
599	} elsif ($1 eq "object") {
600	return "$res \$object";
601	} elsif ($1 eq "source") {
602	return "$res \$source // ()";
603	} elsif ($1 eq "originator") {
604	return "$res \$originator // \$source // ()";
605	}
606	} else {
607	return "$res $default";
608	}
609	}
610	}
611	}
612
613	sub parse($;$) {
614	local $_ = shift;
615	local $all = shift;
616
617	my $res;
618
619	eval {
620	$res = cf::match::parser::match "\$object";
621
622	/\G$/gc
623	or die "unexpected trailing characters after match\n";
624	};
625
626	if ($@) {
627	my $ctx = 20;
628	my $str = substr $_, (List::Util::max 0, (pos) - $ctx), $ctx * 2;
629	substr $str, (List::Util::min $ctx, pos), 0, "<-- HERE -->";
630
631	chomp $@;
632	die "$@ ($str)\n";
633	}
634
635	$res
636	}
637
638	if (0) {#d#
639	die parse 'type=SPELL_EFFECT and match(name="bullet" in arch)', 1;
640	exit 0;
641	}
642
643	=item cf::match::match $match, $object[, $self[, $source[, $originator]]]
644
645	Compiles (and caches) the C<$match> expression and matches it against
646	the C<$object>. C<$self> should be the object initiating the match (or
647	C<undef>), C<$source> should be the actor/source and C<$originator> the
648	object that initiated the action (such as the player). C<$originator>
649	defaults to C<$source> when not given.
650
651	In list context it finds and returns all matching objects, in scalar
652	context only a true or false value.
653
654	=cut
655
656	our %CACHE;
657
658	sub compile($$) {
659	my ($match, $all) = @_;
660	my $expr = parse $match, $all;
661	warn "MATCH DEBUG $match,$all => $expr\n";#d#
662	$expr = eval "
663	package cf::match::exec;
664	sub {
665	my (\$object, \$self, \$source, \$originator) = \@_;
666	$expr
667	}
668	";
669	die if $@;
670
671	$expr
672	}
673
674	sub match($$;$$$) {
675	my $match = shift;
676	my $all = wantarray+0;
677
678	&{
679	$CACHE{"$all$match"} \|\|= compile $match, $all
680	}
681	}
682
683	#d# $::schmorp=cf::player::find "schmorp"&
684	#d# cf::match::match '', $::schmorp->ob
685
686
687	=back
688
689	=head1 AUTHOR
690
691	Marc Lehmann <schmorp@schmorp.de>
692	http://home.schmorp.de/
693
694	=cut
695
696	1;
697