arrow.tcl

一个用TCL/TK写的用于verilog的集成编辑环境.

# ------------------------------------------------------------------------------
#  arrow.tcl
#  This file is part of Unifix BWidget Toolkit
# ------------------------------------------------------------------------------
#  Index of commands:
#   Public commands
#     - ArrowButton::create
#     - ArrowButton::configure
#     - ArrowButton::cget
#     - ArrowButton::invoke
#   Private commands (redraw commands)
#     - ArrowButton::_redraw
#     - ArrowButton::_redraw_state
#     - ArrowButton::_redraw_relief
#     - ArrowButton::_redraw_whole
#   Private commands (event bindings)
#     - ArrowButton::_destroy
#     - ArrowButton::_enter
#     - ArrowButton::_leave
#     - ArrowButton::_press
#     - ArrowButton::_release
#     - ArrowButton::_repeat
# ------------------------------------------------------------------------------

namespace eval ArrowButton {

    Widget::tkinclude ArrowButton button :cmd \
        include {
            -borderwidth -bd  -background -bg -relief
            -highlightbackground -highlightcolor -highlightthickness -takefocus}

    Widget::declare ArrowButton {
        {-type                Enum button 0 {arrow button}}
        {-dir                 Enum top    0 {top bottom left right}}
        {-width               Int 15 0 {=0}}
        {-height              Int 15 0 {=0}}
        {-ipadx               Int 0  0 {=0}}
        {-ipady               Int 0  0 {=0}}
        {-clean               Int 2  0 {=0 =2}}
        {-activeforeground    TkResource "" 0 button}
        {-activebackground    TkResource "" 0 button}
        {-disabledforeground  TkResource "" 0 button}
        {-foreground          TkResource "" 0 button}
        {-state               TkResource "" 0 button}

        {-troughcolor     TkResource ""     0 scrollbar}
        {-arrowbd         Int        1      0 {=1 =2}}
        {-arrowrelief     Enum       raised 0 {raised sunken}}

        {-command         String "" 0}
        {-armcommand      String "" 0}
        {-disarmcommand   String "" 0}
        {-repeatdelay     Int 0 0 {=0}}
        {-repeatinterval  Int 0 0 {=0}}

        {-bd              Synonym -borderwidth}
        {-fg              Synonym -foreground}
    }
    DynamicHelp::include ArrowButton balloon

    proc ::ArrowButton { path args } { return [eval ArrowButton::create $path $args] }

    proc use {} {}

    bind BwArrowButton <Enter>           {ArrowButton::_enter %W}
    bind BwArrowButton <Leave>           {ArrowButton::_leave %W}
    bind BwArrowButton <ButtonPress-1>   {ArrowButton::_press %W}
    bind BwArrowButton <ButtonRelease-1> {ArrowButton::_release %W}
    bind BwArrowButton <Key-space>       {ArrowButton::invoke %W; break}
    bind BwArrowButton <Return>          {ArrowButton::invoke %W; break}
    bind BwArrowButton <Configure>       {ArrowButton::_redraw_whole %W %w %h}
    bind BwArrowButton <Destroy>         {ArrowButton::_destroy %W}

    variable _grab
    variable _moved

    array set _grab {current "" pressed "" oldstate "" oldrelief ""}
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::create
# ------------------------------------------------------------------------------
proc ArrowButton::create { path args } {
    variable _moved

    Widget::init ArrowButton $path $args

    set w   [Widget::getoption $path -width]
    set h   [Widget::getoption $path -height]
    set bd  [Widget::getoption $path -borderwidth]
    set ht  [Widget::getoption $path -highlightthickness]
    set pad [expr {2*($bd+$ht)}]

    eval canvas $path [Widget::subcget $path :cmd] \
        -width [expr {$w-$pad}] -height [expr {$h-$pad}]
    bindtags $path [list $path BwArrowButton [winfo toplevel $path] all]

    DynamicHelp::sethelp $path $path 1

    set _moved($path) 0

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval ArrowButton::\$cmd $path \$args\]"

