#################################################################################
# TCL Interactive Spell Checker Version 1.01 
# Developed for use in EXMH by John McLaughlin (johnmcl@sr.hp.com) 6/7/97
# 
# This new spell checking code for EXMH was developed out of
# frustration with the current spell checking EXMH code
# mostly I could not get it to work the way I wanted it to.
# Because I couldn't get the spell checker to work as well
# as I would like, I found myself spending inordinate amounts
# of time when writing e-mail, constantly fretting over
# the spelling.  This little piece of code is the result
# and seems to work pretty well in my environment.  I have
# tested this under both linux (redhat 4.0) HPUX 9.05
# 
# This software operates in one of two different
# modes, it can either spell check as you type, marking words
# in a variety of ways (underline, bold, italic, etc) that are
# not spelled correctly.  Also it can put a button in the sedit
# window to allow in place spell checking. (The button option
# requires changes to your .exmh-defaults file)
#
# This code depends on the excellent 'ispell' program and most
# of the variables & procedure's get their name from it.
# This code was developed under ispell v3.1.20
#
#######################################################################
# MODIFIED for use with Postilion, 22/2/98 Nic Bernstein
############## Performance ##########################
#
# This spell checker seems to operate without any 
# obvious performance drag when typing in sedit
# with enough ram, most modern workstations should 
# be able to use this without any obvious performance hit
# I find running it under Linux with a 40mb P90
# quite comfortable
# as a few benchmarks, this software can spell check
# a 2700 word letter in 12 seconds on a P90 running
# linux (redhat 4.0) with 40mb of ram.  other 
# timing results indicate a user can expect 
# a 1.3ms to 3.0ms additional delay for
# correctly spelled words, and up to 30ms
# for words not spelled correctly.  As always
# ram helps, ram starved machines will 
# not fair as well
######################################################
#
# Enjoy, if you find it useful or have any comments
# please let me know (johnmcl@sr.hp.com) also if you 
# make any improvements please send them to me
#
# John McLaughlin, HP Santa Rosa, January 1997 (johnmcl@sr.hp.com)
######################################################

#########################################################
# ispell_init is called to start the entire process off
#########################################################
proc Ispell_Init { } { 
    global ispellVars

    if {! [ info exists ispellVars(currentLanguage) ] } {
	set ispellVars(currentLanguage) ""
    }

    if { $ispellVars(currentLanguage) == $ispellVars(language) } return ; 
    set ispellVars(currentLanguage) $ispellVars(language)  ; # mark current language
    set ispellVars(last_word) "dummy" 
    set ispellVars(choices) "" 

    # how to view, see the text.n man page for other ideas
    # options include -background <color> -foreground <color> 
    # -font <font> etc..
    #    set ispellVars(viewStyle) "-underline t"
    if { [ info exists ispellVars(spell_buffer) ] } {
	catch {close $ispellVars(spell_buffer)}
    }

    if {!$ispellVars(on)} {
	set ispellVars(currentLanguage) "disabled"
    }
    if {$ispellVars(currentLanguage) == "disabled"} {
	catch {unset ispellVars(spell_buffer) }
	return ;
    }

    if [catch {open "|$ispellVars(command)" r+} ispellVars(spell_buffer)] {
	set ispellVars(on) 0	;# triggers trace
	return
    }

    # Poke the process because:
    # 4.0 doesn't respond with a full line, so gets hangs
    # 2.0 doesn't output a version number.
    # We only like 3.*
    puts $ispellVars(spell_buffer) "?"
    flush $ispellVars(spell_buffer)
    gets $ispellVars(spell_buffer) line
    set version {"unknown"}
    if {([string compare $line *] == 0) ||
	([regexp {[Vv]ersion ([0-9])\.} $line x version] &&
	    $version != 3)} {
	# Oh No!  Why are you not running version 3.X???
	# specifically version 4.0 doesn't work!!!
	RatLog 4 "Ignoring ispell version $version (3.* required)"
	catch { close $ispellVars(spell_buffer) } reason
	set ispellVars(on) 0
	return
    }
    #
    # Since this is the right version, we need to read the (blank) reply to
    # the "?" we sent...
    #
    gets $ispellVars(spell_buffer) line
    IspellWriteSpellBuffer "!" ; # enter terse mode
}

proc IspellOnOff {args} {
    global ispellVars
    catch {unset ispellVars(currentLanguage)}
    Ispell_Init
}



