Updated 2016-09-26 11:02:29 by pooryorick ▲

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:

  1. replace "tick" by "after 100 tick" otherwise it would not show hours and seconds
  2. put the "if ...wm attributes $rootname$segment -topmost 1" section below the "wm geometry $rootname$segment..." part to avoid flickering windows.

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]
}
tick

This 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
}

HoMi 2008-12-02: And here comes the "flickerfree" version:

The "trick" is, draw any digit of the clock if and only if it changes its value. And draw the whole clock only at startup or if the position was changed by moving the "config" window and clicking the "Move" button.

Make the following changes within the code above:

1. Remove the proc 'drawTransNumber', it is not required for this solution

2. Change the array 'foo' to
array set foo {
    hT {}  h {}  mT {}  m {}  sT {}  s {}
    HT -1  H -1  MT -1  M -1  ST -1  S -1
}

3. Change the proc 'tick' to
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)

    foreach {HT H} [split $H {}] break
    if {$HT != $foo(HT)} {
        set foo(HT) $HT
        foreach x $foo(hT) {destroy $x}
        set foo(hT) [drawTransDigit .trans$sx $sx $sy $HT]
    }
    if {$H != $foo(H)} {
        set sx1 [expr {$sx + 70}] ;# distance between the two digits of the hours value
        set foo(H) $H
        foreach x $foo(h) {destroy $x}
        set foo(h) [drawTransDigit .trans$sx1 $sx1 $sy $H]
    }

    incr sx $C(X,incr)
    incr sy $C(Y,incr)

    foreach {MT M} [split $M {}] break
    if {$MT != $foo(MT)} {
        set foo(MT) $MT
        foreach x $foo(mT) {destroy $x}
        set foo(mT) [drawTransDigit .trans$sx $sx $sy $MT]
    }
    if {$M != $foo(M)} {
        set sx1 [expr {$sx + 70}] ;# distance between the two digits of the minutes value
        set foo(M) $M
        foreach x $foo(m) {destroy $x}
        set foo(m) [drawTransDigit .trans$sx1 $sx1 $sy $M]
    }

    incr sx $C(X,incr)
    incr sy $C(Y,incr)

    foreach {ST S} [split $S {}] break
    if {$ST != $foo(ST)} {
        set foo(ST) $ST
        foreach x $foo(sT) {destroy $x}
        set foo(sT) [drawTransDigit .trans$sx $sx $sy $ST]
    }
    if {$S != $foo(S)} {
        set sx1 [expr {$sx + 70}] ;# distance between the two digits of the seconds value
        set foo(S) $S
        foreach x $foo(s) {destroy $x}
        set foo(s) [drawTransDigit .trans$sx1 $sx1 $sy $S]
    }
}

4. Use the 'every' proc from Richard Suchenwirth
 proc every {ms body} {eval $body; after $ms [info level 0]}
 every 1000 tick ;# redraw the 'changed' digits only one time per second

5. Change the proc 'move' to
proc move {} {
    global Config foo

    array set foo {HT -1 H -1 MT -1 M -1 ST -1 S -1}
    set Config(X,base) [winfo x .]
    set Config(Y,base) [winfo y .]
    tick ;# redraw the whole clock at the new position
}

The flickering in the original code was the result of the fact that the segments of both digits of the seconds value were destroyed, and after this the required segments of both digits for the new value were created. This means the tens digit was destroyed and redrawn also if its value was the same.

A further step could be that only the segments of a digit will be destroyed which are not required to show the next value, and after this the additional segments required for the next value will be created. This would result in a 100 percent flickerfree clock. But this requires a complete redesign of the application.

slebetman: Would you mind posting the complete reworked/redesigned code on a separate, dedicated page (perhaps FlickerFreeTransparentDigitalClock) so that people can simply copy and paste it instead of having to do copy/paste/modify ?

MJ: I am probably missing something, but why destroy and recreate the different segments? Can't you just wm withdraw them?

Category ApplicationCategory Date and Time