# *************************************************************************
# * File   : undoer.tcl
# * Purpose: Implement an undo/redo facility for a text widget
# *
# * Author : Tom Wilkason lifted from code by Jean-Luc Fontaine
#
# * Dated  : 9/3/2000
# *
# *************************************************************************
 set RH {
   Revision History:
   -----------------
   $Revision:$
   $Log:$
 }
global classNewId
 if {![info exists classNewId]} {
     # work around object creation between multiple include of this file problem
     set classNewId 0
 }
 ;##
 ;# Call this to get a new undoer for some text widget
 ;# e.g. UnDonew textUndoer .text.widget
 ;#
 proc UnDonew {className args} {
     # calls the constructor for the class with optional arguments
     # and returns a unique object identifier independent of the class name

     global classNewId
     # use local variable for id for new can be called recursively
     set id [incr classNewId]
     if {[llength [info procs ${className}:$className]]>0} {
         # avoid catch to track errors
         eval ${className}:$className $id $args
     }
     return $id
 }

 proc UnDodelete {className id} {
     # calls the destructor for the class and UnDodelete all the object data members

     if {[llength [info procs ${className}:~$className]]>0} {
         # avoid catch to track errors
         catch {${className}:~$className $id}
     }
     global $className
     # and UnDodelete all this object array members if any (assume that they were stored as $className($id,memberName))
     foreach name [array names $className "$id,*"] {
         unset ${className}($name)
     }
 }

 proc udLifo:udLifo {id {size 2147483647}} {
     global udLifo
     set udLifo($id,maximumSize) $size
     udLifo:empty $id
 }

 proc udLifo:push {id data} {
     global udLifo saveTextMsg
     set saveTextMsg 1
     udLifo:tidyUp $id
     if {$udLifo($id,size)>=$udLifo($id,maximumSize)} {
         unset udLifo($id,data,$udLifo($id,first))
         incr udLifo($id,first)
         incr udLifo($id,size) -1
     }
     set udLifo($id,data,[incr udLifo($id,last)]) $data
     incr udLifo($id,size)
 }

 proc udLifo:pop {id} {
     global udLifo saveTextMsg
     set saveTextMsg 1
     udLifo:tidyUp $id
     if {$udLifo($id,last)<$udLifo($id,first)} {
         error "udLifo($id) pop error, empty"
     }
     # delay unsetting popped data to improve performance by avoiding a data copy
     set udLifo($id,unset) $udLifo($id,last)
     incr udLifo($id,last) -1
     incr udLifo($id,size) -1
     return $udLifo($id,data,$udLifo($id,unset))
 }

 proc udLifo:tidyUp {id} {
     global udLifo
     if {[info exists udLifo($id,unset)]} {
         unset udLifo($id,data,$udLifo($id,unset))
         unset udLifo($id,unset)
     }
 }

 proc udLifo:empty {id} {
     global udLifo
     udLifo:tidyUp $id
     foreach name [array names udLifo $id,data,*] {
         unset udLifo($name)
     }
     set udLifo($id,size) 0
     set udLifo($id,first) 0
     set udLifo($id,last) -1
 }

 proc textUndoer:textUndoer {id widget {depth 2147483647}} {
     global textUndoer

     if {[string compare [winfo class $widget] Text]!=0} {
         error "textUndoer error: widget $widget is not a text widget"
     }
     set textUndoer($id,widget) $widget
     set textUndoer($id,originalBindingTags) [bindtags $widget]
     bindtags $widget [concat $textUndoer($id,originalBindingTags) UndoBindings($id)]

     bind UndoBindings($id) <Control-z> "textUndoer:undo $id"

     # self destruct automatically when text widget is gone
     bind UndoBindings($id) <Destroy> "UnDodelete textUndoer $id"

     # rename widget command
     rename $widget [set textUndoer($id,originalCommand) textUndoer:original$widget]
     # and intercept modifying instructions before calling original command
     proc $widget {args} "textUndoer:checkpoint $id \$args;
       global search_count;
       eval $textUndoer($id,originalCommand) \$args"

     set textUndoer($id,commandStack) [UnDonew udLifo $depth]
     set textUndoer($id,cursorStack) [UnDonew udLifo $depth]
     #lee
     textRedoer:textRedoer $id $widget $depth
 }

 proc textUndoer:~textUndoer {id} {
     global textUndoer

     bindtags $textUndoer($id,widget) $textUndoer($id,originalBindingTags)
     rename $textUndoer($id,widget) ""
     rename $textUndoer($id,originalCommand) $textUndoer($id,widget)
     UnDodelete udLifo $textUndoer($id,commandStack)
     UnDodelete udLifo $textUndoer($id,cursorStack)
     #lee
     textRedoer:~textRedoer $id
 }

 proc textUndoer:checkpoint {id arguments} {
     global textUndoer textRedoer

     # do nothing if non modifying command
     if {[string compare [lindex $arguments 0] insert]==0} {
         textUndoer:processInsertion $id [lrange $arguments 1 end]
         if {$textRedoer($id,redo) == 0} {
            textRedoer:reset $id
         }
     }
     if {[string compare [lindex $arguments 0] delete]==0} {
         textUndoer:processDeletion $id [lrange $arguments 1 end]
         if {$textRedoer($id,redo) == 0} {
            textRedoer:reset $id
         }
     }
 }

 proc textUndoer:processInsertion {id arguments} {
     global textUndoer

     set number [llength $arguments]
     set length 0
     # calculate total insertion length while skipping tags in arguments
     for {set index 1} {$index<$number} {incr index 2} {
         incr length [string length [lindex $arguments $index]]
     }
     if {$length>0} {
         set index [$textUndoer($id,originalCommand) index [lindex $arguments 0]]
         udLifo:push $textUndoer($id,commandStack) "delete $index $index+${length}c"
         udLifo:push $textUndoer($id,cursorStack) [$textUndoer($id,originalCommand) index insert]
     }
 }

 proc textUndoer:processDeletion {id arguments} {
     global textUndoer

     set command $textUndoer($id,originalCommand)
     udLifo:push $textUndoer($id,cursorStack) [$command index insert]

     set start [$command index [lindex $arguments 0]]
     if {[llength $arguments]>1} {
         udLifo:push $textUndoer($id,commandStack) "insert $start [list [$command get $start [lindex $arguments 1]]]"
     } else {
         udLifo:push $textUndoer($id,commandStack) "insert $start [list [$command get $start]]"
     }
 }

 proc textUndoer:undo {id} {
     global textUndoer

     if {[catch {set cursor [udLifo:pop $textUndoer($id,cursorStack)]}]} {
         return
     }

     if {[catch {set popArgs [udLifo:pop $textUndoer($id,commandStack)]}]} {
         return
     }
     textRedoer:checkpoint $id $popArgs

     eval $textUndoer($id,originalCommand) $popArgs
     # now restore cursor position
     $textUndoer($id,originalCommand) mark set insert $cursor
     # make sure insertion point can be seen
     $textUndoer($id,originalCommand) see insert
 }

 proc textUndoer:reset {id} {
     global textUndoer
     udLifo:empty $textUndoer($id,commandStack)
     udLifo:empty $textUndoer($id,cursorStack)
 }

 #########################################################################
 proc textRedoer:textRedoer {id widget {depth 2147483647}} {
     global textRedoer
     if {[string compare [winfo class $widget] Text]!=0} {
         error "textRedoer error: widget $widget is not a text widget"
     }
     set textRedoer($id,commandStack) [UnDonew udLifo $depth]
     set textRedoer($id,cursorStack) [UnDonew udLifo $depth]
     set textRedoer($id,redo) 0
 }

 proc textRedoer:~textRedoer {id} {
     global textRedoer
     UnDodelete udLifo $textRedoer($id,commandStack)
     UnDodelete udLifo $textRedoer($id,cursorStack)
 }

 proc textRedoer:checkpoint {id arguments} {
     global textUndoer textRedoer
     # do nothing if non modifying command
     if {[string compare [lindex $arguments 0] insert]==0} {
         textRedoer:processInsertion $id [lrange $arguments 1 end]
     }
     if {[string compare [lindex $arguments 0] delete]==0} {
         textRedoer:processDeletion $id [lrange $arguments 1 end]
     }
 }

 proc textRedoer:processInsertion {id arguments} {
     global textUndoer textRedoer
     set number [llength $arguments]
     set length 0
     # calculate total insertion length while skipping tags in arguments
     for {set index 1} {$index<$number} {incr index 2} {
         incr length [string length [lindex $arguments $index]]
     }
     if {$length>0} {
         set index [$textUndoer($id,originalCommand) index [lindex $arguments 0]]
         udLifo:push $textRedoer($id,commandStack) "delete $index $index+${length}c"
         udLifo:push $textRedoer($id,cursorStack) [$textUndoer($id,originalCommand) index insert]
     }
 }

 proc textRedoer:processDeletion {id arguments} {
     global textUndoer textRedoer
     set command $textUndoer($id,originalCommand)
     udLifo:push $textRedoer($id,cursorStack) [$command index insert]

     set start [$command index [lindex $arguments 0]]
     if {[llength $arguments]>1} {
         udLifo:push $textRedoer($id,commandStack) "insert $start [list [$command get $start [lindex $arguments 1]]]"
     } else {
         udLifo:push $textRedoer($id,commandStack) "insert $start [list [$command get $start]]"
     }
 }
 proc textRedoer:redo {id} {
     global textUndoer textRedoer
     if {[catch {set cursor [udLifo:pop $textRedoer($id,cursorStack)]}]} {
         return
     }
     set textRedoer($id,redo) 1
     set popArgs [udLifo:pop $textRedoer($id,commandStack)]
     textUndoer:checkpoint $id $popArgs
     eval $textUndoer($id,originalCommand) $popArgs
     set textRedoer($id,redo) 0
     # now restore cursor position
     $textUndoer($id,originalCommand) mark set insert $cursor
     # make sure insertion point can be seen
     $textUndoer($id,originalCommand) see insert
 }

 ;##
 ;# Call this to reset the stacks, for example after reading a file in
 ;#
 proc textRedoer:reset {id} {
     global textRedoer
     udLifo:empty $textRedoer($id,commandStack)
     udLifo:empty $textRedoer($id,cursorStack)
 }
package provide Undoer 1.0
