#####################################################
# proc richtext pathname [-option value ...]
# 
# builds a text widget with word processing capability
# i. e. wrap word, cursor up/down by displayed line.
#
# Usage:
# richtext .wp ? option value ? ...
# produces a widget with certain WP abilities:
#
# Cursor navigates as expected by some DAU even if line is wrapped.
# Smart quotes: none, de, en ... (switchable).
# Typographical dashes by key sequences -- and --- (switchable).
# Triple-click selects grammatical sentence.
# Quadruple-click selects logical line (= paragraph)
#
# ::Richtext::requireTypoDash ? (1 | 0) ?
# switches double & triple key minus to produce typographical dashes
# 
# ::Richtext::setQuotes ? (de | en | fr | ch | C) ?
# switches keys \" and \' to produce national "smart" quotes
# or just \" if lang is C (which is default).
#
# 2003-03-13 Wolf Busch, Oberkleen
######################################################

namespace eval Richtext {
    namespace export richtext
    array set object {}
    variable quoteMode C
    variable doubleQuotes [list \" \"]
    variable singleQuotes [list ' ']
    variable typoDashRequired 1
    variable actualWindow {}
    variable actualObject {}
}

proc ::Richtext::richtext {widget {objectName {}}} {
    variable object
    eval text $widget -wrap word
    if {$objectName ne {}} {
	set object($widget) $objectName
    }
    set taglist {}
    foreach tag [bindtags $widget] {
	if {$tag eq "Text"} {
	    # lappend taglist Beforetext Richtext Aftertext
	    lappend taglist Richtext
	} else {
	    lappend taglist $tag
	}
    }
    bindtags $widget $taglist
    $widget configure -cursor ""
    return $widget
}

proc ::Richtext::unselectTablePartiallySelected {text} {
    if {[$text tag ranges sel] ne {}} {
	foreach {from to} [$text tag ranges blockobject] {
	    if {[$text compare $from < sel.first] &&\
		    [$text compare $to > sel.first]} {
		$text tag remove sel sel.first $to
		if {[$text compare insert < $to]} {
		    $text mark set insert $to
		}
		if {[$text tag ranges sel] eq {}} {
		    break
		}
	    }
	    if {[$text compare $to > sel.last] &&\
		    [$text compare $from < sel.last]} {
		$text tag remove sel $from-1chars sel.last
		if {[$text compare insert > $from-1chars]} {
		    $text mark set insert $from-1chars
		}
		if {[$text tag ranges sel] eq {}} {
		    break
		}
	    }
	}
    }
}

proc ::Richtext::TextInsert {w s} {
    variable object
    if {[string equal $s ""] ||\
	    [string equal [$w cget -state] "disabled"]} {
	return
    }
    set compound 0
    catch {
	if {[$w compare sel.first <= insert] &&\
		[$w compare sel.last >= insert]} {
	    set oldSeparator [$w cget -autoseparators]
	    if { $oldSeparator } {
		$w configure -autoseparators 0
		$w edit separator
		set compound 1
	    }
	    unselectTablePartiallySelected $w
	    $w delete sel.first sel.last
	}
    }
    # $w insert insert $s
    $w insert insert $s [$w tag names insert]
    $w see insert
    if { $compound && $oldSeparator } {
	$w edit separator
	$w configure -autoseparators 1
    }
    if {[info exists object($w)]} {
	$object($w) configure -changed 1
    }
}

proc ::Richtext::requireTypoDash {{typo 1}} {
    variable typoDashRequired
    set typoDashRequired $typo
}

proc ::Richtext::insertDash {widget {index insert}} {
    variable typoDashRequired
    set tags [$widget tag names $index]
    if {[atWordEnd $widget $index]} {
	eval lappend tags [$widget tag names $index-1chars]
    }
    if {[string is true $typoDashRequired] &&\
	    ([lsearch $tags pre] < 0) &&\
	    ([lsearch $tags tt] < 0)} {
	switch -- .[$widget get $index-1chars] {
	    .- {
		$widget delete $index-1chars
		$widget insert $index \u2013
	    }
	    .\u2013 {
		$widget delete $index-1chars
		$widget insert $index \u2014	    
	    }
	    default {
		$widget insert $index -
	    }
	}
    } else {
	$widget insert $index -
    }
}

proc ::Richtext::atWordEnd {widget {index insert}} {
    variable doubleQuotes
    variable singleQuotes
    set endpattern ""
    append endpattern \
	\[^\[:space:\]\] \
	\[ \
	\[:space:\] \
	{?!:.,} \
	">\)\\\]\}" \
	\] 
    #
    set startpattern ""
    append startpattern \
	\[ \
	"\{\[(<" \
	[lindex $doubleQuotes 1]\
	[lindex $singleQuotes 1]\
	\].
    #
    if {[$widget compare $index == 1.0]} {
	return 0
    } elseif {[regexp\
		   $startpattern\
		   [$widget get $index-1chars $index+1chars]]} {
	return 0
    } elseif {[regexp\
		   $endpattern\
		   [$widget get $index-1chars $index+1chars]]} {
	return 1
    } else {
	return 0
    }
}

proc ::Richtext::insertQuote {widget {index insert} {quotelist doubleQuotes}} {
    set tags [$widget tag names $index]
    if {[atWordEnd $widget $index]} {
	eval lappend tags [$widget tag names $index-1chars]
    }
    if {([lsearch $tags pre] >= 0) || ([lsearch $tags tt] >= 0)} {
	switch $quotelist {
	    doubleQuotes {
		$widget insert $index \" $tags
	    }
	    default {
		$widget insert $index ' $tags
	    }
	}
	return
    }
    variable doubleQuotes
    variable singleQuotes
    upvar 0 $quotelist quotes
    if {[atWordEnd $widget $index]} {
	$widget insert $index [lindex $quotes end] $tags
    } else {
	$widget insert $index [lindex $quotes 0] $tags
    }
}

proc ::Richtext::setQuotes {{language C}} {
    variable doubleQuotes
    variable singleQuotes
    variable quoteMode
    switch [string tolower $language] {
	german - deutsch - de {
	    set quoteMode de
	    set singleQuotes [list \u201a \u2018]
	    set doubleQuotes [list \u201e \u201c]
	}
	englisch - english - en {
	    set quoteMode en
	    set singleQuotes [list \u2018 \u2019]
	    set doubleQuotes [list \u201c \u201d]
	}
	schweiz - schweizerisch - swiss - suisse - ch {
	    set quoteMode ch
	    set singleQuotes [list \u203a \u2039]
	    set doubleQuotes [list \u00bb \u00ab]
	}
	französisch - francais - fr {
	    set quoteMode fr
	    set singleQuotes [list \u2039 \u203a]
	    set doubleQuotes [list \u00ab \u00bb]
	}
	default {
	    set quoteMode C
	    set singleQuotes [list ' ']
	    set doubleQuotes [list \" \"]
	}
    }
    echo quoteMode $quoteMode
}

namespace import Richtext::richtext

proc tmp {} {
    foreach binding [bind Text] {
	bind Richtext $binding\
	    [string map\
		 {tk::TextInsert Richtext::TextInsert}\
		 [bind Text $binding]]
    }
    # bind Richtext <Quadruple-Button-1> [bind Text <Triple-Button-1>]
    #     bind Richtext <Quadruple-Button-1> {
    # 	::tk::TextSetCursor %W [list @%x,%y linestart]
    # 	::tk::TextKeySelect %W insert+1lines
    #     }
    bind Richtext <Control-Key-minus> {
	tk::TextInsert %W \u00ad
    }
    bind Richtext <Control-Key-l> {
	tk::TextInsert %W \n\u000c\n
    }
    bind Richtext <Alt-Key-2> {
	tk::TextInsert %W \"
    }
    bind Richtext <Alt-Key-numbersign> {
	tk::TextInsert %W '
    }
    bind Richtext <Alt-Control-e> {
	tk::TextInsert %W \u20ac
    }
    bind Richtext <Quadruple-Button-1> [list [lambda {w x y} {
	# bind Richtext <Quadruple-Button-1> (this)
	set linestart [$w index "@$x,$y linestart"]
	if {[lsearch [$w tag names $linestart] prefix] >= 0} {
	    set range [$w tag prevrange prefix $linestart+1chars]
	    set linestart [lindex $range end]
	}
	::tk::TextSetCursor $w $linestart
	::tk::TextKeySelect $w "insert linestart + 1lines"
    }] %W %x %y]
    foreach {key script} {
	<Triple-Button-1> {
	    set tk::Priv(selectMode) sentence
	    tk::TextSetCursor %W\
		[Richtext::prevSentenceIndex %W [%W index @%x,%y]]
	    tk::TextKeySelect %W\
		[Richtext::nextSentenceIndex %W insert]
	}
	<Shift-Button-1> {
	    tk::TextResetAnchor %W @%x,%y
	    tk::TextSelectTo %W %x %y 1
	}
	<Up> {
	    tk::TextSetCursor %W [Richtext::dLineUpIndex %W insert]
	}
	<Down> {
	    tk::TextSetCursor %W [Richtext::dLineDownIndex %W insert]
	}
	<Shift-Up> {
	    tk::TextKeySelect %W [Richtext::dLineUpIndex %W insert]
	}
	<Shift-Down> {
	    tk::TextKeySelect %W [Richtext::dLineDownIndex %W insert]
	}
	<Home> {
	    tk::TextSetCursor %W [Richtext::dLineStartIndex %W insert]
	}
	<Shift-Home> {
	    tk::TextKeySelect %W [Richtext::dLineStartIndex %W insert]
	}
	<End> {
	    tk::TextSetCursor %W [Richtext::dLineEndIndex %W insert]
	}
	<Shift-End> {
	    tk::TextKeySelect %W [Richtext::dLineEndIndex %W insert]
	}
    } {
	bind Richtext $key $script
    }
    foreach {cursorKey letter} {
	Right f
	Left b
	Home a
	End e
    } {
	bind Richtext <Control-$letter> [subst {
	    if {!\$tk_strictMotif} {
		event generate %W <$cursorKey>
	    }
	}]
    }
    bind Richtext <Key-quotedbl> {
	::Richtext::insertQuote %W insert doubleQuotes
    }
    bind Richtext <Key-quoteright> {
	::Richtext::insertQuote %W insert singleQuotes
    }
    bind Richtext <Key-minus><Key-minus> {
	::Richtext::insertDash %W insert
    }
    bind Richtext <Key-minus><Key-minus><Key-minus> {
	::Richtext::insertDash %W insert
    }
    bind Richtext <Destroy> {
	catch {::itcl::delete object $::Richtext::object(%W)}
	array unset ::Richtext::object %W
    }
    bind Richtext <Shift-space> {
	%W insert insert \u00a0 [%W tag names insert]
    }
}
tmp
rename tmp {}

proc ::Richtext::prevSentenceIndex {widget {pos insert}} {
    # return index of previous grammatical sentence begin.
    set dotIndex\
	[$widget search\
	     -count found\
	     -backwards\
	     -regexp {[\:.?!][\]\})]?( |\t|$)} $pos 1.0]
