#---------------------------------------------------------*-tcl-*------
#
#  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-2024, Peter Spjuth  (peter.spjuth@gmail.com)
#
#  Permission is granted to use this code under the same terms as
#  for the Tcl core code.
#
#----------------------------------------------------------------------
#  This is used as a Tcl Module. Use it like this:
#  ::tcl::tm::path add <path-to-dir-with-module>
#  package require psballoon
#  namespace import psballoon::*
#
#  addBalloon .l .b "My help text"
#  addBalloon .f -fmt {
#     Write help more freely.\n
#     New lines need to be explicit like above.
#  }
#----------------------------------------------------------------------

package provide psballoon 1.2

namespace eval psballoon {
    variable balloon
    variable config

    set config(-useframe) 0
    set balloon(W) ""
    set balloon(pending) 0
    set balloon(created) 0
    set balloon(id) ""
    namespace export addBalloon
}

# -useframe <bool>
proc psballoon::configure {args} {
    variable config
    foreach {arg val} $args {
        set config($arg) $val
    }
}

# 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"]
    # Any remaining substs like tabs?
    set msg [subst -nocommand -novariable $msg]
    # 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
}

# addBalloon widget ?widgets...? ?-fmt? ?msg?
# If message is not given, it is extracted from widget. This is used to show
# e.g. labels where text might not be fully visible.
# Message may contain callbacks in [] for dynamic text.
proc psballoon::addBalloon {W args} {
    variable balloon
    variable config

    set frame $config(-useframe)

    # Last argument is message
    set msg [lindex $args end]

    set Wlist [list $W]
    foreach arg [lrange $args 0 end-1] {
        switch $arg {
            -fmt {
                # Request for formatting
                if {$msg ne ""} {
                    set msg [Fmt $msg]
                }
            }
            -frame {
                set frame 1
            }
            -top {
                set frame 0
            }
            default {
                lappend Wlist $arg
            }
        }
    }

    foreach W $Wlist {
        AddBalloon2 $W $msg $frame
    }
}

proc psballoon::AddBalloon2 {W msg frame} {
    variable balloon

    set c [winfo class $W]
    if {$msg == "" && $c != "Listbox" && $c != "Label"} {
        error "Missing message to balloon for $W ($c)"
    }
    set balloon(msg,$W) $msg
    set balloon(frame,$W) $frame

    if {$msg eq "_"} {
        bind $W <Enter> ""
        bind $W <Button> ""
        bind $W <Leave> ""
        bind $W <Motion> ""
        return
    }

    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> {
        psballoon::motionBalloon %W %X %Y %x %y
    }
}

proc psballoon::motionBalloon {W X Y x y} {
    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(W)]} {
        destroy $balloon(W)
    }
    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 mouseX mouseY} {
    variable balloon
    variable config
    if { ! [winfo exists $W]} {
        return
    }
    if {$balloon(created)} {
        return
    }

    # 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
    }

    # Widget Geometry
    set wWidth [winfo width $W]
    set wHeight [winfo height $W]
    if {[winfo class $W] in {TLabelframe Labelframe TNotebook}} {
        # Put it below the label, not the entire widget.
        # 1.5 font heights is a reasonable guess
        set fontHeight [font metrics $font -linespace]
        set wHeight [expr {$fontHeight * 3 /2 }]
        # Below cursor at least
        if {$wHeight <= $mouseY} {
            set wHeight [expr {$mouseY + 5}]
        }
    }

    # Item Geometry within Widget (if any)
    set itemX 0
    set itemY 0
    set create 1
    set msg $balloon(msg,$W)
    if {$msg == ""} {
        # Extract text from widget
        switch [winfo class $W] {
            Listbox {
                set i [$W index @$mouseX,$mouseY]
                set msg [$W get $i]
                foreach {itemX itemY itemWidth wHeight} [$W bbox $i] {break}
                set bWidth $itemWidth
            }
            Label {
                set msg [$W cget -text]
                set bWidth [Measure $font $msg]
            }
        }
        # Don't create a balloon if the text is fully visible.
        set create [expr {$bWidth > $wWidth - 8}]
    } else {
        if {[string index $msg 0] eq "\["} {
            set msg [subst -novariables -nobackslashes $msg]
        }
        set bWidth [Measure $font $msg]
    }

    if {!$create} return

    # Preferred position of the balloon
    set rootX [expr {[winfo rootx $W] + $itemX}]
    set rootY [expr {[winfo rooty $W] + $itemY + $wHeight + 2}]

    set useframe $balloon(frame,$W)

    if {$useframe} {
        set top [winfo toplevel $W]
        set posX [expr {$rootX - [winfo rootx $top]}]
        set posY [expr {$rootY - [winfo rooty $top]}]
        set minX 6
        set maxX [expr {[winfo width $top] - 6}]
    } else {
        set posX $rootX
        set posY $rootY

        # Limits of current screen.
        foreach {minX maxX} [FigureOutScreenWidths $W] {
            if {$minX <= $rootX && $rootX < $maxX} break
        }
    }
    # Move it to the left as needed to fit on screen
    if {$posX + $bWidth + 8 > $maxX} {
        set posX [expr {$maxX - $bWidth - 8}]
    }

    if {$useframe} {
        if {$top eq "."} {
            set B .balloon
        } else {
            set B $top.balloon
        }
        frame $B -borderwidth 1 -relief solid
    } else {
        set B .balloon
        toplevel $B -bg black
        wm overrideredirect $B 1
    }
    label $B.l \
            -text $msg -relief flat -font $font -justify left \
            -bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
    pack $B.l -side left -padx 1 -pady 1
    if {$useframe} {
        place $B -x $posX -y $posY -anchor nw
    } else {
        wm geometry $B +${posX}+${posY}
    }
    set balloon(W) $B
    set balloon(created) 1
}
