server/ext/NPC_Dialogue.pm

=head1 NAME

NPC_Dialogue

=head1 DESCRIPTION

NPC dialogue support module.

=over 4

=cut

package NPC_Dialogue;

use strict;

sub has_dialogue($) {
   my ($ob) = @_;

   $ob->msg =~ /^\@match /;
}

sub parse_message($) {
   map [split /\n/, $_, 2],
      grep length,
         split /^\@match /m,
            $_[0]
}

sub new {
   my ($class, %arg) = @_;

   $arg{ob} = $arg{pl}->ob;

   my $self = bless {
      %arg,
   }, $class;

   $self->{match} ||= [parse_message $self->{npc}->msg];

   $self;
}

sub greet {
   my ($self) = @_;

   $self->tell ("hi")
}

=item ($reply, @topics) = $dialog->tell ($msg)

Tells the dialog object something and returns its response and optionally
a number of topics that are refered to by this topic.

It supports a number of command constructs. They have to follow the
C<@match> directive, and there can be multiple commands that will be
executed in order.

=over 4

=item @comment text...

A single-line comment. It will be completely ignored.

=item @parse regex

Parses the message using a perl regular expression (by default
case-insensitive). Any matches will be available as C<< $match->[$index]
>>.

If the regular expression does not match, the topic is skipped.

Example:

   @match deposit
   @parse deposit (\d+) (\S+)
   @eval bank::deposit $match->[0], $match->[1]

=item @cond perl

Evaluates the given perl code. If it returns false (or causes an
exception), the topic will be skipped, otherwise topic interpretation is
resumed.

The following local variables are defined within the expression:

=over 4

=item $who - The cf::object::player object that initiated the dialogue.

=item $npc - The NPC (or magic_ear etc.) object that is being talked to.

=item $msg - The actual message as passed to this method.

=item $match - An arrayref with previous results from C<@parse>.

=item $state - A hashref that stores state variables associated
with the NPC and the player, that is, it's values relate to the the
specific player-NPC interaction and other players will see a different
state. Useful to react to players in a stateful way. See C<@setstate> and
C<@ifstate>.

=item $flag - A hashref that stores flags associated with the player and
can be seen by all NPCs (so better name your flags uniquely). This is
useful for storing e.g. quest information. See C<@setflag> and C<@ifflag>.

=back

The environment is that standard "map scripting environment", which is
limited in the type of constructs allowed (no loops, for example).

Here is a example:

=over 4

=item B<matching for an item name>

   @match hi
   @cond grep $_->name =~ /royalty/, $who->inv
   You got royalties there! Wanna have!

You may want to change the C<name> method there to something like C<title>,
C<slaying> or any other method that is allowed to be called on a
C<cf::object> here.

=back

=item @eval perl

Like C<@cond>, but proceed regardless of the outcome.

=item @msg perl

Like C<@cond>, but the return value will be stringified and prepended to
the message.

=item @setstate state value

Sets the named state C<state> to the given C<value>. State values are
associated with a specific player-NPC pair, so each NPC has its own state
with respect to a particular player, which makes them useful to store
information about previous questions and possibly answers. State values
get reset whenever the NPC gets reset.

See C<@ifstate> for an example.

=item @ifstate state value

Requires that the named C<state> has the given C<value>, otherwise this
topic is skipped.  For more complex comparisons, see C<@cond> with
C<$state>. Example:

  @match quest
  @setstate question quest
  Do you really want to help find the magic amulet of Beeblebrox?
  @match yes
  @ifstate question quest
  Then fetch it, stupid!

=item @setflag flag value

Sets the named flag C<flag> to the given C<value>. Flag values are
associated with a specific player and can be seen by all NPCs. with
respect to a particular player, which makes them suitable to store quest
markers and other information (e.g. reputation/alignment). Flags are
persistent over the lifetime of a player, so be careful :)

See C<@ifflag> for an example.

=item @ifflag flag value

