'''WJG''' Jan 16th 2005 -
If the TK bag of widget goodies lacks something, then for me its a pucker floating palette. Those of use who are familiar with the Photoshop toolbox will know what I mean. In some of my applications a lot of resources are open which have are usaually placed in a BWidget notebook packed conveniently to one side of the screen. Even with the luxury of using a large monitor in high resoluiton just for parallel text editing, still, I crave more screen space for that text and less for those ever handy resources. Hence I've polished up this code for a floating palette. Next step, tear-off tabs!

----

 ############################################ 
 #
 # Palette.tcl
 # ------------------------
 # 
 # Copyright (C) 2005 William J Giddings
 # email: giddings@freeuk.com
 # 
 ############################################ 
 # 
 # Description:
 # -----------
 # Provide a genuine floating tool palette. The overall appearance was intended to blend in
 # with the look and feel of Windows 2000. As the code is not arcane relatively easy to follow,
 # interested users may need to modify values and settings to suit other platforms. 
 # 
 # Creation:
 # --------
 # Palette pathName ?option value...?  
 #
 # Standard Options:
 # ---------------- 
 #
 # Widget Specific Options:
 # -----------------------
 #
 # -exitcmd                       Command to be executed when palette withrawn.
 # -xpos                          Initial screen x-coordinate at which to create palette.
 # -ypos                          Initial screen y-coordinate at which to create palette.
 # -titlebackground / -titlebg    Colour for titlebar background.
 # -width                         Overall width of the palette.
 # -height                        Overall height of the palette including titlebar.
 # -image                         Custom graphic to show in left side of the titlebar. (16x16 pixels)
 #
 # Returns:                       Pathname of the Palette container.
 # --------                       
 #
 # Widget Commands:
 # --------
 # pathName getframe              Return pathname of the Palette container.
 # pathName gettitle              Return pathname of the titlebar container.  
 # pathName title <string>        Set the palette title to a new value.
 # pathName icon <image>          Change title graphic to new image.
 #
 # Bindings:
 # -----------------------------------
 # Whilst this Megawidget is purely 100% Tk code, especial effort has been made to create a Windows 2000
 # appearance. This extends to the behaviour of the titlebar bindings. These are:
 # 
 # Icon                           Double-Button-1    Withdraw palette. 
 # Title                          Motion-Button-1    Drag palette.
 # Rollup-button                  Button-1           Toggles large or small size.
 #
 # Example:
 # -------
 # This module includes a demo proceedure. Delete and/or comment out as required.
 #
 # Note:
 # ----
 # There is a problem with setting the transient option for the palette.
 # If the option is set, then the associated master window flashes. 
 # Is this a problem with Tk8+?
 # Until this matter is resolved, the palette window attributes will be
 # to topmost.
 #
 # Future enhancements:
 # -------------------
 # If the palette toplevel window is destroyed, then remove 
 # the associated namespace.
 # 
 ############################################  
 package require Tk
 #-------
 # create private widegt namspace
 #------- 
 namespace eval Palette {}
 #-------
 # create floating palette
 #-------
 proc {Palette} { {pathname .pal} args } {  
    #-------
    # no need to rebuild any exiting palette
    #-------
    if { [winfo exists $pathname] } {
        wm deiconify $pathname
        return
    }
    #-------
    # store all related variables in private namespace
    #-------
    namespace eval $pathname {
        set lx -1
        set ly -1
        set small 22
        set height 230
        set width 150
        set exitcmd {bell}
        set title {Floating Palette}
    }
    #-------
    #local variables
    #-------
    set bg #000088
    set xpos 100
    set ypos 100
    set image fp_tickle
    #-------
    # parse arguments
    #-------
    foreach {arg val} $args {
        switch [string trimleft $arg -] {
            exitcmd {set ${pathname}::exitcmd $val}
            xpos {set xpos $val}
            ypos {set ypos $val}
            titlebg -
            titlebackground {set bg $val}
            width {set ${base}::width $val}
            height {set ${base}::height $val}
            image {set image $val}
        }
    }
    #-------
    # create palette toplevel
    #-------
    toplevel $pathname
    wm withdraw $pathname
    wm overrideredirect $pathname 1
    wm resizable $pathname 1 1
    #-------
    # specify new container
    #-------
    set base $pathname.fra
    #-------
    # a few necessary graphics
    #-------
    image create photo fp_tickle -data R0lGODlhEAAQANUAAP////DwzOfktuDaptnRltHFgtHFgc7Bfcy+dsq7csOyY7uyfbqqYrS0mbOyl7Kxk6+sjK6gXq2fXqqdXqGVXZKFSo+NdI+EVXlwRnh4Znd3ZHZtRXZtQ21mSGFaOWFZMVtUMVRPOE5LOkBAN0A8KD05JTw8Mzs7MTAsGCAfGx8fHxQUFBMTEw8PDwwMDAokagMDAwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAEAAQAAAGXsCXcDiMxVLEZBFyUMSUxNgjoXBChTFHgaL4XIWmgeSiQH1jDURHUWGdBZONovR9ZQgeRsVVzxhECiR1dgsgFU9fKwEWHBGIXycaGCGDMS0mIy2PZyqDQzAtnlibREEAOw==
    image create photo fp_close -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADNhi63BMgyinFAy0HC3Xj2EJoIEOM32WeaSeeqFK+say+2azUi+5ttx/QJeQIjshkcsBsOp/MBAA7
    image create photo fp_open -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADMxi63BMgyinFAy0HC3XjmLeA4ngpRKoSZoeuDLmo38mwtVvKu93rIo5gSCwWB8ikcolMAAA7
    #-------
    # the palette container frame
    #-------
    frame $base \
        -borderwidth 3 \
        -relief raised \
        -height [set ${pathname}::height] \
        -width [set ${pathname}::width]  
    pack $base -side top -fill both -expand 1  
    #-------
    # own title bar
    #-------
    frame $base.fra1 \
        -height 30 \
        -background $bg
    pack $base.fra1  \
        -anchor center \
        -fill x \
        -side top
    #-------
    # icon button
    # bindings: double click MB1 to withdraw
    #-------
    label $base.fra1.lab1  \
        -anchor w \
        -background $bg \
        -borderwidth 0 \
        -image $image
    pack $base.fra1.lab1 \
        -anchor w \
        -side left
    bind $base.fra1.lab1 <Double-1> {
        set base  [winfo toplevel %W]
        wm withdraw $base
        eval [set ${base}::exitcmd ]
    }  
    #-------
    # title holder
    # bindings: click and hold MB1 to drag
    #-------
    label $base.fra1.lab2  \
        -anchor w \
        -background $bg \
        -borderwidth 0 \
        -foreground #ffffff  \
        -text [set ${pathname}::title] \
        -font {Ariel 8 bold} \
        -padx 4
    pack $base.fra1.lab2 \
        -anchor w \
        -side left
    bind $base.fra1.lab2 <Button-1> {
        set base [winfo toplevel %W]       
        set ${base}::lx %x
        set ${base}::ly %y
        }
    bind $base.fra1.lab2 <ButtonRelease-1> {
        set base [winfo toplevel %W] 
        set ${base}::lx -1
        set ${base}::ly -1
        }
    bind $base.fra1.lab2 <Motion> {
        set base [winfo toplevel %W]        
        if { [set ${base}::lx] != -1 } {
            set ${base}::dx [expr %x - [set ${base}::lx]]
            set ${base}::dy [expr %y - [set ${base}::ly]] 
            set ${base}::wx [winfo rootx $base]
            set ${base}::wy [winfo rooty $base]
            set ${base}::x [expr [set ${base}::wx] + [set ${base}::dx] ]
            set ${base}::y [expr [set ${base}::wy] + [set ${base}::dy] ]
            wm geometry $base +[set ${base}::x]+[set ${base}::y]
            }
    }
    #-------
    # roll-up button
    # bindings: click MB1 to toggle up or down
    #-------
    label $base.fra1.lab3  \
        -anchor w \
        -background $bg \
        -borderwidth 0 \
        -relief flat \
        -foreground #ffffff  \
        -image fp_open 
    pack $base.fra1.lab3 \
        -anchor e \
        -side right
    bind $base.fra1.lab3 <Button-1> {
        set base [winfo toplevel %W]
        if {[winfo height $base] == [set ${base}::small] } {
                %W configure -image fp_open
                wm geometry $base [set ${base}::width]x[set ${base}::height] ; update
            } else {
                %W configure -image fp_close
                wm geometry $base [set ${base}::width]x[set ${base}::small] ; update   
            }
        } ;# end bind
    #-------
    # 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 {
            title      {eval Palette::title $self $args}
            getframe   {eval Palette::getframe $self}
            icon       {eval Palette::icon $self}  
        }
    }
    #-------
    # resize and locate palette, and always keep on top
    #-------
    wm geometry $pathname [set ${pathname}::width ]x[ set ${pathname}::height]+${xpos}+${ypos}; update
    wm attributes $pathname -topmost 1 
    #-------
    # return pathway to palette container
    #-------
    return $base
 }
 #-------
 # return container name
 #-------
 proc Palette::getframe {path} {
    return $path.fra
 }
 #-------
 # return titebar container
 #-------
 proc Palette::titlebar {path} {
    return $path.fra.fra1
 }
 #-------
 # set palette title
 #-------
 proc Palette::title {path string} {
    $path.fra.fra1.lab2 configure -title $string 
 }
 #-------
 # set palette image
 #-------
 proc Palette::image {path image} {
    $path.fra.fra1.lab1 configure -image $image
 }
 #-------
 # demo
 #-------
 proc Palette::demo {} {
    # authored in ASED it doesn't like new consoles!
    catch { console show }
    # create a master window with some controls
    set ::pal 0 ; # *1
    radiobutton .rad1 -text "Show Palette" -variable pal -value 1 -command {wm deiconify .pal}
    radiobutton .rad2 -text "Hide Palette" -variable pal -value 0 -command {wm withdraw .pal}
    pack .rad1 .rad2 -anchor w -side top
    # create palette 
    Palette .pal -exitcmd {set pal 0}
    # fill the frame from the bottom upwards  
    set base [frame [.pal getframe].fr3]
    pack $base -side bottom -fill both -expand 1
    pack  [button $base.but1 -text "Big Button" -command "puts \{Big Button\}"] -fill x -expand 1
    # create two sets of buttons
    # left
    set base [frame [.pal getframe].fr1]
    pack $base -side left -anchor nw -fill both -expand 1
    for {set i 0} {$i <= 7} {incr i} {
       pack  [button $base.but$i -text "Button (A,$i)" -command "puts (A,$i)"] -fill x -expand 1
    }
    # right 
    set base [frame [.pal getframe].fr2]
    pack $base -side right -anchor ne -fill both -expand 1
    for {set i 0} {$i <= 7} {incr i} {
        pack  [button $base.but$i -text "Button (B,$i)" -command "puts (B,$i)"] -fill x -expand 1
    }
 }
 Palette::demo