if {$dotIndex eq ""} {
    # no previous dot, so return start index of doc.
    return 1.0
}
# now find next non-blank index.
set charIndex\
    [$widget search -regexp {[^[:space:]]} "$dotIndex + $found chars" end]
if {$charIndex eq ""} {
    # no non-blank, so return end index of doc.
    return [$widget index end-1chars]
} else {
    set range [$widget tag prevrange blockobject $pos 1.0]
    if {($range ne {}) &&\
	    [$widget compare [lindex $range end] > $charIndex]} {
	return [lindex $range end]
    } else {
	return $charIndex
    }
}
}
# end of ::Richtext::prevSentenceIndex

proc ::Richtext::nextSentenceIndex {widget {pos insert}} {
    # return index of next grammatical sentce begin.
    set dotIndex\
	[$widget search -regexp {[\:.?!][\]\})]?( |\t|$)} $pos end]
if {$dotIndex eq ""} {
    # no dot found, so return end index of doc.
    $widget index end-1chars
} else {
    $widget search -regexp {( |\t|$)} $dotIndex end
}
}
# end of ::Richtext::nextSentenceIndex

proc ::Richtext::dLineStartIndex {widget {pos insert}} {
    # return start index of displayed line
    $widget xview moveto 0
    set dline [$widget dlineinfo $pos]
    set beginX [lindex $dline 0]
    set beginY [lindex $dline 1] 
    # return this value:
    $widget index @$beginX,$beginY
}

