source: trunk/BWidget-1.2.1/arrow.tcl

Last change on this file was 931, checked in by toby, 11 years ago

include rest of files

File size: 20.4 KB
Line 
1# ------------------------------------------------------------------------------
2#  arrow.tcl
3#  This file is part of Unifix BWidget Toolkit
4# ------------------------------------------------------------------------------
5#  Index of commands:
6#   Public commands
7#     - ArrowButton::create
8#     - ArrowButton::configure
9#     - ArrowButton::cget
10#     - ArrowButton::invoke
11#   Private commands (redraw commands)
12#     - ArrowButton::_redraw
13#     - ArrowButton::_redraw_state
14#     - ArrowButton::_redraw_relief
15#     - ArrowButton::_redraw_whole
16#   Private commands (event bindings)
17#     - ArrowButton::_destroy
18#     - ArrowButton::_enter
19#     - ArrowButton::_leave
20#     - ArrowButton::_press
21#     - ArrowButton::_release
22#     - ArrowButton::_repeat
23# ------------------------------------------------------------------------------
24
25namespace eval ArrowButton {
26
27    Widget::tkinclude ArrowButton button :cmd \
28        include {
29            -borderwidth -bd  -background -bg -relief
30            -highlightbackground -highlightcolor -highlightthickness -takefocus}
31
32    Widget::declare ArrowButton {
33        {-type                Enum button 0 {arrow button}}
34        {-dir                 Enum top    0 {top bottom left right}}
35        {-width               Int 15 0 {=0}}
36        {-height              Int 15 0 {=0}}
37        {-ipadx               Int 0  0 {=0}}
38        {-ipady               Int 0  0 {=0}}
39        {-clean               Int 2  0 {=0 =2}}
40        {-activeforeground    TkResource "" 0 button}
41        {-activebackground    TkResource "" 0 button}
42        {-disabledforeground  TkResource "" 0 button}
43        {-foreground          TkResource "" 0 button}
44        {-state               TkResource "" 0 button}
45
46        {-troughcolor     TkResource ""     0 scrollbar}
47        {-arrowbd         Int        1      0 {=1 =2}}
48        {-arrowrelief     Enum       raised 0 {raised sunken}}
49
50        {-command         String "" 0}
51        {-armcommand      String "" 0}
52        {-disarmcommand   String "" 0}
53        {-repeatdelay     Int 0 0 {=0}}
54        {-repeatinterval  Int 0 0 {=0}}
55
56        {-bd              Synonym -borderwidth}
57        {-fg              Synonym -foreground}
58    }
59    DynamicHelp::include ArrowButton balloon
60
61    proc ::ArrowButton { path args } { return [eval ArrowButton::create $path $args] }
62
63    proc use {} {}
64
65    bind BwArrowButton <Enter>           {ArrowButton::_enter %W}
66    bind BwArrowButton <Leave>           {ArrowButton::_leave %W}
67    bind BwArrowButton <ButtonPress-1>   {ArrowButton::_press %W}
68    bind BwArrowButton <ButtonRelease-1> {ArrowButton::_release %W}
69    bind BwArrowButton <Key-space>       {ArrowButton::invoke %W; break}
70    bind BwArrowButton <Return>          {ArrowButton::invoke %W; break}
71    bind BwArrowButton <Configure>       {ArrowButton::_redraw_whole %W %w %h}
72    bind BwArrowButton <Destroy>         {ArrowButton::_destroy %W}
73
74    variable _grab
75    variable _moved
76
77    array set _grab {current "" pressed "" oldstate "" oldrelief ""}
78}
79
80
81# ------------------------------------------------------------------------------
82#  Command ArrowButton::create
83# ------------------------------------------------------------------------------
84proc ArrowButton::create { path args } {
85    variable _moved
86
87    Widget::init ArrowButton $path $args
88
89    set w   [Widget::getoption $path -width]
90    set h   [Widget::getoption $path -height]
91    set bd  [Widget::getoption $path -borderwidth]
92    set ht  [Widget::getoption $path -highlightthickness]
93    set pad [expr {2*($bd+$ht)}]
94
95    eval canvas $path [Widget::subcget $path :cmd] \
96        -width [expr {$w-$pad}] -height [expr {$h-$pad}]
97    bindtags $path [list $path BwArrowButton [winfo toplevel $path] all]
98
99    DynamicHelp::sethelp $path $path 1
100
101    set _moved($path) 0
102
103    rename $path ::$path:cmd
104    proc ::$path { cmd args } "return \[eval ArrowButton::\$cmd $path \$args\]"
105
106    return $path
107}
108
109
110# ------------------------------------------------------------------------------
111#  Command ArrowButton::configure
112# ------------------------------------------------------------------------------
113proc ArrowButton::configure { path args } {
114    set res [Widget::configure $path $args]
115
116    set ch1 [expr {[Widget::hasChanged $path -width  w] |
117                   [Widget::hasChanged $path -height h] |
118                   [Widget::hasChanged $path -borderwidth bd] |
119                   [Widget::hasChanged $path -highlightthickness ht]}]
120    set ch2 [expr {[Widget::hasChanged $path -type    val] |
121                   [Widget::hasChanged $path -ipadx   val] |
122                   [Widget::hasChanged $path -ipady   val] |
123                   [Widget::hasChanged $path -arrowbd val] |
124                   [Widget::hasChanged $path -clean   val] |
125                   [Widget::hasChanged $path -dir     val]}]
126
127    if { $ch1 } {
128        set pad [expr {2*($bd+$ht)}]
129        $path:cmd configure \
130            -width [expr {$w-$pad}] -height [expr {$h-$pad}] \
131            -borderwidth $bd -highlightthickness $ht
132    } elseif { $ch2 } {
133        _redraw_whole $path [winfo width $path] [winfo height $path]
134    } else {
135        _redraw_relief $path
136        _redraw_state $path
137    }
138    DynamicHelp::sethelp $path $path
139
140    return $res
141}
142
143
144# ------------------------------------------------------------------------------
145#  Command ArrowButton::cget
146# ------------------------------------------------------------------------------
147proc ArrowButton::cget { path option } {
148    return [Widget::cget $path $option]
149}
150
151
152# ------------------------------------------------------------------------------
153#  Command ArrowButton::invoke
154# ------------------------------------------------------------------------------
155proc ArrowButton::invoke { path } {
156    if { [string compare [Widget::getoption $path -state] "disabled"] } {
157        set oldstate [Widget::getoption $path -state]
158        if { ![string compare [Widget::getoption $path -type] "button"] } {
159            set oldrelief [Widget::getoption $path -relief]
160            configure $path -state active -relief sunken
161        } else {
162            set oldrelief [Widget::getoption $path -arrowrelief]
163            configure $path -state active -arrowrelief sunken
164        }
165        update idletasks
166        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
167            uplevel \#0 $cmd
168        }
169        after 10
170        if { ![string compare [Widget::getoption $path -type] "button"] } {
171            configure $path -state $oldstate -relief $oldrelief
172        } else {
173            configure $path -state $oldstate -arrowrelief $oldrelief
174        }
175        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
176            uplevel \#0 $cmd
177        }
178        if { [set cmd [Widget::getoption $path -command]] != "" } {
179            uplevel \#0 $cmd
180        }
181    }
182}
183
184
185# ------------------------------------------------------------------------------
186#  Command ArrowButton::_redraw
187# ------------------------------------------------------------------------------
188proc ArrowButton::_redraw { path width height } {
189    variable _moved
190
191    set _moved($path) 0
192    set type  [Widget::getoption $path -type]
193    set dir   [Widget::getoption $path -dir]
194    set bd    [expr {[$path:cmd cget -borderwidth] + [$path:cmd cget -highlightthickness] + 1}]
195    set clean [Widget::getoption $path -clean]
196    if { ![string compare $type "arrow"] } {
197        if { [set id [$path:cmd find withtag rect]] == "" } {
198            $path:cmd create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect
199        } else {
200            $path:cmd coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}]
201        }
202        $path:cmd lower rect
203        set arrbd [Widget::getoption $path -arrowbd]
204        set bd    [expr {$bd+$arrbd-1}]
205    } else {
206        $path:cmd delete rect
207    }
208    # w and h are max width and max height of arrow
209    set w [expr {$width  - 2*([Widget::getoption $path -ipadx]+$bd)}]
210    set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}]
211
212    if { $w < 2 } {set w 2}
213    if { $h < 2 } {set h 2}
214
215    if { $clean > 0 } {
216        # arrange for base to be odd
217        if { ![string compare $dir "top"] ||
218             ![string compare $dir "bottom"] } {
219            if { !($w % 2) } {
220                incr w -1
221            }
222            if { $clean == 2 } {
223                # arrange for h = (w+1)/2
224                set h2 [expr {($w+1)/2}]
225                if { $h2 > $h } {
226                    set w [expr {2*$h-1}]
227                } else {
228                    set h $h2
229                }
230            }
231        } else {
232            if { !($h % 2) } {
233                incr h -1
234            }
235            if { $clean == 2 } {
236                # arrange for w = (h+1)/2
237                set w2 [expr {($h+1)/2}]
238                if { $w2 > $w } {
239                    set h [expr {2*$w-1}]
240                } else {
241                    set w $w2
242                }
243            }
244        }
245    }
246
247    set x0 [expr {($width-$w)/2}]
248    set y0 [expr {($height-$h)/2}]
249    set x1 [expr {$x0+$w-1}]
250    set y1 [expr {$y0+$h-1}]
251
252    switch $dir {
253        top {
254            set xd [expr {($x0+$x1)/2}]
255            if { [set id [$path:cmd find withtag poly]] == "" } {
256                $path:cmd create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly
257            } else {
258                $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
259            }
260            if { ![string compare $type "arrow"] } {
261                if { [set id [$path:cmd find withtag bot]] == "" } {
262                    $path:cmd create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot
263                } else {
264                    $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
265                }
266                if { [set id [$path:cmd find withtag top]] == "" } {
267                    $path:cmd create line $x0 $y1 $xd $y0 -tags top
268                } else {
269                    $path:cmd coords $id $x0 $y1 $xd $y0
270                }
271                $path:cmd itemconfigure top -width $arrbd
272                $path:cmd itemconfigure bot -width $arrbd
273            } else {
274                $path:cmd delete top
275                $path:cmd delete bot
276            }
277        }
278        bottom {
279            set xd [expr {($x0+$x1)/2}]
280            if { [set id [$path:cmd find withtag poly]] == "" } {
281                $path:cmd create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly
282            } else {
283                $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
284            }
285            if { ![string compare $type "arrow"] } {
286                if { [set id [$path:cmd find withtag top]] == "" } {
287                    $path:cmd create line $x1 $y0 $x0 $y0 $xd $y1 -tags top
288                } else {
289                    $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
290                }
291                if { [set id [$path:cmd find withtag bot]] == "" } {
292                    $path:cmd create line $x1 $y0 $xd $y1 -tags bot
293                } else {
294                    $path:cmd coords $id $x1 $y0 $xd $y1
295                }
296                $path:cmd itemconfigure top -width $arrbd
297                $path:cmd itemconfigure bot -width $arrbd
298            } else {
299                $path:cmd delete top
300                $path:cmd delete bot
301            }
302        }
303        left {
304            set yd [expr {($y0+$y1)/2}]
305            if { [set id [$path:cmd find withtag poly]] == "" } {
306                $path:cmd create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly
307            } else {
308                $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
309            }
310            if { ![string compare $type "arrow"] } {
311                if { [set id [$path:cmd find withtag bot]] == "" } {
312                    $path:cmd create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot
313                } else {
314                    $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
315                }
316                if { [set id [$path:cmd find withtag top]] == "" } {
317                    $path:cmd create line $x1 $y0 $x0 $yd -tags top
318                } else {
319                    $path:cmd coords $id $x1 $y0 $x0 $yd
320                }
321                $path:cmd itemconfigure top -width $arrbd
322                $path:cmd itemconfigure bot -width $arrbd
323            } else {
324                $path:cmd delete top
325                $path:cmd delete bot
326            }
327        }
328        right {
329            set yd [expr {($y0+$y1)/2}]
330            if { [set id [$path:cmd find withtag poly]] == "" } {
331                $path:cmd create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly
332            } else {
333                $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
334            }
335            if { ![string compare $type "arrow"] } {
336                if { [set id [$path:cmd find withtag top]] == "" } {
337                    $path:cmd create line $x0 $y1 $x0 $y0 $x1 $yd -tags top
338                } else {
339                    $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
340                }
341                if { [set id [$path:cmd find withtag bot]] == "" } {
342                    $path:cmd create line $x0 $y1 $x1 $yd -tags bot
343                } else {
344                    $path:cmd coords $id $x0 $y1 $x1 $yd
345                }
346                $path:cmd itemconfigure top -width $arrbd
347                $path:cmd itemconfigure bot -width $arrbd
348            } else {
349                $path:cmd delete top
350                $path:cmd delete bot
351            }
352        }
353    }
354}
355
356
357# ------------------------------------------------------------------------------
358#  Command ArrowButton::_redraw_state
359# ------------------------------------------------------------------------------
360proc ArrowButton::_redraw_state { path } {
361    set state [Widget::getoption $path -state]
362    if { ![string compare [Widget::getoption $path -type] "button"] } {
363        switch $state {
364            normal   {set bg -background;       set fg -foreground}
365            active   {set bg -activebackground; set fg -activeforeground}
366            disabled {set bg -background;       set fg -disabledforeground}
367        }
368        set fg [Widget::getoption $path $fg]
369        $path:cmd configure -background [Widget::getoption $path $bg]
370        $path:cmd itemconfigure poly -fill $fg -outline $fg
371    } else {
372        switch $state {
373            normal   {set stipple "";     set bg [Widget::getoption $path -background] }
374            active   {set stipple "";     set bg [Widget::getoption $path -activebackground] }
375            disabled {set stipple gray50; set bg black }
376        }
377        set thrc [Widget::getoption $path -troughcolor]
378        $path:cmd configure -background [Widget::getoption $path -background]
379        $path:cmd itemconfigure rect -fill $thrc -outline $thrc
380        $path:cmd itemconfigure poly -fill $bg   -outline $bg -stipple $stipple
381    }
382}
383
384
385# ------------------------------------------------------------------------------
386#  Command ArrowButton::_redraw_relief
387# ------------------------------------------------------------------------------
388proc ArrowButton::_redraw_relief { path } {
389    variable _moved
390
391    if { ![string compare [Widget::getoption $path -type] "button"] } {
392        if { ![string compare [Widget::getoption $path -relief] "sunken"] } {
393            if { !$_moved($path) } {
394                $path:cmd move poly 1 1
395                set _moved($path) 1
396            }
397        } else {
398            if { $_moved($path) } {
399                $path:cmd move poly -1 -1
400                set _moved($path) 0
401            }
402        }
403    } else {
404        set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]]
405        switch [Widget::getoption $path -arrowrelief] {
406            raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]}
407            sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]}
408        }
409        $path:cmd itemconfigure top -fill $top
410        $path:cmd itemconfigure bot -fill $bot
411    }
412}
413
414
415# ------------------------------------------------------------------------------
416#  Command ArrowButton::_redraw_whole
417# ------------------------------------------------------------------------------
418proc ArrowButton::_redraw_whole { path width height } {
419    _redraw $path $width $height
420    _redraw_relief $path
421    _redraw_state $path
422}
423
424
425# ------------------------------------------------------------------------------
426#  Command ArrowButton::_destroy
427# ------------------------------------------------------------------------------
428proc ArrowButton::_destroy { path } {
429    variable _moved
430
431    Widget::destroy $path
432    unset _moved($path)
433    rename $path {}
434}
435
436
437# ------------------------------------------------------------------------------
438#  Command ArrowButton::_enter
439# ------------------------------------------------------------------------------
440proc ArrowButton::_enter { path } {
441    variable _grab
442
443    set _grab(current) $path
444    if { [string compare [Widget::getoption $path -state] "disabled"] } {
445        set _grab(oldstate) [Widget::getoption $path -state]
446        configure $path -state active
447        if { $_grab(pressed) == $path } {
448            if { ![string compare [Widget::getoption $path -type] "button"] } {
449                set _grab(oldrelief) [Widget::getoption $path -relief]
450                configure $path -relief sunken
451            } else {
452                set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
453                configure $path -arrowrelief sunken
454            }
455        }
456    }
457}
458
459
460# ------------------------------------------------------------------------------
461#  Command ArrowButton::_leave
462# ------------------------------------------------------------------------------
463proc ArrowButton::_leave { path } {
464    variable _grab
465
466    set _grab(current) ""
467    if { [string compare [Widget::getoption $path -state] "disabled"] } {
468        configure $path -state $_grab(oldstate)
469        if { $_grab(pressed) == $path } {
470            if { ![string compare [Widget::getoption $path -type] "button"] } {
471                configure $path -relief $_grab(oldrelief)
472            } else {
473                configure $path -arrowrelief $_grab(oldrelief)
474            }
475        }
476    }
477}
478
479
480# ------------------------------------------------------------------------------
481#  Command ArrowButton::_press
482# ------------------------------------------------------------------------------
483proc ArrowButton::_press { path } {
484    variable _grab
485
486    if { [string compare [Widget::getoption $path -state] "disabled"] } {
487        set _grab(pressed) $path
488            if { ![string compare [Widget::getoption $path -type] "button"] } {
489            set _grab(oldrelief) [Widget::getoption $path -relief]
490            configure $path -relief sunken
491        } else {
492            set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
493            configure $path -arrowrelief sunken
494        }
495        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
496            uplevel \#0 $cmd
497            if { [set delay [Widget::getoption $path -repeatdelay]]    > 0 ||
498                 [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
499                after $delay "ArrowButton::_repeat $path"
500            }
501        }
502    }
503}
504
505
506# ------------------------------------------------------------------------------
507#  Command ArrowButton::_release
508# ------------------------------------------------------------------------------
509proc ArrowButton::_release { path } {
510    variable _grab
511
512    if { $_grab(pressed) == $path } {
513        set _grab(pressed) ""
514            if { ![string compare [Widget::getoption $path -type] "button"] } {
515            configure $path -relief $_grab(oldrelief)
516        } else {
517            configure $path -arrowrelief $_grab(oldrelief)
518        }
519        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
520            uplevel \#0 $cmd
521        }
522        if { $_grab(current) == $path &&
523             [string compare [Widget::getoption $path -state] "disabled"] &&
524             [set cmd [Widget::getoption $path -command]] != "" } {
525            uplevel \#0 $cmd
526        }
527    }
528}
529
530
531# ------------------------------------------------------------------------------
532#  Command ArrowButton::_repeat
533# ------------------------------------------------------------------------------
534proc ArrowButton::_repeat { path } {
535    variable _grab
536
537    if { $_grab(current) == $path && $_grab(pressed) == $path &&
538         [string compare [Widget::getoption $path -state] "disabled"] &&
539         [set cmd [Widget::getoption $path -armcommand]] != "" } {
540        uplevel \#0 $cmd
541    }
542    if { $_grab(pressed) == $path &&
543         ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
544          [set delay [Widget::getoption $path -repeatdelay]]    > 0) } {
545        after $delay "ArrowButton::_repeat $path"
546    }
547}
548
Note: See TracBrowser for help on using the repository browser.