[ViewVC] Annotation 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;

   @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.54
Committed:	Fri Feb 4 02:12:06 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.53:	+0 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.25	#!/opt/bin/perl
2	elmex	1.1
3			use strict;
4	root	1.2
5	root	1.40	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	root	1.50	s/ß/ss/g;
23			y/a-z\000//cd;
24	root	1.40	$_;
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	root	1.53	my @res = @sym;
56	root	1.40
57			@sym = $self->{s_beg} unless @sym;
58
59			#use Dumpvalue; Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ($self);
60
61			outer:
62			while () {
63			my $node = $tree->{simplify join "\0", @sym};
64
65			if ($node) {
66			my $sel = rand $node->{""};
67			keys %$node;
68
69			while (my ($k, $v) = each %$node) {
70			if (length $k and ($sel -= $v) < 0) {
71			last outer if $k eq $self->{s_end};
72
73			push @sym, $k;
74			push @res, $k;
75
76			$prob->{$k} = $v / $node->{""};
77
78			next outer;
79			}
80			}
81
82			die "FATAL: internal error";
83			} else {
84			shift @sym;
85			@sym
86			or die "FATAL: empty prefix (ENOTUNDERSTOOD)";
87			}
88			}
89
90			@res
91			}
92
93			package main;
94
95	elmex	1.1	use Socket;
96			use IO::Socket::INET;
97	root	1.2
98			use YAML;
99			use Encode;
100	elmex	1.1	use Event;
101			use Net::Knuddels;
102	root	1.23	use List::Util;
103	root	1.27	use Time::HiRes;
104	elmex	1.1
105			my @CHANNELS = (
106	elmex	1.3	'Flirt',
107	root	1.11	'Flirt Private',
108	root	1.10	'Singles 11-14',
109			'Singles 15-17',
110	root	1.11
111	root	1.18	'Singles 11-14 2',
112			'Singles 15-17 2',
113	root	1.11	'Flirt 2',
114	root	1.18	'Flirt Private 2',
115	root	1.11	'Singles 11-14 3',
116	root	1.18	'Singles 15-17 3',
117	root	1.11	'Flirt 3',
118	root	1.18	'Flirt Private 3',
119	root	1.11	'Singles 11-14 4',
120	root	1.18	'Singles 15-17 4',
121	root	1.11	'Flirt 4',
122	root	1.18	'Flirt Private 4',
123	root	1.11	'Singles 11-14 5',
124	root	1.18	'Singles 15-17 5',
125	root	1.11	'Flirt 5',
126	root	1.18	'Flirt Private 5',
127	root	1.11	'Singles 11-14 6',
128	root	1.18	'Singles 15-17 6',
129	root	1.11	'Flirt 6',
130	root	1.18	'Flirt Private 6',
131	root	1.11	'Singles 11-14 7',
132	root	1.18	'Singles 15-17 7',
133	root	1.11	'Flirt 7',
134	root	1.18	'Flirt Private 7',
135	root	1.11	'Singles 11-14 8',
136	root	1.18	'Singles 15-17 8',
137	root	1.11	'Flirt 8',
138	root	1.18	'Flirt Private 8',
139	elmex	1.1	);
140
141	root	1.14	my $logdir = "logs";
142	elmex	1.4
143	root	1.52	my $Knick = $ARGV[0];
144			my $Kpass = $ARGV[1];
145	elmex	1.1
146			my $client;
147
148	root	1.52	my $seed = [split /\n/, do { open my $fh, "<:utf8", "markovbot.txt"; local $/; <$fh> } ];
149	root	1.2
150	root	1.48	my $fwd = new markov longest => 2;
151			my $rev = new markov longest => 2;
152	root	1.23
153			my %freq;
154			my $word_cnt;
155
156			sub word {
157			$_[0] =~ /(\w+)/ ? lc $1 : ();
158			}
159	root	1.11
160			sub seed_msg {
161			my $msg = $_[0];
162	root	1.19
163	root	1.32	return if $msg =~ /leck\|fick\|möse\|mose\|moese\|uschi\|usci\|ushi\|fikk\|scheide\|vagina
164	root	1.39	\|bums\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen\|pussy\|\bsuck\b\|lutsch
165			\|knallen\|schlecken
166	root	1.29	\|\bblas\|piss\|schluck\|fingern\|spritz\|\bloch\|\bsteck\|vögel\|voegel\|vogel
167	root	1.36	\|hure\|strich\|sklave\|handschell\|slave\|perver\|befehl\|stöhn\|dildo
168	root	1.39	\|stengel\|penis\|schwanz\|pimmel\|steifen\|ejak\|sperma\|\btitt\|\bass\|\bsack\|\bsaft\b\|\beier\b\|willy
169	root	1.20	\|\bcs\b\|\bts\b\|\brs\b\|\bicq\b
170	root	1.15	\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
171	root	1.18	\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul\|rosett?e
172	root	1.39	\|zieh.*aus\|nackt\|geile\|feucht\|willig
173	root	1.15	\|sätz\|saetz\|setze\|\bsatz
174	root	1.23	\|sc?h?wul\|schwuchtel\|transe\|transv\|schlampe\|tussi\|nutte\|mädel
175			\|admin\|nachgeburt
176	root	1.15	\|(?-i:[A-Z]{4,})
177	root	1.23	\|\S{20,}
178	root	1.15	/xi;
179
180	root	1.44	my @msg = $msg =~ m/(\S+)/g;
181			#my @msg = split /\b/, $msg;
182	root	1.11
183	root	1.23	$freq{word $_}++ for @msg;
184			$word_cnt += @msg;
185
186	root	1.40	$fwd->seed (\@msg);
187			$rev->seed ([reverse @msg]);
188	root	1.11	}
189
190			for (@$seed) {
191	root	1.52	last if /^$/;
192	root	1.11	seed_msg $_;
193			}
194
195	root	1.23	my %grammar_reply = qw(
196			ich du
197			du ich
198			mir dir
199			dir mir
200			mein dein
201			dein mein
202	root	1.40	deine meine
203			meine deine
204			deiner meiner
205			meiner deiner
206	root	1.23	frau mann
207			mädel junge
208			mädchen junge
209			girls boys
210			boys girls
211			huhu hi
212			hi hi
213			hallo hi
214			typen mädels
215	root	1.33	bye bye
216			ciao bye
217	root	1.23	);
218
219	root	1.11	sub gen_reply {
220			my ($msg) = @_;
221
222	root	1.23	my @msg = $msg =~ /(\S+)/g;
223
224	root	1.40	my @key = map {
225			my $word = word $_;
226
227	root	1.51	$freq{$word} < $word_cnt * 0.003
228	root	1.40	&& $freq{$word}
229			&& 2 <= length $word
230			? $word
231			: ()
232			} @msg;
233
234	root	1.51	my @srch = (("") x 5, @key, map {
235	root	1.23	my $word = word $_;
236
237	root	1.40	$grammar_reply{$word} \|\| ()
238			} @msg);
239	root	1.19
240	root	1.15	my $reply;
241	root	1.46	my $best = -1;
242	root	1.40	my $idx;
243
244	root	1.51	#warn "KEY<@key> SRCH<@srch>\n";#d#
245
246	root	1.40	for (1..200) {
247			my $prob = {};
248
249			my @r = $rev->complete (
250			[reverse $fwd->complete (
251	root	1.46	[
252	root	1.51	$srch[++$idx % @srch]
253	root	1.46	],
254	root	1.40	$prob
255			) ], $prob
256			);
257
258	root	1.45	# my $b = (rand 0.02 / (@r + 1))
259			# + (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
260			#
261			# $b += 0.2 if @r < 3;
262	root	1.15
263	root	1.51	$b = @r ** 0.2 * (rand)
264			+ (@key ? (List::Util::sum map $prob->{$_} \|\| 1, @key) / @key : 0);
265	root	1.46
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	root	1.15	}
270
271			$reply;
272	root	1.11	}
273
274	root	1.43	while ($ENV{DEBUG}) {
275	root	1.23	my $r = gen_reply scalar <>;
276			print "$r\n\n";
277			}
278
279	root	1.11	Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
280	root	1.2
281	root	1.50	Event->timer (after => 60, interval => 60, cb => sub {
282			open my $fh, ">:utf8", "markovbot.txt~"
283	root	1.2	or return;
284	root	1.50	print $fh join "\n", @$seed;
285	root	1.2	close $fh;
286	root	1.50	rename "markovbot.txt~", "markovbot.txt";
287	root	1.2	});
288
289	elmex	1.4	sub logit {
290	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
291	elmex	1.4
292	root	1.12	mkdir $logdir;
293			my $fh;
294	elmex	1.4
295	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
296	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
297			return;
298			}
299
300	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
301	elmex	1.4	}
302
303	elmex	1.1	####################################################################################
304			########################## MAIN START ##############################################
305			####################################################################################
306
307	root	1.23	$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	elmex	1.1
324	root	1.31	$client->register (dialog => sub {
325			use Dumpvalue;
326			print "---\n";
327			Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
328	root	1.35	Event::unloop(-1) if grep /Falsches.*Passwort/i, @_;
329	root	1.31	});
330	root	1.7
331	elmex	1.1	$client->register (login => sub {
332	root	1.47	Event->timer (after => 0, interval => 3, cb => sub {
333	root	1.48	$client->enter_room (shift @CHANNELS, $Knick, $Kpass);
334	root	1.47	});
335	elmex	1.1	});
336
337			$client->register (msg_room => sub {
338			my ($room, $user, $msg) = @_;
339	root	1.2	});
340
341			my @queue;
342
343			Event->timer (interval => 1, cb => sub {
344			my $msg = shift @queue
345			or return;
346
347	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
348	root	1.2	$client->send_priv_msg (@$msg);
349	elmex	1.1	});
350
351	root	1.20	my $some_room;
352
353	root	1.17	$client->register (room_info => sub {
354	root	1.20	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	elmex	1.16	});
361	root	1.17
362	root	1.18	my %next_time;
363
364	elmex	1.16	$client->register (msg_priv_nondup => sub {
365	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
366
367	root	1.27	my $NOW = Time::HiRes::time;
368
369	root	1.7	$msg =~ s/\260[^\260]*\260//g;
370
371	root	1.2	print "($room) $src >> $msg\n";
372	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
373	root	1.2
374	root	1.18	return if $next_time{$src} > time; # do not talk unnaturally often
375
376	root	1.21	my $reply = gen_reply $msg;
377
378	root	1.11	push @$seed, $msg;
379	root	1.50	#seed_msg $msg;#d#
380	elmex	1.1
381	root	1.49	my $delay = 2 + 30 * (rand) ** 5 + 0.2 * length $reply;
382	root	1.18	$next_time{$src} = time + $delay;
383	root	1.9
384	root	1.8	print "($room) $src << $reply ($delay)\n";
385	elmex	1.1
386	root	1.27	Event->timer (at => $NOW + $delay, cb => sub {
387	root	1.2	push @queue, [$src, $room, $reply];
388			});
389	elmex	1.1	});
390
391			Event::loop;
392	root	1.7