546 lines
15 KiB
Tcl
Executable File
546 lines
15 KiB
Tcl
Executable File
# Hierarchical listbox pseudowidget
|
|
# data in $name-hldata
|
|
# each item gets a list:
|
|
# 0 -- "mode" (whatever)
|
|
# 1 -- text
|
|
# 2 -- list of options
|
|
# 3 -- list of child items
|
|
# 4 -- open/closed
|
|
# many features unimplemented
|
|
# see prefs-config.tcl for an example of use.
|
|
|
|
proc HList {name action args} {
|
|
switch $action {
|
|
create {
|
|
HListCreate $name $args
|
|
} insert {
|
|
eval [concat HListInsert $name $args]
|
|
} delete {
|
|
eval [concat HListDelete $name $args]
|
|
} select {
|
|
eval [concat HListSelect $name $args]
|
|
} default {
|
|
bgerror "bad action switch to HList"
|
|
}
|
|
}
|
|
}
|
|
|
|
##########
|
|
# Creation
|
|
|
|
set TKG(switches,HListCreate) {
|
|
pathname
|
|
{data ""}
|
|
menu3
|
|
emptycommand
|
|
{double1 break}
|
|
closedimagefile
|
|
openimagefile
|
|
iconcommand
|
|
{selectmode single}
|
|
selectcommand
|
|
deletecommand
|
|
{allowedchildren ""}
|
|
{font $TKG(textfont)}
|
|
{width 60}
|
|
{height 20}
|
|
{foreground $TKG(foreground)}
|
|
{background $TKG(textbackground)}
|
|
{selectforeground $TKG(foreground)}
|
|
{selectbackground white}
|
|
{activeforeground $TKG(activeforeground)}
|
|
{activebackground $TKG(activebackground)}
|
|
}
|
|
|
|
set TKG(switches,HListCreate,ms) {
|
|
closedimagefile openimagefile iconcommand selectcommand deletecommand
|
|
movecommand menu3
|
|
}
|
|
|
|
proc HListCreate {name args} {
|
|
upvar #0 $name-hlparams P
|
|
set P(modes) ""
|
|
set P(iconcounter) 0
|
|
set P(relation) before
|
|
set args [lindex $args 0]
|
|
# Parse switches
|
|
global TKG
|
|
set switches $TKG(switches,HListCreate)
|
|
set modeswitches $TKG(switches,HListCreate,ms)
|
|
TKGParseArgs $name-hlparams $args\
|
|
$switches $modeswitches "HListCreate"
|
|
TKGSetSwitchDefaults $name-hlparams $switches
|
|
TKGSetMSSwitchDefaults $name-hlparams $switches
|
|
foreach type {closed open} {
|
|
foreach mode $P(modes) {
|
|
if [info exists P(${type}imagefile,$mode)] {
|
|
set imagefile $P(${type}imagefile,$mode)
|
|
set P(${type}image,$mode) HL$imagefile
|
|
if {[lsearch [image names] HL$imagefile] == -1} {
|
|
SetImage HL$imagefile $imagefile
|
|
}
|
|
}
|
|
}
|
|
if [info exists P(${type}imagefile)] {
|
|
set imagefile $P(${type}imagefile)
|
|
set P(${type}image) HL$imagefile
|
|
if {[lsearch [image names] HL$imagefile] == -1} {
|
|
SetImage HL$imagefile $imagefile
|
|
}
|
|
}
|
|
}
|
|
text $P(pathname) -font $P(font) -height $P(height) -width $P(width)\
|
|
-foreground $P(foreground) -background $P(background)\
|
|
-tabs {0 26 46} -cursor top_left_arrow -state disabled
|
|
$P(pathname) tag configure withinItem -relief sunken -borderwidth 1
|
|
$P(pathname) tag configure underItem -underline 1
|
|
$P(pathname) tag configure selected -foreground $P(selectforeground) \
|
|
-background $P(selectbackground)
|
|
bind $P(pathname) <Motion> break
|
|
bind $P(pathname) <1> "HListCheckEmpty $name;break"
|
|
# bind $P(pathname) <Leave> "HListLeave $name"
|
|
if ![Empty [info procs HListInit-$name]] HListInit-$name
|
|
HListMenus $name
|
|
HListDraw $name
|
|
}
|
|
|
|
proc HListCheckEmpty {name} {
|
|
upvar \#0 $name-hlparams P
|
|
if ![llength $P(data)] {
|
|
$P(emptycommand)
|
|
}
|
|
}
|
|
|
|
#########################
|
|
# Draw the whole hlist
|
|
|
|
proc HListDraw {name} {
|
|
upvar \#0 $name-hlparams P
|
|
$P(pathname) configure -state normal
|
|
$P(pathname) delete 1.0 end
|
|
$P(pathname) insert 1.0 \
|
|
" \n" item
|
|
$P(pathname) configure -state disabled
|
|
set ped 0
|
|
set index 2
|
|
foreach item [set P(data)] {
|
|
HListWidgetInsertAtIndex $name $ped $item $index.0
|
|
set index [HListDrawKids $name $ped $item $index]
|
|
incr index
|
|
incr ped
|
|
}
|
|
HListTagPeds $name
|
|
}
|
|
|
|
proc HListDrawKids {name ped item index} {
|
|
set kidnum 0
|
|
foreach child [lindex $item 3] {
|
|
incr index
|
|
HListWidgetInsertAtIndex $name [concat $ped $kidnum] $child $index.0
|
|
set index [HListDrawKids $name [concat $ped $kidnum] $child $index]
|
|
incr kidnum
|
|
}
|
|
return $index
|
|
}
|
|
|
|
########################
|
|
# Insertion and deletion
|
|
|
|
proc HListInsert {name ped item} {
|
|
HListDataReplace $name $ped "" $item
|
|
HListDraw $name
|
|
HListSee $name $ped
|
|
HListItemSelect $name $ped
|
|
}
|
|
|
|
proc HListWidgetInsertAtIndex {name ped item index} {
|
|
upvar \#0 $name-hlparams P
|
|
set joinped [join $ped -]
|
|
set mode [lindex $item 0]
|
|
set label [lindex $item 1]
|
|
set options [lindex $item 2]
|
|
set open [expr ![string match [lindex item 4] closed]]
|
|
if $open {set oc open} {set oc closed}
|
|
# Determine tags
|
|
set tags [list item]
|
|
if {[set i [lsearch $options -T]] != -1} {
|
|
lappend tags [lindex $options [expr $i + 1]]
|
|
}
|
|
# Enable writing
|
|
$P(pathname) configure -state normal
|
|
# Indent
|
|
set tabs "\t"
|
|
for {set i 1} {$i < [llength $ped]} {incr i} {
|
|
append tabs "\t"
|
|
}
|
|
$P(pathname) insert $index "$tabs"
|
|
# Maybe insert an icon
|
|
if [info exists P(${oc}image,$mode)] {
|
|
set image [set P(${oc}image,$mode)]
|
|
} elseif [info exists P(${oc}image)] {
|
|
set image [set P(${oc}image)]
|
|
}
|
|
if [info exists image] {
|
|
set iconpath $P(pathname).i[incr P(iconcounter)]
|
|
label $iconpath -image $image -background $P(background)
|
|
set iconindex [$P(pathname) index "$index lineend"]
|
|
$P(pathname) window create $iconindex -window $iconpath
|
|
if [info exists P(iconcommand,[lindex $item 0])] {
|
|
bind $iconpath <1> \
|
|
"$P(iconcommand,[lindex $item 0]) $name $ped; break"
|
|
bind $iconpath <Double-1> break
|
|
}
|
|
}
|
|
# Always write the label
|
|
$P(pathname) insert "$index lineend" "\t${label}\n" $tags
|
|
# Disable writing
|
|
$P(pathname) configure -state disabled
|
|
}
|
|
|
|
proc HListSee {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
catch {$P(pathname) see Ped-[join $ped -].first}
|
|
}
|
|
|
|
proc HListDelete {name ped1 {ped2 {}}} {
|
|
if [Empty $ped2] {set ped2 $ped1}
|
|
upvar \#0 $name-hlparams P
|
|
HListDataReplace $name $ped1 $ped2
|
|
HListDraw $name
|
|
HListSee $name $ped1
|
|
}
|
|
|
|
proc HListDataReplace {name ped1 {ped2 {}} {insertitem {}}} {
|
|
if [Empty $ped2] {set ped2 $ped1}
|
|
upvar \#0 $name-hlparams P
|
|
if {[llength $ped1] == 1} {
|
|
if [Empty $insertitem] {
|
|
set P(data) [lreplace $P(data) $ped1 $ped2]
|
|
} else {
|
|
set P(data) [linsert $P(data) $ped1 $insertitem]
|
|
}
|
|
return
|
|
}
|
|
# ok, we have to dissect the tree...
|
|
set end [expr [llength $ped1] - 1]
|
|
set item(0) $P(data)
|
|
set i [lindex $ped1 0]
|
|
set item(1) [lindex $item(0) $i]
|
|
for {set level 2} {$level <= $end} {incr level} {
|
|
set i [lindex $ped1 [expr $level - 1]]
|
|
set item($level) [lindex [lindex $item([expr $level - 1]) 3] $i]
|
|
}
|
|
set i [lindex $ped1 end]
|
|
set j [lindex $ped2 end]
|
|
if [Empty $insertitem] {
|
|
set item($end) [lreplace $item($end) 3 3 \
|
|
[lreplace [lindex $item($end) 3] $i $j]]
|
|
} else {
|
|
set item($end) [lreplace $item($end) 3 3 \
|
|
[linsert [lindex $item($end) 3] $i $insertitem]]
|
|
}
|
|
for {set level [expr $end - 1]} {$level > 0} {incr level -1} {
|
|
set i [lindex $ped1 $level]
|
|
set newkids [lreplace [lindex $item($level) 3] $i $i $item([expr $level + 1])]
|
|
set item($level) [lreplace $item($level) 3 3 $newkids]
|
|
}
|
|
set i [lindex $ped1 0]
|
|
set P(data) [lreplace $item(0) $i $i $item(1)]
|
|
}
|
|
|
|
#################################
|
|
# Tags
|
|
|
|
proc HListTagPeds {name} {
|
|
upvar \#0 $name-hlparams P
|
|
set w $P(pathname)
|
|
foreach tag [$w tag names] {
|
|
if [string match Ped-* $tag] {
|
|
$w tag delete $tag
|
|
}
|
|
}
|
|
HListTagWithPed $name $P(pathname) 1 top top
|
|
set D $P(data)
|
|
set line 2
|
|
for {set i 0} {$i < [llength $D]} {incr i} {
|
|
set item [lindex $D $i]
|
|
HListTagWithPed $name $w $line $i [lindex $item 0]
|
|
set line [HListTagKids $name $item $w [expr $line + 1] $i]
|
|
}
|
|
}
|
|
|
|
proc HListTagKids {name item w line ped} {
|
|
set kids [lindex $item 3]
|
|
if [string match [lindex $item 4] closed] {return $line}
|
|
for {set i 0} {$i < [llength $kids]} {incr i} {
|
|
set kid [lindex $kids $i]
|
|
HListTagWithPed $name $w $line [concat $ped $i] [lindex $kid 0]
|
|
set line [HListTagKids $name $kid $w [expr $line + 1] [concat $ped $i]]
|
|
}
|
|
return $line
|
|
}
|
|
|
|
proc HListTagWithPed {name w line ped mode} {
|
|
upvar \#0 $name-hlparams P
|
|
set jp [join $ped -]
|
|
$w tag add Ped-$jp $line.0 [$w index "$line.0 lineend + 1 chars"]
|
|
$w tag bind Ped-$jp <Enter> [list HListItemMotion $name $ped %x %y]
|
|
$w tag bind Ped-$jp <Motion> [list HListItemMotion $name $ped %x %y]
|
|
$w tag bind Ped-$jp <1> [list HList1 $name $ped]
|
|
$w tag bind Ped-$jp <B1-Motion> [list HList1Motion $name $ped %x %y]
|
|
$w tag bind Ped-$jp <ButtonRelease-1> [list HList1Release $name $ped %x %y]
|
|
$w tag bind Ped-$jp <3> [list HList3 %X %Y $name $ped $mode]
|
|
$w tag bind Ped-$jp <Double-1> "
|
|
if {!\[string match top $jp\]} $P(double1)
|
|
"
|
|
}
|
|
|
|
##########################################
|
|
# Getting items and indices
|
|
|
|
proc HListGetItem {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
set data [lindex $P(data) [lindex $ped 0]]
|
|
set ped [lreplace $ped 0 0]
|
|
while {[llength $ped] != 0} {
|
|
set data [lindex [lindex $data 3] [lindex $ped 0]]
|
|
set ped [lreplace $ped 0 0]
|
|
}
|
|
return $data
|
|
}
|
|
|
|
proc HListGetIconPath {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
set range [$P(pathname) tag nextrange Ped-[join $ped -] 1.0]
|
|
set dump [eval $P(pathname) dump -window $range]
|
|
return [lindex $dump 1]
|
|
}
|
|
|
|
proc HListPedLess {ped1 ped2} {
|
|
for {set i 0} {$i < [llength $ped1]} {incr i} {
|
|
set e1 [lindex $ped1 $i]
|
|
if [Empty [set e2 [lindex $ped2 $i]]] {return 0}
|
|
if ![string match $e1 $e2] {
|
|
return [expr $e1 < $e2]
|
|
}
|
|
}
|
|
return [expr [llength $ped1] < [llength $ped2]]
|
|
}
|
|
|
|
proc HListNextPed {ped} {
|
|
return [lreplace $ped end end [expr [lindex $ped end] + 1]]
|
|
}
|
|
|
|
######################
|
|
# Entering and leaving
|
|
|
|
proc HListItemMotion {name ped x y} {
|
|
upvar \#0 $name-hlparams P
|
|
set w $P(pathname)
|
|
set joinped [join $ped -]
|
|
set bbox [$w bbox [$w index "Ped-$joinped.last - 1 chars"]]
|
|
set ymiddle [expr [lindex $bbox 1] + (3*[lindex $bbox 3]/4)]
|
|
if {($y < $ymiddle) && (![string match top $ped])} {
|
|
HListLeave $name
|
|
$w tag add withinItem Ped-$joinped.first Ped-$joinped.last
|
|
set P(relation) within
|
|
} else {
|
|
HListLeave $name
|
|
$w tag add underItem Ped-$joinped.first Ped-$joinped.last
|
|
if {[string match top $ped]} {
|
|
set P(relation) before
|
|
} else {
|
|
set P(relation) after
|
|
}
|
|
}
|
|
}
|
|
|
|
proc HListLeave {name} {
|
|
upvar \#0 $name-hlparams P
|
|
set w $P(pathname)
|
|
catch {
|
|
$w tag remove underItem underItem.first underItem.last
|
|
}
|
|
catch {
|
|
$w tag remove withinItem withinItem.first withinItem.last
|
|
}
|
|
}
|
|
|
|
################
|
|
# Selection
|
|
|
|
proc HList1 {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
HListClearSelection $name
|
|
if {[string match top $ped]} return
|
|
HListItemSelect $name $ped
|
|
$P(pathname) configure -cursor crosshair
|
|
}
|
|
|
|
proc HList1Motion {name ped x y} {
|
|
upvar \#0 $name-hlparams(pathname) w
|
|
if {(![string match top $ped]) &&
|
|
![string match crosshair [$w cget -cursor]]} {
|
|
HListClearSelection $name
|
|
HListItemSelect $name $ped
|
|
}
|
|
set inIndex [$w index @$x,$y]
|
|
if {[regexp {Ped-([^ ]*)} [$w tag names $inIndex] v v]} {
|
|
set ped [split $v -]
|
|
HListItemMotion $name $ped $x $y
|
|
}
|
|
}
|
|
|
|
proc HList1Release {name ped x y} {
|
|
upvar \#0 $name-hlparams P
|
|
set w $P(pathname)
|
|
if ![string match crosshair [$w cget -cursor]] return
|
|
set inIndex [$w index @$x,$y]
|
|
set inTags [$w tag names $inIndex]
|
|
if {![regexp {Ped-([^ ]*)} $inTags tag v]} {
|
|
$w configure -cursor top_left_arrow
|
|
return
|
|
}
|
|
set newped [split $v -]
|
|
if {[In selected $inTags]} {
|
|
$w configure -cursor top_left_arrow
|
|
return
|
|
}
|
|
if {[string match top $newped]} {
|
|
set newped 0
|
|
}
|
|
HListDragDrop $name $newped
|
|
$w configure -cursor top_left_arrow
|
|
}
|
|
|
|
proc HListDragDrop {name targetped} {
|
|
upvar \#0 $name-hlparams P
|
|
# Get item to be moved (item1)
|
|
set selindex [$P(pathname) index selected.first]
|
|
regexp {Ped-([-0-9]*)} [$P(pathname) tag names $selindex] v ped1
|
|
set ped1 [split $ped1 -]
|
|
set item1 [HListGetItem $name $ped1]
|
|
set mode1 [lindex $item1 0]
|
|
|
|
# moving an item into itself?
|
|
if {[string match ${ped1}* $targetped]} return
|
|
|
|
switch $P(relation) {
|
|
before {
|
|
# "before" only happens with ped = {0}
|
|
} within {
|
|
# Make this a child if allowed; else default to "after" behavior
|
|
set item2 [HListGetItem $name $targetped]
|
|
set mode2 [lindex $item2 0]
|
|
array set allowedkids $P(allowedchildren)
|
|
foreach parentmode [array names allowedkids] {
|
|
if {[string match $parentmode $mode2]} {
|
|
foreach childmode $allowedkids($parentmode) {
|
|
if {[string match $childmode $mode1]} {
|
|
lappend targetped 0
|
|
set break 1
|
|
break
|
|
}
|
|
}
|
|
}
|
|
if {[info exists break]} break
|
|
}
|
|
if {![info exists break]} {
|
|
set targetped [HListNextPed $targetped]
|
|
}
|
|
} after {
|
|
# increment the last element of the pedigree
|
|
set targetped [HListNextPed $targetped]
|
|
}
|
|
}
|
|
if {[string match $ped1 $targetped]} return
|
|
if [HListPedLess $ped1 $targetped] {
|
|
HList $name insert $targetped $item1
|
|
HList $name delete $ped1
|
|
} else {
|
|
HList $name delete $ped1
|
|
HList $name insert $targetped $item1
|
|
}
|
|
}
|
|
|
|
proc HListItemSelect {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
$P(pathname) tag add selected \
|
|
Ped-[join $ped -].first Ped-[join $ped -].last
|
|
if ![Empty [set w [HListGetIconPath $name $ped]]] {
|
|
$w configure -foreground $P(selectforeground) \
|
|
-background $P(selectbackground)
|
|
}
|
|
}
|
|
|
|
proc HListClearSelection {name} {
|
|
upvar \#0 $name-hlparams P
|
|
while {![Empty [set range [$P(pathname) tag nextrange selected 1.0]]]} {
|
|
set first [lindex $range 0]
|
|
regexp {Ped-([-0-9]*)} [$P(pathname) tag names $first] ped ped
|
|
set ped [split $ped -]
|
|
HListItemDeselect $name $ped
|
|
}
|
|
}
|
|
|
|
proc HListItemDeselect {name ped} {
|
|
upvar \#0 $name-hlparams P
|
|
catch {
|
|
$P(pathname) tag remove selected \
|
|
Ped-[join $ped -].first Ped-[join $ped -].last
|
|
}
|
|
if ![Empty [set w [HListGetIconPath $name $ped]]] {
|
|
$w configure\
|
|
-foreground $P(foreground) -background $P(background)
|
|
}
|
|
}
|
|
|
|
proc HListGetSelectedPeds {name} {
|
|
upvar \#0 $name-hlparams(pathname) w
|
|
set start "1.0"
|
|
set ret ""
|
|
while {![Empty [set range [$w tag nextrange selected $start]]]} {
|
|
set first [lindex $range 0]
|
|
regexp {Ped-([-0-9]*)} [$w tag names $first] tag ped
|
|
set ped [split $ped -]
|
|
lappend ret $ped
|
|
set start [$w index "$tag.last + 1 chars"]
|
|
}
|
|
return $ret
|
|
}
|
|
|
|
#################
|
|
# Mouse-3 menus
|
|
|
|
proc HList3 {x y name ped mode} {
|
|
HList1 $name $ped
|
|
set w .hlmenu-$name
|
|
if [winfo exists $w$mode] {
|
|
tk_popup $w$mode $x $y
|
|
} elseif [winfo exists $w] {
|
|
tk_popup $w $x $y
|
|
grab $w
|
|
}
|
|
}
|
|
|
|
proc HListMenus {name} {
|
|
upvar \#0 $name-hlparams P
|
|
foreach mode [concat {{}} $P(modes)] {
|
|
set m .hlmenu-$name$mode
|
|
if ![Empty $mode] {
|
|
set itemsvar P(menu3,mode)
|
|
} else {
|
|
set itemsvar P(menu3)
|
|
}
|
|
if ![info exists $itemsvar] return
|
|
set items [set $itemsvar]
|
|
catch {destroy $m}
|
|
menu $m -tearoff 0
|
|
foreach item $items {
|
|
$m add command -label [lindex $item 0]\
|
|
-command [lindex $item 1]
|
|
}
|
|
}
|
|
}
|
|
|