# text.tcl --
#
# This file defines the default bindings for Tk text widgets and provides
# procedures that help in implementing the bindings.
#
# @(#) text.tcl 1.36 95/06/28 10:24:23
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# [mbl] 29dec95
#
# modified this file to support shared text editing
# - renamed all tkText... procs into tkShText...
# - changed all "bind Text ..." to "bind ShText ..."
# - changed all "path delete ..." to "tkShTextDelete path ..."
# - changed all "path insert ..." to "tkShTextInsertChars path ..."
# - defined procs tkShTextDelete and tkShTextInsertChars

#-------------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
# afterId -		If non-null, it means that auto-scanning is underway
#			and it gives the "after" id for the next auto-scan
#			command to be executed.
# char -		Character position on the line;  kept in order
#			to allow moving up or down past short lines while
#			still remembering the desired position.
# mouseMoved -		Non-zero means the mouse has moved a significant
#			amount since the button went down (so, for example,
#			start dragging out a selection).
# prevPos -		Used when moving up or down lines via the keyboard.
#			Keeps track of the previous insert position, so
#			we can distinguish a series of ups and downs, all
#			in a row, from a new up or down.
# selectMode -		The style of selection currently underway:
#			char, word, or line.
# x, y -		Last known mouse coordinates for scanning
#			and auto-scanning. 
# pressX -		??	[mbl]
#-------------------------------------------------------------------------

# tkShTextClipboardKeysyms --
# This procedure is invoked to identify the keys that correspond to
# the "copy", "cut", and "paste" functions for the clipboard.
#
# Arguments:
# copy -	Name of the key (keysym name plus modifiers, if any,
#		such as "Meta-y") used for the copy operation.
# cut -		Name of the key used for the cut operation.
# paste -	Name of the key used for the paste operation.

proc tkShTextClipboardKeysyms {copy cut paste} {
    bind ShText <$copy> {
	if {[selection own -displayof %W] == "%W"} {
	    clipboard clear -displayof %W
	    catch {
		clipboard append -displayof %W [selection get -displayof %W]
	    }
	}
    }
    bind ShText <$cut> {
	if {[selection own -displayof %W] == "%W"} {
	    clipboard clear -displayof %W
	    catch {
		clipboard append -displayof %W [selection get -displayof %W]
		tkShTextDelete %W sel.first sel.last
	    }
	}
    }
    bind ShText <$paste> {
	catch {
	    tkShTextInsterChars %W insert [selection get -displayof %W \
		    -selection CLIPBOARD]
	}
    }
}

#-------------------------------------------------------------------------
# The code below creates the default class bindings for entries.
#-------------------------------------------------------------------------

    # Standard Motif bindings:

bind ShText <1> {
    tkShTextButton1 %W %x %y
    %W tag remove sel 0.0 end
}
bind ShText <B1-Motion> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    tkShTextSelectTo %W %x %y
}
bind ShText <Double-1> {
    set tkPriv(selectMode) word
    tkShTextSelectTo %W %x %y
    catch {%W mark set insert sel.first}
}
bind ShText <Triple-1> {
    set tkPriv(selectMode) line
    tkShTextSelectTo %W %x %y
    catch {%W mark set insert sel.first}
}
bind ShText <Shift-1> {
    tkShTextResetAnchor %W @%x,%y
    set tkPriv(selectMode) char
    tkShTextSelectTo %W %x %y
}
bind ShText <Double-Shift-1>	{
    set tkPriv(selectMode) word
    tkShTextSelectTo %W %x %y
}
bind ShText <Triple-Shift-1>	{
    set tkPriv(selectMode) line
    tkShTextSelectTo %W %x %y
}
bind ShText <B1-Leave> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    tkShTextAutoScan %W
}
bind ShText <B1-Enter> {
    tkCancelRepeat
}
bind ShText <ButtonRelease-1> {
    tkCancelRepeat
}
bind ShText <Control-1> {
    %W mark set insert @%x,%y
}
bind ShText <Left> {
    tkShTextSetCursor %W [%W index {insert - 1c}]
}
bind ShText <Right> {
    tkShTextSetCursor %W [%W index {insert + 1c}]
}
bind ShText <Up> {
    tkShTextSetCursor %W [tkShTextUpDownLine %W -1]
}
bind ShText <Down> {
    tkShTextSetCursor %W [tkShTextUpDownLine %W 1]
}
bind ShText <Shift-Left> {
    tkShTextKeySelect %W [%W index {insert - 1c}]
}
bind ShText <Shift-Right> {
    tkShTextKeySelect %W [%W index {insert + 1c}]
}
bind ShText <Shift-Up> {
    tkShTextKeySelect %W [tkShTextUpDownLine %W -1]
}
bind ShText <Shift-Down> {
    tkShTextKeySelect %W [tkShTextUpDownLine %W 1]
}
bind ShText <Control-Left> {
    tkShTextSetCursor %W [%W index {insert - 1c wordstart}]
}
bind ShText <Control-Right> {
    tkShTextSetCursor %W [%W index {insert wordend}]
}
bind ShText <Control-Up> {
    tkShTextSetCursor %W [tkShTextPrevPara %W insert]
}
bind ShText <Control-Down> {
    tkShTextSetCursor %W [tkShTextNextPara %W insert]
}
bind ShText <Shift-Control-Left> {
    tkShTextKeySelect %W [%W index {insert - 1c wordstart}]
}
bind ShText <Shift-Control-Right> {
    tkShTextKeySelect %W [%W index {insert wordend}]
}
bind ShText <Shift-Control-Up> {
    tkShTextKeySelect %W [tkShTextPrevPara %W insert]
}
bind ShText <Shift-Control-Down> {
    tkShTextKeySelect %W [tkShTextNextPara %W insert]
}
bind ShText <Prior> {
    tkShTextSetCursor %W [tkShTextScrollPages %W -1]
}
bind ShText <Shift-Prior> {
    tkShTextKeySelect %W [tkShTextScrollPages %W -1]
}
bind ShText <Next> {
    tkShTextSetCursor %W [tkShTextScrollPages %W 1]
}
bind ShText <Shift-Next> {
    tkShTextKeySelect %W [tkShTextScrollPages %W 1]
}
bind ShText <Control-Prior> {
    %W xview scroll -1 page
}
bind ShText <Control-Next> {
    %W xview scroll 1 page
}

