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

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;
      $b = rand 1;

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