# a safe procedure to write to the ispell buffer
# this procedure dumps the variable 'word' to the spell buffer
# if the buffer has died, it will restart it
proc IspellWriteSpellBuffer { word } {
    global ispellVars
    
    if {$ispellVars(currentLanguage) == "disabled"} { return * } ;
    puts $ispellVars(spell_buffer) $word
    if { [ catch { flush $ispellVars(spell_buffer) } ] } {
	RatLog 2 "Ispell process terminated!!!!!, temp disabling"
	set ispellVars(language) disabled
	Ispell_Init
	return "*" ; # return if we had to restart
    }
}

# This procedure kills the ispell buffer
# 
proc Ispell_Kill {} { 
    global ispellVars
    if {[info exists ispellVars(spell_buffer)]} {
	flush $ispellVars(spell_buffer)
	close $ispellVars(spell_buffer)
    }
    if {[info exists ispellVars(on)]} {
	set ispellVars(on) 0
    }
}

##########################################
# this is the proc that does the 
# actual spell checking, it will return a 
# '*' if everything is cool, otherwise
# it returns a list of possible miss-spelled
# words.  See ispell(1) for more details
##########################################
proc IspellWords {line} { 
    global ispellVars
    regsub -all { +} $line { } line		;# compress out extra spaces
    set count [llength [split $line { }]]	;# Count space separated words
    set result ""

    if { $ispellVars(currentLanguage) == "disabled" } { return "*" } ;

    # clear out the fileevent
    if { [ catch {fileevent $ispellVars(spell_buffer) readable {} } ] } {
	Ispell_Init
	return "*"
    }
    # so the puts stuff doesn't freak out
    # CRITCAL prepend a '^' to keep the buffer from freaking
    puts $ispellVars(spell_buffer) "^$line"
    # we have to put the ^ in front of the line so ispell works correctly
    # see ispell(1) for more details
    if { [ catch { flush $ispellVars(spell_buffer) } ] } {
	puts "Ispell process terminated!!!!!, restarting"
	Ispell_Init
	return "*" ; # return if we had to restart
    }

    # loop through list of words, usually there is just 1
    for { set i 0 } { $i <= $count } {  incr i } { 
	gets $ispellVars(spell_buffer) var
	if {$var == {} } then {
	    lappend result "*";
	    break;
	}
	lappend result $var
    }
    # invoke a fileevent to help flush out the data so wer are always in sync
    fileevent $ispellVars(spell_buffer) readable {
	global ispellVars
	gets $ispellVars(spell_buffer) dummyy 
    }
    return $result
}

# this proc spell checks the word under the current cursor
# marking it with a 'MissSpelled' tag if it is in fact incorrect
# text is the text window
# This version runs about 300us slower than the previous
# version using tk's built in 'wordstart' and 'wordend'
# (1.3ms vs 1.7ms)
proc IspellTextWindow { text } { 
    set start [ $text get "insert linestart" insert ]
    set end   [ $text get insert "insert lineend" ] 
    set e1 ""
    set s1 ""

    regexp "\[^\t \]*" $end e1
    set e1 [ string trim $e1 ] 
    regexp "\[^\t \]+$" $start s1
    
    set startIndex "insert - [string length $s1] chars"
    set stopIndex "insert + [string length $e1] chars "
    set word "[ string trim $s1$e1 "\"\{\}\[\] \t" ] "
    IspellMarkWord $text $startIndex $stopIndex $word
}

# this Proc is to spell check words that end with 'inserts'
# i.e. after 'space', 'tab' etc.... This version runs at exactly the same speed as 
# the tk built in version (1.3ms) so I feel pretty comfortable that this shouldn't 
# effect speed too much all test times were gotten via 'time'  and thus may have
# some errors (especially  with regexps, I think the system compiles them).  In
# this version I can't use tk's built in 'word' functions because they don't allow
# for european characters....
proc IspellTextWindowInsert { text } { 
    set start [ $text get "insert linestart" insert ]
    set s1 ""

    # now let's pick off the last word
    regexp "\[^\t ]+$" $start s1
    set startIndex "insert - [string length $s1] chars"
    set stopIndex "insert" 
    set word " [ string trim $s1 "\"\{\}\[\]  \t" ] "

    IspellMarkWord $text $startIndex $stopIndex $word 
}

