package require Tk
 set tcl_precision 17

 proc main argv {
    canvas .c -width 200 -height 200 -scrollregion {-50 -50 50 50}
    pack .c -fill both -expand yes;# by AvL
    reset .c
    bind .c <2> {reset .c}
 }
 proc reset w {
    $w delete all
    tan $w 0 0    0 100  50 50
    tan $w 0 100  50 50  100 100
    tan $w 0 0    25 25  75 25   50 0
    tan $w 50 0   100 0  100 50
    tan $w 25 25  75 25  50 50
    tan $w 50 50  75 25  100 50  75 75
    tan $w 75 75  100 50 100 100
    $w bind tan <1> {set ::X %x; set ::Y %y; %W raise current}
    $w bind tan <B1-Motion> {
        %W move current [expr %x-$::X] [expr %y-$::Y]
        set ::X %x
        set ::Y %y
    }
    $w bind tan <3> {rotate %W current 45}
 }
 proc tan {w args} {
    $w create poly $args -fill lightblue -outline blue -tag tan
 }
 proc rotate {w tag angle} {
    set xsum 0; set ysum 0; set n 0
    foreach {x y} [$w coords $tag] {
        set xsum [expr $xsum+$x]
        set ysum [expr $ysum+$y]
        incr n
    }
    set xm [expr $xsum/$n]
    set ym [expr $ysum/$n]
    set coords {}
    set angle [expr {$angle*acos(-1)/180}]
    foreach {x y} [$w coords $tag] {
        set r [expr {hypot($x-$xm,$y-$ym)}]
        set a [expr {atan2($y-$ym,$x-$xm)+$angle}]
        lappend coords \
            [expr {$xm+cos($a)*$r}] \
            [expr {$ym+sin($a)*$r}]
    }
    $w coords $tag $coords
 }
 main $argv