Time and again I am amazed at how Tcl seem to be able to implement impossible feats. In a c.l.t thread someone asked if Tcl can draw opaque GUI elements in a fully transparent window. Specifically he wanted to draw a digital clock with a fully transparent background.
Eventually someone pointed out that Windows can do this and TWAPI was accordingly hacked to support it. But somewhere along the way Uwe Klein suggested a way to do a hack in pure Tcl.
Basically we draw GUI elements, in this case a 7-segment display using nothing but toplevels. Here's my stab at it:
package require Tk
# Transparent Clock in pure Tcl:
array set Config {
X,base 10
Y,base 10
X,incr 190
Y,incr 0
}
proc drawTransDigit {rootname x y number} {
set ret [list]
if {[string is integer -strict $number] &&
[string length $number] == 1
} {
set segmentList {
a 02356789 10 0 40 10
b 045689 0 10 10 40
c 01234789 50 10 10 40
d 2345689 10 50 40 10
e 0268 0 60 10 40
f 013456789 50 60 10 40
g 0235689 10 100 40 10
}
foreach {segment group x1 y1 width height} $segmentList {
if {[string first $number $group] != -1} {
# Experiment with -bg, -highlightbackground and
# -highlightthickness to get the look you like:
lappend ret [toplevel $rootname$segment \
-bg red -highlightbackground yellow \
-highlightthickness 1]
# You should also experiment with other stuff
# which affects toplevels like -relief and
# wm attribute -alpha etc.
# Unfortunately, only windows support -topmost
# which I consider the "proper" behavior
if {[lindex [winfo server .] 0] == "Windows"} {
wm attributes $rootname$segment -topmost 1
}
wm overrideredirect $rootname$segment 1
incr x1 $x
incr y1 $y
wm geometry $rootname$segment ${width}x${height}+${x1}+${y1}
}
}
}
return $ret
}
proc drawTransNumber {rootname x y number} {
set ret [list]
foreach i [split $number {}] {
set ret [concat $ret [drawTransDigit $rootname$x $x $y $i]]
incr x 70
}
return $ret
}
# The code can indeed be simpler than this
# but the simple version flickers too much
# for my taste. All this voodoo is merely
# to reduce flicker:
array set foo {
h {} m {} s {}
H 0 M 0 S 0
}
proc tick {} {
global foo
upvar #0 Config C
set now [clock seconds]
foreach {H M S} [split [clock format $now -format "%I.%M.%S"] .] break
set sx $C(X,base)
set sy $C(Y,base)
if {$H != $foo(H)} {
set foo(H) $H
foreach x $foo(h) {destroy $x}
set foo(h) [drawTransNumber .trans $sx $sy $H]
}
incr sx $C(X,incr)
incr sy $C(Y,incr)
if {$M != $foo(M)} {
set foo(M) $M
foreach x $foo(m) {destroy $x}
set foo(m) [drawTransNumber .trans $sx $sy $M]
}
incr sx $C(X,incr)
incr sy $C(Y,incr)
if {$S != $foo(S)} {
set foo(S) $S
foreach x $foo(s) {destroy $x}
set foo(s) [drawTransNumber .trans $sx $sy $S]
}
after 1000 tick
}
tick
# Show the coords, useful with the new move command:
pack [frame .fy] -side top
pack [label .fy.l -text "Y,base :"] -side left
pack [label .fy.v -textvariable Config(Y,base)] -side right
pack [frame .fx] -side top
pack [label .fx.l -text "X,base :"] -side left
pack [label .fx.v -textvariable Config(X,base)] -side right
# To allow us to easily kill this beast:
pack [button .exit -command exit -text "Exit"] -side right
# Allow moving the clock:
pack [button .move -command move -text "Move here"] -side left
proc move {} {
global Config foo
foreach x [after info] {after cancel $x}
array set foo {H 0 M 0 S 0}
set Config(X,base) [winfo x .]
set Config(Y,base) [winfo y .]
tick
}And for my next trick, a pure Tcl "canvas" supporting full transparency using nothing but hundreds of thousands of pixel-sized toplevels! ;-)
TR - Hey, this is really cool! And it works on Linux here with -topmost and being sticky, too. What a great idea doing it with toplevels!!
tonytraductor - Okay, where's the code for this canvas, and, can the same (transparency) be done with a text widget (and work Linux)?
slebetman The said "canvas", of course, doesn't exist. My tongue was firmly in cheek when I made the proposal :-P
PWE Very nice, but I had to make two changes to work properly on XP:
slebetman That's weird because I develop on XP. I've tested it on several machines now and haven't encountered the "tick" problem.
The flickering windows problem doesn't go away even if you move "wm geometry". To see what I mean try this simpler version of the "tick" proc:
set foo [list]
proc tick {} {
global foo Config
after 1000 tick
foreach x $foo {destroy $x}
set now [clock seconds]
set now [clock format $now -format "%I:%M:%S"]
set foo [drawTransNumber .trans $Config(X) $Config(Y) $now]
}
tickThis tick proc would have been much nicer as a demo since it's simpler and easier to read. But it flickers horribly.
LV I wasn't able to figure out exactly how to move this once it displayed.
UK You don't, you walk around it ;-))
LV: Then is there a way to place it where it isn't in the way? Because the default is in a really weird place that makes it hard to read the numbers due to the surrounding stuff.
UK You can change Screen X and Y and incr with the Config array at global scope.
slebetman Wow! barely 12 hours and the code is already getting third party contributions. Thank you UK, your style is different from mine but I like how Config is self-documenting at the top of the file while C is nice and short when it actually needs to be used :)
Added the ability to move the digits. It doesn't save the position but it does display the X-Y coordinates so you can later edit the source to place the clock at your preferred location.
rdt 2006.12.01 Well, I prefer the following segmentlist with a -highlightthickness of 0:
set segmentList {
a 02356789 0 0 60 10
b 045689 0 0 10 60
c 0234789 50 0 10 60
d 2345689 0 50 60 10
e 0268 0 50 10 60
f 03456789 50 50 10 60
g 0235689 0 100 60 10
h 1 25 0 10 110
}