# mathanim.tcl --
#     Experiments with a little language for creating mathematical
#     animations
#
package require Tcl 8.5
rename update tk_update

# scaling --
#     Set up the canvas and coordinates
#
# Arguments:
#     min        Minimum value of the x/y axis
#     max        Maximum value of the x/y axis
#
# Result:
#     None
#
# Side effects:
#     Default square canvas set up
#
proc scaling {min max} {
    global scaling

    set scaling(min) $min
    set scaling(max) $max

    pack [canvas .c -width 500 -height 500 -bg white]

    set scaling(dx)  [expr {500.0/($max-$min)}]
    set scaling(dy)  [expr {500.0/($max-$min)}]

}

# pause --
#     Pause the program for a given amount of time
#
# Arguments:
#     delay      Delay in ms
#
# Result:
#     None
#
# Side effects:
#     Program pauses, but any GUI is still active, screen updates occur
#
proc pause {delay} {

    after $delay {set ::delayOver 1}
    vwait ::delayOver

}

# create --
#     Create an item on the canvas (type is fixed)
#
# Arguments:
#     name       Name of the item
#     itemdata   Data for the item
#
# Result:
#     None
#
# Side effects:
#     An item with the given name now exists and is possibly visible
#
proc create {name itemdata} {
    global item

    set item(type,$name) [lindex $itemdata 0]

    switch -- $item(type,$name) {
        "point"  { # Nothing to do }
        "dot"    { set item(id,$name) [.c create oval 0 0 0 0] }
        "circle" { set item(id,$name) [.c create oval 0 0 0 0] }
        "line"   { set item(id,$name) [.c create line 0 0 0 0] }
    }

    if { $item(type,$name) != "point" } {
        .c itemconfig $item(id,$name) {*}[lindex $itemdata end]
    }

    update $name {*}$itemdata
}

# update --
#     Update the properties of an item
#
# Arguments:
#     name       Name of the item
#     itemdata   Data for the item
#
# Result:
#     None
#
# Side effects:
#     The item has updated properties
#
proc update {name args} {
    global scaling
    global item

    set type $item(type,$name)

    if { $type != [lindex $args 0] } {
        error "Item $name and given data are incompatible!"
    }

    set item(data,$name) [lrange $args 1 end]

    UpdateCoords $name [lrange $item(data,$name) 0 end-1]
}

# UpdateCoords --
#     Update the canvas coordinates of an item
#
# Arguments:
#     name       Name of the item
#     coords     World coordinates for the item
#
# Result:
#     None
#
# Side effects:
#     The item is updated on the screen
#
proc UpdateCoords {name coords} {
    global item
    global scaling

    switch -- $item(type,$name) {
        "point" {
            # Not visible
        }
        "dot" {
            foreach {x y} $coords {break}
            set xd1 [expr {$scaling(dx)*($x -$scaling(min)) - 3}]
            set yd1 [expr {$scaling(dy)*($scaling(max)-$y) - 3}]
            set xd2 [expr {$scaling(dx)*($x -$scaling(min)) + 3}]
            set yd2 [expr {$scaling(dy)*($scaling(max)-$y) + 3}]

            .c coords $item(id,$name) $xd1 $yd1 $xd2 $yd2
        }
        "circle" {
            set r ""
            foreach {x y r} $coords {break}
            if { $r == "" } {
                set r [lindex $item(data,$name) 2]
            }
            set rad [expr {$scaling(dx)*$r}]
            set xd1 [expr {$scaling(dx)*($x-$scaling(min)) - $rad}]
            set yd1 [expr {$scaling(dy)*($scaling(max)-$y) - $rad}]
            set xd2 [expr {$scaling(dx)*($x-$scaling(min)) + $rad}]
            set yd2 [expr {$scaling(dy)*($scaling(max)-$y) + $rad}]

            .c coords $item(id,$name) $xd1 $yd1 $xd2 $yd2
        }
        "line" {
            foreach {x1 y1 x2 y2} $coords {break}
            set xd1 [expr {$scaling(dx)*($x1-$scaling(min))}]
            set yd1 [expr {$scaling(dy)*($scaling(max)-$y1)}]
            set xd2 [expr {$scaling(dx)*($x2-$scaling(min))}]
            set yd2 [expr {$scaling(dy)*($scaling(max)-$y2)}]

            .c coords $item(id,$name) $xd1 $yd1 $xd2 $yd2
        }
    }
}

# point, dot, circle, line --
#     Prepare the item data for an (invisible) point
#
# Arguments:
#     args       Such things as x-coordinate/y-coordinate but also -fill colour
#
# Result:
#     Item data for [create] or [update]
#
# Note:
#     The extra arguments are only used in the [create] procedure
#
#     point, dot:
#     The first argment can be the name of a point or a pair of
#     coordinates. The rest is used as attributes
#
#     circle:
#     The first argment can be the name of a point or a pair of
#     coordinates. The second must be the radius, the rest is used as
#     attributes
#
#     line:
#     The first and second argments can be the name of a point or a pair
#     of coordinates. The rest is used as attributes.
#
proc point {first args} {
    global item

    if { [llength $first] == 2 } {
        return [concat point $first [list $args]]
    } else {
        return [concat point [lrange $item(data,$first) 0 1] [list $args]]
    }
}

proc dot {first args} {
    global item

    if { [llength $first] == 2 } {
        return [concat dot $first [list $args]]
    } else {
        return [concat dot [lrange $item(data,$first) 0 1] [list $args]]
    }
}

proc circle {first rad args} {
    global item

    if { [llength $first] == 2 } {
        return [concat circle $first $rad [list $args]]
    } else {
        return [concat circle [lrange $item(data,$first) 0 1] $rad [list $args]]
    }
}

proc line {first second args} {
    global item

    if { [llength $first] == 1 } {
        set first [lrange $item(data,$first) 0 1]
    }
    if { [llength $second] == 1 } {
        set second [lrange $item(data,$second) 0 1]
    }
    return [concat line $first $second [list $args]]
}

# add --
#     Translate a point over a given vector and return the coordinates
#
# Arguments:
#     point      Point (name or coordinate pair)
#     vector     Vector (name or coordinate pair)
#
# Result:
#     New coordinate pair
#
proc add {point vector} {
    global item

    if { [llength $point] == 1 } {
        set point [lrange $item(data,$point) 0 1]
    }
    if { [llength $vector] == 1 } {
        set vector [lrange $item(data,$vector) 0 1]
    }

    foreach {xb yb} $point {xe ye} $vector {
        set xn [expr {$xb+$xe}]
        set yn [expr {$yb+$ye}]
        break
    }

    return [list $xn $yn]
}

# translate --
#     Translate one or more item over a given vector and update the coordinates
#
# Arguments:
#     items      List of items
#     vector     Vector (name or coordinate pair)
#
# Result:
#     New coordinate pair
#
proc translate {items vector} {
    global item

    if { [llength $vector] == 1 } {
        set vector [lrange $item(data,$vector) 0 1]
    }
    set xv [lindex $vector 0]
    set yv [lindex $vector 1]

    foreach name $items {
        switch -- $item(type,$name) {
            "point"  {set last 1}
            "dot"    {set last 1}
            "circle" {set last 1}
            "line"   {set last 3}
        }

        set coords [lrange $item(data,$name) 0 $last]
        set newcoords {}

        foreach {xc yc} $coords {
            set xn [expr {$xc + $xv}]
            set yn [expr {$yc + $yv}]

            lappend newcoords $xn $yn
        }

        set item(data,$name) [lreplace $item(data,$name) 0 $last {*}$newcoords]
        UpdateCoords $name $newcoords
    }
}

# rotate --
#     Rotate one or more item over a given angle and update the coordinates
#
# Arguments:
#     items      List of items
#     centre     Centre of rotation (name or coordinate pair)
#     angle      Angle (in radians)
#
# Result:
#     New coordinate pair
#
proc rotate {items centre angle} {
    global item

    if { [llength $centre] == 1 } {
        set centre [lrange $item(data,$centre) 0 1]
    }
    set xr   [lindex $centre 0]
    set yr   [lindex $centre 1]
    set cosa [expr {cos($angle)}]
    set sina [expr {sin($angle)}]

    foreach name $items {
        switch -- $item(type,$name) {
            "point"  {set last 1}
            "dot"    {set last 1}
            "circle" {set last 1}
            "line"   {set last 3}
        }

        set coords [lrange $item(data,$name) 0 $last]
        set newcoords {}

        foreach {xc yc} $coords {
            set xn [expr {$xr + $cosa * ($xc-$xr) - $sina*($yc-$yr)}]
            set yn [expr {$yr + $sina * ($xc-$xr) + $cosa*($yc-$yr)}]

            lappend newcoords $xn $yn
        }

        set item(data,$name) [lreplace $item(data,$name) 0 $last {*}$newcoords]
        UpdateCoords $name $newcoords
    }
}

# track --
#     Track a point
#
# Arguments:
#     cmd        Command in question (start, next or stop)
#     point      Name (!) of the point to track
#     args       Extra attributes (for colour and such)
#
# Result:
#     None
#
# Side effect:
#     A line connecting the dots is drawn
#
proc track {cmd point args} {
    global item
    global scaling

    set xp [lindex $item(data,$point) 0]
    set yp [lindex $item(data,$point) 1]

    switch -- $cmd {
        "start" {
            set xp [expr {$scaling(dx)*($xp-$scaling(min))}]
            set yp [expr {$scaling(dy)*($scaling(max)-$yp)}]
            set item(track,$point) [.c create line $xp $yp $xp $yp {*}$args]
        }
        "next" {
            set coords [.c coords $item(track,$point)]
            lappend coords \
                [expr {$scaling(dx)*($xp-$scaling(min))}] \
                [expr {$scaling(dy)*($scaling(max)-$yp)}]
            .c coords $item(track,$point) $coords
        }
        "stop" {
            unset item(track,$point)
        }
    }
}

# main --
#     Quick test
#
console show
if {0} {
scaling -5 5

create P  [dot {0 0} -fill blue]
create C1 [point {1 1}]
create C  [circle C1 2 -outline red]
create L  [line {0 0} {1 1} -fill green]


for {set i 0} {$i < 20} {incr i} {

    puts "$i ..."
    translate C {-0.2 -0.2}
    pause 30
}
}

#
# Create a cardioid
#
scaling -5 5
create C1      [point {0 0}]
create C2      [point [add C1 {2 0}]]
create circle1 [circle C1 1]
create circle2 [circle C2 1]
create P       [dot [add C2 {1 0}] -fill blue]
create line    [line C2 P -fill red]

set pi    [expr {acos(-1.0)}]
set angle [expr {2.0*$pi/100.0}]

track start P -fill blue
parray item

for {set i 0} {$i < 100} {incr i} {
    rotate {C2 P line circle2} C1 $angle
    rotate {P line}            C2 $angle

    track next P
    pause 30
}
track stop P