lib/cf/match.pm

#
# This file is part of Deliantra, the Roguelike Realtime MMORPG.
# 
# Copyright (©) 2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
# 
# Deliantra is free software: you can redistribute it and/or modify it under
# the terms of the Affero GNU General Public License as published by the
# Free Software Foundation, either version 3 of the License, or (at your
# option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# 
# You should have received a copy of the Affero GNU General Public License
# and the GNU General Public License along with this program. If not, see
# <http://www.gnu.org/licenses/>.
# 
# The authors can be reached via e-mail to <support@deliantra.net>
#

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

It is possible to chain modifiers from right-to-left, so this example
would start with the originator, take it's inventory, find all inventory
items which are potions, looks into their inventory, and then finds all
spells.

   type=SPELL in type=POTION in inv of originator

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 condition, and parentheses can be used to
override operator precedence and execute submatches.

Not that C<not> only negates a condition and not the whole match
expressions, thus

   not applied in inv

is true if there is I<any> non-applied object in the inventory. To negate
a whole match, you have to use a sub-match: To check whether there is
I<no> applied object in someones inventory, write this:

   not (applied in inv)

Example: match applied weapons.

   applied type=WEAPON

Example: match horns or rods.

   type=HORN or type=ROD

Example: see if the originator is a player.

   type=PLAYER of originator

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

Replaces all objects by their head objects.

=item in <condition>

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 <condition> >> 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 also deep in ...

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

So for example, C<also deep in inv> means to take the inventory of all
objects, taking their inventories, and so on, and adding all these objects
to the context set.

Similarly, C<also deep in env> means to take the environment object, their
environemnt object and so on.

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 none

This simply evaluates to false, and simply makes matching I<never> 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 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' modifier
   also      = nothing | 'also'
   deep      = nothing | 'deep'
   modifier  ='inv' | 'env' | 'arch' | 'map' | 'head'

   nothing   =

   # boolean matching condition

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

   factor    = 'not' factor
             | '(' match ')'
             | expr
             | expr operator constant

   operator  = '=' | '==' | '!=' | '<' | '<=' | '>' | '>='

   expr      = flag
             | sattr
             | aattr '[' <constant> ']'
             | 'stat.' statattr
             | special
             | func '(' args ')'
             | '{' perl code block '}'

   func      = <any function name>
   sattr     = <any scalar object attribute>
   aattr     = <any array object attribute>
   flag      = <any object flag>
   statattr  = <any stat attribute: exp, food, str, dex, hp, maxhp...>
   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 ();

{
   package cf::match::exec;

   use List::Util qw(first);

   package cf::match::parser;

   use common::sense;

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

   sub condition ();
   sub match ($$);

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

   our %special = (
      any => sub {
         1
      },
      none => sub {
         0
      },
   );

   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};
   our $lattr = $cf::REFLECT{living}{scalars};

   sub expr {
      # ws done by factor
      my $res;

      if (/\G ( \{ (?: (?> [^{}]+ ) | (?-1) )* \} ) /gcx) {
         # perl

         my $expr = $1;

         $res .= $expr =~ /\{([^;]+)\}/ ? $1 : "do $expr";

      } elsif (/\Gstats\.([A-Za-z0-9_]+)/gc) {

         if (exists $lattr->{$1}) {
            $res .= "\$_->stats->$1";
         } elsif (exists $lattr->{"\u$1"}) {
            $res .= "\$_->stats->\u$1";
         } else {
            die "living statistic name expected (str, pow, hp, sp...)\n";
         }

      } 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 {
         Carp::cluck;#d#
         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 0, '$_') . ')';

         /\G\s*\)/gc or die "closing ')' 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 ($wantarray, $defctx) = @_;

      my $res = condition;

      # if nothing follows, we have a simple condition, so
      # optimise a comon case.
      if ($defctx eq '$_' and /\G\s*(?=\)|$)/gc) {
         return $wantarray
                ? "$res ? \$_ : ()"
                : $res;
      }

      $res = ($wantarray ? " grep { " : " first { ") . $res . "}";

      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|head)\b/gc) {
               if ($1 eq "inv") {
                  $expand = "map \$_->inv,";
               } elsif ($1 eq "env") {
                  $expand = "map \$_->env // (),";
               } elsif ($1 eq "head") {
                  $expand = "map \$_->head,";
                  $deep = 0; # infinite loop otherwise
               } elsif ($1 eq "arch") {
                  $expand = "map \$_->arch,";
                  $deep = 0; # infinite loop otherwise
               } elsif ($1 eq "map") {
                  $expand = "map \$_->map->at (\$_->x, \$_->y),";
                  $deep = 0; # infinite loop otherwise
               }
            } 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";
            }
         } else {

            if (/\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 $defctx";
            }
         }
      }
   }
}

sub parse($$) { # wantarray, matchexpr
   my $res;

   local $_ = $_[1];

   eval {
      $res = cf::match::parser::match $_[0], "\$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 1, 'stats.pow';
   exit 0;
}

our %CACHE;

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

   $expr
}

=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

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

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

our $CACHE_CLEARER = AE::timer 3600, 3600, sub {
   %CACHE = ();
};

#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.24
Committed:	Tue Nov 3 23:44:21 2009 UTC (14 years, 8 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_90, rel-2_92, rel-2_93
Changes since 1.23:	+22 -0 lines
Log Message:	tighten copyright statements for files containing no gpl code whatsoever anymore