[Flame] Searching the wiki I have not found any code implementing modern interface, which is sometimes called 'docking framework'.
The idea is that user can configure the layout of the frames within a window, embed windows in tabs etc. like it is done in IDEs.
Here is some code I've written that implements this functionality based on two Tile widgets panedwindow and notebook.
User can drag tabs from one notebook to another, or place tabs aside the existing notebook. Mid-button "undocks" tab into a separate window; closing that window tries to place tab back, if the notebook still exists, or adds the tab to some other notebook.
----
[KPV] Isn't this what's knowns as a window manager inside a window manager?
----
======
# DockingFramework
# published under BSD license
package require Ttk
namespace eval DockingFramework {
# tbs(tab_path)=panedwindow
# tbs(panedwindow_path)=parent_panedwindow
# tbs(path,path)=tab_path
variable tbs
variable tbcnt 0
# find notebook, corresponding to path
proc find_tbn {path} {
variable tbs
if {$path==""} { return "" }
set top [winfo toplevel $path]
while {$path!=$top} {
if {[info exists tbs($path,path)]} {
return $tbs($path,path)
}
if {[info exists tbs($path)]} {
return $path
}
set path [winfo parent $path]
}
return {}
}
proc replace_tbn_with_pw {tbn anchor} {
variable tbs
variable tbcnt
set pw $tbs($tbn)
if {$tbn!=""} {
set index [lsearch -exact [$pw panes] $tbn]
}
if {$anchor=="w" || $anchor=="e"} {
set orient "horizontal"
} else {
set orient "vertical"
}
set npw [ttk::panedwindow [winfo toplevel $pw].pw$tbcnt -orient $orient]
incr tbcnt
set tbs($tbn) $npw
if {$tbn==""} { # toplevel
set grid_options [grid info $pw]
grid forget $pw
eval grid $npw $grid_options
set tbn $pw
set tbs($pw) $npw
set tbs($npw) {}
} else {
$pw insert $index $npw -weight 1
$pw forget $tbn
set tbs($npw) $pw
}
set ntb [ttk::notebook [winfo toplevel $pw].tb$tbcnt]
incr tbcnt
set tbs($ntb) $npw
if {$anchor=="s" || $anchor=="e"} {
$npw add $tbn -weight 1
$npw add $ntb -weight 1
} else {
$npw add $ntb -weight 1
$npw add $tbn -weight 1
}
_raise_tree $tbn
_raise_tree $ntb
if {[get_class $tbn]=="TPanedwindow"} {
_cleanup_pws $tbn
}
return $ntb
}
proc _raise_tree {path} {
raise $path
switch -exact [get_class $path] {
TPanedwindow {
foreach pane [$path panes] {
_raise_tree $pane
}
}
TNotebook {
foreach tab [$path tabs] {
raise $tab
}
}
}
}
# add a new notebook to the side anchor of the notebook tbn
proc add_tbn {tbn anchor} {
variable tbs
variable tbcnt
set pw $tbs($tbn)
set orient [$pw cget -orient]
if {$anchor=="t"} {
if {$tbn!=""} {
return $tbn
} else {
set anchor [expr {$orient=="horizontal" ? "e" : "s"}]
}
}
# if orientation of the uplevel panedwindow is consistent with anchor, just add the pane
if { ( $orient=="horizontal" && ($anchor=="w" || $anchor=="e") ) ||
( $orient=="vertical" && ($anchor=="n" || $anchor=="s") ) } {
if {$tbn==""} {
if {$anchor=="e" || $anchor=="s"} {
set i [llength [$pw panes]]
} else {
set i 0
}
} else {
set i [lsearch -exact [$pw panes] $tbn]
if {$anchor=="e" || $anchor=="s"} { incr i }
}
set tbn [ttk::notebook [winfo toplevel $pw].tb$tbcnt]
incr tbcnt
set tbs($tbn) $pw
if {$i>=[llength [$pw panes]] || $i<0} {
$pw add $tbn -weight 1
} else {
$pw insert $i $tbn -weight 1
}
_raise_tree $tbn
} else {
set tbn [replace_tbn_with_pw $tbn $anchor]
}
return $tbn
}
proc get_class {path} { return [lindex [bindtags $path] 1] }
proc get_anchor {path x y} {
variable tbs
set tb [find_tbn $path]
set rev {}
if {$tb==""} {
set tb $tbs()
set rev -
}
set w [winfo width $tb]
set h [winfo height $tb]
set x [expr $x-[winfo rootx $tb]]
set y [expr $y-[winfo rooty $tb]]
set in_bbox [expr {(($x>=0 && $y>=0 && $x<=$w && $y<=$h) ? 1 : 0)}]
if {($rev=="" && !$in_bbox) || ($rev!="" && $in_bbox)} {
return {}
}
if {[$tb identify [expr $x-[winfo rootx $tb]] [expr $y-[winfo rooty $tb]]]!=""} {
set anchor "t"
} elseif {$x>=[expr $w/3] && $x<=[expr $w*2/3] && $y>=[expr $h/3] && $y<=[expr $h*2/3]} {
set anchor "t"
} else {
# determine the closest side to the cursor
set side 1
set rdist 1e6
foreach {x0 y0} {0 0 0 0 $w 0 0 $h} a {w n e s} {
set dist [expr abs($x-$x0)*$side+abs($y-$y0)*(1-$side)]
set side [expr 1-$side]
if {$dist<$rdist} {
set rdist $dist
set anchor $a
}
}
}
set rev {}
if {$x<0 || $y<0 || $x>$w || $y>$h} {
set rev -
}
array set cursors {
s bottom_side
w left_side
e right_side
n top_side
t based_arrow_down
{} {}
-s top_side
-w right_side
-e left_side
-n bottom_side
-t {}
}
return [list $anchor $cursors($rev$anchor)]
}
proc _cleanup_pws {pw} {
variable tbs
while {$pw!=$tbs() && [$pw panes]==""} {
destroy $pw
set npw $tbs($pw)
unset tbs($pw)
set pw $npw
}
}
proc _cleanup_tabs {srctab} {
variable tbs
if {[llength [$srctab tabs]]==0} {
destroy $srctab
_cleanup_pws $tbs($srctab)
unset tbs($srctab)
}
}
proc move_tab {srctab dsttab} {
variable tbs
# move tab
set f [$srctab select]
set o [$srctab tab $f]
$srctab forget $f
eval $dsttab add $f $o
raise $f
$dsttab select $f
_cleanup_tabs $srctab
set tbs($f,path) $dsttab
}
variable c_path {}
variable s_cursor {}
proc start_motion {path} {
variable c_path
variable s_cursor
if {$path!=$c_path} {
set c_path [find_tbn $path]
if {$c_path=="" || [get_class $c_path]!="TNotebook" || [llength [$c_path tabs]]==0} {
set c_path {}
return
}
set s_cursor [$c_path cget -cursor]
}
}
proc motion {x y} {
variable c_path
variable s_cursor
if {$c_path!=""} {
set path [winfo containing $x $y]
if {$path==$c_path} {
$c_path configure -cursor $s_cursor
} else {
$c_path configure -cursor [lindex [get_anchor $path $x $y] 1]
}
}
}
proc end_motion {x y} {
variable c_path
variable s_cursor
if {$c_path==""} { return }
set path [winfo containing $x $y]
set anchor [lindex [get_anchor $path $x $y] 0]
$c_path configure -cursor $s_cursor
set tbn [find_tbn $path]
if {$tbn!=$c_path || ($path!=$c_path && $anchor!="t")} {
if {$anchor=="t"} {
move_tab $c_path $tbn
} else {
move_tab $c_path [add_tbn $tbn $anchor]
}
}
set c_path {}
}
bind TNotebook <Button-1> +[namespace code {start_motion %W}]
bind TNotebook <B1-Motion> +[namespace code {motion %X %Y}]
bind TNotebook <ButtonRelease-1> +[namespace code {end_motion %X %Y}]
proc undock_tab {tab} {
variable tbs
set tbn $tbs($tab,path)
set name [$tbn tab $tab -text]
set opts [$tbn tab $tab]
unset tbs($tab,path)
set tbs($tab,undocked) [list $tbn $opts]
$tbn forget $tab
_cleanup_tabs $tbn
wm manage $tab
catch {wm attributes $tab -toolwindow 1}
wm title $tab $name
wm protocol $tab WM_DELETE_WINDOW [namespace code [list __dock $tab]]
wm deiconify $tab
}
proc __dock {wnd} {
variable tbs
wm withdraw $wnd
wm forget $wnd
set tbn [lindex $tbs($wnd,undocked) 0]
set opts [lindex $tbs($wnd,undocked) 1]
unset tbs($wnd,undocked)
if {![winfo exists $tbn]} {
if {[$tbs() panes]==""} {
set tbn [add_tbn {} t]
} else {
foreach tbn [array names tbs] {
if {[winfo exists $tbn] && [get_class $tbn]=="TNotebook"} { break }
}
}
}
eval $tbn add $wnd $opts
set tbs($wnd,path) $tbn
raise $wnd
}
proc __undock_tab {wnd} {
set tbn [find_tbn $wnd]
if {$tbn=="" || [$tbn select]==""} { return }
undock_tab [$tbn select]
}
proc __hide_tab {wnd} {
set tbn [find_tbn $wnd]
if {$tbn=="" || [$tbn select]==""} { return }
hide_tab [$tbn select]
}
proc is_managed_tab {wnd} {
if {[find_tbn $wnd]==""} { return 0 } else { return 1 }
}
proc create_framework {path} {
variable tbs
variable tbcnt
set npw [ttk::panedwindow [winfo toplevel $path].pw$tbcnt -orient vertical]
incr tbcnt
set tbs($npw) {}
set tbs() $npw
grid $npw -in $path -sticky news
grid columnconfigure $path 0 -weight 1
grid rowconfigure $path 0 -weight 1
}
proc add_tab {tab path anchor args} {
variable tbs
if {$anchor=="t" && $path==""} {
set anchor "e"
} elseif {$anchor=="t"} {
set tbn $tbs($path,path)
} else {
set tbn [add_tbn [find_tbn $path] $anchor]
}
eval [list $tbn add $tab] $args
set tbs($tab,path) $tbn
raise $tab
}
proc remove_tab {path} {
variable tbs
set tb [find_tbn $path]
if {$tb=="" || [get_class $tb]!="TNotebook"} {
error "window $path is not managed by the framework"
}
catch {$tb forget $path}
unset tbs($path,path)
_cleanup_tabs $tb
}
proc select_tab {path} {
set tb [find_tbn $path]
if {$tb=="" || [get_class $tb]!="TNotebook"} {
error "window $path is not managed by the framework"
}
$tb select $path
}
proc hide_tab {path} {
variable tbs
set tb [find_tbn $path]
if {$tb=="" || [get_class $tb]!="TNotebook"} {
error "window $path is not managed by the framework"
}
$tb hide $path
}
proc show_tab {path} {
set tb [find_tbn $path]
if {$tb=="" || [get_class $tb]!="TNotebook"} {
error -code "window $path is not managed by the framework"
}
$tb add $path
}
proc get_managed_windows {} {
variable tbs
set res {}
foreach t [array names tbs *,path] {
lappend res [string range $t 0 end-5]
}
return $res
}
proc serialize_widget {path} {
variable tbs
set class [get_class $path]
upvar script script
upvar sashscript sashscript
if {[info exists tbs($path)]} {
switch $class {
TNotebook {
append script "ttk::notebook $path\n"
foreach tab [$path tabs] {
serialize_widget $tab
append script "$path add $tab [$path tab $tab]\n"
append script "raise $tab\n"
append script "$path select $tab\n"
}
append script "$path select [list [$path select]]\n"
}
TPanedwindow {
append script "ttk::panedwindow $path -orient [$path cget -orient]\n"
if {$path==$tbs()} {
append script "eval grid \$tbs() \$tbs(grid_options)\n"
}
set i 0
append sashscript "tkwait visibility $path\n"
foreach pane [$path panes] {
serialize_widget $pane
append script "$path add $pane [$path pane $pane]\n"
if {$i>0} {
append sashscript "$path sashpos [expr $i-1] [$path sashpos [expr $i-1]]\n"
}
incr i
}
}
default {
error "serialization is not supported for the class $class"
}
}
} else {
catch {::serialize $path}
}
}
proc serialize {} {
variable tbs
variable tbcnt
set top [winfo toplevel $tbs()]
set script "namespace eval ::DockingFramework \{\n"
append script "if {\[\$tbs() panes]!=\"\"} { error \"Trying to overwrite existing layout\" }\n"
append script "set tbs(grid_options) \[grid info \$tbs()\]\n"
append script "destroy \$tbs()\n"
append script "unset tbs(\$tbs())\n"
append script "array set tbs [list [array get tbs]]\n"
append script "set tbcnt $tbcnt\n"
append script "wm geometry $top [wm geometry $top]\n"
set sashscript ""
serialize_widget $tbs()
append script $sashscript
foreach w [array names tbs *,undocked] {
set w [string range $w 0 end-[string length ",undocked"]]
append cmd "wm manage $w\n"
append cmd "catch {wm attributes $w -toolwindow 1}\n"
append cmd "wm title $w [list [wm title $w]]\n"
append cmd "wm protocol $w WM_DELETE_WINDOW \[namespace code \[list __dock $w\]\]\n"
append cmd "wm deiconify $w\n"
append cmd "wm geometry $w [wm geometry w]\n"
}
append script "\}\n"
return $script
}
}
if {1} {
toplevel .t1
pack [frame .t1.df] -fill both -expand true
pack [frame .t1.bc] -fill x
DockingFramework::create_framework .t1.df
for {set i 0} {$i<8} {incr i} {
set ntab [label .t1.lb$i -text "notebook $i" -borderwidth 10]
DockingFramework::add_tab $ntab {} e -text "tab $i"
}
pack [button .t1.bc.sl -text " Save layout " -command save_l] -side left -padx 4
pack [button .t1.bc.ll -text " Load layout " -command load_l] -side left -padx 4
pack [button .t1.bc.qq -text " Quit " -command exit] -side right -padx 8 -pady 4
proc save_l {} {
variable layout
set layout [DockingFramework::serialize]
puts "layout: \n$layout"
}
proc load_l {} {
variable layout
if {![info exists layout]} { error "Save layout before loading" }
foreach w [array names DockingFramework::tbs] {
catch {destroy $w}
}
array set DockingFramework::tbs {}
DockingFramework::create_framework .t1.df
eval $layout
}
wm withdraw .
}
======
----
[UKo] 2008-11-09: Added a `package require Tk` to use this code with ''tclkit'' and deleted all trailing whitespaces. Thanks for this nice example!
----
[Flame] 2009-03-08: Updated the code with some bugfixes, now it can save and load the layout.
----
!!!!!!
%| [Category Un<<categorized]s>> |%
!!!!!!GUI