[ViewVC] Annotation of: cvs/Net-Knuddels/eg/markovd

#!/opt/bin/perl

use strict;

use Socket;
use IO::Socket::INET;

use YAML;
use Encode;
use Event;
use Net::Knuddels;
use Algorithm::MarkovChain;
use String::Similarity;
use List::Util;
use Time::HiRes;

my @CHANNELS = (
  'Flirt', 
  'Flirt Private', 
  'Singles 11-14', 
  'Singles 15-17',

  'Singles 11-14 2', 
  'Singles 15-17 2',
  'Flirt 2', 
  'Flirt Private 2', 
  'Singles 11-14 3', 
  'Singles 15-17 3',
  'Flirt 3', 
  'Flirt Private 3', 
  'Singles 11-14 4', 
  'Singles 15-17 4',
  'Flirt 4', 
  'Flirt Private 4', 
  'Singles 11-14 5', 
  'Singles 15-17 5',
  'Flirt 5', 
  'Flirt Private 5', 
  'Singles 11-14 6', 
  'Singles 15-17 6',
  'Flirt 6', 
  'Flirt Private 6', 
  'Singles 11-14 7', 
  'Singles 15-17 7',
  'Flirt 7', 
  'Flirt Private 7', 
  'Singles 11-14 8', 
  'Singles 15-17 8',
  'Flirt 8', 
  'Flirt Private 8', 
);

my $logdir = "logs";

my $Knick = "ich bin suess";
my $Kpass = "qwerty";

my $client;

my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
$seed ||= [];

my $fwd = new Algorithm::MarkovChain;
my $rev = new Algorithm::MarkovChain;

my %freq;
my $word_cnt;

sub word {
   $_[0] =~ /(\w+)/ ? lc $1 : ();
}

sub seed_msg {
   my $msg = $_[0];

   return if $msg =~ /leck|fick|möse|mose|moese|uschi|usci|ushi|fikk|scheide|vagina
                     |bumsen|wichs|wix|popp|popen|fuck|dreck|laber|saugen|pussy|\bsuck\b
                     |\bblas|piss|schluck|fingern|spritz|\bloch|\bsteck|vögel|voegel|vogel
                     |hure|strich|sklave|handschell|slave
                     |stengel|penis|schwanz|pimmel|steifen|ejak|sperma|\btitt|\bass|\bsack|\bsaft\b
                     |\bcs\b|\bts\b|\brs\b|\bicq\b
                     |cam\b|\bmsn\b|\bbot\b|\bchat.*bot\b|tanga|schlafen|sex|\bsau\b
                     |intim|arsch|fotze|dumm|schnauze|klappe|rasiert|fresse|maul\b|\bmaul|rosett?e
                     |zieh.*aus|nackt
                     |sätz|saetz|setze|\bsatz
                     |sc?h?wul|schwuchtel|transe|transv|schlampe|tussi|nutte|mädel
                     |admin|nachgeburt
                     |(?-i:[A-Z]{4,})
                     |\S{20,}
                     /xi;
   
   my @msg = $msg =~ m/(\S+)/g;

   $freq{word $_}++ for @msg;
   $word_cnt += @msg;

   $fwd->seed (symbols => \@msg, longest => 10);
   $rev->seed (symbols => [reverse @msg], longest => 10);
}

for (@$seed) {
   seed_msg $_;
}

my %grammar_reply = qw(
   ich  du
   du   ich
   mir  dir
   dir  mir
   mein dein
   dein mein
   frau mann
   mädel junge
   mädchen junge
   freund freundin
   freundin freund
   girls boys
   boys girls
   huhu hi
   hi hi
   hallo hi
   typen mädels
);

