Floating Palette

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 are placed in a BWidget notebook packed conveniently to one side of the screen. Even with the luxury of using a large monitor in high resolution 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: [email protected]
 # 
 ############################################ 
 # 
 # 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 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 are set 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://wiki.tcl.tk/9079
 image create photo fp_tickle_trans -data {
     R0lGODlhEAAQANUAANnZ2QAAACAfG6+sjM7BfcOyY7Kxk8q7crOyl9HFgqGV
     XWFZMTw8M+Dapq2fXo+EVTAsGLS0mcy+dm1mSJKFShMTE+fktqqdXnZtRT05
     JXh4ZtnRlmFaObqqYgwMDNHFgU5LOkA8KLuyfVtUMRQUFPDwzI+NdHZtQ66g
     Xjs7MXd3ZHlwRlRPOA8PD0BANx8fHwMDA///////////////////////////
     /////////////////////////////////yH5BAEAAAAALAAAAAAQABAAAAZ3
     QIBwOAwEBEQiMTAgFAJEojBgOBQKASIREEAkFIUFkShkNByPAoRIBAQikkmB
     UiESAQHLBVPIEIlCQJoNp0PxAAHCIVHzARVCROJQIxpRAkSikFQynVABInGY
     Uq1YROIw0GK4WgEikRh4EYlEIaxFJBKFgQCRGAQAOw==
   }

 # 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_trans \
             -anchor nw \
             -tags icon
 $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

WJG (17 Jan 2005) The code for the graduated toolbar looks good. I'll have to try it. The work you've done with the registry looks interesting, must have a hack. How did you get on with the corner graphic. The samples that I included had a solid blue background (to match the bar). Have you looked at setting transparency?

MG I didn't set the transparancy, mainly out of lack of time when I put this up, but it's not that difficult to you. I made a page on the Wiki here about Replace one color in an image with transparency which would do the job without a problem (though Photoshop or something like that would do it a few thousand times quicker). I'll come back later and put transparent versions of the image up w/the gradient code, and change that to use the new transparent images, when I get a few minutes. Unless someone else beats me to it, anyway :)

WJG (21 Jan 2005) That would be a really good addition. The overall effect would blend into any(?) windows colour scheme.

MG 21 Jan 2005 - OK, finally got off my ass and sorted that transparent image :) Yeah, it should work no matter what your colour scheme is on Windows, you don't need the default dark/pale blue title bars. (If you change it after the fpActivate command is run, though, the colours won't update until the next time you fpActivate it.) One improvement to make would be to check if the first and second colours are the same (ie, see if the title bar is one solid colour, not a gradient), and just use the -fill option on the canvas if that's the case, not the gradient code.

MG, a few minutes later - Just checked, and (as long as you re-run fpActivate .pal after you change the settings), the title bar on the palette changes colour. Of course, you could then go the whole mile and change the button graphics to get their colours from the registry too. But heck, it took me a week to just make the icon transparent. I'll leave that for someone else :D

AM (17 january 2005) I tried this on Linux:

The wm attributes command was rejected - the -topmost option is Windows-specific. So, just to get an impression, I removed that line
Then it worked, but with one strange side effect: I run a Windows PC and an X emulator. The pallette was definitely present on the Linux machine, but the title bar was a Windows one! Including a little triangle to hide/show the contents
Th second column of buttons was shown in a very narrow column - no text visible, presumably because of the large font used by default.

WJG (17 Jan 2005) My purpose was to replace the standard MS Windows titlebar offerings with something better suited to a rollup palette window. See my notes/comments for reference to these items. One of these days I might add a linux partition to my disk again.

Category GUI

Category Widget