----

[MG] Jan 15th 2005 - There is actually some native support in Windows for palettes via
  wm attribute $toplevel -toolwindow 1
(which can be combined with -toplevel 1 to get a similar effect).

[WJG] Yes, I'm aware of this but I really do want that roll-up effect.

[MG] Sure :) Added a small fix to the demo proc, where the "pal" variable set was local and not global, so the radiobutton wasn't selected.

[MG] With Windows (or at least XP SP2, I haven't tested it elsewhere) and the [registry] package, along with the gradient code from [Gradients Color Transitions], you can also do more native gradient titlebars (by making the titlebar a canvas and binding the movement, etc, to that. A small change is needed in the Gradient code, though; it needs to add the tag 'move' as well as the tag 'gradient'). Here's a quick bit of code to do it (thrown together from a half-hour's playing in the wish console, and only lightly tested)...

 # make sure we have the registry package
 package require registry
 # This replaces everything from "own title bar" (inclusive) to "Here comes the overloaded widget proc" (exclusive)
 source gradient.tcl ;# the code in http://mini.net/tcl/9079
 # Title bar
 frame $base.fra1 -height 30
 pack $base.fra1  \
        -anchor center \
        -fill x \
        -side top
 set canv [canvas $base.fra1.c \
           -width [expr {[set ${pathname}::width]-5}] \
           -height 20 -highlightthickness 0 \
           -borderwidth 0]
 pack $canv -side left -anchor nw -fill x
 $canv create image 2 2 \
             -image fp_tickle \
             -anchor nw \
             -tags icon ;# image should be transparent
 $canv create text 18 2 \
              -text [set ${pathname}::title] \
              -font {Arial 8 bold} -tags [list move titletxt] \
              -anchor nw
 $canv create image [expr {[set ${pathname}::width]-7}] 2 \
              -image fp_open -anchor ne -tags toggleBtn
 $canv bind move <Button-1> {
        set base [winfo toplevel %W]
        set ${base}::lx %x
        set ${base}::ly %y
        }
 $canv bind move <ButtonRelease-1> {
        set base [winfo toplevel %W]
        set ${base}::lx -1
        set ${base}::ly -1
        }
 $canv bind move <Motion> {
        set base [winfo toplevel %W]
        if { [set ${base}::lx] != -1 } {
            set ${base}::dx [expr %x - [set ${base}::lx]]
            set ${base}::dy [expr %y - [set ${base}::ly]]
            set ${base}::wx [winfo rootx $base]
            set ${base}::wy [winfo rooty $base]
            set ${base}::x [expr [set ${base}::wx] + [set ${base}::dx] ]
            set ${base}::y [expr [set ${base}::wy] + [set ${base}::dy] ]
            wm geometry $base +[set ${base}::x]+[set ${base}::y]
            }
    }

 $canv bind icon <Double-1> {
        set base  [winfo toplevel %W]
        wm withdraw $base
        eval [set ${base}::exitcmd ]
        break;
   }
 $canv bind toggleBtn <Button-1> {
        set base [winfo toplevel %W]
        if {[winfo height $base] == [set ${base}::small] } {
                %W itemconfigure toggleBtn -image fp_open
                wm geometry $base [set ${base}::width]x[set ${base}::height] ; update
            } else {
                %W itemconfigure toggleBtn -image fp_close
                wm geometry $base [set ${base}::width]x[set ${base}::small] ; update
            }
        break;
        } ;# end bind

You then need to add these three procs:

 proc col {rgb} {
 
   set r [lindex $rgb 0]; set g [lindex $rgb 1]; set b [lindex $rgb 2]
   format #%04X%04X%04X [expr {($r*255)+($r*2)}] [expr {($g*255)+($g*2)}] [expr {($b*255)+($b*2)}]
 }
 
 proc fpActivate {w} {
 
   set canv $w.fra.fra1.c
   transx::paint_canvas $canv x [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} ActiveTitle]] [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} GradientActiveTitle]]
   $canv lower gradient
   $canv itemconfigure titletxt -fill [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} TitleText]]
 
 }
 
 proc fpDeactivate {w} {
 
   set canv $w.fra.fra1.c
   transx::paint_canvas $canv x [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} InactiveTitle]] [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} GradientInactiveTitle]]
   $canv lower gradient
   $canv itemconfigure titletxt -fill [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} InactiveTitleText]]
 
 }

Then put the active colours on the bar, with

 fpActivate $floatingPaletteToplevel ;# .pal in the demo code

And then bind to the toplevel, so that when it loses focus, ''fpDeactivate .pal'' is run, and ''fpActivate .pal'' is run when it gains focus