# ------------------------------------------------------------------------------
# TopTcl_1.tcl for tG² is under BSD License, Copyright (C) 2010 by 'SeS'
# See https://wiki.tcl-lang.org/25888
# 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 alternative toplevel frame with optional transparent shadow
# ------------------------------------------------------------------------------
proc TopTcl {tParent TLT W H rndArc {shadowType 3} {sfg black}} {
  wm overrideredirect $tParent 1

  if {$shadowType > 0} {
    wm attribute $tParent -topmost 1
    toplevel ${tParent}copy 
    wm geometry ${tParent}copy 1x1+5000+5000
    wm overrideredirect ${tParent}copy 1
    wm attribute ${tParent}copy -alpha 0.5
    wm title ${tParent}copy "${tParent}copy_shadow"
    wm transient ${tParent}copy $tParent
  
    pack [frame ${tParent}copy.lab -bg $sfg -bd 0 -relief flat] -expand 1 -fill both
    update
    switch $TLT {
      "rrectangle" {dll_SetWindowRgn [getHwnd [wm title ${tParent}copy]] [dll_CreateRoundRectRgn 0 0 $W $H $rndArc $rndArc] True}
      "elliptic"   {dll_SetWindowRgn [getHwnd [wm title ${tParent}copy]] [dll_CreateEllipticRgn  [lindex $rndArc 0] [lindex $rndArc 1] $W $H] True}
    }
    bind $tParent <FocusOut>  "+; wm attribute ${tParent}copy -alpha 0.1"
    bind $tParent <FocusIn>   "+; wm attribute ${tParent}copy -alpha 0.5; eval \[bind $tParent <Configure>]"
    bind $tParent <Configure> "+; 
      set geo \[split \[split \[wm geometry $tParent] x\] +\]
      wm deiconify ${tParent}copy
      wm geometry ${tParent}copy \[lindex \$geo 0 0]x\[lindex \$geo 0 1]+\[expr \[lindex \$geo 1]+$shadowType]+\[expr \[lindex \$geo 2]+$shadowType]
    "
    wm title ${tParent}copy ""
  }
  
  switch $TLT {
    "rrectangle" {dll_SetWindowRgn [getHwnd [wm title $tParent]] [dll_CreateRoundRectRgn 0 0 $W $H $rndArc $rndArc] True}
    "elliptic"   {dll_SetWindowRgn [getHwnd [wm title $tParent]] [dll_CreateEllipticRgn  [lindex $rndArc 0] [lindex $rndArc 1] $W $H] True}
  }
  #enableMoveFromAnywhere $tParent; available in official release of tG²
}

# ------------------------------------------------------------------------------
# TopTcl_1.tcl wrapper has dependencies to ffidl package
# ------------------------------------------------------------------------------
package require Ffidl 0.6
ffidl::callout dll_CreateRoundRectRgn {int int int int int int} int [ffidl::symbol gdi32.dll CreateRoundRectRgn]
ffidl::callout dll_FindWindowTitle    {int pointer-utf8} int        [ffidl::symbol user32.dll FindWindowA]
ffidl::callout dll_SetWindowRgn       {int int pointer-utf8} int    [ffidl::symbol user32.dll SetWindowRgn]
ffidl::callout dll_CreateEllipticRgn  {int int int int} int         [ffidl::symbol gdi32.dll CreateEllipticRgn]
proc getHwnd {windowname} {return [dll_FindWindowTitle 0 $windowname]}

# ------------------------------------------------------------------------------
# TEST SCRIPT:
# ------------------------------------------------------------------------------
# Test conditions:
#   -WinXP OS
#   -ActiveState's tcl/tk v8.4.19 distribution, using "wish"
#   -Ffidl v0.6

set MainProgramSize [split [lindex [split [wm geo .] +] 0] x]
bind . <Escape> {exit}
TopTcl . rrectangle [lindex $MainProgramSize 0] [lindex $MainProgramSize 1] 20 10