[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];

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