sub gen_reply {
   my ($msg) = @_;

   my @msg = $msg =~ /(\S+)/g;

   @msg = map {
      my $word = word $_;
      
      $grammar_reply{$word}
         or $freq{$word} < $word_cnt * 0.002
            && $freq{$word} >= 2
            && 4 < length $word
            ? $word
            : ()
   } @msg;

   my $reply;
   my $best = 2;

   for (1..10) {
      shift @msg if @msg > $_;
      my $len = rand() ** 3 * 15 + 2;
      my @r = reverse $rev->spew (complete => [reverse @msg], length => $len, stop_at_terminal => 1);
      @r = $fwd->spew (complete => \@r, length => $len, stop_at_terminal => 1);
      my $r = join " ", @r;
      my $b = (List::Util::sum map $freq{word $_} / $word_cnt, @r) / @r;
      ($reply, $best) = ($r, $b) if $b < $best;
   }

   $reply;
}

while (0) {
   my $r = gen_reply scalar <>;
   print "$r\n\n";
}

Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });

Event->timer (interval => 60, cb => sub {
   open my $fh, ">", "markovbot.dat~"
      or return;
   binmode $fh;
   print $fh Encode::encode_utf8 Dump $seed;
   close $fh;
   rename "markovbot.dat~", "markovbot.dat";
});

sub logit {
  my ($msg, $file, $src, $dst, $room) = @_;

  mkdir $logdir;
  my $fh;

  unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
    warn "Couldn't open for appending $logdir/$src: $!\n";
    return;
  }

  print $fh "$room\t$src\t$dst\t$msg\n";
}

####################################################################################
########################## MAIN START ##############################################
####################################################################################

$client = new Net::Knuddels::Client
   PeerAddr => "213.61.5.150:2710",
   command_wait => sub {
      my ($client, $wait) = @_;
      Event->timer (after => $wait, cb => sub { $client->command_cb });
   };

Event->io (
   fd   => $client->fh, 
   poll => 'r', 
   cb   => sub { 
      $client->ready
         or $_[0]->w->cancel;
});

$client->login;

$client->register (dialog => sub {
   use Dumpvalue;
   print "---\n";
   Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
});

$client->register (login => sub {
   $client->enter_room ($_, $Knick, $Kpass)
      for @CHANNELS;
});

$client->register (msg_room => sub {
   my ($room, $user, $msg) = @_;
});

my @queue;

Event->timer (interval => 1, cb => sub {
   my $msg = shift @queue
      or return;

   logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
   $client->send_priv_msg (@$msg);
});

my $some_room;

$client->register (room_info => sub {
   print "JOIN ROOM: $_[0]\n";
   $some_room = $_[0];
});

Event->timer (after => 60, interval => 60, cb => sub {
   $client->send_priv_msg ("James", $some_room, "/knuschel");
});

my %next_time;

$client->register (msg_priv_nondup => sub {
   my ($room, $src, $dst, $msg) = @_;

   my $NOW = Time::HiRes::time;

   $msg =~ s/\260[^\260]*\260//g;

   print "($room) $src >> $msg\n";
   logit ($msg, $src, $src, $dst, $room);

   return if $next_time{$src} > time; # do not talk unnaturally often

   my $reply = gen_reply $msg;

   push @$seed, $msg;
   seed_msg $msg;

   my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
   $next_time{$src} = time + $delay;

   print "($room) $src << $reply ($delay)\n";

   Event->timer (at => $NOW + $delay, cb => sub {
      push @queue, [$src, $room, $reply];
   });
});

Event::loop;