proc ::Richtext::dLineEndIndex {widget {pos insert}} {
    # return end index of displayed line
    set dline [$widget dlineinfo $pos]
    set endY [lindex $dline 1]
    set endX [lindex $dline 0]
    incr endX [lindex $dline 2]
    set tooWide [expr {$endX > [winfo width $widget]}]
    if {$tooWide} {
	$widget xview moveto 1
    } else {
	$widget xview moveto 0
    }
    set index [$widget index @[winfo width $widget],$endY]
    $widget see $index
    return $index
}

proc ::Richtext::dLineUpIndex {widget {pos insert}} {
    # return index of next char upwards inside text widget
    $widget see $pos
    if {[$widget dlineinfo $pos] == [$widget dlineinfo 1.0]} {
	return [$widget index $pos]
    }
    set bbox [$widget bbox $pos]
    if {[string equal $bbox ""]} {
	set x 0
    } elseif {[$widget get $pos] == "\n"} {
	set x [expr {[lindex $bbox 0] + [lindex $bbox 3] / 4}]
    } else {
	set x [expr {[lindex $bbox 0] + [lindex $bbox 2] / 2}]
    }
    set lbox [$widget dlineinfo $pos]
    set y [lindex $lbox 1]
    if {$y < 5} {
	$widget yview scroll -1 units
	set lbox [$widget dlineinfo $pos]
	set y [lindex $lbox 1]
    }
    incr y -1
    # return this value:
    $widget index @$x,$y
}