    return $path
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::configure
# ------------------------------------------------------------------------------
proc ArrowButton::configure { path args } {
    set res [Widget::configure $path $args]

    set ch1 [expr {[Widget::hasChanged $path -width  w] |
                   [Widget::hasChanged $path -height h] |
                   [Widget::hasChanged $path -borderwidth bd] |
                   [Widget::hasChanged $path -highlightthickness ht]}]
    set ch2 [expr {[Widget::hasChanged $path -type    val] |
                   [Widget::hasChanged $path -ipadx   val] |
                   [Widget::hasChanged $path -ipady   val] |
                   [Widget::hasChanged $path -arrowbd val] |
                   [Widget::hasChanged $path -clean   val] |
                   [Widget::hasChanged $path -dir     val]}]

    if { $ch1 } {
        set pad [expr {2*($bd+$ht)}]
        $path:cmd configure \
            -width [expr {$w-$pad}] -height [expr {$h-$pad}] \
            -borderwidth $bd -highlightthickness $ht
    } elseif { $ch2 } {
        _redraw_whole $path [winfo width $path] [winfo height $path]
    } else {
        _redraw_relief $path
        _redraw_state $path
    }
    DynamicHelp::sethelp $path $path

    return $res
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::cget
# ------------------------------------------------------------------------------
proc ArrowButton::cget { path option } {
    return [Widget::cget $path $option]
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::invoke
# ------------------------------------------------------------------------------
proc ArrowButton::invoke { path } {
    if { [string compare [Widget::getoption $path -state] "disabled"] } {
        set oldstate [Widget::getoption $path -state]
        if { ![string compare [Widget::getoption $path -type] "button"] } {
            set oldrelief [Widget::getoption $path -relief]
            configure $path -state active -relief sunken
        } else {
            set oldrelief [Widget::getoption $path -arrowrelief]
            configure $path -state active -arrowrelief sunken
        }
	update idletasks
        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
            uplevel \#0 $cmd
        }
	after 10
        if { ![string compare [Widget::getoption $path -type] "button"] } {
            configure $path -state $oldstate -relief $oldrelief
        } else {
            configure $path -state $oldstate -arrowrelief $oldrelief
        }
        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
            uplevel \#0 $cmd
        }
        if { [set cmd [Widget::getoption $path -command]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw { path width height } {
    variable _moved

    set _moved($path) 0
    set type  [Widget::getoption $path -type]
    set dir   [Widget::getoption $path -dir]
    set bd    [expr {[$path:cmd cget -borderwidth] + [$path:cmd cget -highlightthickness] + 1}]
    set clean [Widget::getoption $path -clean]
    if { ![string compare $type "arrow"] } {
        if { [set id [$path:cmd find withtag rect]] == "" } {
            $path:cmd create rectangle $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}] -tags rect
        } else {
            $path:cmd coords $id $bd $bd [expr {$width-$bd-1}] [expr {$height-$bd-1}]
        }
        $path:cmd lower rect
        set arrbd [Widget::getoption $path -arrowbd]
        set bd    [expr {$bd+$arrbd-1}]
    } else {
        $path:cmd delete rect
    }
    # w and h are max width and max height of arrow
    set w [expr {$width  - 2*([Widget::getoption $path -ipadx]+$bd)}]
    set h [expr {$height - 2*([Widget::getoption $path -ipady]+$bd)}]

    if { $w < 2 } {set w 2}
    if { $h < 2 } {set h 2}

    if { $clean > 0 } {
        # arrange for base to be odd
        if { ![string compare $dir "top"] ||
             ![string compare $dir "bottom"] } {
            if { !($w % 2) } {
                incr w -1
            }
            if { $clean == 2 } {
                # arrange for h = (w+1)/2
                set h2 [expr {($w+1)/2}]
                if { $h2 > $h } {
                    set w [expr {2*$h-1}]
                } else {
                    set h $h2
                }
            }
        } else {
            if { !($h % 2) } {
                incr h -1
            }
            if { $clean == 2 } {
                # arrange for w = (h+1)/2
                set w2 [expr {($h+1)/2}]
                if { $w2 > $w } {
                    set h [expr {2*$w-1}]
                } else {
                    set w $w2
                }
            }
        }
    }

    set x0 [expr {($width-$w)/2}]
    set y0 [expr {($height-$h)/2}]
    set x1 [expr {$x0+$w-1}]
    set y1 [expr {$y0+$h-1}]

    switch $dir {
        top {
            set xd [expr {($x0+$x1)/2}]
            if { [set id [$path:cmd find withtag poly]] == "" } {
                $path:cmd create polygon $x0 $y1 $x1 $y1 $xd $y0 -tags poly
            } else {
                $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
            }
            if { ![string compare $type "arrow"] } {
                if { [set id [$path:cmd find withtag bot]] == "" } {
                    $path:cmd create line $x0 $y1 $x1 $y1 $xd $y0 -tags bot
                } else {
                    $path:cmd coords $id $x0 $y1 $x1 $y1 $xd $y0
                }
                if { [set id [$path:cmd find withtag top]] == "" } {
                    $path:cmd create line $x0 $y1 $xd $y0 -tags top
                } else {
                    $path:cmd coords $id $x0 $y1 $xd $y0
                }
                $path:cmd itemconfigure top -width $arrbd
                $path:cmd itemconfigure bot -width $arrbd
            } else {
                $path:cmd delete top
                $path:cmd delete bot