[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;

   #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 = $self->{s_beg} unless @sym;
      }
   }

   @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.55
Committed:	Fri Feb 4 02:18:50 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.54:	+1 -4 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	#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
58
59	outer:
60	while () {
61	my $node = $tree->{simplify join "\0", @sym};
62
63	if ($node) {
64	my $sel = rand $node->{""};
65	keys %$node;
66
67	while (my ($k, $v) = each %$node) {
68	if (length $k and ($sel -= $v) < 0) {
69	last outer if $k eq $self->{s_end};
70
71	push @sym, $k;
72	push @res, $k;
73
74	$prob->{$k} = $v / $node->{""};
75
76	next outer;
77	}
78	}
79
80	die "FATAL: internal error";
81	} else {
82	shift @sym;
83	@sym = $self->{s_beg} unless @sym;
84	}
85	}
86
87	@res
88	}
89
90	package main;
91
92	use Socket;
93	use IO::Socket::INET;
94
95	use YAML;
96	use Encode;
97	use Event;
98	use Net::Knuddels;
99	use List::Util;
100	use Time::HiRes;
101
102	my @CHANNELS = (
103	'Flirt',
104	'Flirt Private',
105	'Singles 11-14',
106	'Singles 15-17',
107
108	'Singles 11-14 2',
109	'Singles 15-17 2',
110	'Flirt 2',
111	'Flirt Private 2',
112	'Singles 11-14 3',
113	'Singles 15-17 3',
114	'Flirt 3',
115	'Flirt Private 3',
116	'Singles 11-14 4',
117	'Singles 15-17 4',
118	'Flirt 4',
119	'Flirt Private 4',
120	'Singles 11-14 5',
121	'Singles 15-17 5',
122	'Flirt 5',
123	'Flirt Private 5',
124	'Singles 11-14 6',
125	'Singles 15-17 6',
126	'Flirt 6',
127	'Flirt Private 6',
128	'Singles 11-14 7',
129	'Singles 15-17 7',
130	'Flirt 7',
131	'Flirt Private 7',
132	'Singles 11-14 8',
133	'Singles 15-17 8',
134	'Flirt 8',
135	'Flirt Private 8',
136	);
137
138	my $logdir = "logs";
139
140	my $Knick = $ARGV[0];
141	my $Kpass = $ARGV[1];
142
143	my $client;
144
145	my $seed = [split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];
146
147	my $fwd = new markov longest => 2;
148	my $rev = new markov longest => 2;
149
150	my %freq;
151	my $word_cnt;
152
153	sub word {
154	$_[0] =~ /(\w+)/ ? lc $1 : ();
155	}
156
157	sub seed_msg {
158	my $msg = $_[0];
159
160	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
161	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
162	\|knallen\|schlecken
163	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
164	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
165	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
166	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
167	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
168	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
169	\|zieh.*aus\|nackt\|geile\|feucht\|willig
170	\|sätz\|saetz\|setze\|\bsatz
171	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
172	\|admin\|nachgeburt
173	\|(?-i:[A-Z]{4,})
174	\|\S{20,}
175	/xi;
176
177	my @msg = $msg =~ m/(\S+)/g;
178	#my @msg = split /\b/, $msg;
179
180	$freq{word $_}++ for @msg;
181	$word_cnt += @msg;
182
183	$fwd->seed (\@msg);
184	$rev->seed ([reverse @msg]);
185	}
186
187	for (@$seed) {
188	last if /^$/;
189	seed_msg $_;
190	}
191
192	my %grammar_reply = qw(
193	ich du
194	du ich
195	mir dir
196	dir mir
197	mein dein
198	dein mein
199	deine meine
200	meine deine
201	deiner meiner
202	meiner deiner
203	frau mann
204	mädel junge
205	mädchen junge
206	girls boys
207	boys girls
208	huhu hi
209	hi hi
210	hallo hi
211	typen mädels
212	bye bye
213	ciao bye
214	);
215
216	sub gen_reply {
217	my ($msg) = @_;
218
219	my @msg = $msg =~ /(\S+)/g;
220
221	my @key = map {
222	my $word = word $_;
223
224	$freq{$word} < $word_cnt * 0.003
225	&& $freq{$word}
226	&& 2 <= length $word
227	? $word
228	: ()
229	} @msg;
230
231	my @srch = (("") x 5, @key, map {
232	my $word = word $_;
233
234	$grammar_reply{$word} \|\| ()
235	} @msg);
236
237	my $reply;
238	my $best = -1;
239	my $idx;
240
241	#warn "KEY<@key> SRCH<@srch>\n";#d#
242
243	for (1..200) {
244	my $prob = {};
245
246	my @r = $rev->complete (
247	[reverse $fwd->complete (
248	[
249	$srch[++$idx % @srch]
250	],
251	$prob
252	) ], $prob
253	);
254
255	# my $b = (rand 0.02 / (@r + 1))
256	# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
257	#
258	# $b += 0.2 if @r < 3;
259
260	$b = @r ** 0.2 * (rand)
261	+ (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
262
263	#my $b = (List::Util::sum map $freq{word $_}, @r) / (@r ** 3 * $word_cnt);
264
265	($reply, $best) = ((join " ", reverse @r), $b) if $b > $best;
266	}
267
268	$reply;
269	}
270
271	while ($ENV{DEBUG}) {
272	my $r = gen_reply scalar <>;
273	print "$r\n\n";
274	}
275
276	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
277
278	Event->timer (after => 60, interval => 60, cb => sub {
279	open my $fh, ">:utf8", "markovbot.txt~"
280	or return;
281	print $fh join "\n", @$seed;
282	close $fh;
283	rename "markovbot.txt~", "markovbot.txt";
284	});
285
286	sub logit {
287	my ($msg, $file, $src, $dst, $room) = @_;
288
289	mkdir $logdir;
290	my $fh;
291
292	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
293	warn "Couldn't open for appending $logdir/$src: $!\n";
294	return;
295	}
296
297	print $fh "$room\t$src\t$dst\t$msg\n";
298	}
299
300	####################################################################################
301	########################## MAIN START ##############################################
302	####################################################################################
303
304	$client = new Net::Knuddels::Client
305	PeerAddr => "213.61.5.150:2710",
306	command_wait => sub {
307	my ($client, $wait) = @_;
308	Event->timer (after => $wait, cb => sub { $client->command_cb });
309	};
310
311	Event->io (
312	fd => $client->fh,
313	poll => 'r',
314	cb => sub {
315	$client->ready
316	or $_[0]->w->cancel;
317	});
318
319	$client->login;
320
321	$client->register (dialog => sub {
322	use Dumpvalue;
323	print "---\n";
324	Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
325	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
326	});
327
328	$client->register (login => sub {
329	Event->timer (after => 0, interval => 3, cb => sub {
330	$client->enter_room (shift @CHANNELS, $Knick, $Kpass);
331	});
332	});
333
334	$client->register (msg_room => sub {
335	my ($room, $user, $msg) = @_;
336	});
337
338	my @queue;
339
340	Event->timer (interval => 1, cb => sub {
341	my $msg = shift @queue
342	or return;
343
344	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
345	$client->send_priv_msg (@$msg);
346	});
347
348	my $some_room;
349
350	$client->register (room_info => sub {
351	print "JOIN ROOM: $_[0]\n";
352	$some_room = $_[0];
353	});
354
355	Event->timer (after => 60, interval => 60, cb => sub {
356	$client->send_priv_msg ("James", $some_room, "/knuschel");
357	});
358
359	my %next_time;
360
361	$client->register (msg_priv_nondup => sub {
362	my ($room, $src, $dst, $msg) = @_;
363
364	my $NOW = Time::HiRes::time;
365
366	$msg =~ s/\260[^\260]*\260//g;
367
368	print "($room) $src >> $msg\n";
369	logit ($msg, $src, $src, $dst, $room);
370
371	return if $next_time{$src} > time; # do not talk unnaturally often
372
373	my $reply = gen_reply $msg;
374
375	push @$seed, $msg;
376	#seed_msg $msg;#d#
377
378	my $delay = 2 + 30 * (rand) ** 5 + 0.2 * length $reply;
379	$next_time{$src} = time + $delay;
380
381	print "($room) $src << $reply ($delay)\n";
382
383	Event->timer (at => $NOW + $delay, cb => sub {
384	push @queue, [$src, $room, $reply];
385	});
386	});
387
388	Event::loop;
389