[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
                     |bums|wichs|wix|popp|popen|fuck|dreck|laber|saugen|pussy|\bsuck\b|lutsch
                     |knallen|schlecken
                     |\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|willy
                     |\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|geile|feucht|willig
                     |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.39
Committed:	Mon Jan 31 00:50:50 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.38:	+4 -3 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.39	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
78			\|knallen\|schlecken
79	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
80	root	1.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
81	root	1.39	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
82	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
83	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
84	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
85	root	1.39	\|zieh.*aus\|nackt\|geile\|feucht\|willig
86	root	1.15	\|sätz\|saetz\|setze\|\bsatz
87	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
88			\|admin\|nachgeburt
89	root	1.15	\|(?-i:[A-Z]{4,})
90	root	1.23	\|\S{20,}
91	root	1.15	/xi;
92
93	root	1.11	my @msg = $msg =~ m/(\S+)/g;
94
95	root	1.23	$freq{word $_}++ for @msg;
96			$word_cnt += @msg;
97
98	root	1.37	$fwd->seed (symbols => \@msg, longest => 10);
99			$rev->seed (symbols => [reverse @msg], longest => 10);
100	root	1.11	}
101
102			for (@$seed) {
103			seed_msg $_;
104			}
105
106	root	1.23	my %grammar_reply = qw(
107			ich du
108			du ich
109			mir dir
110			dir mir
111			mein dein
112			dein mein
113			frau mann
114			mädel junge
115			mädchen junge
116			freund freundin
117			freundin freund
118			girls boys
119			boys girls
120			huhu hi
121			hi hi
122			hallo hi
123			typen mädels
124	root	1.33	bye bye
125			ciao bye
126	root	1.23	);
127
128	root	1.11	sub gen_reply {
129			my ($msg) = @_;
130
131	root	1.23	my @msg = $msg =~ /(\S+)/g;
132
133			@msg = map {
134			my $word = word $_;
135
136			$grammar_reply{$word}
137	root	1.33	or $freq{$word} < $word_cnt * 0.003
138	root	1.23	&& $freq{$word} >= 2
139			&& 4 < length $word
140			? $word
141			: ()
142			} @msg;
143	root	1.19
144	root	1.15	my $reply;
145	root	1.23	my $best = 2;
146	root	1.15
147	root	1.37	for (1..10) {
148	root	1.23	shift @msg if @msg > $_;
149	root	1.37	my $len = rand() ** 3 * 15 + 2;
150	root	1.23	my @r = reverse $rev->spew (complete => [reverse @msg], length => $len, stop_at_terminal => 1);
151			@r = $fwd->spew (complete => \@r, length => $len, stop_at_terminal => 1);
152			my $r = join " ", @r;
153			my $b = (List::Util::sum map $freq{word $_} / $word_cnt, @r) / @r;
154			($reply, $best) = ($r, $b) if $b < $best;
155	root	1.15	}
156
157			$reply;
158	root	1.11	}
159
160	root	1.23	while (0) {
161			my $r = gen_reply scalar <>;
162			print "$r\n\n";
163			}
164
165	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
166	root	1.2
167	root	1.8	Event->timer (interval => 60, cb => sub {
168	root	1.11	open my $fh, ">", "markovbot.dat~"
169	root	1.2	or return;
170	root	1.30	binmode $fh;
171	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
172			close $fh;
173	root	1.11	rename "markovbot.dat~", "markovbot.dat";
174	root	1.2	});
175
176	elmex	1.4	sub logit {
177	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
178	elmex	1.4
179	root	1.12	mkdir $logdir;
180			my $fh;
181	elmex	1.4
182	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
183	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
184			return;
185			}
186
187	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
188	elmex	1.4	}
189
190	elmex	1.1	####################################################################################
191			########################## MAIN START ##############################################
192			####################################################################################
193
194	root	1.23	$client = new Net::Knuddels::Client
195			PeerAddr => "213.61.5.150:2710",
196			command_wait => sub {
197			my ($client, $wait) = @_;
198			Event->timer (after => $wait, cb => sub { $client->command_cb });
199			};
200
201			Event->io (
202			fd => $client->fh,
203			poll => 'r',
204			cb => sub {
205			$client->ready
206			or $_[0]->w->cancel;
207			});
208
209			$client->login;
210	elmex	1.1
211	root	1.31	$client->register (dialog => sub {
212			use Dumpvalue;
213			print "---\n";
214			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
215	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
216	root	1.31	});
217	root	1.7
218	elmex	1.1	$client->register (login => sub {
219	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
220			for @CHANNELS;
221	elmex	1.1	});
222
223			$client->register (msg_room => sub {
224			my ($room, $user, $msg) = @_;
225	root	1.2	});
226
227			my @queue;
228
229			Event->timer (interval => 1, cb => sub {
230			my $msg = shift @queue
231			or return;
232
233	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
234	root	1.2	$client->send_priv_msg (@$msg);
235	elmex	1.1	});
236
237	root	1.20	my $some_room;
238
239	root	1.17	$client->register (room_info => sub {
240	root	1.20	print "JOIN ROOM: $_[0]\n";
241			$some_room = $_[0];
242			});
243
244			Event->timer (after => 60, interval => 60, cb => sub {
245			$client->send_priv_msg ("James", $some_room, "/knuschel");
246	elmex	1.16	});
247	root	1.17
248	root	1.18	my %next_time;
249
250	elmex	1.16	$client->register (msg_priv_nondup => sub {
251	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
252
253	root	1.27	my $NOW = Time::HiRes::time;
254
255	root	1.7	$msg =~ s/\260[^\260]*\260//g;
256
257	root	1.2	print "($room) $src >> $msg\n";
258	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
259	root	1.2
260	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
261
262	root	1.21	my $reply = gen_reply $msg;
263
264	root	1.11	push @$seed, $msg;
265	root	1.15	seed_msg $msg;
266	elmex	1.1
267	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
268	root	1.18	$next_time{$src} = time + $delay;
269	root	1.9
270	root	1.8	print "($room) $src << $reply ($delay)\n";
271	elmex	1.1
272	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
273	root	1.2	push @queue, [$src, $room, $reply];
274			});
275	elmex	1.1	});
276
277			Event::loop;
278	root	1.7