anagram interactive

fr listbox experiments: mousewheel selection and circular shifts
enter some text and jumble the characters, spaces included
 package require Tk
 wm title . "Tcl/Tk anagram"
 proc main {} {
   catch {destroy .f}
   frame .f
   label .f.l -text "\nTurn an anagram\nlistboxes go round\nclick or turn mousewheel"
   pack .f.l
   entry .f.e -textvariable ::tv
   button .f.b -command build -text reset
   pack .f
   bind .f.e <Return> build
   bind TURN <ButtonPress-1> {click %W %y}
   bind TURN <MouseWheel> {roll %W %D }
   if {![regexp ^Windows $:env(OS)]} {
      bind all <Button-4> {event generate [focus -displayof %W] <MouseWheel> -delta  120}
     bind all <Button-5> {event generate [focus -displayof %W] <MouseWheel> -delta -120}
   } else {
     bind . <F1> {console show}
   }
   bind TURN <Enter> {prepare %W}
   pack .f.e .f.b -side top -pady 10 -padx 5
 }
 proc build {} {
   set ll [lsort [split $::tv ""]]
   set ::full $ll
   set ::cp $::full
   set ::uu [lsort -unique $::cp]
   set ulen [llength $::uu]
   incr ulen
   set l [llength $::full]
   set lbf .f.f
   catch {destroy $lbf}
   foreach x [info vars ::lv_*] {unset $x}
   frame $lbf
   set ::nr [list]
   set font {Courier 12}
   set values [concat {{}} $::uu]
   listbox $lbf.h -listvariable ::nr -width 2 -font $font -borderwidth 0 -bg [$lbf cget -bg] -height $ulen -takefocus 1
   bind $lbf.h <Enter> {focus -force %W}
   bind $lbf.h <MouseWheel> {horiz %D}
   pack $lbf.h -side left
   for {set n 0} {$n < $l} {incr n} {
     set dez [format %02d $n]
     set lb [listbox $lbf._$n \
     -highlightcolor yellow \
     -borderwidth 0 \
     -width 2 \
     -font $font \
     -height $ulen \
     -takefocus 1 -activestyle dotbox -listvariable ::lv_$dez ]
     set ::lv_$dez $values
     pack $lb -side left -anchor n
     set bi [bindtags $lb]
     lset bi 1 TURN
     bindtags $lb $bi
    }  
   for {set i 0} {$i<$ulen} {incr i} {lappend ::nr $i}
   pack $lbf
 }
 proc horiz {D} {
   set tmp [lsort [info vars ::lv_*]]
   if {$D} {
     set lvs $tmp
     lappend lvs [lindex $lvs 0]
     set values [list]
     foreach n $lvs {lappend values [set $n]}
     foreach [lrange $lvs 0 end-1] [lrange $values 1 end] {break}
   } else {
     set lvs [lindex $tmp end]
     set lvs [concat [list [lindex $tmp end]] [lrange $tmp 0 end-1]]
     set values [list]
     foreach n $lvs {lappend values [set $n]}
     foreach $tmp $values {break}
   }
 }
 proc prepare {w} {
   if {![string equal [focus -displayof .] {}]} {
     set top [$w get 0]
     set ::cp $::full
     lappend ::cp ""
     foreach x [winfo children .f.f] {
       if {![string equal $w $x]} {
         set item [$x get 0]
         if {$item != {}} {
           set pos [lsearch $::cp $item]
           if {[expr {$pos >= 0}]} {
             lset ::cp $pos {}
           }
         }
       }
     }
     set lv [$w cget -listvariable]
     set tmp [lsort -unique $::cp]
     if {[llength $tmp] == 2} {
       set tmp [lsort -decr $tmp]
     }
     set tpos [lsearch $tmp $top]
     if {$tpos > 0} {
       set tmp [concat [lrange $tmp $tpos end] [lrange $tmp 0 [expr {$tpos-1}]]]
     }
     if {[llength $tmp] == 2} {
       set tt ""
       foreach x [winfo children [winfo parent $w]] {
         if {[regexp {[0-9]$} $x]} {
           set c [$x get 0]
           expr {[string equal $c ""] ? [append tt "_"] : [append tt $c]}
         }
       }
       wm title . $tt
     }
     $w configure -height [llength $tmp]
     eval {set $lv $tmp}
     focus -force $w
   }
 }
 
 
 proc roll {w d} {
   set lv [$w cget -listvariable]
   set tmp [set $lv]
   if {$d<0} {
     eval {set $lv [concat [list [lindex $tmp end]] [lrange $tmp 0 end-1]]}
   } else {
     eval {set $lv [concat [lrange $tmp 1 end] [list [lindex $tmp 0]]]}
   }
   $w activate 0
   return -code break
 }
 proc shift_to {list act {dest 0}} {
 # circular shift list index act to index dest
   upvar $list li
   set l [llength $li]
   set tmp [concat $li $li]
   set start [expr {$act - $dest}]
   if {$start<0} {incr start $l}
   set end [expr {$start + $l -1}]
   return [lrange $tmp $start $end] 
 }
 proc click {w y} {
   set lv [$w cget -listvariable]
   eval {set $lv [shift_to $lv [$w nearest $y]]}
   return -code break
 }
 main
Category Toys