Requires that the named C<flag> has the given C<value>, otherwise this
topic is skipped.  For more complex comparisons, see C<@cond> with
C<$flag>. Example:

  @match I want to do the quest!
  @setflag kings_quest 1
  Then seek out Bumblebee in Navar, he will tell you...
  @match I did the quest
  @ifflag kings_quest 1
  Really, which quets?

And Bumblebee might have:

  @match hi
  @ifflag kings_quest
  Hi, I was told you want to do the kings quest?

=item @trigger connected-id [state]

Trigger all objects with the given connected-id.

When the state argument is omitted the trigger is stateful and retains an
internal state per connected-id. There is a limitation to the use of this: The
state won't be changed when the connection is triggered by other triggers.  So
be careful when triggering the connection from other objects.

When a state argument is given it should be either 0 or 1. 1 will 'push' the connection
and 0 will 'release' the connection. This is useful for example when you want to
let a npc control a door.

Trigger all objects with the given connected-id by 'releasing' the connection.

=item @addtopic topic

Adds the given topic names (separated by C<|>) to the list of topics
returned.

=back

=cut

sub tell {
   my ($self, $msg) = @_;

   my $lcmsg = lc $msg;

   topic:
   for my $match (@{ $self->{match} }) {
      for (split /\|/, $match->[0]) {
         if ($_ eq "*" || $lcmsg =~ /\b\Q$_\E\b/i) {
            my $reply = $match->[1];
            my @kw;

            my @replies;
            my @match; # @match/@parse command results

            my $state = $self->{npc}{$self->{ob}->name}{dialog_state} ||= {};
            my $flag  = $self->{ob}{dialog_flag}                      ||= {};

            my %vars = (
               who   => $self->{ob},
               npc   => $self->{npc},
               state => $state,
               flag  => $flag,
               msg   => $msg,
               match => \@match,
            );

            local $self->{ob}{record_replies} = \@replies;

            # now execute @-commands (which can result in a no-match)
            while ($reply =~ s/^\@(\w+)\s*([^\n]*)\n?//) {
               my ($cmd, $args) = ($1, $2);

               if ($cmd eq "parse" || $cmd eq "match") { # match is future rename
                  no re 'eval'; # default, but make sure
                  @match = $msg =~ /$args/i
                     or next topic;

               } elsif ($cmd eq "comment") {
                  # nop

               } elsif ($cmd eq "cond") {
                  cf::safe_eval $args, %vars
                     or next topic;

               } elsif ($cmd eq "eval") {
                  cf::safe_eval $args, %vars;
                  warn "\@eval evaluation error: $@\n" if $@;

               } elsif ($cmd eq "msg") {
                  push @replies, [$self->{npc}, (scalar cf::safe_eval $args, %vars)];

               } elsif ($cmd eq "setflag") {
                  my ($name, $value) = split /\s+/, $args, 2;
                  $value ? $flag->{$name} = $value
                         : delete $flag->{$name};

               } elsif ($cmd eq "setstate") {
                  my ($name, $value) = split /\s+/, $args, 2;
                  $value ? $state->{$name} = $value
                         : delete $state->{$name};

               } elsif ($cmd eq "ifflag") {
                  my ($name, $value) = split /\s+/, $args, 2;
                  $flag->{$name} eq $value
                     or next topic;

               } elsif ($cmd eq "ifstate") {
                  my ($name, $value) = split /\s+/, $args, 2;
                  $state->{$name} eq $value
                     or next topic;

               } elsif ($cmd eq "trigger") {
                  my ($con, $state) = split /\s+/, $args, 2;
                  $con = $con * 1;

                  if (defined $state) {
                    $self->{npc}->map->trigger ($args, $state);
                  } else {
                    my $rvalue = \$self->{npc}{dialog_trigger}{$con};
                    $self->{npc}->map->trigger ($con, $$rvalue = !$$rvalue);
                  }

               } elsif ($cmd eq "addtopic") {
                  push @kw, split /\|/, $args;
                  $self->{add_topic}->(split /\s*\|\s*/, $args) if $self->{add_topic};

               } elsif ($cmd eq "deltopic") {
                  # not yet implemented, do it out-of-band
                  $self->{del_topic}->(split /\s*\|\s*/, $args) if $self->{del_topic};

               } else {
                  warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->msg . ")";
               }
            }

            delete $self->{npc}{$self->{ob}->name}{dialog_state} unless %$state;
            delete $self->{ob}{dialog_flag}                      unless %$flag;

            # combine lines into paragraphs
            $reply =~ s/(?<=\S)\n(?=\w)/ /g;
            $reply =~ s/\n\n/\n/g;

            # ignores flags and npc from replies
            $reply = join "\n", (map $_->[1], @replies), $reply;

            # now mark up all matching keywords
            for my $match (@{ $self->{match} }) {
               for (sort { (length $b) <=> (length $a) } split /\|/, $match->[0]) {
                  if ($reply =~ /\b\Q$_\E\b/i) {
                     push @kw, $_;
                     last;
                  }
               }
            }

            return wantarray ? ($reply, @kw) : $reply;
         }
      }
   }

   ()
}

