#!/usr/bin/perl -w
#
# written on 2003-07-14 by  Willem Jan Hengeveld  <itsme@xs4all.nl>  
#    some fixes on 2003-07-15, to make it handle losing better.

# web: http://www.xs4all.nl/~itsme/projects/sites
#
# if not running with perl5.8,  List::Util must be installed seperately

use strict;

use Dumpvalue;
my $d= Dumpvalue->new();

$|=1;

#############################################################################
# this is a simple interface to a webserver.
package WebServer;
use HTTP::Request::Common qw(POST GET);
use LWP::UserAgent;

use List::Util qw(first);

sub new {
    my ($class, $baseurl)= @_;

    my $ua= LWP::UserAgent->new(agent=>'wetenschapsbot/1.0');

    return bless {
        ua=>$ua,
        baseurl=>$baseurl,
    }, $class;
}
# almost interface compatible with httpost
#   - optional hashref with parameters is merged with parameters.
#
# httpget("/some.cgi", key1=>123, key2=>455);
# httpget("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#
sub httpget {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $uri= URI->new($self->{baseurl});
    $uri->path($path);
    $uri->query_form($query?%$query:(), %params);
    my $rq= GET $uri;

    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    return $rp->content;
}

# can be called in several ways:
# httppost("/some.cgi", key1=>123, key2=>455);
#   -> just form values
# httppost("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#   -> both url and form params
# httppost("/some.cgi", key1=>123, key2=>455, file1=>["filename"]);
#   -> form-data file upload
sub httppost {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $uri= URI->new($self->{baseurl});
    $uri->path($path);
    $uri->query_form(%$query) if ($query);
    my $rq= POST $uri, [ %params ];

    # -- for http uploads : 
    # ( Content_Type=>"form-data", Content=>[ %params ]);

    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    return $rp->content;
}

sub httprequest {
    my ($self, $method, @params)= @_;
    if (lc($method) eq "get") {
        return $self->httpget(@params);
    }
    elsif (lc($method) eq "post") {
        return $self->httppost(@params);
    }
    else {
        die "invalid http request method '$method'\n";
    }
}

package NetspanningServer;

use URI::Escape;
sub new {
    my ($class, $webserver)= @_;

    return bless {
        ref $webserver?(ws=>$webserver):(ws=>WebServer->new($webserver)),
    }, $class;
}

sub requeststatic {
    my ($self, $url)= @_;

    my $answer= $self->{ws}->httprequest("GET", $url);

    my %result;
    for (split /&/, $answer) {
        if (/(.*)=(.*)/) {
            my $key= uri_unescape($1);
            my $value= uri_unescape($2);

            $result{$key}= $value;
        }
    }

    return \%result;
}

sub request {
    my ($self, $url, $request)= @_;

    my $answer= $self->{ws}->httprequest("POST", $url, %$request);

    my %result;
    for (split /&/, $answer) {
        if (/(.*)=(.*)/) {
            my $key= uri_unescape($1);
            my $value= uri_unescape($2);

            $result{$key}= $value;
        }
    }

    return \%result;
}

package Wetenschapkwis;

sub new {
    my ($class, $server)= @_;

    return bless {
        ref $server?(ws=>$server):(ws=>NetspanningServer->new($server)),
    }, $class;
}


package main;

use IO::File;

my $wk= new NetspanningServer(new WebServer("http://forum.vpro.nl"));

my $info= $wk->requeststatic("/wetenschap/netspanning/game.shtml");

# $info->{server}  = "http://forum.vpro.nl/vpro"

my $g_newentries=0;
my $g_dbanswers= 0;
# to keep track of old answers
my $database= LoadDatabase("wetenschapskwis.db");

PlayGame($wk, $info, $database);
#print map { "question: $_->{question}\nanswer: $_->{answer}\n\n"; } values %$database;
SaveDatabase("wetenschapskwis.db", $database);

print("$g_newentries new db entries,  $g_dbanswers questions answered from database\n");
print(scalar keys %$database, " total entries in database\n");