proc ::Richtext::dLineDownIndex {widget {pos insert}} {
    # return index of next char downwards inside text widget
    $widget see $pos
    if {[$widget dlineinfo $pos] == [$widget dlineinfo end-1chars]} {
	return [$widget index $pos]
    }
    set bbox [$widget bbox $pos]
    if {[string equal $bbox ""]} {
	set x 0
    } elseif {[$widget get $pos] == "\n"} {
	set x [expr {[lindex $bbox 0] + [lindex $bbox 3] / 4}]
    } else {
	set x [expr {[lindex $bbox 0] + [lindex $bbox 2] / 2}]
    }
    set lbox [$widget dlineinfo $pos]
    set y [lindex $lbox 1]
    incr y [lindex $lbox 3]
    incr y 5
    if {$y > [winfo height $widget]} {
	# scrollDown
	$widget yview scroll 1 units
	set lbox [$widget dlineinfo $pos]
	set y [lindex $lbox 1]
	set dy [lindex $lbox 3]
	incr y $dy
	incr y 5
    }
    # return this value:
    $widget index @$x,$y
}

# extending tk function:
# extends switch $Priv(selectMode) by clause "sentence"
# which should not matter functions of normal text widgets.

proc ::tk::TextSelectTo {w x y {extend 0}} {
    global tcl_platform
    variable Priv
    
    set cur [TextClosestGap $w $x $y]
    if {[catch {$w index anchor}]} {
	$w mark set anchor $cur
    }
    set anchor [$w index anchor]
    if {[$w compare $cur != $anchor] || (abs($Priv(pressX) - $x) >= 3)} {
	set Priv(mouseMoved) 1
    }
    switch $Priv(selectMode) {
	char {
	    if {[$w compare $cur < anchor]} {
		set first $cur
		set last anchor
	    } else {
		set first anchor
		set last $cur
	    }
	}
	word {
	    if {[$w compare $cur < anchor]} {
		set first [TextPrevPos $w "$cur + 1c" tcl_wordBreakBefore]
		if { !$extend } {
		    set last [TextNextPos $w "anchor" tcl_wordBreakAfter]
		} else {
		    set last anchor
		}
	    } else {
		set last [TextNextPos $w "$cur - 1c" tcl_wordBreakAfter]
		if { !$extend } {
		    set first [TextPrevPos $w anchor tcl_wordBreakBefore]
		} else {
		    set first anchor
		}
	    }
	}
	sentence {
	    # here the extension!
	    if {[$w compare $cur < anchor]} {
		set first [::Richtext::prevSentenceIndex $w $cur]
		set last [::Richtext::nextSentenceIndex $w anchor]
	    } else {
		set first [::Richtext::prevSentenceIndex $w anchor]
		set last [::Richtext::nextSentenceIndex $w $cur]
	    }
	}
	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"]
	    }
	    # modification
	    if {[lsearch [$w tag names $last] blockobject] >= 0} {
		set last [$w index $last-1chars]
	    }
	}
    }
    if {$Priv(mouseMoved) || [string compare $Priv(selectMode) "char"]} {
	$w tag remove sel 0.0 end
	$w mark set insert $cur
	$w tag add sel $first $last
	$w tag remove sel $last end
	update idletasks
    }
}

proc ::tk_textPaste w {
    global tcl_platform
    if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} {
        set oldSeparator [$w cget -autoseparators]
        if { $oldSeparator } {
            $w configure -autoseparators 0
            $w edit separator
        }
#	if {[string compare [tk windowingsystem] "x11"]} {
#	    catch { $w delete sel.first sel.last }
#	}
	#
	catch { $w delete sel.first sel.last }
	#
        $w insert insert $sel
        if { $oldSeparator } {
            $w edit separator
            $w configure -autoseparators 1
        }
    }
}