#!/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]};
	}
    }
}