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

#!/opt/bin/perl

use strict;

package markov;

sub new {
   my ($class, @arg) = @_;
   
   bless {
      longest => 10,
      s_beg   => [], # arbitarry "unique" start symbol
      s_end   => [], # arbitrary "unique" end symbol
      tree    => {},
      @arg,
   }, $class;
}

sub simplify {
   local $_ = lc shift;
   y/aeiouüöä//d;
   $_;
}

sub seed {
   my ($self, $symbols) = @_;

   my @sym = (@$symbols, $self->{s_end});
   my @seq = $self->{s_beg};
   my $tree = $self->{tree};

   while () {
      my $next = shift @sym
         or last;

      shift @seq while @seq > $self->{longest};

      for (1 .. @seq) {
         my $node = $tree->{simplify join "\0", @seq[-$_ .. -1]} ||= {};
         $node->{$next}++;
         $node->{""}++;
      }

      push @seq, $next;
   }
}

sub complete {
   my ($self, $symbols, $prob) = @_;

   my $tree = $self->{tree};
   my @res;
   my @sym = @$symbols;

   # find starting sequence
   shift @sym while @sym && !$tree->{simplify join "\0", @sym};

   @res = @sym;
   @sym = $self->{s_beg} unless @sym;

   #use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);

   outer:
   while () {
      my $node = $tree->{simplify join "\0", @sym};

      if ($node) {
         my $sel = rand $node->{""};
         keys %$node;

         while (my ($k, $v) = each %$node) {
            if (length $k and ($sel -= $v) < 0) {
               last outer if $k eq $self->{s_end};

               push @sym, $k;
               push @res, $k;

               $prob->{$k} = $v / $node->{""};

               next outer;
            }
         }

         die "FATAL: internal error";
      } else {
         shift @sym;
         @sym
            or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
      }
   }

   @res
}

package main;

use Socket;
use IO::Socket::INET;

use YAML;
use Encode;
use Event;
use Net::Knuddels;
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 markov longest => 2;
my $rev = new markov longest => 2;

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;
   #my @msg = split /\b/, $msg;

   $freq{word $_}++ for @msg;
   $word_cnt += @msg;

   $fwd->seed (\@msg);
   $rev->seed ([reverse @msg]);
}

for (@$seed) {
   seed_msg $_;
}

my %grammar_reply = qw(
   ich  du
   du   ich
   mir  dir
   dir  mir
   mein dein
   dein mein
   deine meine
   meine deine
   deiner meiner
   meiner deiner
   frau mann
   mädel junge
   mädchen junge
   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;

   my @key = map {
      my $word = word $_;

      $freq{$word} < $word_cnt * 0.0003
         && $freq{$word}
         && 2 <= length $word
         ? $word
         : ()
   } @msg;

   my @srch = (("") x 10, @key, map {
      my $word = word $_;
      
      $grammar_reply{$word} || ()
   } @msg);

   my $reply;
   my $best = -1;
   my $idx;

   for (1..200) {
      my $prob = {};

      my @r = $rev->complete (
                 [reverse $fwd->complete (
                    [
                    # $srch[++$idx % @srch]
                    ],
                    $prob
                 ) ], $prob
              );

#      my $b = (rand 0.02 / (@r + 1))
#            + (@key ? (List::Util::sum map $prob->{$_} || 1, @key) / @key : 0);
#
#      $b += 0.2 if @r < 3;

      $b = @r ** 0.2 * rand;

      #my $b = (List::Util::sum map $freq{word $_}, @r) / (@r ** 3 * $word_cnt);

      ($reply, $best) = ((join " ", reverse @r), $b) if $b > $best;
   }

   $reply;
}

while ($ENV{DEBUG}) {
   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 {
   Event->timer (after => 0, interval => 3, cb => sub {
      $client->enter_room (shift @CHANNELS, $Knick, $Kpass);
   });
});

