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

=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.5
Committed:	Sat Jun 16 23:22:59 2007 UTC (16 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.4:	+2 -0 lines
Log Message:	reorganised documentation and improved it
#	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			=item @eval perl
113
114			Like C<@cond>, but proceed regardless of the outcome.
115
116			=item @msg perl
117
118			Like C<@cond>, but the return value will be stringified and prepended to
119			the message.
120
121			=item @setstate state value
122
123			Sets the named state C<state> to the given C<value>. State values are
124			associated with a specific player-NPC pair, so each NPC has its own state
125			with respect to a particular player, which makes them useful to store
126			information about previous questions and possibly answers. State values
127			get reset whenever the NPC gets reset.
128
129			See C<@ifstate> for an example.
130
131			=item @ifstate state value
132
133			Requires that the named C<state> has the given C<value>, otherwise this
134			topic is skipped. For more complex comparisons, see C<@cond> with
135			C<$state>. Example:
136
137			@match quest
138			@setstate question quest
139			Do you really want to help find the magic amulet of Beeblebrox?
140			@match yes
141			@ifstate question quest
142			Then fetch it, stupid!
143
144			=item @setflag flag value
145
146			Sets the named flag C<flag> to the given C<value>. Flag values are
147			associated with a specific player and can be seen by all NPCs. with
148			respect to a particular player, which makes them suitable to store quest
149			markers and other information (e.g. reputation/alignment). Flags are
150			persistent over the lifetime of a player, so be careful :)
151
152			See C<@ifflag> for an example.
153
154			=item @ifflag flag value
155
156			Requires that the named C<flag> has the given C<value>, otherwise this
157			topic is skipped. For more complex comparisons, see C<@cond> with
158			C<$flag>. Example:
159
160			@match I want to do the quest!
161			@setflag kings_quest 1
162			Then seek out Bumblebee in Navar, he will tell you...
163			@match I did the quest
164			@ifflag kings_quest 1
165			Really, which quets?
166
167			And Bumblebee might have:
168
169			@match hi
170			@ifflag kings_quest
171			Hi, I was told you want to do the kings quest?
172
173	elmex	1.2	=item @trigger connected-id [state]
174	root	1.1
175	elmex	1.2	Trigger all objects with the given connected-id.
176
177			When the state argument is omitted the trigger is stateful and retains an
178			internal state per connected-id. There is a limitation to the use of this: The
179			state won't be changed when the connection is triggered by other triggers. So
180			be careful when triggering the connection from other objects.
181
182			When a state argument is given it should be either 0 or 1. 1 will 'push' the connection
183			and 0 will 'release' the connection. This is useful for example when you want to
184			let a npc control a door.
185
186			Trigger all objects with the given connected-id by 'releasing' the connection.
187	root	1.1
188			=item @addtopic topic
189
190			Adds the given topic names (separated by C<\|>) to the list of topics
191			returned.
192
193			=back
194
195			=cut
196
197			sub tell {
198			my ($self, $msg) = @_;
199
200			my $lcmsg = lc $msg;
201
202			topic:
203			for my $match (@{ $self->{match} }) {
204			for (split /\\|/, $match->[0]) {
205	elmex	1.3	if ($_ eq "*" \|\| $lcmsg =~ /\b\Q$_\E\b/i) {
206	root	1.1	my $reply = $match->[1];
207			my @kw;
208
209			my @replies;
210			my @match; # @match/@parse command results
211
212			my $state = $self->{npc}{$self->{ob}->name}{dialog_state} \|\|= {};
213			my $flag = $self->{ob}{dialog_flag} \|\|= {};
214
215			my %vars = (
216			who => $self->{ob},
217			npc => $self->{npc},
218			state => $state,
219			flag => $flag,
220			msg => $msg,
221			match => \@match,
222			);
223
224			local $self->{ob}{record_replies} = \@replies;
225
226			# now execute @-commands (which can result in a no-match)
227			while ($reply =~ s/^\@(\w+)\s([^\n])\n?//) {
228			my ($cmd, $args) = ($1, $2);
229
230			if ($cmd eq "parse" \|\| $cmd eq "match") { # match is future rename
231			no re 'eval'; # default, but make sure
232			@match = $msg =~ /$args/i
233			or next topic;
234
235			} elsif ($cmd eq "comment") {
236			# nop
237
238			} elsif ($cmd eq "cond") {
239			cf::safe_eval $args, %vars
240			or next topic;
241
242			} elsif ($cmd eq "eval") {
243			cf::safe_eval $args, %vars;
244			warn "\@eval evaluation error: $@\n" if $@;
245
246			} elsif ($cmd eq "msg") {
247			push @replies, [$self->{npc}, (scalar cf::safe_eval $args, %vars)];
248
249			} elsif ($cmd eq "setflag") {
250			my ($name, $value) = split /\s+/, $args, 2;
251			$value ? $flag->{$name} = $value
252			: delete $flag->{$name};
253
254			} elsif ($cmd eq "setstate") {
255			my ($name, $value) = split /\s+/, $args, 2;
256			$value ? $state->{$name} = $value
257			: delete $state->{$name};
258
259			} elsif ($cmd eq "ifflag") {
260			my ($name, $value) = split /\s+/, $args, 2;
261			$flag->{$name} eq $value
262			or next topic;
263
264			} elsif ($cmd eq "ifstate") {
265			my ($name, $value) = split /\s+/, $args, 2;
266			$state->{$name} eq $value
267			or next topic;
268
269			} elsif ($cmd eq "trigger") {
270	elmex	1.2	my ($con, $state) = split /\s+/, $args, 2;
271			$con = $con * 1;
272
273			if (defined $state) {
274			$self->{npc}->map->trigger ($args, $state);
275			} else {
276			my $rvalue = \$self->{npc}{dialog_trigger}{$con};
277			$self->{npc}->map->trigger ($con, $$rvalue = !$$rvalue);
278			}
279	root	1.1
280			} elsif ($cmd eq "addtopic") {
281			push @kw, split /\\|/, $args;
282			$self->{add_topic}->(split /\s\\|\s/, $args) if $self->{add_topic};
283
284			} elsif ($cmd eq "deltopic") {
285			# not yet implemented, do it out-of-band
286			$self->{del_topic}->(split /\s\\|\s/, $args) if $self->{del_topic};
287
288			} else {
289			warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->msg . ")";
290			}
291			}
292
293			delete $self->{npc}{$self->{ob}->name}{dialog_state} unless %$state;
294			delete $self->{ob}{dialog_flag} unless %$flag;
295
296			# combine lines into paragraphs
297			$reply =~ s/(?<=\S)\n(?=\w)/ /g;
298			$reply =~ s/\n\n/\n/g;
299
300			# ignores flags and npc from replies
301			$reply = join "\n", (map $_->[1], @replies), $reply;
302
303			# now mark up all matching keywords
304			for my $match (@{ $self->{match} }) {
305			for (sort { (length $b) <=> (length $a) } split /\\|/, $match->[0]) {
306			if ($reply =~ /\b\Q$_\E\b/i) {
307			push @kw, $_;
308			last;
309			}
310			}
311			}
312
313			return wantarray ? ($reply, @kw) : $reply;
314			}
315			}
316			}
317
318			()
319			}
320
321			1