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.

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

               } 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;

            my @kw;
            # 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.7
Committed:	Thu Jul 20 04:24:02 2006 UTC (17 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.6:	+88 -6 lines
Log Message:	added @trigger, documentation
#	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			=back
104
105			=cut
106
107	root	1.1	sub tell {
108			my ($self, $msg) = @_;
109
110	root	1.5	my $lcmsg = lc $msg;
111	root	1.3
112	root	1.5	match:
113	root	1.1	for my $match (@{ $self->{match} }) {
114			for (split /\\|/, $match->[0]) {
115	root	1.5	if ($_ eq "*" \|\| $lcmsg eq lc) {
116	root	1.1	my $reply = $match->[1];
117
118	root	1.6	my @replies;
119	root	1.5	my @match; # @match/@parse command results
120	root	1.6	local $self->{ob}{record_replies} = \@replies;
121	root	1.5
122			# now execute @-commands (which can result in a no-match)
123			while ($reply =~ s/^\@(\w+)\s([^\n])\n?//) {
124			my ($cmd, $args) = ($1, $2);
125
126			if ($cmd eq "parse" \|\| $cmd eq "match") { # match is future rename
127			no re 'eval'; # default, but make sure
128			@match = $msg =~ /$args/i
129			or next match;
130
131			} elsif ($cmd eq "cond") {
132	root	1.7	cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match
133	root	1.5	or next match;
134
135			} elsif ($cmd eq "eval") {
136	root	1.7	cf::safe_eval $args, who => $self->{ob}, npc => $self->{npc}, msg => $msg, match => \@match;
137	root	1.5	warn "\@eval evaluation error: $@\n" if $@;
138
139	root	1.7	} elsif ($cmd eq "trigger") {
140			my $rvalue = \$self->{npc}{dialog_trigger}{$args*1};
141
142			my $trigger = cf::object::new "magic_ear";
143			$trigger->set_value ($$rvalue);
144
145			# needs to be on the map for remove_button_link to work
146			# the same should be true for add_button_link....
147			$self->{npc}->map->insert_object ($trigger, 0, 0);
148
149			$trigger->add_button_link ($self->{npc}->map, $args);
150
151			$trigger->use_trigger;
152
153			$trigger->remove_button_link;
154			$trigger->remove;
155
156			$trigger->free;
157
158			$$rvalue = !$$rvalue;
159
160	root	1.5	} else {
161			warn "unknown dialogue command <$cmd,$args> used (from " . $self->{npc}->get_message . ")";
162			}
163			}
164
165	root	1.7	# combine lines into paragraphs
166			$reply =~ s/(?<=\S)\n(?=\w)/ /g;
167			$reply =~ s/\n\n/\n/g;
168
169	root	1.6	# ignores flags and npc from replies
170			$reply = join "\n", (map $_->[1], @replies), $reply;
171	root	1.1
172			my @kw;
173			# now mark up all matching keywords
174			for my $match (@{ $self->{match} }) {
175			for (sort { (length $b) <=> (length $a) } split /\\|/, $match->[0]) {
176			if ($reply =~ /\b\Q$_\E\b/i) {
177			push @kw, $_;
178			last;
179			}
180			}
181			}
182
183			return wantarray ? ($reply, @kw) : $reply;
184			}
185			}
186			}
187
188			()
189			}
190
191			1