MegaWidgets as nested list
if 0 {FM 2009-10-07:
This page is about an experimental package. I wanted to try TclOO to do megawidgets, but, as I'm addict to nested lists, I used TclOO and nested list to deal with.
The principles of this program are very similar as those developped in the page Menu as trees as nested list and shortly explained in the page nested list, to say "nested lists seen as pseudo-type".
I wanted to obtain a "visual" way to build megawidgets. I choose to implement it with the packer algorithm. Nested lists are used as pseudo-type, a way to encode datas, which can be test. The megawidget framework is a class, which accept a nested script as argument. When creating the megawidget object, the class eval the nested script to build a nested list. When the megawidget object is call whith a path, it reads the nested list, recognize the pseudo-type datas, and accordingly, create the widgets, and an ensemble command whith some "methods".
The packer algorithm has 5 mains distincts way to be specified, the -side option being the most important layout element. So I decided to encode it as a nl5 list (constant length eq 5). A widget command is encoded as a nl3 list (type left). The extra pack options are encoded as an nl2 list (type left). The bindings of a widget are encoded as a nl3 list (type middle). The options of the widget, as a nl2 list (type right). The definition of an handler is encoded as a nl4 list (type east). A methods as an nl4 list (type west).
This is to be use with Tcl 8.6 (or TclOO) and nl* package
}
oo::class create megawidget {
package require nl2
package require nl3
package require nl4
package require nl5
constructor {tree} {
my variable WidgetTree
::set WidgetTree(script) $tree
}
method addMethod {rootPath handler methodName methodArgs methodBody} {
my variable WidgetTree
set Index $WidgetTree($rootPath,$handler,methods,index)
set methodBody [regsub -all %MW $methodBody ${rootPath}]; # substitution MegaWidget
set methodBody [regsub -all %${rootPath} $methodBody %MW]; # unsubstitute protected MegaWidget
set methodBody [regsub -all %O $methodBody [self]]; # substitution Object
set methodBody [regsub -all %[self] $methodBody %O]; # unsubstitute protected Object
set Methods [lindex $WidgetTree(tree) $Index]
nl4 append Methods $methodName $methodArgs $methodBody
lset WidgetTree(tree) $Index $Methods
[self] update
}
method getTreeScript {} {
my variable WidgetTree
return $WidgetTree(script)
}
method getTree {} {
my variable WidgetTree
return $WidgetTree(tree)
}
method setTree {Tree} {
my variable WidgetTree
set WidgetTree(tree) $Tree
}
method getIndex {path} {
my variable WidgetTree
return [set WidgetTree($path,index)]
}
method evaluate {code} {
my eval $code
}
method > {args} {
if {[set len [llength $args]] <= 4} {
lappend args {*}[lrepeat [expr {4-$len}] {}]
}
return [nl5 east {*}$args]
}
method v args [regsub -- {nl5 east} [lindex [info class definition megawidget >] 1] {nl5 south}]
method ^ args [regsub -- {nl5 east} [lindex [info class definition megawidget >] 1] {nl5 north}]
method < args [regsub -- {nl5 east} [lindex [info class definition megawidget >] 1] {nl5 west}]
method @ args [regsub -- {nl5 east} [lindex [info class definition megawidget >] 1] {nl5 center}]
foreach {m nl v} [list pack nl2 left \
bind nl3 middle \
widget nl3 left \
megaWidget nl3 right \
options nl2 right \
handler nl4 east \
methods nl4 west] {
method $m {args} [subst -noc {
return [$nl $v {*}\$args]
}]
method _is[string totitle $m] {L} [subst -noc {
return [$nl is $v \$L]
}]
}
method make {tree {ListIndex {}}} {
my variable WidgetTree
my variable path
my variable rootPath
set id 0
set NestedListIndex -1; # initialisation du compteur de l'indice de la liste imbriquée nl5
set NestedListType [nl5 type $tree]; # Type d'imbrication
set Side [dict get [dict create north bottom west right south top east left center {}] $NestedListType]
set P $path; # mise en mémoire du chemin parent
set Li $ListIndex; # mise en mémoire de la valeur d'indice parent
foreach node [nl5 index $tree] {
# puts $path
# lappend ListIndex "nl5 $NestedListType [nl5 2lindex $NestedListType [incr NestedListIndex]]"; # trace
lappend ListIndex {*}[nl5 2lindex $NestedListType [incr NestedListIndex]]
if {$node ne ""} {
# puts $ListIndex; # trace de l'indice de liste imbriqué
}
if {[my _isWidget $node]} {
# widget classique
set handler {}
set iConf 0; # initialisation du compteur de l'indice de type nl3 left
set Args [nl3 assign $node command]
set path $P; # réinitialisation du chemin à celui du parent
set path $path.[regsub -all {::} $command {_}][incr id]; # calcul du chemin de la fenêtre en traitement
lappend WidgetTree(widgets) $path ; # construction de la liste des fenêtres
if {![winfo exist $path]} {
$command $path; # création de la fenêtre
}
if {$Side ne {}} {
pack $path -fill both -expand 1 -side $Side
} else {
pack $path -fill both -expand 1
}
lappend ListIndex 0; # l'exploration de l'imbriquement implique une perte d'imbrication
set WidgetTree(${path},index) $ListIndex
set Lii $ListIndex; # mémorisation de l'index précédent
foreach conf [nl3 index $Args] {
incr iConf; # la commande étant à l'indice 0, on commence à compter à partir de 1
# lappend ListIndex "nl3 left [nl3 2lindex left $iConf]"; # trace
lappend ListIndex {*}[nl3 2lindex left $iConf]; #
# puts $path
if {[my _isOptions $conf]} {
# Options de la fenêtre
set Options [nl2 index $conf]
set Options [regsub -all {%MW} $Options $rootPath]
set Options [regsub -all %$rootPath $Options {%MW}]
set Options [regsub -all {%O} $Options [self]]
set Options [regsub -all %[self] $Options {%O}]
$path configure {*}$Options
set WidgetTree(${path},options,index) $ListIndex
} elseif {[my _isPack $conf]} {
# Option de l'algorithme pack
set Pack [nl2 index $conf]
set Pack [regsub -all {%MW} $Pack $rootPath]
set Pack [regsub -all %$rootPath $Pack {%MW}]
set Pack [regsub -all {%O} $Pack [self]]
set Pack [regsub -all %[self] $Pack {%O}]
::pack conf $path -expand 1 -fill both {*}$Pack {*}[expr {($Side eq "") ? [list] : [list -side $Side]}]
set WidgetTree(${path},pack,index) $ListIndex
} elseif {[my _isBind $conf]} {
# Evènements associés à la fenêtre
set WidgetTree(${path},bind,index) $ListIndex
foreach {event script} [nl3 index $conf] {
set script [regsub -all {%MW} $script $rootPath]
set script [regsub -all %$rootPath $script %MW]
set script [regsub -all {%O} $script [self]]
set script [regsub -all %[self] $script %O]
::bind $path $event $script
}
} elseif {[my _isHandler $conf]} {
set WidgetTree(${path},handler,index) $ListIndex
# définition d'un raccourci (handler)
set handler [nl4 index $conf 0]
# puts $handler
namespace eval ::${rootPath}::$handler {}
namespace eval ::${rootPath}::$path {}
proc ::${rootPath}::${handler}::configure {args} [subst -noc {
$path configure {*}\$args
}]
proc ::${rootPath}::${handler}::pack {args} [subst -noc {
::pack configure $path {*}\$args
}]
proc ::${rootPath}::${handler}::bind {event script} [subst -noc {
puts \$event
puts \$script
::bind $path \$event \$script
}]
proc ::${rootPath}::${handler}::do {args} [subst -noc {
$path {*}\$args
}]
proc ::${rootPath}::${handler}::path {args} [subst -noc {
return $path
}]
proc ::${rootPath}::${path}::handler {args} [subst -noc {
return $handler
}]
proc ::${rootPath}::${handler}::space {args} [subst -noc {
return ::${rootPath}::${handler}
}]
proc ::${rootPath}::${handler}::treeIndex {} [subst -noc {
return \$::${rootPath}::${handler}::treeIndex
}]
# puts $conf; # trace
if {[nl4 index $conf 1] ne {}} {
set Methods {*}[nl4 index [nl4 range $conf 1 end]]
# puts $Methods; # trace
if {[my _isMethods $Methods]} {
set WidgetTree(${path},methods,index) [list {*}$ListIndex 1]
# méthodes associées au raccourci (handler)
foreach {Name Args Body} [nl4 index $Methods] {
set Body [regsub -all %MW $Body ${rootPath}]; # substitution MegaWidget
set Body [regsub -all %${rootPath} $Body %MW]; # unsubstitution MegaWidget
set Body [regsub -all %O $Body [self]]; # substituion Object
set Body [regsub -all %[self] $Body %O]; # unsubstituion Object
proc "::${rootPath}::${handler}::${Name}" $Args $Body
}
}
}
namespace eval ::${rootPath}::${handler} namespace export *
namespace eval ::${rootPath}::${handler} namespace ensemble create
namespace eval ::${rootPath}::${path} namespace export *
namespace eval ::${rootPath}::${path} namespace ensemble create
} elseif {[nl5 type $conf] ne ""} {
# sous fenêtre
if {$handler ne {}} {
proc "::${rootPath}::${handler}::childListIndex" {} [subst -noc {
return [list {*}$ListIndex 0]
}]
# puts "ici : $handler $path $ListIndex"
}
my make $conf [list {*}$ListIndex 0]
} else {
error "could not recognize data $conf"
}
set ListIndex $Lii; # réinitialisation à la valeur avant comptage de l'indice de type nl3 left
}
} else {
if {$node eq ""} continue
puts stderr "ununderstandable {$node} $tree"
}
set ListIndex $Li; # réinitialisation à la valeur avant comptage de l'indice de type nl5
}
set path $P; # réinitialisation du chemin à la valeur du chemin parent
}
method update {} {
my variable WidgetTree
my variable rootPath
my variable path
set w ${rootPath}_
if {![winfo exist [set path ${w}]]} {
frame [set path ${w}]
}
pack $path -expand 1 -fill both
namespace eval ::${rootPath} {}
my make $WidgetTree(tree)
proc ::${rootPath}::rootpath {args} [subst -noc {
return ${rootPath}_
}]
namespace eval ::${rootPath} namespace export *
namespace eval ::${rootPath} namespace ensemble create
}
method updateFromScript {} {
my variable WidgetTree
my variable rootPath
my variable path
# rejouer le script
::set WidgetTree(tree) [my eval $WidgetTree(script)]
set w ${rootPath}_
if {![winfo exist [set path ${w}]]} {
frame [set path ${w}]
}
pack $path -expand 1 -fill both
namespace eval ::${rootPath} {}
my make $WidgetTree(tree)
proc ::${rootPath}::rootpath {args} [subst -noc {
return ${rootPath}_
}]
namespace eval ::${rootPath} namespace export *
namespace eval ::${rootPath} namespace ensemble create
}
method unknown {w args} {
if {[string match .* $w]} {
if {[winfo exist $w]} {
return -code error -message "$w already exist"
}
if {[winfo exist ${w}_]} {
return -code error -message "${w}_ already exist"
}
if {[string last . $w] == 0} {
# la fenêtre parente . existe toujours
if {$w ne "."} {
my _build $w
return $w
} else {
return -code error -message "$w is the toplevel window !"
}
} elseif {[set lastdot [string last . $w]] > 0} {
# la fenêtre parent doit exister
if {[set ParentWindow [winfo exist [string range $w 0 ${lastdot}-1]]]} {
my _build $w
return $w
} else {
return -code error -message "window $ParentWindow don't exist"
}
}
} else {
return -code error -message "Bad widget path name $w"
}
}
method _build {w} {
my variable rootPath
my variable path
my variable WidgetTree
::set WidgetTree(tree) [my eval $WidgetTree(script)]
set rootPath $w
frame [set path ${w}_]
pack $path -expand 1 -fill both
namespace eval ::${rootPath} {}
my make $WidgetTree(tree)
proc ::${rootPath}::rootpath {args} [subst -noc {
return ${rootPath}_
}]
namespace eval ::${rootPath} namespace export *
namespace eval ::${rootPath} namespace ensemble create
}
}
package provide megawidget 0.1
if 0 {The best way to explain it is to show some examples .
A tiny editor megawidget :
}
package require megawidget
set Tree {
my v \
{*}[package require stext; set E {}] \
[my widget frame \
[my handler toolbar \
[my methods \
add {megacode} {
set Index [%MW toolbar childListIndex]
set Tree [%O getTree]
set Children [lindex $Tree $Index]
set toAdd [%O evaluate $megacode]
set toSet [nl5 append Children $toAdd]
lset Tree $Index $toSet
%O setTree $Tree
%O update
}]]\
[my pack -expand 0 -fill x -padx 5 -pady 5]\
[my > \
[my widget ttk::button \
[my handler bNew]\
[my options \
-text "New File" \
-image [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
WXMAAAuHAAALhwGTQIdTAAAAB3RJTUUH1gcYDR0QxT0Z2QAAA3VJREFUSMe1lc1vG1UUxX9v7PFH
nXGdhFQhNG2RQShf7OAfQF1USKgrkFixAgkWSLBlh5CABUtEVwghdVHxL9BFFyxYIZIUqqYlxQoQ
Qm3L9sR27LmHhWdsJ5kipKojXenN03vn3K9zHzzhz/3fg2F7owxUQOeAeVAJ8IEBuBA4ALdTCjZb
qQSffv7J28C1NPBisUch36dcDglmQorFHr4/wPfzDAZ9Ll3Y+3J+vv0zuBqwWQq2asnd7BTOtVev
vEa1WqVYLI43pQ7S35jdYzi4j7QHOqC7+xUAtnCVv/aDdz0vvFEuRz9lMq4QttfDUrBVP0lAtVol
iiI6nU68M0Q6AN1jULtCbvkD4HeOat8xu9rFuQL1bcczSy/TaFRePzxs5oLABIRhe+NmKdgcZI+n
ojgGF0IKQXUc+wAc1b4AoPzCjzhXAGB2tUHj9iwVgD5XCVb3gQawAPzhpeVcEhKgAajJoPYWM899
T2Wlz9yayGZfmhTRVZhbE3NrInj+F3oPbr8DWgAWAbx0cCEzZH2kQ7LnP6az8wrOef/Zae27KxQu
rtwCyqBHEJghjcwkYBgb9HsfISkVfDjcTpa5uH2zqQQmYRIyIWWRMkgZ/OU3OLz/GbJ6KkHrzjr+
+VWAo5E2+CeVACURCFkGUwGpiGxmlHOv/MgUdbt5gCbQArefniJi7zFEHlkZswrSXFxUH6lLfdtR
33ZYdDC+2+nMAO7PkbF3SgcAZpoUWhngaTzvIc5aeEvvU98eiT9/YQPnBjR/PQdA4eJ7NO7ssrhY
3wV3sxRs9U4RtNttLIpiDQgkpAIWLaNMF0+GW/wQzz1kOAyBAd7SOrISprM0GmcBbpWCrd/SRsWk
TUkisJjoKSLLkfVyOK+Ec/M4QnARkoesiJ97lrs74vLl6z9M46UQxAU+JjghzXAUvQg08LwGnqsj
IiwKiKxMsbROq/3gVOETgnGx7Vh6JmvDQB7SHFFUAV2Kz4JMQD61s7KnIjGbAo+7Cpv8y0BTio/X
YZgMSDzAThLkAcKwM1JvcjlpWU1qAhPQUTo5qe4C0EtIEgJ/orPE4zj3HAcSk0gmZ2ya4EysZgFK
CKJxSH7ucZ9hb6zZqQj67Vb7+jfffv3m4yA3G80bU94fe5NdPAWD0ajlTFyXTJy+TOyMiz3UlPWA
zmj+jC2aJnmi378NICLymcn25wAAAABJRU5ErkJggg==
}] -compound top \
-command {
puts hello
}] \
[my pack -ipadx 2 -ipady 5 -expand 0 -fill none]\
]\
[my widget ttk::button \
[my handler bOpen]\
[my pack -ipadx 2 -ipady 5 -expand 0 -fill none]\
[my options \
-text "Open File" \
-image [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
WXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1gkWFgcxduV2nwAAAwBJREFUSMfVlb9vHFUQxz9vbw8d
CRQ+h6soaVKALJEGUVlIB1VACiFuUlFESFDkD6AIJTUddEHCJjH5YUCiCL8khA1FLBpLjiNFCrax
Te6H7853+/bNDMXuHWcO+2wQBU9a7dt535nvznd2duD/vlx/c/7CuXeB9w7BXrx1c+ETn3j5pwQ2
M3OWSuXUCGh7+3dmZ28DXLw2N//xcQji4YdK5RQrK7+MgE6ffo7yRIlavXf1/IVzV8fE/ODa3Pw7
f0sAsLvbGfFYWvqR6svVsW/74MFDFhfvvg0cTNDpdAHY2HhErdYaIlk5NHi5/CTV6jSLi3cPlmh4
1WotPp29fmSt35h5HTM7vAbACKhefzQ2+MTEJACqOuIf/zW4qqL6J2h5eXkswfT0S+O/on5wCYqh
A8DU1NSRZYqi6GAC5xzOOdT2p3ncDJxzB0vknCOEsI/gOBmMbTQgJ8j2vV6XS29dOnKwubmFwV8h
hPDMjflb911u+EhE3hzW0AzK5UlefOEMz595Fu/bdHseVclqpZrXTFAR0tRTevwEnXbK/Gdf0Gw2
n/789pfrcfamydkrVy5TjIs4QCxzNjW899RqvxFESNOAiqL5uaoiIogoqfcUCkUazSYhiEVRnA4k
iiJnIkq320Akk0hyAlUFM9SM1HtEBDXLziUnUCVJPE+o0unsoSobqsEP16BhZpVeL8Esc8oyyHpC
zRARfOIJIplN83tOkiQJVp5k/ddNut3unSTxyYBA1dppGggh0OvtAW4gQV+SIEqaeEQNs9w+JJH3
CQa0O3vsNtute6v3ikA3zodCc2HhDq+9+gqNxmrWdGK51jYI5H2KSNYn/eyybIU0FVSgXm+wtbW1
vrOz8xhAAaDVbn1bKpWqJ0+eeMpFjtQLIShpyDpbBIIYqg6IcESYRTgX4aICkYuJ4yLffb9Eo95c
+2np5w9F5CGQxAAb65ubW1vbl7/+5oev/u0MXlu7/76IrALtfSMzz6aY29zQSB3e9xtFAcuv4bMC
EIBOjvnv1x9cqSJ+BVI3zAAAAABJRU5ErkJggg==
}] -compound top \
-command {
if {[set F [tk_getOpenFile]] ne {}} {
set fid [open $F r]
[%MW text path] delete 0.0 end
%MW text do insert end [read $fid]
}
}]\
]\
]\
]\
\
[my widget ttk::separator \
[my options -orient h]\
[my pack -expand 0 -fill x]]\
\
[my widget frame \
[my pack -padx 5 -pady {5 0}]\
[my > \
[my widget stext\
[my options -yscrollcommand {%MW sy do set} -xscrollcommand {%MW sx do set}]\
[my handler text]\
]\
[my widget scrollbar \
[my handler sy]\
[my options -orient v -command {%MW text do yview}]\
[my pack -expand 0 -fill y]\
]\
]\
]\
\
[my widget scrollbar \
[my options -orient h -command {%MW text do xview}]\
[my pack -expand 0 -fill x -padx 5 -pady {0 5}]\
[my handler sx]\
]\
}
megawidget create editor $Tree
editor .edit
.edit toolbar add {
my widget ttk::separator \
[my options -orient v]\
[my pack -expand 0 -fill y -padx 5]
}
.edit toolbar add {
my widget ttk::button \
[my handler bSave]\
[my pack -ipadx 2 -ipady 5 -expand 0 -fill none]\
[my options \
-text "Save File" \
-image [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
WXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1gkHFy8F42t2TQAAAtpJREFUSMe1lktoFEEQhr/unpnd
mWRjVKJBEyQaFRVEMV4UQUEvgiCexXfQqyKCIsHHQcSDCiKCEREvIuhFRb0LHtSDHkQPAR9Bo0GN
uMluZna7PMzu7CZxIVlMwzDdRVN//fVXdTdM81AAndsv9BbCaD8o7s86XrezHT/PgSgxjr7R9+BY
N4ADUIiKe6+e3snA4BArRx/XDbD71waamxrU5ZtP9gEVAES077mcufKIzddu0diYmbLzbPYPtw7d
4fCBrSDost1JcqVg07oVAGit62KwvmsJVmSMrQpA8f7TDwAGBr8SFcJJO3YdjyAV8O7DD9asXPRv
ABSoWHMWtHVMOfrBwW+gFHYsgQqAVgqlYgBjnPpKUlEboLwB4MPnPkbD/KQdp7w0aTeNUgqppQFU
GHR2LJ1y9P39H2OAUpqTzJQngiQM6u5aRW0GIqCUTqKpZ2ilsOMYJABFgZY5s9h1/hmVIASRmB1S
CWTMumrePHtGbQbWCm3trbS1t5YclZyLYEXitRUE4n+1vWqvqFoMSvU19PYh2c+vJ5eTmcvJNq0C
AeMYGjI+kKnBoEQt2/+Gkz0nCPxGXNfFczxc18V1XAShUCxSLBQZ+j1ET08Pnau3JeIOfP+F1OoD
aytJ9tMBb96+4s7te8nGs2fPkM/nyOVzjIYhc1taEbFxY1mhMXBJpdyJwlcYVIzGOPhpP2a0cA8A
URQSlr8wxIotHYwKbRS+5/yzinS1BrokkGMM6VQAQOvcZoDEcRhGOI5JqkVrjdEG3zNorcp32ESA
/u+/WTIvM5HB80sxQBhHL2JJeankYNRaobXGcw1aa8ZJEGtgFAev3Hx6sXvnliAGMCxetIze6zeI
ooj8aI6R3AjDw8OAYLRJ7ox5M30sQlPg0jLDp1gUUMqOuZMB2jceOWqClgtrMy+n1L0v/nSNPzDE
SP5u3+NT+4CR6oTNBxr+02PCAl+Akel+tfAX6lA0Aw08di8AAAAASUVORK5CYII=
}] -compound top \
-command {
}]\
}
.edit toolbar add {
my widget ttk::button \
[my handler bSaveAs]\
[my pack -ipadx 2 -ipady 5 -expand 0 -fill none]\
[my options \
-text "Save File As" \
-image [image create photo -data {
iVBORw0KGgoAAAANSUhEUgAAABgAAAAYCAYAAADgdz34AAAABmJLR0QA/wD/AP+gvaeTAAAACXBI
WXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1gkHFy81xbJG4QAAA4ZJREFUSMe1ll9oHFUUxn/33pnd
zCabJjExoSaCtqZUodh/LxVFxT5YLIovCqYxTZuq1P+IWNFg2kKQCFqoErDNEgxShPiiUgWfoiJY
FQ1SLVJt00VqY9Mt3WQ3s9l7fJjN7G62K1XshWHmXs583/nOOfeeC1d5KICVDwwdWvBzO0DxYdOe
/wz24MwgiBLj6MMnP3qxD8ABWMjlt78z0MXZ6RRr5o9eEdjk+AQAHRtX0Xh9KwCPXridhvpadSDx
aS9QJEBEexGXvQc/4Z7hUerq4v8IfurpZla9BNFf72ByfAKz7SvS6UuMPn6E53ZuAUEv2jphrBTc
tekWALTWVcF/e7IpBJ//ZqLM/rYNnViRMvsSAsWJqfMAPPHMs2zvfrgCvDmxpQz8xBmYXdvFrt1P
8cbgfn45dZ71a1ZcngAFKsg5I8PDFeA/98UqwJvvf5XV9+1hFJie/hOUwpYLKBJopVAqIDDGKTP6
qTdSAd6+M0HDpkcQkfA/pahOsGgA0LOrj55tDxVDQzl4ausB/sq3whefIyKMJN5naHA/SimkWg6g
qGBsJBGu/tCtWTcGu3NZdrjQOXCM2A3rC8UXeL/57ntJJk8HBIUwVxAIEiooHevG4Psu6Bx4OwQu
LYylEaiqQASUCsotmTwdGkxN/Q7ADDBTsg5grS0raa0UtpqCvEDLtU10v/4lRScEkUAdUnSkbF7y
3XDNsuoKrBXaO9po72gL4ysSvK1IMLeCQPAuXS+xFVVNQaG+Usc/Jn3mxys73RpvJl1/KwgYx1Ab
94B4FQUFaenkJK/0v0zMq8N1XSJOBNd1cR0XQVjI58kv5EldTNHf38/KtVvD5J49dwGptg+sLQbZ
q4kxefw7jrw3Hhru27eXbDZDJpth3vdpbWlDxAYbywp1MZdo1K0QqYsKiovGOHg1XqDoxh4Acjkf
f/HxfazYwkGn0EbhRZzLVpEuzYEuJMgxhppoDIC21gaAENj3cziOCatFa43RBi9i0Fot9rBKguS5
i3Quj1cq+PqtgMAPvBexRCPR8GDUWqG1JuIatNYsSUGQA6N47GDiszf7ujbHAgLDTStWc+jdw+Ry
ObLzGeYyc8zOzgKC0SbcYMsbPSxCfcylZZlHPi+glC3ryQAddz7/gom1DG2Mf/uv+vCxSxuWtnkx
kv3g5NHXeoG50oBdB9T+T5cJC/wBzF3tWwt/A+V/iLv19HhJAAAAAElFTkSuQmCC
}] -compound top \
-command {
}]\
}
# Configure the margins
.edit text do margin configure number -visible yes -background gray
.edit text do margin configure fold -visible yes -foreground gray60 -activeforeground blue
# Set the lexer
.edit text do lexer set tcl
# Set lists of keywords (from 1 to 9)
.edit text do lexer keywords 1 { puts set return }
.edit text do lexer keywords 2 { proc }
# Configure the tags used by the lexer
.edit text do tag configure keyword1 -font {Times -16 bold}
.edit text do tag configure keyword2 -font {Helvetica -16 bold} -foreground blue
.edit text do tag configure string -foreground #7F007F
.edit text do tag configure commentline -foreground #007F00
# Configure the tags used for brace-matching
.edit text do tag configure bracelight -background gray80
.edit text do tag configure bracebad -background #dd0000
if 0 {Explanations: A nested list is created
- The v method initiate a -side top pack algorithm - A frame widget is create, whose handler is "toolbar". It contains a method add and has several specific pack options. - The > method initiate a -side left pack algorithm. Since the script is appended to the toolbar widget, next widgets will be children of the toolbar. - In this toolbar are created two button, named bNew and bOpen with some specifics options. - Under the toolbar is created a separator. - Under the separator is created a frame. - In this frame, the > method initiate a -side left pack algorithm, then an stext widget, named text, and a scrollbar widget, named sy, are created. - finaly a scrollbar, named sx, is created.
To be note :
- %MW is substituted with the name of the megawidget - %O is substituted with the name of the object - To call a widget command, it must be prefixed by the word "do" (to avoid names colisions) eg : %MW text do yview
Comment about the add method : It use the childListIndex class method, which give the index of the child widget list. Knowing this index, it is possible to get the child widget list. The evaluate class method is use to translate the megacode in a megawidget encoded nested list. This encoded list is append to the child widget list. Then, the megawidget tree is updated at the index of the child widget list. Finaly, the object update the megawidget.
So, after the creation of the megawidget, a separator, and 2 buttons are added to the toolbar.
The end is to show how do some extra configurations.
another example :
A multi-listbox
}
set Tree {
my > \
[set L {}; if {![info exist $NbCols]} {set NbCols 3}; for {set i 0} {$i < $NbCols} {incr i} {
lappend L [my widget frame \
[my pack \
-padx [expr {$i == 0 ? [list 5 1] : ($i == $NbCols-1) ? [list 1 5] : "1"}] \
-pady 5 -expand 0]\
[my v \
[my widget label \
[my options -relief groove] \
[my handler title$i \
[my methods \
sort {} {
}\
]\
]\
[my pack -expand 0 -fill x -padx 1 -anchor center]\
[my bind \
<ButtonPress-1> {
[%MW %W handler] sort
}]\
]\
[my widget listbox \
[my options -exportselection 0 -selectbackground GoldenRod4]\
[my handler column$i \
[my methods \
href {url} {
exec -- {c:/Program Files/Mozilla Firefox/firefox.exe} \
[regsub %% {https://wiki.tcl-lang.org/_/search?S=%%&_charset_=UTF-8} $url] &
}]\
]\
[my pack -padx 3]\
[my bind \
<<ListboxSelect>> {
set index [%W curselection]
set NumCol [%MW %W handler]
for {set i 0} {$i<$NbCols} {incr i} {
if {"column$i" eq $NumCol} continue
%MW column$i do selection clear 0 end
%MW column$i do selection set $index
}
} \
<MouseWheel> {
set NumCol [%MW %W handler]
for {set i 0} {$i<$NbCols} {incr i} {
if {"column$i" eq $NumCol} continue
%MW column$i do yview scroll [expr -%D/30] units
}
}\
<Double-1> {
set NumCol [%MW %W handler]
%MW $NumCol href [%MW column0 do get [%MW column0 do curselection]]
}]\
]\
]\
]\
}]\
{*}$L \
}
set NbCols 3
megawidget create MultiListBox $Tree
MultiListBox .mlb
.mlb title0 config -text "Commande" -width 15 -font [set Font [font create -family helvetica -size 12 -weight bold]]
.mlb title1 config -text "Catégorie" -width 25 -font [set Font]
.mlb title2 config -text "Description" -font [set Font]
pack conf [winfo parent [.mlb title2 path]] -expand 1
.mlb column[set i 0] config -font [set Font [font create -family Arial -size 12]]
.mlb column[incr i] config -font [set Font]
.mlb column[incr i] config -font [set Font]
set data \
{
{{after} {Control Constructs} {Execute a command after a time delay}}
{{append} {Variables and Procedures} {Append to variable}}
{{array} {Variables and Procedures} {Manipulate array variables}}
{{bgerror} {Interpreter Routines} {Command invoked to process background errors}}
{{binary} {String Handling} {Insert and extract fields from binary strings}}
{{break} {Control Constructs} {Abort looping command}}
{{catch} {Control Constructs} {Evaluate script and trap exceptional returns}}
{{cd} {System Related} {Change working directory}}
{{clock} {System Related} {Obtain and manipulate time}}
{{close} {Output} {Close an open channel.}}
{{concat} {List Handling} {Join lists together}}
{{continue} {Control Constructs} {Skip to the next iteration of a loop}}
{{dde} {Platform-specific} {Execute a Dynamic Data Exchange command}}
{{encoding} {Library Procedures} {Manipulate encodings}}
{{eof} {Output} {Check for end of file condition on channel}}
{{error} {Control Constructs} {Generate an error}}
{{eval} {Control Constructs} {Evaluate a Tcl script}}
{{exec} {System Related} {Invoke subprocess(es)}}
{{exit} {System Related} {End the application}}
{{expr} {Expr} {Evaluate an expression}}
{{fblocked} {Output} {Test whether the last input operation exhausted all available input}}
{{fconfigure} {Output} {Set and get options on a channel}}
{{fcopy} {Output} {Copy data from one channel to another.}}
{{file} {Output} {Manipulate file names and attributes}}
{{fileevent} {Output} {Execute a script when a channel becomes readable or writable}}
{{flush} {Output} {Flush buffered output for a channel}}
{{for} {Control Constructs} {``For'' loop}}
{{foreach} {Control Constructs} {Iterate over all elements in one or more lists}}
{{format} {String Handling} {Format a string in the style of sprintf}}
{{gets} {Output} {Read a line from a channel}}
{{glob} {System Related} {Return names of files that match patterns}}
{{global} {Variables and Procedures} {Access global variables}}
{{history} {Interpreter Routines} {Manipulate the history list}}
{{http} {Library Procedures} {Client-side implementation of the HTTP/1.0 protocol.}}
{{if} {Control Constructs} {Execute scripts conditionally}}
{{incr} {Variables and Procedures} {Increment the value of a variable}}
{{info} {Interpreter Routines} {Return information about the state of the Tcl interpreter}}
{{interp} {Interpreter Routines} {Create and manipulate Tcl interpreters}}
{{join} {List Handling} {Create a string by joining together list elements}}
{{lappend} {Variables and Procedures} {Append list elements onto a variable}}
{{lindex} {List Handling} {Retrieve an element from a list}}
{{linsert} {List Handling} {Insert elements into a list}}
{{list} {List Handling} {Create a list}}
{{llength} {List Handling} {Count the number of elements in a list}}
{{load} {Packages and Source files} {Load machine code and initialize new commands.}}
{{loadTk} {Packages and Source files} {Load Tk into a safe interpreter.}}
{{lrange} {List Handling} {Return one or more adjacent elements from a list}}
{{lreplace} {List Handling} {Replace elements in a list with new elements}}
{{lsearch} {List Handling} {See if a list contains a particular element}}
{{lset} {Variables and Procedures} {Change an element in a list}}
{{lsort} {List Handling} {Sort the elements of a list}}
{{memory} {Interpreter Routines} {Control Tcl memory debugging capabilities.}}
{{msgcat} {Library Procedures} {Tcl message catalog}}
{{namespace} {Variables and Procedures} {create and manipulate contexts for commands and variables}}
{{open} {Output} {Open a file-based or command pipeline channel}}
{{package} {Packages and Source files} {Facilities for package loading and version control}}
{{pid} {System Related} {Retrieve process id(s)}}
{{pkg::create} {Packages and Source files} {Construct an appropriate \fBpackage ifneeded\fR}}
{{pkg_mkIndex} {Packages and Source files} {Build an index for automatic loading of packages}}
{{proc} {Variables and Procedures} {Create a Tcl procedure}}
{{puts} {Output} {Write to a channel}}
{{pwd} {System Related} {Return the current working directory}}
{{re_syntax} {String Handling} {Syntax of Tcl regular expressions.}}
{{read} {Output} {Read from a channel}}
{{regexp} {String Handling} {Match a regular expression against a string}}
{{registry} {Platform-specific} {Manipulate the Windows registry}}
{{regsub} {String Handling} {Perform substitutions based on regular expression pattern matching}}
{{rename} {Variables and Procedures} {Rename or delete a command}}
{{resource} {Platform-specific} {Manipulate Macintosh resources}}
{{return} {Control Constructs} {Return from a procedure}}
{{scan} {String Handling} {Parse string using conversion specifiers in the style of sscanf}}
{{seek} {Output} {Change the access position for an open channel}}
{{set} {Variables and Procedures} {Read and write variables}}
{{socket} {Output} {Open a TCP network connection}}
{{source} {Packages and Source files} {Evaluate a file or resource as a Tcl script}}
{{split} {List Handling} {Split a string into a proper Tcl list}}
{{string} {String Handling} {Manipulate strings}}
{{subst} {String Handling} {Perform backslash, command, and variable substitutions}}
{{switch} {Control Constructs} {Evaluate one of several scripts, depending on a given value}}
{{tell} {Output} {Return current access position for an open channel}}
{{time} {System Related} {Time the execution of a script}}
{{trace} {Variables and Procedures} {Monitor variable accesses, command usages and command executions}}
{{unknown} {Interpreter Routines} {Handle attempts to use non-existent commands}}
{{unset} {Variables and Procedures} {Delete variables}}
{{update} {Control Constructs} {Process pending events and idle callbacks}}
{{uplevel} {Control Constructs} {Execute a script in a different stack frame}}
{{upvar} {Variables and Procedures} {Create link to variable in a different stack frame}}
{{variable} {Variables and Procedures} {create and initialize a namespace variable}}
{{vwait} {Control Constructs} {Process events until a variable is written}}
{{while} {Control Constructs} {Execute script repeatedly as long as a condition is met}}
}
foreach row $data {
foreach {c0 c1 c2} $row {
foreach i {0 1 2} {
.mlb column$i do insert end [set c$i]
}
}
}
}
if 0 {Comment : The process here consists to build a list of N columns, using a for loop, then return the list.
3rd example : An button list
}
package require megawidget
set Tree {
my v \
[my widget ttk::labelframe \
[my handler empileur \
[my methods \
update {args} {
%O updateFromScript
}]\
] \
[my options -text "Sommaire :"]\
[my pack -padx 10 -pady 10 -fill both]\
[my v \
[set L [list]
foreach {text command} $ButtonListe {
lappend L [my widget ttk::button \
[my options \
-text $text \
-command $command \
] \
[my pack -expand 0 -fill x -padx 10 -pady 2 -ipady 2]\
]\
}]\
{*}$L\
]\
]\
[my widget frame \
[my pack -expand 0 -fill x -anchor e]\
[my > \
[my widget ttk::button \
{*}[# Button to add a button at the bottom of the list of bottom \
(Comments are also possibles !)
]\
[my pack -expand 0 -fill none -padx 20 \
-pady {3 5} -anchor e]\
[my options -text ajouter \
-command {
if {[winfo exist .top]} return
toplevel .top
wm title .top "Ajouter un bouton"
catch {
megawidget create Saisie {
my v \
[my widget ttk::frame \
[my pack -expand 1 -fill x -padx 5 -pady 5] \
[my > \
[my widget ttk::label \
[my pack -expand 0 -fill none -padx 5 -pady 5] \
[my options -text {Texte sur le button :}]\
]\
[my widget ttk::entry \
[my handler Name]\
]\
]]\
[my widget ttk::labelframe \
[my handler script]\
[my pack -expand 1 -fill x -padx 5 -pady 5] \
[my options -text "Commande"]\
[my > \
[my widget text \
[my handler Script] \
[my pack -expand 1 -fill x -padx 5 -pady 5] \
[my bind \
<Control-Return> {%%MW OK do invoke} \
<KeyPress-Escape> {focus [%%MW Name path]}
]\
]\
]\
]\
[my widget ttk::frame \
[my pack -expand 0 -fill none -anchor center -padx 5 -pady 15] \
[my > \
[my widget ttk::button \
[my handler OK]\
[my options -text {OK} -command {
lappend ::ButtonListe [%%MW Name do get] [%%MW Script do get 0.0 end]
}]\
[my pack -padx 20] \
]\
[my widget ttk::button \
[my handler Quit]\
[my options -text {Quitter} -command {
trace remove variable ::ButtonListe write {%%MW empileur update}
destroy .top
}]\
[my pack -padx 20]
]\
]]\
}
}
Saisie .top.dial
trace add variable ::ButtonListe write {%MW empileur update}
}]\
]\
]\
]
}
set ButtonListe [dict create hello {puts hello} hello2 {puts hello2}]
megawidget create Empileur $Tree
Empileur .empil
if 0 {Comment :
%%MW or %%O are substituted with %MW and %O, so it's possible to create a megawidget in a megawidget.
Temporary conclusion :
This package is far from completness and very experimental. But, I think it shows the possibilities of pseudo-type properties of nested list. The encoding give the ability to have hardly a full substitution behaviour. But the number of type is limited by the number of nested list types (and in some case, ambiguities are possible, for instance between 2 nl4 lists with less than 3 members).
In fact, as far as I see it now, this is mainly a work around the lack of type in Tcl. I don't speak about "hardware" types (int, char, ...), but "logical" type, that the programmer can use.
To get a similar behaviour, without using nested lists, it should exist a "user type", configurable by the programmer, as a new field in Tcl_Obj, completly independant of the internal representation, with some persistence, like "tags" on list elements.
I would like also a command :
interp convention variable InterPath prefix LogicalType,
so it should be possible for the programmer, to set up some variable named conventions at the beginning of the script, in relation with logical type, automatically assigned by the interpreter (and of course, the interpreter can test the user type of a variable).
for example :
interp convention variable {} \
poly* polygon \
line* line
pack [canvas .c]
set poly000 [list {*}$cords0]
set line000 [list {*}$cords1]
set E [list $poly000 $line000]
proc draw {L} {
foreach e $L {
.c create [info type $e] $e
}
}
draw $E
Comments welcome.
}