Revision:	1.32
Committed:	Sun Jan 30 08:01:33 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.31:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.25	#!/opt/bin/perl
2	elmex	1.1
3			use strict;
4	root	1.2
5	elmex	1.1	use Socket;
6			use IO::Socket::INET;
7	root	1.2
8			use YAML;
9			use Encode;
10	elmex	1.1	use Event;
11			use Net::Knuddels;
12	root	1.2	use Algorithm::MarkovChain;
13	root	1.15	use String::Similarity;
14	root	1.23	use List::Util;
15	root	1.27	use Time::HiRes;
16	elmex	1.1
17			my @CHANNELS = (
18	elmex	1.3	'Flirt',
19	root	1.11	'Flirt Private',
20	root	1.10	'Singles 11-14',
21			'Singles 15-17',
22	root	1.11
23	root	1.18	'Singles 11-14 2',
24			'Singles 15-17 2',
25	root	1.11	'Flirt 2',
26	root	1.18	'Flirt Private 2',
27	root	1.11	'Singles 11-14 3',
28	root	1.18	'Singles 15-17 3',
29	root	1.11	'Flirt 3',
30	root	1.18	'Flirt Private 3',
31	root	1.11	'Singles 11-14 4',
32	root	1.18	'Singles 15-17 4',
33	root	1.11	'Flirt 4',
34	root	1.18	'Flirt Private 4',
35	root	1.11	'Singles 11-14 5',
36	root	1.18	'Singles 15-17 5',
37	root	1.11	'Flirt 5',
38	root	1.18	'Flirt Private 5',
39	root	1.11	'Singles 11-14 6',
40	root	1.18	'Singles 15-17 6',
41	root	1.11	'Flirt 6',
42	root	1.18	'Flirt Private 6',
43	root	1.11	'Singles 11-14 7',
44	root	1.18	'Singles 15-17 7',
45	root	1.11	'Flirt 7',
46	root	1.18	'Flirt Private 7',
47	root	1.11	'Singles 11-14 8',
48	root	1.18	'Singles 15-17 8',
49	root	1.11	'Flirt 8',
50	root	1.18	'Flirt Private 8',
51	elmex	1.1	);
52
53	root	1.14	my $logdir = "logs";
54	elmex	1.4
55	root	1.18	my $Knick = "ich bin suess";
56	root	1.15	my $Kpass = "qwerty";
57	elmex	1.1
58			my $client;
59
60	root	1.11	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
61	root	1.2	$seed \|\|= [];
62
63	root	1.23	my $fwd = new Algorithm::MarkovChain;
64			my $rev = new Algorithm::MarkovChain;
65
66			my %freq;
67			my $word_cnt;
68
69			sub word {
70			$_[0] =~ /(\w+)/ ? lc $1 : ();
71			}
72	root	1.11
73			sub seed_msg {
74			my $msg = $_[0];
75	root	1.19
76	root	1.32	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
77	root	1.27	\|bumsen\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b
78	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
79	root	1.27	\|hure\|strich\|sklave\|handschell\|slave
80	root	1.23	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b
81	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
82	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
83	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
84	root	1.15	\|zieh.*aus\|nackt
85			\|sätz\|saetz\|setze\|\bsatz
86	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
87			\|admin\|nachgeburt
88	root	1.15	\|(?-i:[A-Z]{4,})
89	root	1.23	\|\S{20,}
90	root	1.15	/xi;
91
92	root	1.11	my @msg = $msg =~ m/(\S+)/g;
93
94	root	1.23	$freq{word $_}++ for @msg;
95			$word_cnt += @msg;
96
97	root	1.27	$fwd->seed (symbols => \@msg, longest => 10);
98			$rev->seed (symbols => [reverse @msg], longest => 10);
99	root	1.11	}
100
101			for (@$seed) {
102			seed_msg $_;
103			}
104
105	root	1.23	my %grammar_reply = qw(
106			ich du
107			du ich
108			mir dir
109			dir mir
110			mein dein
111			dein mein
112			frau mann
113			mädel junge
114			mädchen junge
115			freund freundin
116			freundin freund
117			girls boys
118			boys girls
119			huhu hi
120			hi hi
121			hallo hi
122			typen mädels
123			);
124
125	root	1.11	sub gen_reply {
126			my ($msg) = @_;
127
128	root	1.23	my @msg = $msg =~ /(\S+)/g;
129
130			@msg = map {
131			my $word = word $_;
132
133			$grammar_reply{$word}
134			or $freq{$word} < $word_cnt * 0.002
135			&& $freq{$word} >= 2
136			&& 4 < length $word
137			? $word
138			: ()
139			} @msg;
140	root	1.19
141	root	1.15	my $reply;
142	root	1.23	my $best = 2;
143	root	1.15
144	root	1.27	for (1..10) {
145	root	1.23	shift @msg if @msg > $_;
146	root	1.27	my $len = rand() ** 3 * 15 + 2;
147	root	1.23	my @r = reverse $rev->spew (complete => [reverse @msg], length => $len, stop_at_terminal => 1);
148			@r = $fwd->spew (complete => \@r, length => $len, stop_at_terminal => 1);
149			my $r = join " ", @r;
150			my $b = (List::Util::sum map $freq{word $_} / $word_cnt, @r) / @r;
151			($reply, $best) = ($r, $b) if $b < $best;
152	root	1.15	}
153
154			$reply;
155	root	1.11	}
156
157	root	1.23	while (0) {
158			my $r = gen_reply scalar <>;
159			print "$r\n\n";
160			}
161
162	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
163	root	1.2
164	root	1.8	Event->timer (interval => 60, cb => sub {
165	root	1.11	open my $fh, ">", "markovbot.dat~"
166	root	1.2	or return;
167	root	1.30	binmode $fh;
168	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
169			close $fh;
170	root	1.11	rename "markovbot.dat~", "markovbot.dat";
171	root	1.2	});
172
173	elmex	1.4	sub logit {
174	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
175	elmex	1.4
176	root	1.12	mkdir $logdir;
177			my $fh;
178	elmex	1.4
179	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
180	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
181			return;
182			}
183
184	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
185	elmex	1.4	}
186
187	elmex	1.1	####################################################################################
188			########################## MAIN START ##############################################
189			####################################################################################
190
191	root	1.23	$client = new Net::Knuddels::Client
192			PeerAddr => "213.61.5.150:2710",
193			command_wait => sub {
194			my ($client, $wait) = @_;
195			Event->timer (after => $wait, cb => sub { $client->command_cb });
196			};
197
198			Event->io (
199			fd => $client->fh,
200			poll => 'r',
201			cb => sub {
202			$client->ready
203			or $_[0]->w->cancel;
204			});
205
206			$client->login;
207	elmex	1.1
208	root	1.31	$client->register (dialog => sub {
209			use Dumpvalue;
210			print "---\n";
211			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
212			});
213	root	1.7
214	elmex	1.1	$client->register (login => sub {
215	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
216			for @CHANNELS;
217	elmex	1.1	});
218
219			$client->register (msg_room => sub {
220			my ($room, $user, $msg) = @_;
221	root	1.2	});
222
223			my @queue;
224
225			Event->timer (interval => 1, cb => sub {
226			my $msg = shift @queue
227			or return;
228
229	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
230	root	1.2	$client->send_priv_msg (@$msg);
231	elmex	1.1	});
232
233	root	1.20	my $some_room;
234
235	root	1.17	$client->register (room_info => sub {
236	root	1.20	print "JOIN ROOM: $_[0]\n";
237			$some_room = $_[0];
238			});
239
240			Event->timer (after => 60, interval => 60, cb => sub {
241			$client->send_priv_msg ("James", $some_room, "/knuschel");
242	elmex	1.16	});
243	root	1.17
244	root	1.18	my %next_time;
245
246	elmex	1.16	$client->register (msg_priv_nondup => sub {
247	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
248
249	root	1.27	my $NOW = Time::HiRes::time;
250
251	root	1.7	$msg =~ s/\260[^\260]*\260//g;
252
253	root	1.2	print "($room) $src >> $msg\n";
254	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
255	root	1.2
256	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
257
258	root	1.21	my $reply = gen_reply $msg;
259
260	root	1.11	push @$seed, $msg;
261	root	1.15	seed_msg $msg;
262	elmex	1.1
263	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
264	root	1.18	$next_time{$src} = time + $delay;
265	root	1.9
266	root	1.8	print "($room) $src << $reply ($delay)\n";
267	elmex	1.1
268	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
269	root	1.2	push @queue, [$src, $room, $reply];
270			});
271	elmex	1.1	});
272
273			Event::loop;
274	root	1.7