proc comment text {}
  proc dbg args { tk_messageBox -message "$args" ; return 1}

  comment {
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.

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 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
  }

  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"
	}
  }
 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 [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 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