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 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' | '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 ('$_') . ')'
      },
   );

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