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.
