#!/usr/bin/env tclsh

package require Tk
package require lambda

# wraps a script in a lambda that ignores all its arguments
# useful for making traces
proc ignoreargs {script} {
    lambda@ [uplevel 1 {self namespace}] args $script
}

# list-based stack
interp alias {} lpush {} lappend
proc lpop {_ls varName args} {
    upvar 1 $_ls ls
    set vals [lrange $ls end-[llength $args] end]
    set ls [lreplace $ls end-[llength $args] end]
    tailcall ::foreach [list $varName {*}$args] $vals {}
}

# [incr] that doesn't choke on floats
proc incf {varName {expr 1}} {
    set varName [list $varName]
    tailcall if "\[info exists $varName\]" "
                    set $varName \[expr {\${$varName} + $expr}\]
    " "else" "
                    set $varName \[expr {$expr}\]
    "
}

# dialog box which handles resizing
oo::class create Resizer {
    variable w
    variable radius
    variable id
    variable obj
    variable undo
    constructor {W Obj Id} {
        set w $W
        set obj $Obj
        set id $Id
        lassign [$obj get_center $id] x y
        set radius [$obj get_radius $id]
        set undo [list resize_circle $id $radius]
        label $w.l -text "Adjust diameter of circle at ($x, $y)"
        scale $w.s -variable [my varname radius] -orient h -from 10.0 -to 500.0 -resolution 1.0
        button $w.b -text "Done" -command [namespace code {my Done}]
        button $w.c -text "Cancel" -command [namespace code {my Cancel}]
        grid $w.l - -sticky nsew
        grid $w.s - -sticky nsew
        grid $w.b $w.c -sticky nsew
        trace add variable [my varname radius] write [ignoreargs {my Changed}]
    }
    method Changed {} {
        puts "Resizing $id to $radius"
        $obj resize_circle $id $radius
    }
    method Cancel {} {
        $obj {*}$undo
        destroy $w
        after idle [list [self] destroy]
    }
    method Done {} {
        $obj push_undo $undo
        destroy $w
        after idle [list [self] destroy]
    }
}

proc resize_circle {obj id} {
    set w .resize_${id}
    if {[winfo exists $w]} {
        raise $w
        focus $w
        return
    }
    toplevel $w
    Resizer new $w $obj $id
}

oo::class create Circles {
    constructor {} {
        canvas .c -width 480 -height 320 -background white
        button .u -text "Undo" -command [namespace code {my undo}]
        button .r -text "Redo" -command [namespace code {my redo}]
        grid .c - -sticky nsew
        grid .u .r -sticky nsew
        grid columnconfigure . 0 -weight 1
        grid columnconfigure . 1 -weight 1
        grid rowconfigure . 0 -weight 1
        bind .c <Configure> [namespace code {my canvas.configure %w %h}]
        bind .c <Button-1> [namespace code {my canvas.b1 %x %y}]
        bind .c <Button-3> [namespace code {my canvas.b3 %x %y}]
        oo::objdefine [self] forward canvas .c
    }

    # event handlers
    method canvas.configure {w h} {
        # .c scale all 0 0 [expr {1.0/$w}] [expr {1.0/$h}]
    }
    method canvas.b1 {x y} {
        set item [.c find withtag current]
        if {$item ne ""} {
            # do nothing
        } else {
            my do add_circle $x $y
        }
    }
    method canvas.b3 args {
        set item [.c find withtag current]
        if {$item ne ""} {
            resize_circle [self] $item
        }
    }

    # undo helpers
    variable undo_stack
    variable redo_stack
    method do {cmd args} {
        lpush undo_stack [my $cmd {*}$args]
    }
    method push_undo {cmd args} {
        lpush undo_stack $cmd {*}$args
    }
    method undo {} {
        if {$undo_stack eq ""} {return}
        lpop undo_stack cmd
        puts "undo: $cmd"
        lpush redo_stack [my {*}$cmd]
    }
    method redo {} {
        if {$redo_stack eq ""} {return}
        lpop redo_stack cmd
        puts "redo: $cmd"
        lpush undo_stack [my {*}$cmd]
    }

    # circle geometry helpers
    method get_center {item} {
        foreach {x0 y0} [.c coords $item] {
            incf x $x0
            incf y $y0
            incr n
        }
        set x [expr {$x / $n}]
        set y [expr {$y / $n}]
        list $x $y
    }
    method get_radius {item} {
        lassign [.c coords $item] x0 y0 x1 y1
        expr {( ($x1 - $x0) + ($y1 - $y0) ) / 4}
    }

    # actions: each of these returns an undo action
    method add_circle {x y {r 50} args} {
        set x0 [expr {$x-$r}]
        set x1 [expr {$x+$r}]
        set y0 [expr {$y-$r}]
        set y1 [expr {$y+$r}]
        set id [.c create oval $x0 $y0 $x1 $y1 -fill white {*}$args -activefill grey]
        return [list delete_circle $id]
    }

    method delete_circle {id} {
        foreach {x y} [my get_center $id] {}
        set r [my get_radius $id]
        set cfg [lmap ci [.c itemconfigure $id] {
            if {[lindex $ci 4] eq [lindex $ci 3]} {
                # catches defaults and synonyms
                continue
            }
            list [lindex $ci 0] [lindex $ci 4]
        }]
        .c delete $id
        return [concat add_circle $x $y $r {*}$cfg]
    }

    method resize_circle {id radius} {
        foreach {x y} [my get_center $id] {}
        set oldr [my get_radius $id]
        set x0 [expr {$x - $radius}]
        set x1 [expr {$x + $radius}]
        set y0 [expr {$y - $radius}]
        set y1 [expr {$y + $radius}]
        .c coords $id $x0 $y0 $x1 $y1
        return "resize_circle $id $oldr"
    }

}

