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

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