##+##########################################################################
#
# Canvas Annotations -- draws movable annotations on a canvas
# by Keith Vetter -- April 2009
#

namespace eval ::Annotations {
    variable S
    array set S {radius 5 optimalWidth 12 color lightyellow}
    variable A
    unset -nocomplain A
}

proc ::Annotations::Draw {w aid txt ax ay {dx 0} {dy 20}} {
    variable A
    variable S
    .c delete $aid

    set A($w,$aid,pt) [list $ax $ay]
    set A($w,$aid,doShout) 1  ;# Allows you do disable shout outs
    
    set x [expr {$ax + $dx}]
    set y [expr {$ay + $dy}]
    set anchor [expr {$dy < 0 ? "s" : "n"}]
    $w create text $x $y -tag [list $aid $aid,txt] \
        -text $txt -anchor $anchor -justify c
    set xy [::Annotations::GetShoutXY $w $aid]
    $w create poly $xy -tag [list $aid $aid,box] \
                -fill $S(color) -outline black -smooth 1
    $w raise $aid,txt $aid,box
    
    $w bind $aid <Button-1> [list ::Annotations::Button click %W $aid %x %y]
    $w bind $aid <B1-Motion> [list ::Annotations::Button move %W $aid %x %y]
    $w bind $aid <ButtonRelease-1> [list ::Annotations::Button release %W $aid %x %y]
}

proc ::Annotations::UpdateShout {w aid} {
    variable A
    set xy [::Annotations::GetShoutXY $w $aid]
    $w coords $aid,box $xy
}


##+##########################################################################
# 
# ::Annotations::GetShoutXY -- Returns coords for postit box which will
# have a) rounded corners and b) a shout out.
# 
proc ::Annotations::GetShoutXY {w aid} {
    variable A
    variable S

    # Get bbox of the text with some padding
    foreach xy {x0 y0 x1 y1} val [$w bbox $aid,txt] dxy {-3 -1 3 1} {
        set $xy [expr {$val + $dxy}]
    }
    set xy [::Annotations::RoundRectXY $x0 $y0 $x1 $y1 $S(radius)]
    set A($w,$aid,shout) [list - -]
    if {! $A($w,$aid,doShout)} { return $xy }

    # Determine side arrow should come out of
    set side ""
    foreach {ax ay} $A($w,$aid,pt) break
    if {$ay < $y0} { set side N }
    if {$ay > $y1} { set side S }
    if {$side eq "" && $ax < $x0} { set side W }
    if {$side eq "" && $ax > $x1} { set side E }
    
    if {$side eq "N" || $side eq "S"} {
        set dx0 [expr {$x0+15}]
        set dx1 [expr {$dx0 + $S(optimalWidth)}]
        if {$dx1 > $x1-2*$S(radius)} {          ;# Too big?
            set dx0 [expr {$x0 + 2*$S(radius)}]
            set dx1 [expr {$x1 - 2*$S(radius)}]
            if {$dx1 <= $dx0} {                 ;# Still too big?
                set dx0 [expr {($x0+$x1)/2 - 1}]
                set dx1 [expr {($x0+$x1)/2}]
            }
        }
        if {$side eq "N"} {
            set shoutXY [linsert $xy 4 \
                             $dx0 $y0 $dx0 $y0 $dx0 $y0 \
                             $ax $ay $ax $ay $ax $ay \
                             $dx1 $y0 $dx1 $y0 $dx1 $y0]
            set A($w,$aid,shout) [list $side $y0]
        } else {
            set shoutXY [linsert $xy 16 \
                             $dx1 $y1 $dx1 $y1 $dx1 $y1 \
                             $ax $ay $ax $ay $ax $ay \
                             $dx0 $y1 $dx0 $y1 $dx0 $y1]
            set A($w,$aid,shout) [list $side $y1]
        }
        return $shoutXY
    }
    if {$side eq "W" || $side eq "E"} {
        set dy0 [expr {$y0 + 2*$S(radius)}]
        set dy1 [expr {$dy0 + $S(optimalWidth)}]
        if {$dy1 <= $dy0} {
            set dy0 [expr {($y0+$y1)/2 - 1}]
            set dy1 [expr {($y0+$y1)/2}]
        }
        if {$side eq "W"} {
            set shoutXY [linsert $xy 22 \
                             $x0 $dy1 $x0 $dy1 $x0 $dy1 \
                             $ax $ay $ax $ay $ax $ay \
                             $x0 $dy0 $x0 $dy0 $x0 $dy0]
            set A($w,$aid,shout) [list $side $x0]
        } else {
            set shoutXY [linsert $xy 10 \
                             $x1 $dy0 $x1 $dy0 $x1 $dy0 \
                             $ax $ay $ax $ay $ax $ay \
                             $x1 $dy1 $x1 $dy1 $x1 $dy1]

            set A($w,$aid,shout) [list $side $x1]
        }
        return $shoutXY
    }
    return $xy
}


