#! /usr/local/bin/wish -f

canvas .net -width 1000 -height 800 -background white -relief sunken
pack .net -side bottom

# init variables
set classes 0; set oldx 0; set oldy 0;
# can be change to modify classes aperance (at your own risks)
set attrH 15; set attrX 5; set captionH 30; set charSize 10

# Primitive to draw a class : it automatically fits the members (could be wrong for some names)

proc makeClass {x y caption pubAttrs protAttrs privAttrs} {
    global classes attrH attrX captionH charSize
    set classes [expr "$classes+1"]
    
    set ox [expr "$x+$attrX"]; set oy [expr "$y+$captionH"]
    set maxl [string length $caption]

    for {set i 0} {$i < [llength $pubAttrs] } {incr i} {
	set oy [expr "$oy+$attrH"];
	.net create text $ox $oy -tag pubattr$classes$i -text [lindex $pubAttrs $i] -anchor w \
		-font -*-courier-medium-r-*-*-12-*
	if {$maxl < [string length [lindex $pubAttrs $i]]} {
	    set maxl [string length [lindex $pubAttrs $i]]
	}
    }
    set oy1 [expr "$oy+$attrH"];
    set oy [expr "$oy+$attrH"];

    for {set i 0} {$i < [llength $protAttrs] } {incr i} {
	set oy [expr "$oy+$attrH"];
	.net create text $ox $oy -tag protattr$classes$i -text [lindex $protAttrs $i] -anchor w \
		-font -*-courier-medium-r-*-*-12-*
	if {$maxl < [string length [lindex $protAttrs $i]]} {
	    set maxl [string length [lindex $protAttrs $i]]
	}
    }
    set oy2 [expr "$oy+$attrH"];
    set oy [expr "$oy+$attrH"];

    for {set i 0} {$i < [llength $privAttrs] } {incr i} {
	set oy [expr "$oy+$attrH"];
	.net create text $ox $oy -tag privattr$classes$i -text [lindex $privAttrs $i] -anchor w \
		-font -*-courier-medium-r-*-*-12-*
	if {$maxl < [string length [lindex $privAttrs $i]]} {
	    set maxl [string length [lindex $privAttrs $i]]
	}
    }
    set oy [expr "$oy+$attrH"];

    set x2 [expr "$x+$maxl*$charSize+10"];
    .net create text [expr "$x+($x2-$x)/2"] [expr "$y+($captionH)/2"] -tag caption$classes \
	    -text $caption -font -*-helvetica-bold-r-*-*-14-*
    .net create rectangle $x $y $x2 $oy -tag rect$classes
    .net create line $x [expr "$y+$captionH"] $x2 [expr "$y+$captionH"] -tag captionLine$classes
    .net create line $x $oy1 $x2 $oy1 -tag pubprotLine$classes
    .net create line $x $oy2 $x2 $oy2 -tag protprivLine$classes
     
    # these are the possible actions a user can perform on the classes
    .net bind rect$classes <Enter> ".net itemconfigure rect$classes -width 5"
    .net bind rect$classes <Leave> ".net itemconfigure rect$classes -width 1"
    .net bind rect$classes <ButtonPress-1> "beginmove %x %y"
    .net bind rect$classes <B1-Motion> "moveClass $classes [llength $pubAttrs] [llength $protAttrs] \
	    [llength $privAttrs] %x %y" 
}


# this primitive gives the begining,intermediate and ending points the link should follow to be 
# drawn between two classes.

