File manager - Edit - /home/c14075/dragmet-ural.ru/www/blt2.5.tar
Back
pkgIndex.tcl 0000644 00000003436 15134702070 0007026 0 ustar 00 # Tcl package index file, version 1.0 proc LoadBLT25 { version dir } { set prefix "lib" set suffix [info sharedlibextension] regsub {\.} $version {} version_no_dots set versuf $version$suffix # Determine whether to load the full BLT library or # the "lite" tcl-only version. if {[package vcompare [info tclversion] 8.2] < 0} { set taillib ${versuf}.8.0 } elseif {[package vcompare [info tclversion] 8.3] < 0} { set taillib ${versuf}.8.2 } elseif {[package vcompare [info tclversion] 8.4] < 0} { set taillib ${versuf}.8.3 } elseif {[package vcompare [info tclversion] 8.5] < 0} { set taillib ${versuf}.8.4 } elseif {[package vcompare [info tclversion] 8.6] < 0} { set taillib ${versuf}.8.5 } else { set taillib ${versuf}.8.6 } if { [info commands tk] == "tk" } { set name1 ${prefix}BLT.${taillib} set name2 ${prefix}BLT${version_no_dots}${suffix} } else { set name1 ${prefix}BLTlite.${taillib} set name2 ${prefix}BLTlite${version_no_dots}${suffix} } global tcl_platform foreach name [list $name1 $name2] { if { $tcl_platform(platform) == "unix" } { set library [file join $dir $name] if { ![file exists $library] } { # Try the parent directory. set library [file join [file dirname $dir] $name] } if { ![file exists $library] } { # Default to the path generated at compilation. set library [file join "/usr/lib" $name] } } else { set library $name } if { ![file exists $library] } continue load $library BLT break } } set version "2.5" set patchlevel "2.5.3" package ifneeded BLT $patchlevel [list LoadBLT25 $version $dir] # End of package index file ZoomStack.itcl 0000644 00000023273 15134702070 0007341 0 ustar 00 #import add itcl package require Itcl namespace import itcl::* class ZoomStackGraph { # The name of graph (nee the namespace path) variable graph "" # Indicates which corner of the rectangular zoom region # is currently being choosen. variable corner "first" # Coordinates of the current zoom region. They represent the # two corners of a rectangular area. The two points are order # independent. variable x1 variable y1 variable x2 variable y2 # A list of axis configuration commmands. Acts as a stack to # unzoom the graph back to previous axis limits. variable stack {} constructor { args } { # This will need to change when we start using inheritance. set graph [info namespace tail $this] # What about collisions between the blt::graph instance # command and the ZoomStackGraph instance command? blt::graph $graph if { [llength $args] > 0 } { $graph configure $args } # Set up the bindings to select/deselect the zoom region bind $graph <1> [code $this SelectPoint %x %y] bind $graph <3> [code $this ClearZoom] # The particular mouse buttons should be configurable. } destructor { if { [winfo exists $graph] } { destroy $graph } } # These methods are used internally, within this class, to manage the # zoom stack. private method SaveCoords { x y } private method Zoom {} private method Unzoom {} private method Empty {} private method Push { cmd } private method Pop {} private method MarkPoint { x y } private method SetTitle { title } private method DrawBox { } # These methods are called by "bind" and "after" from the Tk # event loop. Is there any way of hiding them, so that it # doesn't look to the user as part of the public interface? method ClearZoom {} method ClearTitle {} method UpdateOutline { x y } method SelectPoint { x y } } # ---------------------------------------------------------------------- # # SaveCoords -- # # Given a point on the screen, transforms the point into graph # coordinates and saves it as one of the points representing a # corner of the zoom region. # # ---------------------------------------------------------------------- body ZoomStackGraph::SaveCoords { x y } { set coords [$graph invtransform $x $y] set x [lindex $coords 0] set y [lindex $coords 1] scan [$graph xaxis limits] "%s %s" min max if { $x > $max } { set x $max } elseif { $x < $min } { set x $min } scan [$graph yaxis limits] "%s %s" min max if { $y > $max } { set y $max } elseif { $y < $min } { set y $min } if { $corner == "first" } { set x1 $x ; set y1 $y } else { set x2 $x ; set y2 $y } } # ---------------------------------------------------------------------- # # MarkPoint -- # # Adds text around one of the corners of the zoom region. # The text consists of the x,y graph coordinates of the # corner. # # ---------------------------------------------------------------------- body ZoomStackGraph::MarkPoint { x y } { set marker "bltZoom_text_$corner" set text [format "x=%.4g\ny=%.4g" $x $y] if [$graph marker exists $marker] { $graph marker configure $marker -coords { $x $y } -text $text } else { $graph marker create text -coords { $x $y } -name $marker \ -font *lucida*-r-*-10-* \ -text $text -anchor center -bg {} -justify left } } # ---------------------------------------------------------------------- # # Empty -- # # Indicates if the stack of axis configuration commands is # empty. # # ---------------------------------------------------------------------- body ZoomStackGraph::Empty { } { return [llength $stack] } # ---------------------------------------------------------------------- # # Push -- # # Appends a command on the list "stack" which can be used # to return to previous graph x and y axis ranges. # # ---------------------------------------------------------------------- body ZoomStackGraph::Push { cmd } { lappend stack $cmd } # ---------------------------------------------------------------------- # # Pop -- # # Remove the last item pushed onto the stack and returns it. # # ---------------------------------------------------------------------- body ZoomStackGraph::Pop { } { set cmd [lindex $stack end] set stack [lreplace $stack end end] return $cmd } # ---------------------------------------------------------------------- # # ClearTitle -- # # Clears the zoom title (displayed in the upper left corner # of the graph). This routine is called from the event queue # using "after". # # ---------------------------------------------------------------------- body ZoomStackGraph::ClearTitle {} { $graph marker delete "bltZoom_title" } # ---------------------------------------------------------------------- # # Unzoom -- # # Reverts to a previous zoom. Resets the x and y axis limits # back to a previous setting. First checks if there's anything # to pop back to. In addition, displays a title in the upper # left corner showing the current zoom level. # # ---------------------------------------------------------------------- body ZoomStackGraph::Unzoom { } { if ![Empty] { # Reset the x and y axis limits, by invoking the saved graph # command. eval [Pop] # Cheat: Using "Empty" to get the number of entries on the stack. set level [Empty] if { $level > 0 } { SetTitle "Zoom #$level" } blt::busy hold $graph update if { $corner == "first" } { # Remember to remove the zoom title in a couple of seconds after 2000 [code $this ClearTitle] } blt::busy release $graph } else { $graph marker delete "bltZoom_title" } } # ---------------------------------------------------------------------- # # Zoom -- # # Push the old axis limits on the stack and set them to the # zoom region. # # ---------------------------------------------------------------------- body ZoomStackGraph::Zoom { } { $graph marker delete "bltZoom_*" if { ($x1 == $x2) && ($y1 == $y2) } { # The first and last points of the zoom region are the same. # Revert back to the start. return } # Put a command on the stack that lets us revert back to the current # axis limits. set cmd [format { %s xaxis configure -min "%s" -max "%s" %s yaxis configure -min "%s" -max "%s" } $graph [$graph xaxis cget -min] [$graph xaxis cget -max] \ $graph [$graph yaxis cget -min] [$graph yaxis cget -max] ] Push $cmd # The first and last corners of the zoom region don't have to be # selected in ascending order. So consider their relative positions # when setting min and max axis limits. if { $x1 > $x2 } { $graph xaxis configure -min $x2 -max $x1 } elseif { $x1 < $x2 } { $graph xaxis configure -min $x1 -max $x2 } if { $y1 > $y2 } { $graph yaxis configure -min $y2 -max $y1 } elseif { $y1 < $y2 } { $graph yaxis configure -min $y1 -max $y2 } # Call "update" explicitly here after the graph is made busy. # This prevents the user from inadvertantly selecting another zoom # region when the graph is recalculating and redrawing itself. blt::busy hold $graph update blt::busy release $graph } # ---------------------------------------------------------------------- # # ClearZoom -- # # ---------------------------------------------------------------------- body ZoomStackGraph::ClearZoom { } { $graph marker delete "bltZoom_*" if { $corner == "first" } { # We're haven't started to select a zoom region, so assume # that we want to revert back to a previous zoom level. Unzoom } else { # Let the user re-pick the first corner again. So reset the # indicator "corner" and turn off the <Motion> binding. set corner "first" bind $graph <Motion> {} } } # ---------------------------------------------------------------------- # # SetTitle -- # # ---------------------------------------------------------------------- body ZoomStackGraph::SetTitle { title } { $graph marker create text -name "bltZoom_title" -text $title \ -coords {-Inf Inf} -anchor nw -bg {} } # ---------------------------------------------------------------------- # # UpdateOutline -- # # ---------------------------------------------------------------------- body ZoomStackGraph::UpdateOutline { x y } { SaveCoords $x $y MarkPoint $x2 $y2 DrawBox } # ---------------------------------------------------------------------- # # SelectPoint -- # # Invoked from the binding to ButtonPress-1 events. Saves # a corner of zoom region. # # # ---------------------------------------------------------------------- body ZoomStackGraph::SelectPoint { x y } { SaveCoords $x $y if { $corner == "first" } { MarkPoint $x1 $y1 # Display a new title indicating zoom pick is active set level [expr [llength $stack] + 1] SetTitle "Zoom #$level" # Start watching now for motion events, drawing an outline bind $graph <Any-Motion> [code $this UpdateOutline %x %y] # Indicate the next corner is the last set corner last } else { # Stop watching motion events bind $graph <Any-Motion> {} # Zoom into the new region defined by the outline Zoom # Reset to select the first corner, again set corner first } } # ---------------------------------------------------------------------- # # DrawBox -- # # ---------------------------------------------------------------------- body ZoomStackGraph::DrawBox { } { set coords { $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 $x1 $y1 } if [$graph marker exists "bltZoom_outline"] { $graph marker configure "bltZoom_outline" -coords $coords } else { $graph marker create line -coords $coords -name "bltZoom_outline" \ -dashes { 4 2 } } $graph marker before "bltZoom_outline" } bltCanvEps.pro 0000644 00000004345 15134702070 0007334 0 ustar 00 % % PostScript encapulator prolog file of the BLT "eps" canvas item. % % Copyright 1991-1997 Bell Labs Innovations for Lucent Technologies. % % Permission to use, copy, modify, and distribute this software and its % documentation for any purpose and without fee is hereby granted, provided % that the above copyright notice appear in all copies and that both that the % copyright notice and warranty disclaimer appear in supporting documentation, % and that the names of Lucent Technologies any of their entities not be used % in advertising or publicity pertaining to distribution of the software % without specific, written prior permission. % % Lucent Technologies disclaims all warranties with regard to this software, % including all implied warranties of merchantability and fitness. In no event % shall Lucent Technologies be liable for any special, indirect or % consequential damages or any damages whatsoever resulting from loss of use, % data or profits, whether in an action of contract, negligence or other % tortuous action, arising out of or in connection with the use or performance % of this software. % % % The definitions of the next two macros are from Appendix H of % Adobe's "PostScript Language Reference Manual" pp. 709-736. % % Prepare for EPS file /BeginEPSF { /beforeInclusionState save def /dictCount countdictstack def % Save the # objects in the dictionary /opCount count 1 sub def % Count object on operator stack userdict begin % Make "userdict" the current % dictionary /showpage {} def % Redefine showpage to be null 0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin 10 setmiterlimit [] 0 setdash newpath /languagellevel where { pop languagelevel 1 ne { false setstrokeadjust false setoverprint } if } if % note: no "end" } bind def /EndEPSF { %def count opCount sub { pop } repeat countdictstack dictCount sub { end % Clean up dictionary stack } repeat beforeInclusionState restore } bind def % % Set up a clip region based upon a bounding box (x1, y1, x2, y2). % /SetClipRegion { % Stack: x1 y1 x2 y2 newpath 4 2 roll moveto 1 index 0 rlineto 0 exch rlineto neg 0 rlineto closepath clip newpath } def tabnotebook.tcl 0000644 00000024240 15134702070 0007560 0 ustar 00 # # tabnotebook.tcl # # ---------------------------------------------------------------------- # Bindings for the BLT tabnotebook widget # ---------------------------------------------------------------------- # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@bell-labs.com # http://www.tcltk.com/blt # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ====================================================================== # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== # # Indicates whether to activate (highlight) tabs when the mouse passes # over them. This is turned off during scan operations. # set bltTabnotebook(activate) yes # ---------------------------------------------------------------------- # # ButtonPress assignments # # <ButtonPress-2> Starts scan mechanism (pushes the tabs) # <B2-Motion> Adjust scan # <ButtonRelease-2> Stops scan # # ---------------------------------------------------------------------- bind Tabnotebook <B2-Motion> { %W scan dragto %x %y } bind Tabnotebook <ButtonPress-2> { set bltTabnotebook(cursor) [%W cget -cursor] set bltTabnotebook(activate) no %W configure -cursor hand1 %W scan mark %x %y } bind Tabnotebook <ButtonRelease-2> { %W configure -cursor $bltTabnotebook(cursor) set bltTabnotebook(activate) yes %W activate @%x,%y } # ---------------------------------------------------------------------- # # KeyPress assignments # # <KeyPress-Up> Moves focus to the tab immediately above the # current. # <KeyPress-Down> Moves focus to the tab immediately below the # current. # <KeyPress-Left> Moves focus to the tab immediately left of the # currently focused tab. # <KeyPress-Right> Moves focus to the tab immediately right of the # currently focused tab. # <KeyPress-space> Invokes the commands associated with the current # tab. # <KeyPress-Return> Same as above. # <KeyPress> Go to next tab starting with the ASCII character. # # ---------------------------------------------------------------------- bind Tabnotebook <KeyPress-Up> { blt::SelectTab %W "up" } bind Tabnotebook <KeyPress-Down> { blt::SelectTab %W "down" } bind Tabnotebook <KeyPress-Right> { blt::SelectTab %W "right" } bind Tabnotebook <KeyPress-Left> { blt::SelectTab %W "left" } bind Tabnotebook <KeyPress-space> { %W invoke focus } bind Tabnotebook <KeyPress-Return> { %W invoke focus } bind Tabnotebook <KeyPress> { if { [string match {[A-Za-z0-9]*} "%A"] } { blt::FindMatchingTab %W %A } } # ---------------------------------------------------------------------- # # FirstMatchingTab -- # # Find the first tab (from the tab that currently has focus) # starting with the same first letter as the tab. It searches # in order of the tab positions and wraps around. If no tab # matches, it stops back at the current tab. # # Arguments: # widget Tabnotebook widget. # key ASCII character of key pressed # # ---------------------------------------------------------------------- proc blt::FindMatchingTab { widget key } { set key [string tolower $key] set itab [$widget index focus] set numTabs [$widget size] for { set i 0 } { $i < $numTabs } { incr i } { if { [incr itab] >= $numTabs } { set itab 0 } set label [string tolower [$widget tab cget $itab -text]] if { [string index $label 0] == $key } { break } } $widget focus $itab $widget see focus } # ---------------------------------------------------------------------- # # SelectTab -- # # Invokes the command for the tab. If the widget associated tab # is currently torn off, the tearoff is raised. # # Arguments: # widget Tabnotebook widget. # x y Unused. # # ---------------------------------------------------------------------- proc blt::SelectTab { widget tab } { set index [$widget index $tab] if { $index != "" } { $widget select $index $widget focus $index $widget see $index set w [$widget tab tearoff $index] if { ($w != "") && ($w != "$widget") } { raise [winfo toplevel $w] } $widget invoke $index } } # ---------------------------------------------------------------------- # # DestroyTearoff -- # # Destroys the toplevel window and the container tearoff # window holding the embedded widget. The widget is placed # back inside the tab. # # Arguments: # widget Tabnotebook widget. # tab Tab selected. # # ---------------------------------------------------------------------- proc blt::DestroyTearoff { widget tab } { set id [$widget id $tab] set top "$widget.toplevel-$id" if { [winfo exists $top] } { wm withdraw $top update $widget tab tearoff $tab $widget destroy $top } } # ---------------------------------------------------------------------- # # CreateTearoff -- # # Creates a new toplevel window and moves the embedded widget # into it. The toplevel is placed just below the tab. The # DELETE WINDOW property is set so that if the toplevel window # is requested to be deleted by the window manager, the embedded # widget is placed back inside of the tab. Note also that # if the tabnotebook container is ever destroyed, the toplevel is # also destroyed. # # Arguments: # widget Tabnotebook widget. # tab Tab selected. # x y The coordinates of the mouse pointer. # # ---------------------------------------------------------------------- proc blt::CreateTearoff { widget tab rootX rootY } { # ------------------------------------------------------------------ # When reparenting the window contained in the tab, check if the # window or any window in its hierarchy currently has focus. # Since we're reparenting windows behind its back, Tk can # mistakenly activate the keyboard focus when the mouse enters the # old toplevel. The simplest way to deal with this problem is to # take the focus off the window and set it to the tabnotebook widget # itself. # ------------------------------------------------------------------ set focus [focus] set window [$widget tab cget $tab -window] set index [$widget index $tab] if { ($focus == $window) || ([string match $window.* $focus]) } { focus -force $widget } set id [$widget id $index] set top "$widget.toplevel-$id" toplevel $top $widget tab tearoff $tab $top.container table $top $top.container -fill both incr rootX 10 ; incr rootY 10 wm geometry $top +$rootX+$rootY set parent [winfo toplevel $widget] wm title $top "[wm title $parent]: [$widget tab cget $index -text]" wm transient $top $parent # If the user tries to delete the toplevel, put the window back # into the tab folder. wm protocol $top WM_DELETE_WINDOW [list blt::DestroyTearoff $widget $tab] # If the container is ever destroyed, automatically destroy the # toplevel too. bind $top.container <Destroy> [list destroy $top] } # ---------------------------------------------------------------------- # # ToggleTearoff -- # # Toggles the tab tearoff. If the tab contains a embedded widget, # it is placed inside of a toplevel window. If the widget has # already been torn off, the widget is replaced back in the tab. # # Arguments: # widget tabnotebook widget. # x y The coordinates of the mouse pointer. # # ---------------------------------------------------------------------- proc blt::ToggleTearoff { widget x y index } { set tab [$widget index $index] if { $tab == "" } { return } $widget invoke $tab set container [$widget tab tearoff $index] if { $container == "$widget" } { blt::CreateTearoff $widget $tab $x $y } elseif { $container != "" } { blt::DestroyTearoff $widget $tab } } # ---------------------------------------------------------------------- # # TabnotebookInit # # Invoked from C whenever a new tabnotebook widget is created. # Sets up the default bindings for the all tab entries. # These bindings are local to the widget, so they can't be # set through the usual widget class bind tags mechanism. # # <Enter> Activates the tab. # <Leave> Deactivates all tabs. # <ButtonPress-1> Selects the tab and invokes its command. # <Control-ButtonPress-1> # Toggles the tab tearoff. If the tab contains # a embedded widget, it is placed inside of a # toplevel window. If the widget has already # been torn off, the widget is replaced back # in the tab. # # Arguments: # widget tabnotebook widget # # ---------------------------------------------------------------------- proc blt::TabnotebookInit { widget } { $widget bind all <Enter> { if { $bltTabnotebook(activate) } { %W activate current } } $widget bind all <Leave> { %W activate "" } $widget bind all <ButtonPress-1> { blt::SelectTab %W "current" } $widget bind all <Control-ButtonPress-1> { blt::ToggleTearoff %W %X %Y active } $widget configure -perforationcommand { blt::ToggleTearoff %W $bltTabnotebook(x) $bltTabnotebook(y) select } $widget bind Perforation <Enter> { %W perforation activate on } $widget bind Perforation <Leave> { %W perforation activate off } $widget bind Perforation <ButtonPress-1> { set bltTabnotebook(x) %X set bltTabnotebook(y) %Y %W perforation invoke } } treeview.tcl 0000644 00000203037 15134702070 0007106 0 ustar 00 # ====================================================================== # # treeview.tcl # # ---------------------------------------------------------------------- # Bindings for the BLT treeview widget # ---------------------------------------------------------------------- # # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@lucent.com # http://www.tcltk.com/blt # # RCS: $Id: treeview.tcl,v 1.24 2010/05/06 22:26:17 pcmacdon Exp $ # # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ---------------------------------------------------------------------- # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== namespace eval ::blt::tv { variable afterId "" variable scroll 0 variable column "" variable space off variable x 0 variable y 0 variable script [info script] variable dirname [file dirname [info script]] if {[info exists ::tcl_warn(level)] && $::tcl_warn(level)} { source [file join $dirname tvutil.tcl] } else { set ::auto_index(::blt::tv::TableWid) [list source [file join $dirname tvutil.tcl]] set ::auto_index(::blt::tv::TableLoad) [list source [file join $dirname tvutil.tcl]] set ::auto_index(::blt::tv::TreeLoad) [list source [file join $dirname tvutil.tcl]] set ::auto_index(::blt::tv::TreeDump) [list source [file join $dirname tvutil.tcl]] set ::auto_index(::blt::tv::TreeFill) [list source [file join $dirname tvutil.tcl]] } } image create photo blt::tv::normalCloseFolder -format gif -data { R0lGODlhEAANAMIAAAAAAH9/f///////AL+/vwAA/wAAAAAAACH5BAEAAAUALAAAAAAQAA0A AAM8WBrM+rAEQWmIb5KxiWjNInCkV32AJHRlGQBgDA7vdN4vUa8tC78qlrCWmvRKsJTquHkp ZTKAsiCtWq0JADs= } image create photo blt::tv::normalOpenFolder -format gif -data { R0lGODlhEAANAMIAAAAAAH9/f///////AL+/vwAA/wAAAAAAACH5BAEAAAUALAAAAAAQAA0A AAM1WBrM+rAEMigJ8c3Kb3OSII6kGABhp1JnaK1VGwjwKwtvHqNzzd263M3H4n2OH1QBwGw6 nQkAOw== } image create photo blt::tv::activeCloseFolder -format gif -data { R0lGODlhEAANAMIAAAAAAH9/f/////+/AL+/vwAA/wAAAAAAACH5BAEAAAUALAAAAAAQAA0A AAM8WBrM+rAEQWmIb5KxiWjNInCkV32AJHRlGQBgDA7vdN4vUa8tC78qlrCWmvRKsJTquHkp ZTKAsiCtWq0JADs= } image create photo blt::tv::activeOpenFolder -format gif -data { R0lGODlhEAANAMIAAAAAAH9/f/////+/AL+/vwAA/wAAAAAAACH5BAEAAAUALAAAAAAQAA0A AAM1WBrM+rAEMigJ8c3Kb3OSII6kGABhp1JnaK1VGwjwKwtvHqNzzd263M3H4n2OH1QBwGw6 nQkAOw== } image create photo blt::tv::normalFile -format gif -data { R0lGODlhFAAQAMIAAP///wAAALq2VYKCgtvb2wAAAAAAAAAAACH5BAEAAAAA LAAAAAAUABAAAAM7CLrcriHK8BxlsWIgOqCXFkKkyHnT2KjYUFFdjLoPuwS0 dcrCl6+i34Y3ewWNL+EtlVIuBtCodEBgJAAAOw== } image create photo blt::tv::openFile -format gif -data { R0lGODlhEQAQAIUAAPwCBFxaXNze3Ly2rJyanPz+/Ozq7GxqbPz6/PT29HRy dMzOzDQyNExGBIyKhERCRPz+hPz+BPz29MTCBPzy7PTq3NS+rPz+xPz27Pzu 5PTi1My2pPTm1PTezPTm3PTaxMyynMyqjPTizOzWvOzGrOTi3OzOtMSehNTK xNTCtAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEAAAAALAAAAAARABAAAAaj QIBQGCgajcMkICBoNgcBQkBJFBSuBcMBIaUysYWEYsFlKBtWsENxeJgBDTik UaBfE4KBw9yYNyINfXYFEnlvfxMRiYMSFBUWfA0TFxAXE4EFGBkVGhsMfRER EAUQoXObHB2ecJKUloEJHB4aHyCHirgNGRmzHx8hfH6Agh4iHyMkwEJxghkN HCXHJiQnb0MNCwsoKRYbICEh1UoBDOXm5wx2QQA7 } image create photo blt::tv::empty image create photo blt::tv::downarrow -format gif -data { R0lGODlhEQAJAPABAAAAAP///yH5BAEAAAEALAAAAAARAAkAAAJXTJgwYcKE CRMmTJgQIECAAAEiTJgwIUCAAAEiTJgwYUKAAAEiTJgwYcKEAAEiTJgwYcKE CQEiTJgwYcKECRMiTJgwYcKECRMmTJgwYcKECRMmTJgwYcIUADs= } image create photo blt::tv::rightarrow -format gif -data { R0lGODlhEAAQAIAAAPwCBAQCBCH5BAEAAAAALAAAAAAQABAAAAIdhI+pyxCt woNHTmpvy3rxnnwQh1mUI52o6rCu6hcAIf5oQ3JlYXRlZCBieSBCTVBUb0dJ RiBQcm8gdmVyc2lvbiAyLjUNCqkgRGV2ZWxDb3IgMTk5NywxOTk4LiBBbGwg cmlnaHRzIHJlc2VydmVkLg0KaHR0cDovL3d3dy5kZXZlbGNvci5jb20AOw== } image create photo blt::tv::ball -format gif -data { R0lGODlhEQAJAPABAAAAAP///yH5BAEAAAEALAAAAAARAAkAAAJXTJgwYcKE CRMmTJgwYcKECRMmTJgwYcKAABMmTJgwYcKAAAEmTJgwYcKEAAEiTJgwYcKE CQEiTJgwYcKECRMmTJgwYcKECRMmTJgwYcKECRMmTJgwYcIUADs= } # Seems to be a memory leak in @cursors and another in binds. if { $tcl_platform(platform) == "windows" } { if { $tk_version >= 8.3 && ![string match /zvfs* $blt_library]} { set cursor "@[file join $blt_library treeview.cur]" } else { set cursor "size_we" } option add *${className}.ResizeCursor [list $cursor] } else { option add *${className}.ResizeCursor \ "@$blt_library/treeview.xbm $blt_library/treeview_m.xbm black white" } # ---------------------------------------------------------------------- # # Initialize -- # # Invoked by internally by Treeview_Init routine. Initializes # the default bindings for the treeview widget entries. These # are local to the widget, so they can't be set through the # widget's class bind tags. # # TODO: get rid of most of this in favor of class binds. # # ---------------------------------------------------------------------- variable ::blt::tv::oldedit 0 proc ::blt::tv::Initialize { w } { # # Active entry bindings # variable oldedit $w bind Entry <Enter> { %W entry activate current } $w bind Entry <Leave> { %W entry activate "" } # # Button bindings # $w button bind all <ButtonRelease-1> { blt::tv::Toggle %W current } $w button bind all <Enter> { %W button activate current } $w button bind all <Leave> { %W button activate "" } # # ButtonPress-1 # # Performs the following operations: # # 1. Clears the previous selection. # 2. Selects the current entry. # 3. Sets the focus to this entry. # 4. Scrolls the entry into view. # 5. Sets the selection anchor to this entry, just in case # this is "multiple" mode. # $w bind Entry <ButtonPress-1> { blt::tv::SetSelectionSetAnchor %W %x %y set blt::tv::scroll 1 } #$w bind Entry <Double-ButtonPress-1> { %W toggle current } # # B1-Motion # # For "multiple" mode only. Saves the current location of the # pointer for auto-scrolling. Resets the selection mark. # $w bind Entry <B1-Motion> { set blt::tv::x %x set blt::tv::y %y set index [%W nearest %x %y] if { [%W cget -selectmode] == "multiple" } { %W selection mark $index } elseif { [%W cget -selectmode] != "none" } { blt::tv::SetSelectionAnchor %W $index } } # # ButtonRelease-1 # # For "multiple" mode only. # $w bind Entry <ButtonRelease-1> { if { [%W cget -selectmode] == "multiple" } { %W selection anchor current } after cancel $blt::tv::afterId set blt::tv::scroll 0 } # # Shift-ButtonPress-1 # # For "multiple" mode only. # $w bind Entry <Shift-ButtonPress-1> { blt::tv::SetSelectionExtendAnchor %W %x %y } $w bind Entry <Shift-Double-ButtonPress-1> { # do nothing } $w bind Entry <Shift-B1-Motion> { # do nothing } $w bind Entry <Shift-ButtonRelease-1> { after cancel $blt::tv::afterId set blt::tv::scroll 0 } # # Control-ButtonPress-1 # # For "multiple" mode only. # $w bind Entry <Control-ButtonPress-1> { blt::tv::SetSelectionAdd %W %x %y } $w bind Entry <Control-Double-ButtonPress-1> { # do nothing } $w bind Entry <Control-B1-Motion> { # do nothing } $w bind Entry <Control-ButtonRelease-1> { after cancel $blt::tv::afterId set blt::tv::scroll 0 } $w bind Entry <Control-Shift-ButtonPress-1> { if { [%W cget -selectmode] == "multiple" && [%W selection present] } { if { [%W index anchor] == "" } { %W selection anchor current } if { [%W selection includes anchor] } { %W selection set anchor current } else { %W selection clear anchor current %W selection set current } } elseif { [%W cget -selectmode] != "none" } { blt::tv::SetSelectionAnchor %W current } } $w bind Entry <Control-Shift-Double-ButtonPress-1> { # do nothing } $w bind Entry <Control-Shift-B1-Motion> { # do nothing } $w bind Entry <Shift-ButtonPress-3> { blt::tv::EditColumn %W %X %Y } $w column bind all <Enter> { %W column activate [%W column current] } $w column bind all <Leave> { %W column activate "" } $w column bind Rule <Enter> { %W column activate [%W column current] %W column resize activate [%W column current] } $w column bind Rule <Leave> { %W column activate "" %W column resize activate "" } $w column bind Rule <ButtonPress-1> { %W column resize anchor %x } $w column bind Rule <B1-Motion> { %W column resize mark %x } $w column bind Rule <ButtonRelease-1> { %W column configure [%W column current] -width [%W column resize set] } set ::blt::tv::curRelief raised $w column bind all <ButtonPress-1> { set blt::tv::column [%W column current] set blt::tv::curRelief [%W column cget $blt::tv::column -titlerelief] %W column configure $blt::tv::column -titlerelief sunken } $w column bind all <ButtonRelease-1> { set column [%W column current] if { $column != "" } { %W column invoke $column } %W column configure $blt::tv::column -titlerelief $blt::tv::curRelief } if {$oldedit} { $w bind TextBoxStyle <Alt-ButtonPress-3> { if { [%W edit -root -test %X %Y] } { break } } $w bind TextBoxStyle <Shift-ButtonRelease-1> { if { [%W edit -root -test %X %Y] } { blt::tv::EditColumn %W %X %Y break } } $w bind TextBoxStyle <Double-1> { if { [%W edit -root -test %X %Y] } { blt::tv::EditColumn %W %X %Y break } } } # $w bind CheckBoxStyle <Enter> { # set column [%W column current] # if { [%W column cget $column -edit] } { # %W style activate current $column # } # } # $w bind CheckBoxStyle <Leave> { # %W style activate "" # } $w bind CheckBoxStyle <ButtonPress-1> { if { [%W edit -root -test %X %Y] } { event generate %W <<TreeViewEditStart>> -x [%W col index [%W col current]] -y [%W index @%x,%y] break } } $w bind CheckBoxStyle <B1-Motion> { if { [%W column cget [%W column current] -edit] } { break } } $w bind CheckBoxStyle <ButtonRelease-1> { if { [%W edit -root -test %X %Y] } { %W edit -root %X %Y event generate %W <<TreeViewEditEnd>> -x [%W col index [%W col current]] -y [%W index @%x,%y] break } } if 0 { $w bind ComboBoxStyle <ButtonPress-1> { set column [%W column current] %W style activate focus $column if { [%W column cget $column -edit] } { break } } $w bind ComboBoxStyle <ButtonRelease-1> { %W style activate 0 if { [%W edit -root -test %X %Y] } { %W edit -root %X %Y break } } $w bind ComboBoxStyle <Double-1> { if { [%W edit -root -test %X %Y] } { blt::tv::EditColumn %W %X %Y break } } } if {$oldedit} { $w bind ComboBoxStyle <Shift-ButtonRelease-1> { if { [%W edit -root -test %X %Y] } { blt::tv::EditColumn %W %X %Y break } } } else { $w bind ComboBoxStyle <ButtonPress-1> {} } $w bind ComboBoxStyle <ButtonRelease-1> { if { [%W edit -root -test %X %Y] } { blt::tv::Combobox-List %W %X %Y } } } proc ::blt::tv::Combobox-List-Done {W entry col args} { set i [$W index active] set v [$W get $i] set l [winfo parent $W] set w [winfo parent $l] $w entry set $entry $col $v event generate $w <<TreeViewEditEnd>> -x [$w col index $col] -y $entry destroy $l $w style activate 0 } proc ::blt::tv::Combobox-List-Close {l} { set w [winfo parent $l] destroy $l $w style activate 0 } proc ::blt::tv::Combobox-List {w x y} { # Popup combo-list for combobox. # TODO: could put frame in toplevel so not clipped. set Opts { { -height 6 "Listbox height" } { -leafs False "Edit only leaf nodes" } { -leave 1 "Setup handler for leave" } { -conf {} "Listbox widget configuration options" } { -optscmd {} "Callback to get edit options" -type {cmd w r c} } { -readonly False "Do not allow editing" } { -useframe 1 "Use a frame below treeview widget" } { -usetopframe 0 "Use a frame at toplevel" } { -withouttag {} "Edit only entries without tag"} { -withtag {} "Edit only entries with tag"} } if {[winfo exists $w.edit]} return set lx [expr {$x-[winfo rootx $w]}] set ly [expr {$y-[winfo rooty $w]}] set ind [$w index @$lx,$ly] #if {[llength [set lst [$w cget -values]]] == 0} return set col [$w column current] if {![$w column cget $col -edit]} return set widopts [$w column cget $col -editopts] set cellstyle [lindex [$w style get $col $ind] 0] if {$cellstyle != {}} { if {[$w style cget $cellstyle -readonly]} return set widopts [concat $widopts [$w style cget $cellstyle -editopts]] } set edopts {} foreach i $Opts { set q([lindex $i 0]) [lindex $i 1] lappend edopts [lindex $i 0] [lindex $i 1] } set opts { -activestyle dotbox -bd 2 -pad 10 -relief sunken -selectmode single } set style $cellstyle if {$style == {}} { set style [$w column cget $col -style] } set ckey [$w style cget $style -choicekey] set cmd [$w style cget $style -choicecmd] set lst [$w style cget $style -choices] if {$ckey != {}} { set lst [$w entry get $ind $ckey {}] } if {$cmd != {} && $lst == {}} { set cmd [string map [list %% % %W $w %X $x %Y $y %# $ind %C $col] $cmd] set lst [namespace eval :: $cmd] } set offs [$w column offsets] set cind [$w column index $col] set xstart [lindex $offs $cind] if {$cind >= ([llength $offs]-1)} { set xend [winfo width $w] } else { set xend [lindex $offs [expr {$cind+1}]] } if {$q(-optscmd) != {}} { set ewopts [eval $q(-optscmd) $w $ind $col] if {[llength $ewopts]%2} { tclLog "TreeView -optscmd: odd length: '$ewopts' for $w" } else { array set q $ewopts } } if {$q(-readonly)} return if {$q(-leafs) && [llength [$w entry children $ind]]} return set tags [$w tag names $ind] if {$q(-withtag) != {}} { if {[lsearch -exact $tags $q(-withtag)]<0} return } if {$q(-withouttag) != {}} { if {[lsearch -exact $tags $q(-withouttag)]>=0} return } set xsiz [expr {$xend-$xstart}] set entry $ind set bb [$w bbox -screen $ind] if {[llength $bb]!=4} return foreach {xbegin ystart xwidth ywidth} $bb break #set ystart [lindex $bb 1] set yend [expr {$ywidth+$ystart}] #tclLog "COL: $col, $lst, entry=$entry, offs=$offs, cind=$cind, xsiz=$xsiz, xstart=$xstart, bb=$bb" if {$q(-usetopframe)} { set wl [string trimright [winfo toplevel $w] .]._list } else { set wl $w._list } if {[winfo exists $wl]} { destroy $wl focus -force $w $w style activate 0 return } event generate $w <<TreeViewEditStart>> -x $cind -y $ind $w style activate focus $cind focus $w if {$q(-useframe) || $q(-usetopframe)} { canvas $wl if {$q(-leave)} { bind $wl <Leave> { ::blt::tv::Combobox-List-Close %W } } } else { toplevel $wl wm withdraw $wl wm transient $wl [winfo toplevel $w] raise [winfo toplevel $w] wm overrideredirect $wl 1 if {$q(-leave)} { bind $wl <Leave> { if {[winfo toplevel %W] == "%W"} { ::blt::tv::Combobox-List-Close %W } } } } set h $q(-height) if {[llength $lst]<=$h} { set h [expr {1+[llength $lst]}] } set opts [concat -height $h $opts] set l $wl._l listbox $l foreach {i j} $opts { catch { $l conf $i $j } } if {$q(-conf) != {}} { catch { eval $l conf $q(-conf) } } bindtags $l [concat [bindtags $l] TVComboBox::List] $l conf -yscrollcommand [list $wl._vscroll set] scrollbar $wl._vscroll -orient vertical -command [list $l yview] if {[llength $lst]>$h} { grid $wl._vscroll -row 1 -column 2 -sticky ns } grid $l -row 1 -column 1 -sticky news grid columnconf $wl 1 -weight 1 grid rowconf $wl 1 -weight 1 set val [$w get] foreach i $lst { $l insert end $i if {[string equal $i $val]} { $l activate end; $l see end } } bind $l <Visibility> [subst -nocommands { bind $l <Visibility> {} if {[$l xview] != "0 1"} { $l conf -xscrollcommand [list $wl._hscroll set] scrollbar $wl._hscroll -orient horizontal -command [list $wl xview] grid $wl._hscroll -row 2 -column 1 -sticky we grid $wl._vscroll -row 1 -column 2 -sticky ns focus -force $l } }] bind $l <<TVComboBox-List-Done>> [list [namespace current]::Combobox-List-Done $l $entry $col] set H [winfo reqheight $l] set Xstart [expr {$xstart+[winfo x $w]}] set Yend [expr {$yend+[winfo x $w]}] set wwhig [winfo height $w] if {!(($ystart+$H) <= $wwhig || ($ystart-$H)<0)} { set Yend [expr {$ystart-$H}] } if {$q(-usetopframe)} { place $wl -in $w -width ${xsiz} -height $H -x $Xstart -y $Yend $wl conf -width $xsiz -height $H } elseif {$q(-useframe)} { place $wl -in $w -width ${xsiz} -height $H -x $Xstart -y $Yend $wl conf -width $xsiz -height $H } else { wm geometry $wl ${xsiz}x${H}+$Xstart+$Yend wm deiconify $wl } $w edit -noscroll if {$q(-usetopframe)} { bind $e <Destroy> +[list catch "$wl edit -scroll" ] } else { set tag [namespace current] bindtags $wl [concat $tag [bindtags $wl]] bind $tag <Destroy> {catch {[winfo parent %W] edit -scroll}} } after idle [list catch "focus -force $l"] return -code break } proc ::blt::tv::Combobox-List-Key {l ch args} { # Navigate to the first item starting with char ch. array set p { -now 0 } array set p $args if {![string is alpha -strict $ch]} return set cur [$l index active] set e [$l index end] foreach i {0 1} { set n -1 while {[incr n]<$e} { set c [string index [$l get $n] 0] if {$i} { set c [string toupper $c] } if {[string equal $c $ch]} { $l activate $n $l see $n if {$n == $cur || $p(-now)} { event generate $l <Return> } return } } set ch [string toupper $ch] } return -code break } proc ::blt::tv::SortColumn {t {column {}} args} { # Provide sorting for a column. array set p {-hold 1 -see 1 -highlight 0} array set p $args set do 1 if {$column == {}} { set column [$t column current] } if {[string equal $column [$t sort cget -column]]} { set decr [expr {![$t sort cget -decreasing]}] if {!$decr} { $t sort conf -column {} -decreasing 0 if {[$t sort cget -setflat] } { $t configure -flat no $t sort configure -setflat no } set do 0 } } else { set decr 0 } if {$do} { set mode [$t column cget $column -sortmode] if {$mode != "none"} { $t sort configure -mode $mode } $t sort configure -decreasing $decr -column $column if {![$t cget -flat] } { $t configure -flat yes $t sort configure -setflat yes } $t sort auto yes if {$p(-hold)} { blt::busy hold $t update blt::busy release $t } if {$p(-highlight)} { after 300 [list $t column activate $column] } } else { if {$p(-highlight)} { $t column activate {} } } if {$p(-see)} { set sel [$t curselection] if {$sel != {}} { after idle [list $t see [lindex $sel 0]] } } set cind [$t column index $column] event generate $t <<TreeViewSortColumn>> -x $cind } bind TVComboBox <3> [list blt::tv::Combobox-List %W %x %y] bind TVComboBox::List <Enter> { focus -force %W } bind TVComboBox::List <KeyRelease-Escape> { destroy [winfo parent %W] } bind TVComboBox::List <Return> { event generate %W <<TVComboBox-List-Done>>} bind TVComboBox::List <space> [bind TVComboBox::List <Return>] bind TVComboBox::List <ButtonRelease-1> [bind TVComboBox::List <Return>] bind TVComboBox::List <KeyRelease-space> [bind TVComboBox::List <Return>] bind TVComboBox::List <Control-n> [bind Listbox <Down>] bind TVComboBox::List <Control-p> [bind Listbox <Up>] bind TVComboBox::List <Control-d> [bind Listbox <Next>] bind TVComboBox::List <Control-u> [bind Listbox <Prior>] bind TVComboBox::List <KeyPress> [list blt::tv::Combobox-List-Key %W %A] proc blt::tv::SetSelectionAnchor { w tagOrId } { if {$tagOrId == ""} return set index [$w index $tagOrId] # If the anchor hasn't changed, don't do anything if { $index != [$w index anchor] } { $w selection clearall $w see $index $w focus $index $w selection set $index $w selection anchor $index } } proc blt::tv::SetSelectionSetAnchor { w x y} { set mode [$w cget -selectmode] switch -- $mode { none return cell { } multicell {} default { set blt::tv::x $x set blt::tv::y $y SetSelectionAnchor $w @$x,$y return } } $w selection clearall set index [$w index @$x,$y] set col [$w column nearest $x] if {$index != {} && $col != {}} { $w selection set $index $index $col $w selection anchor $index $col $w focus $index } } proc blt::tv::SetSelectionAdd {w x y} { set mode [$w cget -selectmode] set index [$w index @$x,$y] switch -- $mode { none return cell { $w selection clearall } multicell { } multiple { set index [$w index current] $w selection toggle $index $w selection anchor $index return } default { SetSelectionAnchor $w current return } } set col [$w column nearest $x] if {$index != {} && $col != {}} { $w selection toggle $index $index $col } } proc blt::tv::SetSelectionExtendAnchor {w x y} { set mode [$w cget -selectmode] switch -- $mode { none {} multiple { if {[$w selection present] } { if { [$w index anchor] == "" } { $w selection anchor current } set index [$w index anchor] $w selection clearall $w selection set $index current } } single { blt::tv::SetSelectionAnchor $w current } cell { SetSelectionSetAnchor $w $x $y } multicell { # Select range. set col [$w column nearest $x] set oanch [$w selection anchor] set anch [$w index anchor] set ocell [lindex $oanch 1] set index [$w index @$x,$y] if {$col == {} || $ocell == {}} { return [SetSelectionSetAnchor $w $x $y] } set cols [$w column names] set coli [lsearch $cols $col] set ocelli [lsearch $cols $ocell] if {$coli<0 || $ocelli<0} { return [SetSelectionSetAnchor $w $x $y] } if {$coli<$ocelli} { set sci $coli set coli $ocelli set ocelli $sci } set clst {} foreach c [lrange $cols $ocelli $coli] { if {$c == "#0"} continue if {[$w column cget $c -hide]} continue lappend clst $c } set nlst {} foreach n [$w find $index $anch] { if {[$w entry cget $n -hide]} continue lappend nlst $n } $w selection clearall foreach n $nlst { foreach c $clst { $w selection set $n $n $c } } } } } # ---------------------------------------------------------------------- # # AutoScroll -- # # Invoked when the user is selecting elements in a treeview # widget and drags the mouse pointer outside of the widget. # Scrolls the view in the direction of the pointer. # # ---------------------------------------------------------------------- proc blt::tv::AutoScroll { w } { if { ![winfo exists $w] } { return } set x $blt::tv::x set y $blt::tv::y set index [$w nearest $x $y] if {$y >= [winfo height $w]} { $w yview scroll 1 units set neighbor down } elseif {$y < 0} { $w yview scroll -1 units set neighbor up } else { set neighbor $index } if { [$w cget -selectmode] == "single" } { blt::tv::SetSelectionAnchor $w $neighbor } elseif { [$w cget -selectmode] != "none" } { catch {$w selection mark $index} } set ::blt::tv::afterId [after 50 blt::tv::AutoScroll $w] } proc blt::tv::SetFocus { w tagOrId } { # Set focus at index given by tagOrId. if {[catch {$w index $tagOrId} t]} return if {[catch {$w focus $t}]} return $w selection clearall if {[catch {$w selection set $t}]} return $w selection anchor $t $w entry activate $t $w see $t event generate $w <<TreeViewFocusEvent>> return $t } # ---------------------------------------------------------------------- # # MoveFocus -- # # Invoked by KeyPress bindings. Moves the active selection to # the entry <where>, which is an index such as "up", "down", # "prevsibling", "nextsibling", etc. # # ---------------------------------------------------------------------- proc blt::tv::MoveFocus { w tagOrId {flag 0}} { set mode [$w cget -selectmode] switch -- $mode { multiple { catch {$w focus $tagOrId} if {!$flag} { $w selection clearall } if {[catch {$w selection set focus}]} return $w selection anchor focus } single { catch {$w focus $tagOrId} $w selection clearall if {[catch {$w selection set focus}]} return $w selection anchor focus } multicell - cell { set cells [$w selection cells] catch {$w focus $tagOrId} $w selection clearall if {[catch {$w selection set focus}]} return $w selection anchor focus set ind [$w index focus] if {$cells != {}} { set col [lindex $cells 1] } else { set vcols [$w column names -visible] set col [lindex $vcols 0] } $w selection set focus focus $col } } $w see focus event generate $w <<TreeViewFocusEvent>> } # ---------------------------------------------------------------------- # # MovePage -- # # Invoked by KeyPress bindings. Pages the current view up or # down. The <where> argument should be either "top" or # "bottom". # # ---------------------------------------------------------------------- proc blt::tv::MovePage { w where } { # If the focus is already at the top/bottom of the window, we want # to scroll a page. It's really one page minus an entry because we # want to see the last entry on the next/last page. set focus [$w index focus] if {$where == "top"} { if {[$w index up] != $focus} { $w yview scroll -1 pages $w yview scroll 1 units } if {[$w index focus] == $focus} { catch { $w entry select up } } } else { if {[$w index down] != $focus} { $w yview scroll 1 pages $w yview scroll -1 units } if {[$w index focus] == $focus} { catch { $w entry select down } } } update # Adjust the entry focus and the view. Also activate the entry. # just in case the mouse point is not in the widget. $w entry activate view.$where $w focus view.$where $w see view.$where if { [$w cget -selectmode] == "single" } { $w selection clearall catch {$w selection set focus} } event generate $w <<TreeViewFocusEvent>> } # ---------------------------------------------------------------------- # # NextMatch -- # # Invoked by KeyPress bindings. Searches for an entry that # starts with the letter <char> and makes that entry active. # # ---------------------------------------------------------------------- proc blt::tv::NextMatch { w key state} { if {$state != 0 && $state != 1} return if {[string match {[ -~]} $key]} { set last [$w index focus] set next [$w index next] while { $next != {} && $next != $last } { set label [$w entry cget $next -label] set label [string index $label 0] if { [string tolower $label] == [string tolower $key] } { break } set next [$w index -at $next next] } if {$next == {}} return $w focus $next if {[$w cget -selectmode] == "single"} { $w selection clearall $w selection set focus event generate $w <<TreeViewFocusEvent>> } $w see focus } } #------------------------------------------------------------------------ # # InsertText -- # # Inserts a text string into an entry at the insertion cursor. # If there is a selection in the entry, and it covers the point # of the insertion cursor, then delete the selection before # inserting. # # Arguments: # w Widget where to insert the text. # text Text string to insert (usually just a single character) # #------------------------------------------------------------------------ proc blt::tv::InsertText { w text } { if { [string length $text] > 0 } { set index [$w index insert] if { ($index >= [$w index sel.first]) && ($index <= [$w index sel.last]) } { $w delete sel.first sel.last } $w insert $index $text } } #------------------------------------------------------------------------ # # Transpose - # # This procedure implements the "transpose" function for entry # widgets. It tranposes the characters on either side of the # insertion cursor, unless the cursor is at the end of the line. # In this case it transposes the two characters to the left of # the cursor. In either case, the cursor ends up to the right # of the transposed characters. # # Arguments: # w The entry window. # #------------------------------------------------------------------------ proc blt::tv::Transpose { w } { set i [$w index insert] if {$i < [$w index end]} { incr i } set first [expr {$i-2}] if {$first < 0} { return } set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first] $w delete $first $i $w insert insert $new } #------------------------------------------------------------------------ # # GetSelection -- # # Returns the selected text of the entry with respect to the # -show option. # # Arguments: # w Entry window from which the text to get # #------------------------------------------------------------------------ proc blt::tv::GetSelection { w } { set text [string range [$w get] [$w index sel.first] \ [expr {[$w index sel.last] - 1}]] if {[$w cget -show] != ""} { regsub -all . $text [string index [$w cget -show] 0] text } return $text } proc blt::tv::TextCopy {w {edit 0} {aslist 0}} { # Handle <<Copy>> event, copying selection/focus to clipboard. if {!$edit} { catch { set inds [$w curselection] if {$inds == {}} { set inds [$w index focus] } set all {} set n -1 foreach ind $inds { incr n set data {} foreach i [$w column names] { if {[$w col cget $i -hid]} continue if {$i == "#0"} { set val [$w entry cget $ind -label] } else { set val [$w entry set $ind $i] } if {$aslist} { lappend data $val } else { append data " " $val } } if {$aslist} { lappend all $data } else { if {$n} { append all \n } append all $data } } clipboard clear -displayof $w clipboard append -displayof $w $all } } else { catch { set w [winfo parent $w] set ind [$w index focus] set col [$w column current] if {$col == {}} { set col $::blt::tv::curCol } set data [$w entry set $ind $col] clipboard clear -displayof $w clipboard append -displayof $w $data } } } proc ::blt::tv::Toggle {w ind} { # Toggle and set view. set ind [$w index $ind] if {$ind == {}} return $w toggle $ind if {[$w entry isopen $ind] && [$w cget -openanchor] != {} && [$w entry children $ind] != {}} { $w see -anchor [$w cget -openanchor] $ind } else { $w see $ind } } proc ::blt::tv::Click {w x y} { if {[focus] != $w} { focus $w } set ::blt::tv::space off #if {[winfo exists $w.edit]} { destroy $w.edit } event generate $w <<TreeViewFocusEvent>> } bind $className <ButtonRelease-1> {::blt::tv::Click %W %x %y} bind $className <Double-ButtonPress-1> {blt::tv::EditCol %W %x %y } bind $className <Alt-ButtonPress-1> {blt::tv::EditCol %W %x %y } bind $className <Control-minus> {if {[%W index parent]>0} { after idle "%W entry select [%W entry parent focus]"; %W close [%W entry parent focus] }} bind $className <Control-o> { ::blt::tv::Toggle %W focus } bind $className <Control-a> { blt::tv::MoveFocus %W parent } bind $className <Control-Shift-O> { %W open -recurse focus } bind $className <Control-Shift-C> { %W close -recurse focus } bind TreeViewEditWin <KeyRelease-Escape> {focus [winfo parent %W]; destroy %W; break} bind TreeViewEditWin <KeyPress-Return> {event generate %W <<TreeViewEditComplete>>; break} #bind TreeViewEditWin <KeyPress-Return> {break} proc ::blt::tv::EditDone {w e x y ind col cind data styledata cellstyle ied endcmd treelabel vcmd} { # # Handle edit completion: call $endcmd and widget -vcmd if req. switch -- [winfo class $e] { Entry - Spinbox { set newdata [$e get] } Text { set newdata [string trimright [$e get 1.0 end]] } default { set newdata $data } } # Invoke validation for Entry/Spinbox/Text if string changed. set ok 1 if {![string equal $data $newdata]} { if {$vcmd == {}} { set vcmd [$w column cget $col -validatecmd] } if {$vcmd != {}} { if {[string first % $vcmd]>=0} { set ccmd [string map [list %% % %W $w %X $x %Y $y %# $ind %C $cind %V [list $newdata]] $vcmd] } else { set ccmd [concat $vcmd [list $w $newdata $data $ind $col]] } set newdata [namespace eval :: $ccmd] } if {![winfo exists $w]} return } if {![string equal $data $newdata]} { set istree [$w column istree $cind] if {$ind == -1} { $w col conf $cind -title $newdata } elseif {$istree} { if {$treelabel} { [$w cget -tree] label $ind $newdata } else { $w entry conf $ind -label $newdata } } else { if {$styledata != {}} { set newdata [list $styledata $newdata] } $w entry set $ind $col $newdata } if {$endcmd != {}} { if {[string first % $endcmd]>=0} { set ccmd [string map [list %% % %W $w %X $x %Y $y %# $ind %C $cind %V [list $newdata]] $endcmd] set ccmd [concat $endcmd [list $w $newdata $data $ind $col]] } namespace eval :: $ccmd } if {![winfo exists $w]} return event generate $w <<TreeViewEditEnd>> -x $cind -y $ind } if {$ied} { catch { bind $e <Destroy> {} } $w style set $cellstyle $col $ind } else { catch { place forget $e } } destroy $e catch { focus $w } #after idle [list destroy $e] } proc ::blt::tv::TabMove {w ind cind args} { # Handle Tab char. #Opts p $args { # { -cmd {} "Callback to get next cell" -type {cmd ind cind} } # { -endcol {} "Maximum column (defaults to last col)" } # { -startcol 0 "Column to start new row at" } # { -wrap True "At last row return to top" } #} array set p { -cmd {} -endcol {} -startcol 0 -wrap True -opts {}} array set p $args set vis [$w column names -visible] set maxc [expr {[llength $vis]-1}] if {$p(-endcol) == {} || $p(-endcol) > $maxc} { set p(-endcol) $maxc } set maxr [$w index end] if {$p(-cmd) != {}} { set ncol [eval $p(-cmd) $ind,$cind] if {$ncol == {}} return foreach {ind col} $ncol break EditCell $w $ind $col return } set down [expr {$p(-wrap)?"next":"down"}] set cnt 100 while 1 { if {[incr cnt -1] == 0} return incr cind 1 if {$cind > $p(-endcol)} { set cind $p(-startcol) set ind [$w index $down] $w focus $ind } if {[$w column cget $cind -edit] && ![$w column cget $cind -hide]} break } EditCell $w $ind $cind return } proc ::blt::tv::EditCell { w ind col {x {}} {y {}}} { # Handle text editing of a cell. if {![winfo exists $w]} return # Option choices for -editopts. set Opts { { -allowtypes textbox "List of types to allow text editing for (or *)" } { -autonl False "Default to text widget if newlines in data"} { -choices {} "Choices for combo/spinbox" } { -conf {} "Extra entry/text widget options to set" } { -embed False "Use an embedded window style for edit window" } { -endcmd {} "Command to invoke at end of edit" -type cmd } { -leafs False "Edit only leaf nodes" } { -nlkeys {<Control-r> <Shift-Return>} "Keys for inserting newline" } { -notnull False "Field may not be null" } { -optscmd {} "Callback to get edit options" -type {cmd w r c} } { -readonly False "Do not allow editing" } { -sel True "Value is selected on edit" } { -startcmd {} "Command to invoke at start of edit" -type {cmd w r c} } { -tab {} "bind Tab char in edit (bool or args passed to TabMove)" } { -titles False "Allow edit of titles" } { -treelabel True "Edit -tree cmd label rather than treeview label" } { -type {} "Support basic Wize types like bool, int, and choice" } { -typecol {} "Column/key to get -type from" } { -undo True "Text widget enables undo" } { -vcmd {} "Validate command to override -validatecmd" -type cmd } { -widget {} "Widget to use (defaults to entry)" } { -withouttag {} "Edit only entries without tag"} { -withtag {} "Edit only entries with tag"} { -wrap none "Wrap mode for text widget" } } if {[winfo exists $w._list]} return $w see current set e $w.edit if { [winfo exists $e] } { destroy $e } set ind [$w index $ind] set cind [$w column index $col] set ed [$w column cget $col -edit] if { !$ed } return set intitle 0 if {$x == {}} { set bb [$w col bbox $col $ind] set x [lindex $bb 0] set y [lindex $bb 1] } set istree [$w column istree $col] set edopts {} foreach i $Opts { set q([lindex $i 0]) [lindex $i 1] lappend edopts [lindex $i 0] [lindex $i 1] } set widopts [$w column cget $col -editopts] set cellstyle [lindex [$w style get $cind $ind] 0] if {$cellstyle != {}} { if {[$w style cget $cellstyle -readonly]} return set widopts [concat $widopts [$w style cget $cellstyle -editopts]] } if {$widopts != {}} { if {[llength $widopts]%2} { tclLog "TreeView -editopts: odd length: '$widopts' for $w" } else { array set q $widopts if {$q(-optscmd) != {}} { set ewopts [eval $q(-optscmd) $w $ind $col] if {[llength $ewopts]%2} { tclLog "TreeView -optscmd: odd length: '$ewopts' for $w" } else { array set q $ewopts } } if {[array size q] != ([llength $edopts]/2)} { set bad {} array set r $edopts set good [lsort [array names r]] foreach {i j} $widopts { if {![info exists r($i)]} { lappend bad $i } } tclLog "TreeView -editopts: bad option: '$bad' not in '$good'" } } } if {$q(-typecol) != {} && $q(-type) == {}} { if {[catch { set q(-type) [$w entry set $ind $q(-typecol)] }] && [catch { set q(-type) [[$w cget -tree] get $ind $q(-typecol)] }]} { tclLog "Failed to get -typecol $q(-typecol)" } } set wopts {} if {$q(-type) != {}} { switch -- [lindex $q(-type) 0] { bool { set q(-choices) {"" True False} set q(-widget) spinbox } Bool { lset q(-choices) {True False} set q(-widget) spinbox } int - Int - double - Double { array set qq {-min -999999999 -max 99999999 -incr 1} array set qq [lrange $q(-type) 1 end] set wopts [list -from $qq(-min) -to $qq(-max) -increment $qq(-incr)] set q(-widget) spinbox } Choice { set q(-choices) [lrange $q(-type) 1 end] set q(-widget) spinbox } } } if {$q(-readonly)} return if {!$q(-titles) && [set intitle [expr {[$w column nearest $x $y] != {}}]]} return if {$q(-leafs) && [llength [$w entry children $ind]]} return set tags [$w tag names $ind] if {$q(-withtag) != {}} { if {[lsearch -exact $tags $q(-withtag)]<0} return } if {$q(-withouttag) != {}} { if {[lsearch -exact $tags $q(-withouttag)]>=0} return } set styledata {} if {$intitle} { set data [$w column cget $col -title] set ind -1 } elseif {$istree } { if {$q(-treelabel) && [namespace which [$w cget -tree]] == {}} { set q(-treelabel) 0 } if {$q(-treelabel)} { set data [[$w cget -tree] label $ind] } else { set data [$w entry cget $ind -label] } } else { set data [$w entry set $ind $col] if {[$w cget -inlinedata] && [string first @ $data]>=0} { if {![catch {llength $data} len] && $len <= 2 && [string match @?* [lindex $data 0]] && [lsearch -exact [$w style names] [string range [lindex $data 0] 1 end]]>=0} { #set styledata [lindex $data 0] set data [lindex $data 1] } } } set bbox [$w column bbox -visible $col $ind] if {![llength $bbox]} return foreach {X Y W H} $bbox break set wid entry set style [$w col cget $cind -style] set rstyle [expr {$cellstyle == {} ? $style : $cellstyle }] set stype [expr {$rstyle == {} ? {} : [$w style type $rstyle]}] #if {[$w style cget $style -readonly]} return if {[lsearch $q(-allowtypes) $stype]<0 && $q(-allowtypes) != "*"} return if {$widopts != {}} { if {$q(-widget) != {}} { set wid $q(-widget) } elseif {$q(-autonl)} { if {$stype == "combobox"} { set wid spinbox } elseif {[string first \n $data]>=0} { set wid text } else { set wid entry } } } if {[catch {eval $wid $e} err]} { entry $e } foreach {i j} $wopts { catch { $e conf $i $j} } catch { $e conf -font [$w cget -font] } set ied 0 if {$q(-embed) && !$istree} { catch {$w style create windowbox editwin} if {$bbox != {}} { #TODO: embedded should temporarily set col width, if currently is 0. set mwid $W if {$mwid>16} { incr mwid -10 } set mhig $H $w style conf editwin -minheight $mhig -minwidth $mwid } $w style set editwin $cind $ind $w entry set $ind $col $e bind $e <Destroy> [list $w entry set $ind $col $data] bind $e <Destroy> +[list $w style set $cellstyle $col $ind] set ied 1 } else { place $e -x $X -y $Y -width $W -height $H } switch -- [winfo class $e] { Entry { $e insert end $data if {$q(-sel)} { $e selection range 0 end } foreach i $q(-nlkeys) { bind $e $i "$e insert insert {\n}; break" } } Spinbox { $e insert end $data if {$q(-choices) != {}} { $e conf -values $q(-choices) } if {$q(-sel)} { $e selection range 0 end } set style [$w col cget $cind -style] if {$stype == "combobox"} { set ch [$w style cget $style -choices] if {$ch == {} && [set ccmd [$w style cget $style -choicecmd]] != {}} { set ccmd [string map [list %% % %W $w %X $x %Y $y %# $ind %C $cind] $ccmd] set ch [namespace eval :: $ccmd] } if {$ch != {}} { if {[set nn [lsearch -exact $ch $data]]<0} { set ch [concat [list $data] $ch] } elseif {$n != 0} { set ch [concat [list $data] [lreplace $ch $nn $nn]] } $e conf -values $ch } } foreach i $q(-nlkeys) { bind $e $i "$e insert insert {\n}; break" } } Text { $e conf -highlightthick 0 -padx 0 -pady 0 -bd 1 $e conf -undo $q(-undo) -wrap $q(-wrap) $e insert end $data if {$q(-sel)} { $e tag add sel 1.0 end } foreach i $q(-nlkeys) { bind $e $i "$e insert insert {\n}; $e see insert; break" } } } catch {$e conf -highlightthick 0} if {$q(-conf) != {}} { if {[catch {eval $e conf $q(-conf)} err]} { tclLog "Opts err: $err" } } bind $e <1> [list focus $e] bindtags $e [concat TreeViewEditWin [bindtags $e]] tkwait visibility $e focus $e after 100 [list catch [list focus $e]] after 300 [list catch [list focus $e]] bind $e <<TreeViewEditComplete>> [list ::blt::tv::EditDone $w $e $x $y $ind $col $cind $data $styledata $cellstyle $ied $q(-endcmd) $q(-treelabel) $q(-vcmd)] if {![string is false $q(-tab)]} { set topts {} if {![string is true $q(-tab)]} { set topts $q(-tab) } bind $e <Tab> "event generate $e <<TreeViewEditComplete>>; [namespace current]::TabMove $w $ind $cind $topts; break" } event generate $w <<TreeViewEditStart>> -x $cind -y $ind if {[winfo exists $e] && $q(-startcmd) != {}} { if {[string first % $vcmd]>=0} { set ccmd [string map [list %% % %W $w %X $x %Y $y %# $ind %C $cind %V [list $data]] $q(-startcmd)] } else { set ccmd [concat $q(-startcmd) [list $w $col $ind] ] } namespace eval :: $ccmd } if {![winfo exists $e]} return $w edit -noscroll set tag [namespace current] bindtags $e [concat $tag [bindtags $e]] bind $tag <Destroy> { catch {[winfo parent %W] edit -scroll} } return } proc ::blt::tv::commify {num {sep ,}} { # Make number comma seperated every 3 digits. while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1$sep\\2" num]} {} return $num } proc ::blt::tv::EditCol { w x y } { # Main handler for cell-edit/toggle-open. if {![winfo exists $w]} return $w see current set e $w.edit if { [winfo exists $e] } { destroy $e } set ::blt::tv::curCol [set col [$w column nearest $x]] if {$col == {}} return set cind [$w column index $col] set ind [$w index @$x,$y] if { ![$w column cget $col -edit] } { if {$cind == 0} { Toggle $w $ind } return } elseif {$cind == 0} { set object {} $w nearest $x $y object if {$object != "label"} { Toggle $w $ind return } } EditCell $w $ind $col $x $y } proc blt::tv::EditColumn { w x y } { # Old edit function. $w see current if { [winfo exists $w.edit] } { destroy $w.edit } set col [$w column current] if {$col == {}} return set ::blt::tv::curCol $col if { ![$w edit -root -test $x $y] } { return } set ind [$w index @$x,$y] if {$ind == {}} return set data [$w entry set $ind $col] $w edit -root $x $y update focus $w.edit $w.edit selection range 0 end event generate $w <<TreeViewEditStart>> -x $x -y $y grab set $w.edit tkwait window $w.edit grab release $w.edit if {[winfo exists $w]} { event generate $w <<TreeViewEditEnd>> -x $x -y $y } } proc ::blt::tv::SortTree {t column {ind {}} {uselabel 1} {see 1}} { # Sort the children of tree. set istree [$t column istree $column] if {$ind == {}} { set ind [lindex [$t curselection] 0] if {$ind == {}} { if {$istree} { set ind 0 } else { set ind focus } } } set ind [$t index $ind] set clst [$t entry children $ind] if {$clst == {}} return set slst {} foreach i $clst { if {$istree} { set txt [expr {$uselabel?[$t entry cget $i -label]:[$t get $i]}] } else { set txt [$t entry set $i $column] } lappend slst [list $txt $i] } if {[set decreasing [$t sort cget -decreasing]]} { set dec -decreasing } else { set dec -increasing } #set decreasing [expr {!$decreasing}] #$t sort conf -decreasing $decreasing set mode [$t column cget $column -sortmode] if {$mode == "none"} { set mode [$t sort cget -mode] } if {$mode == "none"} return if {$mode == "command"} { set slst [lsort $dec -command [$t column cget $column -sortcommand] $slst] } else { set slst [lsort $dec -$mode $slst] } foreach i $slst { set oi [lindex $i 1] $t move $oi into $ind } if {$see} { set sel [$t curselection] if {$sel != {}} { after idle [list $t see [lindex $sel 0]] } } set cind [$t column index $column] event generate $t <<TreeViewSortTree>> -x $cind -y $ind } # # ButtonPress assignments # # B1-Enter start auto-scrolling # B1-Leave stop auto-scrolling # ButtonPress-2 start scan # B2-Motion adjust scan # ButtonRelease-2 stop scan # bind ${className} <ButtonPress-2> { focus %W } bind ${className} <ButtonPress-2> { set blt::tv::cursor [%W cget -cursor] %W configure -cursor hand1 %W scan mark %x %y } bind ${className} <B2-Motion> { catch { %W scan dragto %x %y } } bind ${className} <ButtonRelease-2> { catch { %W configure -cursor $blt::tv::cursor } } bind ${className} <B1-Leave> { if { $blt::tv::scroll } { blt::tv::AutoScroll %W } } bind ${className} <B1-Enter> { after cancel $blt::tv::afterId } # # KeyPress assignments # # Up # Down # Shift-Up # Shift-Down # Prior (PageUp) # Next (PageDn) # Left # Right # space Start selection toggle of entry currently with focus. # Return Start selection toggle of entry currently with focus. # Home # End # F1 # F2 # ASCII char Go to next open entry starting with character. # # KeyRelease # # space Stop selection toggle of entry currently with focus. # Return Stop selection toggle of entry currently with focus. bind ${className} <KeyPress-Up> { blt::tv::MoveFocus %W up if { $blt::tv::space } { %W selection toggle focus } } bind ${className} <KeyPress-Down> { blt::tv::MoveFocus %W down if { $blt::tv::space } { %W selection toggle focus } } bind ${className} <Control-KeyPress-n> [bind ${className} <KeyPress-Down>] bind ${className} <Control-KeyPress-p> [bind ${className} <KeyPress-Up>] bind ${className} <Shift-KeyPress-Up> { blt::tv::MoveFocus %W up 1 } bind ${className} <Shift-KeyPress-Down> { blt::tv::MoveFocus %W down 1 } bind ${className} <KeyPress-Prior> { blt::tv::MovePage %W top } bind ${className} <KeyPress-Next> { blt::tv::MovePage %W bottom } bind ${className} <Control-KeyPress-d> [bind ${className} <KeyPress-Next>] bind ${className} <Control-KeyPress-u> [bind ${className} <KeyPress-Prior>] #bind ${className} <KeyPress-Left> { # %W close focus #} #bind ${className} <KeyPress-Right> { # %W open focus # %W see focus -anchor w #} proc blt::tv::MoveKey {w cnt} { set mode [$w cget -selectmode] set iscell [expr {$mode == "cell" || $mode == "multicell"}] if {!$iscell} { return [$w xview scroll $cnt unit] } set cells [$w selection cells] if {$cells != {}} { set vcols [$w col names -visible] foreach {ind col} $cells break set cind [lsearch $vcols $col] if {$cind >= 0} { set cind [expr {$cind+$cnt}] if {$cind>=[llength $vcols]} { set cind [expr {[llength $vcols]-1}] } elseif {$cind < 0} { set cind 0 } set ncol [lindex $vcols $cind] $w selection clearall $w selection set $ind $ind $ncol $w column see $ncol } } } proc blt::tv::MarkPos {w} { if { [$w cget -selectmode] == "single" } { if { [$w selection includes focus] } { $w selection clearall } else { $w selection clearall $w selection set focus } } elseif { [$w cget -selectmode] != "none" } { $w selection toggle focus } set blt::tv::space on } bind ${className} <KeyPress-Left> { blt::tv::MoveKey %W -1} bind ${className} <KeyPress-Right> { blt::tv::MoveKey %W 1} #bind ${className} <KeyPress-Left> { %W xview scroll -1 unit} #bind ${className} <KeyPress-Right> { %W xview scroll 1 unit} bind ${className} <Control-KeyPress-Left> { %W xview scroll -1 page} bind ${className} <Control-KeyPress-Right> { %W xview scroll 1 page} bind ${className} <KeyPress-space> { catch {blt::tv::MarkPos %W } } bind ${className} <KeyRelease-space> { set blt::tv::space off } #bind ${className} <KeyPress-Return> { # blt::tv::MoveFocus %W focus # set blt::tv::space on #} #bind ${className} <KeyRelease-Return> { # set blt::tv::space off #} bind ${className} <KeyPress-Return> { #set blt::tv::space on blt::tv::Toggle %W focus #set blt::tv::space off } bind ${className} <KeyRelease-Return> { #set blt::tv::space off } bind ${className} <KeyPress> { blt::tv::NextMatch %W %A %s } bind ${className} <KeyPress-Home> { blt::tv::MoveFocus %W top } bind ${className} <KeyPress-End> { blt::tv::MoveFocus %W bottom } bind ${className} <Control-F1> { %W open -trees root } bind ${className} <Control-F2> { eval %W close -trees root } bind ${className} <Control-F3> { %W conf -flat [expr {![%W cget -flat]}] } bind ${className} <Control-F4> { eval %W col conf [%W col names] -width 0 } bind ${className} <MouseWheel> { if {%D >= 0} { %W yview scroll [expr {-%D/30}] units } else { %W yview scroll [expr {(2-%D)/30}] units } } if {[tk windowingsystem] == "x11"} { bind ${className} <4> { %W yview scroll -3 unit } bind ${className} <5> { %W yview scroll 3 unit } } # # Differences between id "current" and operation nearest. # # set index [$w index current] # set index [$w nearest $x $y] # # o Nearest gives you the closest entry. # o current is "" if # 1) the pointer isn't over an entry. # 2) the pointer is over a open/close button. # 3) # # # Edit mode assignments # # ButtonPress-3 Enables/disables edit mode on entry. Sets focus to # entry. # # KeyPress # # Left Move insertion position to previous. # Right Move insertion position to next. # Up Move insertion position up one line. # Down Move insertion position down one line. # Return End edit mode. # Shift-Return Line feed. # Home Move to first position. # End Move to last position. # ASCII char Insert character left of insertion point. # Del Delete character right of insertion point. # Delete Delete character left of insertion point. # Ctrl-X Cut # Ctrl-V Copy # Ctrl-P Paste # # KeyRelease # # ButtonPress-1 Start selection if in entry, otherwise clear selection. # B1-Motion Extend/reduce selection. # ButtonRelease-1 End selection if in entry, otherwise use last # selection. # B1-Enter Disabled. # B1-Leave Disabled. # ButtonPress-2 Same as above. # B2-Motion Same as above. # ButtonRelease-2 Same as above. # # # Standard Motif bindings: bind ${className}Editor <ButtonPress-1> { %W icursor @%x,%y %W selection clear } bind ${className}Editor <Left> { %W icursor prev %W selection clear } bind ${className}Editor <Right> { %W icursor next %W selection clear } bind ${className}Editor <Shift-Left> { set new [expr {[%W index insert] - 1}] if {![%W selection present]} { %W selection from insert %W selection to $new } else { %W selection adjust $new } %W icursor $new } bind ${className}Editor <Shift-Right> { set new [expr {[%W index insert] + 1}] if {![%W selection present]} { %W selection from insert %W selection to $new } else { %W selection adjust $new } %W icursor $new } bind ${className}Editor <Home> { %W icursor 0 %W selection clear } bind ${className}Editor <Shift-Home> { set new 0 if {![%W selection present]} { %W selection from insert %W selection to $new } else { %W selection adjust $new } %W icursor $new } bind ${className}Editor <End> { %W icursor end %W selection clear } bind ${className}Editor <Shift-End> { set new end if {![%W selection present]} { %W selection from insert %W selection to $new } else { %W selection adjust $new } %W icursor $new } bind ${className}Editor <Delete> { if { [%W selection present]} { %W delete sel.first sel.last } else { %W delete insert } } bind ${className}Editor <BackSpace> { if { [%W selection present] } { %W delete sel.first sel.last } else { set index [expr [%W index insert] - 1] if { $index >= 0 } { %W delete $index $index } } } bind ${className}Editor <Control-space> { %W selection from insert } bind ${className}Editor <Select> { %W selection from insert } bind ${className}Editor <Control-Shift-space> { %W selection adjust insert } bind ${className}Editor <Shift-Select> { %W selection adjust insert } bind ${className}Editor <Control-slash> { %W selection range 0 end } bind ${className}Editor <Control-backslash> { %W selection clear } bind ${className}Editor <KeyPress> { blt::tv::InsertText %W %A } # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. # Otherwise, if a widget binding for one of these is defined, the # <KeyPress> class binding will also fire and insert the character, # which is wrong. Ditto for Escape, Return, and Tab. bind ${className}Editor <Alt-KeyPress> { # nothing } bind ${className}Editor <Meta-KeyPress> { # nothing } bind ${className}Editor <Control-KeyPress> { # nothing } bind ${className}Editor <KeyRelease-Escape> { %W cancel } bind ${className}Editor <Return> { %W apply } bind ${className}Editor <Shift-Return> { blt::tv::InsertText %W "\n" } bind ${className}Editor <KP_Enter> { # nothing } bind ${className}Editor <Tab> { # nothing } if {![string compare $tcl_platform(platform) "macintosh"]} { bind ${className}Editor <Command-KeyPress> { # nothing } } # On Windows, paste is done using Shift-Insert. Shift-Insert already # generates the <<Paste>> event, so we don't need to do anything here. if { [string compare $tcl_platform(platform) "windows"] != 0 } { bind ${className}Editor <Insert> { catch {blt::tv::InsertText %W [::tk::GetSelection %W CLIPBOARD]} #catch {blt::tv::InsertText %W [selection get -displayof %W]} } } bind ${className}Editor <<Paste>> { catch {blt::tv::InsertText %W [::tk::GetSelection %W CLIPBOARD]} } bind ${className}Editor <<Copy>> { ::blt::tv::TextCopy %W 1 } bind ${className} <<Copy>> { ::blt::tv::TextCopy %W } # Additional emacs-like bindings: bind ${className}Editor <Double-1> { set parent [winfo parent %W] %W cancel after idle { blt::tv::EditColumn $parent %X %Y } } bind ${className}Editor <ButtonPress-3> { set parent [winfo parent %W] %W cancel after idle { blt::tv::EditColumn $parent %X %Y } } bind ${className}Editor <Control-a> { %W icursor 0 %W selection clear } bind ${className}Editor <Control-b> { catch {%W icursor [expr {[%W index insert] - 1}]} %W selection clear } bind ${className}Editor <Control-d> { %W delete insert } bind ${className}Editor <Control-e> { %W icursor end %W selection clear } bind ${className}Editor <Control-f> { %W icursor [expr {[%W index insert] + 1}] %W selection clear } bind ${className}Editor <Control-h> { if {[%W selection present]} { %W delete sel.first sel.last } else { set index [expr [%W index insert] - 1] if { $index >= 0 } { %W delete $index $index } } } bind ${className}Editor <Control-k> { %W delete insert end } if 0 { bind ${className}Editor <Control-t> { blt::tv::Transpose %W } bind ${className}Editor <Meta-b> { %W icursor [blt::tv::PreviousWord %W insert] %W selection clear } bind ${className}Editor <Meta-d> { %W delete insert [blt::tv::NextWord %W insert] } bind ${className}Editor <Meta-f> { %W icursor [blt::tv::NextWord %W insert] %W selection clear } bind ${className}Editor <Meta-BackSpace> { %W delete [blt::tv::PreviousWord %W insert] insert } bind ${className}Editor <Meta-Delete> { %W delete [blt::tv::PreviousWord %W insert] insert } # tkEntryNextWord -- Returns the index of the next word position # after a given position in the entry. The next word is platform # dependent and may be either the next end-of-word position or the # next start-of-word position after the next end-of-word position. # # Arguments: # w - The entry window in which the cursor is to move. # start - Position at which to start search. if {![string compare $tcl_platform(platform) "windows"]} { proc ::blt::tv::NextWord {w start} { set pos [tcl_endOfWord [$w get] [$w index $start]] if {$pos >= 0} { set pos [tcl_startOfNextWord [$w get] $pos] } if {$pos < 0} { return end } return $pos } } else { proc ::blt::tv::NextWord {w start} { set pos [tcl_endOfWord [$w get] [$w index $start]] if {$pos < 0} { return end } return $pos } } # PreviousWord -- # # Returns the index of the previous word position before a given # position in the entry. # # Arguments: # w - The entry window in which the cursor is to move. # start - Position at which to start search. proc ::blt::tv::PreviousWord {w start} { set pos [tcl_startOfPreviousWord [$w get] [$w index $start]] if {$pos < 0} { return 0 } return $pos } } proc ::blt::tv::FmtStr {str {len 12}} { # Break a string into fixed size chunks. if {[string length $str]<=$len} { return $str } set lm [expr {$len-1}] set rc {} while {[string length $str]>0} { append rc [string range $str 0 $lm] set str [string range $str $len end] if {$str != {}} { append rc \n } } return $rc } proc ::blt::tv::FmtString {str {len 12} {class alnum}} { # Wrap long strings at word boundries. if {[string length $str]<=$len} { return $str } if {[string is $class $str]} { return [FmtStr $str $len] } set rc {} set crc {} set lw 1 foreach i [split $str {}] { set isw [string is $class $i] if {(($isw && $lw) || (!$isw && !$lw)) && [string length $crc]<$len} { append crc $i } else { lappend rc $crc set crc $i } set lw $isw } if {$crc != {}} { lappend rc $crc } set src {} set cln {} foreach i $rc { if {[string length $cln$i]<=$len} { append cln $i } else { if {$src != {}} { append src \n } append src $cln set cln $i } } append src \n $cln return $src } tabset.tcl 0000644 00000026023 15134702070 0006534 0 ustar 00 # # tabset.tcl # # ---------------------------------------------------------------------- # Bindings for the BLT tabset widget # ---------------------------------------------------------------------- # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@bell-labs.com # http://www.tcltk.com/blt # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ====================================================================== # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== # # Indicates whether to activate (highlight) tabs when the mouse passes # over them. This is turned off during scan operations. # namespace eval ::blt { variable bltTabset set bltTabset(activate) yes set bltTabset(insel) 0 } # ---------------------------------------------------------------------- # # ButtonPress assignments # # <ButtonPress-2> Starts scan mechanism (pushes the tabs) # <B2-Motion> Adjust scan # <ButtonRelease-2> Stops scan # # ---------------------------------------------------------------------- bind Tabset <B2-Motion> { %W scan dragto %x %y } bind Tabset <ButtonPress-2> { set ::blt::bltTabset(cursor) [%W cget -cursor] set ::blt::bltTabset(activate) no %W configure -cursor hand1 %W scan mark %x %y } bind Tabset <ButtonRelease-2> { %W configure -cursor $::blt::bltTabset(cursor) set ::blt::bltTabset(activate) yes catch { %W activate @%x,%y } } # ---------------------------------------------------------------------- # # KeyPress assignments # # <KeyPress-Up> Moves focus to the tab immediately above the # current. # <KeyPress-Down> Moves focus to the tab immediately below the # current. # <KeyPress-Left> Moves focus to the tab immediately left of the # currently focused tab. # <KeyPress-Right> Moves focus to the tab immediately right of the # currently focused tab. # <KeyPress-space> Invokes the commands associated with the current # tab. # <KeyPress-Return> Same as above. # <KeyPress> Go to next tab starting with the ASCII character. # # ---------------------------------------------------------------------- bind Tabset <KeyPress-Up> { blt::TabsetSelect %W "up" } bind Tabset <KeyPress-Down> { blt::TabsetSelect %W "down" } bind Tabset <KeyPress-Right> { blt::TabsetSelect %W "right" } bind Tabset <KeyPress-Left> { blt::TabsetSelect %W "left" } bind Tabset <KeyPress-Next> { blt::TabsetSelect %W "next" } bind Tabset <KeyPress-Prior> { blt::TabsetSelect %W "prev" } bind Tabset <KeyPress-Home> { blt::TabsetSelect %W "begin" } bind Tabset <KeyPress-End> { blt::TabsetSelect %W "end" } bind Tabset <KeyPress-space> { %W invoke focus } bind Tabset <KeyPress-Return> { blt::TabsetSelect %W focus } bind Tabset <KeyPress> { blt::TabsetAccel %W %A } # ---------------------------------------------------------------------- # # TabsetAccel -- # # Find the first tab (from the tab that currently has focus) # starting with the same first letter as the tab. It searches # in order of the tab positions and wraps around. If no tab # matches, it stops back at the current tab. # # Arguments: # widget Tabset widget. # key ASCII character of key pressed # # ---------------------------------------------------------------------- proc blt::TabsetAccel { widget key } { if {$key == "" || ![string is print $key]} return set key [string tolower $key] set itab [$widget index focus] set numTabs [$widget size] for { set i 0 } { $i < $numTabs } { incr i } { if { [incr itab] >= $numTabs } { set itab 0 } set ul [$widget tab cget $itab -underline] set name [$widget get $itab] set label [string tolower [$widget tab cget $name -text]] if { [string index $label $ul] == $key } { break } } TabsetSelect $widget $itab } proc blt::TabsetRaise { widget } { wm withdraw $widget wm deiconify $widget raise $widget } # ---------------------------------------------------------------------- # # TabsetSelect -- # # Invokes the command for the tab. If the widget associated tab # is currently torn off, the tearoff is raised. # # Arguments: # widget Tabset widget. # x y Unused. # # ---------------------------------------------------------------------- proc blt::TabsetSelect { widget tab } { variable bltTabset if {$bltTabset(insel)} return set rc [catch { set bltTabset(insel) 1 set index [$widget index -both $tab] if { $index != "" } { if {[$widget index select] == $index} { $widget see $index } else { focus $widget $widget activate $index $widget select $index $widget focus $index $widget see $index set torn [$widget tab cget $index -tornwindow] if {$torn != {}} { raise $torn } $widget invoke $index event generate $widget <<TabsetSelect>> } } set rv "" } rv] set bltTabset(insel) 0 return -code $rc $rv } proc blt::DestroyTearoff { widget tab window} { wm forget $window $widget tab conf $tab -tornwindow {} event generate $widget <<TabsetUntearoff>> -x [$widget tab number $tab] $widget tab conf $tab -window $window } proc blt::CreateTearoff { widget tab args } { # ------------------------------------------------------------------ # When reparenting the window contained in the tab, check if the # window or any window in its hierarchy currently has focus. # Since we're reparenting windows behind its back, Tk can # mistakenly activate the keyboard focus when the mouse enters the # old toplevel. The simplest way to deal with this problem is to # take the focus off the window and set it to the tabset widget # itself. # ------------------------------------------------------------------ set tab [$widget index $tab] set focus [focus] set name [$widget get $tab] set window [$widget tab cget $name -window] if { ($focus == $window) || ([string match $window.* $focus]) } { focus -force $widget } if {$window == {}} return wm manage $window wm title $window "[$widget tab cget $name -text]" if {[winfo width $widget]>10} { wm geometry $window [winfo width $widget]x[winfo height $widget] } $widget tab conf $tab -tornwindow $window # If the user tries to delete the toplevel, put the window back # into the tab folder. wm protocol $window WM_DELETE_WINDOW [list blt::DestroyTearoff $widget $tab $window] event generate $widget <<TabsetTearoff>> -x [$widget tab number $tab] } # ---------------------------------------------------------------------- # # Tearoff -- # # Toggles the tab tearoff. If the tab contains a embedded widget, # it is placed inside of a toplevel window. If the widget has # already been torn off, the widget is replaced back in the tab. # # Arguments: # widget tabset widget. # x y The coordinates of the mouse pointer. # # ---------------------------------------------------------------------- proc blt::Tearoff { widget x y index } { set tab [$widget index -index $index] if { $tab == "" } { return } $widget invoke $tab set torn [$widget tab tearoff $index] if { $torn == $widget } { blt::CreateTearoff $widget $tab $x $y } else { set window [$widget tab cget $tab -window] blt::DestroyTearoff $widget $tab $window } } proc blt::TabsetTearoff { widget {index focus} } { set tab [$widget index -both $index] if { $tab == "" } { return } $widget invoke $tab set window [$widget tab cget $tab -window] if { $window != {}} { blt::CreateTearoff $widget $tab } else { set window [$widget tab cget $tab -tornwindow] blt::DestroyTearoff $widget $tab $window } } # ---------------------------------------------------------------------- # # TabsetInit # # Invoked from C whenever a new tabset widget is created. # Sets up the default bindings for the all tab entries. # These bindings are local to the widget, so they can't be # set through the usual widget class bind tags mechanism. # # <Enter> Activates the tab. # <Leave> Deactivates all tabs. # <ButtonPress-1> Selects the tab and invokes its command. # <Control-ButtonPress-1> # Toggles the tab tearoff. If the tab contains # a embedded widget, it is placed inside of a # toplevel window. If the widget has already # been torn off, the widget is replaced back # in the tab. # # Arguments: # widget tabset widget # # ---------------------------------------------------------------------- proc blt::TabsetInit { widget } { $widget bind all <Enter> { if { $::blt::bltTabset(activate) } { %W activate current } } $widget bind all <Leave> { %W activate "" } $widget bind all <ButtonPress-1> { blt::TabsetSelect %W "current" } $widget bind all <Control-ButtonPress-1> { if { [%W cget -tearoff] } { blt::Tearoff %W %X %Y active } } $widget configure -perforationcommand { blt::Tearoff %W $::blt::bltTabset(x) $::blt::bltTabset(y) select } $widget bind Perforation <Enter> { %W perforation activate on } $widget bind Perforation <Leave> { %W perforation activate off } $widget bind Perforation <ButtonRelease-1> { set ::blt::bltTabset(x) %X set ::blt::bltTabset(y) %Y %W perforation invoke } } # Insert a table proc blt::InsertTable {widget list args} { array set p { -colprefix F -colnames {} -conf {} } array set p $args set w $widget foreach cn $p(-colnames) { $w column insert end $cn -justify left -bd 1 -relief raised } set clst [$w column names] eval $w conf $p(-conf) $w column conf 0 -hide 1 foreach i $list { while {[llength $clst] <= [llength $i]} { set cn $p(-colprefix)[llength $clst] $w column insert end $cn -justify left -bd 1 -relief raised set clst [$w column names] } set n 0 set d {} foreach j $i { incr n lappend d [lindex $clst $n] $j } $w insert end #auto -data $d } } tclIndex 0000644 00000001215 15134702070 0006237 0 ustar 00 # Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(Blt_ActiveLegend) [list source $dir/graph.tcl] set auto_index(Blt_Crosshairs) [list source $dir/graph.tcl] set auto_index(Blt_ZoomStack) [list source $dir/graph.tcl] set auto_index(Blt_PrintKey) [list source $dir/graph.tcl] set auto_index(Blt_ClosestPoint) [list source $dir/graph.tcl] treeview.xbm 0000644 00000000506 15134702070 0007106 0 ustar 00 #define test_width 16 #define test_height 16 #define test_x_hot 7 #define test_y_hot 7 static unsigned char test_bits[] = { 0x00, 0x00, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x64, 0x26, 0x66, 0x66, 0x7f, 0xfe, 0x66, 0x66, 0x64, 0x26, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x60, 0x06, 0x00, 0x00}; treeview_m.xbm 0000644 00000000513 15134702070 0007420 0 ustar 00 #define testm_width 16 #define testm_height 16 #define testm_x_hot 7 #define testm_y_hot 7 static unsigned char testm_bits[] = { 0xf0, 0x0f, 0xf0, 0x0f, 0xf0, 0x0f, 0xf0, 0x0f, 0xfc, 0x3f, 0xfe, 0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xfe, 0x7f, 0xfc, 0x3f, 0xf0, 0x0f, 0xf0, 0x0f, 0xf0, 0x0f, 0xf0, 0x0f, 0xf0, 0x0f}; hierbox.tcl 0000644 00000032440 15134702070 0006712 0 ustar 00 # # hierbox.tcl # ---------------------------------------------------------------------- # Bindings for the BLT hierbox widget # ---------------------------------------------------------------------- # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@lucent.com # http://www.tcltk.com/blt # # RCS: $Id: hierbox.tcl,v 1.1.1.1 2009/05/09 16:27:21 pcmacdon Exp $ # # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ====================================================================== # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== array set bltHierbox { afterId "" scroll 0 space off x 0 y 0 } catch { namespace eval blt::Hierbox {} } # # ButtonPress assignments # # B1-Enter start auto-scrolling # B1-Leave stop auto-scrolling # ButtonPress-2 start scan # B2-Motion adjust scan # ButtonRelease-2 stop scan # bind Hierbox <ButtonPress-2> { set bltHierbox(cursor) [%W cget -cursor] %W configure -cursor hand1 %W scan mark %x %y } bind Hierbox <B2-Motion> { %W scan dragto %x %y } bind Hierbox <ButtonRelease-2> { %W configure -cursor $bltHierbox(cursor) } bind Hierbox <B1-Leave> { if { $bltHierbox(scroll) } { blt::Hierbox::AutoScroll %W } } bind Hierbox <B1-Enter> { after cancel $bltHierbox(afterId) } # # KeyPress assignments # # Up # Down # Shift-Up # Shift-Down # Prior (PageUp) # Next (PageDn) # Left # Right # space Start selection toggle of entry currently with focus. # Return Start selection toggle of entry currently with focus. # Home # End # F1 # F2 # ASCII char Go to next open entry starting with character. # # KeyRelease # # space Stop selection toggle of entry currently with focus. # Return Stop selection toggle of entry currently with focus. bind Hierbox <KeyPress-Up> { blt::Hierbox::MoveFocus %W up if { $bltHierbox(space) } { %W selection toggle focus } } bind Hierbox <KeyPress-Down> { blt::Hierbox::MoveFocus %W down if { $bltHierbox(space) } { %W selection toggle focus } } bind Hierbox <Shift-KeyPress-Up> { blt::Hierbox::MoveFocus %W prevsibling } bind Hierbox <Shift-KeyPress-Down> { blt::Hierbox::MoveFocus %W nextsibling } bind Hierbox <KeyPress-Prior> { blt::Hierbox::MovePage %W top } bind Hierbox <KeyPress-Next> { blt::Hierbox::MovePage %W bottom } bind Hierbox <KeyPress-Left> { %W close focus } bind Hierbox <KeyPress-Right> { %W open focus %W see focus -anchor w } bind Hierbox <KeyPress-space> { blt::HierboxToggle %W focus set bltHierbox(space) on } bind Hierbox <KeyRelease-space> { set bltHierbox(space) off } bind Hierbox <KeyPress-Return> { blt::HierboxToggle %W focus set bltHierbox(space) on } bind Hierbox <KeyRelease-Return> { set bltHierbox(space) off } bind Hierbox <KeyPress> { blt::Hierbox::NextMatchingEntry %W %A } bind Hierbox <KeyPress-Home> { blt::Hierbox::MoveFocus %W root } bind Hierbox <KeyPress-End> { blt::Hierbox::MoveFocus %W end } bind Hierbox <KeyPress-F1> { %W open -r root } bind Hierbox <KeyPress-F2> { eval %W close -r [%W entry children root 0 end] } # ---------------------------------------------------------------------- # USAGE: blt::HierboxToggle <hierbox> <index> # Arguments: hierbox hierarchy widget # # Invoked when the user presses the space bar. Toggles the selection # for the entry at <index>. # ---------------------------------------------------------------------- proc blt::HierboxToggle { widget index } { switch -- [$widget cget -selectmode] { single { if { [$widget selection includes $index] } { $widget selection clearall } else { $widget selection set $index } } multiple { $widget selection toggle $index } } } # ---------------------------------------------------------------------- # USAGE: blt::Hierbox::MovePage <hierbox> <where> # Arguments: hierbox hierarchy widget # # Invoked by KeyPress bindings. Pages the current view up or down. # The <where> argument should be either "top" or "bottom". # ---------------------------------------------------------------------- proc blt::Hierbox::MovePage { widget where } { # If the focus is already at the top/bottom of the window, we want # to scroll a page. It's really one page minus an entry because we # want to see the last entry on the next/last page. if { [$widget index focus] == [$widget index view.$where] } { if {$where == "top"} { $widget yview scroll -1 pages $widget yview scroll 1 units } else { $widget yview scroll 1 pages $widget yview scroll -1 units } } update # Adjust the entry focus and the view. Also activate the entry. # just in case the mouse point is not in the widget. $widget entry highlight view.$where $widget focus view.$where $widget see view.$where if { [$widget cget -selectmode] == "single" } { $widget selection clearall $widget selection set focus } } # # Edit mode assignments # # ButtonPress-3 Enables/disables edit mode on entry. Sets focus to # entry. # # KeyPress # # Left Move insertion position to previous. # Right Move insertion position to next. # Up Move insertion position up one line. # Down Move insertion position down one line. # Return End edit mode. # Shift-Return Line feed. # Home Move to first position. # End Move to last position. # ASCII char Insert character left of insertion point. # Del Delete character right of insertion point. # Delete Delete character left of insertion point. # Ctrl-X Cut # Ctrl-V Copy # Ctrl-P Paste # # KeyRelease # # ButtonPress-1 Start selection if in entry, otherwise clear selection. # B1-Motion Extend/reduce selection. # ButtonRelease-1 End selection if in entry, otherwise use last selection. # B1-Enter Disabled. # B1-Leave Disabled. # ButtonPress-2 Same as above. # B2-Motion Same as above. # ButtonRelease-2 Same as above. # # All bindings in editting mode will "break" to override other bindings. # # bind Hierbox <ButtonPress-3> { set node [%W nearest %x %y] %W entry insert $node @%x,%y "" # %W entry insert $node 2 "" } proc blt::Hierbox::Init { widget } { # # Active entry bindings # $widget bind Entry <Enter> { %W entry highlight current } $widget bind Entry <Leave> { %W entry highlight "" } # # Button bindings # $widget button bind all <ButtonRelease-1> { %W see current %W toggle current } $widget button bind all <Enter> { %W button highlight current } $widget button bind all <Leave> { %W button highlight "" } # # ButtonPress-1 # # Performs the following operations: # # 1. Clears the previous selection. # 2. Selects the current entry. # 3. Sets the focus to this entry. # 4. Scrolls the entry into view. # 5. Sets the selection anchor to this entry, just in case # this is "multiple" mode. # $widget bind Entry <ButtonPress-1> { blt::Hierbox::SetSelectionAnchor %W current set bltHierbox(scroll) 1 } $widget bin Entry <Double-ButtonPress-1> { %W toggle current } # # B1-Motion # # For "multiple" mode only. Saves the current location of the # pointer for auto-scrolling. # $widget bind Entry <B1-Motion> { set bltHierbox(x) %x set bltHierbox(y) %y set index [%W nearest %x %y] if { [%W cget -selectmode] == "multiple" } { %W selection mark $index } else { blt::Hierbox::SetSelectionAnchor %W $index } } # # ButtonRelease-1 # # For "multiple" mode only. # $widget bind Entry <ButtonRelease-1> { if { [%W cget -selectmode] == "multiple" } { %W selection anchor current } after cancel $bltHierbox(afterId) set bltHierbox(scroll) 0 } # # Shift-ButtonPress-1 # # For "multiple" mode only. # $widget bind Entry <Shift-ButtonPress-1> { if { [%W cget -selectmode] == "multiple" && [%W selection present] } { if { [%W index anchor] == "" } { %W selection anchor current } set index [%W index anchor] %W selection clearall %W selection set $index current } else { blt::Hierbox::SetSelectionAnchor %W current } } $widget bind Entry <Shift-B1-Motion> { # do nothing } $widget bind Entry <Shift-ButtonRelease-1> { after cancel $bltHierbox(afterId) set bltHierbox(scroll) 0 } # # Control-ButtonPress-1 # # For "multiple" mode only. # $widget bind Entry <Control-ButtonPress-1> { if { [%W cget -selectmode] == "multiple" } { set index [%W index current] %W selection toggle $index %W selection anchor $index } else { blt::Hierbox::SetSelectionAnchor %W current } } $widget bind Entry <Control-B1-Motion> { # do nothing } $widget bind Entry <Control-ButtonRelease-1> { after cancel $bltHierbox(afterId) set bltHierbox(scroll) 0 } # # Control-Shift-ButtonPress-1 # # For "multiple" mode only. # $widget bind Entry <Control-Shift-ButtonPress-1> { if { [%W cget -selectmode] == "multiple" && [%W selection present] } { if { [%W index anchor] == "" } { %W selection anchor current } if { [%W selection includes anchor] } { %W selection set anchor current } else { %W selection clear anchor current %W selection set current } } else { blt::Hierbox::SetSelectionAnchor %W current } } $widget bind Entry <Control-Shift-B1-Motion> { # do nothing } } # ---------------------------------------------------------------------- # USAGE: blt::Hierbox::AutoScroll <hierbox> # # Invoked when the user is selecting elements in a hierbox widget # and drags the mouse pointer outside of the widget. Scrolls the # view in the direction of the pointer. # # Arguments: hierbox hierarchy widget # # ---------------------------------------------------------------------- proc blt::Hierbox::AutoScroll { widget } { global bltHierbox if { ![winfo exists $widget] } { return } set x $bltHierbox(x) set y $bltHierbox(y) set index [$widget nearest $x $y] if { $y >= [winfo height $widget] } { $widget yview scroll 1 units set neighbor down } elseif { $y < 0 } { $widget yview scroll -1 units set neighbor up } else { set neighbor $index } if { [$widget cget -selectmode] == "single" } { blt::Hierbox::SetSelectionAnchor $widget $neighbor } else { $widget selection mark $index } set bltHierbox(afterId) [after 10 blt::Hierbox::AutoScroll $widget] } proc blt::Hierbox::SetSelectionAnchor { widget index } { set index [$widget index $index] $widget selection clearall $widget see $index $widget focus $index $widget selection set $index $widget selection anchor $index } # ---------------------------------------------------------------------- # USAGE: blt::Hierbox::NextMatchingEntry <hierbox> <char> # Arguments: hierbox hierarchy widget # # Invoked by KeyPress bindings. Searches for an entry that starts # with the letter <char> and makes that entry active. # ---------------------------------------------------------------------- proc blt::Hierbox::NextMatchingEntry { widget key } { if {[string match {[ -~]} $key]} { set last [$widget index focus] set next [$widget index next] while { $next != $last } { set label [$widget entry cget $next -label] if { [string index $label 0] == $key } { break } set next [$widget index -at $next next] } $widget focus $next if {[$widget cget -selectmode] == "single"} { $widget selection clearall $widget selection set focus } $widget see focus } } # ---------------------------------------------------------------------- # USAGE: blt::Hierbox::MoveFocus <hierbox> <where> # # Invoked by KeyPress bindings. Moves the active selection to the # entry <where>, which is an index such as "up", "down", "prevsibling", # "nextsibling", etc. # ---------------------------------------------------------------------- proc blt::Hierbox::MoveFocus { widget where } { catch {$widget focus $where} if { [$widget cget -selectmode] == "single" } { $widget selection clearall $widget selection set focus } $widget see focus } dnd.tcl 0000644 00000006262 15134702070 0006022 0 ustar 00 # # dnd.tcl # # ---------------------------------------------------------------------- # Bindings for the BLT drag&drop command # ---------------------------------------------------------------------- # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@bell-labs.com # http://www.tcltk.com/blt # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ====================================================================== # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== if { $tcl_version >= 8.0 } { set cmd blt::dnd } else { set cmd dnd } for { set i 1 } { $i <= 5 } { incr i } { bind BltDndButton$i <ButtonPress-$i> [list $cmd select %W %X %Y %t] bind BltDndButton$i <B$i-Motion> [list $cmd drag %W %X %Y] bind BltDndButton$i <ButtonRelease-$i> [list $cmd drop %W %X %Y] } # ---------------------------------------------------------------------- # # DndInit -- # # Invoked from C whenever a new drag&drop source is created. # Sets up the default bindings for the drag&drop source. # # <ButtonPress-?> Starts the drag operation. # <B?-Motion> Updates the drag. # <ButtonRelease-?> Drop the data on the target. # # Arguments: # widget source widget # button Mouse button used to activate drag. # cmd "dragdrop" or "blt::dragdrop" # # ---------------------------------------------------------------------- proc blt::DndInit { widget button } { set tagList {} if { $button > 0 } { lappend tagList BltDndButton$button } foreach tag [bindtags $widget] { if { ![string match BltDndButton* $tag] } { lappend tagList $tag } } bindtags $widget $tagList } proc blt::DndStdDrop { widget args } { array set info $args set fmt [lindex $info(formats) 0] dnd pull $widget $fmt return 0 } proc blt::PrintInfo { array } { upvar $array state parray state if { $info(state) & 0x01 } { puts "Shift-Drop" } if { $info(state) & 0x02 } { puts "CapsLock-Drop" } if { $info(state) & 0x04 } { puts "Control-Drop" } if { $info(state) & 0x08 } { puts "Alt-Drop" } if { $info(state) & 0x10 } { puts "NumLock-Drop" } } init.tcl 0000644 00000000466 15134702070 0006220 0 ustar 00 namespace eval ::blt { proc initializeLibrary {} { foreach w {Button Checkbutton Radiobutton Menubutton Label Scrollbar} { foreach i [bind $w] { bind B$w $i [bind $w $i] } } } if {[info commands tk] == "tk"} { initializeLibrary } } bltGraph.pro 0000644 00000031523 15134702070 0007034 0 ustar 00 %%BeginProlog % % PostScript prolog file of the BLT graph widget. % % Copyright 1989-1992 Regents of the University of California. % Permission to use, copy, modify, and distribute this % software and its documentation for any purpose and without % fee is hereby granted, provided that the above copyright % notice appear in all copies. The University of California % makes no representations about the suitability of this % software for any purpose. It is provided "as is" without % express or implied warranty. % % Copyright 1991-1997 Bell Labs Innovations for Lucent Technologies. % % Permission to use, copy, modify, and distribute this software and its % documentation for any purpose and without fee is hereby granted, provided % that the above copyright notice appear in all copies and that both that the % copyright notice and warranty disclaimer appear in supporting documentation, % and that the names of Lucent Technologies any of their entities not be used % in advertising or publicity pertaining to distribution of the software % without specific, written prior permission. % % Lucent Technologies disclaims all warranties with regard to this software, % including all implied warranties of merchantability and fitness. In no event % shall Lucent Technologies be liable for any special, indirect or % consequential damages or any damages whatsoever resulting from loss of use, % data or profits, whether in an action of contract, negligence or other % tortuous action, arising out of or in connection with the use or performance % of this software. % 200 dict begin /BaseRatio 1.3467736870885982 def % Ratio triangle base / symbol size /BgColorProc 0 def % Background color routine (symbols) /DrawSymbolProc 0 def % Routine to draw symbol outline/fill /StippleProc 0 def % Stipple routine (bar segments) /DashesProc 0 def % Dashes routine (line segments) % Define the array ISOLatin1Encoding (which specifies how characters are % encoded for ISO-8859-1 fonts), if it isn't already present (Postscript % level 2 is supposed to define it, but level 1 doesn't). systemdict /ISOLatin1Encoding known not { /ISOLatin1Encoding [ /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /exclam /quotedbl /numbersign /dollar /percent /ampersand /quoteright /parenleft /parenright /asterisk /plus /comma /minus /period /slash /zero /one /two /three /four /five /six /seven /eight /nine /colon /semicolon /less /equal /greater /question /at /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P /Q /R /S /T /U /V /W /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore /quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p /q /r /s /t /u /v /w /x /y /z /braceleft /bar /braceright /asciitilde /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /space /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron /space /exclamdown /cent /sterling /currency /yen /brokenbar /section /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph /periodcentered /cedillar /onesuperior /ordmasculine /guillemotright /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn /ydieresis ] def } if % font ISOEncode font % This procedure changes the encoding of a font from the default % Postscript encoding to ISOLatin1. It is typically invoked just % before invoking "setfont". The body of this procedure comes from % Section 5.6.1 of the Postscript book. /ISOEncode { dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding ISOLatin1Encoding def currentdict end % I'm not sure why it's necessary to use "definefont" on this new % font, but it seems to be important; just use the name "Temporary" % for the font. /Temporary exch definefont } bind def /Stroke { gsave stroke grestore } def /Fill { gsave fill grestore } def /SetFont { % Stack: pointSize fontName findfont exch scalefont ISOEncode setfont } def /Box { % Stack: x y width height newpath exch 4 2 roll moveto dup 0 rlineto exch 0 exch rlineto neg 0 rlineto closepath } def /SetFgColor { % Stack: red green blue CL 0 eq { pop pop pop 0 0 0 } if setrgbcolor CL 1 eq { currentgray setgray } if } def /SetBgColor { % Stack: red green blue CL 0 eq { pop pop pop 1 1 1 } if setrgbcolor CL 1 eq { currentgray setgray } if } def % The next two definitions are taken from "$tk_library/prolog.ps" % desiredSize EvenPixels closestSize % % The procedure below is used for stippling. Given the optimal size % of a dot in a stipple pattern in the current user coordinate system, % compute the closest size that is an exact multiple of the device's % pixel size. This allows stipple patterns to be displayed without % aliasing effects. /EvenPixels { % Compute exact number of device pixels per stipple dot. dup 0 matrix currentmatrix dtransform dup mul exch dup mul add sqrt % Round to an integer, make sure the number is at least 1, and compute % user coord distance corresponding to this. dup round dup 1 lt {pop 1} if exch div mul } bind def % width height string filled StippleFill -- % % Given a path and other graphics information already set up, this % procedure will fill the current path in a stippled fashion. "String" % contains a proper image description of the stipple pattern and % "width" and "height" give its dimensions. If "filled" is true then % it means that the area to be stippled is gotten by filling the % current path (e.g. the interior of a polygon); if it's false, the % area is gotten by stroking the current path (e.g. a wide line). % Each stipple dot is assumed to be about one unit across in the % current user coordinate system. % width height string StippleFill -- % % Given a path already set up and a clipping region generated from % it, this procedure will fill the clipping region with a stipple % pattern. "String" contains a proper image description of the % stipple pattern and "width" and "height" give its dimensions. Each % stipple dot is assumed to be about one unit across in the current % user coordinate system. This procedure trashes the graphics state. /StippleFill { % The following code is needed to work around a NeWSprint bug. /tmpstip 1 index def % Change the scaling so that one user unit in user coordinates % corresponds to the size of one stipple dot. 1 EvenPixels dup scale % Compute the bounding box occupied by the path (which is now % the clipping region), and round the lower coordinates down % to the nearest starting point for the stipple pattern. Be % careful about negative numbers, since the rounding works % differently on them. pathbbox 4 2 roll 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll % Stack now: width height string y1 y2 x1 x2 % Below is a doubly-nested for loop to iterate across this area % in units of the stipple pattern size, going up columns then % across rows, blasting out a stipple-pattern-sized rectangle at % each position 6 index exch { 2 index 5 index 3 index { % Stack now: width height string y1 y2 x y gsave 1 index exch translate 5 index 5 index true matrix tmpstip imagemask grestore } for pop } for pop pop pop pop pop } bind def /LS { % Stack: x1 y1 x2 y2 newpath 4 2 roll moveto lineto stroke } def /EndText { %Stack : grestore } def /BeginText { %Stack : w h theta centerX centerY gsave % Translate the origin to the center of bounding box and rotate translate neg rotate % Translate back to the origin of the text region -0.5 mul exch -0.5 mul exch translate } def /DrawAdjText { %Stack : str strWidth x y moveto % Go to the text position exch dup dup 4 2 roll % Adjust character widths to get desired overall string width % adjust X = (desired width - real width)/#chars stringwidth pop sub exch length div 0 3 -1 roll % Flip back the scale so that the string is not drawn in reverse gsave 1 -1 scale ashow grestore } def /DrawBitmap { % Stack: ?bgColorProc? boolean centerX centerY width height theta imageStr gsave 6 -2 roll translate % Translate to center of bounding box 4 1 roll neg rotate % Rotate by theta % Find upperleft corner of bounding box 2 copy -.5 mul exch -.5 mul exch translate 2 copy scale % Make pixel unit scale newpath 0 0 moveto 0 1 lineto 1 1 lineto 1 0 lineto closepath % Fill rectangle with background color 4 -1 roll { gsave 4 -1 roll exec fill grestore } if % Paint the image string into the unit rectangle 2 copy true 3 -1 roll 0 0 5 -1 roll 0 0 6 array astore 5 -1 roll imagemask grestore } def % Symbols: % Skinny-cross /Sc { % Stack: x y symbolSize gsave 3 -2 roll translate 45 rotate 0 0 3 -1 roll Sp grestore } def % Skinny-plus /Sp { % Stack: x y symbolSize gsave 3 -2 roll translate 2 idiv dup 2 copy newpath neg 0 moveto 0 lineto DrawSymbolProc newpath neg 0 exch moveto 0 exch lineto DrawSymbolProc grestore } def % Cross /Cr { % Stack: x y symbolSize gsave 3 -2 roll translate 45 rotate 0 0 3 -1 roll Pl grestore } def % Plus /Pl { % Stack: x y symbolSize gsave 3 -2 roll translate dup 2 idiv exch 6 idiv % % 2 3 The plus/cross symbol is a % closed polygon of 12 points. % 0 1 4 5 The diagram to the left % x,y represents the positions of % 11 10 7 6 the points which are computed % below. % 9 8 % newpath 2 copy exch neg exch neg moveto dup neg dup lineto 2 copy neg exch neg lineto 2 copy exch neg lineto dup dup neg lineto 2 copy neg lineto 2 copy lineto dup dup lineto 2 copy exch lineto 2 copy neg exch lineto dup dup neg exch lineto exch neg exch lineto closepath DrawSymbolProc grestore } def % Circle /Ci { % Stack: x y symbolSize gsave 3 copy pop moveto newpath 2 div 0 360 arc closepath DrawSymbolProc grestore } def % Square /Sq { % Stack: x y symbolSize gsave dup dup 2 div dup 6 -1 roll exch sub exch 5 -1 roll exch sub 4 -2 roll Box DrawSymbolProc grestore } def % Line /Li { % Stack: x y symbolSize gsave 3 1 roll exch 3 -1 roll 2 div 3 copy newpath sub exch moveto add exch lineto stroke grestore } def % Diamond /Di { % Stack: x y symbolSize gsave 3 1 roll translate 45 rotate 0 0 3 -1 roll Sq grestore } def % Triangle /Tr { % Stack: x y symbolSize gsave 3 -2 roll translate BaseRatio mul 0.5 mul % Calculate 1/2 base dup 0 exch 30 cos mul % h1 = height above center point neg % b2 0 -h1 newpath moveto % point 1; b2 dup 30 sin 30 cos div mul % h2 = height below center point 2 copy lineto % point 2; b2 h2 exch neg exch lineto % closepath DrawSymbolProc grestore } def % Arrow /Ar { % Stack: x y symbolSize gsave 3 -2 roll translate BaseRatio mul 0.5 mul % Calculate 1/2 base dup 0 exch 30 cos mul % h1 = height above center point % b2 0 h1 newpath moveto % point 1; b2 dup 30 sin 30 cos div mul % h2 = height below center point neg % -h2 b2 2 copy lineto % point 2; b2 h2 exch neg exch lineto % closepath DrawSymbolProc grestore } def % Bitmap /Bm { % Stack: x y symbolSize gsave 3 1 roll translate pop DrawSymbolProc grestore } def %%EndProlog %%BeginSetup gsave % Save the graphics state % Default line/text style parameters 1 setlinewidth % width 1 setlinejoin % join 0 setlinecap % cap [] 0 setdash % dashes /CL 0 def % Set color level mode 0 0 0 setrgbcolor % color dragdrop.tcl 0000644 00000005346 15134702070 0007061 0 ustar 00 # # dragdrop.tcl # # ---------------------------------------------------------------------- # Bindings for the BLT drag&drop command # ---------------------------------------------------------------------- # AUTHOR: George Howlett # Bell Labs Innovations for Lucent Technologies # gah@bell-labs.com # http://www.tcltk.com/blt # ---------------------------------------------------------------------- # Copyright (c) 1998 Lucent Technologies, Inc. # ====================================================================== # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that the copyright notice and warranty disclaimer appear in # supporting documentation, and that the names of Lucent Technologies # any of their entities not be used in advertising or publicity # pertaining to distribution of the software without specific, written # prior permission. # # Lucent Technologies disclaims all warranties with regard to this # software, including all implied warranties of merchantability and # fitness. In no event shall Lucent be liable for any special, indirect # or consequential damages or any damages whatsoever resulting from loss # of use, data or profits, whether in an action of contract, negligence # or other tortuous action, arising out of or in connection with the use # or performance of this software. # # ====================================================================== if { $tcl_version >= 8.0 } { set cmd blt::drag&drop } else { set cmd drag&drop } for { set i 1 } { $i <= 5 } { incr i } { bind BltDrag&DropButton$i <ButtonPress-$i> [list $cmd drag %W %X %Y] bind BltDrag&DropButton$i <B$i-Motion> [list $cmd drag %W %X %Y] bind BltDrag&DropButton$i <ButtonRelease-$i> [list $cmd drop %W %X %Y] } # ---------------------------------------------------------------------- # # Drag&DropInit -- # # Invoked from C whenever a new drag&drop source is created. # Sets up the default bindings for the drag&drop source. # # <ButtonPress-?> Starts the drag operation. # <B?-Motion> Updates the drag. # <ButtonRelease-?> Drop the data on the target. # # Arguments: # widget source widget # button Mouse button used to activate drag. # cmd "dragdrop" or "blt::dragdrop" # # ---------------------------------------------------------------------- proc blt::Drag&DropInit { widget button } { set tagList {} if { $button > 0 } { lappend tagList BltDrag&DropButton$button } foreach tag [bindtags $widget] { if { ![string match BltDrag&DropButton* $tag] } { lappend tagList $tag } } bindtags $widget $tagList } tvutil.tcl 0000644 00000041132 15134702070 0006577 0 ustar 00 # BLT TreeView Utilities. # Load and dump treeview to XTL form. namespace eval ::blt::tv { variable pc set pc(colors) {LightBlue Aquamarine Khaki LightCyan Cornsilk LightYellow Lavender Azure} } proc ::blt::tv::_TreeLoad {w tl {id 0}} { upvar 1 p p foreach {i j} $tl { set tag [lindex $i 0] if {[llength $i]==1} { set lbl [expr {$j == {}?$i:$j}] if {$j == {}} { $w insert end $tag -at $id } else { $w insert end $tag -at $id -data [list $p(-datacol) $j] } } else { set tind [lindex $i 1] array unset data foreach {k l} [lrange $i 2 end] { if {$p(-trim) != {}} { set k [string trimleft $k $p(-trim)] } set data($k) $l } set cns [$w col names] foreach k [array names data] { if {[lsearch -exact $cns $k]<0} { $w col insert end $k foreach m {-relief -bd} { $w col conf $k $m [$w col cget 0 $m] } } } if {$tind != "+"} { set data($p(-datacol)) $j } set nid [$w insert end $tag -at $id -data [array get data]] switch -- $tind { + { if {$p(-defer)} { $w entry conf $nid -forcetree 1 -opencommand [concat [list ::blt::tv::TreeLoad $w $j] [array get p] -id $nid -nice 0] } else { _TreeLoad $w $j $nid } } - - {} {} default { tclLog "Tag '$tind' is not '+' or '-' in: $i $j" } } } } } proc ::blt::tv::TreeLoad {w tl args} { #TYPES: . Win . {opts -trim -nice -defer -id -datacol} # Load treeview from an XTL. array set p {-trim {} -nice 0 -defer 1 -id 0 -datacol Value} array set p $args if {$p(-id) && [$w entry children $p(-id)] != {}} return if {[lsearch -exact [$w col names] $p(-datacol)]<0} { $w col insert end $p(-datacol) } $w conf -allowduplicates 1 busy hold $w update set rc [catch {_TreeLoad $w $tl $p(-id)} rv] busy release $w update if {$p(-nice)} { $w style create textbox alt -bg LightBlue $w conf -underline 1 -altstyle alt -bg White -selectbackground SteelBlue -nofocusselectbackground SteelBlue eval $w col conf [$w col names] -bd 1 -relief raised } return -code $rc $rv } proc ::blt::tv::_TreeDump1 {w node} { upvar 1 p p rc rc set val {} set i $node if {$p(-label)} { set tag [$w entry cget $i -label] } else { set tag [$w get $i] } set avals {} if {$p(-aval) != {}} { catch { set avals [$w entry set $i $p(-aval)] } } else { set avals [$w entry cget $i -data] } foreach {j k} $avals { if {$j == "#0"} { set val $k } else { set j $p(-prefix)$j set data($j) $k } } if {$p(-vval) != {}} { catch { set val [$w entry set $i $p(-vval)] } } if {[$w entry isleaf $i]} { if {[array size data]} { set tattr [concat [list $tag -] [array get data]] } elseif {[string match #* $tag]} { set tattr $tag } else { set tattr [list $tag] } lappend rc $tattr $val } else { set tattr [concat [list $tag +] [array get data]] lappend rc $tattr [_TreeDump $w $i] } } proc ::blt::tv::_TreeDump {w node} { upvar 1 p p set rc {} foreach i [$w entry children $node] { _TreeDump1 $w $i } return $rc } proc ::blt::tv::FmtTree {lst {ind " "} {sp {}}} { set rc {} set n 0 foreach {atag val} $lst { incr n if {[string index $rc end] != "\n"} { append rc \n } if {[lindex $atag 1] == "+"} { set src [FmtTree $val $ind "$sp$ind"] append rc $sp [list $atag $src] \n } else { append rc $sp [list $atag $val] \n } } return $rc[string range $sp 0 end-[string length $ind]] } proc ::blt::tv::TreeDump {w args} { #TYPES: . Win {opts -prefix -fmt -label -aval -vval -start -notop} # Dump a treeview to XTL. array set p {-prefix {} -fmt 1 -label 1 -aval {} -vval {} -start 0 -notop 0} array set p $args if {!$p(-notop)} { set rc [_TreeDump1 $w $p(-start)] } else { set rc [_TreeDump $w $p(-start)] } if {$p(-fmt)} { set rc [FmtTree $rc] } return $rc } proc ::blt::tv::WNew {cmd args} { # Use style commands if possible. if {[info exists ::Tk::Wins]} { return [eval $cmd new $args] } return [eval $cmd $args] } proc ::blt::tv::XTLLoad {args} { #TYPES: win {opts -altcolor -colopts -conf -data -eval -refresh -titles -win} # Load a flat table. array set p { -altcolor * -colopts {} -conf {} -data {} -eval {} -refresh 0 -titles {} -win {} } variable pc array set p $args set data $p(-data) if {$p(-eval) != {}} { set data [eval $p(-eval)] } if {$data == {}} { error "Must provide -data" } set titles $p(-titles) if {$titles == {}} { set titles {Name Value} } set colors $pc(colors) set idx 1 if {[set t $p(-win)] != {}} { if {$p(-refresh) && ![winfo exists $p(-win)]} return $t delete all } else { while {[winfo exists [set w .__tvdatatable$idx]]} { incr idx } WNew Toplevel $w set f $w.f WNew Frame $f grid $f -row 10 -column 10 -sticky news grid columnconf $w 10 -weight 1 grid rowconf $w 10 -weight 1 set t $f.t WNew Scrollbar $f.sv -command "$t yview" WNew Scrollbar $f.sh -command "$t xview" -orient horizontal WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1 grid $t $f.sv grid $f.sh -sticky we grid conf $t -sticky news grid conf $f.sv -sticky ns grid columnconf $f 0 -weight 1 grid rowconf $f 0 -weight 1 } #$t conf -font {Verdana 14 bold}; $t conf -titlefont [$t cget -font] if {$p(-altcolor) != {}} { if {[set color $p(-altcolor)] == "*"} { set color [lindex $colors [expr {($idx-1)%[llength $colors]}]] } catch { $t style create textbox alt -bg $color $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue } } TreeLoad $t $data eval $t col conf [$t col names] -bd 1 -relief raised -autowidth 250 $t col conf 0 -title Tag $t col conf Value -justify left -titlejustify left if {$p(-colopts) != {}} { foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) } } if {$p(-conf) != {}} { eval $t conf $p(-conf) } if {$p(-refresh) > 0} { set p(-win) $t set p(-altcolor) {} set p(-conf) {} after $p(-refresh) [concat [namespace current]::TableLoad [array get p]] } return $t } proc ::blt::tv::TableLoad {args} { #TYPES: win {opts -altcolor -colopts -colprefix -conf -data -eval -refresh -subfield -split -titles -ititles -treefield -win} # Load a flat table. variable pc array set p { -altcolor * -colopts {} -colprefix F -conf {} -data {} -eval {} -refresh 0 -subfield {} -split False -titles {} -ititles False -treefield {} -win {} } array set p $args set data $p(-data) if {$p(-eval) != {}} { set data [eval $p(-eval)] } if {$p(-split)} { set data [split $data \n] } if {$data == {}} { error "Must provide -data" } set titles $p(-titles) if {$p(-ititles)} { set titles [lindex $data 0] set data [lrange $data 1 end] } set colors $pc(colors) set idx 1 if {[set t $p(-win)] != {}} { if {$p(-refresh) && ![winfo exists $p(-win)]} return $t delete all } else { while {[winfo exists [set w .__tvdatatable$idx]]} { incr idx } WNew Toplevel $w set f $w.f WNew Frame $f grid $f -row 10 -column 10 -sticky news grid columnconf $w 10 -weight 1 grid rowconf $w 10 -weight 1 set t $f.t WNew Scrollbar $f.sv -command "$t yview" WNew Scrollbar $f.sh -command "$t xview" -orient horizontal WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1 grid $t $f.sv grid $f.sh -sticky we grid conf $t -sticky news grid conf $f.sv -sticky ns grid columnconf $f 0 -weight 1 grid rowconf $f 0 -weight 1 } #$t conf -font {Verdana 14 bold}; $t conf -titlefont [$t cget -font] if {$p(-altcolor) != {}} { if {[set color $p(-altcolor)] == "*"} { set color [lindex $colors [expr {($idx-1)%[llength $colors]}]] } catch { $t style create textbox alt -bg $color $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue } } if {$p(-treefield) != {}} { $t column conf 0 -relief raised -bd 1 -title $p(-treefield) } else { $t column conf 0 -hide 1 } set data0 [$t column names] foreach i $data { while {[llength $data0] <= [llength $i]} { set cn [lindex $titles [expr {[llength $data0]-1}]] if {$cn == {}} { set cn $p(-colprefix)[llength $data0] } $t column insert end $cn -justify left -relief raised -bd 1 -pad 10 -editopts {-autonl 1} -command [list blt::tv::SortColumn %W %C] set data0 [$t column names] } set d {} set n 0 array unset q foreach j $i { set ii [lindex $data0 [incr n]] lappend d $ii $j set q($ii) $j } if {$p(-treefield) == {}} { set path #auto } else { set path $q($p(-treefield)) } $t insert end $path -data $d } if {$p(-subfield) != {}} { foreach i [$t find] { set id [$t entry set $i $p(-subfield)] if {$id == {}} continue set did [$t find -name $id] if {$did == {}} continue #puts "ID($i) id=$id, did=$did" if {[string equal $did $i]} continue $t move $i into $did } } $t open -trees root bind . <Control-Alt-Insert> "console show" if {$p(-colopts) != {}} { foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) } } if {$p(-conf) != {}} { eval $t conf $p(-conf) } if {$p(-refresh) > 0} { set p(-win) $t set p(-altcolor) {} set p(-conf) {} after $p(-refresh) [concat [namespace current]::TableLoad [array get p]] } return $t } proc ::blt::tv::EditValid {wconf t newdata ind} { # The following uses validate to prevent invalid edit from completing. set nam [$t entry set $ind Name] if {[catch {eval $wconf [list $nam $newdata]} rv]} { return -code 10 $rv } return $newdata } proc ::blt::tv::TableWid {wconf} { # Edit widget configure info in a table. set w [lindex $wconf 0] if {[llength $wconf] == 1} { lappend wconf configure } set data [lsort -dictionary [eval $wconf]] set t [blt::tv::TableLoad -data $data -titles {Name DBName DBClass Default Value Type}] wm title [winfo toplevel $t] "Widget Info: [winfo class $w] [winfo name $w] '[lrange $wconf 1 end]' in [winfo parent $w]" $t col move Value DBName $t col move Default DBName eval $t col conf [$t col names] -bg LightGray $t col conf Value -edit 1 -titleforeground LimeGreen -titlejustify left -bg White $t col conf Value -validatecmd [list [namespace current]::EditValid $wconf %W %V %#] return $t } proc ::blt::tv::TreeFill {w str args} { # Load treeview with data indented by 4 space multiples (converts tabs to 4). # If -flat, load as a table and ignore indents. set cols [$w column names] set tstr [string trim $str] set inttl 0 set istable [$w cget -flat] set sind [expr {$istable?0:1}] if {[llength $cols] == 1} { set inttl 1 set s0 [string first \n $tstr] if {$s0<0} { set str0 $str set str {} } else { set str0 [string range $tstr 0 [incr s0 -1]] set s0 [string first \n $tstr] set str [string range $tstr [incr s0] end] } set cols $str0 set titles [lrange $cols $sind end] foreach i $titles { $w column insert end $i } if {!$istable} { set col0 [lindex $cols 0] $w column conf 0 -title $col0 } } else { set titles [lrange $cols $sind end] if {[lindex $cols 0] != "#0"} { error "tree col must be first" } } if {$istable} { } else { set str [string map {\t { }} $str] } set lst [split $str \n] if {$istable} { foreach i $lst { set data {} foreach j $i k $titles { if {$k == {}} break if {$j != {}} { lappend data $k $j } } $w insert end #auto -data $data } } else { set msg {} while {[string trim [lindex $lst 0]] == {} && [llength $lst]>1} { set lst [lrange $lst 1 end] } set l0 [lindex $lst 0] set l0a [string trimleft $l0] set sp0 [expr {[string length $l0]-[string length $l0a]}] set at 0 set n 0 foreach i $lst { incr n set lbl [lindex $i 0] set ii [lrange $i 1 end] set la [string trimleft $i] if {$la == {}} continue set sp [expr {[string length $i]-[string length $la]}] set lev [expr {($sp-$sp0)/4}] set mod [expr {($sp-$sp0)%4}] if {$mod && $msg == {}} { set msg "treeview data indent ($mod) not divisible by 4 in: '$i'" } set data {} foreach j $ii k $titles { if {$k == {}} { set k [$w column insert end #auto] lappend titles $k } if {$j != {}} { lappend data $k $j } } if {$lev<=0 || $n==1} { set at 0 } else { set at [$w index tail] while {[$w entry depth $at]>$lev} { set at [$w entry parent $at] } } $w insert end [list $lbl] -at $at -data $data } if {$msg != {}} { tclLog $msg } } } if {$argv0 == [info script]} { if {[llength $argv]} { return [eval ::blt::tv::TableLoad $argv] } pack [treeview .tt ] -side left -fill both -expand y variable tree { A 1 A 2 {B - -X 1 -Y 2} 2 {C +} { a 1 b 2 {c - -X 3} 2 {d +} { x 1 } } } ::blt::tv::TreeLoad .tt $tree -trim - -nice 1 tclLog [::blt::tv::TreeDump .tt] pack [treeview .tf ] -side left -fill both -expand y ::blt::tv::TreeFill .tf { A 1 2 3 C 1 2 3 B 1 2 3 1 1 2 3 2 1 2 3 a 1 2 3 b 1 2 3 } .tf open [.tf find -istree] namespace eval ::blt::tv { TableLoad -titles {Name Alpha Bravo Charlie Detroit Foxtrot} -data { {Bob 9 21 9} {Derick 2 1 5} {Bill 3 2 5 2 1} } if {$::tcl_platform(platform) == "unix"} { TableLoad -eval {exec df} -ititles 1 -split 1 TableLoad -ititles 1 -treefield PID -subfield PPID -split 1 -eval {exec ps -eo comm,uid_hack,rss,sz,time,pid,ppid,tty} TableLoad -ititles 1 -data [split [exec ps -Alwj] \n] TableLoad -ititles 1 -data [array get ::env] -llength 2 proc LoadPs {} { set data [split [string trim [exec ps auxw]] \n] set ttl [lindex $data 0] set lst {} lappend lst $ttl set pos [string last [lindex $ttl end] $ttl] foreach i [lrange $data 1 end] { set nl [string range $i 0 [expr {$pos-1}]] lappend nl [string range $i $pos end] lappend lst $nl } return $lst } TableLoad -ititles 1 -eval {LoadPs} -refresh 3000 #eval TableLoad [lrange $argv $n end] } } } graph.tcl 0000644 00000033626 15134702070 0006362 0 ustar 00 proc Blt_ActiveLegend { graph } { $graph legend bind all <Enter> [list blt::ActivateLegend $graph ] $graph legend bind all <Leave> [list blt::DeactivateLegend $graph] $graph legend bind all <ButtonPress-1> [list blt::HighlightLegend $graph] } proc Blt_Crosshairs { graph } { blt::Crosshairs $graph } proc Blt_ResetCrosshairs { graph {state off}} { blt::Crosshairs $graph "Any-Motion" $state } proc Blt_ZoomStack { graph } { blt::ZoomStack $graph } proc Blt_PrintKey { graph } { blt::PrintKey $graph } proc Blt_ClosestPoint { graph } { blt::ClosestPoint $graph } # # The following procedures that reside in the "blt" namespace are # supposed to be private. # proc blt::ActivateLegend { graph } { set elem [$graph legend get current] $graph legend activate $elem } proc blt::DeactivateLegend { graph } { set elem [$graph legend get current] $graph legend deactivate $elem } proc blt::HighlightLegend { graph } { set elem [$graph legend get current] set relief [$graph element cget $elem -labelrelief] if { $relief == "flat" } { $graph element configure $elem -labelrelief raised $graph element activate $elem } else { $graph element configure $elem -labelrelief flat $graph element deactivate $elem } } proc blt::Crosshairs { graph {event "Any-Motion"} {state "on"}} { $graph crosshairs $state bind crosshairs-$graph <$event> { %W crosshairs configure -position @%x,%y } bind crosshairs-$graph <Leave> { %W crosshairs off } bind crosshairs-$graph <Enter> { %W crosshairs on } $graph crosshairs configure -color red if { $state == "on" } { blt::AddBindTag $graph crosshairs-$graph } elseif { $state == "off" } { blt::RemoveBindTag $graph crosshairs-$graph } } proc blt::InitStack { graph } { global zoomInfo set zoomInfo($graph,interval) 100 set zoomInfo($graph,afterId) 0 set zoomInfo($graph,A,x) {} set zoomInfo($graph,A,y) {} set zoomInfo($graph,B,x) {} set zoomInfo($graph,B,y) {} set zoomInfo($graph,stack) {} set zoomInfo($graph,corner) A } proc blt::ZoomStack { graph {start "ButtonPress-1"} {reset "ButtonPress-3"} } { global zoomInfo zoomMod blt::InitStack $graph if { [info exists zoomMod] } { set modifier $zoomMod } else { set modifier "" } bind zoom-$graph <${modifier}${start}> { blt::SetZoomPoint %W %x %y } bind zoom-$graph <${modifier}${reset}> { if { [%W inside %x %y] } { blt::ResetZoom %W } } blt::AddBindTag $graph zoom-$graph } proc blt::PrintKey { graph {event "Shift-ButtonRelease-3"} } { bind print-$graph <$event> { Blt_PostScriptDialog %W } blt::AddBindTag $graph print-$graph } proc blt::ClosestPoint { graph {event "Control-ButtonPress-2"} } { bind closest-point-$graph <$event> { blt::FindElement %W %x %y } blt::AddBindTag $graph closest-point-$graph } proc blt::AddBindTag { widget tag } { set oldTagList [bindtags $widget] if { [lsearch $oldTagList $tag] < 0 } { bindtags $widget [linsert $oldTagList 0 $tag] } } proc blt::RemoveBindTag { widget tag } { set oldTagList [bindtags $widget] set index [lsearch $oldTagList $tag] if { $index >= 0 } { bindtags $widget [lreplace $oldTagList $index $index] } } proc blt::FindElement { graph x y } { if ![$graph element closest $x $y info -interpolate yes] { beep return } # -------------------------------------------------------------- # find(name) - element Id # find(index) - index of closest point # find(x) find(y) - coordinates of closest point # or closest point on line segment. # find(dist) - distance from sample coordinate # -------------------------------------------------------------- set markerName "bltClosest_$info(name)" catch { $graph marker delete $markerName } $graph marker create text -coords { $info(x) $info(y) } \ -name $markerName \ -text "$info(name): $info(dist)\nindex $info(index)" \ -font *lucida*-r-*-10-* \ -anchor center -justify left \ -yoffset 0 -bg {} set coords [$graph invtransform $x $y] set nx [lindex $coords 0] set ny [lindex $coords 1] $graph marker create line -coords "$nx $ny $info(x) $info(y)" \ -name line.$markerName blt::FlashPoint $graph $info(name) $info(index) 10 blt::FlashPoint $graph $info(name) [expr $info(index) + 1] 10 } proc blt::FlashPoint { graph name index count } { if { $count & 1 } { $graph element deactivate $name } else { $graph element activate $name $index } incr count -1 if { $count > 0 } { after 200 blt::FlashPoint $graph $name $index $count update } else { eval $graph marker delete [$graph marker names "bltClosest_*"] } } proc blt::GetCoords { graph x y index } { global zoomInfo if { [$graph cget -invertxy] } { set zoomInfo($graph,$index,x) $y set zoomInfo($graph,$index,y) $x } else { set zoomInfo($graph,$index,x) $x set zoomInfo($graph,$index,y) $y } } proc blt::MarkPoint { graph index } { global zoomInfo set x [$graph xaxis invtransform $zoomInfo($graph,$index,x)] set y [$graph yaxis invtransform $zoomInfo($graph,$index,y)] set marker "zoomText_$index" set text [format "x=%.4g\ny=%.4g" $x $y] if [$graph marker exists $marker] { $graph marker configure $marker -coords { $x $y } -text $text } else { $graph marker create text -coords { $x $y } -name $marker \ -font *lucida*-r-*-10-* \ -text $text -anchor center -bg {} -justify left } } proc blt::DestroyZoomTitle { graph } { global zoomInfo if { $zoomInfo($graph,corner) == "A" } { catch { $graph marker delete "zoomTitle" } } } proc blt::PopZoom { graph } { global zoomInfo set zoomStack $zoomInfo($graph,stack) if { [llength $zoomStack] > 0 } { set cmd [lindex $zoomStack 0] set zoomInfo($graph,stack) [lrange $zoomStack 1 end] eval $cmd blt::ZoomTitleLast $graph busy hold $graph update busy release $graph after 2000 "blt::DestroyZoomTitle $graph" } else { catch { $graph marker delete "zoomTitle" } } } # Push the old axis limits on the stack and set the new ones proc blt::PushZoom { graph } { global zoomInfo eval $graph marker delete [$graph marker names "zoom*"] if { [info exists zoomInfo($graph,afterId)] } { after cancel $zoomInfo($graph,afterId) } set x1 $zoomInfo($graph,A,x) set y1 $zoomInfo($graph,A,y) set x2 $zoomInfo($graph,B,x) set y2 $zoomInfo($graph,B,y) if { ($x1 == $x2) || ($y1 == $y2) } { # No delta, revert to start return } set cmd {} foreach margin { xaxis yaxis x2axis y2axis } { foreach axis [$graph $margin use] { set min [$graph axis cget $axis -min] set max [$graph axis cget $axis -max] set c [list $graph axis configure $axis -min $min -max $max] append cmd "$c\n" } } set zoomInfo($graph,stack) [linsert $zoomInfo($graph,stack) 0 $cmd] foreach margin { xaxis x2axis } { foreach axis [$graph $margin use] { set min [$graph axis invtransform $axis $x1] set max [$graph axis invtransform $axis $x2] if { $min > $max } { $graph axis configure $axis -min $max -max $min } else { $graph axis configure $axis -min $min -max $max } } } foreach margin { yaxis y2axis } { foreach axis [$graph $margin use] { set min [$graph axis invtransform $axis $y1] set max [$graph axis invtransform $axis $y2] if { $min > $max } { $graph axis configure $axis -min $max -max $min } else { $graph axis configure $axis -min $min -max $max } } } busy hold $graph update; # This "update" redraws the graph busy release $graph } # # This routine terminates either an existing zoom, or pops back to # the previous zoom level (if no zoom is in progress). # proc blt::ResetZoom { graph } { global zoomInfo if { ![info exists zoomInfo($graph,corner)] } { blt::InitStack $graph } eval $graph marker delete [$graph marker names "zoom*"] if { $zoomInfo($graph,corner) == "A" } { # Reset the whole axis blt::PopZoom $graph } else { global zoomMod if { [info exists zoomMod] } { set modifier $zoomMod } else { set modifier "Any-" } set zoomInfo($graph,corner) A blt::RemoveBindTag $graph select-region-$graph } } option add *zoomTitle.font -*-helvetica-medium-R-*-*-18-*-*-*-*-*-*-* option add *zoomTitle.shadow yellow4 option add *zoomTitle.foreground yellow1 option add *zoomTitle.coords "-Inf Inf" proc blt::ZoomTitleNext { graph } { global zoomInfo set level [expr [llength $zoomInfo($graph,stack)] + 1] if { [$graph cget -invertxy] } { set coords "-Inf -Inf" } else { set coords "-Inf Inf" } $graph marker create text -name "zoomTitle" -text "Zoom #$level" \ -coords $coords -bindtags "" -anchor nw } proc blt::ZoomTitleLast { graph } { global zoomInfo set level [llength $zoomInfo($graph,stack)] if { $level > 0 } { $graph marker create text -name "zoomTitle" -anchor nw \ -text "Zoom #$level" } } proc blt::SetZoomPoint { graph x y } { global zoomInfo zoomMod if { ![info exists zoomInfo($graph,corner)] } { blt::InitStack $graph } blt::GetCoords $graph $x $y $zoomInfo($graph,corner) if { [info exists zoomMod] } { set modifier $zoomMod } else { set modifier "Any-" } bind select-region-$graph <${modifier}Motion> { blt::GetCoords %W %x %y B #blt::MarkPoint $graph B blt::Box %W } if { $zoomInfo($graph,corner) == "A" } { if { ![$graph inside $x $y] } { return } # First corner selected, start watching motion events #blt::MarkPoint $graph A blt::ZoomTitleNext $graph blt::AddBindTag $graph select-region-$graph set zoomInfo($graph,corner) B } else { # Delete the modal binding blt::RemoveBindTag $graph select-region-$graph blt::PushZoom $graph set zoomInfo($graph,corner) A } } option add *zoomOutline.dashes 4 option add *zoomTitle.anchor nw option add *zoomOutline.lineWidth 2 option add *zoomOutline.xor yes proc blt::MarchingAnts { graph offset } { global zoomInfo incr offset if { [$graph marker exists zoomOutline] } { $graph marker configure zoomOutline -dashoffset $offset set interval $zoomInfo($graph,interval) set id [after $interval [list blt::MarchingAnts $graph $offset]] set zoomInfo($graph,afterId) $id } } proc blt::Box { graph } { global zoomInfo if { $zoomInfo($graph,A,x) > $zoomInfo($graph,B,x) } { set x1 [$graph xaxis invtransform $zoomInfo($graph,B,x)] set y1 [$graph yaxis invtransform $zoomInfo($graph,B,y)] set x2 [$graph xaxis invtransform $zoomInfo($graph,A,x)] set y2 [$graph yaxis invtransform $zoomInfo($graph,A,y)] } else { set x1 [$graph xaxis invtransform $zoomInfo($graph,A,x)] set y1 [$graph yaxis invtransform $zoomInfo($graph,A,y)] set x2 [$graph xaxis invtransform $zoomInfo($graph,B,x)] set y2 [$graph yaxis invtransform $zoomInfo($graph,B,y)] } set coords { $x1 $y1 $x2 $y1 $x2 $y2 $x1 $y2 $x1 $y1 } if { [$graph marker exists "zoomOutline"] } { $graph marker configure "zoomOutline" -coords $coords } else { set X [lindex [$graph xaxis use] 0] set Y [lindex [$graph yaxis use] 0] $graph marker create line -coords $coords -name "zoomOutline" \ -mapx $X -mapy $Y set interval $zoomInfo($graph,interval) set id [after $interval [list blt::MarchingAnts $graph 0]] set zoomInfo($graph,afterId) $id } } proc Blt_PostScriptDialog { graph } { set top $graph.top toplevel $top foreach var { center landscape maxpect preview decorations padx pady paperwidth paperheight width height colormode } { global $graph.$var set $graph.$var [$graph postscript cget -$var] } set row 1 set col 0 label $top.title -text "PostScript Options" blt::table $top $top.title -cspan 7 foreach bool { center landscape maxpect preview decorations } { set w $top.$bool-label label $w -text "-$bool" -font *courier*-r-*12* blt::table $top $row,$col $w -anchor e -pady { 2 0 } -padx { 0 4 } set w $top.$bool-yes global $graph.$bool radiobutton $w -text "yes" -variable $graph.$bool -value 1 blt::table $top $row,$col+1 $w -anchor w set w $top.$bool-no radiobutton $w -text "no" -variable $graph.$bool -value 0 blt::table $top $row,$col+2 $w -anchor w incr row } label $top.modes -text "-colormode" -font *courier*-r-*12* blt::table $top $row,0 $top.modes -anchor e -pady { 2 0 } -padx { 0 4 } set col 1 foreach m { color greyscale } { set w $top.$m radiobutton $w -text $m -variable $graph.colormode -value $m blt::table $top $row,$col $w -anchor w incr col } set row 1 frame $top.sep -width 2 -bd 1 -relief sunken blt::table $top $row,3 $top.sep -fill y -rspan 6 set col 4 foreach value { padx pady paperwidth paperheight width height } { set w $top.$value-label label $w -text "-$value" -font *courier*-r-*12* blt::table $top $row,$col $w -anchor e -pady { 2 0 } -padx { 0 4 } set w $top.$value-entry global $graph.$value entry $w -textvariable $graph.$value -width 8 blt::table $top $row,$col+1 $w -cspan 2 -anchor w -padx 8 incr row } blt::table configure $top c3 -width .125i button $top.cancel -text "Cancel" -command "destroy $top" blt::table $top $row,0 $top.cancel -width 1i -pady 2 -cspan 3 button $top.reset -text "Reset" -command "destroy $top" #blt::table $top $row,1 $top.reset -width 1i button $top.print -text "Print" -command "blt::ResetPostScript $graph" blt::table $top $row,4 $top.print -width 1i -pady 2 -cspan 2 } proc blt::ResetPostScript { graph } { foreach var { center landscape maxpect preview decorations padx pady paperwidth paperheight width height colormode } { global $graph.$var set old [$graph postscript cget -$var] if { [catch {$graph postscript configure -$var [set $graph.$var]}] != 0 } { $graph postscript configure -$var $old set $graph.$var $old } } $graph postscript output "out.ps" puts stdout "wrote file \"out.ps\"." flush stdout }
| ver. 1.4 |
Github
|
.
| PHP 7.4.33 | Generation time: 0.27 |
proxy
|
phpinfo
|
Settings