#!/bin/sh
#\
exec wish "$0" "$@"

###############################################################################
# file    : introspact.tcl
# content : run-time introspection of PAC agents
# history : 2007-Oct-18 - [rb] inital version
#           2007-Oct-22 - [rb] allow to reopen details on agent
#                         [rb] allow reparent
#           2007-Oct-23 - [rb] allow to change animation delay
#           2007-Oct-24 - [rb] adapt size of canvas to its content
#           2007-Nov-12 - [rb] switched to active value in details view
#                         [rb] close details if object disappears
# todo    : - enable method call
#           - enable links in details view
###############################################################################


# Inspect #####################################################################

# InspectP --
#
#   inpector is just a presentation, it uses the generic Control as controler

inherit InspectP Presentation
method InspectP constructor {control agent} {
	this inherited $control
	
	set this(window) [toplevel .w_$control]
	wm title $this(window) "$agent details"
	wm protocol $this(window) WM_DELETE_WINDOW "$this(control) dispose"

	# attributes
	pack [frame $this(window).attr] -side top -fill both
	pack [label $this(window).attr.label -text "attributes" -bg black -fg white -anchor w -padx 2 -pady 2] -side top -fill x
	
	global $agent
	foreach name [array names $agent] {
		pack [frame $this(window).attr.a_$name] -side top -fill x
		pack [label $this(window).attr.a_$name.name -text "$name: " -anchor w -padx 2] -side left 
		pack [label $this(window).attr.a_$name.value -textvariable ${agent}($name) -anchor e -padx 2] -side right
	}
	
	# methods
	pack [frame $this(window).meth] -side top -fill both
	pack [label $this(window).meth.label -text "methods" -bg black -fg white -anchor w -padx 2 -pady 2] -side top -fill x
	set classes [gmlObject info classes $agent]
	
	foreach class $classes {
		pack [frame $this(window).meth.h_$class -bg grey -padx 2 -pady 2] -side top -fill x
		pack [label $this(window).meth.h_$class.name -text "${class}::" -bg grey -anchor w] -side left -fill x
		pack [label $this(window).meth.h_$class.show -text "show" -bd 2 -relief raise] -side right
		bind $this(window).meth.h_$class.show <1> "$objName show $class show"
		
		frame $this(window).meth.c_$class
		foreach {m c name a} [gmlObject info interface $class] {
			set args [gmlObject info args $class $name]
			pack [frame $this(window).meth.c_$class.m_$name -padx 1] -side top -fill x
			pack [label $this(window).meth.c_$class.m_$name.name -text "$name " -anchor nw] -side left -fill y
			pack [label $this(window).meth.c_$class.m_$name.value -text "$args" -fg #777 -anchor nw] -side right -fill x
		}
	}	
	this show [lindex $classes 0]
	
	# delay
	pack [frame $this(window).delay] -side top -fill both
	pack [label $this(window).delay.label -text "delay" -bg black -fg white -anchor w -padx 2 -pady 2] -side top -fill x

	pack [checkbutton $this(window).delay.switch -command "$objName toggle $agent" -variable __delay(switch,$agent)] -side left -fill y
	pack [scale $this(window).delay.scale -orient horizontal -to 1000 -width 10 -variable __delay(delay,$agent)] -side left -fill y
	this toggle $agent
}

method InspectP toggle {agent} {
	global __delay
	if {$__delay(switch,$agent)} {
		$this(window).delay.scale configure -state active
	} else {
		$this(window).delay.scale configure -state disabled
	}
}

method InspectP show {klass {show "show"}} {
	if {$show == "show"} {
		pack $this(window).meth.c_$klass -side top -fill x -after $this(window).meth.h_$klass
		set show "hide"
	} else {
		pack forget $this(window).meth.c_$klass
		set show "show"
	}
	
	$this(window).meth.h_$klass.show configure -text $show
	bind $this(window).meth.h_$klass.show <1> "$objName show $klass $show"
}

method InspectP destructor {} {
	destroy $this(window)
}


# Introspact #################################################################

# IntrospactA --
#
#   introspac functionnal core

inherit IntrospactA Abstraction
method IntrospactA constructor {control {agent ""}} {
	this inherited $control
	
	set this(agent) ""
	this attach $agent
}

method IntrospactA destructor {} {
	this detach
}

method IntrospactA attach {agent} {
	this detach

	set this(call_stack) {}
	set this(agent) $agent

	this wrap $this(agent)
}

method IntrospactA detach {} {
	this wrap $this(agent) remove
	set this(agent) ""
}

method IntrospactA wrap {agent {action add}} {
	if {$agent == ""} return
	
	# depth first traversal
	foreach child [$agent attribute children] {
		this wrap $child $action
	}

	# trace facets
	foreach facet {abstraction presentation} {
		this trace_facet [$agent attribute $facet] $action
	}
	this trace_facet $agent $action

	# trace parts (childrens, abstraction and presentation)
	global $agent
	foreach part {children abstraction presentation} {
		trace $action variable ${agent}($part) "write" "$objName manage_geometry"
	}
}

method IntrospactA trace_facet {facet action} {
	if {$facet != ""} {
		trace $action execution $facet "enter leave" "$objName manage_call_stack"
	}
}
	
method IntrospactA manage_geometry {args} {
	set agent $this(agent)
	
	this detach
	$this(control) display
	this attach $agent	
}

method IntrospactA manage_call_stack {args} {
	set cmd [lindex $args 0]
	set op [lindex $args end]

	set target [lindex $cmd 0]
	set method [lindex $cmd 1]
	set margs [lrange $cmd 2 end]
	
	if {($target == $this(agent)) && ($method == "dispose")	&& ($op == "enter")} {
		$this(control) detach
	}
	
	# special cases
	switch $method {
		attribute {
			return
		}
		dispose {
			# close potential detailed view
			set inspect_name inspect_${target}_
			if {[gmlObject info exists object $inspect_name]} {
				$inspect_name dispose
			}
			return	
		}
	}
	
	# general cases
	switch $op {
		enter {
			set caller [lindex $this(call_stack) 0]
			set this(call_stack) [linsert $this(call_stack) 0 $target]
			$this(control) render_enter $caller $target $method $margs [llength $this(call_stack)]
		}
		leave { 
			$this(control) render_leave [llength $this(call_stack)]
			set this(call_stack) [lrange $this(call_stack) 1 end]
		}
		default {
			error "unexpected op $op"
		}
	}
}


# IntrospactP --
#
#   introspact presentation

inherit IntrospactP Presentation
method IntrospactP constructor {control {agent ""}} {
	this inherited $control

	# window
	set this(window) [toplevel .w_$control]
	wm protocol $this(window) WM_DELETE_WINDOW "$control dispose"
	
	# canvas & scrollbars
	set this(canvas) [canvas $this(window).c]

	scrollbar $this(window).v -orient vertical -command "$this(canvas) yview"
	scrollbar $this(window).h -orient horizontal -command "$this(canvas) xview"
	$this(canvas) configure -yscrollcommand "$this(window).v set" \
	                        -xscrollcommand "$this(window).h set"
	
	grid rowconfigure $this(window) 0 -weight 1
	grid columnconfigure $this(window) 0 -weight 1
	grid $this(canvas) -row 0 -column 0 -sticky "nsew"
	grid $this(window).v -row 0 -column 1 -sticky "ns"
	grid $this(window).h -row 1 -column 0 -sticky "ew"
	
	# attach to PAC agent
	this attach $agent
}

method IntrospactP destructor {} {
	destroy $this(window)
}

method IntrospactP attach {agent} {
	set this(agent) $agent
	wm title $this(window) "$this(control) $agent"
	this display
}

method IntrospactP detach {} {
	this attach ""
}

method IntrospactP display {} {
	$this(canvas) delete all

	this render $this(agent)

	set bbox [$this(canvas) bbox all]
	if {$bbox != ""} {
		set MARGIN 20
		set left   [expr [lindex $bbox 0]-$MARGIN]
		set top    [expr [lindex $bbox 1]-$MARGIN]
		set right  [expr [lindex $bbox 2]+$MARGIN]
		set bottom [expr [lindex $bbox 3]+$MARGIN]
		$this(canvas) configure -scrollregion "$left $top $right $bottom"
	}
}

method IntrospactP render {agent {level 0}} {
	if {$this(agent) == ""} return
	
	if {$level == 0} { 
		set this(x) 0 
	}
	
	foreach child [$agent attribute children] {
		this render $child [expr $level+1]
	}
	this render_agent $agent $level
}


method IntrospactP render_agent {agent level} {
	set level_height 100
	set agent_width  120

	# position
	set bbox [$this(canvas) bbox child_$agent]
	if {$bbox != ""} {
		set x [center $bbox x]
	} else {
		set x $this(x)
		incr this(x) $agent_width
	}

	set y [expr $level * $level_height + 50]
	
	# abstraction, presentation
	foreach {facet dx dxt label} {abstraction -40 -2 A presentation 40 2 P} {
		set facet [$agent attribute $facet]
		if {$facet != ""} {
			set x0 [expr $x + $dx - 15]
			set x1 [expr $x0 + 30]
			set y0 [expr $y]
			set y1 [expr $y0 + 20]
			$this(canvas) create oval $x0 $y0 $x1 $y1 -fill white -tags "$facet oval_$facet"
			$this(canvas) create text [expr $x + $dx + $dxt] [expr $y + 12] -text $label -tags "$facet text_$facet"
			this bind $facet
		}
	}

	# control
	set x0 [expr $x - 40]
	set x1 [expr $x + 40]
	set y0 [expr $y - 17]
	set y1 [expr $y + 15]
	set parent [$agent attribute parent]
	$this(canvas) create oval $x0 $y0 $x1 $y1 -fill white -tags "$agent child_$parent oval_$agent"
	$this(canvas) create text $x $y -text $agent -tags "$agent text_$agent"
	this bind $agent
	
	# links to the children
	foreach child [$this(canvas) find withtag child_$agent] {
		set cbbox [$this(canvas) coords $child]
		$this(canvas) create line $x $y [center $cbbox x] [center $cbbox y] -tags link_$agent
	}
	$this(canvas) lower link_$agent $agent
	$this(canvas) lower link_$agent child_$agent
}

method IntrospactP bind {agent} {
	$this(canvas) bind $agent <Enter> "$this(canvas) itemconfigure oval_$agent -width 2"
	$this(canvas) bind $agent <Leave> "$this(canvas) itemconfigure oval_$agent -width 1"
	$this(canvas) bind $agent <1> "$objName inspect $agent"
}

method IntrospactP inspect {agent} {
	set inspect_name inspect_${agent}_
	if {[gmlObject info exists object $inspect_name]} {
		$inspect_name dispose
	}
	Control $inspect_name $this(control) "" [InspectP ${inspect_name}_pres $inspect_name $agent]
}

method IntrospactP render_enter {caller target method args depth} {
	set callerid [$this(canvas) find withtag oval_$caller]
	set targetid [$this(canvas) find withtag oval_$target]	

	# render call
	set tbbox [$this(canvas) bbox $targetid]
	if {$tbbox == ""} return
	
	set xt [center $tbbox x]
	set yt [center $tbbox y]
	
	if {$callerid == $targetid} {
		set yc [expr $yt + 20]
		set xc $xt	
		set coords [list $xt $yt [expr $xt-20] $yc [expr $xt+20] $yc $xt $yt]
	} else {
		if {$callerid != ""} {
			set cbbox [$this(canvas) bbox $callerid]
			set xc [center $cbbox x]
			set yc [center $cbbox y]	
		} else {
			set xc [expr $xt + 40]
			set yc [expr $yt - 30]
		}
		if {$xc != $xt} {
			set coords [list $xc $yc $xc $yt $xt $yt]
		} else {
			set coords [list $xc $yc $xt $yt]
		}
	}
	$this(canvas) itemconfigure arrow -width 1
	$this(canvas) create line $coords -arrow last -fill red -smooth 1 -tags "call_$depth arrow" -width 2
	$this(canvas) create text [expr $xt+10] [expr $yt+10] -fill blue -text "$method $args" -tags call_text -anchor nw
	
	# delay
	update idletask
	after [delay $target]
	$this(canvas) delete call_text
}

method IntrospactP render_leave {depth} {
	$this(canvas) delete call_$depth
}

proc center {bbox {axe x}} {
	if {$axe == "x"} {
		return [expr ([lindex $bbox 0] + [lindex $bbox 2])/2.]
	} else {
		return [expr ([lindex $bbox 1] + [lindex $bbox 3])/2.]
	}
}

proc delay {agent} {
	# delay set for this agent
	global __delay
	if {[info exists __delay(switch,$agent)]} {
		if {$__delay(switch,$agent)} {
			return $__delay(delay,$agent)
		}
	}
	
	# delay not set: find containing agent delay
	global $agent
	if {[info exists ${agent}(parent)]} {
		set parent [$agent attribute parent]
	} else {
		set parent [$agent attribute control]
	}
	
	if {$parent == ""} {
		return 0
	} else {
		return [delay $parent]
	}
}


# Introspact --
#
#   introspacter control

inherit Introspact Control
method Introspact constructor {{agent ""} {parent ""}} {
	IntrospactA ${objName}_abst $objName
	IntrospactP ${objName}_pres $objName
	this inherited $parent ${objName}_abst ${objName}_pres

	this attach $agent	
}

method Introspact destructor {} {
	this inherited
}

method Introspact attach {agent} {
	this detach
	$this(presentation) attach $agent
	$this(abstraction) attach $agent
}

method Introspact detach {} {
	foreach child $this(children) {
		$child dispose
	}
	$this(presentation) detach
	$this(abstraction) detach
}

method Introspact display {} {
	$this(presentation) display
}

method Introspact render_enter {caller target method args depth} {
	$this(presentation) render_enter $caller $target $method $args $depth
}

method Introspact render_leave {depth} {
	$this(presentation) render_leave $depth
}