[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 Algorithm::MarkovChain;
use String::Similarity;
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 = ("", @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.01 / (@r + 1))
            + (@key ? (List::Util::sum map $prob->{$_}, @key) / @key : 0);

      ($reply, $best) = ((join "", reverse @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;
   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 = 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.41
Committed:	Mon Jan 31 03:07:36 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.40:	+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.2	use Algorithm::MarkovChain;
105	root	1.15	use String::Similarity;
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.11	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
153	root	1.2	$seed \|\|= [];
154
155	root	1.40	my $fwd = new markov longest => 4;
156			my $rev = new markov longest => 4;
157	root	1.23
158			my %freq;
159			my $word_cnt;
160
161			sub word {
162			$_[0] =~ /(\w+)/ ? lc $1 : ();
163			}
164	root	1.11
165			sub seed_msg {
166			my $msg = $_[0];
167	root	1.19
168	root	1.32	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
169	root	1.39	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
170			\|knallen\|schlecken
171	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
172	root	1.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
173	root	1.39	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
174	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
175	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
176	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
177	root	1.39	\|zieh.*aus\|nackt\|geile\|feucht\|willig
178	root	1.15	\|sätz\|saetz\|setze\|\bsatz
179	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
180			\|admin\|nachgeburt
181	root	1.15	\|(?-i:[A-Z]{4,})
182	root	1.23	\|\S{20,}
183	root	1.15	/xi;
184
185	root	1.40	#my @msg = $msg =~ m/(\S+)/g;
186			my @msg = split /\b/, $msg;
187	root	1.11
188	root	1.23	$freq{word $_}++ for @msg;
189			$word_cnt += @msg;
190
191	root	1.40	$fwd->seed (\@msg);
192			$rev->seed ([reverse @msg]);
193	root	1.11	}
194
195			for (@$seed) {
196			seed_msg $_;
197			}
198
199	root	1.23	my %grammar_reply = qw(
200			ich du
201			du ich
202			mir dir
203			dir mir
204			mein dein
205			dein mein
206	root	1.40	deine meine
207			meine deine
208			deiner meiner
209			meiner deiner
210	root	1.23	frau mann
211			mädel junge
212			mädchen junge
213			girls boys
214			boys girls
215			huhu hi
216			hi hi
217			hallo hi
218			typen mädels
219	root	1.33	bye bye
220			ciao bye
221	root	1.23	);
222
223	root	1.11	sub gen_reply {
224			my ($msg) = @_;
225
226	root	1.23	my @msg = $msg =~ /(\S+)/g;
227
228	root	1.40	my @key = map {
229			my $word = word $_;
230
231			$freq{$word} < $word_cnt * 0.0003
232			&& $freq{$word}
233			&& 2 <= length $word
234			? $word
235			: ()
236			} @msg;
237
238			my @srch = ("", @key, map {
239	root	1.23	my $word = word $_;
240
241	root	1.40	$grammar_reply{$word} \|\| ()
242			} @msg);
243	root	1.19
244	root	1.15	my $reply;
245	root	1.23	my $best = 2;
246	root	1.40	my $idx;
247
248			for (1..200) {
249			my $prob = {};
250
251			my @r = $rev->complete (
252			[reverse $fwd->complete (
253			[@srch ? $srch[++$idx % @srch] : ()],
254			$prob
255			) ], $prob
256			);
257
258			my $b = (rand 0.01 / (@r + 1))
259			+ (@key ? (List::Util::sum map $prob->{$_}, @key) / @key : 0);
260	root	1.15
261	root	1.40	($reply, $best) = ((join "", reverse @r), $b) if $b < $best;
262	root	1.15	}
263
264			$reply;
265	root	1.11	}
266
267	root	1.41	while (0) {
268	root	1.23	my $r = gen_reply scalar <>;
269			print "$r\n\n";
270			}
271
272	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
273	root	1.2
274	root	1.8	Event->timer (interval => 60, cb => sub {
275	root	1.11	open my $fh, ">", "markovbot.dat~"
276	root	1.2	or return;
277	root	1.30	binmode $fh;
278	root	1.2	print $fh Encode::encode_utf8 Dump $seed;
279			close $fh;
280	root	1.11	rename "markovbot.dat~", "markovbot.dat";
281	root	1.2	});
282
283	elmex	1.4	sub logit {
284	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
285	elmex	1.4
286	root	1.12	mkdir $logdir;
287			my $fh;
288	elmex	1.4
289	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
290	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
291			return;
292			}
293
294	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
295	elmex	1.4	}
296
297	elmex	1.1	####################################################################################
298			########################## MAIN START ##############################################
299			####################################################################################
300
301	root	1.23	$client = new Net::Knuddels::Client
302			PeerAddr => "213.61.5.150:2710",
303			command_wait => sub {
304			my ($client, $wait) = @_;
305			Event->timer (after => $wait, cb => sub { $client->command_cb });
306			};
307
308			Event->io (
309			fd => $client->fh,
310			poll => 'r',
311			cb => sub {
312			$client->ready
313			or $_[0]->w->cancel;
314			});
315
316			$client->login;
317	elmex	1.1
318	root	1.31	$client->register (dialog => sub {
319			use Dumpvalue;
320			print "---\n";
321			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
322	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
323	root	1.31	});
324	root	1.7
325	elmex	1.1	$client->register (login => sub {
326	root	1.23	$client->enter_room ($_, $Knick, $Kpass)
327			for @CHANNELS;
328	elmex	1.1	});
329
330			$client->register (msg_room => sub {
331			my ($room, $user, $msg) = @_;
332	root	1.2	});
333
334			my @queue;
335
336			Event->timer (interval => 1, cb => sub {
337			my $msg = shift @queue
338			or return;
339
340	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
341	root	1.2	$client->send_priv_msg (@$msg);
342	elmex	1.1	});
343
344	root	1.20	my $some_room;
345
346	root	1.17	$client->register (room_info => sub {
347	root	1.20	print "JOIN ROOM: $_[0]\n";
348			$some_room = $_[0];
349			});
350
351			Event->timer (after => 60, interval => 60, cb => sub {
352			$client->send_priv_msg ("James", $some_room, "/knuschel");
353	elmex	1.16	});
354	root	1.17
355	root	1.18	my %next_time;
356
357	elmex	1.16	$client->register (msg_priv_nondup => sub {
358	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
359
360	root	1.27	my $NOW = Time::HiRes::time;
361
362	root	1.7	$msg =~ s/\260[^\260]*\260//g;
363
364	root	1.2	print "($room) $src >> $msg\n";
365	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
366	root	1.2
367	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
368
369	root	1.21	my $reply = gen_reply $msg;
370
371	root	1.11	push @$seed, $msg;
372	root	1.15	seed_msg $msg;
373	elmex	1.1
374	root	1.22	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
375	root	1.18	$next_time{$src} = time + $delay;
376	root	1.9
377	root	1.8	print "($room) $src << $reply ($delay)\n";
378	elmex	1.1
379	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
380	root	1.2	push @queue, [$src, $room, $reply];
381			});
382	elmex	1.1	});
383
384			Event::loop;
385	root	1.7