package require Tk

set S(size) 800
set S(axis,color) grey
set S(bg,color) white
set S(colors) {purple magenta red orange yellow green blue cyan white black}

set g(color) magenta
set g(pen,size) 4
set g(axes) 21
set g(show,axis) 1

proc main {} {
    global S g

    wm title . "Super SymDoodle"
    frame .f -relief sunken -borderwidth 2
    foreach color $S(colors) {
        checkbutton .f.b$color -width 3 -text "" -variable g(color,$color) -bg $color \
            -command [list NewColor $color]
        bind .f.b$color <3> [list .c config -bg $color]
    }
    ::ttk::button .f.c -text C -width 0 -command {.c delete line} -takefocus 0
    ::ttk::button .f.h -text X -width 0 -command ToggleAxis -takefocus 0

    scale .f.pen -from 1 -to 20 -variable g(pen,size) -orient h -bd 2 -relief ridge \
        -showvalue 0 -command [list NewScaleValue .f.pen "Pen size: "]
    scale .f.axis -from 2 -to 50 -variable g(axes) -orient h -bd 2 -relief ridge \
        -showvalue 0 -command [list NewScaleValue .f.axis "Axis: "]
    bind .f.axis <ButtonRelease-1> DrawAxis
    pack {*}[winfo children .f] -side left -fill y
    foreach child [winfo children .f] {
        if {$child ni [info commands .f.b*]} {
            pack config $child -padx {2mm 0}
        }
    }

    canvas .c -height $S(size) -width $S(size) -bg $S(bg,color) -bd 0 -highlightthickness 0
    bind .c <1>         {penDown %W %x %y}
    bind .c <B1-Motion> {penMove  %W %x %y}
    bind .c <Configure> {Recenter %W %h %w}

    DrawAxis
    NewColor $g(color)
    pack .f -side top -fill x
    pack .c -side top -fill both -expand 1
}
proc NewColor {color} {
    global g
    foreach arr [array names g color,*] { set g($arr) 0 }
    set g(color,$color) 1
    set g(color) $color
}
proc NewScaleValue {w text value} {
    $w config -label "$text$value"
}
proc ToggleAxis {} {
    set ::g(show,axis) [expr {! $::g(show,axis)}]
    DrawAxis
}
proc DrawAxis {} {
    # Draw the g(axes) lines of symmetry and store in AXIS(...) the unit vector and its normal
    global g AXIS S
    .c delete axis
    if { ! $g(show,axis)} return
    for {set axis 0} {$axis < $g(axes)} {incr axis} {
        set angle [expr {acos(-1) * $axis / $g(axes)}]
        set AXIS(axis,$axis) [list [expr {cos($angle)}] [expr {sin($angle)}] ]
        set AXIS(normal,$axis) [VNormal $AXIS(axis,$axis)]
        set xy0 [VScale $AXIS(axis,$axis) 4000]
        set xy1 [VScale $AXIS(axis,$axis) -4000]
        .c create line [concat $xy0 $xy1] -tag axis -fill $S(axis,color)
    }
}

proc penDown {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    set xys [ReflectPoint $x $y]

    set g(currentline,ids) {}
    foreach xy $xys {
        lassign $xy x y
        set id [$w create line $x $y $x $y -fill $g(color) -tag line -width $g(pen,size)]
        lappend g(currentline,ids) $id
    }
}
proc penMove {w x y} {
    global g
    set x [$w canvasx $x]
    set y [$w canvasy $y]
    set xys [ReflectPoint $x $y]
    foreach xy $xys id $g(currentline,ids) {
        lassign $xy x y
        eval $w coords $id [concat [$w coords $id] $x $y]
    }
}
proc ReflectPoint {x y} {
    # Return a list of points where x,y is reflected 4 ways around each axis
    global AXIS g
    set xys {}
    for {set axis 0} {$axis < $g(axes)} {incr axis} {
        foreach {dx dy} {1 1  1 -1 -1 1 -1 -1} {
            set xx [expr {$x * $dx}]
            set yy [expr {$y * $dy}]
            set xy [VAdd [VScale $AXIS(axis,$axis) $xx] [VScale $AXIS(normal,$axis) $yy]]
            lappend xys $xy
        }
    }
    return $xys
}
proc Recenter {W h w} {
    # Update the canvas's scrollregion to put point 0,0 into the middle
    set h [expr {$h / 2.0}]
    set w [expr {$w / 2.0}]
    $W config -scrollregion [list -$w -$h $w $h]
}
proc VAdd {v1 v2 {scaling 1}} {
    foreach {x1 y1} $v1 {x2 y2} $v2 break
    return [list [expr {$x1 + $scaling*$x2}] [expr {$y1 + $scaling*$y2}]]
}
proc VScale {v scaling} {return [VAdd {0 0} $v $scaling]}
proc VNormal {v} { foreach {x y} $v break; return [list $y [expr {-1 * $x}]]}

main

return