[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;
   s/ß/ss/g;
   y/a-z\000//cd;
   $_;
}

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 = [grep $_, split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];

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 (after => 60, interval => 60, cb => sub {
   open my $fh, ">:utf8", "markovbot.txt~"
      or return;
   print $fh join "\n", @$seed;
   close $fh;
   rename "markovbot.txt~", "markovbot.txt";
});

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;#d#

   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.50
Committed:	Tue Feb 1 00:47:33 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.49:	+8 -8 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	root	1.50	s/ß/ss/g;
23			y/a-z\000//cd;
24	root	1.40	$_;
25			}
26
27			sub seed {
28			my ($self, $symbols) = @_;
29
30			my @sym = (@$symbols, $self->{s_end});
31			my @seq = $self->{s_beg};
32			my $tree = $self->{tree};
33
34			while () {
35			my $next = shift @sym
36			or last;
37
38			shift @seq while @seq > $self->{longest};
39
40			for (1 .. @seq) {
41			my $node = $tree->{simplify join "\0", @seq[-$_ .. -1]} \|\|= {};
42			$node->{$next}++;
43			$node->{""}++;
44			}
45
46			push @seq, $next;
47			}
48			}
49
50			sub complete {
51			my ($self, $symbols, $prob) = @_;
52
53			my $tree = $self->{tree};
54			my @res;
55			my @sym = @$symbols;
56
57			# find starting sequence
58			shift @sym while @sym && !$tree->{simplify join "\0", @sym};
59
60			@res = @sym;
61			@sym = $self->{s_beg} unless @sym;
62
63			#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
64
65			outer:
66			while () {
67			my $node = $tree->{simplify join "\0", @sym};
68
69			if ($node) {
70			my $sel = rand $node->{""};
71			keys %$node;
72
73			while (my ($k, $v) = each %$node) {
74			if (length $k and ($sel -= $v) < 0) {
75			last outer if $k eq $self->{s_end};
76
77			push @sym, $k;
78			push @res, $k;
79
80			$prob->{$k} = $v / $node->{""};
81
82			next outer;
83			}
84			}
85
86			die "FATAL: internal error";
87			} else {
88			shift @sym;
89			@sym
90			or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
91			}
92			}
93
94			@res
95			}
96
97			package main;
98
99	elmex	1.1	use Socket;
100			use IO::Socket::INET;
101	root	1.2
102			use YAML;
103			use Encode;
104	elmex	1.1	use Event;
105			use Net::Knuddels;
106	root	1.23	use List::Util;
107	root	1.27	use Time::HiRes;
108	elmex	1.1
109			my @CHANNELS = (
110	elmex	1.3	'Flirt',
111	root	1.11	'Flirt Private',
112	root	1.10	'Singles 11-14',
113			'Singles 15-17',
114	root	1.11
115	root	1.18	'Singles 11-14 2',
116			'Singles 15-17 2',
117	root	1.11	'Flirt 2',
118	root	1.18	'Flirt Private 2',
119	root	1.11	'Singles 11-14 3',
120	root	1.18	'Singles 15-17 3',
121	root	1.11	'Flirt 3',
122	root	1.18	'Flirt Private 3',
123	root	1.11	'Singles 11-14 4',
124	root	1.18	'Singles 15-17 4',
125	root	1.11	'Flirt 4',
126	root	1.18	'Flirt Private 4',
127	root	1.11	'Singles 11-14 5',
128	root	1.18	'Singles 15-17 5',
129	root	1.11	'Flirt 5',
130	root	1.18	'Flirt Private 5',
131	root	1.11	'Singles 11-14 6',
132	root	1.18	'Singles 15-17 6',
133	root	1.11	'Flirt 6',
134	root	1.18	'Flirt Private 6',
135	root	1.11	'Singles 11-14 7',
136	root	1.18	'Singles 15-17 7',
137	root	1.11	'Flirt 7',
138	root	1.18	'Flirt Private 7',
139	root	1.11	'Singles 11-14 8',
140	root	1.18	'Singles 15-17 8',
141	root	1.11	'Flirt 8',
142	root	1.18	'Flirt Private 8',
143	elmex	1.1	);
144
145	root	1.14	my $logdir = "logs";
146	elmex	1.4
147	root	1.18	my $Knick = "ich bin suess";
148	root	1.15	my $Kpass = "qwerty";
149	elmex	1.1
150			my $client;
151
152	root	1.50	my $seed = [grep $_, split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];
153	root	1.2
154	root	1.48	my $fwd = new markov longest => 2;
155			my $rev = new markov longest => 2;
156	root	1.23
157			my %freq;
158			my $word_cnt;
159
160			sub word {
161			$_[0] =~ /(\w+)/ ? lc $1 : ();
162			}
163	root	1.11
164			sub seed_msg {
165			my $msg = $_[0];
166	root	1.19
167	root	1.32	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
168	root	1.39	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
169			\|knallen\|schlecken
170	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
171	root	1.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
172	root	1.39	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
173	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
174	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
175	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
176	root	1.39	\|zieh.*aus\|nackt\|geile\|feucht\|willig
177	root	1.15	\|sätz\|saetz\|setze\|\bsatz
178	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
179			\|admin\|nachgeburt
180	root	1.15	\|(?-i:[A-Z]{4,})
181	root	1.23	\|\S{20,}
182	root	1.15	/xi;
183
184	root	1.44	my @msg = $msg =~ m/(\S+)/g;
185			#my @msg = split /\b/, $msg;
186	root	1.11
187	root	1.23	$freq{word $_}++ for @msg;
188			$word_cnt += @msg;
189
190	root	1.40	$fwd->seed (\@msg);
191			$rev->seed ([reverse @msg]);
192	root	1.11	}
193
194			for (@$seed) {
195			seed_msg $_;
196			}
197
198	root	1.23	my %grammar_reply = qw(
199			ich du
200			du ich
201			mir dir
202			dir mir
203			mein dein
204			dein mein
205	root	1.40	deine meine
206			meine deine
207			deiner meiner
208			meiner deiner
209	root	1.23	frau mann
210			mädel junge
211			mädchen junge
212			girls boys
213			boys girls
214			huhu hi
215			hi hi
216			hallo hi
217			typen mädels
218	root	1.33	bye bye
219			ciao bye
220	root	1.23	);
221
222	root	1.11	sub gen_reply {
223			my ($msg) = @_;
224
225	root	1.23	my @msg = $msg =~ /(\S+)/g;
226
227	root	1.40	my @key = map {
228			my $word = word $_;
229
230			$freq{$word} < $word_cnt * 0.0003
231			&& $freq{$word}
232			&& 2 <= length $word
233			? $word
234			: ()
235			} @msg;
236
237	root	1.46	my @srch = (("") x 10, @key, map {
238	root	1.23	my $word = word $_;
239
240	root	1.40	$grammar_reply{$word} \|\| ()
241			} @msg);
242	root	1.19
243	root	1.15	my $reply;
244	root	1.46	my $best = -1;
245	root	1.40	my $idx;
246
247			for (1..200) {
248			my $prob = {};
249
250			my @r = $rev->complete (
251			[reverse $fwd->complete (
252	root	1.46	[
253			# $srch[++$idx % @srch]
254			],
255	root	1.40	$prob
256			) ], $prob
257			);
258
259	root	1.45	# my $b = (rand 0.02 / (@r + 1))
260			# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
261			#
262			# $b += 0.2 if @r < 3;
263	root	1.15
264	root	1.48	$b = @r ** 0.2 * rand;
265	root	1.46
266			#my $b = (List::Util::sum map $freq{word $_}, @r) / (@r ** 3 * $word_cnt);
267
268			($reply, $best) = ((join " ", reverse @r), $b) if $b > $best;
269	root	1.15	}
270
271			$reply;
272	root	1.11	}
273
274	root	1.43	while ($ENV{DEBUG}) {
275	root	1.23	my $r = gen_reply scalar <>;
276			print "$r\n\n";
277			}
278
279	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
280	root	1.2
281	root	1.50	Event->timer (after => 60, interval => 60, cb => sub {
282			open my $fh, ">:utf8", "markovbot.txt~"
283	root	1.2	or return;
284	root	1.50	print $fh join "\n", @$seed;
285	root	1.2	close $fh;
286	root	1.50	rename "markovbot.txt~", "markovbot.txt";
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.50	#seed_msg $msg;#d#
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