####################################################
# proc to mark words in the text window, with the given 
# indexes, the 'word' is the word in question
####################################################
proc IspellMarkWord {text startIndex stopIndex word} {
    global ispellVars ;
    set result [ IspellWords $word ];
    # * means fine, + means a root?, - means compount controlled by -C
    # option of ispell
    if { ! [regexp {^[*+-]} $result ] } {
	$text tag add MissSpelled $startIndex $stopIndex
	$text tag raise MissSpelled
    } else {
	$text tag remove MissSpelled $startIndex "$stopIndex +1c"
    }
    set ispellVars(last_word) $word ; # store word so we don't re-check next time
    return $result
}


##############################################################
# Proedure to call to mark words after the dictionary has been
# modified, called from within the 'add' menus.....
# 
##############################################################
proc IspellReCheckBuffer { window startIndex stopIndex word } { 
    global ispellVars;
    
    # first let's make sure it's a real word....
    if { $word == "" } return ;

    IspellMarkWord $window $startIndex $stopIndex $word; 

    # check word requested
    if { [ info exists ispellVars(ReCheckAfterAdd) ] }  {
	if { $ispellVars(ReCheckAfterAdd) } { 
	    IspellReCheckWords $window ; 
	    # re-check buffer if requested..
	}   
    }
}

##########################################################
# This proc will take the word currently under the mouse pointer
# spell check it, and pop up a menu with suggestions or allowing
# additions to the ispell-dictionary
# 'text' is the text window, x,y are the co-ordinates relative to the
# window, X,Y are the co-ordinates relative to the root window
##########################################################
proc IspellPostMenuChoices { text x y   X Y } { 

    global ispellVars t

    set adjustment {} 
    set oldInsert [ $text index insert ] 
    $text mark set insert "@$x,$y"

    set start [ $text get "insert linestart" insert ]
    set end   [ $text get insert "insert lineend" ] 
    set e1 ""
    set s1 ""
    
    regexp "\[^\t \]*" $end e1
    set e1 [ string trim $e1 ] 
    regexp "\[^\t \]+$" $start s1

    set startIndex "insert - [string length $s1] chars"
    set stopIndex "insert + [string length $e1] chars "
    set word $s1$e1

    set word [ string trim $word  "\]\[\.\,\<\>\/\?\!\@\#\%\*0123456789\&\@\(\)\:\;\$ \{\}\"\\ \'\~\`\_\-\+\t\n\r\b\a\f\v\n "]   
    set word [ string trim $word ]

    # if there is no word to mention, don't even post a menu...
    if { $word == "" } return ; 
    set result [ IspellMarkWord $text $startIndex $stopIndex $word ]
    $text mark set insert $oldInsert ; # get it back where it belongs
    # create a meanu
    set menu "$text.m"
    catch { 
	destroy $menu
    }
    menu $menu -tearoff f

    # remember the menu name so we can unpost it later.
    set ispellVars(PopupMenu) $menu
    
    # first let's label the menu with the current language
    $menu add command -label $ispellVars(language) -state disabled

    # now if spell checking is disabled, let's mark menus as such
    set disFlag normal
    if { $ispellVars(currentLanguage) == "disabled" } {
	set disFlag "disabled" 
    }
    $menu add command -label "$t(isp-add) '$word' $t(isp-dict)" -command  \
	    "IspellWriteSpellBuffer \"*$word\";\
	    IspellWriteSpellBuffer \#;\
	    IspellReCheckBuffer $text \"$startIndex\" \"$stopIndex\" $word;" -state $disFlag
    # add word to dictionary, save dictionary, recheck word
    $menu add command -label "$t(isp-accept) '$word' $t(isp-for)" -command \
	    "IspellWriteSpellBuffer \"@$word\";\
	    IspellReCheckBuffer $text \"$startIndex\"  \"$stopIndex\" $word;" -state $disFlag
    # add word for this session, recheck word
    $menu add separator
    foreach i   [ split [ lreplace [ lindex $result 0 ] 0 3 ] "," ]   {
	set choice [ string trim $i ", " ]
	$menu add command -label $choice -command "IspellReplaceWordInText $text $x $y \"$choice\" " 
    }
    menu $menu.sub -tearoff f
    $menu.sub add radiobutton -label "disabled" \
	    -command "set ispellVars(language) disabled ;
    set ispellVars(command) \"\";
    Ispell_Init" -variable ispellVars(language) -value "disabled"
    $menu.sub add radiobutton -label $t(default)" \
	-command "set ispellVars(language) default ;
	    set ispellVars(command) \"$ispellVars(defaultCommand)\";
	    Ispell_Init" \
	-variable ispellVars(language) -value "default"
    set count [ llength $ispellVars(otherCommands) ] 
    for { set i 0 } { $i < $count } { incr i 2 } {
	set lab  [ lindex $ispellVars(otherCommands) $i ]
	set command  [ lindex $ispellVars(otherCommands) [ expr $i +1 ]  ]
	$menu.sub add radiobutton -label "$lab " \
	    -command  " set ispellVars(language)  \"$lab\" ; 
		    set ispellVars(command) \"$command\"; 
		    Ispell_Init"  \
	    -variable ispellVars(language) -value "$lab"                       
    }
    
    $menu add cascade -label "$t(alternate)..." -menu $menu.sub
    tk_popup $menu $X $Y 
}

