package require Tk
catch {console show}

canvas .c -width 600 -height 600
pack .c

proc makeLine {x1y1 x2y2} {
    foreach {x1 y1} $x1y1 {}
    foreach {x2 y2} $x2y2 {}
    set id [.c create line $x1 $y1 $x2 $y2 -width 10 -capstyle round]
    .c addtag stick withtag $id
    set ::list_of_attachments($id) ""
    set ::center($id.xy) "$x1 $y1"
    set ::end($id.xy) "$x2 $y2"

    set h0 [makeHandle $x2 $y2]
    mount $h0 $id

    return $id
}

proc getCenter {id} { return $::center($id.xy) }
proc setCenter {id x y} { set ::center($id.xy) "$x $y" }

proc getEnd {id} { return $::end($id.xy) }
proc setEnd {id x y} { set ::end($id.xy) "$x $y" }

proc rotateSome {id a xc yc} {
    rotateOneSome $id $a $xc $yc
    foreach child $::list_of_attachments($id) {
        rotateSome $child $a $xc $yc
    }
}
proc rotateOneSome {id a xc yc} {
    set cosa [expr {cos($a)}]
    set sina [expr {sin($a)}]

    foreach {x1 y1} [getCenter $id] {}
    set dx [expr $x1-$xc]
    set dy [expr $y1-$yc]
    set newx1 [expr {$cosa*$dx - $sina*$dy + $xc}]
    set newy1 [expr {$cosa*$dy + $sina*$dx + $yc}]

    foreach {x2 y2} [getEnd    $id] {}
    set dx [expr $x2-$xc]
    set dy [expr $y2-$yc]
    set newx2 [expr {$cosa*$dx - $sina*$dy + $xc}]
    set newy2 [expr {$cosa*$dy + $sina*$dx + $yc}]

    setCenter $id $newx1 $newy1
    setEnd $id $newx2 $newy2
    .c coords $id $newx1 $newy1 $newx2 $newy2

    set handle [getHasMount $id]
    if {$handle != -1} {
        .c coords $handle $newx2 $newy2 $newx2 $newy2
    }
}

proc makeHandle {x1 y1 {color orange} } {
    set id [.c create line $x1 $y1 $x1 $y1 -width 10 -capstyle round -fill $color]
    set ::list_of_attachments($id) ""
    .c addtag drag1 withtag $id
    .c addtag handle withtag $id
    return $id
}
proc raiseHandles {} {
    .c raise handle
}
proc mount {h1 l1} {
    set ::mounted_on($h1) $l1
    set ::has_mount($l1) $h1
}
proc getMountedOn {id} {
    if { ![info exists ::mounted_on($id) ] }  { return -1 } 
    return $::mounted_on($id) 
}
proc getHasMount {id} {
    if { ![info exists ::has_mount($id) ] }  { return -1 } 
    return $::has_mount($id) 
}
proc attach {l1 l0} {
    set ::attached_on($l1) $l0
    lappend ::list_of_attachments($l0) $l1
}
proc getAttachedOn {id} {
    return $::attached_on($id) 
}



proc canvas_movable w {
    $w bind drag1 <Button-1> "handle_press %W %x %y"
    $w bind drag1 <B1-Motion> {handle_motion %W [%W canvasx %x] [%W canvasy %y]}
}

proc handle_press {W x y} {
    set ::g(id)  [$W find withtag current]
    set mountedOn [getMountedOn $::g(id)]
    foreach {xc yc} [getCenter $mountedOn] {}
    set ::g(x) [$W canvasx $x]
    set ::g(y) [$W canvasy $y]
    set dx [expr $x-$xc]
    set dy [expr $y-$yc]
    set ::g(a) [expr atan2($dy,$dx)]
}

proc handle_motion {w xn yn} {
    set mountedOn [getMountedOn $::g(id)]
    if { $mountedOn == -1 } {
        $w move $::g(id)  [expr {$xn-$::g(x)}] [expr {$yn-$::g(y)}]
        set ::g(x) $xn
        set ::g(y) $yn
    } else {
        foreach {xc yc} [getCenter $mountedOn] {}
        set dx [expr {$xn-$xc}]
        set dy [expr {$yn-$yc}]
        set a  [expr {atan2($dy,$dx)}]
        set da [expr {$a - $::g(a)}]
    
        rotateSome $mountedOn $da $xc $yc
    
        foreach {xf yf} [getEnd $mountedOn] {}
        $w move $::g(id)  [expr {$xf-$::g(x)}] [expr {$yf-$::g(y)}]
        set ::g(x) $xf
        set ::g(y) $yf
        set ::g(a) [expr $::g(a) + $da]
    }
}

.c focus ""
canvas_movable .c

# create a simple figure.  (need to make a gui editor)
set waist "300 300"
set  neck "300 200"
set torso [makeLine $waist $neck]

set head [makeLine $neck   "286 152"]
attach $head $torso

set rUpperArm [makeLine $neck   "375 266"]
attach $rUpperArm $torso
set rLowerArm [makeLine [getEnd $rUpperArm]  "401 362"]
attach $rLowerArm $rUpperArm

set lUpperArm [makeLine $neck   "222 263"]
attach $lUpperArm $torso
set lLowerArm [makeLine [getEnd $lUpperArm]  "201 361"]
attach $lLowerArm $lUpperArm

set rUpperLeg [makeLine $waist   "340 392"]
#attach $rUpperLeg $torso
set rLowerLeg [makeLine [getEnd $rUpperLeg]  "341 492"]
attach $rLowerLeg $rUpperLeg

set lUpperLeg [makeLine $waist   "263 393"]
#attach $lUpperLeg $torso
set lLowerLeg [makeLine [getEnd $lUpperLeg]  "264 493"]
attach $lLowerLeg $lUpperLeg

raiseHandles