# _______________________________________________________________________ #
#
# It's a Tcl/Tk tip widget inspired by:
#   https://wiki.tcl-lang.org/page/balloon+help
#
# See README.md for details.
#
# Scripted by Alex Plotnikov.
# License: MIT.
# _______________________________________________________________________ #

package provide baltip 1.0.6

package require Tk

namespace eval ::baltip {

  namespace export configure cget tip update hide repaint
  namespace ensemble create

  namespace eval my {
    variable ttdata; array set ttdata [list]
    set ttdata(on) yes
    set ttdata(per10) 1600
    set ttdata(fade) 300
    set ttdata(pause) 600
    set ttdata(fg) black
    set ttdata(bg) #FBFB95
    set ttdata(bd) 1
    set ttdata(padx) 4
    set ttdata(pady) 3
    set ttdata(padding) 0
    set ttdata(alpha) 1.0
    set ttdata(bell) no
    set ttdata(font) [font actual TkTooltipFont]
    set ttdata(under) -16
  }
}

# _________________________ baltip UI procedures ______________________ #

proc ::baltip::configure {args} {
  # Configurates the tip for all widgets.
  #   args - options ("name value" pairs)
  # Returns the list of -force, -geometry, -index, -tag option values.

  variable my::ttdata
  set force no
  set index -1
  set geometry [set tag ""]
  set global [expr {[dict exists $args -global] && [dict get $args -global]}]
  foreach {n v} $args {
    set n1 [string range $n 1 end]
    switch -glob -- $n {
      -per10 - -fade - -pause - -fg - -bg - -bd - -alpha - -text - \
      -on - -padx - -pady - -padding - -bell - -under - -font {
        set my::ttdata($n1) $v
      }
      -force - -geometry - -index - -tag - -global {set $n1 $v}
      default {return -code error "invalid option \"$n\""}
    }
    if {$global && ($n ne "-global" || [llength $args]==2)} {
      foreach k [array names my::ttdata -glob on,*] {
        set w [lindex [split $k ,] 1]
        set my::ttdata($n1,$w) $v
      }
    }
  }
  return [list $force $geometry $index $tag]
}
#_______________________

proc ::baltip::cget {args} {
  # Gets the tip's option values.
  #   args - option names (if empty, returns all options)
  # Returns a list of "name value" pairs.

  variable my::ttdata
  if {![llength $args]} {
    lappend args -on -per10 -fade -pause -fg -bg -bd -padx -pady -padding \
      -font -alpha -text -index -tag -bell -under
  }
  set res [list]
  foreach n $args {
    set n [string range $n 1 end]
    if {[info exists my::ttdata($n)]} {
      lappend res -$n $my::ttdata($n)
    }
  }
  return $res
}
#_______________________

proc ::baltip::tip {w text args} {
  # Creates a tip for a widget.
  #   w - the parent widget's path
  #   text - the tip text
  #   args - options ("name value" pairs)

  variable my::ttdata
  array unset my::ttdata winGEO*
  if {[winfo exists $w] || $w eq ""} {
    set arrsaved [array get my::ttdata]
    set optvals [::baltip::my::CGet {*}$args]
    lassign $optvals forced geo index ttag
    set optvals [lrange $optvals 4 end]
    set my::ttdata(optvals,$w) [dict set optvals -text $text]
    set my::ttdata(on,$w) [expr {[string length $text]}]
    set my::ttdata(global,$w) no
    if {$text ne ""} {
      if {$forced || $geo ne ""} {::baltip::my::Show $w $text yes $geo $optvals}
      if {$geo ne ""} {
        array set my::ttdata $arrsaved  ;# balloon popup
      } else {
        set tags [bindtags $w]
        if {[lsearch -exact $tags "Tooltip$w"] == -1} {
          bindtags $w [linsert $tags end "Tooltip$w"]
        }
        bind Tooltip$w <Any-Leave>    [list ::baltip::hide $w]
        bind Tooltip$w <Any-KeyPress> [list ::baltip::hide $w]
        bind Tooltip$w <Any-Button>   [list ::baltip::hide $w]
        if {$index>-1} {
          set my::ttdata($w,$index) $text
          set my::ttdata(LASTMITEM) ""
          bind $w <<MenuSelect>> [list + ::baltip::my::MenuTip $w %W $optvals]
        } elseif {$ttag ne ""} {
          set my::ttdata($w,$ttag) "$text"
          $w tag bind $ttag <Enter> [list + ::baltip::my::TagTip $w $ttag $optvals]
          foreach event {Leave KeyPress Button} {
            $w tag bind $ttag <$event> [list + ::baltip::my::TagTip $w]
          }
        } else {
          bind Tooltip$w <Enter> [list ::baltip::my::Show %W $text no $geo $optvals]
        }
      }
    }
  }
}
#_______________________

