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

   #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 = $self->{s_beg} unless @sym;
      }
   }

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