#!/usr/bin/perl -w

# Original Author: Phil Carmody 
# (The FatPhil associated with asdf.org and fatphil.org)
# Placed in the Public Domain 2011-11-11

use strict qw(subs refs vars);
use Tk;
use Tk::LabEntry;
use Tk::BrowseEntry;
use Tk::Adjuster;
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );

my $theDictionaryFile=$ENV{'ANDICT'};
if(!$theDictionaryFile or !-f $theDictionaryFile) { $theDictionaryFile=$ENV{'DICT'}; }
if(!$theDictionaryFile or !-f $theDictionaryFile) { $theDictionaryFile='/usr/share/dict/words'; }

my $thePhrase='';
my $theWords='';
my @theWordList=();
my $theLetters='';
my $theMinWordLen=1;
my $theMaxWords=10;
my $theMaxNum=100000;
my $theConfigBoxVisible=0;
my $theNumWords='#words/time';
my $theNumAnagrams='#grams/time';
my $stackSave=0;
my $undo;

my ($background,$textcolour)=('black','yellow');
my $mainWindow=MainWindow->new;
#$mainWindow->optionAdd('*font', 'Helvetica 16');
$mainWindow->setPalette(background=>$background, foreground=>$textcolour);
$mainWindow->title("An Affront!");
my $fontSize=16;
my $fontBold=$mainWindow->fontCreate(-size => $fontSize);
my $fontSmall=$mainWindow->fontCreate(-size => $fontSize*.75);
my $fontNorm=$mainWindow->fontCreate(-size => $fontSize);

my $tlConfig;

my $pPhrase=$mainWindow->Frame;
my $lPhrase=$pPhrase->Label(-text => 'Phrase:', -font=>$fontBold);
my $ePhrase=$pPhrase->Entry(-textvariable => \$thePhrase, -exportselection => 1, -font=>$fontNorm);
my $bvClear=0;
sub clearWords
{
    $undo=['clearWords',$thePhrase] if($thePhrase);
    $thePhrase='';
    $theLetters='';
    $bvClear=0;
}
sub undoClearWords
{
    if(ref($undo) and $undo->[0] eq 'clearWords') {
	$thePhrase=$undo->[1];
	$theLetters='';
	$undo=undef;
    }
}
my $bClear=$pPhrase->Checkbutton(-text=>'Clear',
				 -underline=>0,
				 -font=>$fontSmall,
				 -indicatoron=>0,
				 -variable=>\$bvClear,
				 -command=>\&clearWords);
$bClear->bind('<Button-3>',\&undoClearWords);
	      
