Undoing events. Almost all modern programs use an undoing mechanism - so here is one for Tk.
Use the Undo - Redo or Control-z, Control-y to undo/redo the events you perform on the widgets in the interface created. Press any button, menu item, enter text in the text widget, use the spinbox move the sliders with either left drag or right-click - all these options are undoable.
The new 'class' is the undoable - its history of events can be regressed to an earlier state or progressed to recover a state which had been undone. The key is the "-kind XXX" where XXX is any Tk widget; undo operations are provided for entry, scale, spinbox widgets. Buttons (checkbox, radio button) may require some user code. Any widget can have an undocommand - a script that is exercised after a widget's state has been undone.
Each implementation of a widget may require special undo operations - for example if we have 30 objects, all red or yellow then a button changes the yellow objects to red then the undo for this button is NOT change all the red objects (back to) yellow, but change back all the objects which were previously changed. The implementation below provides an '-undocommand' option for each undoable widget; this must be created by the user to provide an exact undo mechanism. Typically each widget would be extended by the user to include a history of the effects of the widget, and then when its 'undo' command is called the last history event would be undone.
proc comment text {}
proc dbg args { tk_messageBox -message "$args" ; return 1}
proc testop {s S P V} { ;# this is the validation routine for entry e2
puts "testop validating $s $S -> $P type $V"
return 1 ;# or 0 if not OK!
}
proc undomenu {menubtn menu} {
puts "Undoing $menubtn $menu [$menubtn cget -text]"
}
proc scalevalue {w v} {
puts "scale $w set to value $v"
}
proc testUndo {} { ;# create an interface using "undoable" Tk items.
console show ;# debug and check infomration appears here via puts commands.
pack [frame .fr]
pack [button .fr.undo -text Undo -command "undolast"] -side left
pack [button .fr.redo -text Redo -command "redolast"] -side left
bind . <Control-z> "undolast"
bind . <Control-y> "redolast"
pack [button .fr.undos -text "Show Undos" -command "showundos"] -side left
pack [button .fr.redos -text "Show Redos" -command "showredos"] -side left
pack [button .fr.exit -text Exit -command "exit 1"] -side left
set testfr [frame .tests]
pack $testfr
# default type is an entry.
pack [undoable $testfr.e1 -validate focus] -side top
pack [undoable $testfr.e2 -kind entry -vcmd "testop %s %S %P %V" -validate all] -side top
pack [undoable $testfr.sp2 -kind spinbox -from 1 -to 12 \
-vcmd "testop %s %S %P %V" -validate all] -side top
pack [undoable $testfr.b1 -kind menubutton -bg red -menu $testfr.b1.menu1 -textvariable menval -bd 2 -relief raised] -side top
undoable $testfr.b1.menu1 -kind menu -tearoff 0 -undocommand "undomenu $testfr.b1 $testfr.b1.menu1"
foreach num {One Two Three} { $testfr.b1.menu1 add command -label $num -command "puts \"menu item $num chosen\"; set ::menval $num"}
$testfr.b1.menu1 add cascade -label "Roman" -menu $testfr.b1.menu1.cascade
undoable $testfr.b1.menu1.cascade -kind menu -tearoff 0 -undocommand "puts \"Undoing $testfr.b1.menu1.cascade\""
foreach num {I II III} { $testfr.b1.menu1.cascade add command -label $num -command "puts \"menu item $num chosen\"; set ::menval $num"}
set ::menval Number
pack [undoable $testfr.bmen1 -kind menubutton -menu $testfr.bmen1.menu1 -text "Dropdown Menu" -bd 2 -relief raised] -side top
undoable $testfr.bmen1.menu1 -kind menu -tearoff 0 -undocommand "undomenu $testfr.bmen1 $testfr.bmen1.menu1"
foreach num {One Two Three} { $testfr.bmen1.menu1 add command -label $num -command "puts \"menu item $num chosen\""}
$testfr.bmen1.menu1 add cascade -label "Roman" -menu $testfr.bmen1.menu1.cascade
undoable $testfr.bmen1.menu1.cascade -kind menu -tearoff 0 -undocommand "puts \"Undoing $testfr.bmen1.menu1.cascade\""
foreach num {I II III} { $testfr.bmen1.menu1.cascade add command -label $num -command "puts \"menu item $num chosen\""}
pack [undoable $testfr.b2 -kind button -text "Press Me" -command "puts {Button pressed}" \
-undocommand "puts {Button press undone}" ] -side top
pack [undoable $testfr.b3 -kind checkbutton -text "Check Me" -command "puts {checkButton pressed}" \
-undocommand "puts {checkButton press undone}" ] -side top
pack [undoable $testfr.b4 -kind radiobutton -text "Check Me" -command "puts {radioButton pressed}" \
-undocommand "puts {radioButton press undone}" ] -side top
pack [undoable $testfr.e3 -kind entry \
-vcmd "puts {validating %s %S -> %P type %V}; return 1" \
-validate all] -side top
pack [undoable $testfr.s1 -kind scale -from 100 -to 200 \
-command "scalevalue $testfr.s1" -orient horiz] -side top
pack [undoable $testfr.s2 -kind scale -from 0 -to 120 \
-command "scalevalue $testfr.s2" -orient horiz] -side top
pack [undoable $testfr.lb2 -kind listbox -command "puts {Listbox Selected}" \
-undocommand "puts {Listbox undone}" ] -side top
foreach fruit [list "Apple" "Peach" "Pear" "Banana" "Strawberry" \
"Lingonberry" "Blackberry" "Damson" "Plum"] {
$testfr.lb2 insert end $fruit
}
pack [undoable $testfr.tx1 -kind text -undo true ] -side top
}
comment {
This is the important part - a list of undoable events, and a redo list (in case you undid
an event and realised it should not have been undone).
Each undo event has two parts (it is a list) - the record of old values needing to be undone,
and the redo event (a copy of the original event).
The class undoable is a [polymorphism%|%polymorphic] or Template class which records the actions
of any Tk widget and can 'undo' these actions.
Records events in all undoable widgets as a list, then you can undo the list
(and possibly redo). All Tk widgets (except canvas?) can be used as undoables.
"Polymorphism" means that the undoable widget can inherit from any of the Tk widgets.
It should also be able to represent an Iwidget or BWidget.
Usually 'entry' 'menu' and 'scale' widgets won't need an undocommand as they call the
return the value of the widget to its previous value, which calls the standard
'item changed command' for the widget (which should cause all changes to be reset
as if the menu/entry/scale had been set manually).
undoableCmd is the place where the undo events are coded and interpreted.
}
global undoings ;# list of undoable things - each is a 2 part list
# first the arguments to undo the operation;
# then the arguments to redo the operation.
set undoings {}
global redoings ;# list of redoable things - copy of those undoings which have been undone.
set redoings {}
proc showundos {} { ;# display list of undo operations.
global undoings
foreach un $undoings { puts "Undo:: [lindex $un 0] ::redo:: [lindex $un 1]"}
}
proc showredos {} { ;# display list of redo operations.
global redoings
foreach un $redoings { puts "Redo:: [lindex $un 0] ::undo:: [lindex $un 1]"}
}
proc undolast {} { ;# undoes last undoable operation.
global undoings
if {[llength $undoings]>0} {
set undothis [lindex [lindex $undoings end] 0]
set widget [lindex $undothis 0]
eval $widget undo $undothis
global redoings
lappend redoings [lindex $undoings end]
set undoings [lrange $undoings 0 end-1]
} else {
puts "No more undoable events"
}
}
proc redolast {} {
global redoings
if {[llength $redoings]>0} {
set redothis [lindex $redoings end]
set redocommand [lindex $redothis 1]
set widget [lindex $redocommand 0]
eval $widget undo $widget [lrange $redocommand 1 end]
update idletasks
set redoings [lrange $redoings 0 end-1]
global undoings
lappend undoings $redothis
}
}
proc undoable {w args} { ;# an undoable is a widget
# and allows new smooth shaped buttons.
global $w.props ;# an array of options specific to the undoable 'class'
# set by .this -<option> <value>
array set $w.props {-kind entry -undoing 0 -undocommand "" -command "" oldvalue "0"}
# define the option list and default values
# kind is the type of Tk widget (entry, button, menu ection...)
# undoing is true if we are in an undo operation (does not get put on the undoable list)
# undocommand may be supplied for items such as buttons which may invoke complex operations
# and hence require a complex undo operation.
upvar #0 $w.props props ;# get local address for global array
set baseArgs {} ;# list of arguments not specific to the class
set options(-kind) entry
set options(-vcmd) "return 1"
# extract special arguments for w - command is special in that commands (from buttons etc)
# need to record their actions to be undone
foreach {opt val} $args {
if {[array names $w.props $opt]!=""} {
set options($opt) $val
set $w.props($opt) $val
} else { lappend baseArgs $opt $val }
}
# make the base widget
eval $options(-kind) $w $baseArgs ;# create the "procedure" w
interp hide {} $w
# Install the alias:
interp alias {} $w {} undoableCmd $w ;# undoableCmd processes sub-commands for undoable class
switch [winfo class $w] {
{Listbox} {
bind $w <ButtonPress-1> "$w Select %y"
}
{Text} {
bind $w <Enter> "$w TextSavepoint"
bind $w <Leave> "$w TextSavepoint"
}
default {}
}
foreach opt [array names options] {
if {[$w isanoption $opt] != ""} {
switch -- $opt {
"-command" { ;# assemble complete validation command - saves history of behaviours
set undocmd "$w undooptions ; $options($opt)"
eval interp invokehidden {{}} $w configure "$opt" \"$undocmd\"
}
"-validatecommand" -
"-vcmd" { ;# assemble complete Entry validation command - saves history of behaviours
set undocmd "$w undooptions %P ; $options($opt)"
eval interp invokehidden {{}} $w configure "$opt" \"$undocmd\"
}
default { $w configure $opt "$options($opt)" }
}
} else {
set $w.props($opt) $options($opt)
}
}
return $w ;# the original object
}
proc undoableCmd {self cmd args} {
global $self.props
switch -- $cmd {
configure {eval undoableConfigure $self $args}
cget {eval undoableCget $self $args}
{undooptions} { ;# save undooptions sufficient to undo and redo an action
if {![$self cget -undoing]} { ;# not in an undo so save event.
global undoings ;# store state before and after event change.
set dodata [lindex $args end] ;# and record the redo event
switch [winfo class $self] {
{Menu} { ;# [file rootname $self] is the menu parent - button or cascade
set menubutt [file rootname $self]
while {[winfo class $menubutt]!="Menubutton"} {
# ascend tree to an actual menubutton.
set menubutt [file rootname $menubutt]
}
set tvar [$menubutt cget -text]
set dodata [list $self $cmd $menubutt $args]
set undodata [list $self $cmd $menubutt $tvar]
}
{Button} -
{Checkbutton} -
{Radiobutton} {
set undodata [list $self $cmd $args]
set dodata [list $self $cmd $args ]
}
{Entry} {
set undodata [list $self [$self oldvalue] ]
set dodata [list $self $args ]
}
{Scale} {
set dodata [list $self [$self oldvalue] ]
set undodata [list $self [$self cget oldvalue]]
puts "Undo scale save $self [$self oldvalue] [$self cget oldvalue]"
}
{Listbox} {
set undodata [list $self [$self curselection ] ]
set dodata [list $self [lindex $args 0]]
}
{Text} {
# NB this records undo state when mouse enters into text widget
set undodata [list $self "[$self oldvalue]"]
set dodata $undodata
}
{Spinbox} {
set undodata [list $self [$self get ] ]
set dodata [list $self $args]
}
default {
set undodata [list $self "Dont know how to undo [winfo class $self]"]
}
}
# foreach un $undoings { puts "Undo:: $un"}
lappend undoings [list $undodata $dodata] ;# and record the undo event
} ;# else { puts "In undo dont save event $cmd $args"}
set $self.props(oldvalue) [$self oldvalue] ;# saved for redo record.
}
{undo} { ;# the action invoked by an undo
set $self.props(-undoing) 1
switch [winfo class $self] {
{Entry} {
$self selection range 0 end
if {[$self selection present]} { $self delete sel.first sel.last }
$self insert insert [lindex $args 1] ;# insert
}
{Menu} { ;# here we want to perform some undoing mechanism
set tvar [ [lindex $args 2] cget -textvariable]
if {$tvar !=""} {
global $tvar
set $tvar [lindex $args 3]
}
puts "menu $self undo [winfo class $self] event $args"
}
{Listbox} {
$self selection clear 0 end
if {[lindex $args 1]!=""} {
$self selection set [lindex $args 1]
puts "Undo [lindex $args 0] oldvalues [lindex $args 1] new [lindex $args 2]"
}
}
{Checkbutton} -
{Radiobutton} -
{Button} { ;# these Tk items usually need their own undocommand
puts "Undoing [winfo class $self] called $self"
}
{Scale} { ;# scale set should call its own -command option
eval $self set [lindex $args 1]
}
{Spinbox} {
eval $self set [lindex $args 1]
}
{Text} { ;# NB this reverts to state at time of mouse entering/leaving text widget
$self delete 0.0 end
$self insert end [lindex $args 1]
}
default {
puts "? undo [winfo class $self] event $args"
}
}
set undoc [$self cget "-undocommand"]
if {$undoc!=""} { eval $undoc}
update idletasks ;# updates all the -vcmds etc before setting the undo flag
set $self.props(-undoing) 0 ;# start collecitng widget events for undoing again
}
{Select} { ;# in Listbox - no automatic setting of current selection in Tk(!)
set y [$self nearest [lindex $args 0]]
$self undooptions $y
$self selection set $y
upvar #0 $self.props props
eval $props(-command)
}
{TextSavepoint} { ;# mouse has entered or left text - create an undo event
$self undooptions
}
{oldvalue} { ;# for generic resetting - some classes save the old value
switch [winfo class $self] {
{Entry} -
{Scale} { return [$self get]}
{Text} { return [$self get 0.0 end]}
default { return ""}
}
}
{isanoption} { ;# check all the declared options of self for $args being valid.
foreach op [$self config] {
set n [lsearch $op $args]
if {$n>=0} { return $op}
}
return ""
}
{add} { ;# for type menu add an option (command etc) means add an undoable menu item
if {[$self isanoption $cmd] != ""} {
puts "$self Could not $cmd with $args - $self should be a menu item."
} else {
set undoargs [lindex $args 0]
set pog [lsearch $args "-label"]
if {$pog>0} {
incr pog
set pog [lindex $args $pog]
}
foreach {opt val} [lrange $args 1 end] { ;# first arg arg[0] is command (or radiobutton, checkbutton, etc)
switch -- $opt {
{-command} {
lappend undoargs $opt "$self undooptions $pog ; $val"
}
default {lappend undoargs $opt $val }
}
}
set id [eval interp invokehidden {{}} $self $cmd $undoargs]
}
}
{default} { ;# use default $cmd to widget
eval interp invokehidden {{}} $self $cmd $args
}
}
}
proc undoableConfigure {self args} {
# 3 scenarios:
#
# $args is empty -> return all options with their values
# $args is one element -> return current values
# $args is 2+ elements -> configure the options
#puts "Config comd $self $cmd $args [llength $args]"
global $self.props
switch [llength $args] {
0 { ;# return all options
set result [array names $self.props]
return $result
}
1 { ;# return argument values
if {[array names $w.props $opt]!=""} { lappend opts [$self cget $args]
} else { puts "No option $opt in $self specific arguments." }
return $opts
}
default { ;# >1 arg - an option and its value
# go through each option:
foreach {option value} [lrange $args 0 end] {
if {[array names $self.props $option]!=""} { ;# set global array element for special option.
set $self.props($option) "$value"
} else {
eval interp invokehidden {{}} $self configure $option $value
}
}
return {}
}
}
}
proc undoableCget {self args} { ;# cget defaults done by the interp cget command
upvar #0 $self.props props ;# get local address for global array
if {[array names props $args ]!=""} {
return $props($args)
}
return [uplevel 1 [list interp invokehidden {} $self cget $args]]
}
testUndo ;# call the test routine