proc ::baltip::update {w text args} {
  # Updates tip's text and settings.
  #  w - widget's path
  #  text - tip's text
  #  args - tip's settings

  variable my::ttdata
  set my::ttdata(text,$w) $text
  foreach {k v} $args {set my::ttdata([string range $k 1 end],$w) $v}
}
#_______________________

proc ::baltip::hide {{w ""}} {
  # Destroys the tip's window.
  #   w - widget's path
  # Returns 1, if the window was really hidden.

  return [expr {![catch {destroy $w.w__BALTIP}]}]
}
#_______________________

proc ::baltip::repaint {w args} {
  # Repaints a tip immediately.
  #   w - widget's path
  #  args - options (incl. -index/-tag)

  variable my::ttdata
  if {[winfo exists $w] && [info exists my::ttdata(optvals,$w)] && \
  [dict exists $my::ttdata(optvals,$w) -text]} {
    set optvals $my::ttdata(optvals,$w)
    lappend optvals {*}$args
    catch {after cancel $my::ttdata(after)}
    set my::ttdata(after) [after idle [list ::baltip::my::Show $w \
      [dict get $my::ttdata(optvals,$w) -text] yes {} $optvals]]
  }
}

# _____________________ baltip internal procedures ____________________ #

proc ::baltip::my::CGet {args} {
  # Gets options' values, using local (args) and global (ttdata) settings.
  #   args - local settings ("name value" pairs)
  # Returns the full list of settings ("name value" pairs, "name" without "-") \
   in which special options go first.
  # See also: cget, configure

  variable ttdata
  set saved [array get ttdata]
  set res [::baltip::configure {*}$args]
  lappend res {*}[::baltip::cget]
  array set ttdata $saved
  return $res
}
#_______________________

proc ::baltip::my::ShowWindow {win} {
  # Shows a window of tip.
  #   win - the tip's window

  variable ttdata
  if {![winfo exists $win] || ![info exists ttdata(winGEO,$win)]} return
  set geo $ttdata(winGEO,$win)
  set under $ttdata(winUNDER,$win)
  set w [winfo parent $win]
  set px [winfo pointerx .]
  set py [winfo pointery .]
  set width [winfo reqwidth $win.label]
  set height [winfo reqheight $win.label]
  set ady 0
  if {[catch {set wheight [winfo height $w]}]} {
    set wheight 0
  } else {
    for {set i 0} {$i<$wheight} {incr i} {  ;# find the widget's bottom
      incr py
      incr ady
      if {![string match $w [winfo containing $px $py]]} break
    }
  }
  if {$geo eq {}} {
    set x [expr {max(1,$px - round($width / 2.0))}]
    set y [expr {$under>=0 ? ($py + $under) : ($py - $under - $ady)}]
  } else {
    lassign [split $geo +] -> x y
    set x [expr [string map "W $width" $x]]  ;# W to shift horizontally
    set y [expr [string map "H $height" $y]] ;# H to shift vertically
  }
  # check for edges of screen incl. decors
  set scrw [winfo screenwidth .]
  set scrh [winfo screenheight .]
  if {($x + $width) > $scrw}  {set x [expr {$scrw - $width - 1}]}
  if {($y + $height) > $scrh} {set y [expr {$py - $height - 16}]}
  wm geometry $win [join  "$width x $height + $x + $y" {}]
  catch {wm deiconify $win ; raise $win}
}
#_______________________