$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 = 2 + 30 * (rand) ** 5 + 0.2 * 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.49
Committed:	Mon Jan 31 05:38:56 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.48:	+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	root	1.40	package markov;
6
7			sub new {
8			my ($class, @arg) = @_;
9
10			bless {
11			longest => 10,
12			s_beg => [], # arbitarry "unique" start symbol
13			s_end => [], # arbitrary "unique" end symbol
14			tree => {},
15			@arg,
16			}, $class;
17			}
18
19			sub simplify {
20			local $_ = lc shift;
21			y/aeiouüöä//d;
22			$_;
23			}
24
25			sub seed {
26			my ($self, $symbols) = @_;
27
28			my @sym = (@$symbols, $self->{s_end});
29			my @seq = $self->{s_beg};
30			my $tree = $self->{tree};
31
32			while () {
33			my $next = shift @sym
34			or last;
35
36			shift @seq while @seq > $self->{longest};
37
38			for (1 .. @seq) {
39			my $node = $tree->{simplify join "\0", @seq[-$_ .. -1]} \|\|= {};
40			$node->{$next}++;
41			$node->{""}++;
42			}
43
44			push @seq, $next;
45			}
46			}
47
48			sub complete {
49			my ($self, $symbols, $prob) = @_;
50
51			my $tree = $self->{tree};
52			my @res;
53			my @sym = @$symbols;
54
55			# find starting sequence
56			shift @sym while @sym && !$tree->{simplify join "\0", @sym};
57
58			@res = @sym;
59			@sym = $self->{s_beg} unless @sym;
60
61			#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
62
63			outer:
64			while () {
65			my $node = $tree->{simplify join "\0", @sym};
66
67			if ($node) {
68			my $sel = rand $node->{""};
69			keys %$node;
70
71			while (my ($k, $v) = each %$node) {
72			if (length $k and ($sel -= $v) < 0) {
73			last outer if $k eq $self->{s_end};
74
75			push @sym, $k;
76			push @res, $k;
77
78			$prob->{$k} = $v / $node->{""};
79
80			next outer;
81			}
82			}
83
84			die "FATAL: internal error";
85			} else {
86			shift @sym;
87			@sym
88			or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
89			}
90			}
91
92			@res
93			}
94
95			package main;
96
97	elmex	1.1	use Socket;
98			use IO::Socket::INET;
99	root	1.2
100			use YAML;
101			use Encode;
102	elmex	1.1	use Event;
103			use Net::Knuddels;
104	root	1.23	use List::Util;
105	root	1.27	use Time::HiRes;
106	elmex	1.1
107			my @CHANNELS = (
108	elmex	1.3	'Flirt',
109	root	1.11	'Flirt Private',
110	root	1.10	'Singles 11-14',
111			'Singles 15-17',
112	root	1.11
113	root	1.18	'Singles 11-14 2',
114			'Singles 15-17 2',
115	root	1.11	'Flirt 2',
116	root	1.18	'Flirt Private 2',
117	root	1.11	'Singles 11-14 3',
118	root	1.18	'Singles 15-17 3',
119	root	1.11	'Flirt 3',
120	root	1.18	'Flirt Private 3',
121	root	1.11	'Singles 11-14 4',
122	root	1.18	'Singles 15-17 4',
123	root	1.11	'Flirt 4',
124	root	1.18	'Flirt Private 4',
125	root	1.11	'Singles 11-14 5',
126	root	1.18	'Singles 15-17 5',
127	root	1.11	'Flirt 5',
128	root	1.18	'Flirt Private 5',
129	root	1.11	'Singles 11-14 6',
130	root	1.18	'Singles 15-17 6',
131	root	1.11	'Flirt 6',
132	root	1.18	'Flirt Private 6',
133	root	1.11	'Singles 11-14 7',
134	root	1.18	'Singles 15-17 7',
135	root	1.11	'Flirt 7',
136	root	1.18	'Flirt Private 7',
137	root	1.11	'Singles 11-14 8',
138	root	1.18	'Singles 15-17 8',
139	root	1.11	'Flirt 8',
140	root	1.18	'Flirt Private 8',
141	elmex	1.1	);
142
143	root	1.14	my $logdir = "logs";
144	elmex	1.4
145	root	1.18	my $Knick = "ich bin suess";
146	root	1.15	my $Kpass = "qwerty";
147	elmex	1.1
148			my $client;
149
150	root	1.11	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
151	root	1.2	$seed \|\|= [];
152
153	root	1.48	my $fwd = new markov longest => 2;
154			my $rev = new markov longest => 2;
155	root	1.23
156			my %freq;
157			my $word_cnt;
158
159			sub word {
160			$_[0] =~ /(\w+)/ ? lc $1 : ();
161			}
162	root	1.11
163			sub seed_msg {
164			my $msg = $_[0];
165	root	1.19
166	root	1.32	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
167	root	1.39	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
168			\|knallen\|schlecken
169	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
170	root	1.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
171	root	1.39	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
172	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
173	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
174	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
175	root	1.39	\|zieh.*aus\|nackt\|geile\|feucht\|willig
176	root	1.15	\|sätz\|saetz\|setze\|\bsatz
177	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
178			\|admin\|nachgeburt
179	root	1.15	\|(?-i:[A-Z]{4,})
180	root	1.23	\|\S{20,}
181	root	1.15	/xi;
182
183	root	1.44	my @msg = $msg =~ m/(\S+)/g;
184			#my @msg = split /\b/, $msg;
185	root	1.11
186	root	1.23	$freq{word $_}++ for @msg;
187			$word_cnt += @msg;
188
189	root	1.40	$fwd->seed (\@msg);
190			$rev->seed ([reverse @msg]);
191	root	1.11	}
192
193			for (@$seed) {
194			seed_msg $_;
195			}
196
197	root	1.23	my %grammar_reply = qw(
198			ich du
199			du ich
200			mir dir
201			dir mir
202			mein dein
203			dein mein
204	root	1.40	deine meine
205			meine deine
206			deiner meiner
207			meiner deiner
208	root	1.23	frau mann
209			mädel junge
210			mädchen junge
211			girls boys
212			boys girls
213			huhu hi
214			hi hi
215			hallo hi
216			typen mädels
217	root	1.33	bye bye
218			ciao bye
219	root	1.23	);
220
221	root	1.11	sub gen_reply {
222			my ($msg) = @_;
223
224	root	1.23	my @msg = $msg =~ /(\S+)/g;
225
226	root	1.40	my @key = map {
227			my $word = word $_;
228
229			$freq{$word} < $word_cnt * 0.0003
230			&& $freq{$word}
231			&& 2 <= length $word
232			? $word
233			: ()
234			} @msg;
235
236	root	1.46	my @srch = (("") x 10, @key, map {
237	root	1.23	my $word = word $_;
238
239	root	1.40	$grammar_reply{$word} \|\| ()
240			} @msg);
241	root	1.19
242	root	1.15	my $reply;
243	root	1.46	my $best = -1;
244	root	1.40	my $idx;
245
246			for (1..200) {
247			my $prob = {};
248
249			my @r = $rev->complete (
250			[reverse $fwd->complete (
251	root	1.46	[
252			# $srch[++$idx % @srch]
253			],
254	root	1.40	$prob
255			) ], $prob
256			);
257
258	root	1.45	# my $b = (rand 0.02 / (@r + 1))
259			# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
260			#
261			# $b += 0.2 if @r < 3;
262	root	1.15
263	root	1.48	$b = @r ** 0.2 * rand;
264	root	1.46
265			#my $b = (List::Util::sum map $freq{word $_}, @r) / (@r ** 3 * $word_cnt);
266
267			($reply, $best) = ((join " ", reverse @r), $b) if $b > $best;
268	root	1.15	}
269
270			$reply;
271	root	1.11	}
272
273	root	1.43	while ($ENV{DEBUG}) {
274	root	1.23	my $r = gen_reply scalar <>;
275			print "$r\n\n";
276			}
277
278	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
279	root	1.2
280	root	1.8	Event->timer (interval => 60, cb => sub {
281	root	1.11	open my $fh, ">", "markovbot.dat~"
282	root	1.2	or return;
283	root	1.30	binmode $fh;
284	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
285			close $fh;
286	root	1.11	rename "markovbot.dat~", "markovbot.dat";
287	root	1.2	});
288
289	elmex	1.4	sub logit {
290	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
291	elmex	1.4
292	root	1.12	mkdir $logdir;
293			my $fh;
294	elmex	1.4
295	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
296	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
297			return;
298			}
299
300	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
301	elmex	1.4	}
302
303	elmex	1.1	####################################################################################
304			########################## MAIN START ##############################################
305			####################################################################################
306
307	root	1.23	$client = new Net::Knuddels::Client
308			PeerAddr => "213.61.5.150:2710",
309			command_wait => sub {
310			my ($client, $wait) = @_;
311			Event->timer (after => $wait, cb => sub { $client->command_cb });
312			};
313
314			Event->io (
315			fd => $client->fh,
316			poll => 'r',
317			cb => sub {
318			$client->ready
319			or $_[0]->w->cancel;
320			});
321
322			$client->login;
323	elmex	1.1
324	root	1.31	$client->register (dialog => sub {
325			use Dumpvalue;
326			print "---\n";
327			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
328	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
329	root	1.31	});
330	root	1.7
331	elmex	1.1	$client->register (login => sub {
332	root	1.47	Event->timer (after => 0, interval => 3, cb => sub {
333	root	1.48	$client->enter_room (shift @CHANNELS, $Knick, $Kpass);
334	root	1.47	});
335	elmex	1.1	});
336
337			$client->register (msg_room => sub {
338			my ($room, $user, $msg) = @_;
339	root	1.2	});
340
341			my @queue;
342
343			Event->timer (interval => 1, cb => sub {
344			my $msg = shift @queue
345			or return;
346
347	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
348	root	1.2	$client->send_priv_msg (@$msg);
349	elmex	1.1	});
350
351	root	1.20	my $some_room;
352
353	root	1.17	$client->register (room_info => sub {
354	root	1.20	print "JOIN ROOM: $_[0]\n";
355			$some_room = $_[0];
356			});
357
358			Event->timer (after => 60, interval => 60, cb => sub {
359			$client->send_priv_msg ("James", $some_room, "/knuschel");
360	elmex	1.16	});
361	root	1.17
362	root	1.18	my %next_time;
363
364	elmex	1.16	$client->register (msg_priv_nondup => sub {
365	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
366
367	root	1.27	my $NOW = Time::HiRes::time;
368
369	root	1.7	$msg =~ s/\260[^\260]*\260//g;
370
371	root	1.2	print "($room) $src >> $msg\n";
372	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
373	root	1.2
374	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
375
376	root	1.21	my $reply = gen_reply $msg;
377
378	root	1.11	push @$seed, $msg;
379	root	1.15	seed_msg $msg;
380	elmex	1.1
381	root	1.49	my $delay = 2 + 30 * (rand) ** 5 + 0.2 * length $reply;
382	root	1.18	$next_time{$src} = time + $delay;
383	root	1.9
384	root	1.8	print "($room) $src << $reply ($delay)\n";
385	elmex	1.1
386	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
387	root	1.2	push @queue, [$src, $room, $reply];
388			});
389	elmex	1.1	});
390
391			Event::loop;
392	root	1.7