Updated 2013-03-05 02:05:33 by pooryorick

Description  edit

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
wm geometry . 235x280+0+0