Updated 2013-08-29 07:44:53 by arjen

Kevin Walzer: I've been interested in implementing a Cocoa-style NSPopover window in Tk (see https://developer.apple.com/library/mac/#documentation/AppKit/Reference/NSPopover_Class/Reference/Reference.html). Using a few tricks from wm attributes, it is simpler to do in Tk than one might expect.

Here's what a native popover window looks like:

And here's my Tk implementation:

And finally, here's the code. It's not really feasible to make this a general package because we are drawing individual windows, not a standard structure with a string and image, but this should give you an idea of how to implement the window in your own apps.

proc create_popover {x y parent} {

catch {destroy .pop}

toplevel .pop -width 200 -height 400

wm overrideredirect .pop 1

wm attribute .pop -transparent 1

wm attributes .pop -alpha 0.0

wm transient .pop  $parent 

bind .pop <Any-Enter> {focus -force .pop}


frame .pop.f -bg systemTransparent
pack .pop.f -fill both -expand yes


ttk::label .pop.f.l -text \u25B2 -padding -3 
pack .pop.f.l -side top -expand no

ttk::frame .pop.f.m -padding 5
pack .pop.f.m -side bottom -fill both -expand yes

ttk::button .pop.f.m.b -text "Close" -command {fade_out .pop}
pack .pop.f.m.b -side bottom -fill both -expand yes

text .pop.f.m.t
pack .pop.f.m.t -side bottom -fill both -expand yes

.pop.f.m.t insert end "Here is a Cocoa-style popover window in Tk.\n"

set placex [expr $x-100]
set placey [expr $y+5]


wm geometry .pop 200x400+$placex+$placey

raise .pop

fade_in .pop


}

proc fade_out {w} {

        set prev_degree [wm attributes $w -alpha]

        set new_degree [expr $prev_degree - 0.05]
        set current_degree [wm attributes $w -alpha $new_degree]
        
        if {$new_degree > 0.0 && $new_degree != $prev_degree} {
                after 10 [list fade_out $w]
        } else {
                destroy $w
        }

}

proc fade_in {w} {

        set prev_degree [wm attributes $w -alpha]

        set new_degree [expr $prev_degree + 0.05]
        set current_degree [wm attributes $w -alpha $new_degree]
        
        if {$new_degree < 1.0 && $new_degree != $prev_degree} {
                after 10 [list fade_in $w]
        } else {
                return
        }

}



button .b -text "Show Popover"
pack .b
bind .b <1> {create_popover %X %Y .}

---

