[ViewVC] Contents 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 => 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 (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 {
   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;

   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.49
Committed:	Mon Jan 31 05:38:56 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.48:	+1 -1 lines
Log Message:	* empty log message *
#	Content
1	#!/opt/bin/perl
2
3	use strict;
4
5	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	use Socket;
98	use IO::Socket::INET;
99
100	use YAML;
101	use Encode;
102	use Event;
103	use Net::Knuddels;
104	use List::Util;
105	use Time::HiRes;
106
107	my @CHANNELS = (
108	'Flirt',
109	'Flirt Private',
110	'Singles 11-14',
111	'Singles 15-17',
112
113	'Singles 11-14 2',
114	'Singles 15-17 2',
115	'Flirt 2',
116	'Flirt Private 2',
117	'Singles 11-14 3',
118	'Singles 15-17 3',
119	'Flirt 3',
120	'Flirt Private 3',
121	'Singles 11-14 4',
122	'Singles 15-17 4',
123	'Flirt 4',
124	'Flirt Private 4',
125	'Singles 11-14 5',
126	'Singles 15-17 5',
127	'Flirt 5',
128	'Flirt Private 5',
129	'Singles 11-14 6',
130	'Singles 15-17 6',
131	'Flirt 6',
132	'Flirt Private 6',
133	'Singles 11-14 7',
134	'Singles 15-17 7',
135	'Flirt 7',
136	'Flirt Private 7',
137	'Singles 11-14 8',
138	'Singles 15-17 8',
139	'Flirt 8',
140	'Flirt Private 8',
141	);
142
143	my $logdir = "logs";
144
145	my $Knick = "ich bin suess";
146	my $Kpass = "qwerty";
147
148	my $client;
149
150	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
151	$seed \|\|= [];
152
153	my $fwd = new markov longest => 2;
154	my $rev = new markov longest => 2;
155
156	my %freq;
157	my $word_cnt;
158
159	sub word {
160	$_[0] =~ /(\w+)/ ? lc $1 : ();
161	}
162
163	sub seed_msg {
164	my $msg = $_[0];
165
166	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
167	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
168	\|knallen\|schlecken
169	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
170	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
171	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
172	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
173	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
174	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
175	\|zieh.*aus\|nackt\|geile\|feucht\|willig
176	\|sätz\|saetz\|setze\|\bsatz
177	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
178	\|admin\|nachgeburt
179	\|(?-i:[A-Z]{4,})
180	\|\S{20,}
181	/xi;
182
183	my @msg = $msg =~ m/(\S+)/g;
184	#my @msg = split /\b/, $msg;
185
186	$freq{word $_}++ for @msg;
187	$word_cnt += @msg;
188
189	$fwd->seed (\@msg);
190	$rev->seed ([reverse @msg]);
191	}
192
193	for (@$seed) {
194	seed_msg $_;
195	}
196
197	my %grammar_reply = qw(
198	ich du
199	du ich
200	mir dir
201	dir mir
202	mein dein
203	dein mein
204	deine meine
205	meine deine
206	deiner meiner
207	meiner deiner
208	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	bye bye
218	ciao bye
219	);
220
221	sub gen_reply {
222	my ($msg) = @_;
223
224	my @msg = $msg =~ /(\S+)/g;
225
226	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 = (("") x 10, @key, map {
237	my $word = word $_;
238
239	$grammar_reply{$word} \|\| ()
240	} @msg);
241
242	my $reply;
243	my $best = -1;
244	my $idx;
245
246	for (1..200) {
247	my $prob = {};
248
249	my @r = $rev->complete (
250	[reverse $fwd->complete (
251	[
252	# $srch[++$idx % @srch]
253	],
254	$prob
255	) ], $prob
256	);
257
258	# 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
263	$b = @r ** 0.2 * 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	}
269
270	$reply;
271	}
272
273	while ($ENV{DEBUG}) {
274	my $r = gen_reply scalar <>;
275	print "$r\n\n";
276	}
277
278	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
279
280	Event->timer (interval => 60, cb => sub {
281	open my $fh, ">", "markovbot.dat~"
282	or return;
283	binmode $fh;
284	print $fh Encode::encode_utf8 Dump $seed;
285	close $fh;
286	rename "markovbot.dat~", "markovbot.dat";
287	});
288
289	sub logit {
290	my ($msg, $file, $src, $dst, $room) = @_;
291
292	mkdir $logdir;
293	my $fh;
294
295	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
296	warn "Couldn't open for appending $logdir/$src: $!\n";
297	return;
298	}
299
300	print $fh "$room\t$src\t$dst\t$msg\n";
301	}
302
303	####################################################################################
304	########################## MAIN START ##############################################
305	####################################################################################
306
307	$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
324	$client->register (dialog => sub {
325	use Dumpvalue;
326	print "---\n";
327	Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
328	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
329	});
330
331	$client->register (login => sub {
332	Event->timer (after => 0, interval => 3, cb => sub {
333	$client->enter_room (shift @CHANNELS, $Knick, $Kpass);
334	});
335	});
336
337	$client->register (msg_room => sub {
338	my ($room, $user, $msg) = @_;
339	});
340
341	my @queue;
342
343	Event->timer (interval => 1, cb => sub {
344	my $msg = shift @queue
345	or return;
346
347	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
348	$client->send_priv_msg (@$msg);
349	});
350
351	my $some_room;
352
353	$client->register (room_info => sub {
354	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	});
361
362	my %next_time;
363
364	$client->register (msg_priv_nondup => sub {
365	my ($room, $src, $dst, $msg) = @_;
366
367	my $NOW = Time::HiRes::time;
368
369	$msg =~ s/\260[^\260]*\260//g;
370
371	print "($room) $src >> $msg\n";
372	logit ($msg, $src, $src, $dst, $room);
373
374	return if $next_time{$src} > time; # do not talk unnaturally often
375
376	my $reply = gen_reply $msg;
377
378	push @$seed, $msg;
379	seed_msg $msg;
380
381	my $delay = 2 + 30 * (rand) ** 5 + 0.2 * length $reply;
382	$next_time{$src} = time + $delay;
383
384	print "($room) $src << $reply ($delay)\n";
385
386	Event->timer (at => $NOW + $delay, cb => sub {
387	push @queue, [$src, $room, $reply];
388	});
389	});
390
391	Event::loop;
392