#!/usr/bin/perl

# Configuration #############################################

$text_font   = '-*-courier-regular-r-*-*-14-*-*-*-*-*-*-*';
$big_font    = '-*-charter-bold-r-*-*-60-*-*-*-*-*-*-*';
$status_font = '-*-charter-bold-r-*-*-24-*-*-*-*-*-*-*';
$dict_file   = 'ptkboggle.dict';

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

package Dict;

sub TIEHASH {
  my $class = shift;
  my ($fh, $partial) = @_;
  my $self = {};
  
  $self->{fh} = $fh;
  $self->{partial} = $partial;
  return bless $self, $class;
}

sub FETCH {
  my ($self, $word) = @_;
  my ($fh, $partial) = ($self->{fh}, $self->{partial});
  seek $fh, 0, 0 or die $!;
 OUTER:
  while(1) {
	my ($s);
	read $fh, $s, 1 or die $!;
	my ($w) = unpack "c", $s;

	return 1 if ($w >= 0 and $word eq "");
	return $partial if $word eq "";
	for (1..abs($w)) {
	  read $fh, $s, 1;
	  my ($c) = unpack "c", $s;
	  read $fh, $s, 3;

	  if (ord(substr($word, 0, 1)) - (ord 'A') + 1 == $c) {
		seek $fh, (unpack "l", ($s . "\x0")), 0;
		$word =~ s/^.//;
		next OUTER;
	  }
	}
	return 0;
  }
}

package main;

use Tk;

sub valid_words {
  my ($x, $y, $str, %seen) = @_;
  my @vw = ();
  return if $seen{"$x,$y"};
  $seen{"$x,$y"} = 1;
  $str .= $board[$x * 4 + $y];
  push @vw, $str if $w{uc $str};
  if ($p{uc $str}) {
	push @vw, valid_words($x-1, $y-1, $str, %seen) if ($x > 0 && $y > 0);
	push @vw, valid_words($x, $y-1, $str, %seen) if ($y > 0);
	push @vw, valid_words($x+1, $y-1, $str, %seen) if ($x < 3 && $y > 0);
	push @vw, valid_words($x-1, $y, $str, %seen) if ($x > 0);
	push @vw, valid_words($x+1, $y, $str, %seen) if ($x < 3);
	push @vw, valid_words($x-1, $y+1, $str, %seen) if ($x > 0 && $y < 3);
	push @vw, valid_words($x, $y+1, $str, %seen) if ($y < 3);
	push @vw, valid_words($x+1, $y+1, $str, %seen) if ($x < 3 && $y < 3);
  }
  return @vw;
}

sub check_word {
  return unless $game && !$paused;
  my $wrd = uc $e->get();
  $e->delete(0,"end");

  if ($seen_word{$wrd}) { 
	hilite_line($seen, $seen_word{$wrd}, "yellow");
	return;
  }
  if ($seen_invalid_word{$wrd}) {
	hilite_line($seen_invalid, $seen_invalid_word{$wrd}, "red");
	return;
  }
  if (!$valid_word{$wrd}) {
	$seen_invalid->insert("end", "$wrd\n");
	$seen_invalid_word{$wrd} = ++$cur_seen_invalid;
	hilite_line($seen_invalid, $seen_invalid_word{$wrd}, "red");
	return;
  }
  $seen->insert("end", "$wrd\n");
  $seen_word{$wrd} = ++$cur_seen;
  hilite_line($seen, $seen_word{$wrd}, "green");
  $score++;
}

$mw = MainWindow->new();

@dice = ("ednosw", "aaciot", "acelrs", "ehinps",
         "eefhiy", "elpstu", "acdemp", "gilruw",
         "egkluy", "ahmors", "abilty", "adenvz",
         "bfiorx", "dknotu", "abjmoq", "egintv");

my $menubar = $mw->Frame
  (
   -relief => 'raised', -borderwidth => 2,
  )->pack(-side => "top", -fill => "x");

