[ViewVC] Annotation of: cvs/Net-Knuddels/eg/markovd

#!/usr/bin/perl

use strict;

use Socket;
use IO::Socket::INET;

use YAML;
use Encode;
use Event;
use Net::Knuddels;
use Algorithm::MarkovChain;
use String::Similarity;

my @CHANNELS = (
  'Flirt', 
  'Flirt Private', 
  'Flirt Private 2', 
  'Singles 11-14', 
  'Singles 11-14 2', 
  'Singles 15-17',

  'Flirt 2', 
  'Singles 11-14 3', 
  'Singles 15-17 2',
  'Flirt 3', 
  'Singles 11-14 4', 
  'Singles 15-17 3',
  'Flirt 4', 
  'Singles 11-14 5', 
  'Singles 15-17 4',
  'Flirt 5', 
  'Singles 11-14 6', 
  'Singles 15-17 5',
  'Flirt 6', 
  'Singles 11-14 7', 
  'Singles 15-17 6',
  'Flirt 7', 
  'Singles 11-14 8', 
  'Singles 15-17 7',
  'Flirt 8', 
  'Singles 11-14 9', 
  'Singles 15-17 8',
);

my $logdir = "logs";

my $Knick = "baileysmaedl";
my $Kpass = "qwerty";

my $client;

my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
$seed ||= [];

my $markov = new Algorithm::MarkovChain;

sub seed_msg {
   my $msg = $_[0];

   return if $msg =~ /leck|fick|m.se|uschi|fikkn|bumsen|wichs|wix|popp|popen|fuck|dreck|laber|saugen
                     |blasen
                     |hure|strich
                     |stengel|penis|schwanz|pimmel|steifen
                     |\bcs\b|\bts\b|\brs\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
                     |zieh.*aus|nackt
                     |sätz|saetz|setze|\bsatz
                     |schwul|schwuchtel|transe|transv
                     |(?-i:[A-Z]{4,})
                     /xi;
   
   my @msg = $msg =~ m/(\S+)/g;

   $markov->seed (symbols => \@msg, longest => 10);
}

for (@$seed) {
   seed_msg $_;
}

sub gen_reply {
   my ($msg) = @_;

   my $reply;
   my $best = -1;

   for (1..20) {
      my $r = join " ", $markov->spew (length => 5, stop_at_terminal => 1);
      my $b = similarity lc $msg, lc $r, $best;
      ($reply, $best) = ($r, $b) if $b > $best;
   }

   $reply;
}

Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });

Event->timer (interval => 60, cb => sub {
   open my $fh, ">", "markovbot.dat~"
      or return;
   print $fh Encode::encode_utf8 Dump $seed;
   close $fh;
   rename "markovbot.dat~", "markovbot.dat";
});

sub connect_knuddels {
  $client->login;
  Event->io (
    fd => $client->fh, 
    poll => 'r', 
    cb => sub { 
      my $e = shift;
      if (not $client->ready) {
        $e->w->cancel;
      }
    });
}

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

#$client->register (ALL => sub {
#   use Dumpvalue;
#   print "---\n";
#   Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
#});

$client->register (login => sub {
   Event->timer (after => 0, interval => 1, repeat => 0, cb => sub {
      my $channel = pop @CHANNELS
         or return;

      print "join<$channel>\n";
      $client->enter_room ($channel, $Knick, $Kpass);
      $_[0]->w->again;
   });
});

$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 %last;

$client->register (msg_priv_nondup => sub {
   my ($room, $src, $dst, $msg) = @_;

   return if $last{$src} eq $msg; $last{$src} = $msg;

   $msg =~ s/\260[^\260]*\260//g;

   print "($room) $src >> $msg\n";
   logit ($msg, $src, $src, $dst, $room);

   push @$seed, $msg;
   seed_msg $msg;

   my $reply = gen_reply $msg;

   my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;

   print "($room) $src << $reply ($delay)\n";

   Event->timer (after => $delay, cb => sub {
      push @queue, [$src, $room, $reply];
   });
});

