# copyright (C) 1997-2006 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

# $Id: drag.tcl,v 2.26 2006/01/28 19:16:59 jfontain Exp $

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

    set (out) circle                                                        ;# when dragging, mouse cursor shown outside a drop site
    set (in) dot                                                             ;# when dragging, mouse cursor shown inside a drop site

    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],path)
        place $(grabber) -x -1 -y -1                                                                 ;# 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 -grab 1 1]\
            [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-grab {this value} {}

    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::button1Pressed $this"
    }

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

    # public procedure to make new formats available or unavailable for data (can be invoked up to and within the validate command)
    proc provide {this {format {}} {command ?}} {
        variable ${this}provider

        if {[string length $format] == 0} {                                 ;# return existing formats for which there is a provider
            return [array names ${this}provider]
        }
        switch $command {
            ? {
                return [set ${this}provider($format)]                                ;# return existing command for specified format
            }
            {} {
                catch {unset ${this}provider($format)}                               ;# remove existing command for specified format
            }
            default {
                set ${this}provider($format) $command                                            ;# set command for specified format
            }
        }
    }

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

        if {![info exists (X)] || ![info exists (Y)]} return               ;# can be made to happen by clicking around like crazy...
        # do not actually start drag until mouse pointer is far enough, thus mimicking Windows behavior
        if {(abs($xRoot - $(X)) + abs($yRoot - $(Y))) < 5} return
        if {$switched::($this,-grab)} {
            grab $(grabber)                                                                       ;# drag cursor is used from now on
            update idletasks
        }
        set (highlight) [new highlighter]
        $(grabber) configure -cursor $(out)
        update idletasks                                                                   ;# note: drop code must not invoke update
        # place smaller regions first so that if several regions come from the same window, embedded regions can be selected:
        set (dropRegions) [lsort -command dragSite::smaller [dropSite::regions [array names ${this}provider]]]
        set (lastSite) 0
        # setup bindings after initializations above:
        if {$switched::($this,-grab)} {
            bind $(grabber) <ButtonRelease-1> "dragSite::drop $this %X %Y"
            bind $(grabber) <Button1-Motion> "dragSite::track $this %X %Y"
        } else {
            bindings::set $($this,bindings) <ButtonRelease-1> "dragSite::drop $this %X %Y"
            bindings::set $($this,bindings) <Button1-Motion> "dragSite::track $this %X %Y"
        }
    }

    proc dropSite {xRoot yRoot} {
        set path [winfo containing $xRoot $yRoot]
        foreach region $(dropRegions) {                                        ;# first try to find which drop site the cursor is in
            foreach {site container left top right bottom} $region {}
            if {($xRoot < $left) || ($xRoot > $right) || ($yRoot < $top) || ($yRoot > $bottom)} continue
            if {[contains $container $path]} {                                                              ;# in a drop site window
                return $region                                                                                               ;# done
            }
        }
        return [list 0 {} {} {} {}]                                                                          ;# not over a drop site
    }

    proc track {this xRoot yRoot} {
        foreach {site path left top right bottom} [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)
            highlighter::hide $(highlight)
            $(grabber) configure -cursor $(out)
            update idletasks
        } else {
            highlighter::show $(highlight)\
                [expr {$left - 1}] [expr {$top - 1}] [expr {$right - $left + 2}] [expr {$bottom - $top + 2}]
            $(grabber) configure -cursor $(in)
            update idletasks
        }
        set (lastSite) $site
    }

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

        if {$switched::($this,-grab)} {
            bind $(grabber) <ButtonRelease-1> {}
            bind $(grabber) <Button1-Motion> {}
            grab release $(grabber)                                                                ;# cursor before grab is restored
            update idletasks
        } else {
            bindings::set $($this,bindings) <ButtonRelease-1> {}
            bindings::set $($this,bindings) <Button1-Motion> {}
        }
        delete $(highlight); unset (highlight)
        $(grabber) configure -cursor $(out)
        update idletasks
        unset (lastSite)
        foreach {site path left top right bottom} [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)
        dropSite::dropped $site                                                                    ;# tell drop site to process data
        catch {unset data}          ;# free memory after data has been used by drop site (data may not exist... (actually happened))
    }

    proc contains {container path} {
        while {[string length $path] > 0} {
            if {[string equal $path $container]} {
                return 1
            }
            set path [winfo parent $path]
        }
        return 0
    }

    # Public procedure under certain conditions (see below).
    # Invoked when the mouse button 1 is pressed in the drag area. That event signal the eventual start of the drag procedure.
    # Normally invoked automatically by the drag implementation, but must also be invoked by the client code when the
    # <ButtonPress-1> binding does not work on the -path option widget.
    proc button1Pressed {this} {
        set path $switched::($this,-path)
        bindings::set $($this,bindings) <Button1-Motion> {}                                                         ;# reset binding
        set command $switched::($this,-validcommand)
        set (X) [winfo pointerx .]
        set (Y) [winfo pointery .]
        if {\
            ([string length $command] > 0) &&\
            ![uplevel #0 $command [expr {$(X) - [winfo rootx $path]}] [expr {$(Y) - [winfo rooty $path]}]]\
        } return
        bindings::set $($this,bindings) <Button1-Motion> "dragSite::start $this %X %Y"
    }

    proc smaller {region1 region2} {              ;# compare 2 regions (returns -1 if first smaller than second, 0 if equal, else 1)
        foreach {site container left top right bottom} $region1 {}
        set area [expr {($right - $left) * ($bottom - $top)}]
        foreach {site container left top right bottom} $region2 {}
        return [expr {$area - (($right - $left) * ($bottom - $top))}]
    }

}