my $file_menubutton = $menubar->Menubutton
  (
   qw/-text File -underline 0 -menuitems/ =>
   [
	[Button => '~New Game', -accelerator => "n", -command => \&file_new_game],
	[Button => '~Pause', -accelerator => "p", -command => \&file_pause],
	[Separator => ''],
	[Button => '~Quit', -accelerator => "q", -command => \&file_quit],
   ]
  )->pack(-side => "left");

$f = $mw->Frame->pack(-side => "top");
$c = $f->Canvas(-width => 400, -height => 400, -background => "white")->pack(-side => "left");

for ( [\$seen, "Seen"], [\$seen_invalid, "Invalid"], [\$missed, "Missed"] ) {
  my ($t, $label) = @$_;
  my $f2 = $f->Frame->pack(-side => "left");
  $f2->Label(-text => $label)->pack();
  $$t = $f2->Scrolled("ROText", -scrollbars => "oe", -width => 15, -height => 30,
					  -font => $text_font, 
					 )->pack();
}


$e = $mw->Entry()->pack(-side => "top", -expand => 1, -fill => "x");
$e->bind("<Key-Return>", \&check_word);
  for $i (0..3) {
	for $j (0..3) {
	  $letters[$i + 4 * $j] = $c->createText($i * 100 + 50, $j * 100 + 50, -text => "?", 
											 -justify => "center", -anchor => "c",
											 -font => $big_font,
											 -tags => ['die'],
											);
	}
}

$mw->Label(-textvariable => \$status,
		   -font => $status_font,
)->pack();

sub redo_board {
  $c->itemconfigure("die", -fill => "black");
  for $i (0..3) {
	for $j (0..3) {
	  $c->itemconfigure($letters[$i + 4 * $j], -text => $board[$i + 4 * $j]);
	}
  }
}

sub clear_board {
  $c->itemconfigure("die", -text => "?");
}

sub clear_line {
  foreach ($seen, $seen_invalid) {
	$_->tagDelete("hilite");
  }
} 

sub hilite_line {
  my ($text, $line, $color) = @_;
  clear_line();
  $text->tagAdd("hilite", "$line.0", ($line + 1) . ".0");
  $text->tagConfigure("hilite", -background => $color);
  $text->see("$line.0");
}

sub timer_handler {
  unless (--$time) {
	end_game(); 
	return;
  } 
  $status = sprintf "%d:%02d", $time / 60, $time % 60;
}

sub file_new_game {
  $score = 0;
  $time = 180;
  if ($game) {
	end_game();
  }
  $timer = $mw->repeat(1000, \&timer_handler);
  $game = 1;
  $e->focus();
  
  @board = 
	map {$_ eq "Q" ? "Qu" : $_}
	map {uc(substr($_->[0],rand(6),1))} 
	sort {$a->[1]<=>$b->[1]} 
	map {[$_,rand()]} 
	@dice;

  foreach($seen, $seen_invalid, $missed) {
	$_->delete("1.0", "end");
  }
  $cur_seen = 0;
  $cur_seen_invalid = 0;

  %valid_word = ();
  %seen_word = ();
  %seen_invalid_word = ();
  for $i (0..3) {
	for $j (0..3) {
	  $valid_word{uc $_} = 1 for valid_words($i, $j);
	}
  }

  $e->delete(0, "end");
  redo_board();
}

sub end_game {
  $mw->afterCancel($timer);
  $game = 0;
  clear_line();
  $status = "Score: $score/" . (scalar keys %valid_word) . "   ". sprintf("%.2f", 100 * ($score / keys %valid_word)) .  "%\n";
  foreach (sort grep {!$seen_word{$_}} keys %valid_word) {
	$missed->insert("end", "$_\n");
  }
  $c->itemconfigure("die", -fill => "gray");
}

sub file_pause {
  return unless $game;
  if ($paused) {
	$paused = 0;
	redo_board();
	$timer = $mw->repeat(1000, \&timer_handler);
  }
  else {
	$paused = 1;
	$mw->afterCancel($timer);
	clear_board();
	$status = "Paused";
  }
}

sub file_quit {
  exit;
}

$|=1;  

open(IN, $dict_file) or die $!;
tie %p, 'Dict', \*IN, 1 or die $!;
tie %w, 'Dict', \*IN    or die $!;

MainLoop();