#########################################################
# This proc will replace whatever word is listed at x,y
# with 'word'  It goes to some lengths to keep surrouning
# punctuation.
#########################################################
proc IspellReplaceWordInText { text x y word } { 

    set oldInsert [ $text index insert ] 
    $text mark set insert "@$x,$y"
    set start [ $text get "insert linestart" insert ]
    set end   [ $text get insert "insert lineend" ] 
    set e1 ""
    set s1 ""
    
    regexp "\[^\t \]*" $end e1
    set e1 [ string trim $e1 ] 
    regexp "\[^\t \]+$" $start s1

    # If we are being asked to replace a word, first remove the tag
    # so that whatever highlighting is there will be gone.
    $text tag remove MissSpelled "insert - [string length $s1] chars" "insert + [string length $e1] chars "

    # Now let's clean up that string a bit..... remove punctuation & stuff
    set e1 [ string trim [ string trim $e1 ] "\]\[\.\,\<\>\/\?\!\@\#\%\*0123456789\&\@\(\)\:\;\$ \{\}\"\\ \'\~\`\_\-\+\t\n\r\b\a\f\v\n "]   
    set s1 [ string trim [ string trim $s1 ] "\]\[\.\,\<\>\/\?\!\@\#\%\*0123456789\&\@\(\)\:\;\$ \{\}\"\\ \'\~\`\_\-\+\t\n\r\b\a\f\v\n "]   

    # now let's remove the old word & insert the new word.
    set startIndex "insert - [string length $s1] chars"
    set stopIndex "insert + [string length $e1] chars "
    set startInsert [ $text index $startIndex ] 

    $text delete $startIndex $stopIndex 
    $text insert $startInsert $word
    $text mark set insert $oldInsert ; # get it back where it belongs
}

##########################################################
# Postilion Specific procedure to bind the window in question 
##########################################################
proc IspellTagMissSpelled { window } {
    global ispellVars
    # only configure the window for ispell support if it is
    # actually needed, and if the appropriate variables exist
    # 
    # bind the window.....
    # use default style of underline
    set style "-underline t"

    if { [ catch {    
	switch -exact -- $ispellVars(viewStyle) \
	    underline  { set style "-underline t"} \
	    italic { set style "-font *italic*" } \
	    bold { set style "-font *bold*"} \
	    other { set style "$ispellVars(viewStyle-Other)" } \
	    bgcolor { set style "-background $ispellVars(viewStyle-Color)" } \
	    fgcolor { set style "-foreground $ispellVars(viewStyle-Color)" } 
	    eval  $window tag configure MissSpelled $style 
    } result ] } { 	
	tk_dialog .window "Bad Style" \
	    "Invalid I-Spell style: '$result' changing to underline" \
	    {} 0 ok
	eval $window tag configure MissSpelled -underline t
    }
    # Only bind the window if 'ispell' is turned on...
    if { [ info exists ispellVars(on) ] } {
	if { $ispellVars(on) == 1 } { 
	    set ispellVars($window,effect) 1
	    $window tag bind MissSpelled <Enter> "$window config -cursor question_arrow"
	    $window tag bind MissSpelled <Leave> "$window config -cursor xterm"
	}
    }
    set ispellVars(command) $ispellVars(defaultCommand)
    set ispellVars(language) "default" 
    # Only init the spell checker if it had already not been previously init'd
    if { ! [ info exists ispellVars(spell_buffer) ] } { 
	Ispell_Init ; # init if the spell buffer is undefine
    }
} 

