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

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 = ("", @key, map {
      my $word = word $_;
      
      $grammar_reply{$word} || ()
   } @msg);

   my $reply;
   my $best = 2;
   my $idx;

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

      my @r = $rev->complete (
                 [reverse $fwd->complete (
                    [@srch ? $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 = rand 1;

      ($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.45
Committed:	Mon Jan 31 04:22:20 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.44:	+8 -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.45	my $fwd = new markov longest => 3;
154			my $rev = new markov longest => 3;
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			my @srch = ("", @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.23	my $best = 2;
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			[@srch ? $srch[++$idx % @srch] : ()],
252			$prob
253			) ], $prob
254			);
255
256	root	1.45	# my $b = (rand 0.02 / (@r + 1))
257			# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
258			#
259			# $b += 0.2 if @r < 3;
260			$b = rand 1;
261	root	1.15
262	root	1.44	($reply, $best) = ((join " ", reverse @r), $b) if $b < $best;
263	root	1.15	}
264
265			$reply;
266	root	1.11	}
267
268	root	1.43	while ($ENV{DEBUG}) {
269	root	1.23	my $r = gen_reply scalar <>;
270			print "$r\n\n";
271			}
272
273	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
274	root	1.2
275	root	1.8	Event->timer (interval => 60, cb => sub {
276	root	1.11	open my $fh, ">", "markovbot.dat~"
277	root	1.2	or return;
278	root	1.30	binmode $fh;
279	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
280			close $fh;
281	root	1.11	rename "markovbot.dat~", "markovbot.dat";
282	root	1.2	});
283
284	elmex	1.4	sub logit {
285	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
286	elmex	1.4
287	root	1.12	mkdir $logdir;
288			my $fh;
289	elmex	1.4
290	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
291	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
292			return;
293			}
294
295	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
296	elmex	1.4	}
297
298	elmex	1.1	####################################################################################
299			########################## MAIN START ##############################################
300			####################################################################################
301
302	root	1.23	$client = new Net::Knuddels::Client
303			PeerAddr => "213.61.5.150:2710",
304			command_wait => sub {
305			my ($client, $wait) = @_;
306			Event->timer (after => $wait, cb => sub { $client->command_cb });
307			};
308
309			Event->io (
310			fd => $client->fh,
311			poll => 'r',
312			cb => sub {
313			$client->ready
314			or $_[0]->w->cancel;
315			});
316
317			$client->login;
318	elmex	1.1
319	root	1.31	$client->register (dialog => sub {
320			use Dumpvalue;
321			print "---\n";
322			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
323	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
324	root	1.31	});
325	root	1.7
326	elmex	1.1	$client->register (login => sub {
327	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
328			for @CHANNELS;
329	elmex	1.1	});
330
331			$client->register (msg_room => sub {
332			my ($room, $user, $msg) = @_;
333	root	1.2	});
334
335			my @queue;
336
337			Event->timer (interval => 1, cb => sub {
338			my $msg = shift @queue
339			or return;
340
341	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
342	root	1.2	$client->send_priv_msg (@$msg);
343	elmex	1.1	});
344
345	root	1.20	my $some_room;
346
347	root	1.17	$client->register (room_info => sub {
348	root	1.20	print "JOIN ROOM: $_[0]\n";
349			$some_room = $_[0];
350			});
351
352			Event->timer (after => 60, interval => 60, cb => sub {
353			$client->send_priv_msg ("James", $some_room, "/knuschel");
354	elmex	1.16	});
355	root	1.17
356	root	1.18	my %next_time;
357
358	elmex	1.16	$client->register (msg_priv_nondup => sub {
359	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
360
361	root	1.27	my $NOW = Time::HiRes::time;
362
363	root	1.7	$msg =~ s/\260[^\260]*\260//g;
364
365	root	1.2	print "($room) $src >> $msg\n";
366	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
367	root	1.2
368	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
369
370	root	1.21	my $reply = gen_reply $msg;
371
372	root	1.11	push @$seed, $msg;
373	root	1.15	seed_msg $msg;
374	elmex	1.1
375	root	1.45	my $delay = 2 + 30 * (rand) ** 5 + 0.3 * length $reply;
376	root	1.18	$next_time{$src} = time + $delay;
377	root	1.9
378	root	1.8	print "($room) $src << $reply ($delay)\n";
379	elmex	1.1
380	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
381	root	1.2	push @queue, [$src, $room, $reply];
382			});
383	elmex	1.1	});
384
385			Event::loop;
386	root	1.7