proc ::baltip::my::Show {w text force geo optvals} {
  # Creates and shows the tip's window.
  #   w - the widget's path
  #   text - the tip text
  #   force - if true, re-displays the existing tip
  #   geo - being +X+Y, sets the tip coordinates
  #   optvals - settings ("option value" pairs)
  # See also: Fade, ShowWindow, ::baltip::update

  variable ttdata
  if {$w ne "" && ![winfo exists $w]} return
  set win $w.w__BALTIP
  # keep the label's colors untouched (for apave package)
  catch {::apave::obj untouchWidgets $win.label}
  set px [winfo pointerx .]
  set py [winfo pointery .]
  if {$geo ne ""} {                    ;# balloons not related to widgets
    array set data $optvals
  } elseif {$ttdata(global,$w)} {      ;# flag 'use global settings'
    array set data [::baltip::cget]
  } else {
    array set data $optvals
    foreach k [array names ttdata -glob *,$w] {
      set n1 [lindex [split $k ,] 0]   ;# settings set by 'update'
      if {$n1 eq "text"} {
        set text $ttdata($k)           ;# tip's text
      } else {
        set data(-$n1) $ttdata($k)     ;# tip's options
      }
    }
  }
  if {!$force && $geo eq "" && [winfo class $w] ne "Menu" && \
  ([winfo exists $win] || ![info exists ttdata(on,$w)] || !$ttdata(on,$w) || \
  ![string match $w [winfo containing $px $py]])} {
    return
  }
  ::baltip::hide $w
  set icount [string length [string trim $text]]
  if {!$icount || (!$ttdata(on) && !$data(-on))} return
  lappend ttdata(REGISTERED) $w
  foreach wold [lrange $ttdata(REGISTERED) 0 end-1] {::baltip::hide $wold}
  if {$data(-fg) eq "" || $data(-bg) eq ""} {
    set data(-fg) black
    set data(-bg) #FBFB95
  }
  toplevel $win -bg $data(-bg) -class Tooltip$w
  catch {wm withdraw $win}
  wm overrideredirect $win 1
  wm attributes $win -topmost 1
  pack [label $win.label -text $text -justify left -relief solid \
    -bd $data(-bd) -bg $data(-bg) -fg $data(-fg) -font $data(-font) \
    -padx $data(-padx) -pady $data(-pady)] -padx $data(-padding) -pady $data(-padding)
  # defeat rare artifact by passing mouse over a tip to destroy it
  bindtags $win "Tooltip$win"
  bind $win <Any-Enter>  [list ::baltip::hide $w]
  bind Tooltip$win <Any-Enter>  [list ::baltip::hide $w]
  bind Tooltip$win <Any-Button> [list ::baltip::hide $w]
  set aint 20
  set fint [expr {int($data(-fade)/$aint)}]
  set icount [expr {int($data(-per10)/$aint*$icount/10.0)}]
  set icount [expr {max(1000/$aint+1,$icount)}] ;# 1 sec. be minimal
  set ttdata(winGEO,$win) $geo
  set ttdata(winUNDER,$win) $data(-under)
  if {$icount} {
    if {$geo eq ""} {
      catch {wm attributes $win -alpha $data(-alpha)}
    } else {
      Fade $win $aint [expr {round(1.0*$data(-pause)/$aint)}] \
        0 Un $data(-alpha) 1 $geo
    }
    if {$force} {
      Fade $win $aint $fint $icount {} $data(-alpha) 1 $geo
    } else {
      catch {after cancel $ttdata(after)}
      set ttdata(after) [after $data(-pause) [list \
        ::baltip::my::Fade $win $aint $fint $icount {} $data(-alpha) 1 $geo]]
    }
  } else {
    # just showing, no fading
    catch {after cancel $ttdata(after)}
    set ttdata(after) [after $data(-pause) [list ::baltip::my::ShowWindow $win]]
  }
  if {$data(-bell)} [list after [expr {$data(-pause)/4}] bell]
  array unset data
}
#_______________________

