#
package provide balloonhelp 24.04.27

# <20240427.1333.38>

# this package provides 'balloon help' AKA tooltip help
# for tk windows. It uses several globals to control
# the details of font, colors, delay and enabling.
#
# To define a 'tip' for a window include one of the following
# lines in the code definition:
#
# balloonhelp_for window text
#
# balloonhelpd_for window text

# if 'text' starts with '#! callback function' 
# When that 'text' is to be displayed the 'callback function' is called with
# 3 appended parameters:
# 1 the window name 'window' above
# 2 the location of the mouse as '@x,y'
# 3 the number of this call in the sequence (first is 0).

# At this time this is used to reduce the number of copies of the same help
# or tip kept in memory.

# The expected return from the 'callback function' is the text to display and
# the time to display it in decaseconds. At the end of this period, if the
# display has not been canceled by mouse movement, the 'callback function' is
# called again. This sequence will repeat until the return 'time to display' is
# 0 or negative. If zero, the returned text will be displayed only if
# 'balloon_help' is enabled and will be taken down as per normal balloon_help
# messages. If the return time is negative no more messages will be
# displayed for this trigger.
#
# balloonhelp_for will pop up the tip window after a delay
# balloonhelpd_for will pop up the window immediately
# 
# In both cases the trigger for the display is the mouse
# entering the window and the tear down is triggered by
# the mouse moving the window.

# In order to make better use of memory, the 'window' operand may be affixed with
# .. followed by an optional qualifing condition to apply to the windows
# childeren. Thus, for example '.foo..' would set up each child of '.foo' to
# share the given 'text', while '.foo.. -font' would only set up children of
# '.foo' which accepted fonts, and '.foo.. !"pat"' would accept children except
# those that contained "pat" in their name. The condition string format,at this
# time is: ?!?-opt or ?!?opt. The '-' causes a 'cget' test for 'opt' while the
# opt without the '-' uses the string match function.
#
# The following globals may be used to control balloon help:
#
#  ::balloon_help::font
#  ::balloon_help::fg
#  ::balloon_help::bg
#  ::balloon_help::enable    (1 do the tip, 0 disable tips)
#  ::balloon_help::delay     (delay time in centaseconds for the delay version)
#  ::balloon_help::display   (list for each monitor of lists Xmin Xmax Ymin Ymax
#
#  If one of ::balloon_help::font,  ::balloon_help::fg, ::balloon_help::bg
#
#  is changed balloon_help_config may be called to update the display
#
#  An alternate way to change the font or color is to call
#       balloon_help_config option 'new option value'
#
#  where option is one of {font bg fg delay} any number of option value
#  pairs may be passed in the call
#
#Set up balloon help
option add *Balloonhelp*background white widgetDefault
option add *Balloonhelp*foreground black widgetDefault
option add *Balloonhelpinfo.wrapLength 3i  widgetDefault
option add *Balloonhelp.info.justify left widgetDefault

package require elastictabs

# proc balloonhelp_for  { a b}     {::balloon_help::balloonhelp_for $a $b}
# proc balloonhelpd_for { a b}     {::balloon_help::balloonhelpd_for $a $b}
# proc balloon_help_config {args}  {eval "::balloon_help::balloon_help_config $args"}
# proc balloon_help_display {Text args} \
#     {::balloon_help::balloon_help_display $Text {*}$args}

namespace eval balloon_help {
  variable font TkDefaultFont
  variable fg
  variable bg
  variable delay 300 ; # Default to 3sec.
  variable enable 0
  variable loc @0,0
  variable display [list [list 0 [winfo screenwidth .] 0 [winfo screenheight .]]]
  variable boundWins {}
  variable curDisplay {}
  variable messages {}

  namespace export balloon_help_config balloonhelp_for balloonhelpd_for

  # This little command removes scripts from bindings, if found
  # It takes w the window, event the <...> bit and text the script
  # If 'refresh' is true it then put the binding back
  # We use this to avoid two identical bindings
  
