[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 => 4;
my $rev = new markov longest => 4;

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 * 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 {
   $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 = 2 + 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.46
Committed:	Mon Jan 31 04:55:51 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.45:	+12 -7 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.46	my $fwd = new markov longest => 4;
154			my $rev = new markov longest => 4;
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.46	$b = @r * rand;
264
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.23	$client->enter_room ($_, $Knick, $Kpass)
333			for @CHANNELS;
334	elmex	1.1	});
335
336			$client->register (msg_room => sub {
337			my ($room, $user, $msg) = @_;
338	root	1.2	});
339
340			my @queue;
341
342			Event->timer (interval => 1, cb => sub {
343			my $msg = shift @queue
344			or return;
345
346	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
347	root	1.2	$client->send_priv_msg (@$msg);
348	elmex	1.1	});
349
350	root	1.20	my $some_room;
351
352	root	1.17	$client->register (room_info => sub {
353	root	1.20	print "JOIN ROOM: $_[0]\n";
354			$some_room = $_[0];
355			});
356
357			Event->timer (after => 60, interval => 60, cb => sub {
358			$client->send_priv_msg ("James", $some_room, "/knuschel");
359	elmex	1.16	});
360	root	1.17
361	root	1.18	my %next_time;
362
363	elmex	1.16	$client->register (msg_priv_nondup => sub {
364	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
365
366	root	1.27	my $NOW = Time::HiRes::time;
367
368	root	1.7	$msg =~ s/\260[^\260]*\260//g;
369
370	root	1.2	print "($room) $src >> $msg\n";
371	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
372	root	1.2
373	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
374
375	root	1.21	my $reply = gen_reply $msg;
376
377	root	1.11	push @$seed, $msg;
378	root	1.15	seed_msg $msg;
379	elmex	1.1
380	root	1.45	my $delay = 2 + 30 * (rand) ** 5 + 0.3 * length $reply;
381	root	1.18	$next_time{$src} = time + $delay;
382	root	1.9
383	root	1.8	print "($room) $src << $reply ($delay)\n";
384	elmex	1.1
385	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
386	root	1.2	push @queue, [$src, $room, $reply];
387			});
388	elmex	1.1	});
389
390			Event::loop;
391	root	1.7