# ------------------------------------------------------------------------------
# All scripts presented in this page are under BSD License
# Part of TopTcl_1.tcl, see also https://wiki.tcl-lang.org/27347
# copyright (C) 2012 by Sedat Serper
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of 
# this software and associated documentation files (the ``Software''), to deal in 
# the Software without restriction, including without limitation the rights to use, 
# copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the 
# Software, and to permit persons to whom the Software is furnished to do so, 
# subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in all 
# copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 
# FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR
# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
# ------------------------------------------------------------------------------

# ------------------------------------------------------------------------------
# Purpose : creates centred image on any toplevel, with transparency to mimick a watermark
# ------------------------------------------------------------------------------
proc TLWmark {im {w .} {imW 30} {imH 30}} {
  if {$w!="."} {set wmrk ${w}.wmrk} {set wmrk .wmrk}
  if {![catch {winfo class ${w}wmrk}]} {return} ;# if already called once for this toplevel, exit...
  toplevel $wmrk
  wm geo $wmrk 1x1+5000+5000
  wm attribute $wmrk -alpha 0.1
  wm overrideredirect $wmrk 1
  wm deiconify $wmrk

  #set imW 30 ;# image width in pixels
  #set imH 30 ;# image height in pixels
  
  pack [label $wmrk.l  -image $im] -expand 1 -fill both ;# this will hold the image
  bind $w <FocusIn> "+; raise $wmrk"
  bind $w <Configure> "+; 
    raise $wmrk
    set tmp \[split \[split \[wm geo $w] x] +]
    set wW \[lindex \$tmp 0 0]
    set wH \[lindex \$tmp 0 1]
    if {\$wH>2*$imH} {wm geo $wmrk +\[expr \[lindex \$tmp 1]+\$wW/2]+\[expr \[lindex \$tmp 2]+\$wH/2]}
    if {(\$wH<2*$imH) || (\$wW<2*$imW)} {wm withdraw $wmrk} {wm deiconify $wmrk}
  "
  bind $w <FocusOut> "+; if {\[wm state $w]!=\"normal\"} {wm withdraw $wmrk}"
  wm geo $wmrk ${imW}x${imH}
  
  # In case of rounded images, one can actually trim the toplevel to it's circular form with DLL calls
  # in tG2 there is a wrapper which can perform this, see TopTcl_1.tcl
  catch {
    source $::dev_folder/procedures/TopTcl_1.tcl ;# to generate this wrapper, see Project Properties
    TopTcl $wmrk elliptic ${imW} ${imH} {0 0} 1
    wm attribute ${wmrk}copy -alpha 0.01 
  }
  event generate $w <Configure>
}

