1272 lines
38 KiB
Tcl
1272 lines
38 KiB
Tcl
##
|
|
## Layout routines taken from oooold code, author unkown.
|
|
## Copyright 1995-1998 Jeffrey Hobbs, jeff.hobbs@acm.org
|
|
##
|
|
## Last Update: 28 June 1997
|
|
##
|
|
package require Widget 2.0
|
|
package provide Hierarchy 2.0
|
|
|
|
##-----------------------------------------------------------------------
|
|
## PROCEDURE(S)
|
|
## hierarchy, hierarchy_dir, hierarchy_widget
|
|
##
|
|
## ARGUMENTS && DESCRIPTION
|
|
##
|
|
## hierarchy <window pathname> <options>
|
|
## Implements a hierarchical listbox
|
|
## hierarchy_dir <window pathname> <options>
|
|
## Implements a hierarchical listbox using a directory view structure
|
|
## for the default methods
|
|
## hierarchy_widget <window pathname> <options>
|
|
## Implements a hierarchical listbox using a widget view structure
|
|
## for the default methods
|
|
##
|
|
## OPTIONS
|
|
## (Any canvas option may be used with a hierarchy)
|
|
##
|
|
## -autoscrollbar TCL_BOOLEAN DEFAULT: 1
|
|
## Determines whether scrollbars automagically pop-up or
|
|
## are permanently there.
|
|
##
|
|
## -browsecmd procedure DEFAULT: noop
|
|
## A command which the widget will execute when the node is expanded
|
|
## to retrieve the children of a node. The widget and node path are
|
|
## appended to the command as a list of node names which
|
|
## form a path to the node from the root. Thus the first
|
|
## element of this list will always be the root node.
|
|
##
|
|
## -command procedure DEFAULT: noop
|
|
## A command which the widget will execute when the node is toggled.
|
|
## The name of the widget, the node path, and whether the children of
|
|
## the node are showing (0/1) is appended to the procedure args.
|
|
##
|
|
## -decoration TCL_BOOLEAN DEFAULT: 1
|
|
## If this is true, the "tree" lines are drawn.
|
|
##
|
|
## -expand # DEFAULT: 1
|
|
## an integer value for an initial depth to expand to.
|
|
##
|
|
## -font fontname DEFAULT: fixed
|
|
## The default font used for the text.
|
|
##
|
|
## -foreground color DEFAULT: black
|
|
## The default foreground color used for text of unselected nodes.
|
|
##
|
|
## -ipad # DEFAULT: 3
|
|
## The internal space added between the image and the text for a
|
|
## given node.
|
|
##
|
|
## -nodelook procedure DEFAULT: noop
|
|
## A command the widget will execute to get the look of a node.
|
|
## The node is appended to the command as a list of
|
|
## node-names which form a path to the node from the root.
|
|
## Thus the first element of this list will always be the
|
|
## root node. Also appended is a
|
|
## boolean value which indicates whether the node's children
|
|
## are currently displayed. This allows the node's
|
|
## look to change if it is "opened" or "closed".
|
|
##
|
|
## This command must return a 4-tuple list containing:
|
|
## 0. the text to display at the node
|
|
## 1. the font to use for the text
|
|
## 2. an image to display
|
|
## 3. the foreground color to use for the node
|
|
## If no font (ie. {}) is specified then
|
|
## the value from -font is used. If no image is specified
|
|
## then no image is displayed.
|
|
## The default is a command to which produces a nice look
|
|
## for a file manager.
|
|
##
|
|
## -paddepth # DEFAULT: 12
|
|
## The indent space added for child branches.
|
|
##
|
|
## -padstack # DEFAULT: 2
|
|
## The space added between two rows
|
|
##
|
|
## -root rootname DEFAULT: {}
|
|
## The name of the root node of the tree. Each node
|
|
## name must be unique amongst the children of each node.
|
|
##
|
|
## -selectbackground color DEFAULT: red
|
|
## The default background color used for the text of selected nodes.
|
|
##
|
|
## -selectmode (single|browse|multiple) DEFAULT: browse
|
|
## Like listbox modes, "multiple" is a mix of multiple && extended.
|
|
##
|
|
## -showall TCL_BOOLEAN DEFAULT: 0
|
|
## For directory nodelook, also show Unix '.' (hidden) files/dirs.
|
|
##
|
|
## -showfiles TCL_BOOLEAN DEFAULT: 0
|
|
## Show files as well as directories.
|
|
##
|
|
## -showparent string DEFAULT: {}
|
|
## For hierarchy_dir nodelook, if string != {}, then it will show that
|
|
## string which will reset the root node to its parent.
|
|
##
|
|
## METHODS
|
|
## These are the methods that the hierachical listbox object recognizes.
|
|
## (ie - hierachy .h ; .h <method> <args>)
|
|
## Any unique substring is acceptable
|
|
##
|
|
## configure ?option? ?value option value ...?
|
|
## cget option
|
|
## Standard tk widget routines.
|
|
##
|
|
## close index
|
|
## Closes the specified index (will trigger -command).
|
|
##
|
|
## curselection
|
|
## Returns the indices of the selected items. This differs from the
|
|
## listbox method because indices here have no implied order.
|
|
##
|
|
## get index ?index ...?
|
|
## Returns the node paths of the items referenced. Ranges are not
|
|
## allowed. Index specification is like that allowed by the index
|
|
## method.
|
|
##
|
|
## qget index ?index ...?
|
|
## As above, but the indices must be that of the item (as returned
|
|
## by the index or curselection method).
|
|
##
|
|
## index index
|
|
## Returns the hierarchy numerical index of the item (the numerical
|
|
## index has no implied order relative to the list items). index
|
|
## may be of the form:
|
|
##
|
|
## number - Specifies the element as a numerical index.
|
|
## root - specifies the root item.
|
|
## string - Specifis an item that has that text in it's node.
|
|
## @x,y - Indicates the element that covers the point in
|
|
## the listbox window specified by x and y (in pixel
|
|
## coordinates). If no element covers that point,
|
|
## then the closest element to that point is used.
|
|
##
|
|
## open index
|
|
## Opens the specified index (will trigger -command).
|
|
##
|
|
## see index
|
|
## Ensures that the item specified by the index is viewable.
|
|
##
|
|
## refresh
|
|
## Refreshes all open nodes
|
|
##
|
|
## selection option arg
|
|
## This works like the listbox selection method with the following
|
|
## exceptions:
|
|
##
|
|
## The selection clear option can take multiple indices, but not a range.
|
|
## No arguments to clear means clear all the selected elements.
|
|
##
|
|
## The selection set option can take multiple indices, but not a range.
|
|
## The key word 'all' sets the selection for all elements.
|
|
##
|
|
## size
|
|
## Returns the number of items in the hierarchical listbox.
|
|
##
|
|
## toggle index
|
|
## Toggles (open or closed) the item specified by index
|
|
## (triggers -command).
|
|
##
|
|
## BINDINGS
|
|
## Most Button-1 bindings on the hierarchy work in the same manner
|
|
## as those for the listbox widget, as defined by the selectmode.
|
|
## Those that vary are listed below:
|
|
##
|
|
## <Double-Button-1>
|
|
## Toggles a node in the hierarchy
|
|
##
|
|
## NAMESPACE & STATE
|
|
## The megawidget creates a global array with the classname, and a
|
|
## global array which is the name of each megawidget is created. The latter
|
|
## array is deleted when the megawidget is destroyed.
|
|
## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
|
|
## Other procs that begin with $CLASSNAME are private. For each widget,
|
|
## commands named .$widgetname and $CLASSNAME$widgetname are created.
|
|
##
|
|
##-----------------------------------------------------------------------
|
|
|
|
# Create this to make sure there are registered in auto_mkindex
|
|
# these must come before the [widget create ...]
|
|
proc Hierarchy args {}
|
|
proc hierarchy args {}
|
|
|
|
## In general, we cannot use $data(basecmd) in the construction, but the
|
|
## scrollbar commands won't be called until after it really exists as a
|
|
## proper command
|
|
widget create Hierarchy -type frame -base canvas -components {
|
|
{base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \
|
|
-yscrollcommand [list $data(yscrollbar) set] \
|
|
-xscrollcommand [list $data(xscrollbar) set]}}
|
|
{scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
|
|
-command [list $data(basecmd) xview]}}
|
|
{scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
|
|
-command [list $data(basecmd) yview]}}
|
|
} -options {
|
|
{-autoscrollbar autoScrollbar AutoScrollbar 1}
|
|
{-browsecmd browseCmd BrowseCmd {}}
|
|
{-command command Command {}}
|
|
{-decoration decoration Decoration 1}
|
|
{-expand expand Expand 1}
|
|
{-font font Font fixed}
|
|
{-foreground foreground Foreground black}
|
|
{-ipad ipad Ipad 3}
|
|
{-nodelook nodeLook NodeLook {}}
|
|
{-paddepth padDepth PadDepth 12}
|
|
{-padstack padStack PadStack 2}
|
|
{-root root Root {}}
|
|
{-selectmode selectMode SelectMode browse}
|
|
{-selectbackground selectBackground SelectBackground red}
|
|
{-state state State normal}
|
|
|
|
{-showall showAll ShowAll 0}
|
|
{-showparent showParent ShowParent {}}
|
|
{-showfiles showFiles ShowFiles 0}
|
|
}
|
|
|
|
proc hierarchy_dir {w args} {
|
|
uplevel [list hierarchy $w -root [pwd] \
|
|
-nodelook {namespace inscope ::Widget::Hierarchy FileLook} \
|
|
-command {namespace inscope ::Widget::Hierarchy FileActivate} \
|
|
-browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \
|
|
$args
|
|
}
|
|
|
|
proc hierarchy_widget {w args} {
|
|
uplevel [list hierarchy $w -root . \
|
|
-nodelook {namespace inscope ::Widget::Hierarchy WidgetLook} \
|
|
-command {namespace inscope ::Widget::Hierarchy WidgetActivate} \
|
|
-browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \
|
|
$args
|
|
}
|
|
|
|
namespace eval ::Widget::Hierarchy {;
|
|
|
|
;proc construct w {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
## Private variables
|
|
array set data [list \
|
|
hasnodelook 0 \
|
|
halfpstk [expr $data(-padstack)/2] \
|
|
width 400 \
|
|
]
|
|
|
|
grid $data(canvas) $data(yscrollbar) -sticky news
|
|
grid $data(xscrollbar) -sticky ew
|
|
grid columnconfig $w 0 -weight 1
|
|
grid rowconfig $w 0 -weight 1
|
|
bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]]
|
|
}
|
|
|
|
;proc init w {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set data(:$data(-root),showkids) 0
|
|
ExpandNodeN $w $data(-root) $data(-expand)
|
|
if {[catch {$w see $data(-root)}]} {
|
|
$data(basecmd) configure -scrollregion {0 0 1 1}
|
|
}
|
|
}
|
|
|
|
;proc configure {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set truth {^(1|yes|true|on)$}
|
|
array set config { resize 0 root 0 showall 0 }
|
|
foreach {key val} $args {
|
|
switch -- $key {
|
|
-autoscrollbar {
|
|
set val [regexp -nocase $truth $val]
|
|
if {$val} {
|
|
set config(resize) 1
|
|
} else {
|
|
grid $data(xscrollbar)
|
|
grid $data(yscrollbar)
|
|
}
|
|
}
|
|
-decoration { set val [regexp -nocase $truth $val] }
|
|
-padstack { set data(halfpstk) [expr {$val/2}] }
|
|
-nodelook {
|
|
## We set this special bool val because it saves some
|
|
## computation in ExpandNode, a deeply nested proc
|
|
set data(hasnodelook) [string compare $val {}]
|
|
}
|
|
-root {
|
|
if {[info exists data(:$data(-root),showkids)]} {
|
|
## All data about items and selection should be
|
|
## cleared and the items deleted
|
|
foreach name [concat [array names data :*] \
|
|
[array names data S,*]] {unset data($name)}
|
|
$data(basecmd) delete all
|
|
set data(-root) $val
|
|
set config(root) 1
|
|
## Avoid setting data($key) below
|
|
continue
|
|
}
|
|
}
|
|
-selectbackground {
|
|
foreach i [array names data S,*] {
|
|
$data(basecmd) itemconfigure [string range $i 2 end] \
|
|
-fill $val
|
|
}
|
|
}
|
|
-state {
|
|
if {![regexp {^(normal|disabled)$} $val junk val]} {
|
|
return -code error "bad state value \"$val\":\
|
|
must be normal or disabled"
|
|
}
|
|
}
|
|
-showall -
|
|
-showfiles {
|
|
set val [regexp -nocase $truth $val]
|
|
if {$val == $data($key)} continue
|
|
set config(showall) 1
|
|
}
|
|
}
|
|
set data($key) $val
|
|
}
|
|
if {$config(root)} {
|
|
set data(:$val,showkids) 0
|
|
ExpandNodeN $w $val $data(-expand)
|
|
} elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} {
|
|
_refresh $w
|
|
} elseif {$config(resize)} {
|
|
Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
|
|
}
|
|
}
|
|
|
|
## Cryptic source code arguments explained:
|
|
## (these, or a similar form, might appear as variables later)
|
|
## np == node path
|
|
## cnp == changed np
|
|
## knp == kids np
|
|
## xcnp == extra cnp
|
|
|
|
;proc _index { w idx } {
|
|
upvar \#0 [namespace current]::$w data
|
|
set c $data(basecmd)
|
|
if {[string match all $idx]} {
|
|
return [$c find withtag box]
|
|
} elseif {[regexp {^(root|anchor)$} $idx]} {
|
|
return [$c find withtag box:$data(-root)]
|
|
}
|
|
foreach i [$c find withtag $idx] {
|
|
if {[string match rec* [$c type $i]]} { return $i }
|
|
}
|
|
if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
|
|
return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
|
|
}
|
|
foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
|
|
return -code error "bad hierarchy index \"$idx\":\
|
|
must be current, @x,y, a number, or a node name"
|
|
}
|
|
|
|
;proc _selection { w args } {
|
|
if {[string match {} $args]} {
|
|
return -code error \
|
|
"wrong \# args: should be \"$w selection option args\""
|
|
}
|
|
upvar \#0 [namespace current]::$w data
|
|
set err [catch {_index $w [lindex $args 1]} idx]
|
|
switch -glob -- [lindex $args 0] {
|
|
an* {
|
|
## anchor
|
|
## stubbed out - too complicated to support
|
|
}
|
|
cl* {
|
|
## clear
|
|
set c $data(basecmd)
|
|
if {$err} {
|
|
foreach arg [array names data S,*] { unset data($arg) }
|
|
$c itemconfig box -fill {}
|
|
} else {
|
|
catch {unset data(S,$idx)}
|
|
$c itemconfig $idx -fill {}
|
|
foreach idx [lrange $args 2 end] {
|
|
if {[catch {_index $w $idx} idx]} {
|
|
catch {unset data(S,$idx)}
|
|
$c itemconfig $idx -fill {}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
in* {
|
|
## includes
|
|
if {$err} {
|
|
if {[llength $args]==2} {
|
|
return -code error $idx
|
|
} else {
|
|
return -code error "wrong \# args:\
|
|
should be \"$w selection includes index\""
|
|
}
|
|
}
|
|
return [info exists data(S,$idx)]
|
|
}
|
|
se* {
|
|
## set
|
|
if {$err} {
|
|
if {[string compare {} $args]} return
|
|
return -code error "wrong \# args:\
|
|
should be \"$w selection set index ?index ...?\""
|
|
} else {
|
|
set c $data(basecmd); set col $data(-selectbackground)
|
|
if {[string match all [lindex $args 1]]} {
|
|
foreach i $idx { set data(S,$i) 1 }
|
|
$c itemconfig box -fill $col
|
|
} else {
|
|
set data(S,$idx) 1
|
|
$c itemconfig $idx -fill $col
|
|
foreach idx [lrange $args 2 end] {
|
|
if {![catch {_index $w $idx} idx]} {
|
|
set data(S,$idx) 1
|
|
$c itemconfig $idx -fill $col
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
default {
|
|
return -code error "bad selection option \"[lindex $args 0]\":\
|
|
must be clear, includes, set"
|
|
}
|
|
}
|
|
}
|
|
|
|
;proc _curselection {w} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set res {}
|
|
foreach i [array names data S,*] { lappend res [string range $i 2 end] }
|
|
return $res
|
|
}
|
|
|
|
;proc _get {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set nps {}
|
|
foreach arg $args {
|
|
if {![catch {_index $w $arg} idx] && \
|
|
[string compare {} $idx]} {
|
|
set tags [$data(basecmd) gettags $idx]
|
|
if {[set i [lsearch -glob $tags box:*]]>-1} {
|
|
lappend nps [string range [lindex $tags $i] 4 end]
|
|
}
|
|
}
|
|
}
|
|
return $nps
|
|
}
|
|
|
|
;proc _qget {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
## Quick get. Avoids expensive _index call
|
|
set nps {}
|
|
foreach arg $args {
|
|
set tags [$data(basecmd) itemcget $arg -tags]
|
|
if {[set i [lsearch -glob $tags box:*]]>-1} {
|
|
lappend nps [string range [lindex $tags $i] 4 end]
|
|
}
|
|
}
|
|
return $nps
|
|
}
|
|
|
|
;proc _see {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
if {[catch {_index $w $args} idx]} {
|
|
return -code error $idx
|
|
} elseif {[string compare {} $idx]} {
|
|
set c $data(basecmd)
|
|
foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
|
|
set stk [lindex [$c cget -scrollregion] 3]
|
|
set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
|
|
}
|
|
$c yview moveto $pos
|
|
}
|
|
}
|
|
|
|
;proc _refresh {w} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
array set expanded [array get data ":*,showkids"]
|
|
foreach i [concat [array names data :*] \
|
|
[array names data S,*]] {unset data($i)}
|
|
$data(basecmd) delete all
|
|
## -dec makes it sort in root-first order
|
|
foreach i [lsort -ascii -decreasing [array names expanded]] {
|
|
if {$expanded($i)} {
|
|
regexp {^:(.*),showkids$} $i junk np
|
|
## Quick way to remove the last element of a list
|
|
set prnt [lreplace $np end end]
|
|
## checks to get rid of dead, previously opened nodes
|
|
if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \
|
|
&& [lsearch -exact $data(:$prnt,kids) \
|
|
[lindex $np end]] != -1)} {
|
|
set data($i) 0
|
|
ExpandNode $w $np
|
|
}
|
|
}
|
|
}
|
|
Redraw $w $data(-root)
|
|
Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
|
|
}
|
|
|
|
;proc _size {w} {
|
|
upvar \#0 [namespace current]::$w data
|
|
return [llength [$data(basecmd) find withtag box]]
|
|
}
|
|
|
|
## This will be the one called by <Double-Button-1> on the canvas,
|
|
## if -state is normal, so we have to make sure that $w is correct.
|
|
##
|
|
;proc _toggle { w index } {
|
|
toggle $w $index toggle
|
|
}
|
|
|
|
;proc _close { w index } {
|
|
toggle $w $index close
|
|
}
|
|
|
|
;proc _open { w index } {
|
|
toggle $w $index open
|
|
}
|
|
|
|
;proc toggle { w index which } {
|
|
if {[string compare Hierarchy [winfo class $w]]} {
|
|
set w [winfo parent $w]
|
|
}
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
if {[string match {} [set np [_get $w $index]]]} return
|
|
set np [lindex $np 0]
|
|
|
|
set old [$data(basecmd) cget -cursor]
|
|
$data(basecmd) config -cursor watch
|
|
update
|
|
switch $which {
|
|
close { CollapseNodeAll $w $np }
|
|
open { ExpandNodeN $w $np 1 }
|
|
toggle {
|
|
if {$data(:$np,showkids)} {
|
|
CollapseNodeAll $w $np
|
|
} else {
|
|
ExpandNodeN $w $np 1
|
|
}
|
|
}
|
|
}
|
|
if {[string compare {} $data(-command)]} {
|
|
uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
|
|
}
|
|
$data(basecmd) config -cursor $old
|
|
return
|
|
}
|
|
|
|
;proc Resize { w wid hgt } {
|
|
upvar \#0 [namespace current]::$w data
|
|
set c $data(basecmd)
|
|
if {[string compare {} [set box [$c bbox image text]]]} {
|
|
set X [lindex $box 2]
|
|
if {$data(-autoscrollbar)} {
|
|
set Y [lindex $box 3]
|
|
if {$wid>$X} {
|
|
set X $wid
|
|
grid remove $data(xscrollbar)
|
|
} else {
|
|
grid $data(xscrollbar)
|
|
}
|
|
if {$hgt>$Y} {
|
|
set Y $hgt
|
|
grid remove $data(yscrollbar)
|
|
} else {
|
|
grid $data(yscrollbar)
|
|
}
|
|
$c config -scrollregion "0 0 $X $Y"
|
|
}
|
|
## This makes full width highlight boxes
|
|
## data(width) is the default width of boxes
|
|
if {$X>$data(width)} {
|
|
set data(width) $X
|
|
foreach b [$c find withtag box] {
|
|
foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
|
|
}
|
|
}
|
|
} elseif {$data(-autoscrollbar)} {
|
|
grid remove $data(xscrollbar) $data(yscrollbar)
|
|
}
|
|
}
|
|
|
|
;proc CollapseNodeAll { w np } {
|
|
if {[CollapseNode $w $np]} {
|
|
upvar \#0 [namespace current]::$w data
|
|
Redraw $w $np
|
|
DiscardChildren $w $np
|
|
Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
|
|
}
|
|
}
|
|
|
|
;proc ExpandNodeN { w np n } {
|
|
upvar \#0 [namespace current]::$w data
|
|
if {[ExpandNodeN_aux $w $np $n] || \
|
|
([string compare $data(-root) {}] && \
|
|
![string compare $data(-root) $np])} {
|
|
Redraw $w $np
|
|
Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
|
|
}
|
|
}
|
|
|
|
;proc ExpandNodeN_aux { w np n } {
|
|
if {![ExpandNode $w $np]} { return 0 }
|
|
if {$n==1} { return 1 }
|
|
incr n -1
|
|
upvar \#0 [namespace current]::$w data
|
|
foreach k $data(:$np,kids) {
|
|
ExpandNodeN_aux $w "$np [list $k]" $n
|
|
}
|
|
return 1
|
|
}
|
|
|
|
########################################################################
|
|
##
|
|
## Private routines to collapse and expand a single node w/o redrawing
|
|
## Most routines return 0/1 to indicate if any change has occurred
|
|
##
|
|
########################################################################
|
|
|
|
;proc ExpandNode { w np } {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
if {$data(:$np,showkids)} { return 0 }
|
|
set data(:$np,showkids) 1
|
|
if {![info exists data(:$np,kids)]} {
|
|
if {[string compare $data(-browsecmd) {}]} {
|
|
set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
|
|
} else {
|
|
set data(:$np,kids) {}
|
|
}
|
|
}
|
|
if $data(hasnodelook) {
|
|
set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
|
|
} else {
|
|
set data(:$np,look) {}
|
|
}
|
|
if {[string match {} $data(:$np,kids)]} {
|
|
## This is needed when there are no kids to make sure the
|
|
## look of the node will be updated appropriately
|
|
foreach {txt font img fg} $data(:$np,look) {
|
|
lappend tags box:$np box $np
|
|
set c $data(basecmd)
|
|
if {[string compare $img {}]} {
|
|
## Catch just in case the image doesn't exist
|
|
catch {
|
|
$c itemconfigure img:$np -image $img
|
|
lappend tags $img
|
|
}
|
|
}
|
|
if {[string compare $txt {}]} {
|
|
if {[string match {} $font]} { set font $data(-font) }
|
|
if {[string match {} $fg]} { set fg $data(-foreground) }
|
|
$c itemconfigure txt:$np -fill $fg -text $txt -font $font
|
|
if {[string compare $np $txt]} { lappend tags $txt }
|
|
}
|
|
$c itemconfigure box:$np -tags $tags
|
|
## We only want to go through once
|
|
break
|
|
}
|
|
return 0
|
|
}
|
|
foreach k $data(:$np,kids) {
|
|
set knp "$np [list $k]"
|
|
## Check to make sure it doesn't already exist,
|
|
## in case we are refreshing the node or something
|
|
if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 }
|
|
if $data(hasnodelook) {
|
|
set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
|
|
} else {
|
|
set data(:$knp,look) {}
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
|
|
;proc CollapseNode { w np } {
|
|
upvar \#0 [namespace current]::$w data
|
|
if {!$data(:$np,showkids)} { return 0 }
|
|
set data(:$np,showkids) 0
|
|
if {[string match {} $data(:$np,kids)]} { return 0 }
|
|
if {[string compare $data(-nodelook) {}]} {
|
|
set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
|
|
} else {
|
|
set data(:$np,look) {}
|
|
}
|
|
foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" }
|
|
return 1
|
|
}
|
|
|
|
;proc DiscardChildren { w np } {
|
|
upvar \#0 [namespace current]::$w data
|
|
if {[info exists data(:$np,kids)]} {
|
|
foreach k $data(:$np,kids) {
|
|
set knp "$np [list $k]"
|
|
$data(basecmd) delete img:$knp txt:$knp box:$knp
|
|
foreach i {showkids look stkusg stack iwidth offset} {
|
|
catch {unset data(:$knp,$i)}
|
|
}
|
|
DiscardChildren $w $knp
|
|
}
|
|
unset data(:$np,kids)
|
|
}
|
|
}
|
|
|
|
## REDRAW mechanism
|
|
## 2 parts: recompute offsets of all children from changed node path
|
|
## then redraw children based on their offsets and look
|
|
##
|
|
;proc Redraw { w cnp } {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set c $data(basecmd)
|
|
# When a node changes, the positions of a whole lot of things
|
|
# change. The size of the scroll region also changes.
|
|
$c delete decor
|
|
|
|
# Calculate the new offset locations of everything
|
|
Recompute $w $data(-root) [lrange $cnp 1 end]
|
|
|
|
# Next recursively move all the bits around to their correct positions.
|
|
# We choose an initial point (4,4) to begin at.
|
|
Redraw_aux $w $data(-root) 4 4
|
|
|
|
# Necessary to make sure find closest gets the right item
|
|
# ordering: image > text > box
|
|
after idle "catch { [list $c] raise image text; [list $c] lower box text }"
|
|
}
|
|
|
|
## RECOMPUTE recurses through the tree working out the relative offsets
|
|
## of children from their parents in terms of stack values.
|
|
##
|
|
## "cnp" is either empty or a node name which indicates where the only
|
|
## changes have occured in the hierarchy since the last call to Recompute.
|
|
## This is used because when a node is toggled on/off deep in the
|
|
## hierarchy then not all the positions of items need to be recomputed.
|
|
## The only ones that do are everything below the changed node (of
|
|
## course), and also everything which might depend on the stack usage of
|
|
## that node (i.e. everything above it). Specifically the usages of the
|
|
## changed node's siblings do *not* need to be recomputed.
|
|
##
|
|
;proc Recompute { w np cnp } {
|
|
upvar \#0 [namespace current]::$w data
|
|
# If the cnp now has only one element then
|
|
# it must be one of the children of the current node.
|
|
# We do not need to Recompute the usages of its siblings if it is.
|
|
set cnode_is_child [expr {[llength $cnp]==1}]
|
|
if {$cnode_is_child} {
|
|
set cnode [lindex $cnp 0]
|
|
} else {
|
|
set xcnp [lrange $cnp 1 end]
|
|
}
|
|
|
|
# Run through the children, recursively calculating their usage of
|
|
# stack real-estate, and allocating an intial placement for each child
|
|
#
|
|
# Values do not need to be recomputed for siblings of the changed
|
|
# node and their descendants. For the cnode itself, in the
|
|
# recursive call we set the value of cnode to {} to prevent
|
|
# any further cnode checks.
|
|
|
|
set children_stack 0
|
|
if {$data(:$np,showkids)} {
|
|
foreach k $data(:$np,kids) {
|
|
set knp "$np [list $k]"
|
|
set data(:$knp,offset) $children_stack
|
|
if {$cnode_is_child && [string match $cnode $k]} {
|
|
set data(:$knp,stkusg) [Recompute $w $knp {}]
|
|
} elseif {!$cnode_is_child} {
|
|
set data(:$knp,stkusg) [Recompute $w $knp $xcnp]
|
|
}
|
|
incr children_stack $data(:$knp,stkusg)
|
|
incr children_stack $data(-padstack)
|
|
}
|
|
}
|
|
|
|
## Make the image/text if they don't exist.
|
|
## Positioning occurs in Redraw_aux.
|
|
## And calculate the stack usage of our little piece of the world.
|
|
set img_height 0; set img_width 0; set txt_width 0; set txt_height 0
|
|
|
|
foreach {txt font img fg} $data(:$np,look) {
|
|
lappend tags box:$np box $np
|
|
set c $data(basecmd)
|
|
if {[string compare $img {}]} {
|
|
if {[string match {} [$c find withtag img:$np]]} {
|
|
$c create image 0 0 -anchor nw -tags [list img:$np image]
|
|
}
|
|
## Catch just in case the image doesn't exist
|
|
catch {
|
|
$c itemconfigure img:$np -image $img
|
|
lappend tags $img
|
|
foreach {x y img_width img_height} [$c bbox img:$np] {
|
|
incr img_width -$x; incr img_height -$y
|
|
}
|
|
}
|
|
}
|
|
if {[string compare $txt {}]} {
|
|
if {[string match {} [$c find withtag txt:$np]]} {
|
|
$c create text 0 0 -anchor nw -tags [list txt:$np text]
|
|
}
|
|
if {[string match {} $font]} { set font $data(-font) }
|
|
if {[string match {} $fg]} { set fg $data(-foreground) }
|
|
$c itemconfigure txt:$np -fill $fg -text $txt -font $font
|
|
if {[string compare $np $txt]} { lappend tags $txt }
|
|
foreach {x y txt_width txt_height} [$c bbox txt:$np] {
|
|
incr txt_width -$x; incr txt_height -$y
|
|
}
|
|
}
|
|
if {[string match {} [$c find withtag box:$np]]} {
|
|
$c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
|
|
}
|
|
$c itemconfigure box:$np -tags $tags
|
|
## We only want to go through this once
|
|
break
|
|
}
|
|
|
|
set stack [expr {$txt_height>$img_height?$txt_height:$img_height}]
|
|
|
|
# Now reposition the children downward by "stack"
|
|
set overall_stack [expr {$children_stack+$stack}]
|
|
|
|
if {$data(:$np,showkids)} {
|
|
set off [expr {$stack+$data(-padstack)}]
|
|
foreach k $data(:$np,kids) {
|
|
set knp "$np [list $k]"
|
|
incr data(:$knp,offset) $off
|
|
}
|
|
}
|
|
# remember some facts for locating the image and drawing decor
|
|
array set data [list :$np,stack $stack :$np,iwidth $img_width]
|
|
|
|
return $overall_stack
|
|
}
|
|
|
|
;proc Redraw_aux {w np deppos stkpos} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
set c $data(basecmd)
|
|
$c coords img:$np $deppos $stkpos
|
|
$c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
|
|
$c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \
|
|
$data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}]
|
|
|
|
if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return
|
|
|
|
set minkid_stkpos 100000
|
|
set maxkid_stkpos 0
|
|
set bar_deppos [expr {$deppos+$data(-paddepth)/2}]
|
|
set kid_deppos [expr {$deppos+$data(-paddepth)}]
|
|
|
|
foreach k $data(:$np,kids) {
|
|
set knp "$np [list $k]"
|
|
set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}]
|
|
Redraw_aux $w $knp $kid_deppos $kid_stkpos
|
|
|
|
if {$data(-decoration)} {
|
|
if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
|
|
set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}]
|
|
if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
|
|
|
|
$c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
|
|
-width 1 -tags decor
|
|
}
|
|
}
|
|
if {$data(-decoration)} {
|
|
$c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
|
|
-width 1 -tags decor
|
|
}
|
|
}
|
|
|
|
|
|
##
|
|
## DEFAULT BINDINGS FOR HIERARCHY
|
|
##
|
|
## Since we give no border to the frame, all Hierarchy bindings
|
|
## will always register on the canvas widget
|
|
##
|
|
bind Hierarchy <Double-Button-1> {
|
|
set w [winfo parent %W]
|
|
if {[string match normal [$w cget -state]]} {
|
|
$w toggle @%x,%y
|
|
}
|
|
}
|
|
bind Hierarchy <ButtonPress-1> {
|
|
if {[winfo exists %W]} {
|
|
namespace eval ::Widget::Hierarchy \
|
|
[list BeginSelect [winfo parent %W] @%x,%y]
|
|
}
|
|
}
|
|
bind Hierarchy <B1-Motion> {
|
|
set tkPriv(x) %x
|
|
set tkPriv(y) %y
|
|
namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y]
|
|
}
|
|
bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
|
|
bind Hierarchy <Shift-1> [namespace code \
|
|
{ BeginExtend [winfo parent %W] @%x,%y }]
|
|
bind Hierarchy <Control-1> [namespace code \
|
|
{ BeginToggle [winfo parent %W] @%x,%y }]
|
|
bind Hierarchy <B1-Leave> {
|
|
set tkPriv(x) %x
|
|
set tkPriv(y) %y
|
|
namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]]
|
|
}
|
|
bind Hierarchy <B1-Enter> { tkCancelRepeat }
|
|
|
|
## Should reserve L/R U/D for traversing nodes
|
|
bind Hierarchy <Up> { %W yview scroll -1 units }
|
|
bind Hierarchy <Down> { %W yview scroll 1 units }
|
|
bind Hierarchy <Left> { %W xview scroll -1 units }
|
|
bind Hierarchy <Right> { %W xview scroll 1 units }
|
|
|
|
bind Hierarchy <Control-Up> { %W yview scroll -1 pages }
|
|
bind Hierarchy <Control-Down> { %W yview scroll 1 pages }
|
|
bind Hierarchy <Control-Left> { %W xview scroll -1 pages }
|
|
bind Hierarchy <Control-Right> { %W xview scroll 1 pages }
|
|
bind Hierarchy <Prior> { %W yview scroll -1 pages }
|
|
bind Hierarchy <Next> { %W yview scroll 1 pages }
|
|
bind Hierarchy <Control-Prior> { %W xview scroll -1 pages }
|
|
bind Hierarchy <Control-Next> { %W xview scroll 1 pages }
|
|
bind Hierarchy <Home> { %W xview moveto 0 }
|
|
bind Hierarchy <End> { %W xview moveto 1 }
|
|
bind Hierarchy <Control-slash> [namespace code \
|
|
{ SelectAll [winfo parent %W] }]
|
|
bind Hierarchy <Control-backslash> [namespace code \
|
|
{ [winfo parent %W] selection clear }]
|
|
|
|
bind Hierarchy <2> {
|
|
set tkPriv(x) %x
|
|
set tkPriv(y) %y
|
|
%W scan mark %x %y
|
|
}
|
|
bind Hierarchy <B2-Motion> {
|
|
%W scan dragto $tkPriv(x) %y
|
|
}
|
|
|
|
## BINDING HELPER PROCEDURES
|
|
##
|
|
## These are mostly mirrored from the Listbox class bindings.
|
|
##
|
|
## Some of these are hacked up to be more efficient by making calls
|
|
## that require forknowledge of the megawidget structure.
|
|
##
|
|
|
|
# BeginSelect --
|
|
#
|
|
# This procedure is typically invoked on button-1 presses. It begins
|
|
# the process of making a selection in the hierarchy. Its exact behavior
|
|
# depends on the selection mode currently in effect for the hierarchy;
|
|
# see the Motif documentation for details.
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
# el - The element for the selection operation (typically the
|
|
# one under the pointer). Must be in numerical form.
|
|
|
|
;proc BeginSelect {w el} {
|
|
global tkPriv
|
|
if {[catch {_index $w $el} el]} return
|
|
_selection $w clear
|
|
_selection $w set $el
|
|
set tkPriv(hierarchyPrev) $el
|
|
}
|
|
|
|
# Motion --
|
|
#
|
|
# This procedure is called to process mouse motion events while
|
|
# button 1 is down. It may move or extend the selection, depending
|
|
# on the hierarchy's selection mode.
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
# el - The element under the pointer (must be a number).
|
|
|
|
;proc Motion {w el} {
|
|
global tkPriv
|
|
if {[catch {_index $w $el} el] || \
|
|
[string match $el $tkPriv(hierarchyPrev)]} return
|
|
switch [_cget $w -selectmode] {
|
|
browse {
|
|
_selection $w clear 0 end
|
|
if {![catch {_selection $w set $el}]} {
|
|
set tkPriv(hierarchyPrev) $el
|
|
}
|
|
}
|
|
multiple {
|
|
## This happens when a double-1 occurs and all the index boxes
|
|
## have changed
|
|
if {[catch {_selection $w includes \
|
|
$tkPriv(hierarchyPrev)} inc]} {
|
|
set tkPriv(hierarchyPrev) [_index $w $el]
|
|
return
|
|
}
|
|
if {$inc} {
|
|
_selection $w set $el
|
|
} else {
|
|
_selection $w clear $el
|
|
}
|
|
set tkPriv(hierarchyPrev) $el
|
|
}
|
|
}
|
|
}
|
|
|
|
# BeginExtend --
|
|
#
|
|
# This procedure is typically invoked on shift-button-1 presses. It
|
|
# begins the process of extending a selection in the hierarchy. Its
|
|
# exact behavior depends on the selection mode currently in effect
|
|
# for the hierarchy;
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
# el - The element for the selection operation (typically the
|
|
# one under the pointer). Must be in numerical form.
|
|
|
|
;proc BeginExtend {w el} {
|
|
if {[catch {_index $w $el} el]} return
|
|
if {[string match multiple [_cget $w -selectmode]]} {
|
|
Motion $w $el
|
|
}
|
|
}
|
|
|
|
# BeginToggle --
|
|
#
|
|
# This procedure is typically invoked on control-button-1 presses. It
|
|
# begins the process of toggling a selection in the hierarchy. Its
|
|
# exact behavior depends on the selection mode currently in effect
|
|
# for the hierarchy; see the Motif documentation for details.
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
# el - The element for the selection operation (typically the
|
|
# one under the pointer). Must be in numerical form.
|
|
|
|
;proc BeginToggle {w el} {
|
|
global tkPriv
|
|
if {[catch {_index $w $el} el]} return
|
|
if {[string match multiple [_cget $w -selectmode]]} {
|
|
_selection $w anchor $el
|
|
if {[_selection $w includes $el]} {
|
|
_selection $w clear $el
|
|
} else {
|
|
_selection $w set $el
|
|
}
|
|
set tkPriv(hierarchyPrev) $el
|
|
}
|
|
}
|
|
|
|
# AutoScan --
|
|
# This procedure is invoked when the mouse leaves an entry window
|
|
# with button 1 down. It scrolls the window up, down, left, or
|
|
# right, depending on where the mouse left the window, and reschedules
|
|
# itself as an "after" command so that the window continues to scroll until
|
|
# the mouse moves back into the window or the mouse button is released.
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
|
|
;proc AutoScan {w} {
|
|
global tkPriv
|
|
if {![winfo exists $w]} return
|
|
set x $tkPriv(x)
|
|
set y $tkPriv(y)
|
|
if {$y>=[winfo height $w]} {
|
|
$w yview scroll 1 units
|
|
} elseif {$y<0} {
|
|
$w yview scroll -1 units
|
|
} elseif {$x>=[winfo width $w]} {
|
|
$w xview scroll 2 units
|
|
} elseif {$x<0} {
|
|
$w xview scroll -2 units
|
|
} else {
|
|
return
|
|
}
|
|
#Motion $w [$w index @$x,$y]
|
|
set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w]
|
|
}
|
|
|
|
# SelectAll
|
|
#
|
|
# This procedure is invoked to handle the "select all" operation.
|
|
# For single and browse mode, it just selects the root element.
|
|
# Otherwise it selects everything in the widget.
|
|
#
|
|
# Arguments:
|
|
# w - The hierarchy widget.
|
|
|
|
;proc SelectAll w {
|
|
if {[regexp (browse|single) [_cget $w -selectmode]]} {
|
|
_selection $w clear
|
|
_selection $w set root
|
|
} else {
|
|
_selection $w set all
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------
|
|
# Default nodelook methods
|
|
#------------------------------------------------------------
|
|
|
|
;proc FileLook { w np isopen } {
|
|
upvar \#0 [namespace current]::$w data
|
|
set path [eval file join $np]
|
|
set file [lindex $np end]
|
|
set bmp {}
|
|
if {[file readable $path]} {
|
|
if {[file isdirectory $path]} {
|
|
if {$isopen} {
|
|
## We know that kids will always be set by the time
|
|
## the isopen is set to 1
|
|
if {[string compare $data(:$np,kids) {}]} {
|
|
set bmp ::Widget::Hierarchy::bmp:dir_minus
|
|
} else {
|
|
set bmp ::Widget::Hierarchy::bmp:dir
|
|
}
|
|
} else {
|
|
set bmp ::Widget::Hierarchy::bmp:dir_plus
|
|
}
|
|
if 0 {
|
|
## NOTE: accurate, but very expensive
|
|
if {[string compare [FileList $w $np] {}]} {
|
|
set bmp [expr {$isopen ?\
|
|
{::Widget::Hierarchy::bmp:dir_minus} :\
|
|
{::Widget::Hierarchy::bmp:dir_plus}}]
|
|
} else {
|
|
set bmp ::Widget::Hierarchy::bmp:dir
|
|
}
|
|
}
|
|
}
|
|
set fg \#000000
|
|
} elseif {[string compare $data(-showparent) {}] && \
|
|
[string match $data(-showparent) $file]} {
|
|
set fg \#0000FF
|
|
set bmp ::Widget::Hierarchy::bmp:up
|
|
} else {
|
|
set fg \#a9a9a9
|
|
if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir}
|
|
}
|
|
return [list $file $data(-font) $bmp $fg]
|
|
}
|
|
|
|
## FileList
|
|
# ARGS: w hierarchy widget
|
|
# np node path
|
|
# Returns: directory listing
|
|
##
|
|
;proc FileList { w np } {
|
|
set pwd [pwd]
|
|
if {[catch "cd \[file join $np\]"]} {
|
|
set list {}
|
|
} else {
|
|
global tcl_platform
|
|
upvar \#0 [namespace current]::$w data
|
|
set str *
|
|
if {!$data(-showfiles)} { append str / }
|
|
if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
|
|
## NOTE: Use of non-core lremove
|
|
if {[catch {lsort [concat [glob -nocomplain $str] \
|
|
[lremove [glob -nocomplain .$str] {. ..}]]} list]} {
|
|
return {}
|
|
}
|
|
} else {
|
|
## The extra catch is necessary for unusual error conditions
|
|
if {[catch {lsort [glob -nocomplain $str]} list]} {
|
|
return {}
|
|
}
|
|
}
|
|
set root $data(-root)
|
|
if {[string compare {} $data(-showparent)] && \
|
|
[string match $root $np]} {
|
|
if {![regexp {^(.:)?/+$} $root] && \
|
|
[string compare [file dir $root] $root]} {
|
|
set list [linsert $list 0 $data(-showparent)]
|
|
}
|
|
}
|
|
}
|
|
cd $pwd
|
|
return $list
|
|
}
|
|
|
|
;proc FileActivate { w np isopen } {
|
|
upvar \#0 [namespace current]::$w data
|
|
set path [eval file join $np]
|
|
if {[file isdirectory $path]} return
|
|
if {[string compare $data(-showparent) {}] && \
|
|
[string match $data(-showparent) [lindex $np end]]} {
|
|
$w configure -root [file dir $data(-root)]
|
|
}
|
|
}
|
|
|
|
;proc WidgetLook { W np isopen } {
|
|
upvar \#0 [namespace current]::$W data
|
|
if {$data(-showall)} {
|
|
set w [lindex $np end]
|
|
} else {
|
|
set w [join $np {}]
|
|
regsub {\.\.} $w {.} w
|
|
}
|
|
if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
|
|
return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
|
|
}
|
|
|
|
;proc WidgetList { W np } {
|
|
upvar \#0 [namespace current]::$W data
|
|
if {$data(-showall)} {
|
|
set w [lindex $np end]
|
|
} else {
|
|
set w [join $np {}]
|
|
regsub {\.\.} $w {.} w
|
|
}
|
|
set kids {}
|
|
foreach i [lsort [winfo children $w]] {
|
|
if {$data(-showall)} {
|
|
lappend kids $i
|
|
} else {
|
|
lappend kids [file extension $i]
|
|
}
|
|
}
|
|
return $kids
|
|
}
|
|
|
|
;proc WidgetActivate { w np isopen } {}
|
|
|
|
|
|
## BITMAPS
|
|
##
|
|
image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16
|
|
#define folder_height 12
|
|
static char folder_bits[] = {
|
|
0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
|
|
0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
|
|
image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16
|
|
#define folder_plus_height 12
|
|
static char folder_plus_bits[] = {
|
|
0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
|
|
0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
|
|
image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16
|
|
#define folder_minus_height 12
|
|
static char folder_minus_bits[] = {
|
|
0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
|
|
0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
|
|
image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16
|
|
#define up.xbm_height 12
|
|
static unsigned char up.xbm_bits[] = {
|
|
0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
|
|
0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
|
|
image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15
|
|
#define text_height 14
|
|
static char text_bits[] = {
|
|
0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
|
|
0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}
|
|
|
|
}; # end namespace ::Widget::Hierarchy
|
|
|
|
return
|