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

   # find starting sequence
   shift @sym while @sym && !$tree->{simplify join "\0", @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.53
Committed:	Fri Feb 4 02:10:31 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.52:	+1 -2 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	# find starting sequence
58	shift @sym while @sym && !$tree->{simplify join "\0", @sym};
59
60	@sym = $self->{s_beg} unless @sym;
61
62	#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
63
64	outer:
65	while () {
66	my $node = $tree->{simplify join "\0", @sym};
67
68	if ($node) {
69	my $sel = rand $node->{""};
70	keys %$node;
71
72	while (my ($k, $v) = each %$node) {
73	if (length $k and ($sel -= $v) < 0) {
74	last outer if $k eq $self->{s_end};
75
76	push @sym, $k;
77	push @res, $k;
78
79	$prob->{$k} = $v / $node->{""};
80
81	next outer;
82	}
83	}
84
85	die "FATAL: internal error";
86	} else {
87	shift @sym;
88	@sym
89	or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
90	}
91	}
92
93	@res
94	}
95
96	package main;
97
98	use Socket;
99	use IO::Socket::INET;
100
101	use YAML;
102	use Encode;
103	use Event;
104	use Net::Knuddels;
105	use List::Util;
106	use Time::HiRes;
107
108	my @CHANNELS = (
109	'Flirt',
110	'Flirt Private',
111	'Singles 11-14',
112	'Singles 15-17',
113
114	'Singles 11-14 2',
115	'Singles 15-17 2',
116	'Flirt 2',
117	'Flirt Private 2',
118	'Singles 11-14 3',
119	'Singles 15-17 3',
120	'Flirt 3',
121	'Flirt Private 3',
122	'Singles 11-14 4',
123	'Singles 15-17 4',
124	'Flirt 4',
125	'Flirt Private 4',
126	'Singles 11-14 5',
127	'Singles 15-17 5',
128	'Flirt 5',
129	'Flirt Private 5',
130	'Singles 11-14 6',
131	'Singles 15-17 6',
132	'Flirt 6',
133	'Flirt Private 6',
134	'Singles 11-14 7',
135	'Singles 15-17 7',
136	'Flirt 7',
137	'Flirt Private 7',
138	'Singles 11-14 8',
139	'Singles 15-17 8',
140	'Flirt 8',
141	'Flirt Private 8',
142	);
143
144	my $logdir = "logs";
145
146	my $Knick = $ARGV[0];
147	my $Kpass = $ARGV[1];
148
149	my $client;
150
151	my $seed = [split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];
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	last if /^$/;
195	seed_msg $_;
196	}
197
198	my %grammar_reply = qw(
199	ich du
200	du ich
201	mir dir
202	dir mir
203	mein dein
204	dein mein
205	deine meine
206	meine deine
207	deiner meiner
208	meiner deiner
209	frau mann
210	mädel junge
211	mädchen junge
212	girls boys
213	boys girls
214	huhu hi
215	hi hi
216	hallo hi
217	typen mädels
218	bye bye
219	ciao bye
220	);
221
222	sub gen_reply {
223	my ($msg) = @_;
224
225	my @msg = $msg =~ /(\S+)/g;
226
227	my @key = map {
228	my $word = word $_;
229
230	$freq{$word} < $word_cnt * 0.003
231	&& $freq{$word}
232	&& 2 <= length $word
233	? $word
234	: ()
235	} @msg;
236
237	my @srch = (("") x 5, @key, map {
238	my $word = word $_;
239
240	$grammar_reply{$word} \|\| ()
241	} @msg);
242
243	my $reply;
244	my $best = -1;
245	my $idx;
246
247	#warn "KEY<@key> SRCH<@srch>\n";#d#
248
249	for (1..200) {
250	my $prob = {};
251
252	my @r = $rev->complete (
253	[reverse $fwd->complete (
254	[
255	$srch[++$idx % @srch]
256	],
257	$prob
258	) ], $prob
259	);
260
261	# my $b = (rand 0.02 / (@r + 1))
262	# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
263	#
264	# $b += 0.2 if @r < 3;
265
266	$b = @r ** 0.2 * (rand)
267	+ (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
268
269	#my $b = (List::Util::sum map $freq{word $_}, @r) / (@r ** 3 * $word_cnt);
270
271	($reply, $best) = ((join " ", reverse @r), $b) if $b > $best;
272	}
273
274	$reply;
275	}
276
277	while ($ENV{DEBUG}) {
278	my $r = gen_reply scalar <>;
279	print "$r\n\n";
280	}
281
282	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
283
284	Event->timer (after => 60, interval => 60, cb => sub {
285	open my $fh, ">:utf8", "markovbot.txt~"
286	or return;
287	print $fh join "\n", @$seed;
288	close $fh;
289	rename "markovbot.txt~", "markovbot.txt";
290	});
291
292	sub logit {
293	my ($msg, $file, $src, $dst, $room) = @_;
294
295	mkdir $logdir;
296	my $fh;
297
298	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
299	warn "Couldn't open for appending $logdir/$src: $!\n";
300	return;
301	}
302
303	print $fh "$room\t$src\t$dst\t$msg\n";
304	}
305
306	####################################################################################
307	########################## MAIN START ##############################################
308	####################################################################################
309
310	$client = new Net::Knuddels::Client
311	PeerAddr => "213.61.5.150:2710",
312	command_wait => sub {
313	my ($client, $wait) = @_;
314	Event->timer (after => $wait, cb => sub { $client->command_cb });
315	};
316
317	Event->io (
318	fd => $client->fh,
319	poll => 'r',
320	cb => sub {
321	$client->ready
322	or $_[0]->w->cancel;
323	});
324
325	$client->login;
326
327	$client->register (dialog => sub {
328	use Dumpvalue;
329	print "---\n";
330	Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
331	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
332	});
333
334	$client->register (login => sub {
335	Event->timer (after => 0, interval => 3, cb => sub {
336	$client->enter_room (shift @CHANNELS, $Knick, $Kpass);
337	});
338	});
339
340	$client->register (msg_room => sub {
341	my ($room, $user, $msg) = @_;
342	});
343
344	my @queue;
345
346	Event->timer (interval => 1, cb => sub {
347	my $msg = shift @queue
348	or return;
349
350	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
351	$client->send_priv_msg (@$msg);
352	});
353
354	my $some_room;
355
356	$client->register (room_info => sub {
357	print "JOIN ROOM: $_[0]\n";
358	$some_room = $_[0];
359	});
360
361	Event->timer (after => 60, interval => 60, cb => sub {
362	$client->send_priv_msg ("James", $some_room, "/knuschel");
363	});
364
365	my %next_time;
366
367	$client->register (msg_priv_nondup => sub {
368	my ($room, $src, $dst, $msg) = @_;
369
370	my $NOW = Time::HiRes::time;
371
372	$msg =~ s/\260[^\260]*\260//g;
373
374	print "($room) $src >> $msg\n";
375	logit ($msg, $src, $src, $dst, $room);
376
377	return if $next_time{$src} > time; # do not talk unnaturally often
378
379	my $reply = gen_reply $msg;
380
381	push @$seed, $msg;
382	#seed_msg $msg;#d#
383
384	my $delay = 2 + 30 * (rand) ** 5 + 0.2 * length $reply;
385	$next_time{$src} = time + $delay;
386
387	print "($room) $src << $reply ($delay)\n";
388
389	Event->timer (at => $NOW + $delay, cb => sub {
390	push @queue, [$src, $room, $reply];
391	});
392	});
393
394	Event::loop;
395