1
Revision:	1.6
Committed:	Wed Aug 8 07:55:57 2007 UTC (16 years, 9 months ago) by elmex
Branch:	MAIN
Changes since 1.5:	+16 -0 lines
Log Message:	added example for @cond
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			NPC_Dialogue
4
5			=head1 DESCRIPTION
6
7			NPC dialogue support module.
8
9	root	1.5	=over 4
10
11	root	1.1	=cut
12
13			package NPC_Dialogue;
14
15			use strict;
16
17			sub has_dialogue($) {
18			my ($ob) = @_;
19
20			$ob->msg =~ /^\@match /;
21			}
22
23			sub parse_message($) {
24			map [split /\n/, $_, 2],
25			grep length,
26			split /^\@match /m,
27			$_[0]
28			}
29
30			sub new {
31			my ($class, %arg) = @_;
32
33	root	1.4	$arg{ob} = $arg{pl}->ob;
34
35	root	1.1	my $self = bless {
36			%arg,
37			}, $class;
38
39			$self->{match} \|\|= [parse_message $self->{npc}->msg];
40
41			$self;
42			}
43
44			sub greet {
45			my ($self) = @_;
46
47			$self->tell ("hi")
48			}
49
50			=item ($reply, @topics) = $dialog->tell ($msg)
51
52			Tells the dialog object something and returns its response and optionally
53			a number of topics that are refered to by this topic.
54
55			It supports a number of command constructs. They have to follow the
56			C<@match> directive, and there can be multiple commands that will be
57			executed in order.
58
59			=over 4
60
61			=item @comment text...
62
63			A single-line comment. It will be completely ignored.
64
65			=item @parse regex
66
67			Parses the message using a perl regular expression (by default
68			case-insensitive). Any matches will be available as C<< $match->[$index]
69			>>.
70
71			If the regular expression does not match, the topic is skipped.
72
73			Example:
74
75			@match deposit
76			@parse deposit (\d+) (\S+)
77			@eval bank::deposit $match->[0], $match->[1]
78
79			=item @cond perl
80
81			Evaluates the given perl code. If it returns false (or causes an
82			exception), the topic will be skipped, otherwise topic interpretation is
83			resumed.
84
85			The following local variables are defined within the expression:
86
87			=over 4
88
89			=item $who - The cf::object::player object that initiated the dialogue.
90
91			=item $npc - The NPC (or magic_ear etc.) object that is being talked to.
92
93			=item $msg - The actual message as passed to this method.
94
95			=item $match - An arrayref with previous results from C<@parse>.
96
97			=item $state - A hashref that stores state variables associated
98			with the NPC and the player, that is, it's values relate to the the
99			specific player-NPC interaction and other players will see a different
100			state. Useful to react to players in a stateful way. See C<@setstate> and
101			C<@ifstate>.
102
103			=item $flag - A hashref that stores flags associated with the player and
104			can be seen by all NPCs (so better name your flags uniquely). This is
105			useful for storing e.g. quest information. See C<@setflag> and C<@ifflag>.
106
107			=back
108
109			The environment is that standard "map scripting environment", which is
110			limited in the type of constructs allowed (no loops, for example).
111
112	elmex	1.6	Here is a example:
113
114			=over 4
115
116			=item B<matching for an item name>
117
118			@match hi
119			@cond grep $_->name =~ /royalty/, $who->inv
120			You got royalties there! Wanna have!
121
122			You may want to change the C<name> method there to something like C<title>,
123			C<slaying> or any other method that is allowed to be called on a
124			C<cf::object> here.
125
126			=back
127
128	root	1.1	=item @eval perl
129
130			Like C<@cond>, but proceed regardless of the outcome.
131
132			=item @msg perl
133
134			Like C<@cond>, but the return value will be stringified and prepended to
135			the message.
136
137			=item @setstate state value
138
139			Sets the named state C<state> to the given C<value>. State values are
140			associated with a specific player-NPC pair, so each NPC has its own state
141			with respect to a particular player, which makes them useful to store
142			information about previous questions and possibly answers. State values
143			get reset whenever the NPC gets reset.
144
145			See C<@ifstate> for an example.
146
147			=item @ifstate state value
148
149			Requires that the named C<state> has the given C<value>, otherwise this
150			topic is skipped. For more complex comparisons, see C<@cond> with
151			C<$state>. Example:
152
153			@match quest
154			@setstate question quest
155			Do you really want to help find the magic amulet of Beeblebrox?
156			@match yes
157			@ifstate question quest
158			Then fetch it, stupid!
159
160			=item @setflag flag value
161
162			Sets the named flag C<flag> to the given C<value>. Flag values are
163			associated with a specific player and can be seen by all NPCs. with
164			respect to a particular player, which makes them suitable to store quest
165			markers and other information (e.g. reputation/alignment). Flags are
166			persistent over the lifetime of a player, so be careful :)
167
168			See C<@ifflag> for an example.
169
170			=item @ifflag flag value
171
172			Requires that the named C<flag> has the given C<value>, otherwise this
173			topic is skipped. For more complex comparisons, see C<@cond> with
174			C<$flag>. Example:
175
176			@match I want to do the quest!
177			@setflag kings_quest 1
178			Then seek out Bumblebee in Navar, he will tell you...
179			@match I did the quest
180			@ifflag kings_quest 1
181			Really, which quets?
182
183			And Bumblebee might have:
184
185			@match hi
186			@ifflag kings_quest
187			Hi, I was told you want to do the kings quest?
188
189	elmex	1.2	=item @trigger connected-id [state]
190	root	1.1
191	elmex	1.2	Trigger all objects with the given connected-id.
192
193			When the state argument is omitted the trigger is stateful and retains an
194			internal state per connected-id. There is a limitation to the use of this: The
195			state won't be changed when the connection is triggered by other triggers. So
196			be careful when triggering the connection from other objects.
197
198			When a state argument is given it should be either 0 or 1. 1 will 'push' the connection
199			and 0 will 'release' the connection. This is useful for example when you want to
200			let a npc control a door.
201
202			Trigger all objects with the given connected-id by 'releasing' the connection.
203	root	1.1
204			=item @addtopic topic
205
206			Adds the given topic names (separated by C<\|>) to the list of topics
207			returned.
208
209			=back
210
211			=cut
212
213			sub tell {
214			my ($self, $msg) = @_;
215
216			my $lcmsg = lc $msg;
217
218			topic:
219			for my $match (@{ $self->{match} }) {
220			for (split /\\|/, $match->[0]) {
221	elmex	1.3	if ($_ eq "*" \|\| $lcmsg =~ /\b\Q$_\E\b/i) {
222	root	1.1	my $reply = $match->[1];
223			my @kw;
224
225			my @replies;
226			my @match; # @match/@parse command results
227
228			my $state = $self->{npc}{$self->{ob}->name}{dialog_state} \|\|= {};
229			my $flag = $self->{ob}{dialog_flag} \|\|= {};
230
231			my %vars = (
232			who => $self->{ob},
233			npc => $self->{npc},
234			state => $state,
235			flag => $flag,
236			msg => $msg,
237			match => \@match,
238			);
239
240			local $self->{ob}{record_replies} = \@replies;
241
242			# now execute @-commands (which can result in a no-match)
243			while ($reply =~ s/^\@(\w+)\s([^\n])\n?//) {
244			my ($cmd, $args) = ($1, $2);
245
246			if ($cmd eq "parse" \|\| $cmd eq "match") { # match is future rename
247			no re 'eval'; # default, but make sure
248			@match = $msg =~ /$args/i
249			or next topic;
250
251			} elsif ($cmd eq "comment") {
252			# nop
253
254			} elsif ($cmd eq "cond") {
255			cf::safe_eval $args, %vars
256			or next topic;
257
258			} elsif ($cmd eq "eval") {
259			cf::safe_eval $args, %vars;
260			warn "\@eval evaluation error: $@\n" if $@;
261
262			} elsif ($cmd eq "msg") {
263			push @replies, [$self->{npc}, (scalar cf::safe_eval $args, %vars)];
264
265			} elsif ($cmd eq "setflag") {
266			my ($name, $value) = split /\s+/, $args, 2;
267			$value ? $flag->{$name} = $value
268			: delete $flag->{$name};
269
270			} elsif ($cmd eq "setstate") {
271			my ($name, $value) = split /\s+/, $args, 2;
272			$value ? $state->{$name} = $value
273			: delete $state->{$name};
274
275			} elsif ($cmd eq "ifflag") {
276			my ($name, $value) = split /\s+/, $args, 2;
277			$flag->{$name} eq $value
278			or next topic;
279
280			} elsif ($cmd eq "ifstate") {
281			my ($name, $value) = split /\s+/, $args, 2;
282			$state->{$name} eq $value
283			or next topic;
284
285			} elsif ($cmd eq "trigger") {
286	elmex	1.2	my ($con, $state) = split /\s+/, $args, 2;
287			$con = $con * 1;
288
289			if (defined $state) {
290			$self->{npc}->map->trigger ($args, $state);
291			} else {
292			my $rvalue = \$self->{npc}{dialog_trigger}{$con};
293			$self->{npc}->map->trigger ($con, $$rvalue = !$$rvalue);
294			}
295	root	1.1
296			} elsif ($cmd eq "addtopic") {
297			push @kw, split /\\|/, $args;
298			$self->{add_topic}->(split /\s\\|\s/, $args) if $self->{add_topic};
299
300			} elsif ($cmd eq "deltopic") {
301			# not yet implemented, do it out-of-band
302			$self->{del_topic}->(split /\s\\|\s/, $args) if $self->{del_topic};
303
304			} else {
305			warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->msg . ")";
306			}
307			}
308
309			delete $self->{npc}{$self->{ob}->name}{dialog_state} unless %$state;
310			delete $self->{ob}{dialog_flag} unless %$flag;
311
312			# combine lines into paragraphs
313			$reply =~ s/(?<=\S)\n(?=\w)/ /g;
314			$reply =~ s/\n\n/\n/g;
315
316			# ignores flags and npc from replies
317			$reply = join "\n", (map $_->[1], @replies), $reply;
318
319			# now mark up all matching keywords
320			for my $match (@{ $self->{match} }) {
321			for (sort { (length $b) <=> (length $a) } split /\\|/, $match->[0]) {
322			if ($reply =~ /\b\Q$_\E\b/i) {
323			push @kw, $_;
324			last;
325			}
326			}
327			}
328
329			return wantarray ? ($reply, @kw) : $reply;
330			}
331			}
332			}
333
334			()
335			}
336
337			1