  proc reBind {refresh w event text} {
    set text [string trimleft $text "+"]
    # frputs text
    set curText [bind $w $event]
    if {[set first [string first $text $curText]] != -1} {
      bind $w $event \
	  [string trim [string replace $curText $first $first+[string length $text]]]
    }
    if {$refresh} {
      bind $w $event $text
    }
  }

  # The missing array command...
  proc arrayVal {array} {
    set rtn {}
    foreach {nam val} [array get $array] {
      lappend rtn $val
    }
    return $rtn
  }

  proc balloon_help_config { args} {
    variable font
    variable fg
    variable bg
    variable delay
    variable enable
    variable display
    variable bhInfo
    variable messages
    set oldEnable $enable
    set oldFont $font
    foreach {arg val} $args {
      set $arg $val
    }
    if {$font != $oldFont } {
      # This lets us adjust the font without messing
      # up other windows using the same font
      set font [font create {*}[font actual $font]]
    }
    foreach op {font fg bg} {
      if {[info exists $op]} {
	.balloonhelp.info config -$op [set $op]
      }
    }
    # frputs enable boundWins
    if {$enable ^ $oldEnable} {
      foreach {win val} [array get bhInfo] {
	if {![winfo exist $win]} {
	  # If window is gone, eliminate its data and clear it
	  unset -nocomplain bhInfo($win)
	  lappend rm $val
	} else {
	  reBind $enable $win <Enter>\
	      "+[namespace code {balloonhelp_enter %W @%x,%y}]"
	  reBind $enable $win <Motion>\
	      "+[namespace code {balloonhelp_motion %W @%x,%y}]"
	  reBind $enable $win <1>\
	      "+[namespace code {balloonhelp_button1 %W @%x,%y}]"
	  reBind $enable $win <Leave>\
	      "+[namespace code {balloonhelp_leave %W}]"
	}
      }
      if {[info exists rm]} {
	balloonhelp_freeMesg $rm
      }
    }
  }
  
  toplevel .balloonhelp \
      -class Balloonhelp \
      -background black \
      -borderwidth 1 \
      -relief flat
  label .balloonhelp.info 
  balloon_help_config
  grid .balloonhelp.info
  wm overrideredirect .balloonhelp 1
  wm withdraw .balloonhelp
  .balloonhelp.info configure -text ""
  
  reBind 1 .balloonhelp <Motion>\
      "+[namespace code {balloonhelp_motion %W @%x,%y}]"
  reBind 1 .balloonhelp <Leave>\
      "+[namespace code {balloonhelp_cancel}]"
  reBind 1 .balloonhelp <1>\
      "+[namespace code {balloonhelp_button1 %W @%x,%y}]"
  
  proc balloonhelp_freeMesg {rm} {
    variable messages
    variable bhInfo
    # we removed a reference to a message. If none left remove the message
    set vals [arrayVal bhInfo]
    foreach val $rm {
      if {$val in $vals} {continue}
      set messages [lreplace $messages $val $val]
    }
  }
    

