#!/usr/bin/perl -w use threads qw( yield ); use threads::shared; use Thread::Queue; use Thread::Semaphore; use Net::IRC; use constant NICK => "vingt"; # use constant IRC_HOST => "irc.freenode.net"; # use constant IRC_CHAN => "#wireless"; use constant IRC_HOST => "irc.pobox.com"; use constant IRC_CHAN => "#killallhumans"; use YAML qw( DumpFile LoadFile ); use constant DBFILE => "vingt.yaml"; use constant PATH => 0; use constant QUERY => 1; use constant YES => 2; use constant NO => 3; use strict; use warnings; no warnings 'uninitialized'; $|++; my $tree : shared = &share([]); my $index : shared = &share({}); my %queue; my $master = Thread::Semaphore->new; my $out = Thread::Queue->new; my $nick; # not shared sub debug { warn "[", threads->self->tid, "] @_\n"; } sub say { debug "Saying to $nick: @_"; my ($who, $where) = split("/", $nick, 2); my @what : shared; if ($where =~ /#/o) { @what = ($where, "$who: @_"); } else { @what = ($who, "@_"); } $out->enqueue(\@what); } sub answer_is_yes { my $answer; $master->up; while (($answer = $queue{$nick}->dequeue) !~ /^[yn]/io) { goto THREAD_EXIT if $answer =~ /^(reset|start over)/o; say "That was a simple yes or no question.", "Tell me to start over if you want."; } $master->down; return scalar( $answer =~ /^y/io ); } sub answer_freely { my $answer; $master->up; 1 while (chomp($answer = $queue{$nick}->dequeue) && $answer eq ""); goto THREAD_EXIT if $answer =~ /^(reset|start over)/o; $master->down; $answer =~ s/^\s+|\s+$//gos; return lc $answer; } sub reconsider { my $head = shift; my $path = shift || $head->[PATH]; $head->[PATH] = $path; for my $i (YES, NO) { my $node = $head->[$i]; if (ref($node)) { reconsider( $node, $path . $i ); } elsif ($node) { $index->{lc $node} = $path . $i; } } yield; } sub unlearn { my ($parent, $actual) = @_; my $other = $index->{lc $actual}; my @that = split //, $other; my @this = split //, $parent->[PATH]; my $node = $tree; my $i; # Find out where the decision trees diverge. for ($i = 0; $this[$i] eq $that[$i]; $node = $node->[$this[$i++]] ) {} # Get the wrong answer. my $parity = $that[$i]; my $wrong = ($parity eq YES ? "yes" : "no" ); if ($node) { say "Previously, when discussing a $actual, I asked", "'$node->[QUERY]' I was told $wrong. Is this incorrect?"; if ( answer_is_yes ) { $parity = pop @that; $node = $node->[$that[$_]] for $i .. $#that; $node->[$parity] = ""; } } else { debug "Bad index '$other' for answer '$actual'?"; } } sub learn { my ($parent, $mistake) = @_; my ($actual, $query, $answer, $converse); if ($parent->[YES] eq $mistake) { $answer = YES; $converse = NO; } else { $answer = NO; $converse = YES; } say "I give up. What animal were you thinking of?"; $actual = answer_freely; $actual =~ s/^(?:a|an|the)\s+|\W+$//gos; # If we've already heard about this, see what we learned wrong. # unlearn( $parent, $actual ) if $index->{lc $actual}; # If we already have a distinguishing question for this mistaken # answer, but no converse, try asking the question we know. # unless ( $parent->[$converse] ) { say "I've never heard of a $actual.", $parent->[QUERY]; if (answer_is_yes xor $answer eq YES) { $parent->[$converse] = $actual; $converse = 0; } } # Otherwise, ask for a new distinguishing question. # if ($converse) { say "I see. What is a question that would distinguish a $actual from", ( $mistake ? "a $mistake" : "something else" ), "?"; while (( $query = ucfirst answer_freely ) !~ /\?$/o) { say "Is that really a question about ${actual}s?", "Tell me to start over if you're confused."; } say "For a $actual, the answer would be?\n"; my $dest = &share([]); push @$dest, "", $query; if (answer_is_yes) { push @$dest, $actual, $mistake; } else { push @$dest, $mistake, $actual; } $parent->[$answer] = $dest; } reconsider( $parent ); say "Got it." } sub conclude { my ($parent, $node) = @_; say "Is it a $node?"; if (answer_is_yes) { say "I knew it all along!"; } else { learn($parent, $node); } } sub ask { my $node = shift; my ($path, $query, $yes, $no) = @$node; debug "Considering $node => [@$node]"; if ($yes and $no) { my $answer; say $query; if (answer_is_yes) { ponder($node, $yes); } else { ponder($node, $no); } } else { ponder($node, $yes || $no); # Fall-through } } sub ponder { my ($node, $branch) = @_; if (ref $branch eq "ARRAY") { ask($branch); } elsif ($branch) { conclude($node, $branch); } else { learn($node, ""); } } ######################################## sub deep_share { my @stuff : shared; for (@_) { if (ref $_) { my $dest = &share([]); push @$dest, deep_share(@$_); push @stuff, $dest; } else { push @stuff, $_; } } return @stuff; } sub checkpoint { $master->down; DumpFile( DBFILE, $tree ); $master->up; } sub get_nick { my $event = shift; return join("/", $event->nick, $event->to); } sub handle_user { my $event = shift; my @notice : shared = $nick = get_nick($event); debug "Started new thread for $nick"; say( "Think of an animal, and I will try to guess what it is." ); $master->down; ask( $tree ); $master->up; checkpoint; THREAD_EXIT: say "Ask me to guess again?"; debug "Finishing thread for $nick"; $out->enqueue(\@notice); # Note that we're done. } sub handle_msg { my ($conn, $event) = @_; my $who = get_nick($event); my ($data) = $event->args; return unless $event->format eq "msg" or $data =~ /^@{[NICK]}\s*\W\s*(.*)/o; if ($queue{$who}) { my $msg = $1 || $data; debug "Queuing for $who: $msg"; $queue{$who}->enqueue($msg); } else { debug "Starting new thread for $who"; $queue{$who} = Thread::Queue->new; my $thr = threads->create( \&handle_user, $event ); $thr->detach; } } sub handle_login { my ($conn, $event) = @_; debug "Connected, joining", IRC_CHAN; $conn->join(IRC_CHAN); $conn->privmsg(IRC_CHAN, "Hello, my name is ", NICK, ". Please ask me to play twenty questions with you. ", "(Please feel free to /msg me, if you prefer.)"); } if (-r DBFILE) { my $thing = LoadFile( DBFILE ); ($tree) = deep_share($thing); } else { push @$tree, "", "Does it fly?", "sparrow", "salmon"; } reconsider( $tree ); debug "Initalized decision tree: [@$tree]"; debug "Connecting to", IRC_HOST; my $irc = Net::IRC->new; my $conn = $irc->newconn( Server => IRC_HOST, Nick => NICK ); $conn->add_handler( endofmotd => \&handle_login ); $conn->add_handler( public => \&handle_msg ); $conn->add_handler( msg => \&handle_msg ); while (1) { $irc->do_one_loop; while (defined( my $data = $out->dequeue_nb )) { if (defined $data->[1]) { $conn->privmsg( @$data ); } else { delete $queue{$data->[0]}; } } }