#!/opt/bin/perl

# lots of things have been hardcoded. search for #d# to find the places

require 5.008;

use KGS::Protocol;
use KGS::Listener::Debug;

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

use Getopt::Long;
use Carp;

our $VERSION = '0.0'; # be more confident....

$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };

my $conn = new KGS::Protocol;
my $kgs;
my $gtp;

my $verbose = 1;
my $user = "gtpguest";
my $pass = undef;

$Event::DIED = sub {
   Event::verbose_exception_handler (@_);
   Event::unloop_all;
};

sub format_user($) {
   my $format =
      sprintf "%s|%s|%s",
         $_[0]{name},
         $_[0]->flags_string,
         $_[0]->rank_string;

   $format =~ y/ //d;
   $format;
}

sub coord($$) {
   qw(A B C D E F G H J K L M N O P Q R S T U V W X Y Z)[$_[0]] . $_[1];
}

#############################################################################

package kgs;

use base KGS::Listener;

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;

   print STDERR "$0 version $VERSION connecting...\n" if $verbose;

   my $sock = new IO::Socket::INET PeerHost => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
      or die "connect: $!";

   $sock->blocking (1);
   $conn->handshake ($sock);

   $self->listen ($conn, "any");

   # Listener for kgs data
   $self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
      my $len = sysread $sock, my $buf, 16384;
      if ($len) {
         $conn->feed_data ($buf);
      } elsif (defined $len || (!$!{EINTR} and !$!{EAGAIN})) {
         print STDERR "disconnected\n" if $verbose;
         Event::unloop;
      }
   });

   $conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});

   $self;
}

sub inject_login {
   my ($self, $msg) = @_;

   print STDERR "login: $msg->{message}\n" if $verbose >= 2;

   $gtp->send ("kgs-login $msg->{message}");

#   use KGS::Listener::User;
#   $user = new KGS::Listener::User name => "tetra";
#   $user->listen ($self->{conn});
#   $user->game_record;
}

sub inject_msg_room {
   my ($self, $msg) = @_;

   $gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
}

sub inject_any {
   my ($self, $msg) = @_;
   if ($verbose >= 2) {
      print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
      for (sort keys %$msg) {
         print  STDERR"   $_<$msg->{$_}>";
      }
      print STDERR "\n";
   }
}

sub inject_upd_rooms {
   my ($self, $msg) = @_;

   for (@{$msg->{rooms}}) {
      $gtp->send ("kgs-room-update $_->{channel} $_->{name}");
   }
}

sub inject_msg_chat {
   my ($self, $msg) = @_;

   return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});

   $gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
}

sub inject_new_game {
   my ($self, $msg) = @_;

   $::lastnew = $msg->{channel};#d#
   $gtp->send ("kgs-game-new $msg->{cid} $msg->{channel}");
}

#############################################################################

package room;

use base KGS::Listener::Room;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_join {
   my $self = shift;

   $self->SUPER::join (@_);

   $self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
      $self->req_games;
   });
}

sub event_update_games {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
                  $self->{channel}, $_->{channel},
                  $_->type_char,
                  ::format_user $_->{black},
                  ::format_user $_->{white},
                  ::format_user $_->{owner},
                  $_->size,
                  $_->{handicap},
                  $_->{komi},
                  $_->moves,
                  $_->{flags},
                  $_->{observers},
                  $_->{saved},
                  $_->{notes},
      );
   }

   for (@$del) {
      $gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
   }
}

