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.

=item B<matching for an item name and removing the matched item>

   @match found earhorn
   @cond grep $_->slaying =~ /Gramp's walking stick/, $who->inv
   @eval my @g = grep { $_->slaying =~ /Gramp's walking stick/ } $who->inv; $g[0]->decrease_ob_nr (1);
   Thanks for the earhorn!

This example is a bit more complex. The C<@eval> statement will search
the players inventory for the same term as the C<@cond> and then
decreases the number of objects used there.

(See also the map: C<scorn/houses/cornerbrook.map> for an example how this is
used in the real world :-)

=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 @playersound face-name

Plays the given sound face (either an alias or sound file path) so that
only the player talking to the npc can hear it.

=item @npcsound face-name

Plays the given sound face (either an alias or sound file path) as if
the npc had made that sound, i.e. it will be located at the npc and all
players near enough can hear it.

=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 "playersound") {
                  $self->{ob}->contr->play_sound (cf::sound::find $args);

               } elsif ($cmd eq "npcsound") {
                  $self->{npc}->play_sound (cf::sound::find $args);

               } 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.8
Committed:	Sun Aug 26 04:07:40 2007 UTC (16 years, 9 months ago) by root
Branch:	MAIN
CVS Tags:	rel-2_4, rel-2_5, rel-2_2, rel-2_3, rel-2_32, rel-2_43, rel-2_42, rel-2_41
Changes since 1.7:	+17 -0 lines
Log Message:	and one more rename
#	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	elmex	1.7	=item B<matching for an item name and removing the matched item>
127
128			@match found earhorn
129			@cond grep $_->slaying =~ /Gramp's walking stick/, $who->inv
130			@eval my @g = grep { $_->slaying =~ /Gramp's walking stick/ } $who->inv; $g[0]->decrease_ob_nr (1);
131			Thanks for the earhorn!
132
133			This example is a bit more complex. The C<@eval> statement will search
134			the players inventory for the same term as the C<@cond> and then
135			decreases the number of objects used there.
136
137			(See also the map: C<scorn/houses/cornerbrook.map> for an example how this is
138			used in the real world :-)
139
140	elmex	1.6	=back
141
142	root	1.1	=item @eval perl
143
144			Like C<@cond>, but proceed regardless of the outcome.
145
146			=item @msg perl
147
148			Like C<@cond>, but the return value will be stringified and prepended to
149			the message.
150
151			=item @setstate state value
152
153			Sets the named state C<state> to the given C<value>. State values are
154			associated with a specific player-NPC pair, so each NPC has its own state
155			with respect to a particular player, which makes them useful to store
156			information about previous questions and possibly answers. State values
157			get reset whenever the NPC gets reset.
158
159			See C<@ifstate> for an example.
160
161			=item @ifstate state value
162
163			Requires that the named C<state> has the given C<value>, otherwise this
164			topic is skipped. For more complex comparisons, see C<@cond> with
165			C<$state>. Example:
166
167			@match quest
168			@setstate question quest
169			Do you really want to help find the magic amulet of Beeblebrox?
170			@match yes
171			@ifstate question quest
172			Then fetch it, stupid!
173
174			=item @setflag flag value
175
176			Sets the named flag C<flag> to the given C<value>. Flag values are
177			associated with a specific player and can be seen by all NPCs. with
178			respect to a particular player, which makes them suitable to store quest
179			markers and other information (e.g. reputation/alignment). Flags are
180			persistent over the lifetime of a player, so be careful :)
181
182			See C<@ifflag> for an example.
183
184			=item @ifflag flag value
185
186			Requires that the named C<flag> has the given C<value>, otherwise this
187			topic is skipped. For more complex comparisons, see C<@cond> with
188			C<$flag>. Example:
189
190			@match I want to do the quest!
191			@setflag kings_quest 1
192			Then seek out Bumblebee in Navar, he will tell you...
193			@match I did the quest
194			@ifflag kings_quest 1
195			Really, which quets?
196
197			And Bumblebee might have:
198
199			@match hi
200			@ifflag kings_quest
201			Hi, I was told you want to do the kings quest?
202
203	elmex	1.2	=item @trigger connected-id [state]
204	root	1.1
205	elmex	1.2	Trigger all objects with the given connected-id.
206
207			When the state argument is omitted the trigger is stateful and retains an
208			internal state per connected-id. There is a limitation to the use of this: The
209			state won't be changed when the connection is triggered by other triggers. So
210			be careful when triggering the connection from other objects.
211
212			When a state argument is given it should be either 0 or 1. 1 will 'push' the connection
213			and 0 will 'release' the connection. This is useful for example when you want to
214			let a npc control a door.
215
216			Trigger all objects with the given connected-id by 'releasing' the connection.
217	root	1.1
218	root	1.8	=item @playersound face-name
219
220			Plays the given sound face (either an alias or sound file path) so that
221			only the player talking to the npc can hear it.
222
223			=item @npcsound face-name
224
225			Plays the given sound face (either an alias or sound file path) as if
226			the npc had made that sound, i.e. it will be located at the npc and all
227			players near enough can hear it.
228
229	root	1.1	=item @addtopic topic
230
231			Adds the given topic names (separated by C<\|>) to the list of topics
232			returned.
233
234			=back
235
236			=cut
237
238			sub tell {
239			my ($self, $msg) = @_;
240
241			my $lcmsg = lc $msg;
242
243			topic:
244			for my $match (@{ $self->{match} }) {
245			for (split /\\|/, $match->[0]) {
246	elmex	1.3	if ($_ eq "*" \|\| $lcmsg =~ /\b\Q$_\E\b/i) {
247	root	1.1	my $reply = $match->[1];
248			my @kw;
249
250			my @replies;
251			my @match; # @match/@parse command results
252
253			my $state = $self->{npc}{$self->{ob}->name}{dialog_state} \|\|= {};
254			my $flag = $self->{ob}{dialog_flag} \|\|= {};
255
256			my %vars = (
257			who => $self->{ob},
258			npc => $self->{npc},
259			state => $state,
260			flag => $flag,
261			msg => $msg,
262			match => \@match,
263			);
264
265			local $self->{ob}{record_replies} = \@replies;
266
267			# now execute @-commands (which can result in a no-match)
268			while ($reply =~ s/^\@(\w+)\s([^\n])\n?//) {
269			my ($cmd, $args) = ($1, $2);
270
271			if ($cmd eq "parse" \|\| $cmd eq "match") { # match is future rename
272			no re 'eval'; # default, but make sure
273			@match = $msg =~ /$args/i
274			or next topic;
275
276			} elsif ($cmd eq "comment") {
277			# nop
278
279	root	1.8	} elsif ($cmd eq "playersound") {
280			$self->{ob}->contr->play_sound (cf::sound::find $args);
281
282			} elsif ($cmd eq "npcsound") {
283			$self->{npc}->play_sound (cf::sound::find $args);
284
285	root	1.1	} elsif ($cmd eq "cond") {
286			cf::safe_eval $args, %vars
287			or next topic;
288
289			} elsif ($cmd eq "eval") {
290			cf::safe_eval $args, %vars;
291			warn "\@eval evaluation error: $@\n" if $@;
292
293			} elsif ($cmd eq "msg") {
294			push @replies, [$self->{npc}, (scalar cf::safe_eval $args, %vars)];
295
296			} elsif ($cmd eq "setflag") {
297			my ($name, $value) = split /\s+/, $args, 2;
298			$value ? $flag->{$name} = $value
299			: delete $flag->{$name};
300
301			} elsif ($cmd eq "setstate") {
302			my ($name, $value) = split /\s+/, $args, 2;
303			$value ? $state->{$name} = $value
304			: delete $state->{$name};
305
306			} elsif ($cmd eq "ifflag") {
307			my ($name, $value) = split /\s+/, $args, 2;
308			$flag->{$name} eq $value
309			or next topic;
310
311			} elsif ($cmd eq "ifstate") {
312			my ($name, $value) = split /\s+/, $args, 2;
313			$state->{$name} eq $value
314			or next topic;
315
316			} elsif ($cmd eq "trigger") {
317	elmex	1.2	my ($con, $state) = split /\s+/, $args, 2;
318			$con = $con * 1;
319
320			if (defined $state) {
321			$self->{npc}->map->trigger ($args, $state);
322			} else {
323			my $rvalue = \$self->{npc}{dialog_trigger}{$con};
324			$self->{npc}->map->trigger ($con, $$rvalue = !$$rvalue);
325			}
326	root	1.1
327			} elsif ($cmd eq "addtopic") {
328			push @kw, split /\\|/, $args;
329			$self->{add_topic}->(split /\s\\|\s/, $args) if $self->{add_topic};
330
331			} elsif ($cmd eq "deltopic") {
332			# not yet implemented, do it out-of-band
333			$self->{del_topic}->(split /\s\\|\s/, $args) if $self->{del_topic};
334
335			} else {
336			warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->msg . ")";
337			}
338			}
339
340			delete $self->{npc}{$self->{ob}->name}{dialog_state} unless %$state;
341			delete $self->{ob}{dialog_flag} unless %$flag;
342
343			# combine lines into paragraphs
344			$reply =~ s/(?<=\S)\n(?=\w)/ /g;
345			$reply =~ s/\n\n/\n/g;
346
347			# ignores flags and npc from replies
348			$reply = join "\n", (map $_->[1], @replies), $reply;
349
350			# now mark up all matching keywords
351			for my $match (@{ $self->{match} }) {
352			for (sort { (length $b) <=> (length $a) } split /\\|/, $match->[0]) {
353			if ($reply =~ /\b\Q$_\E\b/i) {
354			push @kw, $_;
355			last;
356			}
357			}
358			}
359
360			return wantarray ? ($reply, @kw) : $reply;
361			}
362			}
363			}
364
365			()
366			}
367
368			1