[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 = ("", @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;

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

   $reply;
}

while (1) {
   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.42
Committed:	Mon Jan 31 03:26:41 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.41:	+5 -5 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.40	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.40	#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.42	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	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.42	while (1) {
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