[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 Algorithm::MarkovChain;
use String::Similarity;
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.01 / (@r + 1))
            + (@key ? (List::Util::sum map $prob->{$_}, @key) / @key : 0);

      ($reply, $best) = ((join "", reverse @r), $b) if $b < $best;
   }

   $reply;
}

while (1) {
   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.40
Committed:	Mon Jan 31 03:05:46 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.39:	+131 -24 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 Algorithm::MarkovChain;
105	use String::Similarity;
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 = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
153	$seed \|\|= [];
154
155	my $fwd = new markov longest => 4;
156	my $rev = new markov longest => 4;
157
158	my %freq;
159	my $word_cnt;
160
161	sub word {
162	$_[0] =~ /(\w+)/ ? lc $1 : ();
163	}
164
165	sub seed_msg {
166	my $msg = $_[0];
167
168	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
169	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
170	\|knallen\|schlecken
171	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
172	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
173	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
174	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
175	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
176	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
177	\|zieh.*aus\|nackt\|geile\|feucht\|willig
178	\|sätz\|saetz\|setze\|\bsatz
179	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
180	\|admin\|nachgeburt
181	\|(?-i:[A-Z]{4,})
182	\|\S{20,}
183	/xi;
184
185	#my @msg = $msg =~ m/(\S+)/g;
186	my @msg = split /\b/, $msg;
187
188	$freq{word $_}++ for @msg;
189	$word_cnt += @msg;
190
191	$fwd->seed (\@msg);
192	$rev->seed ([reverse @msg]);
193	}
194
195	for (@$seed) {
196	seed_msg $_;
197	}
198
199	my %grammar_reply = qw(
200	ich du
201	du ich
202	mir dir
203	dir mir
204	mein dein
205	dein mein
206	deine meine
207	meine deine
208	deiner meiner
209	meiner deiner
210	frau mann
211	mädel junge
212	mädchen junge
213	girls boys
214	boys girls
215	huhu hi
216	hi hi
217	hallo hi
218	typen mädels
219	bye bye
220	ciao bye
221	);
222
223	sub gen_reply {
224	my ($msg) = @_;
225
226	my @msg = $msg =~ /(\S+)/g;
227
228	my @key = map {
229	my $word = word $_;
230
231	$freq{$word} < $word_cnt * 0.0003
232	&& $freq{$word}
233	&& 2 <= length $word
234	? $word
235	: ()
236	} @msg;
237
238	my @srch = ("", @key, map {
239	my $word = word $_;
240
241	$grammar_reply{$word} \|\| ()
242	} @msg);
243
244	my $reply;
245	my $best = 2;
246	my $idx;
247
248	for (1..200) {
249	my $prob = {};
250
251	my @r = $rev->complete (
252	[reverse $fwd->complete (
253	[@srch ? $srch[++$idx % @srch] : ()],
254	$prob
255	) ], $prob
256	);
257
258	my $b = (rand 0.01 / (@r + 1))
259	+ (@key ? (List::Util::sum map $prob->{$_}, @key) / @key : 0);
260
261	($reply, $best) = ((join "", reverse @r), $b) if $b < $best;
262	}
263
264	$reply;
265	}
266
267	while (1) {
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