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

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

   match:
   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
            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 match;

               } elsif ($cmd eq "cond") {
                  cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match
                     or next match;

               } elsif ($cmd eq "eval") {
                  cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match;
                  warn "\@eval evaluation error: $@\n" if $@;

               } elsif ($cmd eq "trigger") {
                  my $rvalue = \$self->{npc}{dialog_trigger}{$args*1};

                  my $trigger = cf::object::new "magic_ear";
                  $trigger->set_value ($$rvalue);
                  
                  # needs to be on the map for remove_button_link to work
                  # the same *should* be true for add_button_link....
                  $self->{npc}->map->insert_object ($trigger, 0, 0);

                  $trigger->add_button_link ($self->{npc}->map, $args);

                  $trigger->use_trigger;

                  $trigger->remove_button_link;
                  $trigger->remove;
                  $trigger->free;

                  $$rvalue = !$$rvalue;

               } elsif ($cmd eq "addtopic") {
                  push @kw, split /\|/, $args;

               } else {
                  warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->get_message . ")";
               }
            }

            # 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:	Thu Jul 20 04:28:26 2006 UTC (17 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.7:	+9 -2 lines
Log Message:	added @addtopic
#	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			=back
90
91			The environment is that standard "map scripting environment", which is
92			limited in the type of constructs allowed (no loops, for example).
93
94			=item @eval perl
95
96			Like C<@cond>, but proceed regardless of the outcome.
97
98			=item @trigger connected-id
99
100			Trigger all objects with the given connected-id. The trigger is stateful
101			and retains state per connected-id.
102
103	root	1.8	=item @addtopic topic
104
105			Adds the given topic names (separated by C<\|>) to the list of topics
106			returned.
107
108	root	1.7	=back
109
110			=cut
111
112	root	1.1	sub tell {
113			my ($self, $msg) = @_;
114
115	root	1.5	my $lcmsg = lc $msg;
116	root	1.3
117	root	1.5	match:
118	root	1.1	for my $match (@{ $self->{match} }) {
119			for (split /\\|/, $match->[0]) {
120	root	1.5	if ($_ eq "*" \|\| $lcmsg eq lc) {
121	root	1.1	my $reply = $match->[1];
122	root	1.8	my @kw;
123	root	1.1
124	root	1.6	my @replies;
125	root	1.5	my @match; # @match/@parse command results
126	root	1.6	local $self->{ob}{record_replies} = \@replies;
127	root	1.5
128			# now execute @-commands (which can result in a no-match)
129			while ($reply =~ s/^\@(\w+)\s([^\n])\n?//) {
130			my ($cmd, $args) = ($1, $2);
131
132			if ($cmd eq "parse" \|\| $cmd eq "match") { # match is future rename
133			no re 'eval'; # default, but make sure
134			@match = $msg =~ /$args/i
135			or next match;
136
137			} elsif ($cmd eq "cond") {
138	root	1.7	cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match
139	root	1.5	or next match;
140
141			} elsif ($cmd eq "eval") {
142	root	1.7	cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match;
143	root	1.5	warn "\@eval evaluation error: $@\n" if $@;
144
145	root	1.7	} elsif ($cmd eq "trigger") {
146			my $rvalue = \$self->{npc}{dialog_trigger}{$args*1};
147
148			my $trigger = cf::object::new "magic_ear";
149			$trigger->set_value ($$rvalue);
150
151			# needs to be on the map for remove_button_link to work
152			# the same should be true for add_button_link....
153			$self->{npc}->map->insert_object ($trigger, 0, 0);
154
155			$trigger->add_button_link ($self->{npc}->map, $args);
156
157			$trigger->use_trigger;
158
159			$trigger->remove_button_link;
160			$trigger->remove;
161			$trigger->free;
162
163			$$rvalue = !$$rvalue;
164
165	root	1.8	} elsif ($cmd eq "addtopic") {
166			push @kw, split /\\|/, $args;
167
168	root	1.5	} else {
169			warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->get_message . ")";
170			}
171			}
172
173	root	1.7	# combine lines into paragraphs
174			$reply =~ s/(?<=\S)\n(?=\w)/ /g;
175			$reply =~ s/\n\n/\n/g;
176
177	root	1.6	# ignores flags and npc from replies
178			$reply = join "\n", (map $_->[1], @replies), $reply;
179	root	1.1
180			# now mark up all matching keywords
181			for my $match (@{ $self->{match} }) {
182			for (sort { (length $b) <=> (length $a) } split /\\|/, $match->[0]) {
183			if ($reply =~ /\b\Q$_\E\b/i) {
184			push @kw, $_;
185			last;
186			}
187			}
188			}
189
190			return wantarray ? ($reply, @kw) : $reply;
191			}
192			}
193			}
194
195			()
196			}
197
198			1