sub event_update_users {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub DESTROY {
   my $self = shift;

   $self->{timer}->cancel if $self->{timer};

   $self->SUPER::DESTROY;
}

#############################################################################

package game;

use Gtk2::GoBoard::Constants;

use base KGS::Listener::Game;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_update_users {
   return;

   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub inject_resign_game {
   my ($self, $msg) = @_;

   $gtp->set_gid ($self->{channel});
   $gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
}

sub inject_final_result {
   my ($self, $msg) = @_;

   $gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
               $_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
               $_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
}

sub inject_set_teacher {
   my ($self, $msg) = @_;
}

sub event_update_game {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   # timesettings etc.
}

sub event_update_tree {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   my $path = $self->get_path;
   my $prev = $self->{prevpath};

   $self->{prevpath} = [ @$path ];

   if (@$prev > 1
       and @$path > @$prev
       and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {

      splice @$path, @prev, $#path, ();

   } else {
      $gtp->send ("boardsize $path->[0]{rules}{size}");
      $gtp->send ("komi $path->[0]{rules}{komi}");
      $gtp->send ("clear_board");

      my $setup = shift @$path;
      my $handi;

      while (my ($k, $v) = each %$setup) {
         if ($k =~ /^(\d+),(\d+)$/) {
            $handi .= " " . ::coord $1, $2;
         }
      }

      $gtp->send ("set_free_handicap$handi");
   }

   for (@$path) {
      while (my ($k, $v) = each %$_) {
         if ($k =~ /^(\d+),(\d+)$/) {
            if ($v->[0] & MARK_MOVE) {
               if ($v->[0] & MARK_B) {
                  $gtp->send ("play b ". ::coord $1, $2);
               } else {
                  $gtp->send ("play w ". ::coord $1, $2);
               }
            }
         }
      }
   }
}

sub DESTROY {
   my $self = shift;

   $self->SUPER::DESTROY;
}

#############################################################################

package gtp;

use Gtk2::GoBoard::Constants;
use KGS::Constants;

use Fcntl;

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

sub set_fh {
   my ($self, $rfh, $wfh) = @_;

   $self->{r} = $rfh;
   $self->{w} = $wfh;

   fcntl $rfh, F_SETFL, O_NONBLOCK;

   my $buf;

   Event->io (fd => $rfh, poll => 'r', cb => sub {
      my $r = sysread $rfh, $buf, 16384, length $buf;

      if (defined $r and !$r) {
         die "gtp engine sent EOF, I'm simply dying now, sorry\n";
      } else {
         $buf =~ y/\010\015/ /d;
         $buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
         while () {
            if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
               print STDERR "got response ($1|$2|$3)\n" if $verbose >= 2;

               if (my $cb = delete $self->{waitq}{$2}) {
                  $cb->($1, $3);
               } else {
                  warn "WARNING: got response if '$1 $2' without outstanding request\n";
               }
            } elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
               $self->parse_command ($1, $2);
            } elsif ($buf =~ s/^\s*\012//) {
               # ignore, idiotic part of gtp spec
            } else {
               last;
            }
         }
      }
   });

   # generate login commands
   $self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
   $self->send ("name", sub { $self->{name} = $_[1] });#d#
   $self->send ("version", sub { $self->{version} = $_[1] });
}

sub run_engine {
   my ($self, @argv) = @_;

   require IPC::Open2;

   my ($r, $w);

   IPC::Open2::open2 ($r, $w, @argv)
      or die "unable to start @argv: $!";

   $self->set_fh ($r, $w);
}

sub send {
   my ($self, $cmd, $cb) = @_;

   # first check for known_command

   my $id = ++$self->{id};

   $cmd =~ y/\015//d;
   $cmd =~ s/\012/\\n/g;

   $self->{waitq}{$id} = $cb || sub { };
   print { $self->{w} } "$id $cmd\012";
}

sub reply {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "=$id $response\012";
}

sub reply_err {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "?$id $response\012";
}

sub parse_command {
   my ($self, $id, $cmd) = @_;

   print STDERR "got command $cmd\n" if $verbose >= 2;

   $cmd =~ s/\s+$//;

   if ($cmd eq "kgs-room-list") {
      # no args, just request all rooms
      $kgs->send (list_rooms => group => $_) for 0..5;
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
      $kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
      $kgs->{room}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
      (delete $kgs->{room}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
      $kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
      $kgs->{game}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
      (delete $kgs->{game}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
      $kgs->send (msg_chat =>
                  name => $kgs->{user},
                  name2 => $1,
                  message => $2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-game-new-demo\s+(\d+)\s+(\d+)$/) {
      my $tid = $conn->alloc_clientid;
      $kgs->send (new_game =>
                  channel  => $1,
                  cid      => $tid,
                  type     => 0,
                  rules => {
                     ruleset  => 0,
                     size     => $2,
                     komi     => 0,
                     timesys  => 0,
                     time     => 0,
                     interval => 0,
                     count    => 0,
                  });
      $self->reply ($id, $tid);
   } elsif ($cmd =~ /^kgs-game-edit\s+(\d+)\s+(.*)$/) {
      my $gid = $1 || $::lastnew;#d#
      my $spec = $2;
      my @tree = ();
      while ($spec =~ s/^([a-z])(\d+)\s+\+?(\S+)\s*//) { # should use mg
         my ($x, $y, $spec) = ($1, $2, $3);
         my $add = $spec !~ s/^-//;
         $x = index "abcdefghjklmnopqrstuvwxyz", lc $x;
         $y--;

         if ($spec eq "b")                { push @tree, [set_stone => 0, $x, $y];
         } elsif ($spec eq "w")           { push @tree, [set_stone => 1, $x, $y];
         } elsif ($spec eq "n")           { push @tree, [set_stone => 2, $x, $y];
         } elsif ($spec eq "sb")          { push @tree, [mark => $add, MARK_SMALL_B, $x, $y];
         } elsif ($spec eq "sw")          { push @tree, [mark => $add, MARK_SMALL_W, $x, $y];
         } elsif ($spec eq "sn")          { push @tree, [mark =>    0, MARK_SMALL_B, $x, $y];
         } elsif ($spec eq "triangle")    { push @tree, [mark => $add, MARK_TRIANGLE, $x, $y];
         } elsif ($spec eq "square")      { push @tree, [mark => $add, MARK_SQUARE, $x, $y];
         } elsif ($spec eq "circle")      { push @tree, [mark => $add, MARK_CIRCLE, $x, $y];
         } elsif ($spec =~ /label=(\S+)/) { push @tree, [mark => length $1, MARK_LABEL, $x, $y, $1];
         } elsif ($spec eq "grayed")      { push @tree, [mark => $add, MARK_GRAYED, $x, $y];
         } else {
            $self->reply_err ($id, "illegal edit spec '$spec'");
            return;
         }
      }
      $kgs->send (upd_tree =>
                  channel => $gid,
                  tree => \@tree);
      $self->reply ($id, "");
   
   } else {
      $self->reply_err ($id, "illegal command");
   }
}

sub set_gid {
   my ($self, $gid) = @_;

   if ($gid != $self->{gid}) {
      $self->send ("kgs-game-id $gid");
      $self->{gid} = $gid;
   }
}

package main;

sub usage {
   print STDERR <<EOF;
Usage: $0 [options] -- engine engine-args...
           -u username    usernmae to connect
           -p password    optional password to connect (none => guest)
           -v             increase verbosity
           -q             decrease verbosity

$0 connects to the kiseido go server, starts the named engine
and communicates with it using GTP protocol using it's stdin and stdout.

If no engine is given, uses stdin/stdout itself for communications.

The engine can optionally act as controller, too, as long as it isn't
confused by responses on it's command input stream.

Command extension used by the controller:

kgs-login message
kgs-room-update <rid> <name>          # update room info
kgs-room-chat <rid> <user> <message>  # somebody says sth.
kgs-game-update <rid> <gid> <type> <black> <white> \
                <owner> <size> <handicap> <komi> <moves> \
                <flags> <observers> <saved> <notes>
kgs-game-delete <rid> <gid>           # game removed
kgs-user-update <rid> <user>          # user added/updated   
kgs-user-delete <rid> <user>          # user removed

kgs-game-resign <gid> <color>
kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
kgs-game-id <gid>                     # set id for following gid-less commands

kgs-user-chat <user> <message>        # got private message from user
kgs-game-new <tid> <gid>              # a new game was created with temporary id <tid>
...

Commands usable by the client as commands issued to the controller:

kgs-room-list                         # ask for roomlist update
kgs-room-join <rid>                   # join given room
kgs-room-chat <rid> <message>         # say sth. in room
kgs-room-part <rid>                   # leave gives room

kgs-game-join <gid>                   # join the given game
kgs-game-part <gid>                   # leave the given game
kgs-game-chat <gid> <message>         # say sth.

kgs-user-chat <user> <message>        # send private msg to user
kgs-game-new-demo <rid> <size>        # create new demo game (other agruments might get added)
                                      # returns a temporary game id
kgs-game-edit <gid> <coord> <editspec> <coord> <editspec>...
                                      # editspec is one of
                                      #    b|w|n        set black/white/no stone
                                      #    sb|sw|sn     set/clear black/white/no small stone
                                      #    [+-]triangle set/clear triangle
                                      #    [+-]square   set/clear square
                                      #    [+-]circle   set/clear circle
                                      #    [+-]grayed   set/clear grayed-flag
                                      #    label=xyz    set label to xyz
...

EOF
   exit shift;
}

GetOptions (
      "u=s" => \$user,
      "v"   => sub { $verbose++ },
      "q"   => sub { $verbose-- },
      "h"   => sub { usage(0) },
) or die usage(1);

$gtp = new gtp;

if (@ARGV) {
   $gtp->run_engine (@ARGV);
} else {
   $gtp->set_fh (\*STDIN, \*STDOUT);
}

$kgs = new kgs user => $user, password => $pass;

Event::loop;

1;