server/ext/NPC_Dialogue.pm

=head1 NAME

NPC_Dialogue

=head1 DESCRIPTION

NPC dialogue support module.

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

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