Circles create c
wm protocol . WM_DELETE_WINDOW exit

#!/usr/bin/env tclsh
#
package require Tk
package require tablelist

# REQUIRES:
#   [lremove]
    proc lremove {_ls args} {
        upvar 1 $_ls ls
        foreach a $args {
            set ls [lsearch -exact -not -all -inline $ls $a]
        }
    }
#   [unbound]   -- originally from colin
    proc unbound {__text} {
        set __unbound {}
        while {$__text ne ""} {
            try {
                dict with __unbound {
                    subst -nocommands -nobackslashes $__text
                }
            } trap {TCL LOOKUP VARNAME} {__e __eo} {
                dict set __unbound [lindex [dict get $__eo -errorcode] end] \$[lindex [dict get $__eo -errorcode] end]
            } on error {e eo} {
                puts stderr "$e ($eo)"
                return -options $eo $e  ;# improvement due to dgp
            } on ok {} {
                return [dict keys $__unbound]
            }
        }
    } 


variable Alphabet " ABCDEFGHIJKLMNOPQRSTUVWXYZ"

oo::class create Sheet {
    variable W
    variable Values     ;# list of lists of values, bound to display
    variable Formulas   ;# array(CellId) -> "=$expr"
    variable Depends    ;# array(CellId) -> {dependent cellids ..}

    constructor {{w .}} {
        if {$w eq "."} {set w ""}
        set W $w

    # create widgets
        tablelist::tablelist ${W}.tl -selecttype cell
        ttk::sizegrip ${W}.z -takefocus 0

        scrollbar ${W}.sy -orient v -command [list ${W}.tl yview]
        scrollbar ${W}.sx -orient h -command [list ${W}.tl xview]
        ${W}.tl configure -xscrollcommand [list ${W}.sx set]
        ${W}.tl configure -yscrollcommand [list ${W}.sy set]

    # set up tablelist
        $W.tl configure -columntitles [split $::Alphabet ""]
        $W.tl configure -editstartcommand [namespace code {my EditStart}]
        $W.tl configure -editendcommand [namespace code {my EditEnd}]
        for {set i 1} {$i < 27} {incr i} {
            $W.tl columnconfigure $i -editable 1
        }
    # columns don't support -relief or -border .. FIXME!
        foreach opt {background foreground font } {
            $W.tl columnconfigure 0 -${opt} [$W.tl cget -label${opt}]
        }

    # set up Values
        set 26 [lrepeat 26 {}]
        for {set i 0} {$i < 99} {incr i} {
            lappend Values [list $i {*}$26]
        }
        $W.tl configure -listvariable [my varname Values]

    # lay out:
        grid ${W}.tl ${W}.sy -sticky nsew
        grid ${W}.sx ${W}.z -sticky nsew
        set w .[string trimleft $W .]
        grid columnconfigure $w 0 -weight 1
        grid rowconfigure $w 0 -weight 1
    }

    method Eval {script} {  ;# debugging helper
        try $script
    }
    
    method CellId {x y} {
        return [string index $::Alphabet $x]$y
    }
    method CellRef {id} {
        regexp {([A-Z]+)([0-9]+)} $id -> x y
        set x [string first $x $::Alphabet]
        list $x $y
    }

    method EditStart {tl y x dispvalue} {
        set cellid [my CellId $x $y]
        if {[info exists Formulas($cellid)]} {
            set f $Formulas($cellid)
            unset Formulas($cellid)
            foreach ub [unbound $f] {
                lremove Depends($ub) $cellid
            }
            return $f
        }
        return $dispvalue
    }
    method EditEnd {tl y x newvalue} {
        set cellid [my CellId $x $y]
        after idle [namespace code [list my Recalculate $cellid]]
        if {[string match =* $newvalue]} {
            set Formulas($cellid) $newvalue
            foreach ub [unbound $newvalue] {
                if {![info exists Depends($ub)] || $cellid ni $Depends($ub)} {
                    lappend Depends($ub) $cellid
                }
            }
            return -1
        }
        # $tl rejectinput
        return $newvalue
    }

    method Evaluate {expr} {
        set expr [string trimleft $expr =]
        set env [lmap name [unbound $expr] {
            lassign [my CellRef $name] x y
            list $name [lindex $Values $y $x]
        }]
        try {
            apply [list $env [list expr $expr]]
        } on error {e o} {
            return "#!ERROR"
        }
    }
    method Recalculate {cellid} {
        lassign [my CellRef $cellid] x y
        if {[info exists Formulas($cellid)]} {
            set expr $Formulas($cellid)
            set val [my Evaluate $expr]
            lset Values $y $x $val
        }
        if {[info exists Depends($cellid)]} {
           foreach dep $Depends($cellid) {
               after idle [namespace code [list my Recalculate $dep]]
           }
        }
    }
}

Sheet create s
wm protocol . WM_DELETE_WINDOW exit