# ------------------------------------------------------------------------------
# DEMO:
# ALl code developed within Windows Vista, using ActiveTcl v8.4.19, tG² v1.06.01.43
#
image create photo pause_icon -data {
R0lGODlhHgAeAP8AAAUFBgIUmg8QEABVyQBGuAEKmQEqqGt6zAA7sj3E+i2x
93yK1CSn9DxDU9ze4QAjngYGFcHM8t7h4guG6ABn1wM1qgN35CUpKomi4tLS
02yC0zQ5RVd10zpCWYL2/3x+gwgIJAIZopqboTtFZhua8Dl1tUXN+y4zQkVM
WXyH0BCM7mLZ/YyW1lVqwmJ2y7nD1gUOpnKL1I2RmYWQ1UNJV32UxDZVwQRj
ylBmwVptxDtHdVNuynOE0WB70goYs7u7vnZ6goKVzBEZRg0QQIur9Iya2ict
OEtpuUhUg4Sj8F14uC5PtX2AiLLF8rrG8Hh8iBseIdjc7HnQ7XyLwEar7Gtu
ddTa7DtIfhw1gUp+uhUuvxaT7nWLvG18tBUrmRUgorjM+ExalBY8pWLP+EzY
/3X1/1hnnjuk/FfU/B5LpRI2rzVbkg0TjTRIi6zB8yo8rTNIphUYGja794iK
krvL9DCF61VYW01SXt3e3q670khOWg4QPmaG4xBRy05tzKaw4V10zJ6n3klN
VnKK2M7Q1WaA1zQ7SomW2IGL04CV3UJFRdHU2ZGc2liYyRAVckJjxUJmyXOL
yEhoxxwwcIObym7A5V9iaGRpcgsNNhQlbxcmcCwwMmtxejY/Vio0VzlGfDA8
YzdAYoCCinyAhUlTai86YjI1NXN3fT4/QGlqbGlwgKOv1ZCY1pao1J2s1Jag
2qu02qWw1miD2M3Nz21/0L3CzsfKzyNe1CNg1MfK0LC80X6e7a2+7svW6puy
7KTA+oXv/7bJ96G9+dba3qGq3weC3oOZ3snO55at6nWU4HiX4iA/tiBAtiBa
tBxJtR5ruhBYu6CpuTtXukhgoyhHpR0+n0leohQ5sFZ0syFCq6Worj1kx3KH
x1uGxUtnxn2TylRwzMTGyXyMylZtvF5zvlZ6uz1avDV1xGZ5xLy/wi9Zw/7+
/gAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAACH5BAEAAOsALAAAAAAeAB4AAAj/ANcJHEiwoMGD
CAk6SCfiw6VLQET8cJAwYQYmNGh06NShYwcUKJhkqEgQzwc9DUYgMdNlypQu
ZpCMaIDiAx6SGVCOCBOkSYSfQHkFCTNT0EiEGe400BEJDJ0/gVixYMHo1R8n
wbjpoHEHYbgNKD5hAENsKqIFKVIsQDTjUCA6GK4YenJQVYMrGJwwSpT2gN+/
PBbMKNIEg44GhApG2xAqhpsiM3gcAIQDR4sWOHLkOBD4kJsYnjgVJGVo2i8M
CzS4yIHOyrEW5sStg9XCBa0FRYRZOyGD4AZQynyldgFIWiyBlLJFEUjOmwsN
MZAlK3VioK0NbYgY09Bjh58lqwQG/xGzfN24Rzt6aEhEpM2GXAKBnIBDZFAh
cJIeLXEl8JsYKwIdYYMk6Q2SBBy8rfOCESC8kYQsHHAAyTbOtCJQJBX0EqA6
kPjBQSG7vAFBFevUcgEEX/DBgQ3MqKHGAzUIpEQALwhETQXXLGMDB3x8AcEm
6yxiCggBwBBAAQGEYEAAXEggATYB5OGAA9WEEEIAWPpQAAgXCKQIBEci+YAB
FTzAhYwP6CKBA2kY8MADYQYAgSIC2QEAGzAUEMIDFSBQQYzrlFOBlMOkgQAC
BoRQAAxsAGCHQKMA4IgPARiAAAGY1iDBOt0g8IIDEjSDKaIB+OAIAKcI9EMc
Q2hhKQEDxO2axToSnDMAJQpCEysBiGqxhwC9CXSBAF70ASsFFFhAQQklUDDB
DVk8k+yufXgBgBEEpQLAELjckOwEKmwxwQQkkLBFMSqoMIEFA9xwyx4AfEDQ
LAIIkEkdFqhAAgMMKODvvwowQMK6dWgCACoGWQKAAFicwa8cCUQsccRy8HsG
FgIA8MNBVWQ8CRVkmGACGiuUvAIaIpNBxSQZi5DQExkLUcIYZXhgMzA2lzFG
CUMsLApJc0ABAABCrNFIJVJIUUkjawgxNBRzkCTQIh9cMDQEIGCCCQgQDH0B
EIlJTZAIgsRRb71GWKKN2GyLHRAAOw==
}

TLWmark pause_icon

proc TLWmark {im {tParent .}} {
  set ::wmrk(parent) $tParent
  set ::wmrk(path) .wmrk
  set ::wmrk(imW) 30 ;# image width in pixels
  set ::wmrk(imH) 30 ;# image height in pixels
  if {![catch {winfo class $::wmrk(path)}]} {return} ;# if already called once for this toplevel, exit...
  toplevel $::wmrk(path)
  wm geo $::wmrk(path) 1x1+5000+5000
  wm attribute $::wmrk(path) -alpha 0.1
  wm overrideredirect $::wmrk(path) 1
  wm deiconify $::wmrk(path)
  pack [label $::wmrk(path).l -image $im] -expand 1 -fill both ;# this will hold the image
  bind $::wmrk(parent) <FocusIn> {+; raise $::wmrk(path)}
  bind $::wmrk(parent) <Configure> {+; 
    raise $::wmrk(path)
    set tmp [split [split [wm geo $::wmrk(parent)] x] +]
    set wW [lindex $tmp 0 0]
    set wH [lindex $tmp 0 1]
    if {$wH>2*$::wmrk(imH)} {wm geo $::wmrk(path) +[expr [lindex $tmp 1]+$wW/2]+[expr [lindex $tmp 2]+$wH/2]}
    if {($wH<2*$::wmrk(imH)) || ($wW<2*$::wmrk(imW))} {wm withdraw $::wmrk(path)} {wm deiconify $::wmrk(path)}
  }
  bind $::wmrk(parent) <FocusOut> {+; if {[wm state $::wmrk(parent)]!="normal"} {wm withdraw $::wmrk(path)}}
  wm geo $::wmrk(path) ${::wmrk(imW)}x${::wmrk(imH)}
  
  # In case of rounded images, one can actually trim the toplevel to it's circular form with DLL calls
  # in tG2 there is a wrapper which can perform this, see TopTcl_1.tcl
  catch {
    source $::dev_folder/procedures/TopTcl_1.tcl ;# to generate this wrapper, see Project Properties
    TopTcl $::wmrk(path) elliptic $::wmrk(imW) $::wmrk(imH) {0 0} 1
    wm attribute ${::wmrk(path)}copy -alpha 0.01 
  }
  event generate $::wmrk(parent) <Configure>
}