proc ::baltip::my::Fade {w aint fint icount Un alpha show geo {geos ""}} {
  # Fades/unfades the tip's window.
  #   w - the tip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   Un - if equal to "Un", unfades the tip
  #   alpha - value of -alpha option
  #   show - flag "show the window"
  #   geo - coordinates (+X+Y) of balloon
  #   geos - saved coordinates (+X+Y) of shown tip
  # See also: FadeNext, UnFadeNext

  variable ttdata
  update
  if {[winfo exists $w]} {
    catch {after cancel $ttdata(after)}
    set ttdata(after) [after idle [list after $aint \
      [list ::baltip::my::${Un}FadeNext $w $aint $fint $icount $alpha $show $geo $geos]]]
  }
}
#_______________________

proc ::baltip::my::FadeNext {w aint fint icount alpha show geo {geos ""}} {
  # A step to fade the tip's window.
  #   w - the tip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   alpha - value of -alpha option
  #   show - flag "show the window"
  #   geo - coordinates (+X+Y) of balloon
  #   geos - saved coordinates (+X+Y) of shown tip
  # See also: Fade

  incr icount -1
  if {$show} {ShowWindow $w}
  set show 0
  if {![winfo exists $w]} return
  lassign [split [wm geometry $w] +] -> X Y
  if {$geos ne "" && $geos ne "+$X+$Y"} return
  if {$fint<=0} {set fint 10}
  if {[catch {set al [expr {min($alpha,($fint+$icount*1.5)/$fint)}]}]} {
    set al 0
  }
  if {$icount<0} {
    if {$al>0} {
      if {[catch {wm attributes $w -alpha $al}]} {set al 0}
    }
    if {$al<=0 || ![winfo exists $w]} {
      catch {destroy $w}
      return
    }
  } elseif {$al>0 && $geo eq ""} {
    catch {wm attributes $w -alpha $al}
  }
  Fade $w $aint $fint $icount {} $alpha $show $geo +$X+$Y
}
#_______________________

proc ::baltip::my::UnFadeNext {w aint fint icount alpha show geo {geos ""}} {
  # A step to unfade the balloon's window.
  #   w - the tip's window
  #   aint - interval for 'after'
  #   fint - interval for fading
  #   icount - counter of intervals
  #   alpha - value of -alpha option
  #   show - not used (here just for compliance with Fade)
  #   geo - not used (here just for compliance with Fade)
  #   geos - not used (here just for compliance with Fade)
  # See also: Fade

  incr icount
  set al [expr {min($alpha,$icount*1.5/$fint)}]
  if {$al<$alpha && [catch {wm attributes $w -alpha $al}]} {set al 1}
  if {$show} {
    ShowWindow $w
    set show 0
  }
  if {[winfo exists $w] && $al<$alpha} {
    Fade $w $aint $fint $icount Un $alpha 0 $geo
  }
}
#_______________________

proc ::baltip::my::MenuTip {w wt optvals} {
  # Shows a menu's tip.
  #   w - the menu's path
  #   wt - the menu's path (incl. tearoff menu)
  #   optvals - settings of tip

  variable ttdata
  ::baltip::hide $w
  set index [$wt index active]
  set mit "$w/$index"
  if {$index eq "none"} return
  if {[info exists ttdata($w,$index)] && ([::baltip::hide $w] || \
  ![info exists ttdata(LASTMITEM)] || $ttdata(LASTMITEM) ne $mit)} {
    set text $ttdata($w,$index)
    ::baltip::my::Show $w $text no {} $optvals
  }
  set ttdata(LASTMITEM) $mit
}
#_______________________

proc ::baltip::my::TagTip {w {tag ""} {optvals ""}} {
  # Shows a text tag's tip.
  #   w - the text's path
  #   tag - the tag's name
  #   optvals - settings of tip

  variable ttdata
  ::baltip::hide $w
  if {$tag eq ""} return
  ::baltip::my::Show $w $ttdata($w,$tag) no {} $optvals
}

# ________________________________ EOF __________________________________ #
#RUNF1: ./test.tcl
#RUNF2: ../tests/test2_pave.tcl
