# draw_geometry.tcl --
 #    Draw and manipulate (plane) geometrical objects. Well, it is
 #    merely an illustration of what I mean by "geometrical drawing app"
 #

 # PixelPoint --
 #    Compute pixel coordinates
 # Arguments:
 #    x         X-coordinate/point
 #    y         Y-coordinate/point
 #    type      Type of object
 # Result:
 #    List of pixel coordinates
 #
 proc PixelPoint {x {y {}} {type {}}} {
     if { $y == {} } {
         set px [lindex $x 1]
         set py [lindex $x 2]
         return [list [expr {$px*100+200}] [expr {-$py*100+200}]]
     }
     if { $type == "oval" } {
         return [list [expr {$x*100+200-2}] [expr {-$y*100+200-2}] \
                      [expr {$x*100+200+2}] [expr {-$y*100+200+2}]]
     }
 }

 # point --
 #    Create (and draw) a point at given coordinates
 # Arguments:
 #    x         X-coordinate
 #    y         Y-coordinate
 # Result:
 #    A point at the given coordinates
 #
 proc point {x y} {
     .c create oval [PixelPoint $x $y oval] -fill black
     return [list POINT $x $y]
 }

 # line --
 #    Create (and draw) a line through two points
 # Arguments:
 #    point1    First point
 #    point2    Second point
 # Result:
 #    A line through the two points
 #
 proc line {point1 point2} {
     .c create line [concat [PixelPoint $point1] [PixelPoint $point2]] -fill black
     return [list LINE $point1 $point2]
 }

 # circle --
 #    Create (and draw) a circle at given coordinates
 # Arguments:
 #    point     Centre of the circle
 #    rad       Radius
 # Result:
 #    A circle at the given centre and given radius
 #
 proc circle {point rad} {
     set x  [lindex $point 1]
     set y  [lindex $point 2]
     set p1 [list POINT [expr {$x+$rad}] [expr {$y+$rad}]]
     set p2 [list POINT [expr {$x-$rad}] [expr {$y-$rad}]]
     .c create oval [concat [PixelPoint $p1] [PixelPoint $p2]] -outline black
     return [list CIRCLE $point $rad]
 }

 # distance --
 #    Compute the distance between two objects
 # Arguments:
 #    obj1      Point, line, ...
 #    obj2      Point, line, ...
 # Result:
 #    Distance between the given objects (now: only points)
 #
 proc distance {obj1 obj2} {
     if { [lindex $obj1 0] == "POINT" } {
         set px1 [lindex $obj1 1]
         set py1 [lindex $obj1 2]
         if { [lindex $obj2 0] == "POINT" } {
             set px2 [lindex $obj2 1]
             set py2 [lindex $obj2 2]
             return [expr {hypot($px2-$px1,$py2-$py1)}]
         } else {
             error "Types unsupported"
         }
     } else {
         error "Types unsupported"
     }
 }

 # inprod --
 #    Compute the inproduct of two vectors
 # Arguments:
 #    vect1     First vector
 #    vect2     Second vector
 # Result:
 #    Inproduct
 #
 proc inprod {vect1 vect2} {
     set vx1 [lindex $vect1 1]
     set vy1 [lindex $vect1 2]
     set vx2 [lindex $vect2 1]
     set vy2 [lindex $vect2 2]

     return [expr {$vx1*$vx2+$vy1*$vy2}]
 }

 # pointonline --
 #    Compute the coordinates of a point on a line
 # Arguments:
 #    line      Line in question
 #    lambda    Parameter value
 # Result:
 #    Point on the line
 #
 proc pointonline {line lambda} {
     set v   [vectorfromline $line]

     set vx  [lindex $v 1]
     set vy  [lindex $v 2]
     set px  [lindex $line 1 1]
     set py  [lindex $line 1 2]
     set x   [expr {$px+$lambda*$vx}]
     set y   [expr {$py+$lambda*$vy}]

     return [point $x $y] ;# Make it visible
 }

 # vectorfromline --
 #    Compute the directional vector of a line
 # Arguments:
 #    line      Line in question
 # Result:
 #    Vector in the direction of the line
 #
 proc vectorfromline {line} {
     set px1 [lindex $line 1 1]
     set py1 [lindex $line 1 2]
     set px2 [lindex $line 2 1]
     set py2 [lindex $line 2 2]
     set vx  [expr {$px2-$px1}]
     set vy  [expr {$py2-$py1}]

     return [list VECTOR $vx $vy]
 }

 # diffvector --
 #    Compute the vector from one point to the next
 # Arguments:
 #    point1    First point
 #    point2    Second point
 # Result:
 #    Vector
 #
 proc diffvector {point1 point2} {
     set px1 [lindex $point1 1]
     set py1 [lindex $point1 2]
     set px2 [lindex $point2 1]
     set py2 [lindex $point2 2]
     set vx  [expr {$px2-$px1}]
     set vy  [expr {$py2-$py1}]

     return [list VECTOR $vx $vy]
 }

 # normal --
 #    Compute the normal vector to another vector or a line
 # Arguments:
 #    obj       Directed object
 # Result:
 #    Vector normal to the direction of the object
 #
 proc normal {obj} {
     if { [lindex $obj 0] == "LINE" } {
         set obj [vectorfromline $obj]
     }

     set vy  [expr {-[lindex $obj 1]}]
     set vx  [lindex $obj 2]
     set len [expr {hypot($vx,$vy)}]

     return [list VECTOR [expr {$vx/$len}] [expr {$vy/$len}]]
 }

 # intersect --
 #    Compute the intersection between two objects
 # Arguments:
 #    obj1      line, circle, ...
 #    obj2      line, circle, ...
 # Result:
 #    One point or a collection of points (now: only lines)
 #
 proc intersect {obj1 obj2} {
     if { [lindex $obj1 0] == "LINE" } {
         #
         # Construct the equation for the line obj1
         #
         set n1 [normal $obj1]
         set p1 [lindex $obj1 1]

         if { [lindex $obj2 0] == "LINE" } {
             #
             # Get the parametrisation of the line obj2
             #
             set v2     [vectorfromline $obj2]
             set p2     [lindex $obj2 1]
             set lambda [expr {[inprod [diffvector $p2 $p1] $n1]/ \
                               [inprod $v2 $n1]}]
             return [pointonline $obj2 $lambda]
         } else {
             error "Types unsupported"
         }
     } else {
         error "Types unsupported"
     }
 }

 #
 # Create the standard canvas
 #
 pack [canvas .c -width 400 -height 400 -bg white]

 #
 # Simple illustration:
 # Define two lines, get their intersection and draw a circle with that
 # point as the centre.
 #

 set P1 [point 0 0]
 set P2 [point 1 1]
 set P3 [point 1 0.5]
 set P4 [point 0.1 0.5]
 set L1 [line $P1 $P2]
 set L2 [line $P3 $P4]
 set P5 [intersect $L1 $L2]
 puts $P5
 set r  [distance $P2 $P1]
 set C  [circle $P5 $r]