## Version 0 of Attracting objects on the canvas

Updated 2009-06-08 06:59:44 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.

```# 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
```