[ViewVC] Contents 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', 
  '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 = "ich bin suess";
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|pussy
                     |blasen
                     |hure|strich
                     |stengel|penis|schwanz|pimmel|steifen|ejak|sperma
                     |\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
                     |sätz|saetz|setze|\bsatz
                     |sc?h?wul|schwuchtel|transe|transv|schlampe|tussi
                     |mädel
                     |(?-i:[A-Z]{4,})
                     /xi;
   
   my @msg = $msg =~ m/(\S+)/g;

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

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

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

   #my @msg = $msg =~ /(\S+)/g;

   my $reply;
   my $best = -1;

   for (1..30) {
      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 = shift @CHANNELS
         or return;

      $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 $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) = @_;

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

   my $delay = 5 + 30 * (rand) ** 5 + 0.3 * length $reply;
   $next_time{$src} = time + $delay;

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

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

connect_knuddels;
Event::loop;

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