ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/maps/perl/NPC_Dialogue.pm
Revision: 1.13
Committed: Fri Dec 15 19:11:46 2006 UTC (17 years, 7 months ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.12: +0 -0 lines
State: FILE REMOVED
Log Message:
move .ext to server

File Contents

# Content
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 =item @trigger connected-id
170
171 Trigger all objects with the given connected-id. The trigger is stateful
172 and retains state per connected-id.
173
174 =item @addtopic topic
175
176 Adds the given topic names (separated by C<|>) to the list of topics
177 returned.
178
179 =back
180
181 =cut
182
183 sub tell {
184 my ($self, $msg) = @_;
185
186 my $lcmsg = lc $msg;
187
188 topic:
189 for my $match (@{ $self->{match} }) {
190 for (split /\|/, $match->[0]) {
191 if ($_ eq "*" || $lcmsg eq lc) {
192 my $reply = $match->[1];
193 my @kw;
194
195 my @replies;
196 my @match; # @match/@parse command results
197
198 my $state = $self->{npc}{$self->{ob}->name}{dialog_state} ||= {};
199 my $flag = $self->{ob}{dialog_flag} ||= {};
200
201 my %vars = (
202 who => $self->{ob},
203 npc => $self->{npc},
204 state => $state,
205 flag => $flag,
206 msg => $msg,
207 match => \@match,
208 );
209
210 local $self->{ob}{record_replies} = \@replies;
211
212 # now execute @-commands (which can result in a no-match)
213 while ($reply =~ s/^\@(\w+)\s*([^\n]*)\n?//) {
214 my ($cmd, $args) = ($1, $2);
215
216 if ($cmd eq "parse" || $cmd eq "match") { # match is future rename
217 no re 'eval'; # default, but make sure
218 @match = $msg =~ /$args/i
219 or next topic;
220
221 } elsif ($cmd eq "comment") {
222 # nop
223
224 } elsif ($cmd eq "cond") {
225 cf::safe_eval $args, %vars
226 or next topic;
227
228 } elsif ($cmd eq "eval") {
229 cf::safe_eval $args, %vars;
230 warn "\@eval evaluation error: $@\n" if $@;
231
232 } elsif ($cmd eq "msg") {
233 push @replies, [$self->{npc}, (scalar cf::safe_eval $args, %vars)];
234
235 } elsif ($cmd eq "setflag") {
236 my ($name, $value) = split /\s+/, $args, 2;
237 $value ? $flag->{$name} = $value
238 : delete $flag->{$name};
239
240 } elsif ($cmd eq "setstate") {
241 my ($name, $value) = split /\s+/, $args, 2;
242 $value ? $state->{$name} = $value
243 : delete $state->{$name};
244
245 } elsif ($cmd eq "ifflag") {
246 my ($name, $value) = split /\s+/, $args, 2;
247 $flag->{$name} eq $value
248 or next topic;
249
250 } elsif ($cmd eq "ifstate") {
251 my ($name, $value) = split /\s+/, $args, 2;
252 $state->{$name} eq $value
253 or next topic;
254
255 } elsif ($cmd eq "trigger") {
256 my $rvalue = \$self->{npc}{dialog_trigger}{$args*1};
257 $self->{npc}->map->trigger ($args, $$rvalue = !$$rvalue);
258
259 } elsif ($cmd eq "addtopic") {
260 push @kw, split /\|/, $args;
261 $self->{add_topic}->(split /\s*\|\s*/, $args) if $self->{add_topic};
262
263 } elsif ($cmd eq "deltopic") {
264 # not yet implemented, do it out-of-band
265 $self->{del_topic}->(split /\s*\|\s*/, $args) if $self->{del_topic};
266
267 } else {
268 warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->msg . ")";
269 }
270 }
271
272 delete $self->{npc}{$self->{ob}->name}{dialog_state} unless %$state;
273 delete $self->{ob}{dialog_flag} unless %$flag;
274
275 # combine lines into paragraphs
276 $reply =~ s/(?<=\S)\n(?=\w)/ /g;
277 $reply =~ s/\n\n/\n/g;
278
279 # ignores flags and npc from replies
280 $reply = join "\n", (map $_->[1], @replies), $reply;
281
282 # now mark up all matching keywords
283 for my $match (@{ $self->{match} }) {
284 for (sort { (length $b) <=> (length $a) } split /\|/, $match->[0]) {
285 if ($reply =~ /\b\Q$_\E\b/i) {
286 push @kw, $_;
287 last;
288 }
289 }
290 }
291
292 return wantarray ? ($reply, @kw) : $reply;
293 }
294 }
295 }
296
297 ()
298 }
299
300 1