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