my $pWords=$mainWindow->Frame;
my $lWords=$pWords->Label(-text => 'Words:', -font=>$fontBold);
my $eWords=$pWords->Entry(-textvariable => \$theWords, -exportselection => 1, -font=>$fontNorm);
my $bvDelWord=0;
sub deleteLastWord
{
    $undo=['deleteLastWord',$1] if($theWords =~ s/\s*(\S+)\s*$//);
    $bvDelWord=0;
}
sub undoDeleteLastWord
{
    if(ref($undo) and $undo->[0] eq 'deleteLastWord') {
	$theWords =~ s/\s*$/ $undo->[1]/;
	$undo=undef;
    }
}
my $bDelWord=$pWords->Checkbutton(-text=>'Remove',
				  -underline=>0,
				  -font=>$fontSmall,
                                  -indicatoron=>0,
                                  -variable=>\$bvDelWord,
                                  -command=>\&deleteLastWord,);
$bDelWord->bind('<Button-3>', \&undoDeleteLastWord);

my $pStack=$mainWindow->Frame;
my $theStackTop='';
my @theStack=(); # [phrase, words]
my $theStackRebuiltFrom='';
my $iStackTopIndex=undef;
my $stackSaveFile=($ENV{'HOME'}//'.')."/.anaffront_hist";

sub stackRebuild
{
    print STDERR ("return if(!$_[1] and $thePhrase eq $theStackRebuiltFrom);\n");
    return if(!$_[1] and $thePhrase eq $theStackRebuiltFrom);
    my $widg=$_[0];
    my @fordisplay=map {
	print STDERR ($_->[1] . ((!$_->[1] || $_->[0] ne $thePhrase) ? " ($_->[0])" : '') . "\n");
	$_->[1] . ((!$_->[1] || $_->[0] ne $thePhrase) ? " ($_->[0])" : '');
    } @theStack;
    $widg->choices(\@fordisplay);
    $theStackRebuiltFrom=$thePhrase;
}
sub stackSelect
{
    my $widg=$_[0];
    $iStackTopIndex=$_[1];
    $thePhrase=$theStack[$iStackTopIndex]->[0];
    $theWords=$theStack[$iStackTopIndex]->[1];
    $theLetters='';
    stackRebuild($widg);
    $theStackTop=$widg->get($iStackTopIndex);
}
my $lStack=$pStack->Label(-text=>'Stack:', -font=>$fontBold);
my $eStack=$pStack->BrowseEntry(-font => $fontNorm,
				-variable => \$theStackTop,
				-listcmd => \&stackRebuild,
                                -browse2cmd => \&stackSelect,
				-background => $background,
				-colorstate => 1,
				-state => 'readonly');

sub stackDontHave
{
    my ($p,$w)=@_;
    return 0 if(!$p);
    my @phrasematch=grep { $_->[0] eq $p } (@theStack);
    return 1 if(!@phrasematch);
    return 0 if(!$w);
    return (grep { $_->[1] eq $w } @phrasematch) ? 0 : 1;
}
sub stackStoreArb
{
    my ($index,$phrase,$words)=@_;
    print STDERR ("my ($index,$phrase,$words)=\@_;\n");
    if(stackDontHave($phrase,$words)) {
	$theStackTop=$words;
	splice(@theStack,$index,0,[$phrase,$words]);
	$eStack->insert($index, $words);
	$iStackTopIndex=$index;
	stackRebuild($eStack,1);
	stackSave() if($stackSave);
    }
    else { print STDERR "not storing\n"; }
}
sub stackStore { stackStoreArb(0,$thePhrase,$theWords); }
sub stackDrop
{
    return if(!defined($iStackTopIndex));
    $eStack->delete($iStackTopIndex, $iStackTopIndex);
    my $drop=splice(@theStack,$iStackTopIndex,1);
    $undo=['stackDrop',[$iStackTopIndex,$drop->[0],$drop->[1]]];
    print STDERR ("\$undo=['stackDrop',[$iStackTopIndex,$drop->[0],$drop->[1]]];\n");
    stackRebuild($eStack);
    stackSave() if($stackSave);
    if($iStackTopIndex>0) {
	--$iStackTopIndex;
    }
    $theStackTop=$eStack->get($iStackTopIndex) || '';
    if(!length($theStackTop)) { $iStackTopIndex=undef; }
}
sub undoStackDrop
{
    if(ref($undo) and $undo->[0] eq 'stackDrop') {
	stackStoreArb(@{$undo->[1]});
	$undo=undef;
    }
}
sub stackSave
{
    if(!open(S, ">", $stackSaveFile)) {
	print STDERR ("Stack save to '$stackSaveFile' failed\n");
	return;
    }
    foreach(@theStack) {
	my ($p,$w)=@$_;
	$p =~ s/\s+/ /;
	$w =~ s/\s+/ /;
	print S ("$p\t-\t$w\n");
    }
    close(S);
}
sub stackRestore
{
    if(!open(S, "<", $stackSaveFile)) {
	print STDERR ("Stack restore from '$stackSaveFile' failed\n");
	return;
    }
    while(<S>) {
	my ($p,$w)=($_=~m/^(.*?)\t-\t(.*?)$/);
	push(@theStack, [$p,$w]);
	$eStack->insert('end', $theWords);
    }
    close(S);
    stackRebuild($eStack,1);
    $stackSave=1;
}
stackRestore();

my $bPushStack=$pStack->Button(-text=>'store', -font=>$fontSmall,
			       -padx=>0,
			       -pady=>0,
			       -command=>\&stackStore,);
my $bDropStack=$pStack->Button(-text=>'drop', -font=>$fontSmall,
                               -padx=>0, -pady=>0,
                               -command=>\&stackDrop,);
$bDropStack->bind('<Button-3>', \&undoStackDrop);

my $pAction=$mainWindow->Frame;
my $bvGetDict=0;
my $lNumWords=$pAction->Label(-textvariable => \$theNumWords, -font=>$fontSmall);
my $eWContains=$pAction->Entry(-textvariable => \$theLetters, -font=>$fontSmall,
			       -width=>4,
			       -validate => 'key', -validatecommand => \&filterDict);
my $bGetDict=$pAction->Checkbutton(-text=>'Get Words!',
				   -underline=>4,
				   -font=>$fontSmall,
                                   -indicatoron=>0,
                                   -variable=>\$bvGetDict,
                                   -command=>\&getDict);
my $cbConfigure=$pAction->Checkbutton(-text=>'Configuration', -font=>$fontSmall,
                                      -indicatoron=>0,
                                      -variable=>\$theConfigBoxVisible,
                                      -command=>\&configure);
my $bvGetAnagrams=0;
my $bGetAnagrams=$pAction->Checkbutton(-text=>'Get Anagrams',
				       -underline=>0,
				       -font=>$fontSmall,
                                       -indicatoron=>0,
                                       -variable=>\$bvGetAnagrams,
                                       -command=>\&getAnagrams);
my $lNumAnagrams=$pAction->Label(-textvariable => \$theNumAnagrams, -font=>$fontSmall);

my $slDict=$mainWindow->Scrolled('Listbox',
				 -font=>$fontNorm,
				 -scrollbars=>'e',
				 -selectmode=>'single');
$slDict->bind('<Double-Button-1>', \&selectWord);
$slDict->bind('<Button-3>', \&gotoWord);
my $adj1=$mainWindow->Adjuster();
my $slAnag=$mainWindow->Scrolled('Listbox',
				 -font=>$fontNorm,
				 -scrollbars=>'e',
				 -selectmode=>'single');
my $lastPrint;
$slAnag->bind('<Double-Button-1>', \&selectAnagram);
$slAnag->bind('<Button-3>', \&nextWord);

$lPhrase->pack(-side=>'left');
$bClear->pack(-side=>'right');
$ePhrase->pack(-side=>'right', -expand=>1, -fill=>'x');
$pPhrase->pack(-side=>'top', -fill=>'x');

$lWords->pack(-side=>'left');
$bDelWord->pack(-side=>'right');
$eWords->pack(-side=>'left', -expand=>1, -fill=>'x');
$pWords->pack(-side=>'top', -fill=>'x');

$bDropStack->pack(-side=>'right');
$bPushStack->pack(-side=>'right');
$lStack->pack(-side=>'left');
$eStack->pack(-side=>'left', -expand=>1, -fill=>'x');
$pStack->pack(-side=>'top', -fill=>'x');

$lNumWords->pack(-side=>'left');
$eWContains->pack(-side=>'left');
$bGetDict->pack(-side=>'left');
$lNumAnagrams->pack(-side=>'right');
$bGetAnagrams->pack(-side=>'right');
$cbConfigure->pack(-side=>'left');
$pAction->pack(-side=>'top');

$slDict->pack(-side=>'left', -fill=>'y');
$adj1->packAfter($slDict, -side => 'left');
$slAnag->pack(-side=>'right', -fill=>'both', -expand=>1);

sub setFont
{
    $fontSize+=$_[0]//0;
    $mainWindow->fontConfigure($fontBold, -size=>$fontSize);
    $mainWindow->fontConfigure($fontSmall, -size=>$fontSize*.75);
    $mainWindow->fontConfigure($fontNorm, -size=>$fontSize);
}

$mainWindow->bind("<Control-Key-q>", sub { exit(); });
$mainWindow->bind("<Control-Key-plus>", sub { setFont(+1); });
$mainWindow->bind("<Control-Key-minus>", sub { setFont(-1); });
$mainWindow->bind("<Control-Key-KP_Add>", sub { setFont(+2); });
$mainWindow->bind("<Control-Key-KP_Subtract>", sub { setFont(-2); });
$mainWindow->bind("<Control-Button-4>", sub { setFont(+1); });
$mainWindow->bind("<Control-Button-5>", sub { setFont(-1); });
$mainWindow->bind("<Control-Key-Left>", sub { $adj1->delta_width(-1); });
$mainWindow->bind("<Control-Key-Right>", sub { $adj1->delta_width(+1); });
$mainWindow->bind("<Control-Key-KP_Left>", sub { $adj1->delta_width(-5); });
$mainWindow->bind("<Control-Key-KP_Right>", sub { $adj1->delta_width(+5); });
$mainWindow->bind("<Control-w>", sub { $bvGetDict=1; getDict(); });
$mainWindow->bind("<Control-g>", sub { $bvGetAnagrams=1; getAnagrams(); });
$mainWindow->bind("<Control-r>", sub { $bvDelWord=1; deleteLastWord(); });
$mainWindow->bind("<Control-c>", sub { $bvClear=1; clearWords(); });
$mainWindow->bind('<Control-n>', \&nextWord);

sub filterDict
{
    # The proposed value of the Entry (the value of the text variable too)
    # The characters to be added or deleted; undef if called due to focus, explicit call, or change in text variable
    # The current value before the proposed change
    # The index of the string to be added/deleted, if any; otherwise, -1
    # The type of action: 1 for insert, 0 for delete, -1 if a forced validation or text variable validation
    my ($prop,$adddel,$old,$idx,$action)=@_;
    $slDict->delete(0,'end');
    if($prop ne '')
    {
	my $letterre=join('.*',sort(split('',$prop)));
	my $word=join('',sort(split('',$thePhrase)));
	return 0 if($adddel and $word!~m/$letterre/i);
        my @fdict=grep { $word=join('',sort(split('',$_))); $word=~m/$letterre/i; } @theWordList;
        $slDict->insert('end',@fdict);
    }
    else
    {
        $slDict->insert('end',@theWordList);
    }
    return 1;
}


sub getDict
{
    if($bvGetDict && -r $theDictionaryFile)
    {
        my $time = [gettimeofday];
        my $dict    =" -d '$theDictionaryFile'";
        my $used    =$theWords;
	$used=~s/[^[:alpha:] ]//g;
	if($used) { $used=" -u '$used'"; }
        my $phrase=$thePhrase; 
        $phrase=~s/[^[:alpha:]]//g;
        my $minlen  =$theMinWordLen>1?" -m $theMinWordLen":'';
        @theWordList=();
        if(open(AN, "an $dict$used$minlen -w '$phrase'|"))
        {
            while(<AN>) { chomp; push(@theWordList, $_); }
            close(AN);
        }
        else
        {
            print STDERR "Command failed: $@\nan $dict$used$minlen -w '$phrase'|";
	}
	filterDict($theLetters,undef,$theLetters,-1,-1);
        my $elapsed = int(100*tv_interval( $time, [gettimeofday])+.5)/100;
        $theNumWords = scalar(@theWordList)."w in ${elapsed}s.";
    }
    $bvGetDict=0;
}

sub getAnagrams
{
    if($bvGetAnagrams && -r $theDictionaryFile)
    {
        my $time = [gettimeofday];
        my $dict    =$theDictionaryFile?" -d '$theDictionaryFile'":'';
        my $used    =$theWords;
	$used=~s/[^[:alpha:] ]//g;
	if($used) { $used=" -c '$used'"; } # faster than -u and rebuild
        my $phrase=$thePhrase; 
        $phrase=~s/[^[:alpha:]]//g;
        my $maxnum  =$theMaxNum      ?" -n $theMaxNum":'';
        my $maxwords=$theMaxWords<10 ?" -l $theMaxWords":'';
        open(AN, "an $dict$used$maxnum$maxwords '$phrase'|");
        my @grams=();
	while(<AN>) { chomp; push(@grams, $_); } # faster than block read
        close(AN);
        my $elapsed = int(100*tv_interval( $time, [gettimeofday])+.5)/100;
        $theNumAnagrams = scalar(@grams)." in ${elapsed}s.";
        $slAnag->delete(0,'end');
        $slAnag->insert('end',@grams);
    }
    $bvGetAnagrams=0;
}

sub selectWord
{
    my @words=();
    if($theWords)
    {
        @words=split(/\s+/, $theWords);
        if(!$words[0]) { shift(@words); }
        if(!$words[-1]) { pop(@words); }
    }
    push @words, $slDict->get($slDict->curselection());
    $theWords = join(' ', @words);
}
sub selectAnagram
{
    print((($lastPrint and $lastPrint eq $thePhrase) ? "" : $thePhrase),
	  " = ",
	  $slAnag->get($slAnag->curselection()),
	  "\n");
    $lastPrint = $thePhrase;
}
sub nextWord
{
    my $ev=$_[0]->XEvent;
    my $i=$slAnag->nearest($ev->T eq 'ButtonPress' ? $ev->y : 0);
    my $end=$slAnag->size();
    my $line=$slAnag->get($i);
    my $ci=0;
    while($ci<length($theWords) and substr($theWords,$ci,1) eq substr($line,$ci,1)) {
	++$ci;
    }
    my ($nextword)=(substr($line,$ci)=~m/^(\s*\S+.?)/);
    my $prefix=substr($line,0,$ci+length($nextword));
    my $plen=length($prefix);
    #print STDERR ("next word is '$nextword', so prefix is '$prefix'\n");
    while($i<$end and substr($slAnag->get($i),0,$plen) eq $prefix) { ++$i; }
    $slAnag->yview($i);
}
sub gotoWord
{
    my $ev=$_[0]->XEvent;
    my $i=$slAnag->nearest($ev->y);
    my $end=$slAnag->size();
    my $line=$slAnag->get($i);
    $i=0;
    while($i<$end and $slAnag->get($i)=~m/\b$theWords/) { ++$i; }
    $slAnag->yview($i) if($i<$end);
}

sub configure
{
    if(!$theConfigBoxVisible)
    {
        $tlConfig->withdraw();
    }
    elsif(!$tlConfig)
    {
        $tlConfig=$mainWindow->Toplevel();
        $tlConfig->title('Configure An Affront');
        $tlConfig->Button(-text => 'Close', 
                          -command=>sub { $tlConfig->withdraw(); $theConfigBoxVisible=0; })
            ->pack();
	$tlConfig->Checkbutton(-text => 'Save Stack',
			       -onvalue => 1,
			       -offvalue => 0,
			       -variable => \$stackSave)
	    ->pack(-expand=>1, -fill=>'x');
        $tlConfig->LabEntry(-label => 'dictionary', 
                            -textvariable => \$theDictionaryFile)
            ->pack(-expand=>1, -fill=>'x');
        $tlConfig->Scale(-label=>'dictionary min word length', 
                         -variable=>\$theMinWordLen, 
                         -from=>1, -to=>12, 
                         -orient=>'horizontal')
            ->pack(-expand=>1, -fill=>'x');
        $tlConfig->Scale(-label=>'Font Size',
                         -variable=>\$fontSize,
                         -from=>8, -to=>48,
                         -orient=>'horizontal',
			 -command=>sub { setFont(0); },)
            ->pack(-expand=>1, -fill=>'x');
    }
    else
    {
        $tlConfig->deiconify();
        $tlConfig->raise();
    }
}

MainLoop;