#! /usr/local/tcl/bin/wish

#	   ___    0  Michel Beaudouin-Lafon        e-mail: mbl@lri.fr
#	  /   \  /   LRI - Bat 490                 www   : http://www-ihm.lri.fr/~mbl
#	 /  __/ /    Universite de Paris-Sud       voice : +33 1 69 15 69 10
#	/__   \/     91 405 ORSAY Cedex - FRANCE   fax   : +33 1 69 15 65 86
#
#	Cet exemple illustre un mode original de deplacement des objets
# 	dans un editeur de dessins, base sur un modele physiqe (cinematique).

# detruire eventuellement ce qui est deja dans l'interface
catch {eval destroy [winfo children .]}

# creer un canvase
pack [canvas .c] -fill both -expand on

# creer un objet.
# On utilise un tableau global G pour stocker les valeurs
# des champs des objets : chaque objet a un identificateur unique ($id).
# On stocke la valeur du champ x de l'objet dans G($id.x)
proc Object {id} {
	global G
	set xG 0
	set yG 0
	set n 0
	foreach {x y} [.c coords $id] {
		set xG [expr $xG + $x]
		set yG [expr $yG + $y]
		incr n
	}
	set G($id.x) [expr $xG / $n]
	set G($id.y) [expr $yG / $n]
}

# liaison d'evenement lorsque l'on clique sur un objet
.c bind all <ButtonPress-1> {
	.c addtag dragged withtag current
	global MouseX MouseY
	set MouseX %x
	set MouseY %y
}

# liaison d'evenement lorsque l'on deplace un objet
# la procedure Track s'occupe de calculer la nouvelle position de l'objet
.c bind dragged <Button1-Motion> {
	global MouseX MouseY
	
	set id [.c find withtag dragged]
	Track $id $MouseX $MouseY %x %y
	update idletasks
	set MouseX %x
	set MouseY %y
}

# liaison d'evenement lorsque l'on a fini de deplacer un objet
.c bind all <ButtonRelease-1> {
	.c dtag dragged
}

# procedure qui calcule la nouvelle configuration de l'objet.
# le principe est que si l'on a clique sur l'objet en un point M
# que le centre de gravite de l'objet est G, et que l'on deplace
# M en M', la nouvelle position de G va etre autant que possible
# alignee avec MM'. Un peu de geometrie donne les expressions ci-dessous...
proc Track {id xM0 yM0 xM1 yM1} {
	global G
	
	set coords [.c coords $id]
	set xG $G($id.x)
	set yG $G($id.y)
	
	set dxM0 [expr $xM0 - $xG]
	set dyM0 [expr $yM0 - $yG]
	set dxM1 [expr $xM1 - $xG]
	set dyM1 [expr $yM1 - $yG]

	set norm [expr sqrt($dxM0*$dxM0 + $dyM0*$dyM0) \
		* sqrt($dxM1*$dxM1 + $dyM1*$dyM1)]
	set cosa [expr ($dxM0*$dxM1 + $dyM0*$dyM1) / $norm]
	set sina [expr ($dxM0*$dyM1 - $dyM0*$dxM1) / $norm]
	
	set new {}
	foreach {x y} $coords {
		set dx [expr $x - $xM0]
		set dy [expr $y - $yM0]
		set x1 [expr $dx*$cosa - $dy*$sina + $xM1]
		set y1 [expr $dx*$sina + $dy*$cosa + $yM1]
		lappend new $x1 $y1
	}
	
	eval .c coords $id $new
	
	set dx [expr $xG - $xM0]
	set dy [expr $yG - $yM0]
	set G($id.x) [expr $dx*$cosa - $dy*$sina + $xM1]
	set G($id.y) [expr $dx*$sina + $dy*$cosa + $yM1]
}

# creer 3 objets pour tester
Object [.c create polygon 10 10 100 10 100 50 10 50 -fill red]
Object [.c create line 200 200 300 300 -width 10 -fill green]
Object [.c create polygon 200 50 150 100 250 100 -fill blue]


wm geometry . 400x400