TR This is a cool thing. But we can do even better. We can use the right MacWindowStyle (as exemplified in Perfect Aqua Look and build a canvas with a transparent background and the perfect shape! Like this:

I now wrapped the popover code into a namespaced proc so it can be used easier and changed the placement code a bit (and got it wrong, the top of the triangle will not appear directly at the cursor, this is left as an exercise for the reader). We could embed even more of the code of the main program into the popover code in order to make it even easier to use. Ideally, the user would only need to provide the inner widgets of the popover and the proc would do the rest including proper window size and placement. This approach has also the advantage that the code automatically (or via a user option) could place the triangle at any place, more the the left or right of the upper edge or even on another side of the canvas. Anyway, here's my code, tested on Mac with Tcl 8.6:
namespace eval pop {
   variable Popover
}
proc pop::PopOver {cmd pop args} {
        #
        # a popover window that follows its parent
        #
        # cmd - a command for the PopOver. Can be:
        #    create = creates a popover window from a new toplevel
        #    show = shows the creates popover
        # pop - a toplevel window that has been or must be created with [pop::PopOver create <toplevel>])
        # args - additional args, see below
        #
        variable Popover
        switch $cmd {
                create {
                        #
                        # takes a new toplevel window that will be the popover later
                        #
                        # args=
                        #  parent - the parent window, which the popover should follow
                        #
                        lassign $args parent
                        set Popover($pop,parent) $parent
                        catch {destroy $pop}
                        toplevel $pop -width 200 -height 400
                        wm overrideredirect $pop 1
                        wm transient $pop $parent 
                        bind $pop <Any-Enter> [list focus -force $pop]
                        if {[winfo toplevel $parent] eq $parent} {
                                wm protocol $parent WM_DELETE_WINDOW "destroy $pop ; destroy $parent"
                        }
                        wm withdraw $pop
                        return $pop
                }
                fadeIn {
                        #
                        # fade the popover into view
                        #
                        # args= -none-
                        #
                        set prev_degree [wm attributes $pop -alpha]
                        set new_degree [expr $prev_degree + 0.05]
                        set current_degree [wm attributes $pop -alpha $new_degree]
                        if {$new_degree < 1.0 && $new_degree != $prev_degree} {
                                after 10 [list pop::PopOver fadeIn $pop]
                        } else {
                                return
                        }
                }
                fadeOut {
                        #
                        # fade the popover out of view
                        #
                        # args= -none-
                        #
                        set prev_degree [wm attributes $pop -alpha]
                        set new_degree [expr $prev_degree - 0.05]
                        set current_degree [wm attributes $pop -alpha $new_degree]
                        if {$new_degree > 0.0 && $new_degree != $prev_degree} {
                                after 10 [list pop::PopOver fadeOut $pop -animate 1]
                        } else {
                                wm withdraw $pop
                        }
                }
                hide {
                        #
                        # hide the popover from view
                        #
                        # args=
                        #  -animate = boolean flag, whether to fade the popover out
                        #
                        array set options {-animate 0}
                        array set options $args
                        if {$options(-animate)} {pop::PopOver fadeOut $pop}
                        wm withdraw $pop
                }
                show {
                        #
                        # shows a previously created popover
                        #
                        # args=
                        #  -x = horizontal coordinate of where to place the popover
                        #  -y = vertical coordinate of where to place the popover
                        #  -width = width of the popover
                        #  -height = height of the popover
                        #  -animate = boolean flag, whether to fade the popover in
                        #
                        array set options [list -x [winfo pointerx $Popover($pop,parent)] -y [winfo pointery $Popover($pop,parent)] -width 200 -height 200 -animate 0]
                        array set options $args
                        set placex [expr $options(-x)-$options(-width)/2]
                        set placey [expr $options(-y)+5]
                        if {$options(-animate)} {
                                wm attribute $pop -transparent 1
                                wm attributes $pop -alpha 0.0
                        } else {
                                wm attribute $pop -transparent 0
                                wm attributes $pop -alpha 1.0
                        }
                        wm deiconify $pop
                        wm geometry $pop $options(-width)x$options(-height)+$placex+$placey
                        raise $pop
                        if {$options(-animate)} {pop::PopOver fadeIn $pop}
                }
                default {return -code error "pop::PopOver: no such cmd '$cmd'"}
        }
        
}

if 1 {
        # 1. main window:
        button .b -text "Show Popover"
        bind .b <1> {pop::PopOver show .pop -x %X -y %Y -animate 1}
        pack .b
        # 2. make popover:
        pop::PopOver create .pop .
        ## 3. modify popover to be the correct style:
        ::tk::unsupported::MacWindowStyle style .pop document {noTitleBar}
        wm attribute .pop -transparent 1
        # 4. build the inner of the popover to match a Mac style NSPopover:
        grid [canvas .pop.t -width 200 -height 200 -highlightthickness 0]
        .pop.t configure -background systemTransparent
        .pop.t create polygon 70 15 80 0 90 15 -fill systemSheetBackground -outline systemSheetBackground
        .pop.t create polygon 12 22 12 160 150 160 150 22 12 22 \
                -fill systemSheetBackground -outline systemSheetBackground -width 12 -joinstyle round
        # place some interactive elements on top of the canvas:
        #place [ttk::button .pop.b -text Exit! -command exit] -relx 0.25 -rely 0.3
        #place [ttk::button .pop.c -text Hide! -command {pop::PopOver hide .pop -animate 1}] -relx 0.25 -rely 0.5
        # or do it by creating windows in the canvas:
        .pop.t create window 75 50 -window [ttk::button .pop.b -text Exit! -command exit]
        .pop.t create window 75 75 -window [ttk::button .pop.c -text Hide! -command {pop::PopOver hide .pop -animate 1}]
}

Kevin Walzer: A definite improvement from a visual standpoint; however, my approach allows for simpler, more standard placement of Tk widgets within the popover window because it's not backed by a canvas. This, for instance, makes it trivial to implement a scrolling listbox that displays similar behavior to the "downloads" popover in Safari, which would be a lot harder to get right by placing widgets in a canvas. I hard-coded the arrow character for the same reason: I'm opting for simplicity over flexibility and a bit more visual polish. But, the more the merrier! Thank you for the alternate implementation; it's nice to see a few different ways to do something, and hopefully others will benefit.

AM (29 august 2013) I am not familiar with Cocoa-specific widgets and GUI elements, but isn't the matter of listboxes placed in a canvas solved by using BWidget? IIUIC, it uses the canvas for a lot of its megawidgets.