#! /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
#
#	Package qui complete sm.tcl pour tester des machines a etat dans un canvas Tk.
#	Voir la documentation jointe "Machines a etat mini-tutorial".
# 	Les autres fichiers de ce repertoire sont des exemples d'utilisation.
#	

# reset state in case we reload this file
#
catch {eval destroy [winfo children .]}
catch {namespace delete StateMachine}

# Interface :
#

# barre de controle/commande en haut : boutons Reset et Quit, et etat courant

frame .top
pack .top -side top -fill x

button .reset -text Reset -command Reset
button .spy -text Spy -command Spy
button .quit -text Quit -command {destroy .}

set undef "undef"
label .machinelbl -text "Machine =" -anchor e
label .machine -text undef -width 12 -anchor w
label .eventlbl -text "Event =" -anchor e
label .event -textvariable undef -width 12 -anchor w
label .statelbl -text "State =" -anchor e
label .state -textvariable undef -width 12 -anchor w

foreach widget {reset spy quit machinelbl machine eventlbl event statelbl state} {
	pack .$widget -in .top -side left -padx 5 -pady 5
}

# canvas pour tester la machine a etat au milieu

canvas .c -width 400 -height 300 -relief sunken -borderwidth 2
pack .c -side top -fill both -expand true
focus .c

# Chargement et activation des machines a etats.
#

# chaque machine a etat chargee par la suite ajoute un bouton en bas.
# ce bouton sert a activer cette machines a etats.

source sm.tcl
package require StateMachine 1.1

set Machines(current) ""

proc Reset {} {
	global Machines
	
	DisableMachine $Machines(current)
	.c delete all
	bindtags .c {.c Canvas . all}
}

proc state_machine {name body} {
	global Machines
	StateMachine::define $name $body
#	set Machines($name) $body
	AddMachine $name
	return $name
}

proc AddMachine {name} {
	button .sm$name -text $name -command "EnableMachine $name"
	pack .sm$name -side left -padx 5 -pady 5
}

proc EnableMachine {name} {
	global Machines
	
	DisableMachine $Machines(current)
	
	StateMachine::enable $name .c
	.machine config -text $name
	.event config -textvariable $name\::_event
	.state config -textvariable $name\::_state
	
	set Machines(current) $name

	if [winfo exist .spyvars] {
		Spy
	}
}

proc DisableMachine {name} {
	global Machines
	
	if {$name != ""} {
		StateMachine::disable $Machines(current) .c
		.machine config -text undef
		.event config -textvariable undef
		.state config -textvariable undef
	}
	
	set Machines(current) ""
}	

# Espionnage des variables locales de la machine en cours
#

proc Spy {} {
	if {[winfo exist .spyvars]} {
		foreach w [winfo children .spyvars] {
			destroy $w
		}
	} else {
		toplevel .spyvars
	}
	
	global Machines
	if {$Machines(current) == ""} {
		return
	}
	
	set i 0
	grid columnconfigure .spyvars 1 -weight 1
	foreach local [namespace eval $Machines(current) {set _locals}] {
		label .spyvars.l$local -text $local
		label .spyvars.v$local -textvariable ::$Machines(current)\::$local \
			-anchor w -width 10 -relief sunken
		grid configure .spyvars.l$local -column 0 -row $i -sticky e -padx 5 -pady 5
		grid configure .spyvars.v$local -column 1 -row $i -sticky we -padx 5 -pady 5
		incr i
	}
}

# procedures utilitaires
#

proc Command {cmd} {
	button .cmd$cmd -text $cmd -command $cmd
	pack .cmd$cmd -side left -padx 5 -pady 5
}

proc PointsClose {P1 P2} {
	if {abs ([lindex $P1 0] - [lindex $P2 0]) > 3} {
		return 0
	}
	if {abs ([lindex $P1 1] - [lindex $P2 1]) > 3} {
		return 0
	}
	return 1
}

proc Delta {P1 P2} {
	set d {}
	foreach c1 $P1 c2 $P2 {
		lappend d [expr $c2 - $c1]
	}
	return $d
}	

# procedures pour creer et manipuler des objets dans le canvas
#

proc CreateLine {P1 P2 args} {
	return [eval .c create line $P1 $P2 $args]
}

proc CreateRect {P1 P2 args} {
	return [eval .c create rectangle $P1 $P2 $args]
}

proc CreatePolygon {points args} {
	set coords {}
	foreach point $points {
		eval lappend coords $point
	}
	return [eval .c create line $coords $args]
}

proc ChangeCoords {obj P1 P2} {
	eval .c coords $obj $P1 $P2
}

proc ChangeItem {obj args} {
	eval .c itemconfig $obj $args
}

proc DeleteItem {obj} {
	.c delete $obj
}

# procedures pour gerer des icones (stylisees) dans un canvas
#

proc random {min max} {
	return [expr $min + [clock clicks] % ($max - $min)]
}

proc CreateIcon {P} {
	foreach {x y} $P {}
	return [.c create rectangle $x $y [expr $x+20] [expr $y+30] -tags icon -fill white]
}

proc RandomIcon {} {
	set w [expr [.c cget -width] -20]
	set h [expr [.c cget -height] -20]
	set x [random 20 $w]
	set y [random 20 $h]
	return [CreateIcon [list $x $y]]
}

proc ShadowIcons {icons} {
	set shadows {}
	foreach icon $icons {
		lappend shadows [eval .c create rectangle [.c coords $icon]]
	}
	return $shadows
}

proc SelectIcons {icons} {
	foreach icon $icons {
		.c itemconfig $icon -fill red
		.c raise $icon
	}
}

proc DeselectIcons {icons} {
	foreach icon $icons {
		.c itemconfig $icon -fill white
	}
}

proc HiliteIcons {icons} {
	foreach icon $icons {
		.c itemconfig $icon -width 3
		.c raise $icon
	}
}

proc UnhiliteIcons {icons} {
	foreach icon $icons {
		.c itemconfig $icon -width 1
	}
}

proc MoveIcons {icons delta} {
	foreach icon $icons {
		eval .c move $icon $delta
	}
}

proc DeleteIcons {icons} {
	foreach icon $icons {
		.c delete $icon
	}
}

proc IconAtPoint {P} {
	# too bad 'find' can't take several specifications ...
	foreach item [eval .c find overlapping $P $P] {
		if {[lsearch [.c gettags $item] icon] >= 0} {
			return $item
		}
	}
	return {}
}

proc IconsInRect {P1 P2} {
	set icons {}
	# too bad 'find' can't take several specifications ...
	foreach item [eval .c find overlapping $P1 $P2] {
		if {[lsearch [.c gettags $item] icon] >= 0} {
			lappend icons $item
		}
	}
	return $icons
}