Docking framework

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 Tk
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)
  if {$pw==""} {return {}}
  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) || $path==$tb} {
    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 {$anchor!="" && ($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.


thgr 2018-08-21: Thank you for this GUI gem! Updated the code to prevent errors when button release occurs on a panedwindow sash.


JJS 2019-07-16: This is the start of something good. I found that when loading a layout that actually requires the sashes to be positioned, that they weren't being positioned in spite of the commands being present. I fixed this by modifying the serialize_widget procedure to add this line after the "tkwait visibility" line:

        append sashscript "update idletasks\n"

That apparently allows the sashpos commands to actually take effect. I think delaying the sashpos commands as an "after idle" script works, too.