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

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