proc ::Annotations::Button {what w aid x y} {
    variable A

    if {$what eq "click"} {
        $w itemconfig $aid,box -width 3
        $w config -cursor fleur
        set x [$w canvasx $x] ; set y [$w canvasy $y]
        set A($w,$aid,cxy) [list $x $y]
        foreach {side val} $A($w,$aid,shout) break
        set A($w,$aid,keepAnchor) 1
        if {($side eq "N" && $y < $val) ||
            ($side eq "S" && $y > $val)} {
            set A($w,$aid,keepAnchor) 0
        }
    } elseif {$what eq "release"} {
        $w itemconfig $aid,box -width 1
        $w config -cursor {}
    } elseif {$what eq "move"} {
        set x [$w canvasx $x] ; set y [$w canvasy $y] 
        foreach {ox oy} $A($w,$aid,cxy) break           ;# Where it was
        set dx [expr {$x - $ox}]
        set dy [expr {$y - $oy}]
        set A($w,$aid,cxy) [list $x $y]

        $w move $aid $dx $dy
        if {$A($w,$aid,keepAnchor)} {
            ::Annotations::UpdateShout $w $aid
        } else {
            foreach {ax ay} $A($w,$aid,pt) break
            set ax [expr {$ax + $dx}]
            set ay [expr {$ay + $dy}]
            set A($w,$aid,pt) [list $ax $ay]
        }
    }
}
##+##########################################################################
# 
# ::Annotations::RoundRectXY -- Returns coordinate list for rounded rectangle
# 
proc ::Annotations::RoundRectXY {x0 y0 x3 y3 radius} {

    set r [winfo pixels . $radius]
    set d [expr {2 * $r}]

    # Make sure that the radius of the curve is less than 3/8
    # size of the box!

    set maxr 0.75

    if { $d > $maxr * ($x3 - $x0) } {
        set d [expr { $maxr * ($x3 - $x0) }]
    }
    if { $d > $maxr * ($y3 - $y0) } {
        set d [expr { $maxr * ($y3 - $y0) }]
    }

    set x1 [expr {$x0 + $d}]
    set x2 [expr {$x3 - $d}]
    set y1 [expr {$y0 + $d}]
    set y2 [expr {$y3 - $d}]

    set xy {}
    lappend xy $x0 $y0
    lappend xy $x1 $y0
    lappend xy $x2 $y0
    lappend xy $x3 $y0
    lappend xy $x3 $y1
    lappend xy $x3 $y2
    lappend xy $x3 $y3
    lappend xy $x2 $y3
    lappend xy $x1 $y3
    lappend xy $x0 $y3
    lappend xy $x0 $y2
    lappend xy $x0 $y1
    return $xy
}

################################################################
#
# Demo code
#
package require Tk
label .title -text "Canvas Annotations" -font {Helvetica 36 bold}
canvas .c -width 500 -height 500 -bg cyan -bd 2 -relief ridge
pack .title .c -side top

.c create rect 100 100 130 200 -fill red
::Annotations::Draw .c id1 "This is a\nred square" 115 200

.c create oval 200 120 260 180 -fill yellow
::Annotations::Draw .c id2 "This is a\nyellow circle" 230 120 0 -20

.c create poly 350 100 400 200 300 200 -fill blue
::Annotations::Draw .c id3 "This is a\nblue triangle" 375 150 30 -20

set    txt "These annotations, once positioned, can be moved\n"
append txt "anywhere just by dragging them around the screen,\n"
append txt "all the while staying linked to its anchor. If you\n"
append txt "grab on the 'arrow' part then the whole annotation\n"
append txt "gets moved."

.c create oval 140 290 160 310 -fill black
::Annotations::Draw .c id4 $txt 150 300 90 30
return