# copyright (C) 1997-2001 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

set rcsId {$Id: drag.tcl,v 2.6 2000/12/31 23:14:19 jfontain Exp $}

class dragSite {                                          ;# make a Tk widget a drag site with multiple formats support for its data

    if {![info exists (grabber)]} {
        # use a specific invisible frame so that when dragging is active, the frame is grabbed and its specific cursor is used,
        # thus preventing any interferences from source grab widget. use a specific cursor for user feedback
        set (grabber) $widget::([new frame . -background {} -width 0 -height 0 -cursor circle],path)
        place $(grabber) -x -32768 -y -32768                                                         ;# make sure frame is invisible
    }

    proc dragSite {this args} switched {$args} {
        switched::complete $this
    }

    proc ~dragSite {this} {
        variable ${this}provider
        variable draggable

        unset ${this}provider
        if {[string length $switched::($this,-path)]>0} {                                        ;# if there was an actual drag site
            delete $($this,bindings)                                                                         ;# remove drag bindings
            unset draggable($switched::($this,-path))                                              ;# unregister path as a drag site
        }
    }

    proc options {this} {
        return [list\
            [list -data {} {}]\
            [list -path {} {}]\
            [list -validcommand {} {}]\
        ]
    }

    proc set-data {this value} {       ;# a way to provide unformatted data as a default, while data is stored at the switched level
        proc unformatted {this format} {return $switched::($this,-data)}
        provide $this {} "dragSite::unformatted $this"
    }

    proc set-path {this value} {                                                                               ;# source widget path
        variable draggable

        if {$switched::($this,complete)} {
            error {option -path cannot be set dynamically}
        }
        if {![winfo exists $value]} {
            error "invalid path: \"$value\""
        }
        if {[info exists draggable($value)]} {
            error "path \"$value\" is already a drag site"                                    ;# multiple drag behavior is undefined
        }
        set draggable($value) {}                                                                     ;# register path as a drag site
        set ($this,bindings) [new bindings $value end]                                    ;# do not interfere with existing bindings
        bindings::set $($this,bindings) <ButtonPress-1> "dragSite::hit $this %x %y %X %Y"
    }

    proc set-validcommand {this value} {}       ;# command is invoked with x and y hit coordinates for widget, must return a boolean

    proc provide {this format {command 0}} {               ;# public procedure to make new formats available or unavailable for data
        variable ${this}provider

        switch $command {
            0 {
                return [set ${this}provider($format)]                                ;# return existing command for specified format
            }
            {} {
                unset ${this}provider($format)                                       ;# remove existing command for specified format
            }
            default {
                set ${this}provider($format) $command                                            ;# set command for specified format
            }
        }
    }

    proc hit {this xWidget yWidget xRoot yRoot} {
        bindings::set $($this,bindings) <Button1-Motion> {}                                                         ;# reset binding
        set command $switched::($this,-validcommand)
        if {([string length $command]>0)&&![uplevel #0 $command $xWidget $yWidget]} return
        set (x) $xWidget                                          ;# make widget and root coordinates available to provider commands
        set (y) $yWidget
        set (X) $xRoot
        set (Y) $yRoot
        bindings::set $($this,bindings) <Button1-Motion> "dragSite::start $this %X %Y"
    }

    proc start {this xRoot yRoot} {
        variable ${this}provider

        # do not actually start drag until mouse pointer is far enough, thus mimicking Windows behavior
        if {(abs($xRoot-$(X))+abs($yRoot-$(Y)))<5} return

        grab $(grabber)                                                                           ;# drag cursor is used from now on
        update idletasks

        # for the highlighting frame, use a toplevel object to make sure its path is unique
        set (highlightFrame) [new toplevel . -background {} -highlightthickness 1 -highlightbackground black]
        wm withdraw $widget::($(highlightFrame),path)
        wm overrideredirect $widget::($(highlightFrame),path) 1
        set (dropRegions) [dropSite::regions [array names ${this}provider]]                ;# note: drop code must not invoke update
        set (lastSite) 0
        # setup bindings after initializations above
        bind $(grabber) <ButtonRelease-1> "dragSite::drop $this %X %Y"
        bind $(grabber) <Button1-Motion> "dragSite::track $this %X %Y"
    }

    proc framed {x y left top right bottom} {                            ;# check whether a point is contained in a rectangular area
        return [expr {($x>=$left)&&($x<=$right)&&($y>=$top)&&($y<=$bottom)}]
    }

    proc dropSite {xRoot yRoot} {
        foreach region $(dropRegions) {                                        ;# first try to find which drop site the cursor is in
            if {[framed $xRoot $yRoot [lindex $region 1] [lindex $region 2] [lindex $region 3] [lindex $region 4]]} {
                return [lindex $region 0]                                           ;# found drop site, first element of region list
            }
        }
        return 0                                                                                             ;# not over a drop site
    }

    proc track {this xRoot yRoot} {
        set site [dropSite $xRoot $yRoot]
        if {$site==$(lastSite)} {                                                             ;# in the same drop site or in no site
            return                                                                                       ;# no change, nothing to do
        } elseif {($site==0)||[string equal $switched::($site,-path) $switched::($this,-path)]} {
            # no longer in a drop site (if drag site itself is also a drop site, it is not considered to be valid)
            wm withdraw $widget::($(highlightFrame),path)                                                 ;# hide highlighting frame
        } else {
            set frame $widget::($(highlightFrame),path)
            wm withdraw $frame                 ;# hide highlighting frame first so it shows no previously highlighted widget residue
            set path $switched::($site,-path)
            $frame configure -width [expr {[winfo width $path]+2}] -height [expr {[winfo height $path]+2}]
            showTopLevel $frame +[expr {[winfo rootx $path]-1}]+[expr {[winfo rooty $path]-1}]            ;# show highlighting frame
        }
        set (lastSite) $site
    }

    proc drop {this xRoot yRoot} {
        variable ${this}provider
        variable data

        bind $(grabber) <ButtonRelease-1> {}
        bind $(grabber) <Button1-Motion> {}
        grab release $(grabber)                                                                    ;# cursor before grab is restored
        update idletasks

        delete $(highlightFrame)
        unset (lastSite)

        set site [dropSite $xRoot $yRoot]
        unset (dropRegions)
        if {($site==0)||[string equal $switched::($site,-path) $switched::($this,-path)]} {
            return                                                               ;# no point in being able to drop data in drag site
        }

        foreach format [switched::cget $site -formats] {      ;# copy formatted data into data array so that drop site can access it
            if {[catch {set command [set ${this}provider($format)]}]} continue                           ;# skip unavailable formats
            set data($format) [uplevel #0 $command [list $format]]                   ;# invoke at global level as Tk buttons command
        }
        unset (x) (y) (X) (Y)                                                               ;# no longer needed by provider commands
        dropSite::dropped $site                                                                    ;# tell drop site to process data
        unset data                                                              ;# free memory after data has been used by drop site
    }
}
