jt.pl

#!/usr/bin/perl -w

# JumbleTime-style quiz program. Copyright(C) Amit Chakrabarti, 2003-2007.
# Last updated Tue Feb 6 18:44:53 EST 2007.
#
# Modifying this program is allowed. If you add any interesting features
# please notify me by email: <amitc at ias dot edu>. I will try to keep
# a "latest" version of this program at the following URL:
#           http://www.cs.princeton.edu/~amitc/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 SENATOR TREASON -
#        aeinort 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);

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

my ($num_qs, $quiz_duration) = (64, 200);    # 50 questions, 300 seconds
my $requiz_prob = 0.0;                       # Prob to redo a seen question
my ($numcols, $width, $height) = (8, 11, 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];

# ---> Read the words and select a random subset for the quiz. <---
open T, $filename or die "Cannot open $filename: $!";
@words = <T>;
@words = map {[ split ' ' ]} grep !/^#/, @words;
cls;
for(($i,$lineno,$ttl) = (0,0,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;
  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
close T;
unless($num_qs)  {
  print "Couldn't find anything unsolved.\n";
  exit 0;
}

# ---> Do the quiz itself. <---
my $promptrow = 1 + (1 + int($num_qs / $numcols)) * $height;
my $num_unsolved = $num_qs;
eval  {
  local $SIG{ALRM} = sub { die "alarm\n" };
  alarm $quiz_duration;
  do  {
    my $resp = getresp();
    die "alarm\n" if $resp eq "XXX";  # Fake timeout if user entered 'XXX'

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

# ---> Quiz over; either we timed out or all questions were solved. <---
if($@)  {
  die "Something bad happened at '$@'\n" unless $@ eq "alarm\n";
  print locate($promptrow,0), clline, 
    "Time'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 $timeleft = alarm 0;
  print locate($promptrow,0), clline, "Done!\n$timeleft 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;


# ---> Accept keyboard input. <---
sub getresp  {
  my $line;
  do  {
    print locate($promptrow,0), clline, "Solution: ";
    $line = <STDIN>;
    $line =~ s/[\-+\s\e\[\]]//g;  
  } while $line eq "";
  chomp $line;
  uc $line;
}


# ---> 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;
}