  proc balloonhelp_setBindings {win idx} {
    variable bhInfo
    variable enable

    #if {[info exists bhInfo($win)]} {return}
    set bhInfo($win) $idx
   
    reBind $enable $win <Enter>\
	"+[namespace code {balloonhelp_enter %W @%x,%y}]"
    reBind $enable $win <Motion>\
	"+[namespace code {balloonhelp_motion %W @%x,%y}]"
    reBind $enable $win <1>\
	"+[namespace code {balloonhelp_button1 %W @%x,%y}]"
    reBind $enable $win <Leave>\
	"+[namespace code {balloonhelp_leave %W}]"
  }
  proc balloonhelp_save {mesg win} {
    variable messages
    # If this win has another message, delete that one.
    if {[info exists bhInfo($win)]} {
      if {[lindex $messages [set idxx $bhInfo($win)]] == $mesg} {
	return $bhInfo($win)
      } else {
	# text has changed..
	unset -nocomplain bhInfo($win)
	balloonhelp_freeMesg $idxx
      }
    }
    if {[set idx [lsearch -exact $messages $mesg]] == -1} {
      if {[set idx [lsearch $messages {}]] != -1} {
	set messages [lreplace $messages $idx $idx $mesg]
      } else {
	set idx [llength $messages]
	lappend messages $mesg
      }
    }
    return $idx
  }
  proc balloonhelp_expandWin {win} {
    if {[set dDot [string first {..} $win]] == -1} {
      return $win
    }
    set pat [string trim [string range $win $dDot+2 end]]
    set not [expr {[string index $pat 0] == "!"}]
    if {$not} {
      set pat [string trim [string range $pat 1 end]]
    }
    set root [string range $win 0 $dDot-1]
    if {$pat == ""} {return [winfo children $root]}
    
    set winList {}
    foreach subWin [winfo children $root] {
      if {[string index $pat 0] == "-"} {
	if {[catch {$subWin cget $pat}] == 0 ^ $not } {
	  lappend winList $subWin
	}
      } elseif {[string match $pat $subWin] ^ $not} {
	lappend winList $subWin
      }
    }
    return $winList
  }
  
  proc balloonhelp_for {window mesg} {
    foreach win [balloonhelp_expandWin "$window"] {
      balloonhelp_setBindings $win [balloonhelp_save $mesg $win]
    }
  }

  proc balloonhelpd_for {window mesg} {
    variable bhInfo
    variable enable
    foreach win [balloonhelp_expandWin "$window"] {
   
      set idx [balloonhelp_save $mesg $win]
      set bhInfo($win) $idx
      
      reBind $enable $win <Enter>\
	  "+[namespace code {balloonhelp_show %W 1}]"
      # reBind $enable $win <Leave>\
      # 	"+[namespace code {wm withdraw .balloonhelp;\
      # 	   .balloonhelp.info configure -text ""}]"
    }
  }

  proc balloonhelp_enter   {win xy} {
    if {[wm state .balloonhelp] == "normal"} {return}
    frputs ENTER win
    balloonhelp_pending $win $xy
  }

  proc balloonhelp_pending {win xy} {
    variable bhInfo
    variable delay
    variable enable
    variable loc
    variable curDisplay
    
    #frputs win xy

    if {$loc == "@0,0"} {
      set loc $xy
      return
    }
    # if already displaying this Tip, don't redo it.
    if {$curDisplay == $win} {return}
    
    set loc $xy
    balloonhelp_cancel
    if {$enable && $win != ".balloonhelp.info" } {
      set PendTime [expr {$delay * 10}]

      #frputs win
      set bhInfo(pending) [after $PendTime \
			       [namespace code [list balloonhelp_show $win 0]]]
    }
  }

  proc balloonhelp_motion {w xy} {
    variable loc
    variable bhInfo
    variable curDisplay
    frputs loc xy curDisplay
    if {$loc == "@0,0"} {
      set loc $xy
    }
    if {$xy == $loc} {return}

    #check if it was significant movement
    lassign [split $loc @,] -> ox oy
    lassign [split $xy  @,] -> nx ny
    set mxMove [expr {max ($ox - $nx , $nx - $ox , $oy - $ny , $ny - $oy)}]
    # allow a bit more movement if the window is up
    if {[wm state .balloonhelp] == "normal" && $mxMove < 25} {return}
    if {$mxMove < 10} {return}
    frputs MOTION
    set curDisplay {}
    balloonhelp_pending $w $xy
  }

  proc balloonhelp_button1 {w xy} {
    variable loc
     frputs loc xy
    if {$loc == "@0,0"} {
      set loc $xy
      return -code break
    }
    balloonhelp_cancel
  }

  proc balloonhelp_leave  {w} {
    # if we have a window up, don't tear down. This allows us to put the window
    # over the mouse without generating a cancel
    # frputs "=[.balloonhelp.info cget -text]< "
    if {[wm state .balloonhelp] != "withdrawn"} {return}
    frputs LEAVE w
    balloonhelp_cancel
  }
  

