Menu as trees as nested list
This page is about code that is aimed to help a developer to deal with tk menu widgets.
Introduction
FM, 2009-04-05. Menus are tree objects. Here is code to design their trees as nested list.
I chose to use a 4-length nested list (nl4tree) because for cascades entries, there are two kinds of data : the options for the uplevel menu itself and also the options to be set when adding the child menu.
Here is code to make a nl4tree. To use it you need the nl4 ensemble command, which can be found at nested list page of the wiki. The exemple below should look like this :
nl4 tree package
# package require nl4;# look at [nested list] page to get the nl4 ensemble command
namespace eval nl4tree {
proc append {tree ParentNode TreeToAppend} {
# nl4tree append ... Ok
upvar $tree Tree
::set Index [lreplace [nl4tree lindex $Tree $ParentNode] end end [nl4 rindice [nl4 type $Tree]] 0 0]
::set l [::lindex $Tree $Index]
lappend l $TreeToAppend
lset Tree $Index $l
}
proc children {tree parent} {
# nl4tree children ... Ok
::set Children [list]
lassign [nl4 index $tree] node data0 data1 children
foreach {child} [::lindex $children] {
if {$parent eq $node} {
lappend Children {*}[::lindex $child 0]
} else {
lappend Children {*}[nl4tree children $child $parent]
}
}
return $Children
}
proc delete {tree node} {
# nl4tree delete ... Ok
upvar $tree Tree
if {$node eq [nl4tree root $Tree]} {uplevel "unset $tree"; return}
::set TailIndex [::lindex [::set NodeIndex [nl4tree lindex $Tree $node]] end-1]
::set ListNodeIndex [lreplace $NodeIndex end-1 end]
::set L [lreplace [::lindex $Tree $ListNodeIndex] $TailIndex $TailIndex]
::set ParentIndex [nl4tree lindex $Tree [::set Parent [nl4tree parent $Tree $node]]]
::set SubTreeIndex [lreplace $ParentIndex end end]
lset Tree {*}$SubTreeIndex [nl4 rindice [nl4 type $Tree]] 0 0 $L
return
}
proc get {tree node numdict args} {
# nl4tree get .. Ok
::set index [lreplace [nl4tree lindex $tree $node] end end]
return [dict get [nl4 index [::lindex $tree $index] [expr {$numdict+1}]] {*}$args]
}
proc glob {tree pattern {index {}}} {
# nl4tree glob ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {[string match $pattern $node]} {
lappend L $node
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl4 rindice [nl4 type $tree]] 0 0 $j]
lappend L {*}[nl4tree glob $child $pattern $childIndex]
incr j
}
if {[info exist L]} {
return $L
}
}
proc insert {tree Parent index TreeToInsert} {
# nl4tree insert ...Ok
upvar $tree Tree
::set ParentIndex [lreplace [nl4tree lindex $Tree $Parent] end end [nl4 rindice [nl4 type $Tree]] 0 0]
::set l [::lindex $Tree $ParentIndex]
if {$index < [nl4tree numchildren $Tree $Parent]} {
lset Tree $ParentIndex [linsert $l $index $TreeToInsert]
}
}
proc keys {tree node numdict args} {
# nl4tree keys ... Ok
::set index [lreplace [nl4tree lindex $tree $node] end end]
return [dict keys [nl4 index [::lindex $tree $index] [expr {$numdict+1}]] {*}$args]
}
proc lindex {tree parent {index {}}} {
# nl4tree lindex ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {$parent eq $node} {
return [list {*}$index 0]
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl4 rindice [nl4 type $tree]] 0 0 $j]
if {[::set p [nl4tree lindex $child $parent $childIndex]] ne ""} {
return $p
}
incr j
}
return
}
proc node {tree args} {
# nl4tree node ... Ok
::set i 0
foreach i $args {
lappend Index [nl4 rindice [nl4 type $tree]] 0 0 $i
incr i
}
lappend Index 0
::lindex $tree {*}$Index
}
proc numchildren {tree node} {
# nl4tree numchildren ... Ok
::set Index [lreplace [nl4tree lindex $tree $node] end end]
llength [nl4 index [::lindex $tree $Index] 3]
}
proc parent {tree parent {Parent {}}} {
# nl4tree parent ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {$parent eq $node} {
return $Parent
}
foreach {child} [::lindex $children] {
if {[::set p [nl4tree parent $child $parent $node]] ne ""} {
return $p
}
}
return
}
proc root {tree} {
# nl4tree root ... Ok
return [::lindex $tree 0]
}
proc set {tree node numdict args} {
# nl4tree set .. Ok
upvar $tree Tree
::set keys [lrange $args 0 end-1]
::set arg [::lindex $args end]
::set index [lreplace [nl4tree lindex $Tree $node] end end ]
::set DictIndex [::lindex [nl4 iorder [nl4 type [::lindex $Tree $index]]] [expr {$numdict+1}]]
::set Dict [nl4 index [::lindex $Tree $index] [expr {$numdict+1}]]
dict set Dict {*}$keys $arg
lset Tree {*}$index $DictIndex [list $Dict]
return $Dict
}
namespace export *
namespace ensemble create
}
package provide nl4tree 0.1treeMenu package
# source nl4tree.tcl;# you'll find the nl4tree ensemble command just above
namespace eval treeMenu {
variable numMenu 0
variable numCommand 0
variable numSeparator 0
variable numCheckButton 0
variable numRadioButton 0
# create menu / cascade
proc cascade {D0 D1 args} {
variable numMenu
if {[llength $args] != 0} {
menu [::set N .menu[incr numMenu]] -tearoff false {*}$D0
return [nl4 south $N $D0 $D1 [list $args]]
} else {
return [nl4 south $N $D0 $D1]
}
}
# command entry
proc command {args} {
variable numCommand
::set N .command[incr numCommand]
return [nl4 south $N {} [dict create {*}$args]]
}
# separator entry
proc separator {args} {
variable numSeparator
::set N .separator[incr numSeparator]
return [nl4 south $N {} {}]
}
# checkbutton entry
proc checkbutton {args} {
variable numCheckButton
::set N .checkbutton[incr numCheckButton]
return [nl4 south $N {} [dict create {*}$args]]
}
# radiobutton entry
proc radiobutton {args} {
variable numRadioButton
::set N .radiobutton[incr numRadioButton]
return [nl4 south $N {} [dict create {*}$args]]
}
# Build the menu
variable TreeMenu
proc set {var tree {node {}}} {
variable TreeMenu
if {$node eq {}} {
::set TreeMenu($var,script) $tree
::set tree [uplevel $tree]
::set TreeMenu($var,tree) $tree
::set node [nl4tree root $tree]
}
foreach n [nl4tree children $tree $node] {
if {[string match .menu* $n]} {
$node add cascade -menu $n {*}[nl4tree get $tree $n 1]
} elseif {[string match .command* $n]} {
$node add command {*}[::set options [nl4tree get $tree $n 1]]
if {[dict exist $options -accelerator]} {
::set Accelerator [string map {Ctrl Control + -} [dict get $options -accelerator]]
if {! (([string index $Accelerator 0] eq "<") && ([string index $Accelerator 0] eq ">"))} {
::set Accelerator <$Accelerator>
}
bind . $Accelerator [subst {
$node invoke [$node index [dict get $options -label]]
}]
}
} elseif {[string match .separator* $n]} {
$node add separator {*}[nl4tree get $tree $n 1]
} elseif {[string match .checkbutton* $n]} {
$node add checkbutton {*}[nl4tree get $tree $n 1]
} elseif {[string match .radiobutton* $n]} {
$node add radiobutton {*}[nl4tree get $tree $n 1]
}
::treeMenu set $var $tree $n
}
return $node
}
proc update {var widget} {
# basic : destruction / reconstruction
variable TreeMenu
::set Reinit {{var pattern} {
expr {[regsub $pattern [lindex [lsort [nl4tree glob $::treeMenu::TreeMenu($var,tree) $pattern*]] 0] {}]-1}
}}
variable numMenu [apply $Reinit $var .menu]
variable numCommand [apply $Reinit $var .command]
variable numSeparator [apply $Reinit $var .separator]
variable numCheckButton [apply $Reinit $var .checkbutton]
variable numRadioButton [apply $Reinit $var .radiobutton]
destroy {*}[nl4tree glob $TreeMenu($var,tree) .menu*]
$widget conf -menu [uplevel [list ::treeMenu set $var $TreeMenu($var,script)]]
}
namespace export *
namespace ensemble create
}
# package provide treeMenu 0.1
Here's an example, so you can feel the way it works.
# package require treeMenu (See above)
# using some shorthand
interp alias {} + {} treeMenu cascade
interp alias {} ! {} treeMenu command
interp alias {} - {} treeMenu separator
interp alias {} x {} treeMenu checkbutton
interp alias {} ° {} treeMenu radio
# Use some alternatives languages for menu label
proc translate {label lang} {
return [dict get [dict create \
Fichier [dict create en File fr Fichier] \
Ouvrir [dict create en Open fr Ouvrir] \
Nouveau [dict create en New fr Nouveau] \
Exporter [dict create en Export fr Exporter]\
Enregistrer [dict create en Save fr Enregistrer]\
"Enregistrer sous..." [dict create en "Save as..." fr "Enregistrer sous..."]\
Editer [dict create en Edit fr Editer] \
Fermer [dict create en Close fr Fermer] \
Quitter [dict create en Quit fr Quitter]\
Copier [dict create en Copy fr Copier]\
Coller [dict create en Paste fr Coller]\
Couper [dict create en Cut fr Couper]\
"en PDF" [dict create en "as PDF" fr "en PDF"]\
"en DVI" [dict create en "as DVI" fr "en DVI"]\
"en Postscript" [dict create en "as Postscript" fr "en Postscript"]\
"Cas" [dict create en Check fr "Cas"]\
"Options" [dict create en Options fr "Options"]\
"Anglais" [dict create en "English" fr "Anglais"]\
"Français" [dict create en "French" fr "Français"]\
"Comme nouveau" [dict create en "As new file" fr "Comme nouveau"]\
"Comme un calque" [dict create en "As new layer" fr "Comme un calque"]\
"Verrouiller" [dict create en "Press to lock file" fr "Cliquer pour verrouiller"]\
"Déverrouiller" [dict create en "Press to unlock file" fr "Cliquer pour déverrouiller"]\
] $label $lang]
}
# use state variables (fileopen : if there is a file open, lock : to protect the file of any change)
set fileopen 0
set lock 0
# variable to config the langage (you can change it in options menu)
set lang fr
# style of the menu
set Style [list -bg DarkOrange4 -fg white -activebackground DarkOliveGreen -activeforeground yellow -font \
[set font [font create -family Helvetica -size 12]]]
# Create the menu on the . Widget
. conf -menu [treeMenu set Menu {
+ $Style {} \
[+ $Style [list \
-label [translate "Fichier" $lang] \
-underline 0 ] \
[! -label [translate "Nouveau" $lang] \
-underline 0 \
-accelerator Ctrl+n \
-image [image create photo -data {
R0lGODlhEAAQAMZYAIiKg4iKhYqLg5ORe6CdeamkacW5TdPDO9HFYO3UAO3UAe3UAu3UBO3UBe3V
BO3VB+3VCe3VCujUJe7WCu7XEfDaIPPdIvPdI/ThP/fiNvTjW/XkV/rmRfrmRvblYPblYfrnR/Dk
iu7klvvoS+7lj/voTPvoTe/lj+bizezkqenjvOzkqujjw+fjye7mm+zlrOTj2eTj2uPj3ePj3uPj
4ePj4uPj4+fk2+Tk5OXk5OTl4eXl5e3nvunm1ubm5urn1Ofn5+ro3Ojo6Ovo5enp5+rp6erp6uvr
6+zs7Pjxr/32wvz55vz65vz65/365vz67P375/376v376/377f389P39/f7+/P7+/v//////////
////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////yH5
BAEKAH8ALAAAAAAQABAAAAergH9/AYQBAAMFBgcSF4KCAVeRV09JGxUKChQWjpBIR0M8EAsJU1MJ
Cg6PV0dFQS4NTU6yTkwOHYNXRkQ/IQxMs7QOILhCQD0nGAtQsksKGSO4QD43LxoMVkxMTQ4cJrg+
OzotJA9RDAxSDyWqOTg2MywiER8eEwicVzb67ygqKylKCODbp4+GjBgwqAgYSFBfjRpVAjBsqO+K
RFUU91nEJ6mjpIuDCokcKSgQADs=
}]\
-compound left \
-command {
set fileopen 1
treeMenu update Menu .
}] \
[! -label [translate "Ouvrir" $lang] \
-underline 0 \
-accelerator Ctrl-o \
-image [image create photo -data {
R0lGODlhEAAQAMZCAExOSk1PS05QTU9RTVBSTlVXU1dZVVhaVmJkYGRmXmZoY2lrZ2psaG1vZXt9
a4GEcIeJgYqNeIyPe4+Rfo+SfpCSg5KUgZiajJmbhpqch5qdiJydkJ2fkaKkk6OklaOllqeplqmq
mqqumq+wma6wnq+wn7CxmrGym7CyoLGxrbKzprO1o7m6rLu9qr6/rr6/r76+vL/Arr/Ar8DBr8DB
tcHDssPEs8PEt8PFtcnKu8rMvsvNvs/Qws/RwtDRw9DRxNHSxO7u7P//////////////////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////yH5
BAEKAH8ALAAAAAAQABAAAAemgAwFg4MLf4eIiAU1OI0sBYmRBS0aGRglhJkFCn8FKxQUExYhHR4f
px8ckJ6gCZqDDaqdnxQFQre4QgWyBSgRErZBwsK6F6skERG2MMzMuhWrIA8PwcNBz6siDg62KQMA
4OABBwcFCAHoARs3QEA8Ozo5EIM+PPb2NiMm+/s/gz0nAgoceGIEjUEuZsRYOGOGjIcLX6jYRICA
gIsYBVS0aCCSR4+BAAA7
}] \
-compound left \
-command {
set fileopen 1
tk_getOpenFile
treeMenu update Menu .
}] \
[- ------------------------------------------ -]\
[+ $Style [list \
-label [translate "Exporter" $lang] \
-state [expr {$fileopen ? "normal" : "disable"}] \
-underline 0] \
[! -label [translate "en PDF" $lang] \
-command {
tk_getSaveFile
}] \
[! -label [translate "en DVI" $lang] \
-command {
tk_getSaveFile
}] \
[! -label [translate "en Postscript" $lang] \
-command {
tk_getSaveFile
}] \
]\
[- ----------------------------------------- -]\
[! -label [translate "Enregistrer" $lang] \
-state [expr {$fileopen==1 && $lock == 0 ? "normal" : "disable"}]\
-accelerator {Ctrl+s} \
-image [image create photo -data {
R0lGODlhEAAQAKUnACBKh1VXU85cAGF6kmF6k117mWJ7kmN7kmJ8lGN8lGB+nGmMsHCeznGeznKf
znKfz46pzJS227Kyspi43PyvPrm5ubm6urq6ur+/v8LCwsXFxb7S6tbW1sjZ7tfX1+Hh4eLi4uPj
4+bm5ufn5/T09Pn5+f7+/v//////////////////////////////////////////////////////
/////////////////////////////////////////////yH5BAEKAD8ALAAAAAAQABAAAAaAQIBQ
QCwahcJNh8JsOjeb5KNErVofUcBmCup6uyWs1EQqm81i7cPkabvbpPSWfD7L16a8Xn9/+P+AdwsI
hIUICxF3ChcaGh8jHhYFDBFZWwONAQEgGhUEDZVSBo6ajRifoQAQEwYfIqUZEqhZqgchHBe5FRUJ
DhNRP0Kaw8RIAEEAOw==
}]\
-compound left \
-command {
tk_getSaveFile
}] \
[! -label [translate "Enregistrer sous..." $lang] \
-state [expr {$fileopen ? "normal" : "disable"}] \
-image [image create photo -data {
R0lGODlhEAAQAKU7AAAAAExCJiBKh1VXU2tXNnBbOY9ZArdaAM5cAGF6kmF6k117mWJ7kmN7kmJ8
lGN8lGB+nKCDVWmMsKOFVaSHV3CeznGeznKfznKfz46pzMKritKsas+tcZS227KyssSwkZi43Pyv
Prm5ubm6urq6usi9rL+/v8LCwsXFxb7S6t/Vw9bW1sjZ7tfX1+PZx+Hh4eLi4uPj4+bm5ufn5+7q
xu/rx/Pz8/T09Pn5+fz8/P7+/v///////////////////yH5BAEKAD8ALAAAAAAQABAAAAadQIEQ
QSwaDAeEUJhihZ5PA41jCKVSTAxuizPUNhGDC4MVpLQwmHdDMXxwlvJZd7sVNBODqh7P6loGAQQG
JS0tNmR+NwB6dY6JZhg6k5SUOZBnGJqbnJgYEg6hog4SHZ4QJCgoLzMtIwsVHXIYCaoDAzAoIgoW
slkMq7eqJry+AhkgDC8ywicexWXHDTErJNYiIg8XIFg/Qrfg4UsCQQA7
}] -compound left \
-command {
tk_getSaveFile
}] \
[! -label [translate "Fermer" $lang] \
-state [expr {$fileopen ? "normal" : "disable"}] \
-command {
tk_messageBox -message "Closing"
set fileopen 0
set lock 0
treeMenu update Menu .
}] \
[- ---------------------------------------- -]\
[! -label [translate "Quitter" $lang] -accelerator {Ctrl+q} \
-image [image create photo -data {
R0lGODlhEAAQAKUzAAcPAA0cABMoAKQAABgtBrQAABgzAMwAAC40NiI+CCFBBitODSpPBy9WDTJZ
EDZbGDleGe8pKTpiFzhmDjtlGD5kHltbWjxsE0FuGT9wFUNuH0R1GUZ0I0t6Imxsakt+H05+JVB+
KlB/K3Z5enl5d/uCgqSkoq2tq7e3tbm5t729u8DAvcHBvtDQzdPT0NTU0d7e3ODg3uLi4P//////
/////////////////////////////////////////////yH5BAEKAD8ALAAAAAAQABAAAAaDwJ9w
SCwaEcik8ihzrU4yBECAIA4GiOYKFQ0YqsNBaQBzsVJRgqJ6vZbGrXM0wWC/34exyhRdNOwHgYFj
JBYIDhNsEQWMjBEDHlEPF4oRlgWPcggQGWxtlgMvmhIYYEIDjzKiMlEUG6Y/VwgxrCMIFRwfsEJZ
thodICEiuz9KxsRGRUEAOw==
}] -compound left -command {
tk_messageBox -message [translate "Quitter" $lang]
}] \
]\
[+ $Style [list \
-label [translate "Editer" $lang] \
-state [expr {$fileopen ? "normal" : "disable"}]] \
[! -label [translate "Couper" $lang] \
-accelerator Ctrl+x \
-image [image create photo -data {
R0lGODlhEAAQAIQZAFVXU2VnY3R1coGCf42Oi5iZlqipp66sp7Gup7+7sb6/vcfEu8jHwsrKyczK
xs/KwdHOxNXTytjW0dza0dzb1uPh3OPi3OTi3evp5f///////////////////////////yH5BAEK
AB8ALAAAAAAQABAAAAVJ4CeOZFkCpzmiJMCe1AtMb1sV4wDVq8MEHwAGwRsJJIQPIZJUBS8HgCVR
JAUWgEf15HKKXC4FwNBNBRufBou3Xn3Nsjd37q2HAAA7
}] \
-compound left \
-command {
tk_messageBox -message "Coupé"
}] \
[! -label [translate "Copier" $lang] \
-accelerator Ctrl+c \
-image [image create photo -data {
R0lGODlhEAAQAMIEAIiKhbu8uLq9tu7u7P///////////////yH5BAEKAAcALAAAAAAQABAAAANE
eLC891CRSSeIDxDBO7mYNozkh0mdB0biGDRNtnFaRV3toKWcudMEUglX+aVMikZQOECyZscVJDc8
GQUj59R2OyVhoAQAOw==
}] \
-compound left \
-command {
tk_messageBox -message "Copié"
}] \
[! -label [translate "Coller" $lang] \
-state [expr {$lock ? "disable" : "normal"}] \
-accelerator Ctrl+v \
-image [image create photo -data {
R0lGODlhEAAQAMZFAC0mGiwtLDstFy40No9ZAot2Unt5cIiDc4iKhZyTf6KbjaCinqGkoKOloaWm
o6aopKeopaippqmrp6qrqKusqausqq2uq7+8s+m5bs7Lwc/Mwc7Pys/RzdHTztbTyNLUz9TW0tXX
0tjY2NnY19fZ1dna19ra2Nrb2Nvb29vd2dze2t3e297f3N/h3d/h3uDi3u/gx+Hi3+Lj3+Pj4+Pk
4uTl4ubn5efo5efo5uvo3Ovo3enp5+jq6Orr6Ovr6evs6uzt6+7v7e/v7fDx7/Pz8f//////////
////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////yH5
BAEKAH8ALAAAAAAQABAAAAeegH+CggOFg4eCBIoAKDMiAooEhwQwMAYBIxcmAQqVkokwGAM5HhoZ
OgMYMJ9/lBgFhbEFqqyuGBgJCLq7vLYYCEXBwsIIvsAbHB8gJCUpRcWht8AdCwwNDg8uz8ZFISQn
KiwxNNvRv0UlDhAREhQ45bfnKy0yNTY7PvDSRS8TFRY9gAjRd67GDR4/ggwhUq4SDGDDhiFoFekA
r4sIAgEAOw==
}] \
-compound left \
-command {
tk_messageBox -message "Collé"
}] \
\
[- --------------Separator--------------------------- -]\
[+ $Style [dict create \
-label [translate "Coller" $lang]... \
-state [expr {$lock ? "disable" : "normal"}]]\
\
[! -label [translate "Comme un calque" $lang] \
-command {
tk_messageBox -message "Collé comme un calque"
}]\
[! -label [translate "Comme nouveau" $lang]\
-command {
tk_messageBox -message "Coller comme nouveau"
}]\
]\
] \
[+ $Style [dict create \
-label [translate "Options" $lang] \
-underline 0] \
\
[x -label [translate [expr {$lock ? "Déverrouiller" : "Verrouiller"}] $lang ]\
-state [expr {$fileopen ? "normal" : "disable"}]\
-variable ::lock \
-onvalue 1 -offvalue 0 \
-command {
treeMenu update Menu .
}]\
[- ---------Separator----------------------------------- -]\
[° -label [translate Anglais $lang] -variable ::lang -value en -command {
treeMenu update Menu .
}]\
[° -label [translate Français $lang] -variable ::lang -value fr -command {
treeMenu update Menu .
}]\
]}]
Fully configurable, style control, language handling, state handling, accelerator handling, readable, tree aspect. It's marvelous, isn't it?