[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|\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 => 14);
   $rev->seed (symbols => [reverse @msg], longest => 14);
}

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..15) {
      shift @msg if @msg > $_;
      my $len = rand() ** 4 * 20 + 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.33
Committed:	Sun Jan 30 14:07:27 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.32:	+8 -6 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.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.33	$fwd->seed (symbols => \@msg, longest => 14);
98			$rev->seed (symbols => [reverse @msg], longest => 14);
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.33	for (1..15) {
147	root	1.23	shift @msg if @msg > $_;
148	root	1.33	my $len = rand() ** 4 * 20 + 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			});
215	root	1.7
216	elmex	1.1	$client->register (login => sub {
217	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
218			for @CHANNELS;
219	elmex	1.1	});
220
221			$client->register (msg_room => sub {
222			my ($room, $user, $msg) = @_;
223	root	1.2	});
224
225			my @queue;
226
227			Event->timer (interval => 1, cb => sub {
228			my $msg = shift @queue
229			or return;
230
231	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
232	root	1.2	$client->send_priv_msg (@$msg);
233	elmex	1.1	});
234
235	root	1.20	my $some_room;
236
237	root	1.17	$client->register (room_info => sub {
238	root	1.20	print "JOIN ROOM: $_[0]\n";
239			$some_room = $_[0];
240			});
241
242			Event->timer (after => 60, interval => 60, cb => sub {
243			$client->send_priv_msg ("James", $some_room, "/knuschel");
244	elmex	1.16	});
245	root	1.17
246	root	1.18	my %next_time;
247
248	elmex	1.16	$client->register (msg_priv_nondup => sub {
249	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
250
251	root	1.27	my $NOW = Time::HiRes::time;
252
253	root	1.7	$msg =~ s/\260[^\260]*\260//g;
254
255	root	1.2	print "($room) $src >> $msg\n";
256	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
257	root	1.2
258	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
259
260	root	1.21	my $reply = gen_reply $msg;
261
262	root	1.11	push @$seed, $msg;
263	root	1.15	seed_msg $msg;
264	elmex	1.1
265	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
266	root	1.18	$next_time{$src} = time + $delay;
267	root	1.9
268	root	1.8	print "($room) $src << $reply ($delay)\n";
269	elmex	1.1
270	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
271	root	1.2	push @queue, [$src, $room, $reply];
272			});
273	elmex	1.1	});
274
275			Event::loop;
276	root	1.7