#!/usr/bin/env perl

# JumbleTime-style quiz program. Copyright(C) Amit Chakrabarti, 2003-2053.
#
# Modifying this program is allowed. If you add any interesting features
# please notify me by email: <amitc at cs dot dartmouth etc>. I will try to keep
# a "latest" version of this program at the following URL:
#           http://www.cs.dartmouth.edu/~ac/Scrab/jt
#
# Functionality: Display a bunch of alphagrams on the screen in a grid,
# wait for user to solve them and type the words in, erasing alphagrams
# as they get fully solved.
#
# Input file must have lines of the following format:
#	 aenorst ATONERS SANTERO SENATOR TREASON -
#        aeinort NOTAIRE OTARINE +
# and it is very important that the alphagram be lowercase! The final
# +/- on the line indicates question seen before (+) or new (-). This
# program is not robust, so the input file had better be well behaved;
# thus, no duplicate entries, no blank lines, no funny stuff.
#
# Inspired by the applet at http://www.jumbletime.com; try that out too!

use strict;
use Term::ANSIScreen qw(:all);
use AnyEvent;

die "USAGE: jt <inputfile> [<duration> <requiz_prob> <prompt>]\n" if $#ARGV < 0;

my ($num_qs, $quiz_duration) = (50, 300);    # 50 questions, 300 seconds
my $requiz_prob = 0.1;                       # Prob to redo a seen question
my ($numcols, $width, $height) = (6, 13, 2); # Display parameters
my (@words, @picked, @counts, $i, $lineno, $ttl);
my $filename = shift;
$quiz_duration = shift if defined $ARGV[0];
$requiz_prob = shift if defined $ARGV[0];
my $prompt = shift || "Solution: ";
$| = 1;  # Force autoflush on STDOUT


# ---> Read words, select random subset for quiz, show selected words. <---
open T, $filename or die "Cannot open $filename: $!";
@words = map {[ split ' ' ]} grep !/^#/, <T>;
close T;
cls;
for(($i,$lineno,$ttl) = (0,0,1+100*$#words); $i < $num_qs && $ttl; $ttl--)  {
  # If $requiz_prob negative, pick next free word, else a random word
  my $rnd = $requiz_prob < 0 ? $lineno++ : int rand @words;
  last if $rnd > $#words;
  next if join(' ', @picked) =~ /\b$rnd\b/;
  next if $words[$rnd][-1] =~ /\+/ && rand > $requiz_prob;
  push @picked, $rnd;
  push @counts, $#{$words[$rnd]} - 1;
  update($i++);
}
$num_qs = $i;   # Needed in case we quit the loop due to $ttl
die "Couldn't find anything unsolved.\n" unless $num_qs;


# ---> Set up the quiz. <---
my $promptrow = 1 + (1 + int($num_qs / $numcols)) * $height;
my $num_unsolved = $num_qs;
print locate($promptrow,0), clline, $prompt;
my $cv = AE::cv;
my $deadline = $quiz_duration + AE::now;


# ---> Update the countdown timer. <---
my $time_watcher = AE::timer 0, 1, sub {
  my $time_left = $deadline - AE::now;
  savepos;
  print locate($promptrow+1,0), clline, int $time_left, " seconds remaining";
  loadpos;
  $cv->send if $time_left < 0.1;
};


# ---> Read keyboard input and update quiz state as needed. <---
my $kbd_watcher = AE::io *STDIN, 0, sub {
  chomp(my $resp = <STDIN>);
  $resp =~ s/[\-+\s\e\[\]]//g;  
  $resp =~ s/\./#/;  $resp = uc $resp;
  $cv->send if $resp eq "XXX";  # Fake timeout if user entered 'XXX'

  if($resp)  {
    for(my ($i,$found)=(0,0); $i < $num_qs && !$found; $i++)  {
      if(join(' ', @{$words[$picked[$i]]}) =~ / $resp /)  {  
        $found = 1;
	$words[$picked[$i]] = [ map {/$resp/?lc:$_} @{$words[$picked[$i]]} ];
        if(--$counts[$i] == 0)
	  { erase($i); $num_unsolved--; }
        else
	  { update($i); }
      }
    }
  } 
  $cv->send unless $num_unsolved;

  print locate($promptrow,0), clline, $prompt;
};


# ---> Do the quiz itself. <---
$cv->recv;


# ---> Display results. <---
print locate($promptrow,0), clline;
if($num_unsolved)  {
  print "\nTime's up! You missed $num_unsolved/$num_qs:\n";
  for(my $i=0; $i<$num_qs; $i++)  {
    print join(' ', @{$words[$picked[$i]]}), "\n" if $counts[$i];
  }
}
else  {
  my $time_left = int($deadline - AE::now);
  print "Done!\n$time_left seconds to spare.\n";
}


# ---> Update the JT file marking questions solved this session. <---
open T, ">$filename" or die "Cannot write to $filename: $!";
my $idx = 0;
my %indexof = map { $_ => $idx++ } @picked;
for my $j (0 .. $#words)  {
  print T shift @{$words[$j]}, " ";
  my $line = uc join(' ', @{$words[$j]});
  if(exists $indexof{$j})  {
    $line =~ s/\+/-/ if $counts[$indexof{$j}];  # Mark '-' if unsolved
    $line =~ s/-/+/ if !$counts[$indexof{$j}];  # Mark '+' if solved
  }
  print T "$line\n";
}
close T;
0;


# ---> Erase a solved question. <---
sub erase {
  use integer;
  savepos;
  my $i = shift;
  my $row = 1 + ($i / $numcols) * $height;
  my $col = 1 + ($i % $numcols) * $width;
  print locate($row,$col), ' ' x $width;
  loadpos;
}


# ---> Print a question (alphagram), updating #anagrams left to solve. <---
sub update {
  use integer;
  savepos;
  my $i = shift;
  my $row = 1 + ($i / $numcols) * $height;
  my $col = 1 + ($i % $numcols) * $width;
  my $mult = $counts[$i] > 1 ? " $counts[$i]" : "  ";
  print locate($row,$col), uc $words[$picked[$i]][0], RED, "$mult ", RESET;
  loadpos;
}