connect_knuddels;
Event::loop;

Revision:	1.15
Committed:	Sat Jan 29 06:09:37 2005 UTC (21 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.14:	+37 -6 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	elmex	1.1	#!/usr/bin/perl
2
3			use strict;
4	root	1.2
5	elmex	1.1	use Socket;
6			use IO::Socket::INET;
7	root	1.2
8			use YAML;
9			use Encode;
10	elmex	1.1	use Event;
11			use Net::Knuddels;
12	root	1.2	use Algorithm::MarkovChain;
13	root	1.15	use String::Similarity;
14	elmex	1.1
15			my @CHANNELS = (
16	elmex	1.3	'Flirt',
17	root	1.11	'Flirt Private',
18			'Flirt Private 2',
19	root	1.10	'Singles 11-14',
20			'Singles 11-14 2',
21			'Singles 15-17',
22	root	1.11
23			'Flirt 2',
24			'Singles 11-14 3',
25			'Singles 15-17 2',
26			'Flirt 3',
27			'Singles 11-14 4',
28			'Singles 15-17 3',
29			'Flirt 4',
30			'Singles 11-14 5',
31			'Singles 15-17 4',
32			'Flirt 5',
33			'Singles 11-14 6',
34			'Singles 15-17 5',
35			'Flirt 6',
36			'Singles 11-14 7',
37			'Singles 15-17 6',
38			'Flirt 7',
39			'Singles 11-14 8',
40			'Singles 15-17 7',
41			'Flirt 8',
42			'Singles 11-14 9',
43			'Singles 15-17 8',
44	elmex	1.1	);
45
46	root	1.14	my $logdir = "logs";
47	elmex	1.4
48	root	1.15	my $Knick = "baileysmaedl";
49			my $Kpass = "qwerty";
50	elmex	1.1
51			my $client;
52
53	root	1.11	my $seed = Load do { open my $fh, "<", "markovbot.dat"; binmode $fh, ":utf8"; local $/; <$fh> };
54	root	1.2	$seed \|\|= [];
55
56	root	1.11	my $markov = new Algorithm::MarkovChain;
57
58			sub seed_msg {
59			my $msg = $_[0];
60	root	1.15
61			return if $msg =~ /leck\|fick\|m.se\|uschi\|fikkn\|bumsen\|wichs\|wix\|popp\|popen\|fuck\|dreck\|laber\|saugen
62			\|blasen
63			\|hure\|strich
64			\|stengel\|penis\|schwanz\|pimmel\|steifen
65			\|\bcs\b\|\bts\b\|\brs\b
66			\|cam\b\|\bmsn\b\|\bbot\b\|\bchat.*bot\b\|tanga\|schlafen\|sex\|\bsau\b
67			\|intim\|arsch\|fotze\|dumm\|schnauze\|klappe\|rasiert\|fresse\|maul\b\|\bmaul
68			\|zieh.*aus\|nackt
69			\|sätz\|saetz\|setze\|\bsatz
70			\|schwul\|schwuchtel\|transe\|transv
71			\|(?-i:[A-Z]{4,})
72			/xi;
73
74	root	1.11	my @msg = $msg =~ m/(\S+)/g;
75
76	root	1.15	$markov->seed (symbols => \@msg, longest => 10);
77	root	1.11	}
78
79			for (@$seed) {
80			seed_msg $_;
81			}
82
83			sub gen_reply {
84			my ($msg) = @_;
85
86	root	1.15	my $reply;
87			my $best = -1;
88
89			for (1..20) {
90			my $r = join " ", $markov->spew (length => 5, stop_at_terminal => 1);
91			my $b = similarity lc $msg, lc $r, $best;
92			($reply, $best) = ($r, $b) if $b > $best;
93			}
94
95			$reply;
96	root	1.11	}
97
98			Event->signal (signal => "INT", cb => sub { Event::unloop(-1) });
99	root	1.2
100	root	1.8	Event->timer (interval => 60, cb => sub {
101	root	1.11	open my $fh, ">", "markovbot.dat~"
102	root	1.2	or return;
103			print $fh Encode::encode_utf8 Dump $seed;
104			close $fh;
105	root	1.11	rename "markovbot.dat~", "markovbot.dat";
106	root	1.2	});
107
108	elmex	1.1	sub connect_knuddels {
109			$client->login;
110			Event->io (
111			fd => $client->fh,
112			poll => 'r',
113			cb => sub {
114			my $e = shift;
115			if (not $client->ready) {
116			$e->w->cancel;
117			}
118			});
119			}
120
121	elmex	1.4	sub logit {
122	elmex	1.6	my ($msg, $file, $src, $dst, $room) = @_;
123	elmex	1.4
124	root	1.12	mkdir $logdir;
125			my $fh;
126	elmex	1.4
127	root	1.13	unless (open $fh, ">>:utf8", Encode::encode_utf8 "$logdir/$file") {
128	elmex	1.4	warn "Couldn't open for appending $logdir/$src: $!\n";
129			return;
130			}
131
132	root	1.12	print $fh "$room\t$src\t$dst\t$msg\n";
133	elmex	1.4	}
134
135	elmex	1.1	####################################################################################
136			########################## MAIN START ##############################################
137			####################################################################################
138
139			$client = new Net::Knuddels::Client PeerAddr => "213.61.5.150:2710";
140
141	root	1.11	#$client->register (ALL => sub {
142	root	1.7	# use Dumpvalue;
143			# print "---\n";
144			# Dumpvalue->new (compactDump => 1, veryCompact => 1, quoteHighBit => 1, tick => '"')->dumpValue ([@_]);
145			#});
146
147	elmex	1.1	$client->register (login => sub {
148	root	1.15	Event->timer (after => 0, interval => 1, repeat => 0, cb => sub {
149			my $channel = pop @CHANNELS
150			or return;
151
152			print "join<$channel>\n";
153			$client->enter_room ($channel, $Knick, $Kpass);
154			$_[0]->w->again;
155			});
156	elmex	1.1	});
157
158			$client->register (msg_room => sub {
159			my ($room, $user, $msg) = @_;
160	root	1.2	});
161
162			my @queue;
163
164			Event->timer (interval => 1, cb => sub {
165			my $msg = shift @queue
166			or return;
167
168	elmex	1.6	logit ($msg->[2], $msg->[0], $Knick, $msg->[0], $msg->[1]);
169	root	1.2	$client->send_priv_msg (@$msg);
170	elmex	1.1	});
171
172	root	1.11	my %last;
173
174			$client->register (msg_priv_nondup => sub {
175	elmex	1.1	my ($room, $src, $dst, $msg) = @_;
176
177	root	1.11	return if $last{$src} eq $msg; $last{$src} = $msg;
178	root	1.2
179	root	1.7	$msg =~ s/\260[^\260]*\260//g;
180
181	root	1.2	print "($room) $src >> $msg\n";
182	elmex	1.6	logit ($msg, $src, $src, $dst, $room);
183	root	1.2
184	root	1.11	push @$seed, $msg;
185	root	1.15	seed_msg $msg;
186	elmex	1.1
187	root	1.11	my $reply = gen_reply $msg;
188	elmex	1.1
189	root	1.9	my $delay = 30 * (rand) ** 5 + 0.3 * length $reply;
190
191	root	1.8	print "($room) $src << $reply ($delay)\n";
192	elmex	1.1
193	root	1.2	Event->timer (after => $delay, cb => sub {
194			push @queue, [$src, $room, $reply];
195			});
196	elmex	1.1	});
197
198			connect_knuddels;
199			Event::loop;
200	root	1.7