proc getRelationPoints {classId1 classId2} {
    set bbox1 [.net bbox rect$classId1]; set bbox2 [.net bbox rect$classId2]
    set mx1 [expr "([lindex $bbox1 0]+[lindex $bbox1 2])/2"]
    set mx2 [expr "([lindex $bbox2 0]+[lindex $bbox2 2])/2"]
    set my1 [expr "([lindex $bbox1 1]+[lindex $bbox1 3])/2"]
    set my2 [expr "([lindex $bbox2 1]+[lindex $bbox2 3])/2"]
    if {[lindex $bbox2 0] > [lindex $bbox1 2]} {
	set xorig [lindex $bbox1 2]; set yorig $my1
	if {$my1 <= [lindex $bbox2 3] && $my1 >= [lindex $bbox2 1]} {
	    set xdest [lindex $bbox2 0]; set ydest $my1; set xint [expr "($mx2+$mx1)/2"]; set yint $my1
	} else {
	    if {$my1 < [lindex $bbox2 3]} {
		set ydest [lindex $bbox2 1]; set xdest $mx2; set yint $my1; set xint $mx2
	    } else {
		set ydest [lindex $bbox2 3]; set xdest $mx2; set yint $my1; set xint $mx2
	    }
	}
	return "$xorig $yorig $xint $yint $xdest $ydest"
    }

    if {[lindex $bbox1 0] > [lindex $bbox2 2]} {
	set xorig [lindex $bbox1 0]; set yorig $my1
	if {$my1 <= [lindex $bbox2 3] && $my1 >= [lindex $bbox2 1]} {
	    set xdest [lindex $bbox2 2]; set ydest $my1; set xint [expr "($mx1+$mx2)/2"]; set yint $my1
	} else {
	    if {$my1 < [lindex $bbox2 3]} {
		set ydest [lindex $bbox2 1]; set xdest $mx2; set yint $my1; set xint $mx2
	    } else {
		set ydest [lindex $bbox2 3]; set xdest $mx2; set yint $my1; set xint $mx2
	    }
	}
	return "$xorig $yorig $xint $yint $xdest $ydest"
    }

    if {$my1 > $my2} {
	set xorig $mx1; set yorig [lindex $bbox1 1]
	set xint1 $mx1; set yint1 [expr "([lindex $bbox2 3]+[lindex $bbox1 1])/2"]
	set xint2 $mx2; set yint2 $yint1
	set xdest $mx2; set ydest [lindex $bbox2 3]
    } else {
	set xorig $mx1; set yorig [lindex $bbox1 3]
	set xint1 $mx1; set yint1 [expr "([lindex $bbox2 1]+[lindex $bbox1 3])/2"]
	set xint2 $mx2; set yint2 $yint1
	set xdest $mx2; set ydest [lindex $bbox2 1]
    }
    return "$xorig $yorig $xint1 $yint1 $xint2 $yint2 $xdest $ydest"
}

# makes a relation using the "getRelationPoints" primitive

proc makeRelation {classId1 classId2} {
    eval {.net create line} [getRelationPoints $classId1 $classId2] \
	    {-tag rel$classId1$classId2}
    .net addtag rel$classId2$classId1 withtag rel$classId1$classId2
}

# register the old position of the mouse

proc beginmove {x y} {
	global oldx oldy
	set oldx $x; set oldy $y
}

# move the class from (x-oldx, y-oldy)

proc moveClass {classId nPubAttrs nProtAttrs nPrivAttrs x y} {
    global oldx oldy classes 
    .net move rect$classId [expr "$x - $oldx"] [expr "$y - $oldy"]
    .net move caption$classId [expr "$x - $oldx"] [expr "$y - $oldy"]
    .net move captionLine$classId [expr "$x - $oldx"] [expr "$y - $oldy"]
    for {set i 0} {$i < $nPubAttrs} {incr i} {
	.net move pubattr$classId$i [expr "$x - $oldx"] [expr "$y - $oldy"]
    }
    for {set i 0} {$i < $nProtAttrs} {incr i} {
	.net move protattr$classId$i [expr "$x - $oldx"] [expr "$y - $oldy"]
    }
    for {set i 0} {$i < $nPrivAttrs} {incr i} {
	.net move privattr$classId$i [expr "$x - $oldx"] [expr "$y - $oldy"]
    }
    .net move pubprotLine$classId [expr "$x - $oldx"] [expr "$y - $oldy"]
    .net move protprivLine$classId [expr "$x - $oldx"] [expr "$y - $oldy"]
    for {set i 1} {$i <= $classes} {incr i} {
	eval {.net coords rel$classId$i} [getRelationPoints $classId $i]
    }
    set oldx $x; set oldy $y
}

# the graph compiler will append the code to draw the classes after this line...