bind ShText <Home> {
    tkShTextSetCursor %W {insert linestart}
}
bind ShText <Shift-Home> {
    tkShTextKeySelect %W {insert linestart}
}
bind ShText <End> {
    tkShTextSetCursor %W {insert lineend}
}
bind ShText <Shift-End> {
    tkShTextKeySelect %W {insert lineend}
}
bind ShText <Control-Home> {
    tkShTextSetCursor %W 1.0
}
bind ShText <Control-Shift-Home> {
    tkShTextKeySelect %W 1.0
}
bind ShText <Control-End> {
    tkShTextSetCursor %W {end - 1 char}
}
bind ShText <Control-Shift-End> {
    tkShTextKeySelect %W {end - 1 char}
}

bind ShText <Tab> {
    tkShTextInsert %W \t
    focus %W
    break
}
bind ShText <Shift-Tab> {
    # Needed only to keep <Tab> binding from triggering;  doesn't
    # have to actually do anything.
}
bind ShText <Control-Tab> {
    focus [tk_focusNext %W]
}
bind ShText <Control-Shift-Tab> {
    focus [tk_focusPrev %W]
}
bind ShText <Control-i> {
    tkShTextInsert %W \t
}
bind ShText <Return> {
    tkShTextInsert %W \n
}
bind ShText <Delete> {
    if {[%W tag nextrange sel 1.0 end] != ""} {
	tkShTextDelete %W sel.first sel.last
    } else {
	tkShTextDelete %W insert
	%W see insert
    }
}
bind ShText <BackSpace> {
    if {[%W tag nextrange sel 1.0 end] != ""} {
	tkShTextDelete %W sel.first sel.last
    } elseif [%W compare insert != 1.0] {
	tkShTextDelete %W insert-1c
	%W see insert
    }
}

bind ShText <Control-space> {
    %W mark set anchor insert
}
bind ShText <Select> {
    %W mark set anchor insert
}
bind ShText <Control-Shift-space> {
    set tkPriv(selectMode) char
    tkShTextKeyExtend %W insert
}
bind ShText <Shift-Select> {
    set tkPriv(selectMode) char
    tkShTextKeyExtend %W insert
}
bind ShText <Control-slash> {
    %W tag add sel 1.0 end
}
bind ShText <Control-backslash> {
    %W tag remove sel 1.0 end
}
tkShTextClipboardKeysyms F16 F20 F18
bind ShText <Insert> {
    catch {tkShTextInsert %W [selection get -displayof %W]}
}
bind ShText <KeyPress> {
    tkShTextInsert %W %A
}

# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong.  Ditto for <Escape>.

