nm.tcl~

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

        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
            }
        }
        bottom {
            set xd [expr {($x0+$x1)/2}]
            if { [set id [$path:cmd find withtag poly]] == "" } {
                $path:cmd create polygon $x1 $y0 $x0 $y0 $xd $y1 -tags poly
            } else {
                $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
            }
            if { ![string compare $type "arrow"] } {
                if { [set id [$path:cmd find withtag top]] == "" } {
                    $path:cmd create line $x1 $y0 $x0 $y0 $xd $y1 -tags top
                } else {
                    $path:cmd coords $id $x1 $y0 $x0 $y0 $xd $y1
                }
                if { [set id [$path:cmd find withtag bot]] == "" } {
                    $path:cmd create line $x1 $y0 $xd $y1 -tags bot
                } else {
                    $path:cmd coords $id $x1 $y0 $xd $y1
                }
                $path:cmd itemconfigure top -width $arrbd
                $path:cmd itemconfigure bot -width $arrbd
            } else {
                $path:cmd delete top
                $path:cmd delete bot
            }
        }
        left {
            set yd [expr {($y0+$y1)/2}]
            if { [set id [$path:cmd find withtag poly]] == "" } {
                $path:cmd create polygon $x1 $y0 $x1 $y1 $x0 $yd -tags poly
            } else {
                $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
            }
            if { ![string compare $type "arrow"] } {
                if { [set id [$path:cmd find withtag bot]] == "" } {
                    $path:cmd create line $x1 $y0 $x1 $y1 $x0 $yd -tags bot
                } else {
                    $path:cmd coords $id $x1 $y0 $x1 $y1 $x0 $yd
                }
                if { [set id [$path:cmd find withtag top]] == "" } {
                    $path:cmd create line $x1 $y0 $x0 $yd -tags top
                } else {
                    $path:cmd coords $id $x1 $y0 $x0 $yd
                }
                $path:cmd itemconfigure top -width $arrbd
                $path:cmd itemconfigure bot -width $arrbd
            } else {
                $path:cmd delete top
                $path:cmd delete bot
            }
        }
        right {
            set yd [expr {($y0+$y1)/2}]
            if { [set id [$path:cmd find withtag poly]] == "" } {
                $path:cmd create polygon $x0 $y1 $x0 $y0 $x1 $yd -tags poly
            } else {
                $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
            }
            if { ![string compare $type "arrow"] } {
                if { [set id [$path:cmd find withtag top]] == "" } {
                    $path:cmd create line $x0 $y1 $x0 $y0 $x1 $yd -tags top
                } else {
                    $path:cmd coords $id $x0 $y1 $x0 $y0 $x1 $yd
                }
                if { [set id [$path:cmd find withtag bot]] == "" } {
                    $path:cmd create line $x0 $y1 $x1 $yd -tags bot
                } else {
                    $path:cmd coords $id $x0 $y1 $x1 $yd
                }
                $path:cmd itemconfigure top -width $arrbd
                $path:cmd itemconfigure bot -width $arrbd
            } else {
                $path:cmd delete top
                $path:cmd delete bot
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_state
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_state { path } {
    set state [Widget::getoption $path -state]
    if { ![string compare [Widget::getoption $path -type] "button"] } {
        switch $state {
            normal   {set bg -background;       set fg -foreground}
            active   {set bg -activebackground; set fg -activeforeground}
            disabled {set bg -background;       set fg -disabledforeground}
        }
        set fg [Widget::getoption $path $fg]
        $path:cmd configure -background [Widget::getoption $path $bg]
        $path:cmd itemconfigure poly -fill $fg -outline $fg
    } else {
        switch $state {
            normal   {set stipple "";     set bg [Widget::getoption $path -background] }
            active   {set stipple "";     set bg [Widget::getoption $path -activebackground] }
            disabled {set stipple gray50; set bg black }
        }
        set thrc [Widget::getoption $path -troughcolor]
        $path:cmd configure -background [Widget::getoption $path -background]
        $path:cmd itemconfigure rect -fill $thrc -outline $thrc
        $path:cmd itemconfigure poly -fill $bg   -outline $bg -stipple $stipple
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_relief
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_relief { path } {
    variable _moved

    if { ![string compare [Widget::getoption $path -type] "button"] } {
        if { ![string compare [Widget::getoption $path -relief] "sunken"] } {
            if { !$_moved($path) } {
                $path:cmd move poly 1 1
                set _moved($path) 1
            }
        } else {
            if { $_moved($path) } {
                $path:cmd move poly -1 -1
                set _moved($path) 0
            }
        }
    } else {
        set col3d [BWidget::get3dcolor $path [Widget::getoption $path -background]]
        switch [Widget::getoption $path -arrowrelief] {
            raised {set top [lindex $col3d 1]; set bot [lindex $col3d 0]}
            sunken {set top [lindex $col3d 0]; set bot [lindex $col3d 1]}
        }
        $path:cmd itemconfigure top -fill $top
        $path:cmd itemconfigure bot -fill $bot
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_redraw_whole
# ------------------------------------------------------------------------------
proc ArrowButton::_redraw_whole { path width height } {
    _redraw $path $width $height
    _redraw_relief $path
    _redraw_state $path
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_destroy
# ------------------------------------------------------------------------------
proc ArrowButton::_destroy { path } {
    variable _moved

    Widget::destroy $path
    unset _moved($path)
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_enter
# ------------------------------------------------------------------------------
proc ArrowButton::_enter { path } {
    variable _grab

    set _grab(current) $path
    if { [string compare [Widget::getoption $path -state] "disabled"] } {
        set _grab(oldstate) [Widget::getoption $path -state]
        configure $path -state active
        if { $_grab(pressed) == $path } {
            if { ![string compare [Widget::getoption $path -type] "button"] } {
                set _grab(oldrelief) [Widget::getoption $path -relief]
                configure $path -relief sunken
            } else {
                set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
                configure $path -arrowrelief sunken
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_leave
# ------------------------------------------------------------------------------
proc ArrowButton::_leave { path } {
    variable _grab

    set _grab(current) ""
    if { [string compare [Widget::getoption $path -state] "disabled"] } {
        configure $path -state $_grab(oldstate)
        if { $_grab(pressed) == $path } {
            if { ![string compare [Widget::getoption $path -type] "button"] } {
                configure $path -relief $_grab(oldrelief)
            } else {
                configure $path -arrowrelief $_grab(oldrelief)
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_press
# ------------------------------------------------------------------------------
proc ArrowButton::_press { path } {
    variable _grab

    if { [string compare [Widget::getoption $path -state] "disabled"] } {
        set _grab(pressed) $path
            if { ![string compare [Widget::getoption $path -type] "button"] } {
            set _grab(oldrelief) [Widget::getoption $path -relief]
            configure $path -relief sunken
        } else {
            set _grab(oldrelief) [Widget::getoption $path -arrowrelief]
            configure $path -arrowrelief sunken
        }
        if { [set cmd [Widget::getoption $path -armcommand]] != "" } {
            uplevel \#0 $cmd
            if { [set delay [Widget::getoption $path -repeatdelay]]    > 0 ||
                 [set delay [Widget::getoption $path -repeatinterval]] > 0 } {
                after $delay "ArrowButton::_repeat $path"
            }
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_release
# ------------------------------------------------------------------------------
proc ArrowButton::_release { path } {
    variable _grab

    if { $_grab(pressed) == $path } {
        set _grab(pressed) ""
            if { ![string compare [Widget::getoption $path -type] "button"] } {
            configure $path -relief $_grab(oldrelief)
        } else {
            configure $path -arrowrelief $_grab(oldrelief)
        }
        if { [set cmd [Widget::getoption $path -disarmcommand]] != "" } {
            uplevel \#0 $cmd
        }
        if { $_grab(current) == $path &&
             [string compare [Widget::getoption $path -state] "disabled"] &&
             [set cmd [Widget::getoption $path -command]] != "" } {
            uplevel \#0 $cmd
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ArrowButton::_repeat
# ------------------------------------------------------------------------------
proc ArrowButton::_repeat { path } {
    variable _grab

    if { $_grab(current) == $path && $_grab(pressed) == $path &&
         [string compare [Widget::getoption $path -state] "disabled"] &&
         [set cmd [Widget::getoption $path -armcommand]] != "" } {
        uplevel \#0 $cmd
    }
    if { $_grab(pressed) == $path &&
         ([set delay [Widget::getoption $path -repeatinterval]] > 0 ||
          [set delay [Widget::getoption $path -repeatdelay]]    > 0) } {
        after $delay "ArrowButton::_repeat $path"
    }
}

# ------------------------------------------------------------------------------
#  bitmap.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: bitmap.tcl,v 1.2 1999/05/25 08:28:10 eric Exp $
# ------------------------------------------------------------------------------
#  Index of commands:
#     - Bitmap::get
#     - Bitmap::_init
# ------------------------------------------------------------------------------
namespace eval Bitmap {
    variable path
    variable _bmp
    variable _types {
        photo  .gif
        photo  .ppm
        bitmap .xbm
        photo  .xpm
    }

    proc use {} {}
}


# ------------------------------------------------------------------------------
#  Command Bitmap::get
# ------------------------------------------------------------------------------
proc Bitmap::get { name } {
    variable path
    variable _bmp
    variable _types

    if {[info exists _bmp($name)]} {
        return $_bmp($name)
    }

    # --- Nom de fichier avec extension ------------------------------------------------------
    set ext [file extension $name]
    if { $ext != "" } {
        if { ![info exists _bmp($ext)] } {
            error "$ext not supported"
        }

        if { [file exists $name] } {
            if {![string compare $ext ".xpm"]} {
                set _bmp($name) [xpm-to-image $name]
                return $_bmp($name)
            }
            if {![catch {set _bmp($name) [image create $_bmp($ext) -file $name]}]} {
                return $_bmp($name)
            }
        }
    }

    foreach dir $path {
        foreach {type ext} $_types {
            if { [file exists [file join $dir $name$ext]] } {
                if {![string compare $ext ".xpm"]} {
                    set _bmp($name) [xpm-to-image [file join $dir $name$ext]]
                    return $_bmp($name)
                } else {
                    if {![catch {set _bmp($name) [image create $type -file [file join $dir $name$ext]]}]} {
                        return $_bmp($name)
                    }
                }
            }
        }
    }

    return -code error "$name not found"
}


# ------------------------------------------------------------------------------
#  Comm