# tko_tip.tcl --
#
#   Tooltip handling. Ideas borrowed from ::tooltip::tooltip.
#
# Copyright (c) 2024 <r.zaumseil@freenet.de>

# Bindings
bind Tkotip <Enter>         {::tko::tip::enter %W}
bind Tkotip <Leave>         {::tko::tip::hide}
bind Tkotip <Any-KeyPress>  {::tko::tip::hide}
bind Tkotip <Any-Button>    {::tko::tip::hide}
bind Menu   <<MenuSelect>>  {::tko::tip::menumotion %W}
bind Graph  <<TipIndex>>    {::tko::tip::tipindex %W %d}
# Fonts
catch {font create TkTooltipFontItalic {*}[font configure TkTooltipFont] -slant italic}

# Add and clear tip infomrations.
# path  - If args not emtpy then add new tip information of this path.
#         Otherwise delete tip information for all matching path.
# args  - "option value" list of tip informations
#   -index ..   - numerical index inside path p.e. menuitem
#   -text ..    - tip text
#   -info ..    - additional tip info
#   -image ..   - image for tip display
proc ::tko::tip {path args} {
    if {[string index $path 0] ne {.}} {
        return -code error "wrong path or pattern: $path"
    }
    # clear data
    if {$args eq {}} {
        # cache the current widget at pointer
        set myCur [winfo containing [winfo pointerx .] [winfo pointery .]]
        foreach myW [array names ::tko::tip::_ $path] {
            unset ::tko::tip::_($myW)
            if {[winfo exists $myW]} {
                set myTags [bindtags $myW]
                ## We don't remove TooltipMenu because there
                ## might be other indices that use it
                if {[set i [lsearch -exact $myTags {Tkotip}]] != -1} {
                    bindtags $myW [lreplace $myTags $i $i]
                }
                # Withdraw the tooltip if we clear the current contained item
                if {$myCur eq $myW} { ::tko::tip::hide }
            }
        }
        return
    }
    # set data
    set myIdx {}
    set myImg {}
    set myInf {}
    set myTxt {}
    foreach {myOpt myVal} $args {
        switch -- $myOpt {
            -index {set myIdx $myVal}
            -image {set myImg $myVal}
            -info {set myInf $myVal}
            -text {set myTxt $myVal}
            default {
return -code error "bad option \"$myOpt\": should be one of -index, -image, -info, or -text"
            }
        }
    }
    if {$myIdx eq {}} {;# widget
        set ::tko::tip::_($path) [list $myTxt $myImg $myInf]
        bindtags $path [linsert [bindtags $path] end "Tkotip"]
    } else {;# menu or widget item
        set ::tko::tip::_($path,$myIdx) [list $myTxt $myImg $myInf]
    }
}

#
# Internal data
#
namespace eval ::tko::tip {
    # Internal data
    variable _
    set _(widget)   {.__tko__tip__};# used toplevel widget
    set _(afterid)  {};# internally delayed display command id
    set _(menulast) {};# used in menu to track menu item changes
    # _(.*) {text image info} = individual tip informations
}

# Show tip information widget.
# path  - name of widget to show tip for
# text  - tip text information
# image - image to display in tip
# info  - additional tip text information
proc ::tko::tip::show {path text image info} {
    variable _

    if {![winfo exists $path]} return
    if {([winfo class $path] ne {Menu})
        && ![string match $path* [eval [list winfo containing] [winfo pointerxy $path]]]} return
    set w $_(widget)
    $w.f.l configure -text $text -image $image
    if {$info eq {}} {
        ::grid remove $w.f.i
    } else {
        $w.f.i configure -text $info
        ::grid $w.f.i
    }
    update idletasks
    set screenw [winfo screenwidth $path]
    set screenh [winfo screenheight $path]
    set reqw [winfo reqwidth $w]
    set reqh [winfo reqheight $w]
    # When adjusting for being on the screen boundary, check that we are
    # near the "edge" already, as Tk handles multiple monitors oddly
    set y [expr {[winfo pointery $path]+20}]
    if {($y < $screenh) && ($y+$reqh) > $screenh} {
        set y [expr {[winfo pointery $path]-$reqh-5}]
    }
    set x [winfo pointerx $path]
    # only readjust when we would appear right on the screen edge
    if {$x<0 && ($x+$reqw)>0} {
        set x 0
    } elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
        set x [expr {$screenw-$reqw}]
    }
    if {[tk windowingsystem] eq "aqua"} {
        set focus [focus]
    }
    wm geometry $w +$x+$y
    wm deiconify $w
    raise $w
    if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
        # Aqua's help window steals focus on display
        after idle [list focus -force $focus]
    }
}

# Given path widget <Enter> event.
# path  - name of widget to show tip for
proc ::tko::tip::enter {path} {
    variable _
    set _(menulast) {}
    if {[info exists _($path)]} {
        set _(afterid) [after 1000 [list ::tko::tip::show $path {*}$_($path)]]
    }
}

# Menu motion event.
# path  - name of widget to show tip for
proc ::tko::tip::menumotion {path} {
    variable _
    # Menu events come from a funny path, map to the real path.
    if {[string first {#} $path]!=-1} {
        set myM [string map {"#" "."} [winfo name $path]]
    } else {
        set myM $path
    }
    set myCur   [$path index active]
    # Emulate <<MenuSelect>>
    if {"$myM,$myCur" eq $_(menulast)} return
    ::tko::tip::hide
    set _(menulast) "$myM,$myCur"
    if {[info exists _($myM,$myCur)]} {
        set _(afterid) [after 1000 [list ::tko::tip::show $path {*}$_($myM,$myCur)]]
    } else {
        set _(afterid) {}
    }
}

# Change index in given path event.
# path  - name of widget to show tip for
# index - index of menu or other item under path
proc ::tko::tip::tipindex {path index} {
    variable tip
    ::tko::tip::hide
    if {[info exists _($path,$index)]} {
        set _(afterid) [after 1000 [list ::tko::tip::show $path {*}$_($path,$index)]]
    }
}

# Hide currently displayed tip widget.
proc ::tko::tip::hide {} {
    variable _
    after cancel $_(afterid)
    set _(afterid) {}
    catch {wm withdraw $_(widget)}
}

# Initialize tip widget.
proc ::tko::tip::init {} {
    # build internal widget
    set w $::tko::tip::_(widget)
    catch {destroy $w}
    toplevel $w -class Tkotip
    if {[tk windowingsystem] eq {aqua}} {
        ::tk::unsupported::MacWindowStyle style $w help none
    } else {
        wm overrideredirect $w 1
    }
    catch {wm attributes $w -topmost 1}
    catch {wm attributes $w -alpha 0.99}
    wm positionfrom $w program
    wm withdraw $w
    ::frame $w.f\
        -relief         solid\
        -borderwidth    1\
        -background     #ffffd0
    ::grid $w.f
    ::grid columnconfigure $w.f 1 -weight 1
    ::label $w.f.l\
        -background #ffffd0\
        -fg         black\
        -padx       1\
        -pady       1\
        -justify    left\
        -compound   left\
        -font       TkTooltipFont
    ::grid $w.f.l -sticky w
    ::label $w.f.i\
        -background #ffffd0\
        -fg         black\
        -padx       3\
        -pady       3\
        -justify    left\
        -font       TkTooltipFontItalic
    ::grid $w.f.i -sticky w
}
::tko::tip::init;# call to initialize data and create internal widget
rename ::tko::tip::init {};# remove proc after use

# vim: set ts=4 sw=4 sts=4 et :
