[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;

   shift @sym while @sym && !$tree->{simplify join "\0", @sym};

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