Version 3 of A triangle toy

Updated 2007-06-29 19:29:48 by LV

if 0 {Richard Suchenwirth 2003-07-01 - Yet another educational Tcltoy to play with triangles. Corners and sides are named, and the length of each side and angle at each corner is displayed.

}

 set about "triangle.tcl
   R. Suchenwirth 2003
   Powered by Tcl/Tk!

   Draw a rectangle by clicking on three points.
   Click on a corner to see its x/y coordinates.
   Move selected corner with the cursor keys.
   Click Clear to start a new triangle."

if 0 { Challenge: construct rectangular (one angle 90°), isosceles (two angles equal), equilateral (all angles 60°) triangles - the last I haven't managed yet, because of integer pixel resolution. Stronger challenge: fix assignNames so it always maintains counter-clock sense for A, B and C. }

 proc main {} {
    frame .f
    label .f.i -width 28 -textvar info -bg white
    button .f.a -text About -command {tk_messageBox -message $about}
    button .f.c -text Clear -command {clear .c}
    button .f.x -text X -command exit
    eval pack [winfo children .f] -side left
    pack .f [canvas .c -width 230]
    .c config -scrollregion {-10 -200 200 10}
    .c create line -10 0 200 0
    .c create line 0 10 0 -200
    bind .c <1> {tap %W %x %y}
    bind .c <Up>     {movePt %W 0 -1}
    bind .c <Down> {movePt %W 0 1}
    bind .c <Left>   {movePt %W -1 0}
    bind .c <Right> {movePt %W 1 0}
    focus .c
    clear .c
 }
 proc clear w {
    $w delete my
    set ::info "Select corners of triangle"
    set ::points {}
    set ::g(point) ""
 }
 proc tap {w x y} {
    global points
    set x [= round([$w canvasx $x])]
    set y [= round([$w canvasy $y])]
    if {[llength $points]<6} {
       lappend points $x $y
       $w create rect [= $x-1] [= $y-1] [= $x+1] [= $y+1] -tags "my point"
       if {[llength $points]==6} {
          set ::info "Click on a corner to move it"
          assignNames $w
          redraw $w
       }
    }
 }
 interp alias {} = {} expr
 proc assignNames w {
    global points g
    foreach {x y} $points {
       lappend t [list $x $y [= abs($x*$y)]]
    }
    set t [lsort -int  -index 2 $t]
    foreach p {A B C} xy $t {
       foreach "g($p,x) g($p,y)" $xy break
    }
 }
 proc redraw w {
    global g
    $w delete my
    foreach p {A B C} {
       set x($p) $g($p,x)
       set y($p) $g($p,y)
    }
    foreach p {A B C} {
       $w create text $x($p) $y($p) \
         -text $p -tag "my point $p"
    }
    foreach p {A B C} {
         foreach {x0 y0} [$w coords $p] break
      $w itemconfig $p -text $p\n[angle $w $x0 $y0] -just center
    }
   $w bind point <1> {markPt %W}
   drawLine $w a $x(C) $y(C) $x(B) $y(B)
   drawLine $w b $x(A) $y(A) $x(C) $y(C)
   drawLine $w c $x(A) $y(A) $x(B) $y(B)
 }
 proc drawLine {w name x y X Y} {
    $w create line $x $y $X $Y -fill blue -tag my
   set len [format %.2f [expr {hypot($x-$X,$y-$Y)}]]
   $w create text [expr {($x+$X)/2}] [expr {($y+$Y)/2}] \
     -text "$name: $len" -tag my
 }
 proc markPt w {
    set id [$w find withtag current]
    $w itemconfig point -fill black
    set name [$w itemcget $id -text]
    set ::g(point) [string index $name 0]
    showPt $w $::g(point)
 }
 proc showPt {w name} {
    $w itemconfig $name -fill red
    foreach {x y} [$w coords $name] break
    set ::info "$name x:$x y:[= {-$y}]"
 }
 proc angle {w x y} {
    set angles {}
    foreach id [$w find withtag point] {
       foreach {x0 y0} [$w coords $id] break
       if {$x==$x0 && $y==$y0} continue
       lappend angles [expr {atan2($y-$y0,$x-$x0)}]   
    }
    foreach {a1 a2} $angles break
    set a [expr {abs($a1-$a2)*180/acos(-1.)}]
    if {$a>180} {set a [expr {360-$a}]}
    format %.2f $a
 }
 proc movePt {w dx dy} {
    global g
    set p $g(point)
    if {$p==""} return
    incr g($p,x) $dx
    incr g($p,y) $dy
    redraw $w
    showPt $w $p
 }
 main
 wm geometry . 235x280+0+0

---

Category Toys | Arts and crafts of Tcl-Tk programming