# this procedure re-checks the entire buffer in the
# window specified by 'window'
proc Ispell_CheckEntireWindow { text } { 
    global ispellVars

    set oldInsert [ $text index insert ] 
    set count 0
    # First things first, because this function COULD be called without
    # using any of the other ispell stuff, first ensure that the ispell 
    # process is running...
    # Only init the spell checker if it had already not been previously init'd
    if { ! [ info exists ispellVars(spell_buffer) ] } { 
	Ispell_Init ; # init if the spell buffer is undefine
    }
    # Pop up a little window to allow spell checking to be turned off......
    #
    set ispellVars(label) "Stop Spell Checking"
    catch { destroy .ispellStopWindow }
    set top [ toplevel .ispellStopWindow ] 
    button $top.b  -textvariable ispellVars(label) -command { 
	set ispellVars(label) "" 
    }
    label $top.l1 -bitmap warning
    label $top.l2 -bitmap warning
    
    pack $top.l1 -side left
    pack $top.b -side left
    pack $top.l2 -side left
    
    set endOfDoc [ $text index end ] ; # get the last index mark
    set current 1.0

    # here is the actual code to spell check the document
    while { [ expr $current < $endOfDoc ] }  {
	if { $ispellVars(label) == "" } { break}
	$text mark set insert "$current"
	set start [ $text get "insert linestart" insert ]
	set end   [ $text get insert "insert lineend" ] 
	set e1 ""
	set s1 ""
	
	regexp "\[^\t \]*" $end e1
	regexp "\[^\t \]+$" $start s1
	
	set startIndex "insert - [string length $s1] chars"
	set stopIndex "insert + [string length $e1] chars "
	set word "[ string trim $s1$e1 "\"\{\}\[\]" ] "
	set current [ $text index "$stopIndex + 2 chars" ]

	if {[string length $word] == 1} continue; # speed up process for small words....

	incr count
	update
	if { $count > 120 } {
	    $text see $current
	    set count 0
	}
	IspellMarkWord $text $startIndex $stopIndex $word 
    }
    destroy $top
    # now let's redisplay the screen at the insert point....
    $text mark set insert "$oldInsert"
    $text see insert
}


########################################################
# procedure to re-check bound words to reconfirm they
# are still missspelled
# note that if quite a few words are missSpelled this could
# take quite a while.... Also note that this should probably
# only be called AFTER the dictionary has changed/updated
########################################################
proc IspellReCheckWords {window} { 
    global ispellVars
    
    set ranges [ $window tag ranges MissSpelled ] 
    set ispellVars(label) "Stop Spell Checking"
    set wcount 0
    if { [ expr [ llength $ranges ] > 100 ] } { 
	# Only pop up a window if
	# 100 or so need to be re-checked.
	catch {
	    destroy .ispellStop
	}
	toplevel .ispellStop
	button .ispellStop.b  -textvariable ispellVars(label) -command { 
	    set ispellVars(label) "" 
	}
	label .ispellStop.l1 -bitmap warning
	label .ispellStop.l2 -bitmap warning
	pack .ispellStop.l1 -side left
	pack .ispellStop.b -side left
	pack .ispellStop.l2 -side left
    }

    # loop through all the current words marked as misspelled
    #
    for { set i 0 } { $i < [ expr [llength $ranges] / 2 ] } { incr i } {
	set startIndex [ lindex $ranges [ expr $i*2 ] ] 
	set stopIndex  [ lindex $ranges [ expr $i*2+1 ] ]
	if { [ $window compare "$startIndex + 1 chars" == "$stopIndex" ] } {
	    $window tag remove MissSpelled $startIndex "$stopIndex +1c"
	}
	set word  " [ string trim [ $window get $startIndex $stopIndex ] \
		 " \t\"\{\}\[\]"] " ; # "
	if { $ispellVars(label) == "" } { break }
	incr wcount
	if { $wcount > 20 } {
	    $window see $startIndex
	    set wcount 0
	}
	update
	set result [ IspellMarkWord $window $startIndex $stopIndex $word ]
    }

    # destroy the toplevel window
    catch {
	destroy .ispellStop
    }
    # put the window back under the insert cursor
    $window see insert
}