sub PlayGame {
    my ($wk, $info, $database)= @_;

    my $game= $wk->request("/vpro/$info->{aanmeldURL}", {login=>"gast"});

    my @players;    # names of all players
    my @score;
    my $spelerno;   # which player am I?
    my $round= 0;

    my @nrinround= map { $game->{"vragenR$_"} } (1,2,3);
    my $questionnr;
    my @questions;

    my $id= $game->{id};

    my %usedcategories;
    $usedcategories{$_}= 0 for map { $info->{"categorie$_"} } (1..9);

    while(1) {
        my $params= {time=>$game->{time}||"", id=>$game->{id}||$id};
        my $url= $game->{url};

        # create new request
        if (!defined $url) {
            print "??? no continuation url specified\n";
            print "??? request $url {", join(",", map { "$_=>$params->{$_}" } keys %$params), "}\n";
            print "??? answer {", join(",", map { "$_=>$game->{$_}" } keys %$game), "}\n";
            last;
        }
        elsif ($url eq "do.AvatarS") {
            # entering new game
            # received info on other players
        }
        elsif ($url eq "do.CategorieS") {
            # last question answered
            if ($game->{kiezer} eq "1") {
                $params->{cat}=ChooseCategory(\%usedcategories);
            }
            else {
                $params->{cat}="noppo";
            }
        }
        elsif ($url eq "do.AntwoordS") {
            # question answered
            # possibly received list of new questions

            # if answer is unsure, and round 3, pick higher value for tijd.
            my $answer= LookupAnswer($questions[$questionnr], $database);
            $params->{antwoord}= $answer || qw(a b c)[int(rand(3))];
            $params->{tijd}= (($round<3 || $answer) ? 0 : 5) + int(rand(3));
        }
        else {
            print "end of game\n";
            last;
        }

        sleep(1) ; # +rand(2);
        #print "\nrequest $url {", join(",", map { "$_=>$params->{$_}" } keys %$params), "}\n";
        $game= $wk->request("/vpro/$url", $params);

        #print "answer {", join(",", map { "$_=>$game->{$_}" } keys %$game), "}\n";

        # process answer
        if ($url eq "do.AvatarS") {
            # received info on other players
            $spelerno= $game->{spelerno};
            @players= map { $game->{"speler$_"} || "" } (1,2,3);

            print "players: @players\n";
        }
        elsif ($url eq "do.CategorieS") {
            if (!$game->{cat}) {
                print "??? expected category in reply to categories request\n";
                print "??? request $url {", join(",", map { "$_=>$params->{$_}" } keys %$params), "}\n";
                print "??? answer {", join(",", map { "$_=>$game->{$_}" } keys %$game), "}\n";
                last;   # something wrong
            }
            # received list of new questions ( round 1 + 2 )
            $usedcategories{$game->{cat}}=1;
        }
        elsif ($url eq "do.AntwoordS") {
            # question answered
            if (!$game->{goedeantwoord}) {
                print "??? missing variable goedeantwoord\n";
                print "??? request $url {", join(",", map { "$_=>$params->{$_}" } keys %$params), "}\n";
                print "??? answer {", join(",", map { "$_=>$game->{$_}" } keys %$game), "}\n";
                last;   # seems we have incorrectly assumed we are still playing.
            }
            if (!exists $questions[$questionnr]->{$game->{goedeantwoord}}) {
                print "??? expecting to find answer for 'goedeantwoord' in ", join(",", keys %{$questions[$questionnr]}), "\n";
                print "??? request $url {", join(",", map { "$_=>$params->{$_}" } keys %$params), "}\n";
                print "??? answer {", join(",", map { "$_=>$game->{$_}" } keys %$game), "}\n";
                last;
            }
            $questions[$questionnr]->{answer}= $questions[$questionnr]->{$game->{goedeantwoord}};
            @score= map { $game->{"score$_"} } (1,2,3);
            print join("  ", map { "$players[$_-1]=$score[$_-1]" } grep { defined $score[$_-1] && $score[$_-1] ne "" } (1,2,3) ), "\n";

            $questionnr++;
        }

        if (grep { defined $game->{"gaatdoor$_"} } (1,2,3)) {
            print join(" ", map { qq($players[$_-1]=$game->{"gaatdoor$_"}) } grep { defined $game->{"gaatdoor$_"} } (1,2,3) ) , "\n";
        }

        if (exists $game->{v1}) {
            if (@questions) {
                SaveAnswers(\@questions, $database);
            }
            $round++;
            @questions= ();
            for (my $i=1 ; exists $game->{"v$i"} ; $i++) {
                $questions[$i-1]= {
                    question=>$game->{"v$i"},
                    a=>$game->{"a$i"},
                    b=>$game->{"b$i"},
                    c=>$game->{"c$i"},
                    category=>(exists $game->{cat}?$game->{cat}:$game->{"cat$i"}),
                } 
            }
            $questionnr= 0;

            PrintQuestions(\@questions);
        }
    }

    if (@questions) {
        SaveAnswers(\@questions, $database);
    }
}

exit(0);

sub ChooseCategory {
    my ($usedcats)= @_;

    for (keys %$usedcats) {
        if ($usedcats->{$_}==0) {
            return $_;
        }
    }
    return "noppo";
}
sub LookupAnswer {
    my ($question, $database)= @_;
    if (exists $database->{$question->{question}} 
            && exists $database->{$question->{question}}{answer}) {
        my $answer= $database->{$question->{question}}{answer};
        for (qw(a b c)) {
            if ($question->{$_} eq $answer) {
                print "\nFROM DATABASE: $_\n";
                $g_dbanswers++;
                return $_;
            }
        }
        print "!!! answer not found in new question: $question->{question}\n";
    }
    return undef;
}
sub SaveAnswers {
    my ($questions, $database)= @_;

    for my $q (@$questions) {
        if (!exists $database->{$q->{question}}) {
            $g_newentries++;
            $database->{$q->{question}}= $q;
        }
        else {
            if ($q->{answer} && $database->{$q->{question}}{answer} ne $q->{answer}) {
                print "!!! answer changed: $q->{question}\n";
                print "   old : $database->{$q->{question}}{answer}\n";
                print "   new : $q->{answer}\n";
                # probably due to old cut+paste error, fixing it.
                $database->{$q->{question}}{answer}= $q->{answer};
            }
        }
    }
}
sub PrintQuestions {
    my ($questions)= @_;
    for my $q (@$questions) {
        print "question: $q->{question}\n";
        print map { "    $_ : $q->{$_}\n"; } (qw(a b c));
    }
}
sub LoadDatabase {
    my ($fn)= @_;
    my %database;

    my $fh= IO::File->new($fn, "r");

    my $i=0;
    my $q;
    $/="\x00";
    while (<$fh>) {
        s/\x00$//;
        if ($i&1) {
            $database{$q}= {question=>$q, answer=>$_};
        }
        else {
            $q= $_;
        }
        $i++;
    }
    $fh->close();

    return \%database;
}
sub SaveDatabase {
    my ($fn, $database)= @_;

    my $fh= IO::File->new($fn, "w+");

    for my $q (sort { $a->{question} cmp $b->{question} } values %$database)
    {
        $fh->print("$q->{question}\x00$q->{answer}\x00");
    }
    $fh->close();
}