  proc balloonhelp_cancel {} {
    variable bhInfo
    variable curDisplay
    variable wait

    if {[info exist wait] && $wait} {return}
    set curDisplay {}
    if { [info exists bhInfo(pending)]} {
      after cancel $bhInfo(pending)
      unset bhInfo(pending)
    }
    if {[wm state .balloonhelp] != "withdrawn"} {
      wm withdraw .balloonhelp
      .balloonhelp.info configure -text ""
      update idletasks
    }
  }
  proc balloonhelp_show {win d args} {
    variable font
    variable enable
    variable bhInfo
    variable loc
    variable curDisplay
    variable messages

    frputs SHOW win d args
    set curDisplay $win
    # if {$d} {
    # 	if {![info exists bhInfo($win)]} {
    # 	  balloonhelp_cancel
    # 	  return
    # 	}		
    # 	set Text $bhInfo($win)
    # } else {
    #  If we don't have help for this check each window in the ancestry
    while {![info exists bhInfo($win)]} {
      if {$win == "."} {	  
	balloonhelp_cancel
	return
      }
      set win [string range $win 0 [string last "." $win]-1]
    }
    #frputs win
    set Text [lindex $messages $bhInfo($win)]
    # }
    set first2 [string range $Text 0 1]
    if {($enable || $first2 == "#!") && [winfo exists $win]} {
      if {([catch {$win curselection} val] == 0 && $val != {}) ||\
	      [catch {$win index sel.first} val] == 0} {
	# window has a selection, lets get out.
	balloonhelp_cancel
	return
      }
      #      puts "$Text"
      set count [expr {$args == {} ? -1 : [lindex $args 0]}]
      set timeToDisplay 0
      if {$first2 == "#!"} {
	lassign [{*}[string range $Text 2 end]\
		     $win $loc [incr count]] Text timeToDisplay
	set first2 [string range $Text 0 1]
	if {$timeToDisplay < 0} {
	  balloonhelp_cancel
	  return
	}
      }
      if {$first2 == "\[_" } {
	set Text [eval concat $Text ]
      }
      balloon_help_display $Text w $win
      
      if {$timeToDisplay > 0} {
	# # frputs timeToDisplay
	set bhInfo(pending)\
	    [after [expr {int (100 * $timeToDisplay)}]\
		 [namespace code [list balloonhelp_show $win 0 $count]]]
      }
    }
    unset -nocomplain bhInfo(pending)
  }

  # This little helper returns the start point for an object of 'width'
  # centered 'on' with restraints that object be contained within
  # 'lowL' and 'highL'. It errors out if 'highL' - 'lowL' is less than 'width'
  # or if 'on' is < 'lowL' or >= 'highL'
  #
  proc center {lowL highL width on} {
    if {$highL - $lowL < $width || $on < $lowL || $on >= $highL} {
      return -code error $lowL
    }
    set mp [expr {$width / 2}]
    if {$on - $mp  <= $lowL} {return $lowL}
    if {$on + $mp  > $highL} {return [expr {$highL - $width}]}
    return [expr {$on - $mp}]
  }
  
