############################################
 #
 # tearofftabbar.tcl
 # ------------------------
 #
 # Copyright (C) 2005 William J Giddings
 # email: [email protected]
 #
 ############################################
 #
 # Description:
 # -----------
 # Provide a horizontal notebook tab-bar megawidget that allows
 # floating palettes to appear rather than book pages. Conceptually
 # this is similar to a standard menu button but the author
 # is now able to embed other resources into the palette.
 #
 # Creation:
 # --------
 # TearoffTabBar pathName ?option value...?
 #
 # Standard Options:
 # ----------------
 # -relief            (default = flat)
 # -borderwidth       (default = 0)
 #
 # Widget Specific Options:
 # -----------------------
 # -lbevel             Tab left bevel (default = 2)
 # -rbevel             Tab right bevel (default = 2)
 # -font               Tab font (default = Ariel 10)
 # -height             Set base tab height (default = 20)
 # -width              Set base tab width (default = 75)
 # -shift              Set rise/drop of tags (default = +/-3)
 #
 # Returns:
 # --------
 # Pathname of the tabbar container.
 #
 # Widget Commands:
 # --------
 # pathName add        Add new tab to the bar. Returns pathname of the palette created.
 # pathName raisetab   Raise tab to topmost position.
 # pathName lowertab   Lowet tab.
 #
 # Bindings:
 # -----------------------------------#
 # Tab                 Button-1    Raise tab and show palette. Lower previously selected tab.
 # Palette             Focus-In    Raise associated tab.
 #
 # Example:
 # -------
 # This module includes a demo proceedure. Delete and/or comment out as required.
 #
 # Note:
 # ----
 # Work still in progress.
 #
 # Future enhancements:
 # -------------------
 # 1) Improve/complete this notes section.
 # 2) Combine with floating-palettes.
 # 4) Means of tracking available palettes per tabbar widget.
 #
 ############################################

 package require Tk

 namespace eval TearoffTabBar {}

 proc TearoffTabBar { pathName args} {
     #-------
     # create private namespace and set defaults
     #-------
     namespace eval ${pathName} {
         set height 20
         set width 75
         set relief flat
         set borderwidth 0
         set font {Ariel 10}
         set tabbg SystemButtonFace
         set tabhighlight #ddddcc
         set lbevel 2          ;# tab drawing parameter
         set rbevel 15
     set shift 3
     set image ""
     set lastx 0           ;# mouse inpt
     set lasty 0
     set lasttab ""        ;# hide/lower previous items
     set tabmin_x ""        ;# used in testing during dragging the tab in the tabbar
     set tabmax_x ""
 }
 #-------
 # parse args
 #-------
 foreach {arg val} $args {
     puts "$arg : $val"
     switch -- $arg {
         -height -
         -relief -
         -borderwidth -
         -lbevel -
         -rbevel -
         -font { set ${pathName}::[string trimleft $arg -] $val }
     }
 }
 #-------
 # create container
 #-------
 canvas $pathName \
     -height [set ${pathName}::height] \
     -relief [set ${pathName}::relief] \
     -borderwidth [set ${pathName}::borderwidth]
 #-------
 # Here comes the overloaded widget proc:
 #-------
 rename $pathName _$pathName      ;# keep the original widget command
 proc $pathName {cmd args} {
     set self [lindex [info level 0] 0] ;# get name I was called with
     switch -- $cmd {
         add          {eval TearoffTabBar::add $self $args}
         raisetab     {eval TearoffTabBar::raisetab $self $args}
         lowertab     {eval TearoffTabBar::lowertab $self $args}
         default      {uplevel 1 _$self $cmd $args}
     }
 }
 return $pathName
 }
 #-------
 # add new items to the bar
 #-------
 # currently creating tab at disired location, this perhaps causing problems
 # create tab, then move to xpos

 proc TearoffTabBar::add {pathName args} {
 #-------
 # set some defaults
 #-------
 set xpos 1
 set height [set ${pathName}::height]
 set width 75
 set title "NEW"
 set font {Ariel 10}
 set tabbg SystemButtonFace
 set image ""
 set palettewidth 100
 set paletteheight 150
 #-------
 # parse args
 #-------
 foreach {arg val} $args {
     switch -- $arg {
         -tag -
         -xpos -
         -height -
         -width -
         -title -
         -image -
         -font  { set [string trimleft $arg -] $val}
         -tabbg -
         -palettewidth -
         -paletteheight -
         -tabbackground { set tabbg $val}
     }
 }
 #-------
 # add local vars, make this easier to read
 #-------
 set lbevel [set ${pathName}::lbevel]
 set rbevel [set ${pathName}::rbevel]
 #-------
 # draw the tab
 #-------
 set tmp $xpos
 set xpos 0
 # 1) background polygon
 $pathName create polygon \
     0 $height 0 $lbevel \
     0 $lbevel $lbevel 0 \
     $lbevel 0 [expr $width - $rbevel] 0 \
     [expr $width - $rbevel] 0 $width $rbevel \
     $width $height  \
     -fill  $tabbg \
     -outline $tabbg \
     -tag "$tag $tag.tab"
 #2) tab outline
 #2a) left line
 #
 #|
 #|
 #|
 $pathName create line \
     $xpos $height \
     $xpos $lbevel \
     -fill white \
     -tag $tag
 #2b) left bevel
 #/
 #|
 #|
 #|
 $pathName create line \
     $xpos $lbevel \
     [expr $xpos + $lbevel] 0 \
     -fill white \
     -tag $tag
 #2c) top line
 #/-------------
 #|
 #|
 #|
 $pathName create line \
     [expr $xpos + $lbevel] 0  \
     [expr $xpos + $width - $rbevel] 0 \
     -fill white \
     -tag $tag
 #2d) right bevel
 #/-------------\
 #|              \
 #|               \
 #|
 $pathName create line \
     [expr $xpos + $width - $rbevel] 0 \
     [expr $xpos + $width] $rbevel \
     -fill #888888 \
     -tag $tag
 #2e) right line
 #/-------------\
 #|              \
 #|               \
 #|                |
 $pathName create line \
         [expr $xpos + $width] $rbevel \
         [expr $xpos + $width] $height  \
         -fill #888888 \
         -tag $tag
 #3) add icon
 if {$image != "" } { \
     $pathName create image \
         [expr $xpos + 4] 11 \
         -image $image \
         -anchor w \
         -tag "$tag $tag.image"
 }
 # 4) add text
 $pathName create text \
     [expr $xpos + 22] 11 \
     -text $title \
     -anchor w \
     -font $font \
     -tag "$tag $tag.text"
 #---------
 # shuffle the tabs down
 # --------
 $pathName move $tag $tmp 2
 #---------
 # add bindings
 #---------
 #-------
 # select & raise tab
 #-------
 $pathName bind $tag <ButtonPress-1> {
    set tags [lindex [%W gettags current] 0]
    #hide previous palette
    if { [set %W::lasttab] != "" } {
         withdrawIfNeeded [string tolower .[set %W::lasttab]]
    }
    %W raise $tags
    %W raisetab $tags
    set %W::lasttab $tags
    set %W::lastx %x
    set %W::lasty %y
    update idletasks
    set %W::x %x
    #minmax %W
    #puts "$tags %x min [set %W::tabminx] max [set %W::tabmaxx]"
 }
 #-------
 # show palette
 #-------
 $pathName bind $tag <Double-ButtonPress-1> {
    #hide previous palette
    if { [set %W::lasttab] != "" } {
         withdrawIfNeeded [string tolower .[set %W::lasttab]]
    }
    %W raise [set %W::lasttab]
    %W raisetab [set %W::lasttab]
    TearoffTabBar::_placepalette %W
 }
 #-------
 # show palette, allow movement
 #-------
 $pathName bind $tag.image <Double-ButtonPress-1> {
     #hide previous palette
     if { [set %W::lasttab] != "" } {
         withdrawIfNeeded [string tolower .[set %W::lasttab]]
     }
     %W raise [set %W::lasttab]
     %W raisetab [set %W::lasttab]
     TearoffTabBar::_placepalette %W
     wm overrideredirect [string tolower .[set %W::lasttab]] 0
     [string tolower .[set %W::lasttab]].fra config -relief flat
     focus -force [string tolower .[set %W::lasttab]]
     %W move [set %W::lasttab] 0 20
 }

 #---------
 # drag tab to different location
 #---------
  $pathName bind $tag <Button1-Motion> {
      set tags [lindex [%W gettags current] 0]
      drag.canvas.item %W $tags %x -1
      #test to see if torn-ff
 }
 #-------
 # show palette
 #-------
 # $pathName bind $tag <ButtonRelease-1> {
    # wm deiconify [string tolower .[set %W::lasttab]]
    # #TearoffTabBar::_placepalette %W
    # set %W::lastx %x
    # set %W::lasty %y
 # }
 #-------
 # create palette
 #-------
 set title [string tolower $title]
 toplevel .$title
 wm transient .$title .
 wm title .$title "Palette: $title"
 wm protocol .$title WM_DELETE_WINDOW \
         "wm overrideredirect .$title 1
         wm withdraw .$title
         .$title.fra config -relief raised
         $pathName move [string totitle $title] 0 -20
         "
 wm withdraw .$title
 wm geometry .$title ${palettewidth}x${paletteheight}
 wm overrideredirect .$title 1
 bind .$title <FocusIn> ".ttb raisetab $title"
 return .$title
 }

 proc withdrawIfNeeded {w} {
     if {[wm overrideredirect $w] == 1} {
         #not for detached palettes
         wm withdraw $w
     }
 }

 proc drag.canvas.item {w item x y} {
     #test for locked axis, -1 = locked
     if {$x} {
         set dx [expr {$x - [set ${w}::lastx]}]
     } else  {
         set dx 0
     }
     if {$y} {
         set dy [expr {$y - [set ${w}::lasty]}]
     } else  {
         set dy 0
     }
     #test before moving
     if {[inside $w $item $dx $dy]} {
         puts inside
         $w move $item $dx $dy
     }
     set ${w}::lastx $x
     set ${w}::lasty $y
 }

 proc inside {w item dx dy} {
     #canvas extents
     set can(minx) 2
     set can(miny) 2
     set can(maxx) [expr [winfo width $w ] - 3 ]
     set can(maxy) [expr [winfo height $w ] - 0 ]
     #item coords
     set item [$w coords $item]
     #check min values
     foreach {x y} $item {
         set x [expr $x + $dx]
         set y [expr $y + $dy]
         if {$x < $can(minx)} {
             return 0
         }
         if {$y < $can(miny)} {
             return 0
         }
         if {$x > $can(maxx)} {
             return 0
         }
         if {$y > $can(maxy)} {
             return 0
         }
     }
     #puts $item
     return 1
 }

 #-------
 # move tag up 5 pixels
 #-------
 proc TearoffTabBar::raisetab {pathName tag} {
 catch {  $pathName lowertab [set ${pathName}::lasttab] }
 $pathName raise $tag
 $pathName move $tag 0 -[set ${pathName}::shift]
 set ${pathName}::lasttab $tag
 $pathName itemconfigure $tag.tab -fill [set ${pathName}::tabhighlight]
 }
 #-------
 # move tag down 5 pixels
 #-------
 proc TearoffTabBar::lowertab {pathName tag} {
 $pathName move $tag 0 [set ${pathName}::shift]
 $pathName lower $tag [set ${pathName}::lasttab]
 $pathName itemconfigure $tag.tab -fill [set ${pathName}::tabbg]
 }
 #-------
 # position palette window, called by tab bindings
 #-------
 proc TearoffTabBar::_placepalette {w} {
 set cc ""
 set aa [lindex [$w gettags current] 0 ]
 foreach item [$w coords $aa ] {
     set item [string trimright $item ".0"]
     lappend cc $item
 }
 set maxx 0
 foreach {x y} $cc {
     if {$x > $maxx} {
         set maxx $x
     }
 }
 set aa [string tolower $aa]
 wm geometry .$aa +[expr [winfo rootx $w] + $maxx -90]+[expr [winfo rooty $w]+25]
 wm deiconify .$aa
 update
 }
 ################################################################################
 # test block
 ################################################################################
 proc demo {} {
 pack [TearoffTabBar .ttb -rbevel 15] -fill x
 pack [text .txt -font {Ariel 12} ] -fill both -expand 1
 set x 5
 #-------
 # create some initial graphics
 #-------
 image create photo im_red -data R0lGODlhDAAMAJEAAP////8AAAAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw==
 image create photo im_green -data R0lGODlhDAAMAJEAAP///wD/AAAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw==
 image create photo im_blue -data R0lGODlhDAAMAJEAAP///wAA/wAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw==

  # Scotland Wales Ireland Eire
  foreach item {England Scotland Wales Ireland Eire} {
     .ttb add -title $item -font {Ariel 8} -xpos $x -width 90 -tag $item -image im_red
     .ttb lowertab $item
     incr x 75
     #add some palette widgets
     pack [frame .[string tolower $item].fra -height 150 -width 100 -relief raised -borderwidth 2] -fill both -expand 1
     pack [label .[string tolower $item].fra.lab1 -text $item -width 15 -borderwidth 2 -relief ridge]
     pack [label .[string tolower $item].fra.lab2 -text $item -width 15 -borderwidth 2 -relief ridge]
     pack [label .[string tolower $item].fra.lab3 -text $item -width 15 -borderwidth 2 -relief ridge]
  }
  .txt insert end \
  "Tearoff Tabbar.
  Click on a tab...
      Drag left/right to move.
      Double-Click for popup-palette.
      Double-Click icon for floating palette, tab will vanish.
      Close floating palette to restore tab."
 }
 demo

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References