[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 @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 = [grep $_, 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) {
   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 (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.50
Committed:	Tue Feb 1 00:47:33 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.49:	+8 -8 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 @res;
55	my @sym = @$symbols;
56
57	# find starting sequence
58	shift @sym while @sym && !$tree->{simplify join "\0", @sym};
59
60	@res = @sym;
61	@sym = $self->{s_beg} unless @sym;
62
63	#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
64
65	outer:
66	while () {
67	my $node = $tree->{simplify join "\0", @sym};
68
69	if ($node) {
70	my $sel = rand $node->{""};
71	keys %$node;
72
73	while (my ($k, $v) = each %$node) {
74	if (length $k and ($sel -= $v) < 0) {
75	last outer if $k eq $self->{s_end};
76
77	push @sym, $k;
78	push @res, $k;
79
80	$prob->{$k} = $v / $node->{""};
81
82	next outer;
83	}
84	}
85
86	die "FATAL: internal error";
87	} else {
88	shift @sym;
89	@sym
90	or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
91	}
92	}
93
94	@res
95	}
96
97	package main;
98
99	use Socket;
100	use IO::Socket::INET;
101
102	use YAML;
103	use Encode;
104	use Event;
105	use Net::Knuddels;
106	use List::Util;
107	use Time::HiRes;
108
109	my @CHANNELS = (
110	'Flirt',
111	'Flirt Private',
112	'Singles 11-14',
113	'Singles 15-17',
114
115	'Singles 11-14 2',
116	'Singles 15-17 2',
117	'Flirt 2',
118	'Flirt Private 2',
119	'Singles 11-14 3',
120	'Singles 15-17 3',
121	'Flirt 3',
122	'Flirt Private 3',
123	'Singles 11-14 4',
124	'Singles 15-17 4',
125	'Flirt 4',
126	'Flirt Private 4',
127	'Singles 11-14 5',
128	'Singles 15-17 5',
129	'Flirt 5',
130	'Flirt Private 5',
131	'Singles 11-14 6',
132	'Singles 15-17 6',
133	'Flirt 6',
134	'Flirt Private 6',
135	'Singles 11-14 7',
136	'Singles 15-17 7',
137	'Flirt 7',
138	'Flirt Private 7',
139	'Singles 11-14 8',
140	'Singles 15-17 8',
141	'Flirt 8',
142	'Flirt Private 8',
143	);
144
145	my $logdir = "logs";
146
147	my $Knick = "ich bin suess";
148	my $Kpass = "qwerty";
149
150	my $client;
151
152	my $seed = [grep $_, split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];
153
154	my $fwd = new markov longest => 2;
155	my $rev = new markov longest => 2;
156
157	my %freq;
158	my $word_cnt;
159
160	sub word {
161	$_[0] =~ /(\w+)/ ? lc $1 : ();
162	}
163
164	sub seed_msg {
165	my $msg = $_[0];
166
167	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
168	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
169	\|knallen\|schlecken
170	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
171	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
172	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
173	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
174	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
175	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
176	\|zieh.*aus\|nackt\|geile\|feucht\|willig
177	\|sätz\|saetz\|setze\|\bsatz
178	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
179	\|admin\|nachgeburt
180	\|(?-i:[A-Z]{4,})
181	\|\S{20,}
182	/xi;
183
184	my @msg = $msg =~ m/(\S+)/g;
185	#my @msg = split /\b/, $msg;
186
187	$freq{word $_}++ for @msg;
188	$word_cnt += @msg;
189
190	$fwd->seed (\@msg);
191	$rev->seed ([reverse @msg]);
192	}
193
194	for (@$seed) {
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.0003
231	&& $freq{$word}
232	&& 2 <= length $word
233	? $word
234	: ()
235	} @msg;
236
237	my @srch = (("") x 10, @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	for (1..200) {
248	my $prob = {};
249
250	my @r = $rev->complete (
251	[reverse $fwd->complete (
252	[
253	# $srch[++$idx % @srch]
254	],
255	$prob
256	) ], $prob
257	);
258
259	# my $b = (rand 0.02 / (@r + 1))
260	# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
261	#
262	# $b += 0.2 if @r < 3;
263
264	$b = @r ** 0.2 * rand;
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