  proc balloon_help_display {Text args} {
    variable wait  ; # if true we will keep the tip window.
    variable font
    variable loc
    variable display
    # balloonhelp_setBindings [winfo containing {*}[winfo pointerxy .]]
    set loc "@0,0"
    # set mx [winfo pointerx .] 
    # set my [winfo pointery .]
    # default
    lappend ops "keeplong" 1
    lassign $args isW w
    set mX [winfo pointerx .] 
    set mY [winfo pointery .]
    if {$isW == "w"} {
    } else {
      # possible override
      lappend ops {*}$args
      balloonhelp_cancel
      set w [winfo containing $mX $mY]
    }      	
    if {[winfo exists $w ]} {
      
      while {[set pw [winfo parent $w]] != {} } {set w $pw}
      # lassign [split [winfo geometry $w] "+x"] cw ch cx cy
      #
      # Depend on the user to pass us the display boundries in multi-display
      # screens. we will position the balloonhelp window as close to the center
      # of the window containg the pointer with one of the four corners at the 
      # pointer position, unless that would put the window off screen
      # (screen not display).

      # First find the display info (note: display is a monitor, screen is the total
      # of all monitors added together)

      set found 0
      # get main window size and location
      lassign [split [wm geometry $w] "+x"] cMaxX cMaxY c0X c0Y

      # get display info for monitor the mouse is in
      foreach disp $display {
	lassign $disp mon0X monMaxX mon0Y monMaxY
	if {$mX >= $mon0X && $mX < $monMaxX && $mY >= $mon0Y && $mY < $monMaxY} {
	  incr found
	  break
	}
      }
      frputs found display mx my
      if {!$found} {
	lassign [list 0 [winfo screenwidth .] 0 [winfo screenheight .]] \
	    mon0X monMaxX mon0Y monMaxY
      }
      # If the main window (top level) is not fully on a display, figure alternative
      # limits (defaulted to the main window) such that we know when we are off the
      # screen.
      set lim0X  [expr {max ($c0X, $mon0X)}]
      set lim0Y  [expr {max ($c0Y, $mon0Y)}]
      set limMaxX [expr {min ($cMaxX + $c0X, $monMaxX)}]
      set limMaxY [expr {min ($cMaxY + $c0Y, $monMaxY)}]
      
      while {[incr failsafe] < 50} {
	.balloonhelp.info configure\
	    -text\
	    [elasticTabStops::ElasticTabStops $Text .balloonhelp.info\
		 width [expr {[winfo width $w] - 10}] {*}$ops]
	
	after cancel "set ::balloon_help::wait 0"
	after 500    "set ::balloon_help::wait 0"
	set wait 1
	wm geometry .balloonhelp +$mX+$mY
	wm deiconify .balloonhelp
	raise .balloonhelp
	# Need the update to allow the wm to do its thing... before we ask
	# how big the window is/will be.
	#
	# Least I forget, one of the window managers does not actually size the 
	# window until it is up, thus we raise it and then move it if needed.
	# (May cause a slight flash of the first position (below and left of ptr.)
	update idletasks
	
	# We try two positions (all attempt to put the mouse at the center
	# 1. adjust position to center as best we can on the mouse and limited
	#    by the main window borders
	# 2. as above but limited by the size of the monitor the mouse is in.
	# 3. if this fails we reduce the font size and try again.
	#  (Note we do not go back to ElasticTabs with new font on the first
	#   help, but the change is not undone so subsequence messages will
	#   pass through ElasticTabs with the new font.
	
	# The players: m   - the mouse
	#              mMax- the sized of the window to be displayed
	#              lim - the containing window modified to be on display
	#              mon - display area on monitor
	
	set mMaxX [winfo reqwidth  .balloonhelp]
	set mMaxY [winfo reqheight .balloonhelp]
	# frputs lim0X limMaxX mX mMaxX
	foreach xy {X Y} {
	  if {![catch {center [set lim0$xy] [set limMax$xy]\
			   [set mMax$xy] [set m$xy]} r$xy]} {
	    continue
	  }
	  if {![catch {center [set mon0$xy] [set monMax$xy]\
			   [set mMax$xy] [set m$xy]} r$xy]} {
	    continue
	  }
	  incr fail
	  # frputs FONT
	  font configure $font -size [expr {[font configure $font -size] -1}]
	  break
	}
	wm geometry .balloonhelp ${mMaxX}x${mMaxY}+$rX+$rY
	if {[info exists fail]} {
	  unset fail
	  continue
	}
	break
      }
      if {$failsafe >= 50} {
	error "Size adjust loop in balloon_help_display"
      }
      # frputs mX mY
      # wm geometry .balloonhelp ${mMaxX}x${mMaxY}+$rX+$rY
    }
  }
  namespace export balloon_help_config balloonhelp_for balloonhelpd_for balloon_help_display

}

namespace import balloon_help::*
