[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 => 4;
my $rev = new markov longest => 4;

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 = ("", @key, map {
      my $word = word $_;
      
      $grammar_reply{$word} || ()
   } @msg);

   my $reply;
   my $best = 2;
   my $idx;

   for (1..200) {
      my $prob = {};

      my @r = $rev->complete (
                 [reverse $fwd->complete (
                    [@srch ? $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;

      ($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 {
   $client->enter_room ($_, $Knick, $Kpass)
      for @CHANNELS;
});

$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 = 30 * (rand) ** 5 + 0.3 * 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.44
Committed:	Mon Jan 31 03:52:52 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.43:	+3 -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	$_;
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 => 4;
154	my $rev = new markov longest => 4;
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 = ("", @key, map {
237	my $word = word $_;
238
239	$grammar_reply{$word} \|\| ()
240	} @msg);
241
242	my $reply;
243	my $best = 2;
244	my $idx;
245
246	for (1..200) {
247	my $prob = {};
248
249	my @r = $rev->complete (
250	[reverse $fwd->complete (
251	[@srch ? $srch[++$idx % @srch] : ()],
252	$prob
253	) ], $prob
254	);
255
256	my $b = (rand 0.02 / (@r + 1))
257	+ (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
258
259	$b += 0.2 if @r < 3;
260
261	($reply, $best) = ((join " ", reverse @r), $b) if $b < $best;
262	}
263
264	$reply;
265	}
266
267	while ($ENV{DEBUG}) {
268	my $r = gen_reply scalar <>;
269	print "$r\n\n";
270	}
271
272	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
273
274	Event->timer (interval => 60, cb => sub {
275	open my $fh, ">", "markovbot.dat~"
276	or return;
277	binmode $fh;
278	print $fh Encode::encode_utf8 Dump $seed;
279	close $fh;
280	rename "markovbot.dat~", "markovbot.dat";
281	});
282
283	sub logit {
284	my ($msg, $file, $src, $dst, $room) = @_;
285
286	mkdir $logdir;
287	my $fh;
288
289	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
290	warn "Couldn't open for appending $logdir/$src: $!\n";
291	return;
292	}
293
294	print $fh "$room\t$src\t$dst\t$msg\n";
295	}
296
297	####################################################################################
298	########################## MAIN START ##############################################
299	####################################################################################
300
301	$client = new Net::Knuddels::Client
302	PeerAddr => "213.61.5.150:2710",
303	command_wait => sub {
304	my ($client, $wait) = @_;
305	Event->timer (after => $wait, cb => sub { $client->command_cb });
306	};
307
308	Event->io (
309	fd => $client->fh,
310	poll => 'r',
311	cb => sub {
312	$client->ready
313	or $_[0]->w->cancel;
314	});
315
316	$client->login;
317
318	$client->register (dialog => sub {
319	use Dumpvalue;
320	print "---\n";
321	Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
322	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
323	});
324
325	$client->register (login => sub {
326	$client->enter_room ($_, $Knick, $Kpass)
327	for @CHANNELS;
328	});
329
330	$client->register (msg_room => sub {
331	my ($room, $user, $msg) = @_;
332	});
333
334	my @queue;
335
336	Event->timer (interval => 1, cb => sub {
337	my $msg = shift @queue
338	or return;
339
340	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
341	$client->send_priv_msg (@$msg);
342	});
343
344	my $some_room;
345
346	$client->register (room_info => sub {
347	print "JOIN ROOM: $_[0]\n";
348	$some_room = $_[0];
349	});
350
351	Event->timer (after => 60, interval => 60, cb => sub {
352	$client->send_priv_msg ("James", $some_room, "/knuschel");
353	});
354
355	my %next_time;
356
357	$client->register (msg_priv_nondup => sub {
358	my ($room, $src, $dst, $msg) = @_;
359
360	my $NOW = Time::HiRes::time;
361
362	$msg =~ s/\260[^\260]*\260//g;
363
364	print "($room) $src >> $msg\n";
365	logit ($msg, $src, $src, $dst, $room);
366
367	return if $next_time{$src} > time; # do not talk unnaturally often
368
369	my $reply = gen_reply $msg;
370
371	push @$seed, $msg;
372	seed_msg $msg;
373
374	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
375	$next_time{$src} = time + $delay;
376
377	print "($room) $src << $reply ($delay)\n";
378
379	Event->timer (at => $NOW + $delay, cb => sub {
380	push @queue, [$src, $room, $reply];
381	});
382	});
383
384	Event::loop;
385