bind ShText <Alt-KeyPress> {# nothing }
bind ShText <Meta-KeyPress> {# nothing}
bind ShText <Control-KeyPress> {# nothing}
bind ShText <Escape> {# nothing}
bind ShText <KP_Enter> {# nothing}

# Additional emacs-like bindings:

if !$tk_strictMotif {
    bind ShText <Control-a> {
	tkShTextSetCursor %W {insert linestart}
    }
    bind ShText <Control-b> {
	tkShTextSetCursor %W insert-1c
    }
    bind ShText <Control-d> {
	tkShTextDelete %W insert
    }
    bind ShText <Control-e> {
	tkShTextSetCursor %W {insert lineend}
    }
    bind ShText <Control-f> {
	tkShTextSetCursor %W insert+1c
    }
    bind ShText <Control-k> {
	if [%W compare insert == {insert lineend}] {
	    tkShTextDelete %W insert
	} else {
	    tkShTextDelete %W insert {insert lineend}
	}
    }
    bind ShText <Control-n> {
	tkShTextSetCursor %W [tkShTextUpDownLine %W 1]
    }
    bind ShText <Control-o> {
	%W insert insert \n
	%W mark set insert insert-1c
    }
    bind ShText <Control-p> {
	tkShTextSetCursor %W [tkShTextUpDownLine %W -1]
    }
    bind ShText <Control-t> {
	tkShTextTranspose %W
    }
    bind ShText <Control-v> {
	tkShTextScrollPages %W 1
    }
    bind ShText <Meta-b> {
	tkShTextSetCursor %W {insert - 1c wordstart}
    }
    bind ShText <Meta-d> {
	tkShTextDelete %W insert {insert wordend}
    }
    bind ShText <Meta-f> {
	tkShTextSetCursor %W {insert wordend}
    }
    bind ShText <Meta-less> {
	tkShTextSetCursor %W 1.0
    }
    bind ShText <Meta-greater> {
	tkShTextSetCursor %W end-1c
    }
    bind ShText <Meta-BackSpace> {
	tkShTextDelete %W {insert -1c wordstart} insert
    }
    bind ShText <Meta-Delete> {
	tkShTextDelete %W {insert -1c wordstart} insert
    }
    tkShTextClipboardKeysyms Meta-w Control-w Control-y

    # A few additional bindings of my own.

    bind ShText <Control-h> {
	if [%W compare insert != 1.0] {
	    tkShTextDelete %W insert-1c
	    %W see insert
	}
    }
    bind ShText <2> {
	%W scan mark %x %y
	set tkPriv(x) %x
	set tkPriv(y) %y
	set tkPriv(mouseMoved) 0
    }
    bind ShText <B2-Motion> {
	if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} {
	    set tkPriv(mouseMoved) 1
	}
	if $tkPriv(mouseMoved) {
	    %W scan dragto %x %y
	}
    }
    bind ShText <ButtonRelease-2> {
	if !$tkPriv(mouseMoved) {
	    catch {
		tkShTextInsertChars %W @%x,%y [selection get -displayof %W]
	    }
	}
    }
}
set tkPriv(prevPos) {}

# tkShTextButton1 --
# This procedure is invoked to handle button-1 presses in text
# widgets.  It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w -		The text window in which the button was pressed.
# x -		The x-coordinate of the button press.
# y -		The x-coordinate of the button press.

proc tkShTextButton1 {w x y} {
    global tkPriv

    set tkPriv(selectMode) char
    set tkPriv(mouseMoved) 0
    set tkPriv(pressX) $x
    $w mark set insert @$x,$y
    $w mark set anchor insert
    if {[$w cget -state] == "normal"} {focus $w}
}

# tkShTextSelectTo --
# This procedure is invoked to extend the selection, typically when
# dragging it with the mouse.  Depending on the selection mode (character,
# word, line) it selects in different-sized units.  This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Arguments:
# w -		The text window in which the button was pressed.
# x -		Mouse x position.
# y - 		Mouse y position.

proc tkShTextSelectTo {w x y} {
    global tkPriv

    set cur [$w index @$x,$y]
    if [catch {$w index anchor}] {
	$w mark set anchor $cur
    }
    set anchor [$w index anchor]
    if {[$w compare $cur != $anchor] || (abs($tkPriv(pressX) - $x) >= 3)} {
	set tkPriv(mouseMoved) 1
    }
    switch $tkPriv(selectMode) {
	char {
	    if [$w compare $cur < anchor] {
		set first $cur
		set last anchor
	    } else {
		set first anchor
		set last [$w index "$cur + 1c"]
	    }
	}
	word {
	    if [$w compare $cur < anchor] {
		set first [$w index "$cur wordstart"]
		set last [$w index "anchor - 1c wordend"]
	    } else {
		set first [$w index "anchor wordstart"]
		set last [$w index "$cur wordend"]
	    }
	}
	line {
	    if [$w compare $cur < anchor] {
		set first [$w index "$cur linestart"]
		set last [$w index "anchor - 1c lineend + 1c"]
	    } else {
		set first [$w index "anchor linestart"]
		set last [$w index "$cur lineend + 1c"]
	    }
	}
    }
    if {$tkPriv(mouseMoved) || ($tkPriv(selectMode) != "char")} {
	$w tag remove sel 0.0 $first
	$w tag add sel $first $last
	$w tag remove sel $last end
	update idletasks
    }
}

# tkShTextKeyExtend --
# This procedure handles extending the selection from the keyboard,
# where the point to extend to is really the boundary between two
# characters rather than a particular character.
#
# Arguments:
# w -		The text window.
# index -	The point to which the selection is to be extended.

proc tkShTextKeyExtend {w index} {
    global tkPriv

    set cur [$w index $index]
    if [catch {$w index anchor}] {
	$w mark set anchor $cur
    }
    set anchor [$w index anchor]
    if [$w compare $cur < anchor] {
	set first $cur
	set last anchor
    } else {
	set first anchor
	set last $cur
    }
    $w tag remove sel 0.0 $first
    $w tag add sel $first $last
    $w tag remove sel $last end
}

# tkShTextAutoScan --
# This procedure is invoked when the mouse leaves a text window
# with button 1 down.  It scrolls the window up, down, left, or right,
# depending on where the mouse is (this information was saved in
# tkPriv(x) and tkPriv(y)), and reschedules itself as an "after"
# command so that the window continues to scroll until the mouse
# moves back into the window or the mouse button is released.
#
# Arguments:
# w -		The text window.

proc tkShTextAutoScan {w} {
    global tkPriv
    if {$tkPriv(y) >= [winfo height $w]} {
	$w yview scroll 2 units
    } elseif {$tkPriv(y) < 0} {
	$w yview scroll -2 units
    } elseif {$tkPriv(x) >= [winfo width $w]} {
	$w xview scroll 2 units
    } elseif {$tkPriv(x) < 0} {
	$w xview scroll -2 units
    } else {
	return
    }
    tkShTextSelectTo $w $tkPriv(x) $tkPriv(y)
    set tkPriv(afterId) [after 50 tkShTextAutoScan $w]
}

# tkShTextSetCursor
# Move the insertion cursor to a given position in a text.  Also
# clears the selection, if there is one in the text, and makes sure
# that the insertion cursor is visible.  Also, don't let the insertion
# cursor appear on the dummy last line of the text.
#
# Arguments:
# w -		The text window.
# pos -		The desired new position for the cursor in the window.

proc tkShTextSetCursor {w pos} {
    global tkPriv

    if [$w compare $pos == end] {
	set pos {end - 1 chars}
    }
    $w mark set insert $pos
    $w tag remove sel 1.0 end
    $w see insert
}

# tkShTextKeySelect
# This procedure is invoked when stroking out selections using the
# keyboard.  It moves the cursor to a new position, then extends
# the selection to that position.
#
# Arguments:
# w -		The text window.
# new -		A new position for the insertion cursor (the cursor hasn't
#		actually been moved to this position yet).

proc tkShTextKeySelect {w new} {
    global tkPriv

    if {[$w tag nextrange sel 1.0 end] == ""} {
	if [$w compare $new < insert] {
	    $w tag add sel $new insert
	} else {
	    $w tag add sel insert $new
	}
	$w mark set anchor insert
    } else {
	if [$w compare $new < anchor] {
	    set first $new
	    set last anchor
	} else {
	    set first anchor
	    set last $new
	}
	$w tag remove sel 1.0 $first
	$w tag add sel $first $last
	$w tag remove sel $last end
    }
    $w mark set insert $new
    $w see insert
    update idletasks
}

# tkShTextResetAnchor --
# Set the selection anchor to whichever end is farthest from the
# index argument.  One special trick: if the selection has two or
# fewer characters, just leave the anchor where it is.  In this
# case it doesn't matter which point gets chosen for the anchor,
# and for the things like Shift-Left and Shift-Right this produces
# better behavior when the cursor moves back and forth across the
# anchor.
#
# Arguments:
# w -		The text widget.
# index -	Position at which mouse button was pressed, which determines
#		which end of selection should be used as anchor point.

proc tkShTextResetAnchor {w index} {
    global tkPriv

    if {[$w tag ranges sel] == ""} {
	$w mark set anchor $index
	return
    }
    set a [$w index $index]
    set b [$w index sel.first]
    set c [$w index sel.last]
    if [$w compare $a < $b] {
	$w mark set anchor sel.last
	return
    }
    if [$w compare $a > $c] {
	$w mark set anchor sel.first
	return
    }
    scan $a "%d.%d" lineA chA
    scan $b "%d.%d" lineB chB
    scan $c "%d.%d" lineC chC
    if {$lineB < $lineC+2} {
	set total [string length [$w get $b $c]]
	if {$total <= 2} {
	    return
	}
	if {[string length [$w get $b $a]] < ($total/2)} {
	    $w mark set anchor sel.last
	} else {
	    $w mark set anchor sel.first
	}
	return
    }
    if {($lineA-$lineB) < ($lineC-$lineA)} {
	$w mark set anchor sel.last
    } else {
	$w mark set anchor sel.first
    }
}

# tkShTextInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w -		The text window in which to insert the string
# s -		The string to insert (usually just a single character)

proc tkShTextInsert {w s} {
    if {($s == "") || ([$w cget -state] == "disabled")} {
	return
    }
    catch {
	if {[$w compare sel.first <= insert]
		&& [$w compare sel.last >= insert]} {
	    tkShTextDelete $w sel.first sel.last
	}
    }
    tkShTextInsertChars $w insert $s
    $w see insert
}

# tkShTextUpDownLine --
# Returns the index of the character one line above or below the
# insertion cursor.  There are two tricky things here.  First,
# we want to maintain the original column across repeated operations,
# even though some lines that will get passed through don't have
# enough characters to cover the original column.  Second, don't
# try to scroll past the beginning or end of the text.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# n -		The number of lines to move: -1 for up one line,
#		+1 for down one line.

proc tkShTextUpDownLine {w n} {
    global tkPriv

    set i [$w index insert]
    scan $i "%d.%d" line char
    if {[string compare $tkPriv(prevPos) $i] != 0} {
	set tkPriv(char) $char
    }
    set new [$w index [expr $line + $n].$tkPriv(char)]
    if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} {
	set new $i
    }
    set tkPriv(prevPos) $new
    return $new
}

# tkShTextPrevPara --
# Returns the index of the beginning of the paragraph just before a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w -		The text window in which the cursor is to move.
# pos -		Position at which to start search.

proc tkShTextPrevPara {w pos} {
    set pos [$w index "$pos linestart"]
    while 1 {
	if {(([$w get "$pos - 1 line"] == "\n") && ([$w get $pos] != "\n"))
		|| ($pos == "1.0")} {
	    if [regexp -indices {^[ 	]+(.)} [$w get $pos "$pos lineend"] \
		    dummy index] {
		set pos [$w index "$pos + [lindex $index 0] chars"]
	    }
	    if {[$w compare $pos != insert] || ($pos == "1.0")} {
		return $pos
	    }
	}
	set pos [$w index "$pos - 1 line"]
    }
}

# tkShTextNextPara --
# Returns the index of the beginning of the paragraph just after a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w -		The text window in which the cursor is to move.
# start -	Position at which to start search.

proc tkShTextNextPara {w start} {
    set pos [$w index "$start linestart + 1 line"]
    while {[$w get $pos] != "\n"} {
	if [$w compare $pos == end] {
	    return [$w index "end - 1c"]
	}
	set pos [$w index "$pos + 1 line"]
    }
    while {[$w get $pos] == "\n"} {
	set pos [$w index "$pos + 1 line"]
	if [$w compare $pos == end] {
	    return [$w index "end - 1c"]
	}
    }
    if [regexp -indices {^[ 	]+(.)} [$w get $pos "$pos lineend"] \
	    dummy index] {
	return [$w index "$pos + [lindex $index 0] chars"]
    }
    return $pos
}

# tkShTextScrollPages --
# This is a utility procedure used in bindings for moving up and down
# pages and possibly extending the selection along the way.  It scrolls
# the view in the widget by the number of pages, and it returns the
# index of the character that is at the same position in the new view
# as the insertion cursor used to be in the old view.
#
# Arguments:
# w -		The text window in which the cursor is to move.
# count -	Number of pages forward to scroll;  may be negative
#		to scroll backwards.

proc tkShTextScrollPages {w count} {
    set bbox [$w bbox insert]
    $w yview scroll $count pages
    if {$bbox == ""} {
	return [$w index @[expr [winfo height $w]/2],0]
    }
    return [$w index @[lindex $bbox 0],[lindex $bbox 1]]
}

# tkShTextTranspose --
# This procedure implements the "transpose" function for text widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line.  In this case it
# transposes the two characters to the left of the cursor.  In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w -		Text window in which to transpose.

proc tkShTextTranspose w {
    set pos insert
    if [$w compare $pos != "$pos lineend"] {
	set pos [$w index "$pos + 1 char"]
    }
    set new [$w get "$pos - 1 char"][$w get  "$pos - 2 char"]
    if [$w compare "$pos - 1 char" == 1.0] {
	return
    }
    tkShTextDelete $w "$pos - 2 char" $pos
    tkShTextInsertChars $w insert $new
    $w see insert
}

# ----------------------------------------------------------------
# [mbl] new procs for shared text
#

# globals used for shared text editing
#
# tkShNextId -		a unique ID to be used for creating "share ids".
# tkShId -			indexed by widget name. 
#					Gives the associated "share id".
#					All widgets in the same session have the same share id.
# tkShWidgetList -	indexed by share id. 
#					Gives the list of text widget names.
# tkShScrollList -	indexed by share id. 
#					Gives the list of scroll indicator widget names.
# tkShWidgetOwner -	indexed by widget name.
#					Gives the name of the user "owning" the widget.
# tkShUserColor -	indexed by user name.
#					Gives the color associated to that user
# tkShJoinCallback -	indexed by widget name.
#						Gives the script to execute when a widget joins the session.
# tkShLeaveCallback -	indexed by widget name.
#						Gives the script to execute when a widget leaves the session.
# shscrollHeight -	indexed by scroll indicator widget name.
#					Gives the height of the widget

# tkShTextDelete --
# This proc replaces the 'delete' text command for shared text widgets.
# It deletes the text between 'from' and 'to' in all the widgets that are
# in the same session as widget 'w'.
#
# Arguments:
# w -		The text widget.
# from -	The index from which to delete characters.
# to -		The index until which to delete characters. Defaults to 'insert'.
#
proc tkShTextDelete {w from {to insert}} {
	# convert indices to absolute values
	set from [$w index $from]
	set to [$w index $to]
	
	# update all instances
	global tkShWidgetList tkShId
	foreach widget $tkShWidgetList($tkShId($w)) {
		$widget delete $from $to
	}
}

# tkShTextInsertChars --
# This proc replaces the 'insert' text command for shared text widgets.
# It inserts characters at a given position in all the widgets that are
# in the same session as widget 'w'.
# The inserted characters are tagged with the name of the owner of 
# widget 'w'.
#
# Arguments:
# w -		The text widget.
# pos -		The index at which to insert characters.
# chars -	The string to insert.
#
proc tkShTextInsertChars {w pos chars} {
	# convert indices to absolute values
	set pos [$w index $pos]
	global tkShWidgetOwner
	set owner $tkShWidgetOwner($w)
	
	# compute the list of tags to apply to inserted characters.
	# copy all tags except 'sel' and user names.
	# XXX with a list containing all the forbidden tags, this might be faster.
	global tkShUserColor
	set tags {}
	set users [array names tkShUserColor]
	foreach tag [$w tag names insert] {
		if {[string compare $tag "sel"] == 0} {
			# don't copy selection
			continue
		}
		if {[lsearch -exact $users $tag] < 0} {
			lappend tags $tag
		}
	}
	# append owner's tag
	lappend tags $owner
	
	# update all instances
	global tkShWidgetList tkShId
	foreach widget $tkShWidgetList($tkShId($w)) {
		$widget insert $pos $chars $tags
	}
}

# tkShTextAddTag --
# tkShTextRemoveTag --
# These procs replace the 'tag add'/'tag remove' text commands for shared 
# text widgets. They add/remove tags in all the widgets that are in the 
# same session as widget 'w'.
#
# Arguments:
# w -		The text widget.
# tag -		The tag to add to the characters.
# from -	The index of the first character to be tagged/untagged.
# to -		The index of the last character to be tagged/untagged.
#
proc tkShTextAddTag {w tag from to} {
	# convert indices to absolute values
	set from [$w index $from]
	set to [$w index $to]

	# update all instances
	global tkShWidgetList tkShId
	foreach widget $tkShWidgetList($tkShId($w)) {
		$widget tag add $tag $from $to
	}
}

proc tkShTextRemoveTag {w tag from to} {
	# convert indices to absolute values
	set from [$w index $from]
	set to [$w index $to]

	# update all instances
	global tkShWidgetList tkShId
	foreach widget $tkShWidgetList($tkShId($w)) {
		$widget tag remove $tag $from $to
	}
}

# tkShNextId --
# This global variable is used to generate unique "share ids".
# A "share id" (shid) identifies a session, i.e. all the widgets
# sharing the same text.
#
set tkShNextId 0

# define a binding to ensure proper termination of a shared session
# when a shared text widget is destroyed.
#
bind ShText <Destroy> {
	tkUnsetSharedText %W
}

# tkSetSharedText --
# This proc creates a new shared editing session or adds a text widget to 
# an existing session. In the latter case, the joining widget's contents
# is cleared and replaced by the current state of the shared text, and the
# other widgets in the session are notified of the new member.
#
# Arguments:
# w -		The text widget.
# owner -	The name of the user owning this widget.
# other -	Another text widget in the same session. Defaults to null.
#			If null, a new session is created with 'w' as only member.
#
proc tkSetSharedText {w owner {other {}}} {
	# change the tag list to use 'ShText' bindings rather than 'Text' bindings.
	# XXX we shoud _replace_ Text by ShText in the bindtags rather than set it.
	bindtags $w [list $w ShText . all]
	
	# register the widget's owner
	global tkShWidgetOwner 
	set tkShWidgetOwner($w) $owner
	
	# change the background color to the owner's color.
	global tkShUserColor
	$w configure -background $tkShUserColor($owner)
	
	# activate Identification mode (XXX this could be commented out)
	tkIdentifySharedText $w on

	global tkShWidgetList tkShId tkShNextId
	if {$other == {}} {
		# create a new session: 
		# - generate new share id
		set id shid$tkShNextId
		incr tkShNextId
		# - initialize global arrays
		set tkShId($w) $id
		set tkShWidgetList($id) [list $w]
		set tkShScrollList($id) {}
	} else {
		# join an existing session:
		# - register ourselves
		set id $tkShId($other)
		set tkShId($w) $id
		# - remove text in w and copy text from other into w
		$w delete 1.0 end
		$w insert end [$other get 1.0 end]
		foreach tag [$other tag names] {
			if {[string compare $tag "sel"] == 0} {
				# don't copy selection
				continue
			}
			set range [$other tag ranges $tag]
			if {[string compare $range {}] != 0} {
				# use eval to flatten $range
				eval $w tag add $tag $range
			}
		}
		# - update scroll indicators, if any
		shscrollAddIndicator $w
		# - notify other widgets in the session
		global tkShJoinCallback
		foreach widget $tkShWidgetList($id) {
			catch {
				eval $tkShJoinCallback($widget) $w
			}
		}
		# - update widget list
		lappend tkShWidgetList($id) $w
	}
}

# tkUnsetSharedText --
# This proc removes 'w' from the set of widgets in a shared editing session.
# It is called automatically before a text widget is destroyed. If 'w' is the
# last widget in the editing session, the session is destroyed.
#
# Arguments:
# w -		The text widget
#
proc tkUnsetSharedText {w} {
	# reset text bindings
	# XXX we shoud _replace_ ShText by Text in the bindtags rather than set it.
	bindtags $w [list $w Text . all]
	
	# update globals
	global tkShId tkShWidgetOwner tkShWidgetList tkShScrollList
	if {[catch { set id $tkShId($w) }] != 0} {
		# this is probably not a shared text widget
		return
	}
	
	set i [lsearch -exact $tkShWidgetList($id) $w]
	if {$i < 0} {
		return
	}
	set tkShWidgetList($id) [lreplace $tkShWidgetList($id) $i $i]
	
	if {[llength $tkShWidgetList($id)] == 0} {
		# no widget left in session: kill it
		unset tkShWidgetList($id)
	} else {
		# update scroll indicators, if any
		shscrollRemoveIndicator $w
		# notify other widgets in the session
		global tkShLeaveCallback
		foreach widget $tkShWidgetList($id) {
			catch {
				eval $tkShLeaveCallback($widget) $w
			}
		}
	}
	
	unset tkShId($w)
	unset tkShWidgetOwner($w)
	
	# XXX problems
	# - we don't reset the bg color to the default.
	# - we don't change the yscrollcommand callback.
	# - we don't deal with any scroll indicator widget associated to 'w'.
	# In other words, this is mostly meant for the Destroy binding
}

# tkIdentifySharedText --
# This proc activates/deactivates the Identification mode of a shared text
# widget. When this mode is active, the characters' background color reflects
# the identity of the user who typed them.
#
# XXX note: the coloring is done for all the users in the tkShUserColor array.
# XXX instead of the users currently in the session.
# XXX If we want to the latter, then we have to make sure than when a user
# XXX joins/leaves, the proper tag configuration occurs.
#
# Arguments:
# w -		The text widget.
# on -		A boolean indicating whether to activate or deactivate the mode.
#
proc tkIdentifySharedText {w on} {
	global tkShUserColor tkShWidgetOwner
	set owner $tkShWidgetOwner($w)
	set default [$w cget -background]
	if {$on} {
		foreach user [array names tkShUserColor] {
			# don't use color for the user's own text
			if {[string compare $user $owner] != 0} {
				$w tag configure $user -background $tkShUserColor($user)
			}
		}
	} else {
		foreach user [array names tkShUserColor] {
			if {[string compare $user $owner] != 0} {
				$w tag configure $user -background $default
			}
		}
	}
}

# shscroll --
# This proc creates a scroll indicator widget associated to a shared text.
# Note: tkSetSharedText must already have been called for the text widget.
#
# Arguments:
# si -		The name of the scroll indicator widget to be created.
# w -		The shared text widget associated to the scroll indicator.
# args -	configuration options for the canvas implementing the scroll indicator.
#
# Return value:
#			The name of the scroll indicator.
#
proc shscroll {si w args} {
	global tkShId tkShWidgetOwner tkShWidgetList tkShScrollList
	
	# update globals
	set id $tkShId($w)
	set owner $tkShWidgetOwner($w)
	set tkShId($si) $id
	set tkShWidgetOwner($si) $owner
	lappend tkShScrollList($id) $si
	
	# create canvas
	eval canvas $si -width 2 $args -background white
	global shscrollHeight
	set shscrollHeight($si) [$si cget -height]
	bind $si <Configure> {
		# recompute indicators on change size
		set shscrollHeight(%W) %h
		set id $tkShId(%W)
		foreach widget $tkShWidgetList($id) {
			eval shscrollSetOne %W $tkShWidgetOwner($widget) [$widget yview]	
		}	
	}
	bind $si <Destroy> {
		# clean up on destroy
		shscrollDestroy %W
	}
	
	# add indicators for existing text widgets in session
	foreach widget $tkShWidgetList($id) {
		set user $tkShWidgetOwner($widget)
		# skip owner
		if {[string compare $owner $user] == 0} {
			continue
		}
		# add indicator in this scroll indicator only
		shscrollAddOneIndicator $si $user
	}
	
	return $si
}	

# shscrollDestroy --
# This proc is called when a scroll indicator widget is destroyed.
#
# Arguments:
# w -		The scroll indicator widget.
proc shscrollDestroy {w} {
	global tkShId tkShWidgetOwner tkShScrollList
	set id $tkShId($w)
	
	# update globals
	unset tkShId($w)
	unset tkShWidgetOwner($w)
	unset shscrollHeight($w)
	set i [lsearch -exact $tkShScrollList($id) $w]
	if {$i < 0} {
		return
	}
	set tkShScrollList($id) [lreplace $tkShScrollList($id) $i $i]
	
	if {[llength $tkShScrollList($id)] == 0} {
		# no widget left in session: kill it
		unset tkShScrollList($id)
	}
}

# shscrollAddIndicator --
# Adds an indicator for a new shared text widget in all the scroll indicators
# bound to a session.
#
# Arguments:
# w -		The text widget entering the session.
#
proc shscrollAddIndicator {w} {
	global tkShId tkShWidgetOwner tkShScrollList
	
	set id $tkShId($w)
	set owner $tkShWidgetOwner($w)
	set scrolls $tkShScrollList($id)
	
	# add an indicator to each canvas in the list $scrolls,
	# except those whose owner is the same as the owner of 'w'
	foreach scroll $scrolls {
		if {[string compare $owner $tkShWidgetOwner($scroll)] == 0} {
			continue
		}
		shscrollAddOneIndicator $scroll $owner
	}
}

# shscrolAddOneIndicator --
# This proc adds an indicator to a scroll indicator.
#
# Arguments:
# scroll -		The scroll indicator widget.
# owner -		The owner of both widgets.
#
proc shscrollAddOneIndicator {scroll owner} {
	# move existing indicators to the right
	set width 5
	$scroll move all $width 0
	
	# create the new indicator to the left of the existing ones
	global tkShUserColor
	set color $tkShUserColor($owner)
	$scroll create rectangle 3 0 [expr $width + 3] 100 -fill $color -tags $owner
	
	# enlarge the canvas
	$scroll configure -width [expr [$scroll cget -width] + $width]
}

# shscrollRemoveIndicator --
# Removes an indicator for a shared text widget in all the scroll indicators
# bound to a session.
#
# Arguments:
# w -		The text widget leaving the session.
#
proc shscrollRemoveIndicator {w} {
	global tkShId tkShWidgetOwner tkShScrollList
	
	set id $tkShId($w)
	set owner $tkShWidgetOwner($w)
	set scrolls $tkShScrollList($id)
	set width 5
	
	# remove an indicator from each canvas in the list $scrolls
	foreach scroll $scrolls {
		$scroll delete $owner
		# XXX need to collapse remaining indicators and to reduce canvas width
	}
}

# shscrollSet --
# This proc is to be used as a callback script for the -yscrollcommand
# option of a shared text widget. It updates a regular scrollbar and also
# updates the scroll indicators associated to the different text widgets
# in the session.
#
# Arguments:
# w -		The text widget.
# sb -		The vertical scrollbar.
# first -	The relative postion of the first visible position.
# last -	The relative postion of the last visible position.
#
proc shscrollSet {w sb first last} {
	catch {
		$sb set $first $last
	}
	
	global tkShScrollList tkShId tkShWidgetOwner
	catch {
		# XXX we use a catch because tkShScrollList might not be set yet
		set owner $tkShWidgetOwner($w)
		foreach shs $tkShScrollList($tkShId($w)) {
			shscrollSetOne $shs $owner $first $last
		}
	}
}

# shscrollSetOne --
# This proc sets the position and height of the indicator corresponding
# to owner in the scroll indicator shs.
#
# Arguments:
# shs -		The scroll indicator widget.
# owner -	The owner of the indicator to be updated.
# first -	The relative postion of the first visible position.
# last -	The relative postion of the last visible position.
#
proc shscrollSetOne {shs owner first last} {
	set coords [$shs coords $owner]
	set x0 [lindex $coords 0]
	set x1 [lindex $coords 2]

	global shscrollHeight
	set h $shscrollHeight($shs)
	set y0 [expr $h * $first]
	set y1 [expr $h * $last]
	if {$y1 - $y0 < 6} {
		set y [expr ($y0 + $y1) / 2]
		set y0 [expr $y - 3]
		set y1 [expr $y + 3]
	}
	$shs coords $owner $x0 $y0 $x1 $y1
}

#---- test program

proc makeMenu {mbar menu title cdata args} {
	set mbutton $mbar.m$menu
	set mpath $mbar.m$menu.$menu
	menubutton $mbutton -text $title -menu $mpath
	pack $mbutton -side left
	menu $mpath
	foreach entry $args {
		if {[llength $entry] == 0} {
			$mpath add separator
		} else {
			set title [lindex $entry 0]
			set callback [lindex $entry 1]
			$mpath add command -label $title -command [concat $callback $cdata]
		}
	}
}


set charStyles {underline super sub}
set paraStyles {title}

proc defineTextStyles {txt} {
	$txt tag configure underline -underline on
	$txt tag configure super -offset 4p -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-*
	$txt tag configure sub -offset -2p -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-*
	
	$txt tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
}

proc makeTextWindow {top {owner {}} {sharewith {}}} {
	# create toplevel
	toplevel $top
	if {[string length $owner] > 0} {
		wm title $top $owner
	}
	
	# create menubar and menus
	frame $top.mbar
	
	makeMenu $top.mbar file "File" $top \
		{"New" fileNew} \
		{"Open ..." fileOpen} \
		{"Close" fileClose} \
		{"Save" fileSave} \
		{"Save as ..." fileSaveAs} \
		{"Share with ..." fileShareWith} \
		{"Quit" fileQuit}
 
	makeMenu $top.mbar edit "Edit" $top.text \
		{"Cut" editCut} \
		{"Copy" editCopy} \
		{"Paste" editPaste} \
		{"Clear" editClear} \
		{"Select All" editSelectAll}
	
	makeMenu $top.mbar style "Style" $top.text \
		{"Plain" {charStyle {}}} \
		{"Underline" {charStyle underline}} \
		{"Superscript" {charStyle super}} \
		{"Subscript" {charStyle sub}} \
		{} \
		{"Paragraph" {paraStyle {}}} \
		{"Title" {paraStyle title}}

	# XXX this menu is incomplete
	makeMenu $top.mbar group "Group" $top.text \
		{"Own" groupOwn} \
		{} \
		{"Michel" puts } \
		{"Wendy" puts } \
		{"Alex" puts }

	# create text and scrollbar
	text $top.text -width 30 -yscrollcommand [list shscrollSet $top.text $top.sb]
	scrollbar $top.sb -command [list $top.text yview]
	defineTextStyles $top.text
	
	# enable text sharing
	if {[string compare $owner {}] != 0} {
		if {[string compare $sharewith {}] != 0} {
			tkSetSharedText $top.text $owner $sharewith
		} else {
			tkSetSharedText $top.text $owner
		}
	}
	
	# create scroll indicator
	shscroll $top.si $top.text

	# pack everything
	pack $top.mbar -side top -fill x
	pack $top.text -side left -fill both -expand on
	pack $top.si -side left -fill y
	pack $top.sb -side left -fill y
}

set nextWindowId 1

proc fileNew {top} {
	global nextWindowId tkShWidgetOwner
	makeTextWindow .w$nextWindowId $tkShWidgetOwner($top.text)
	incr nextWindowId
}

proc fileOpen {top} {
	set file [PromptString "File to open"]
	if {[string compare $file ""] == 0} {
		return
	}
	if {[catch {set fid [open $file "r"]}] != 0} {
		return
	}
	
	tkShTextDelete $top.text 1.0 end
	gets $fid line
	while {! [eof $fid]} {
		tkShTextInsertChars $top.text end $line
		tkShTextInsertChars $top.text end "\n"
		gets $fid line
	}
	
	close $fid
}

proc fileClose {top} {
	destroy $top
}

proc fileSave {top} {
	# XXX TBD
}

proc fileSaveAs {top} {
	# XXX TBD
}

proc fileShareWith {top} {
	global nextWindowId tkShWidgetOwner
	set user [PromptString "User name to share text with"]
	if {[string compare $user ""] == 0} {
		return
	}
	makeTextWindow .w$nextWindowId $user $top.text
	incr nextWindowId
}

proc fileQuit {top} {
	destroy .
}

proc editCut {txt} {
	if {[selection own -displayof $txt] == "$txt"} {
		clipboard clear -displayof $txt
		catch {
			clipboard append -displayof $txt [selection get -displayof $txt]
			tkShTextDelete $txt sel.first sel.last
		}
	}
}

proc editCopy {txt} {
	if {[selection own -displayof $txt] == "$txt"} {
		clipboard clear -displayof $txt
		catch {
			clipboard append -displayof $txt [selection get -displayof $txt]
		}
	}
}

proc editPaste {txt} {
	catch {
		tkShTextInsterChars $txt insert [selection get -displayof $txt \
			-selection CLIPBOARD]
	}
}

proc editClear {txt} {
	tkShTextDelete $txt sel.first sel.last
}

proc editSelectAll {txt} {
	$txt tag add sel 1.0 end
}

proc charStyle {style txt} {
	global charStyles

	if {[$txt tag nextrange sel 1.0 end] == ""} {
		return
	}

	foreach cstyle $charStyles {
		tkShTextRemoveTag $txt $cstyle sel.first sel.last
	}
	if {[string compare $style {}] != 0} {
		tkShTextAddTag $txt $style sel.first sel.last
	}
}

proc paraStyle {style txt} {
	global paraStyles
	foreach pstyle $paraStyles {
		tkShTextRemoveTag $txt $pstyle {insert linestart} {insert lineend}
	}
	if {[string compare $style {}] != 0} {
		tkShTextAddTag $txt $style {insert linestart} {insert lineend}
	}
}

proc groupOwn {txt} {
	if {[$txt tag nextrange sel 1.0 end] == ""} {
		return
	}

	global tkShUserColor tkShWidgetOwner
	foreach user [array names tkShUserColor] {
		tkShTextRemoveTag $txt $user sel.first sel.last
	}
	tkShTextAddTag $txt $tkShWidgetOwner($txt) sel.first sel.last
}

proc PromptString {msg {dflt {}}} {
	global reply
	
	set reply $dflt
	toplevel .prompt
	label .prompt.msg -text $msg
	entry .prompt.reply -textvariable reply
	button .prompt.ok -text "Ok" -command {destroy .prompt}
	button .prompt.cancel -text "Cancel" -command {set reply {}; destroy .prompt}
	
	pack .prompt.msg -side top -anchor w
	pack .prompt.reply -side top -anchor w -fill x
	pack .prompt.cancel -side right -padx 5 -pady 5
	pack .prompt.ok -side right -padx 5 -pady 5
	
	.prompt.reply selection range 0 end
	bind .prompt.reply <Return> {.prompt.ok invoke}
	focus .prompt.reply
	
	tkwait window .prompt
	return $reply
}

# set tkShUserColor(Michel) green
# set tkShUserColor(Wendy) blue
# set tkShUserColor(Alex) red

set tkShUserColor(Michel) "#aaffaa"
set tkShUserColor(Wendy) "#aaaaff"
set tkShUserColor(Alex) "#ffaaaa"

#
makeTextWindow .w0 Michel

#TODO
# use 2 arrays for colors: fg / bg color
#
# save/load text file

proc FOO {} {
# create text and scrollbar 1
text .t1 -width 20 -yscrollcommand {tkShSetScroll .t1 .s1}
scrollbar .s1 -command {.t1 yview}

# create text and scrollbar 2
text .t2 -width 20 -yscrollcommand {tkShSetScroll .t2 .s2}
scrollbar .s2 -command {.t2 yview}

# create text and scrollbar 3
text .t3 -width 20 -yscrollcommand {tkShSetScroll .t3 .s3}
scrollbar .s3 -command {.t3 yview}

# enable sharing

tkSetSharedText .t1 Michel
tkSetSharedText .t2 Wendy .t1
tkSetSharedText .t3 Alex .t2

makeShScroll .c1 .t1
makeShScroll .c2 .t2
makeShScroll .c3 .t3

# pack
pack .t1 -side left -fill both -expand on
pack .c1 -side left -fill y
pack .s1 -side left -fill y

pack .t2 -side left -fill both -expand on
pack .c2 -side left -fill y
pack .s2 -side left -fill y

pack .t3 -side left -fill both -expand on
pack .c3 -side left -fill y
pack .s3 -side left -fill y

.t1 tag configure title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*
.t1 tag configure bold -font -*-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*
.t1 tag configure big -font -*-Courier-Bold-R-Normal--*-140-*-*-*-*-*-*
.t1 tag configure verybig -font -*-Helvetica-Bold-R-Normal--*-240-*-*-*-*-*-*
.t1 tag configure super -offset 4p -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-*
.t1 tag configure sub -offset -2p -font -Adobe-Courier-Medium-R-Normal--*-100-*-*-*-*-*-*

.t1 insert insert "title\n" title
.t1 insert insert "not bold" {} " bold" bold "not bold\n" {}
.t1 insert insert "normal" {} " big" big " superbig\n" verybig
.t1 insert insert "normal" {} "super" super " normal" {} "sub\n" sub
}