Version 8 of Attracting objects on the canvas

Updated 2010-06-21 08:42:33 by arjen

Arjen Markus (8 june 2009) Inspired by the presentation on a railway signalling system at the 8th European Tclers' Meeting, I thought one aspect of that system would be easy to implement with the standard canvas. It was. Or at least: the basic idea of objects on the canvas that attract each other and reposition themselves accordingly. The devil was, as usual, in the details.

The idea is simple: objects of compatible type may need to be positioned in some alignment with each other (like pieces of railway tracks) and the user can then simply put them in each other's vicinity. A "line of force" indicates the fact that they are attracting each other. In the railway application this is done via the "magnets" extension.

The code below shows the principle: move the squares around via the mouse (hold the left button down). When they are close enough a red line appears.

AK: Is it possible to make the operation a continuous thing? For example, by defining 'close enough' as +Inf. And without the user having to move objects? Because then this might be usable as core for a 'graph layout' system. Would likely need repellent forces as well, to ensure that nodes are not pulled on top of each but keep some distance. (In the example here, the minimum distance would be whatever is needed to keep the objects side by side without gap, but not on top of each other).

AM That should be doable — but if you have many objects, you would probably want to select the ones to connect to. This can be done of course: in the railway application the connections have a "type" and for representing graphs I would imagine that only those pairs of attraction points are active that indicate the relation between the object that is moved and the others.

To turn this into an automatic graph layout system, you would be modelling a dynamic system: the forces between objects being attractive up to a certain distance and below that distance repellent. Items should be more attracted to each other when there is a connection... Hm, with tclode (or its Tcl-only cousins in Tcllib) and some expressions for the forces that should be quite doable.


# magnets.tcl --
#     Toy program to see how one could implement "magnets" in the
#     standard canvas - inspired by the demonstration of Adrien Peulvast
#     and Eric Boudaillier at the 8th EuroTcl meeting.
#
#     Note:
#     It is not quite perfect yet ... you can connect the squares
#     diagonally :)
#

# createMagnet --
#     Create a square that has four "magnets"
#
# Arguments:
#     xcentre        X coordinate of the centre of the square
#     ycentre        Y coordinate of the centre of the square
#     size           Size of the square
#
# Result:
#     None
#
proc createMagnet {xcentre ycentre size} {
    global magnet

    set xmin [expr {$xcentre-$size/2}]
    set ymin [expr {$ycentre-$size/2}]
    set xmax [expr {$xcentre+$size/2}]
    set ymax [expr {$ycentre+$size/2}]

    set item [.c create rectangle $xmin $ymin $xmax $ymax -fill blue -outline black]

    lappend magnet [list $item $xmin $ycentre $xmax $ycentre \
                               $xcentre $ymin $xcentre $ymax]
}

# updatePositions --
#     Update the coordinates of the anchor points
#
# Arguments:
#     item         Current item
#     dx           Move over that number of pixels in x-direction
#     dy           Move over that number of pixels in y-direction
#
# Result:
#     None
#
proc updatePositions {item dx dy} {
    global magnet

    set idx 0
    foreach objs $magnet {
        set mobj [lindex $objs 0]

        if { $item == $mobj } {
            set toPoints [lrange $objs 1 end]
            break
        }
        incr idx
    }

    set newpoints [list $item]
    foreach {x y} $toPoints {
        lappend newpoints [expr {$x+$dx}] [expr {$y+$dy}]
    }
    lset magnet $idx $newpoints
}

# moveSquare --
#     Move the square - handle the attracking points
#
# Arguments:
#     x              X-coordinate to where it should be moved
#     y              Y-coordinate
#
# Result:
#     None
#
proc moveSquare {x y} {
    global line
    global move
    global xpos
    global ypos
    global dxanchor
    global dyanchor
    global magnet

    if { ! $move } return

    set dx [expr {$x - $xpos}]
    set dy [expr {$y - $ypos}]

    .c move current $dx $dy

    set xpos $x
    set ypos $y

    #
    # Check if there are any "magnet" points close by
    #
    set item [.c find withtag current]

    set idx 0
    foreach objs $magnet {
        set mobj [lindex $objs 0]

        if { $item == $mobj } {
            set toPoints [lrange $objs 1 end]
            break
        }
        incr idx
    }

    set line 0
    foreach objs $magnet {
        set mobj [lindex $objs 0]

        if { $item != $mobj && ! $line } {
            set fromPoints [lrange $objs 1 end]

            foreach {xto yto} $toPoints {
                foreach {xfrom yfrom} $fromPoints {

                    if { hypot($xto-$xfrom,$yto-$yfrom) < 20 } {
                        setMagnetLine $xto $xfrom $yto $yfrom
                        set dxanchor [expr {$xfrom-$xto}]
                        set dyanchor [expr {$yfrom-$yto}]
                        set line 1
                        break
                    }
                }
                if { $line } {
                    break
                }
            }
        }
    }

    if { ! $line } {
        hideMagnetLine
    }

    updatePositions $item $dx $dy
}

# grabSquare --
#     Register which square (position)
#
# Arguments:
#     x              X-coordinate to where it should be moved
#     y              Y-coordinate
#
# Result:
#     None
#
proc grabSquare {x y} {
    global line
    global move
    global xpos
    global ypos

    set line 0
    set move 1

    set xpos $x
    set ypos $y
}

# releaseSquare --
#     Release the square - move it to a suitable position
#
# Arguments:
#     x              X-coordinate to where it should be moved
#     y              Y-coordinate
#
# Result:
#     None
#
# Note:
#     Not perfect! Motion just before release is not captured
#
proc releaseSquare {x y} {
    global line
    global move
    global dxanchor
    global dyanchor

    moveSquare $x $y

    set move 0

    if { $line } {
        .c move current $dxanchor $dyanchor
        updatePositions [.c find withtag current] $dxanchor $dyanchor
    }
}

# createMagnetLine --
#     Create a line that connects two objects flexibly
#
# Arguments:
#     None
#
# Result:
#     None
#
proc createMagnetLine {} {
    global magnetLine

    set magnetLine [.c create line 0 0 0 0 -fill {} -width 2]

}

# setMagnetLine --
#     Set the coordinates for the magnet line
#
# Arguments:
#     xto, xfrom ,yto, yfrom     Coordinates of the line
#
# Result:
#     None
#
proc setMagnetLine {xto xfrom yto yfrom} {
    global magnetLine

    .c coords $magnetLine $xfrom $yfrom $xto $yto
    .c itemconfigure $magnetLine -fill red

}

# hideMagnetLine --
#     Hide the magnet line
#
# Arguments:
#     None
#
# Result:
#     None
#
proc hideMagnetLine {} {
    global magnetLine

    .c itemconfigure $magnetLine -fill {}

}

# main --
#     Set up the canvas and put in two squares
#
pack [canvas .c -width 400 -height 400]

.c bind current <ButtonPress-1>    [list grabSquare %x %y]
.c bind current <Motion>           [list moveSquare %x %y]
.c bind current <ButtonRelease-1>  [list releaseSquare %x %y]

set move 0
createMagnetLine
createMagnet 200 200 40
createMagnet   0   0 40

Screenshots Section

http://farm5.static.flickr.com/4029/4715104662_0e34e1008f.jpg

gold added pix