scripts/tools.itk

   1 # vim: foldmarker=<<<,>>>
   2
   3 proc tlc::tools {pathName args} {
   4         uplevel tlc::Tools $pathName $args
   5 }
   6
   7
   8 class tlc::Tools {
   9         inherit tlc::Border tlc::Tooltips tlc::Baselog
  10
  11         constructor {args} {}
  12         destructor {}
  13
  14         itk_option define -orient orient Text "h" need_repack
  15         itk_option define -midslot midSlot Integer 20 need_repack
  16         itk_option define -gap gap Integer 4 need_repack
  17         itk_option define -buttonwidth buttonWidth Integer 7
  18         if {$::tcl_platform(platform) == "windows"} {
  19                 itk_option define -padx padX PadX 10
  20                 itk_option define -pady padY PadY 2
  21         } else {
  22                 itk_option define -padx padX PadX 3m
  23                 itk_option define -pady padY PadY 2
  24         }
  25
  26         public {
  27                 variable type           "text";         # or "bitmap", "image"
  28                 variable debug          0
  29
  30                 method add {name cmd {side "left"} args}
  31                 method path {name}
  32                 method attach_signal {name signal {sense normal}}
  33                 method item_focus {name}
  34                 method explain {name}
  35                 method toggle_ref {name}
  36                 method separator {{side left} args}
  37         }
  38
  39         private {
  40                 variable slot   0
  41                 variable pathmap
  42                 variable slotmap
  43                 variable repack_id      ""
  44                 variable toggles
  45
  46                 method getcell {slotnum}
  47                 method repack {}
  48                 method tableadd {path myslot}
  49                 method need_repack {}
  50         }
  51 }
  52
  53
  54 configbody tlc::Tools::buttonwidth { #<<<1
  55         log debug $w
  56         foreach c [winfo children $w] {
  57                 $c configure -width $itk_option(-buttonwidth)
  58         }
  59 }
  60
  61
  62 body tlc::Tools::constructor {args} { #<<<1
  63         log debug $w
  64         array set toggles {}
  65
  66         blt::table $w
  67
  68         eval itk_initialize $args
  69 }
  70
  71
  72 body tlc::Tools::destructor {} { #<<<1
  73         log debug $w
  74         after cancel $repack_id; set repack_id  ""
  75 }
  76
  77
  78 body tlc::Tools::add {name cmd {side "left"} args} { #<<<1
  79         log debug $w
  80         switch -- $side {
  81                 left - right - top - bottom {}
  82                 default {
  83                         error "Unknown side specification: ($side)"
  84                 }
  85         }
  86
  87         set padd        [string tolower $name]
  88         set padd        [string map {" " "_" "." "_"} $padd]
  89         set padd        [string trim $padd]
  90         set path        $w.$padd
  91
  92         if {[winfo exists $path]} {
  93                 error "pathname $path already exists"
  94         }
  95
  96         set myslot      [incr slot]
  97         switch -- $side {
  98                 left - top {}
  99                 default {
 100                         incr myslot $itk_option(-midslot)
 101                 }
 102         }
 103
 104         set pathmap($name)              $path
 105         set slotmap($path)              $myslot
 106
 107         set toggle      {-state {disabled normal}}
 108         log debug "Adding type $type \"$name\" as $path"
 109         switch $type {
 110                 text {
 111                         eval [list button $path -text $name -command $cmd \
 112                                         -width $itk_option(-buttonwidth) \
 113                                         -padx $itk_option(-padx) -pady $itk_option(-pady)] $args
 114                 }
 115
 116                 bitmap {
 117                         eval [list button $path -bitmap $name -command $cmd \
 118                                         -width $itk_option(-buttonwidth)] $args
 119                 }
 120
 121                 image {
 122                         eval [list button $path -image $name -command $cmd \
 123                                         -width $itk_option(-buttonwidth)] $args
 124                 }
 125
 126                 default {
 127                         error "Unknown type: ($type)"
 128                 }
 129         }
 130         eval [list tlc::StateToggle #auto toggles($name) $path] $toggle
 131         $toggles($name) configure -default 1 -debugmode $debug
 132         tableadd $path $myslot
 133
 134         log debug "done add"
 135         return $path
 136 }
 137
 138
 139 body tlc::Tools::tableadd {path myslot} { #<<<1
 140         log debug $w
 141         if {$myslot < $itk_option(-midslot)} {
 142                 set side        "left"
 143         } else {
 144                 set side        "right"
 145         }
 146
 147         switch $side {
 148                 left {
 149                         set padx        [list 0 $itk_option(-gap)]
 150                 }
 151
 152                 right {
 153                         set padx        [list $itk_option(-gap) 0]
 154                 }
 155         }
 156
 157         switch $itk_option(-orient) {
 158                 h {
 159                         set pad_type    "padx"
 160                         set fill_type   y
 161                         blt::table configure $w c$myslot -resize none
 162                         blt::table configure $w r$myslot -resize both
 163                 }
 164
 165                 v {
 166                         set pad_type    "pady"
 167                         set fill_type   x
 168                         blt::table configure $w r$myslot -resize none
 169                         blt::table configure $w c$myslot -resize both
 170                 }
 171         }
 172
 173         blt::table $w $path [getcell $myslot] -$pad_type $padx -fill $fill_type
 174 }
 175
 176
 177 body tlc::Tools::path {name} { #<<<1
 178         log debug $w
 179         if {![info exists pathmap($name)]} {
 180                 error "No button called ($name), choose from ([array names pathmap])"
 181         }
 182         return $pathmap($name)
 183 }
 184
 185
 186 body tlc::Tools::getcell {slotnum} { #<<<1
 187         log debug $w
 188         switch $itk_option(-orient) {
 189                 h {
 190                         return "1,$slotnum"
 191                 }
 192
 193                 v {
 194                         return "$slotnum,1"
 195                 }
 196         }
 197 }
 198
 199
 200 body tlc::Tools::repack {} { #<<<1
 201         log debug $w
 202         after cancel $repack_id; set repack_id  ""
 203         foreach c [winfo children $w] {
 204                 tableadd $c $slotmap($c)
 205         }
 206         if {$itk_option(-orient) == "h"} {
 207                 blt::table configure $w c$itk_option(-midslot) -resize both
 208                 blt::table configure $w r$itk_option(-midslot) -resize none
 209         } else {
 210                 blt::table configure $w r$itk_option(-midslot) -resize both
 211                 blt::table configure $w c$itk_option(-midslot) -resize none
 212         }
 213 }
 214
 215
 216 body tlc::Tools::attach_signal {name signal {sense normal}} { #<<<1
 217         log debug $w
 218         $toggles($name) attach_signal $signal $sense
 219 }
 220
 221
 222 body tlc::Tools::need_repack {} { #<<<1
 223         log debug $w
 224         if {$repack_id != ""} return
 225
 226         set repack_id   [after idle [code $this repack]]
 227 }
 228
 229
 230 body tlc::Tools::item_focus {name} { #<<<1
 231         log debug $w
 232         focus [path $name]
 233 }
 234
 235
 236 body tlc::Tools::explain {name} { #<<<1
 237         log debug $w
 238         return [$toggles($name) explain]
 239 }
 240
 241
 242 body tlc::Tools::toggle_ref {name} { #<<<1
 243         log debug $w
 244         return $toggles($name)
 245 }
 246
 247
 248 body tlc::Tools::separator {{side left} args} { #<<<1
 249         log debug $w
 250         switch -- $side {
 251                 left - right - top - bottom {}
 252                 default {
 253                         error "Unknown side specification: ($side)"
 254                 }
 255         }
 256
 257         set myslot      [incr slot]
 258         switch -- $side {
 259                 left - top {}
 260                 default {
 261                         incr myslot $itk_option(-midslot)
 262                 }
 263         }
 264
 265         set name        "sep$myslot"
 266
 267         set path        [string tolower $w.$name]
 268         regsub { +} $path {} path
 269         set path        [string map {" " _} $path]
 270         set path        [string trim $path]
 271
 272         if {[winfo exists $path]} {
 273                 error "pathname $path already exists"
 274         }
 275
 276         set pathmap($name)              $path
 277         set slotmap($path)              $myslot
 278
 279         set toggle      {-state {disabled normal}}
 280         switch $type {
 281                 text -
 282                 bitmap -
 283                 image {
 284                         eval [list frame $path -borderwidth 2 -relief ridge -width 2 -height 2] $args
 285                 }
 286
 287                 default {
 288                         error "Unknown type: ($type)"
 289                 }
 290         }
 291         eval [list tlc::StateToggle #auto toggles($name) $path] $toggle
 292         $toggles($name) configure -default 1
 293         tableadd $path $myslot
 294
 295         return $path
 296 }
 297
 298