scripts/spinner.itcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 # Signals fired:
   4 #       onselect(newvalue)      - New value selected
   5
   6 class tlc::Spinner {
   7         inherit tlc::Border tlc::Signalsource tlc::Textvariable tlc::Handlers
   8
   9         constructor {args} {}
  10         destructor      {}
  11
  12         public {
  13                 variable state                  "normal"
  14                 variable wrap                   0
  15                 variable choices                {}
  16                 variable value                  ""      seekvalue
  17                 variable pagelength             5       rebindpage
  18                 variable zoom_memory    2000            ;# in ms
  19
  20                 method move {delta}
  21                 method moveto {sel_idx}
  22                 method next {{delta 1}}
  23                 method prev {{delta 1}}
  24                 method last {{offset 0}}
  25                 method first {{offset 0}}
  26                 method last_idx {}
  27                 method popdown {}
  28                 method set_choice {newidx args}
  29         }
  30
  31         protected {
  32                 variable idx                    0
  33
  34                 method update_view {}
  35                 method seekvalue {}
  36                 method rebindpage {}
  37                 method textvariable_changed {newvalue}
  38         }
  39
  40         private {
  41                 variable toggles
  42                 variable last_zoom_ms
  43                 variable zoom_spec              ""
  44                 variable popup_obj
  45                 variable choices_init   1
  46                 variable oldvalue
  47
  48                 common upimg
  49                 common downimg
  50                 common upimg_refcount
  51                 common downimg_refcount
  52
  53                 method reset {}
  54                 method validate_input {newval}
  55                 method scrollwheel {delta}
  56                 method zoom {char}
  57                 method binding {args}
  58                 method popup {}
  59                 method toggle_popup {}
  60                 method statechanged {newstate}
  61                 method choices_set_changed {newstate}
  62         }
  63 }
  64
  65
  66 configbody tlc::Spinner::value { #<<<1
  67         if {$value == "" && [info exists oldvalue]} {
  68                 set value       $oldvalue
  69         }
  70         set oldvalue    $value
  71         seekvalue
  72 }
  73
  74
  75 configbody tlc::Spinner::choices { #<<<1
  76         if {$choices_init} {
  77                 set choices_init        0
  78         } else {
  79                 puts stderr "choices: ([join $choices |]) value: ($value)"
  80                 $signals(choices_set) set_state 1
  81         }
  82         reset
  83 }
  84
  85
  86 configbody tlc::Spinner::state { #<<<1
  87         log debug "state: ($state)"
  88         [stategate_ref] configure -default [expr {$state == "normal"}]
  89 }
  90
  91
  92 body tlc::Spinner::constructor {args} { #<<<1
  93         array set toggles       {}
  94
  95         tlc::Signal #auto signals(valid) -name "$w valid"
  96         tlc::Signal #auto signals(choices_set) -name "$w choices_set"
  97
  98         $signals(choices_set) attach_output [code $this choices_set_changed]
  99
 100         # Initialize bitmaps <<<
 101         if {![info exists upimg]} {
 102                 set upimg       [image create bitmap \
 103                                 -file [file join $::tlc::library scripts images spinup.xbm] \
 104                                 -foreground $tlc::config(enabledforeground)]
 105                 set upimg_refcount              1
 106         } else {
 107                 incr upimg_refcount
 108         }
 109
 110         if {![info exists downimg]} {
 111                 set downimg     [image create bitmap \
 112                                 -file [file join $::tlc::library scripts images spindown.xbm] \
 113                                 -foreground $tlc::config(enabledforeground)]
 114                 set downimg_refcount    1
 115         } else {
 116                 incr downimg_refcount
 117         }
 118         # Initialize bitmaps >>>
 119
 120         # Border hacks <<<
 121         $itk_component(border) configure \
 122                         -highlightthickness 1 \
 123                         -takefocus 1 \
 124                         -highlightcolor black
 125         tlc::StateToggle #auto toggles(border) $itk_component(border) \
 126                         -takefocus {0 1}
 127         $toggles(border) attach_signal [stategate_ref]
 128         bind $itk_component(border).inner <FocusIn> \
 129                         [code focus $itk_component(border)]
 130         # Border hacks >>>
 131
 132         # Entry <<<
 133         itk_component add entry {
 134                 entry $w.entry -borderwidth 0 -highlightthickness 0 -state disabled \
 135                                 -validate all -validatecommand [code $this validate_input %P]
 136         } {
 137                 keep -width
 138                 rename -background -textbackground textBackground TextBackground
 139         }
 140         set enabled_fg          [$tlc::theme setting foreground]
 141         set enabled_bg          [$tlc::theme setting textbackground]
 142         set disabled_fg         [$tlc::theme setting disabledforeground]
 143         set disabled_bg         [$tlc::theme setting disabledbackground]
 144         tlc::StateToggle #auto toggles(entry) $itk_component(entry) \
 145                         -foreground [list $disabled_fg $enabled_fg] \
 146                         -background [list $disabled_bg $enabled_bg] \
 147                         -disabledforeground [list $disabled_fg $enabled_fg] \
 148                         -disabledbackground [list $disabled_bg $enabled_bg]
 149         $toggles(entry) attach_signal [stategate_ref]
 150         # Entry >>>
 151
 152         # Spin buttons <<<
 153         option add *$wdb.Button.takeFocus                       0
 154         option add *$wdb.Button.borderWidth                     1
 155         option add *$wdb.Button.padX                            2
 156         option add *$wdb.Button.width                           10
 157         option add *$wdb.Button.padY                            0
 158         option add *$wdb.Button.highlightThickness      0
 159
 160         button $w.up -image $upimg -command [code $this prev]
 161         tlc::StateToggle #auto toggles(up) $w.up \
 162                         -state {disabled normal}
 163         $toggles(up) attach_input [stategate_ref]
 164
 165         button $w.down -image $downimg -command [code $this next]
 166         tlc::StateToggle #auto toggles(down) $w.down \
 167                         -state {disabled normal}
 168         $toggles(down) attach_input [stategate_ref]
 169         # Spin buttons >>>
 170
 171         # Popup <<<
 172         itk_component add popup {
 173                 tlc::Comboselect $w.#auto -parent $this
 174         } {
 175                 keep -maxheight -textbackground
 176                 rename -listwidth -width width Width
 177         }
 178         set popup_obj   $itk_component(popup)
 179         # Popup >>>
 180
 181         blt::table $w \
 182                         $w.entry        1,1 -rspan 2 -fill both \
 183                         $w.up           1,2 -fill y \
 184                         $w.down         2,2 -fill y
 185         blt::table configure $w c2 -resize none
 186
 187         eval itk_initialize     $args
 188
 189         set baselog_instancename        $w
 190
 191         set listend             [expr {[llength $choices] - 1}]
 192         if {$listend < 0} {set listend 0}
 193
 194         bind $itk_component(entry) <Button-4> [code $this binding move -1]
 195         bind $itk_component(entry) <Button-5> [code $this binding move 1]
 196         bind $itk_component(entry) <MouseWheel> [code $this binding scrollwheel %D]
 197         #bind $itk_component(entry) <Button-1> [code focus $w]
 198         bind $itk_component(entry) <Button-1> [code $this toggle_popup]
 199         bind $itk_component(entry) <Button-3> [code $this toggle_popup]
 200         bind $itk_component(border) <Key-Up> [code $this binding move -1]
 201         bind $itk_component(border) <Key-Down> [code $this binding move 1]
 202         bind $itk_component(border) <Key-Home> [code $this binding moveto 0]
 203         bind $itk_component(border) <Key-End>  [code $this binding moveto $listend]
 204         bind $itk_component(border) <Key>  [code $this zoom %A]
 205
 206         [stategate_ref] attach_output [code $this statechanged]
 207 }
 208
 209
 210 body tlc::Spinner::destructor {} { #<<<1
 211         incr upimg_refcount -1
 212         incr downimg_refcount -1
 213         if {$upimg_refcount == 0} {
 214                 image delete $upimg
 215                 unset upimg
 216                 unset upimg_refcount
 217         }
 218         if {$downimg_refcount == 0} {
 219                 image delete $downimg
 220                 unset downimg
 221                 unset downimg_refcount
 222         }
 223 }
 224
 225
 226 body tlc::Spinner::move {delta} { #<<<1
 227         set sel_idx             [lsearch $choices [$w.entry get]]
 228
 229         set choices_len [llength $choices]
 230
 231         if {$sel_idx == -1} {
 232                 if {$delta < 0} {
 233                         set sel_idx             [expr {$choices_len + $delta}]
 234                         if {$sel_idx == [llength $choices]} {
 235                                 set sel_idx     [expr {$choices_len - 1}]
 236                         }
 237                 } else {
 238                         set sel_idx             [expr {$delta - 1}]
 239                         if {$sel_idx < 0} {
 240                                 set sel_idx             0
 241                         }
 242                 }
 243         } else {
 244                 set sel_idx             [expr {$sel_idx + $delta}]
 245         }
 246
 247         if {$wrap} {
 248                 if {$choices_len == 0} {
 249                         set sel_idx             0
 250                 } else {
 251                         set sel_idx     [expr {$sel_idx % $choices_len}]
 252                 }
 253         } else {
 254                 if {$sel_idx > [last_idx]} {
 255                         set sel_idx     [last_idx]
 256                 } elseif {$sel_idx < 0} {
 257                         set sel_idx     0
 258                 }
 259         }
 260
 261         moveto $sel_idx
 262 }
 263
 264
 265 body tlc::Spinner::moveto {sel_idx} { #<<<1
 266         if {![[stategate_ref] state]} return
 267         if {$sel_idx < 0 || $sel_idx > [last_idx]} {
 268                 error "Spinner choice out of bounds: $sel_idx (max is [last_idx])"
 269         } else {
 270                 set idx $sel_idx
 271         }
 272         update_view
 273 }
 274
 275
 276 body tlc::Spinner::next {{delta 1}} { #<<<1
 277         move $delta
 278 }
 279
 280
 281 body tlc::Spinner::prev {{delta 1}} { #<<<1
 282         move [expr {0 - $delta}]
 283 }
 284
 285
 286 body tlc::Spinner::last {{offset 0}} { #<<<1
 287         moveto [expr {[last_idx] + $offset}]
 288 }
 289
 290
 291 body tlc::Spinner::first {{offset 0}} { #<<<1
 292         moveto $offset
 293 }
 294
 295
 296 body tlc::Spinner::last_idx {} { #<<<1
 297         return [expr {[llength $choices] - 1}]
 298 }
 299
 300
 301 body tlc::Spinner::update_view {} { #<<<1
 302         set new         [lindex $choices $idx]
 303
 304         set hold        [$itk_component(entry) cget -state]
 305         $itk_component(entry) configure -state normal
 306         $itk_component(entry) delete 0 end
 307         $itk_component(entry) insert 0 $new
 308         $itk_component(entry) configure -state $hold
 309
 310         set_textvariable $new
 311         invoke_handlers onselect $new
 312 }
 313
 314
 315 body tlc::Spinner::seekvalue {} { #<<<1
 316         if {![$signals(choices_set) state]} return
 317         log debug "looking for ($value) in ([join $choices |])"
 318         set sel_idx     [lsearch $choices $value]
 319         if {$sel_idx != -1} {
 320                 moveto $sel_idx
 321         }
 322         set zoom_spec   ""
 323 }
 324
 325
 326 body tlc::Spinner::rebindpage {} { #<<<1
 327         bind $itk_component(border) <Key-Prior> [code $this binding move -$pagelength]
 328         bind $itk_component(border) <Key-Next>  [code $this binding move $pagelength]
 329 }
 330
 331
 332 body tlc::Spinner::reset {} { #<<<1
 333         log debug "choices are: ([join $choices |]) value is: ($value)"
 334         set tidx                [lsearch $choices [$itk_component(entry) get]]
 335         if {$tidx == -1} {
 336                 $itk_component(entry) delete 0 end
 337         }
 338
 339         set listend             [expr {[llength $choices] - 1}]
 340         if {$listend < 0} {set listend 0}
 341
 342         bind $itk_component(entry) <Key-End> [code $this binding moveto $listend]
 343
 344         $popup_obj set_choices [lrange $choices 0 end]
 345
 346         seekvalue
 347 }
 348
 349
 350 body tlc::Spinner::validate_input {newval} { #<<<1
 351         set exists      [expr {[lsearch $choices $newval] != -1}]
 352         $signals(valid) set_state $exists
 353
 354         return [expr {$exists || $newval == ""}]
 355 }
 356
 357
 358 body tlc::Spinner::textvariable_changed {newvalue} { #<<<1
 359         log debug "choices set? [$signals(choices_set) state] choices: ([join $choices |])"
 360
 361         if {$newvalue == ""} {
 362                 set hold        [$itk_component(entry) cget -state]
 363                 $itk_component(entry) configure -state normal
 364                 $itk_component(entry) delete 0 end
 365                 $itk_component(entry) insert 0 ""
 366                 $itk_component(entry) configure -state $hold
 367         } else {
 368                 if {[$signals(choices_set) state]} {
 369                         if {[lsearch $choices $newvalue] == -1} {
 370                                 error "Invalid value" "" [list reject_change]
 371                         }
 372                 }
 373
 374                 configure -value $newvalue
 375         }
 376 }
 377
 378
 379 body tlc::Spinner::scrollwheel {delta} { #<<<1
 380         if {$delta > 0} {
 381                 move -1
 382         } else {
 383                 move 1
 384         }
 385 }
 386
 387
 388 body tlc::Spinner::zoom {char} { #<<<1
 389         set now         [clock clicks -milliseconds]
 390         if {![info exists last_zoom_ms] || $now - $last_zoom_ms > $zoom_memory} {
 391                 set zoom_spec           $char
 392         } else {
 393                 append zoom_spec        $char
 394         }
 395         set last_zoom_ms        $now
 396
 397         set zoom_spec   [string tolower $zoom_spec]
 398
 399         set zoom_last   [string length $zoom_spec]
 400         incr zoom_last  -1
 401
 402         set tidx                -1
 403         foreach choice $choices {
 404                 incr tidx
 405                 if {
 406                         [string tolower [string range $choice 0 $zoom_last]] == $zoom_spec
 407                 } {
 408                         moveto $tidx
 409                         return
 410                 }
 411         }
 412
 413         if {[string length $zoom_spec] > 1} {
 414                 # Try instead with this char only
 415                 set zoom_spec   ""
 416                 zoom $char
 417         }
 418 }
 419
 420
 421 body tlc::Spinner::binding {args} { #<<<1
 422         log debug "Binding: $args"
 423         focus $w
 424         eval [code $this] $args
 425 }
 426
 427
 428 body tlc::Spinner::popup {} { #<<<1
 429         if {![[stategate_ref] state]} return
 430         grab -global $w
 431         set topx                [winfo rootx $w.up]
 432         set topy                [winfo rooty $w.up]
 433
 434         set screenheight        [winfo screenheight $w]
 435         set screenwidth         [winfo screenwidth $w]
 436
 437         table arrange $w
 438         update idletasks
 439         foreach {id x y wd ht} [table extents $w c2] break
 440
 441         set botx                [expr $topx + $wd]
 442         set boty                [expr $topy + $ht]
 443
 444         $popup_obj set_choices [lrange $choices 0 end]
 445
 446         set listwidth   [winfo reqwidth $popup_obj]
 447         set listheight  [winfo reqheight $popup_obj]
 448         wm overrideredirect $popup_obj 1
 449         wm positionfrom $popup_obj user
 450
 451         set planx       [expr {$botx - $listwidth}]
 452         set plany       [expr {$boty + 1}]
 453
 454         # Avoid going off the screen <<<
 455         if {$planx < 0} {set planx 0}
 456         if {$plany < 0} {set plany 0}
 457         if {$planx + $listwidth > $screenwidth} {
 458                 set planx       [expr {$screenwidth - $listwidth}]
 459         }
 460         if {$plany + $listheight > $screenheight} {
 461                 set plany       [expr {$screenheight - $listheight}]
 462         }
 463         # Avoid going off the screen >>>
 464
 465         $popup_obj moveto $planx $plany
 466         $popup_obj show
 467
 468         focus [$popup_obj component list]
 469
 470         bind $w <Button> [code $this popdown]
 471         bind $w <Key> [code $this popdown]
 472 }
 473
 474
 475 body tlc::Spinner::popdown {} { #<<<1
 476         if {[winfo ismapped $popup_obj]} {
 477                 grab release $w
 478                 $popup_obj hide
 479
 480                 focus $itk_component(border)
 481         }
 482 }
 483
 484
 485 body tlc::Spinner::toggle_popup {} { #<<<1
 486         if {[winfo ismapped $popup_obj]} {
 487                 popdown
 488         } else {
 489                 popup
 490         }
 491 }
 492
 493
 494 body tlc::Spinner::set_choice {newidx args} { #<<<1
 495         moveto $newidx
 496
 497         popdown
 498 }
 499
 500
 501 body tlc::Spinner::statechanged {newstate} { #<<<1
 502         if {$newstate} {
 503         } else {
 504                 popdown
 505         }
 506 }
 507
 508
 509 body tlc::Spinner::choices_set_changed {newstate} { #<<<1
 510         log debug
 511 }
 512
 513