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

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