#----------------------------------------------------------------------
#
#  psballoon.tcl,
#   Procedures to create help message balloons or display balloons for
#   listboxes and labels that can't display all of their contents.
#
#  Copyright (c) 2003, Peter Spjuth  (peter.spjuth@gmail.com)
#
#  Permission is granted to use this code under the same terms as
#  for the Tcl core code.
#
#----------------------------------------------------------------------
# $Revision: 1.1 $
#----------------------------------------------------------------------

package provide psballoon 1.1

namespace eval psballoon {
    variable balloon

    set balloon(pending) 0
    set balloon(created) 0
    set balloon(id) ""
    namespace export addBalloon
}

# Do some simple formatting, to be able to have cleaner text in source
proc psballoon::Fmt {msg} {
    # Remove any newlines.
    set msg [regsub -all "\n" $msg " "]
    # Remove multiple whitespace
    set msg [regsub -all {\s+} $msg " "]
    set msg [string trim $msg]
    # Any explicitly requested newlines?
    set msg [regsub -all {\\n\s*} $msg "\n"]
    # Further line breaks by length?
    set lines {}
    foreach line [split $msg \n] {
        while {[string length $line] > 80} {
            # There should be no path through this loop that does not
            # shorten $line
            set ix [string last " " $line 80]
            if {$ix < 0} {
                set ix [string first " " $line]
                if {$ix < 0} {
                    # Just cut at 80
                    set ix 80
                }
            }

            if {$ix == 0} {
                set line [string trim $line]
            } else {
                lappend lines [string range $line 0 $ix-1]
                set line [string range $line $ix+1 end]
            }
        }
        lappend lines $line
    }
    set msg [join $lines \n]
    return $msg
}

proc psballoon::addBalloon {W args} {
    variable balloon

    set msg [lindex $args end]
    set args [lrange $args 0 end-1]

    # Request for formatting
    if {"-fmt" in $args && $msg ne ""} {
        set msg [Fmt $msg]
    }

    set c [winfo class $W]
    if {$msg == "" && $c != "Listbox" && $c != "Label"} {
        error "Missing message to balloon for $W ($c)"
    }
    set balloon(msg,$W) $msg
    bind $W <Enter> {
        set ::psballoon::balloon(pending) 1
        set ::psballoon::balloon(created) 0
        set ::psballoon::balloon(lastX) %X
        set ::psballoon::balloon(lastY) %Y
        set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
    }
    bind $W <Button> {
        psballoon::killBalloon
    }
    bind $W <Leave> {
        psballoon::killBalloon
    }
    bind $W <Motion> {
        if {$::psballoon::balloon(pending) == 1} {
            after cancel $::psballoon::balloon(id)
        }
        if {$::psballoon::balloon(created) == 1} {
            if {$::psballoon::balloon(lastX) == %X && \
                        $::psballoon::balloon(lastY) == %Y} {
                # Sometimes when the balloon is created, a motion event with
                # the same coordinates arrive. Ignore that to avoid killing the
                # new balloon.
                return
            }
            psballoon::killBalloon
        }
        set ::psballoon::balloon(lastX) %X
        set ::psballoon::balloon(lastY) %Y
        set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
        set ::psballoon::balloon(pending) 1
    }
}

proc psballoon::killBalloon {} {
    variable balloon
    if {$balloon(pending) == 1} {
        after cancel $balloon(id)
    }
    if {[winfo exists .balloon] == 1} {
        destroy .balloon
    }
    set balloon(created) 0
    set balloon(pending) 0
}

# Measure display width needed for a text with line breaks
proc psballoon::Measure {font txt} {
    set len 0
    foreach line [split $txt \n] {
        set lw [font measure $font $line]
        if {$lw > $len} {
            set len $lw
        }
    }
    return $len
}

# Returns a list of minX maxX for each screen.
# maxX are exclusive and normally equal to the next minX
proc psballoon::FigureOutScreenWidths {W} {
    set screens {}
    # Range of X over multiple windows
    set minX [winfo vrootx $W]
    set maxX [expr {$minX + [winfo vrootwidth $W]}]
    set sW [winfo screenwidth $W]

    # Guess: If minX is negative, there is a screen from minX to 0
    if {$minX < 0} {
	lappend screens $minX 0
    }
    # Guess: Main screen is in the middle if three

    # Main screen is 0 to screenWidth
    lappend screens 0 $sW

    # Guess: If maxX is larger than screen width (main screen), there
    # is one more screen to the right
    if {$maxX > $sW} {
	lappend screens $sW $maxX
    }
    return $screens
}

proc psballoon::createBalloon {W mx my} {
    variable balloon
    if { ! [winfo exists $W]} {
        return
    }
    if {$balloon(created) == 0} {
        # Figure out widget's font
        if {[catch {set font [$W cget -font]}]} {
            set font [ttk::style lookup [winfo class $W] -font]
        }
        # Fallback to something reasonable if font fails.
        if {$font eq ""} {
            set font TkDefaultFont
        }
        set ww [winfo width $W]
        set ih [winfo height $W]
        if {[winfo class $W] in {TLabelframe Labelframe}} {
            # Put it below the label, not the entire widget.
            # 1.5 font heights is a reasonable guess
            set fh [font metrics $font -linespace]
            set ih [expr {$fh * 3 /2 }]
            # Below cursor at least
            if {$ih <= $my} {
                set ih [expr {$my + 5}]
            }
        }
        set ix 0
        set iy 0
        set create 1
        set msg $balloon(msg,$W)
        if {$msg == ""} {
            switch [winfo class $W] {
                Listbox {
                    set i [$W index @$mx,$my]
                    set msg [$W get $i]
                    foreach {ix iy iw ih} [$W bbox $i] {break}
                }
                Label {
                    set msg [$W cget -text]
		    set iw [Measure $font $msg]
                }
            }
            # Don't create a balloon if the text is fully visible.
            set create [expr {$iw > $ww - 8}]
        } else {
            if {[string index $msg 0] eq "\["} {
                set msg [subst -novariables -nobackslashes $msg]
            }
	    set iw [Measure $font $msg]
	}
	if {$create} {
            set x [expr {[winfo rootx $W] + $ix}]
            set y [expr {[winfo rooty $W] + $iy + $ih + 2}]
            # Limits of current screen.
            foreach {minX maxX} [FigureOutScreenWidths $W] {
                if {$minX <= $x && $x < $maxX} break
            }

            # Move it to the left as needed to fit on screen
            if {$x + $iw + 8 > $maxX} {
                set x [expr {$maxX - $iw - 8}]
            }
            # TBD, option to use a frame in parent instead?
            toplevel .balloon -bg black
            wm overrideredirect .balloon 1
            label .balloon.l \
                    -text $msg -relief flat -font $font -justify left \
                    -bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
            pack .balloon.l -side left -padx 1 -pady 1
            wm geometry .balloon +${x}+${y}
            set balloon(created) 1
        }
    }
}
