** Description **

[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. 

[WikiDbImage triangle.jpg]

======
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 {
        lassign $xy g($p,x) g($p,y)
    }
}
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} {
          lassign [$w coords $p] x0 y0
      $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
    lassign [$w coords $name] x y
    set ::info "$name x:$x y:[= {-$y}]"
}
proc angle {w x y} {
    set angles {}
    foreach id [$w find withtag point] {
        lassign [$w coords $id] x0 y0
        if {$x==$x0 && $y==$y0} continue
        lappend angles [expr {atan2($y-$y0,$x-$x0)}]   
    }
    lassign $angles a1 a2
    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
======

<<categories>> Category Toys | Arts and Crafts of Tcl-Tk Programming | RS