use Tk;use Tk::ROText;$mw=new MainWindow;$x='Searching anagrams';$tpj='the perl journal';$wo='Jon rape';my@f=qw(-fill both);@p=(@f,'-expand',1);my @sl=qw( side left);$f=$mw->Frame->pack( @f);$l=$f->Label(-width=>30)->pack(@sl , @f);$f->Label(-text=>'   You search anagrams of:')->pack(@sl,@f);$e=$f->Entry(-textvariable=>\$tpj)->pack(@sl,@f);$t=$mw->Entry(-textvariable=>\$wo)->pack(@f);$u=$mw->Scrolled('ROText',-scrollbars => 'w', -wrap => 'word' )->pack(@p);;$s=$mw->Scrolled('ROText', -scrollbars => 'w')->pack(@p);for($t,$e){$_->bind('<Return>',\&re)}for($u,$s){$_->bind('<Double-1>',\&add)}sub re{if($state eq'done'){&doit}else{$state='unstack'}}sub add{$wo.=' '.$_[0]->get('sel.first', 'sel.last');re;}$,=$"=" ";die"missing dict file: $!" unless open F,@ARGV?$ARGV[0]:"/usr/dict/words";my@i=(<F>,'perl');@w=map{chomp;$_}@i;sub up {$mw->updateWidgets;}sub sent {%j=();$j='';grep{m/\w/&&$j{$_}++ } split'',$_[0];grep{$j.=$_.'-'x$j{$_}}sort keys %j;}sub calc{calcword( $_)for sort{lc$a cmp lc$b}@w}sub cand{ $l->configure(-text => "selecting candidate wo"); $u->delete("1.0", "end"); up;grep{if($j=~m/$qr{$_}/){$u->insert("end","$_ ");up;$_;}}@_;}sub calcword { my($w)=@_; my (%a, $m);$l->configure(-text=>'Processing dictionnary (long)');grep{m/\w/&&$a{lc($_)}++}split'',$w;grep{$m.=$_.'-'x$a{$_}.".*"}sort keys%a;$m{$w}=$m;$qr{$w}= qr/$m/;}sub addword{local$_=shift;up;return 0 if$j!~m/$qr{$_}/;$j=~s/(?<=$1)$2// while $m{$_}=~ m/(\w)(-*)\.*/g;$j=~s/(\w+)(?=(\w|$))//g;push @a,$_;if ($j eq''){$n++; $s->insert('end', "@a\n");$l->configure(-text => "$x: $n found");up }1}sub srch{my$a=shift;local@wo=@_;$l->configure(-text => "$x: $n found");   rec($j, @$a); }sub rec {up;return if$state eq 'unstack';for(@wo){local($j,@a)=@_;&rec($j,@a)if addword $_}}sub doit{do{$n=0;$state='srch';@a='';sent $tpj;while(1){calcword $wo;last if addword$wo or$wo eq '';chop $wo; $mw->bell}calc;my @w0=cand @w;$s->delete("1.0","end");srch(\@a,@w0);$l->configure(-text =>"Done: $n anagrams found");}while($state ne'srch');$state='done';Tk::MainLoop;}doit;
