home *** CD-ROM | disk | FTP | other *** search
- # SpecTcl, by S. A. Uhler
- # Copyright (c) 1994-1995 Sun Microsystems, Inc.
- #
- # See the file "license.txt" for information on usage and redistribution
- # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- #
- # procedures to manage highlighting. Highlighting comes in two flavors
- # (which are sufficiently unrelated as to belong in different files).
- # The window highlights are red borders around the active widget. The
- # border is a rectagular "frame" managed (with the placer) by the widget,
- # but stacked below it.
-
- # The resize handles are little squares at the corners and sides of the active
- # widget that are used for interactive resizing. The "handles" are managed
- # by the widgets outline(see outline.tk), so they stick to the edges of
- # the widgets cavity.
-
- # draw a highlight frame around a window
- # arguments
- # win: the window to highlight
- # border: the size of the border around the window
- # name: - don't change. Used to name highlight windows
- # conf: - don't change. Used internally for managing recursion
- # return value
- # The name of the highlight window
- # side affects
- # add a binding tag to the window to pick up configure events
- # notes
- # This version uses the new placer stuff
-
- proc window_highlight {win {border 2} {name highlight} {conf 0}} {
- set new ${win}_$name
- catch {frame $new -bg red -relief raised -bd 1}
- place $new -in $win -bordermode outside -relx 0 -rely 0 \
- -relwidth 1 -relheight 1 \
- -x -$border -y -$border \
- -width [expr 2 * $border] \
- -height [expr 2 * $border]
- lower $new $win
- return $new
- }
-
- # unhighlight a window (or all windows)
- # arguments
- # win: window to "un-highlight" (or all highlighted object)
- # name: - don't change (must match highlight_window name)
- # returns
- # window that was un-highlighted
-
- proc window_unhighlight {{win ""} {name highlight}} {
- if {$win == ""} {
- set result ""
- foreach i [info commands *.*_$name] {
- regsub "(.+)_$name" $i {\1} win
- lappend result [window_unhighlight $win $name]
- }
- return $result
- }
- if {![winfo exists [set del ${win}_$name]]} {
- # puts " no $del to unhighlight"
- return ""
- }
- destroy $del
- return $win
- }
-
-
- # Add resize handles to a widget. The resize handles consist of 8 (or 9)
- # squares placed around the edges and sides of a widget's cavity.
-
- # arguments
- # master: The window to add resize handles around (usually the outline)
- # <masterframe>.<widget name>_outline
- # size: the size of the highlight frame border (see highlight_window)
- # extra: the amount the resize handles protrude into the window
- # color: the color of the resize handles
- # return value
- # the name of the resize frame
-
- set Handle_Cursors { \
- top_left_corner top_side top_right_corner \
- left_side cross right_side \
- bottom_left_corner bottom_side bottom_right_corner
- }
-
- proc add_resize_handles {master {size 5} {extra 3} {color gray35}} {
- global Handle_Cursors
- set z [expr $size + $extra]
-
- foreach i {0 1 2 3 4 5 6 7 8 } {
- set x [expr ($i%3)]
- set y [expr ($i/3)]
- set anchor [lindex {"n" "" "s"} $y][lindex {"w" "" "e"} $x]
- # If a "center" handle is desired, swap comment the following 2 lines
- # if {$i == 4} {set anchor c}
- if {$i == 4} {continue}
- # resize handles should be siblings of their widgets, so they
- # are always visible floating "above" the widget.
- # pick a name that can be parsed to retrieve the outline, widget,
- # anchor, and widget master, that is a sibling of the widget
- set name .can.f.[winfo name $master]:$anchor
- catch {frame $name -relief raised -bd 1}
- $name configure -width $z -height $z \
- -bg $color -cursor [lindex $Handle_Cursors $i]
- place $name -in $master -relx [expr $x/2.0] -rely [expr $y/2.0] \
- -anchor $anchor -bordermode outside
- bindtags $name "resize [winfo toplevel $name] all"
- }
- }
-
- # destroy all resize handles managed in master. (if any)
- # Resize handles should be the only slaves of the outline, so destroying
- # all of its slaves should be adaquate
-
- proc del_resize_handles {master} {
- eval "destroy [info commands .*_outline:*]"
-
- }
-
- # parameters for moving resize handles. For each resize handle, we only
- # change either x or y of the managing frame, which we keep track of here.
- # The coordinate names (-x, -y) are chosen to match the "place" option names
- # The coords +x and +y are easier to use than -width and -height
-
- # map from a resize handle name to the coordinate that needs to be adjusted
- array set Adjust {
- n.y -y s.y +y w.x -x e.x +x
- nw.x -x nw.y -y ne.x +x ne.y -y
- sw.x -x sw.y +y se.x +x se.y +y
- }
-
- # adjust the resize frame, called from bind with %W %X %Y
- # %W is the resize handle, named: .can.f.<name of outline's widget>:<anchor code>
- # The outline is named: <frame managing widget>.<widget name>_outline
-
- proc resize_sweep {win x y} {
- global Adjust Current _Message
- upvar #0 geom:$Current(frame) data
-
- # make coords relative to parent
-
- incr x -[winfo rootx $Adjust(parent)]
- incr y -[winfo rooty $Adjust(parent)]
-
- # make modulo row/col (is this better?)
-
- set row [expr [blt_table row $Current(frame) location $y] & ~1]
- set col [expr [blt_table column $Current(frame) location $x] & ~1]
- if {$row < 2 || $col < 2} return
- if {($row == $Adjust(row)) && ($col == $Adjust(column))} return
- set Adjust(row) $row; set Adjust(column) $col
- if {![get_position r1 c1 r2 c2]} return
- if {![position_ok $Adjust(owner) $r1 $c1 $r2 $c2]} return
- foreach i {r1 c1 r2 c2} {set Adjust($i) [set $i]} ;# last good position
- if {$row > $Adjust(start_row)} { incr row -1}
- if {$col > $Adjust(start_column)} { incr col -1}
- set y $data(row_$row)
- set x $data(column_$col)
-
- # do the replacement
-
- foreach coord {x y} {
- set index $Adjust(how).$coord
- if {[info exists Adjust($index)]} {
- set Adjust([set Adjust($index)]) [set $coord]
- }
- }
-
- # move the "box" by extracting the proper array elements
-
- set Adjust(-width) [expr $Adjust(+x) - $Adjust(-x)]
- set Adjust(-height) [expr $Adjust(+y) - $Adjust(-y)]
- eval "place $Adjust(master) [array get Adjust -*]"
- }
-
- # temporary binding stuff
- # <prefix>_down: The button went down
- # <prefix>_start_sweep We started a sweep
- # <prefix>_sweep We are sweeping
- # <prefix>_end_sweep We ended the sweep (button up)
- # <prefix>_up button up - no sweep
-
- proc resize_down {win x y} {
- global _Message Cancel
- after cancel $Cancel
- set _Message "Drag past grid-line to change span"
- }
-
- # We started a sweep. Compute relevent information
-
- proc resize_start_sweep {win x y} {
- global Adjust
-
- set Adjust(win) $win ;# The name of the resize handle
- regexp {.can.f.(.*)_outline:(.*)$} $win dummy owner Adjust(how)
- set Adjust(owner) .can.f.$owner ;# The widget owning the outline
- set Adjust(parent) .can.f[find_master .can.f.$owner] ;# The parent frame
- array set temp [place info $win]
- set Adjust(master) $temp(-in)
- array set Adjust [place info $Adjust(master)]
- set Adjust(+x) [expr $Adjust(-x) + $Adjust(-width)]
- set Adjust(+y) [expr $Adjust(-y) + $Adjust(-height)]
- set Adjust(row) ""
- set Adjust(column) ""
-
- blt_get .can.f.$owner info
- set Adjust(start_row) $info(-row)
- set Adjust(start_column) $info(-column)
- set Adjust(end_row) [expr $info(-row) + $info(-rowspan) - 1]
- set Adjust(end_column) [expr $info(-column) + $info(-columnspan) - 1]
- set Adjust(revert) [place info $Adjust(master)]
- set Adjust(r1) $Adjust(start_row)
- set Adjust(c1) $Adjust(start_column)
- set Adjust(r2) $Adjust(end_row)
- set Adjust(c2) $Adjust(end_column)
-
- # kludge to get around serious implicit-grab bug in TK
- # That causes an implicit grab to be released when "%W" is moved
- grab $win
- }
-
- # change the widget position by adjusting the span and/or row/col
-
- proc resize_end_sweep {win x y} {
-
- # undo grab kludge
- grab release $win
-
- global Adjust
-
- set column $Adjust(c1); set row $Adjust(r1)
- set rowspan [expr $Adjust(r2) - $row + 1]
- set columnspan [expr $Adjust(c2) - $column + 1]
- set widget $Adjust(owner)
- blt_table .can.f[find_master $widget] $widget $row,$column \
- -rowspan $rowspan -columnspan $columnspan
- foreach i {row column columnspan rowspan} {
- sync_form $i [set $i]
- }
-
-
- return 1
- }
-
- # We could use this as a short cut for setting the edge stickyness
-
- proc resize_up {win x y} {
- }
-
- # check to make sure widget can occupy slot(s)
- # This is brute force for now, it should be made faster,
- # Since it needs to be run at mouse-motion time
- # All of the info needed for this is already packaged in the Adjust
- # array, so don't bother passing in all of the parameters
-
- # convert Adjustment position into starting and ending rows and columns
-
- proc get_position {R1 C1 R2 C2} {
- global Adjust
- upvar $R1 r1 $C1 c1 $R2 r2 $C2 c2
-
- foreach element {
- row column owner how start_row start_column end_row end_column} {
- set $element $Adjust($element)
- }
-
- switch -glob $how {
- n* {
- if {$row > $end_row} {return 0}
- set r1 $row; set r2 $end_row
- }
- s* {
- if {$row <= $start_row} {return 0}
- set r1 $start_row; set r2 $row; incr r2 -2
- }
- * {
- set r1 $start_row; set r2 $end_row
- }
- }
-
- switch -glob $how {
- *w {
- if {$column > $end_column} {return 0}
- set c1 $column; set c2 $end_column
- }
- *e {
- if {$column <= $start_column} {return 0}
- set c1 $start_column; set c2 $column; incr c2 -2
- }
- * {
- set c1 $start_column; set c2 $end_column
- }
- }
- return 1
- }
-
- # See if rows and column range is empty
-
- proc position_ok {widget r1 c1 r2 c2 {result _Message}} {
- global Current Adjust
- upvar #0 geom:$Current(frame) data
- upvar $result _Message
-
- dputs "OK? $widget (in $Current(frame)) $r1,$c1 $r2,$c2"
- if {$r1 <2 || $c1 < 2 || $r2 >= $data(rows) || $c2 >= $data(columns)} {
- set _Message "Location is past the edge of the table"
- dputs " PAST EDGE"
- return 0
- }
- for {} {$r1 <= $r2} {incr r1 2} {
- for {set c $c1} {$c <= $c2} {incr c 2} {
- set win [blt_table slaves $Current(frame) -row $r1 -column $c]
- if {$win == ""} continue
- if {$widget != $win} {
- set _Message "Location is occupied (by [winfo name $win])"
- return 0
- }
- }
- }
- set _Message ""
- # puts " OK"
- return 1
- }
-