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

#!/usr/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;

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 $Knick = "baileysmaedl";
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|fikkn|bumsen|wichs|wix|popp|popen|fuck|dreck|laber|saugen|pussy
                     |\bblas|piss|schluck|fingern|spritz|\bloch
                     |hure|strich|sklave|handschell
                     |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 => 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
);

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..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;
   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 (ALL => 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) = @_;

   $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 (after => $delay, cb => sub {
      push @queue, [$src, $room, $reply];
   });
});

Event::loop;

Revision:	1.24
Committed:	Sun Jan 30 05:43:15 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.23:	+1 -1 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	elmex	1.1	#!/usr/bin/perl
2
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	elmex	1.1
16			my @CHANNELS = (
17	elmex	1.3	'Flirt',
18	root	1.11	'Flirt Private',
19	root	1.10	'Singles 11-14',
20			'Singles 15-17',
21	root	1.11
22	root	1.18	'Singles 11-14 2',
23			'Singles 15-17 2',
24	root	1.11	'Flirt 2',
25	root	1.18	'Flirt Private 2',
26	root	1.11	'Singles 11-14 3',
27	root	1.18	'Singles 15-17 3',
28	root	1.11	'Flirt 3',
29	root	1.18	'Flirt Private 3',
30	root	1.11	'Singles 11-14 4',
31	root	1.18	'Singles 15-17 4',
32	root	1.11	'Flirt 4',
33	root	1.18	'Flirt Private 4',
34	root	1.11	'Singles 11-14 5',
35	root	1.18	'Singles 15-17 5',
36	root	1.11	'Flirt 5',
37	root	1.18	'Flirt Private 5',
38	root	1.11	'Singles 11-14 6',
39	root	1.18	'Singles 15-17 6',
40	root	1.11	'Flirt 6',
41	root	1.18	'Flirt Private 6',
42	root	1.11	'Singles 11-14 7',
43	root	1.18	'Singles 15-17 7',
44	root	1.11	'Flirt 7',
45	root	1.18	'Flirt Private 7',
46	root	1.11	'Singles 11-14 8',
47	root	1.18	'Singles 15-17 8',
48	root	1.11	'Flirt 8',
49	root	1.18	'Flirt Private 8',
50	elmex	1.1	);
51
52	root	1.14	my $logdir = "logs";
53	elmex	1.4
54	root	1.18	my $Knick = "ich bin suess";
55	root	1.15	my $Kpass = "qwerty";
56	root	1.23	my $Knick = "baileysmaedl";
57			my $Kpass = "qwerty";
58	elmex	1.1
59			my $client;
60
61	root	1.11	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
62	root	1.2	$seed \|\|= [];
63
64	root	1.23	my $fwd = new Algorithm::MarkovChain;
65			my $rev = new Algorithm::MarkovChain;
66
67			my %freq;
68			my $word_cnt;
69
70			sub word {
71			$_[0] =~ /(\w+)/ ? lc $1 : ();
72			}
73	root	1.11
74			sub seed_msg {
75			my $msg = $_[0];
76	root	1.19
77	root	1.23	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|fikkn\|bumsen\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy
78			\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch
79	root	1.24	\|hure\|strich\|sklave\|handschell
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			$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			);
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.23	for (1..15) {
145			shift @msg if @msg > $_;
146			my $len = rand() ** 4 * 20 + 2;
147			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			print $fh Encode::encode_utf8 Dump $seed;
168			close $fh;
169	root	1.11	rename "markovbot.dat~", "markovbot.dat";
170	root	1.2	});
171
172	elmex	1.4	sub logit {
173	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
174	elmex	1.4
175	root	1.12	mkdir $logdir;
176			my $fh;
177	elmex	1.4
178	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
179	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
180			return;
181			}
182
183	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
184	elmex	1.4	}
185
186	elmex	1.1	####################################################################################
187			########################## MAIN START ##############################################
188			####################################################################################
189
190	root	1.23	$client = new Net::Knuddels::Client
191			PeerAddr => "213.61.5.150:2710",
192			command_wait => sub {
193			my ($client, $wait) = @_;
194			Event->timer (after => $wait, cb => sub { $client->command_cb });
195			};
196
197			Event->io (
198			fd => $client->fh,
199			poll => 'r',
200			cb => sub {
201			$client->ready
202			or $_[0]->w->cancel;
203			});
204
205			$client->login;
206	elmex	1.1
207	root	1.11	#$client->register (ALL => sub {
208	root	1.7	# use Dumpvalue;
209			# print "---\n";
210			# Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
211			#});
212
213	elmex	1.1	$client->register (login => sub {
214	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
215			for @CHANNELS;
216	elmex	1.1	});
217
218			$client->register (msg_room => sub {
219			my ($room, $user, $msg) = @_;
220	root	1.2	});
221
222			my @queue;
223
224			Event->timer (interval => 1, cb => sub {
225			my $msg = shift @queue
226			or return;
227
228	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
229	root	1.2	$client->send_priv_msg (@$msg);
230	elmex	1.1	});
231
232	root	1.20	my $some_room;
233
234	root	1.17	$client->register (room_info => sub {
235	root	1.20	print "JOIN ROOM: $_[0]\n";
236			$some_room = $_[0];
237			});
238
239			Event->timer (after => 60, interval => 60, cb => sub {
240			$client->send_priv_msg ("James", $some_room, "/knuschel");
241	elmex	1.16	});
242	root	1.17
243	root	1.18	my %next_time;
244
245	elmex	1.16	$client->register (msg_priv_nondup => sub {
246	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
247
248	root	1.7	$msg =~ s/\260[^\260]*\260//g;
249
250	root	1.2	print "($room) $src >> $msg\n";
251	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
252	root	1.2
253	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
254
255	root	1.21	my $reply = gen_reply $msg;
256
257	root	1.11	push @$seed, $msg;
258	root	1.15	seed_msg $msg;
259	elmex	1.1
260	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
261	root	1.18	$next_time{$src} = time + $delay;
262	root	1.9
263	root	1.8	print "($room) $src << $reply ($delay)\n";
264	elmex	1.1
265	root	1.2	Event->timer (after => $delay, cb => sub {
266			push @queue, [$src, $room, $reply];
267			});
268	elmex	1.1	});
269
270			Event::loop;
271	root	1.7