maps/perl/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->get_message =~ /^\@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}->get_message];

   $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 @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

Trigger all objects with the given connected-id. The trigger is stateful
and retains state per connected-id.

=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 eq lc) {
            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 "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 $rvalue = \$self->{npc}{dialog_trigger}{$args*1};
                  $self->{npc}->map->trigger ($args, $$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}->get_message . ")";
               }
            }

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