[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;
   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 @sym = @$symbols;
   my @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 = $ARGV[0];
my $Kpass = $ARGV[1];

my $client;

my $seed = [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) {
   last if /^$/;
   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.003
         && $freq{$word}
         && 2 <= length $word
         ? $word
         : ()
   } @msg;

   my @srch = (("") x 5, @key, map {
      my $word = word $_;
      
      $grammar_reply{$word} || ()
   } @msg);

   my $reply;
   my $best = -1;
   my $idx;

   #warn "KEY<@key> SRCH<@srch>\n";#d#

   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)
            + (@key ? (List::Util::sum map $prob->{$_} || 1, @key) / @key : 0);

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