[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|perver|befehl|stöhn|dildo
                     |stengel|penis|schwanz|pimmel|steifen|ejak|sperma|\btitt|\bass|\bsack|\bsaft\b|\beier\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
   bye bye
   ciao bye
);

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

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

   @msg = map {
      my $word = word $_;
      
      $grammar_reply{$word}
         or $freq{$word} < $word_cnt * 0.003
            && $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 ([@_]);
   Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
});

$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.38
Committed:	Sun Jan 30 21:32:47 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.37:	+0 -8 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.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
80	root	1.33	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\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.37	$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	root	1.33	bye bye
124			ciao bye
125	root	1.23	);
126
127	root	1.11	sub gen_reply {
128			my ($msg) = @_;
129
130	root	1.23	my @msg = $msg =~ /(\S+)/g;
131
132			@msg = map {
133			my $word = word $_;
134
135			$grammar_reply{$word}
136	root	1.33	or $freq{$word} < $word_cnt * 0.003
137	root	1.23	&& $freq{$word} >= 2
138			&& 4 < length $word
139			? $word
140			: ()
141			} @msg;
142	root	1.19
143	root	1.15	my $reply;
144	root	1.23	my $best = 2;
145	root	1.15
146	root	1.37	for (1..10) {
147	root	1.23	shift @msg if @msg > $_;
148	root	1.37	my $len = rand() ** 3 * 15 + 2;
149	root	1.23	my @r = reverse $rev->spew (complete => [reverse @msg], length => $len, stop_at_terminal => 1);
150			@r = $fwd->spew (complete => \@r, length => $len, stop_at_terminal => 1);
151			my $r = join " ", @r;
152			my $b = (List::Util::sum map $freq{word $_} / $word_cnt, @r) / @r;
153			($reply, $best) = ($r, $b) if $b < $best;
154	root	1.15	}
155
156			$reply;
157	root	1.11	}
158
159	root	1.23	while (0) {
160			my $r = gen_reply scalar <>;
161			print "$r\n\n";
162			}
163
164	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
165	root	1.2
166	root	1.8	Event->timer (interval => 60, cb => sub {
167	root	1.11	open my $fh, ">", "markovbot.dat~"
168	root	1.2	or return;
169	root	1.30	binmode $fh;
170	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
171			close $fh;
172	root	1.11	rename "markovbot.dat~", "markovbot.dat";
173	root	1.2	});
174
175	elmex	1.4	sub logit {
176	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
177	elmex	1.4
178	root	1.12	mkdir $logdir;
179			my $fh;
180	elmex	1.4
181	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
182	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
183			return;
184			}
185
186	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
187	elmex	1.4	}
188
189	elmex	1.1	####################################################################################
190			########################## MAIN START ##############################################
191			####################################################################################
192
193	root	1.23	$client = new Net::Knuddels::Client
194			PeerAddr => "213.61.5.150:2710",
195			command_wait => sub {
196			my ($client, $wait) = @_;
197			Event->timer (after => $wait, cb => sub { $client->command_cb });
198			};
199
200			Event->io (
201			fd => $client->fh,
202			poll => 'r',
203			cb => sub {
204			$client->ready
205			or $_[0]->w->cancel;
206			});
207
208			$client->login;
209	elmex	1.1
210	root	1.31	$client->register (dialog => sub {
211			use Dumpvalue;
212			print "---\n";
213			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
214	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
215	root	1.31	});
216	root	1.7
217	elmex	1.1	$client->register (login => sub {
218	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
219			for @CHANNELS;
220	elmex	1.1	});
221
222			$client->register (msg_room => sub {
223			my ($room, $user, $msg) = @_;
224	root	1.2	});
225
226			my @queue;
227
228			Event->timer (interval => 1, cb => sub {
229			my $msg = shift @queue
230			or return;
231
232	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
233	root	1.2	$client->send_priv_msg (@$msg);
234	elmex	1.1	});
235
236	root	1.20	my $some_room;
237
238	root	1.17	$client->register (room_info => sub {
239	root	1.20	print "JOIN ROOM: $_[0]\n";
240			$some_room = $_[0];
241			});
242
243			Event->timer (after => 60, interval => 60, cb => sub {
244			$client->send_priv_msg ("James", $some_room, "/knuschel");
245	elmex	1.16	});
246	root	1.17
247	root	1.18	my %next_time;
248
249	elmex	1.16	$client->register (msg_priv_nondup => sub {
250	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
251
252	root	1.27	my $NOW = Time::HiRes::time;
253
254	root	1.7	$msg =~ s/\260[^\260]*\260//g;
255
256	root	1.2	print "($room) $src >> $msg\n";
257	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
258	root	1.2
259	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
260
261	root	1.21	my $reply = gen_reply $msg;
262
263	root	1.11	push @$seed, $msg;
264	root	1.15	seed_msg $msg;
265	elmex	1.1
266	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
267	root	1.18	$next_time{$src} = time + $delay;
268	root	1.9
269	root	1.8	print "($room) $src << $reply ($delay)\n";
270	elmex	1.1
271	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
272	root	1.2	push @queue, [$src, $room, $reply];
273			});
274	elmex	1.1	});
275
276			Event::loop;
277	root	1.7