[Tkabber-dev] r68 - throwaway/ctcomp2

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Thu Oct 4 04:29:36 MSD 2007


Author: kostix
Date: 2007-10-04 04:29:35 +0400 (Thu, 04 Oct 2007)
New Revision: 68

Added:
   throwaway/ctcomp2/TODO
Modified:
   throwaway/ctcomp2/ctcomp.tcl
Log:
ctcomp.tcl: New approach integrated with the original matching engine.
 Mostly works; needs working out some corner cases like no matches
 to the word attempted to be completed (which currently switches the
 active mode on).

TODO: Added TODO list.


Added: throwaway/ctcomp2/TODO
===================================================================
--- throwaway/ctcomp2/TODO	                        (rev 0)
+++ throwaway/ctcomp2/TODO	2007-10-04 00:29:35 UTC (rev 68)
@@ -0,0 +1,7 @@
+$Id$
+
+* Redesign the binding handles to that the "active"
+  mode isn't actually switched on if there's no matches
+  or there's a single match that exactly matches the
+  word being completed.
+


Property changes on: throwaway/ctcomp2/TODO
___________________________________________________________________
Name: svn:keywords
   + Id
Name: svn:eol-style
   + native

Modified: throwaway/ctcomp2/ctcomp.tcl
===================================================================
--- throwaway/ctcomp2/ctcomp.tcl	2007-10-03 17:52:38 UTC (rev 67)
+++ throwaway/ctcomp2/ctcomp.tcl	2007-10-04 00:29:35 UTC (rev 68)
@@ -9,31 +9,55 @@
 
 	set options(pattern) {\m%s\w*\M}
 
-	event add <<ChatTextCompNext>>   <Control-n>
-	event add <<ChatTextCompPrev>>   <Control-p>
-	event add <<ChatTextCompCancel>> <Escape>
+	event add <<ChatTextCompNext>>      <Control-n>
+	event add <<ChatTextCompPrev>>      <Control-p>
+	event add <<ChatTextCompAccept>>    <Return>
+	event add <<ChatTextCompAcceptIns>> <space>
+	event add <<ChatTextCompAcceptIns>> <Tab>
+	event add <<ChatTextCompCancel>>    <Escape>
 
 	bind ChatTextCompInactive <<ChatTextCompNext>> [namespace code {
+		hook::run chat_text_completion_start_hook
 		activate %W
-		offer_next %W
+		match next in %W
+		break
 	}]
 	bind ChatTextCompInactive <<ChatTextCompPrev>> [namespace code {
+		hook::run chat_text_completion_start_hook
 		activate %W
-		offer_prev %W
+		match prev in %W
+		break
 	}]
 
 	bind ChatTextCompActive <<ChatTextCompNext>> [namespace code {
-		offer_next %W
+		match next in %W
+		break
 	}]
 	bind ChatTextCompActive <<ChatTextCompPrev>> [namespace code {
-		offer_prev %W
+		match prev in %W
+		break
 	}]
+	bind ChatTextCompActive <<ChatTextCompAccept>> [namespace code {
+		accept %W
+		deactivate %W
+		hook::run chat_text_completion_end_hook
+		break
+	}]
+	bind ChatTextCompActive <<ChatTextCompAcceptIns>> [namespace code {
+		accept %W
+		deactivate %W
+		hook::run chat_text_completion_end_hook
+	}]
 	bind ChatTextCompActive <<ChatTextCompCancel>> [namespace code {
-		_cancel %W
+		cancel %W
 		deactivate %W
+		hook::run chat_text_completion_end_hook
+		break
 	}]
 	bind ChatTextCompActive <Key> [namespace code {
+		cancel %W
 		deactivate %W
+		hook::run chat_text_completion_end_hook
 	}]
 }
 
@@ -41,64 +65,28 @@
 namespace eval chat {
 	proc input_win chatid { return .iw }
 	proc chat_win  chatid { return .cw }
+	proc get_jid   chatid { return foo at bar.biz }
+	proc add_message {chatid jid type msg x} {
+		.cw config -state normal
+		.cw insert end $msg\n $type
+		.cw config -state disabled
+	}
 }
+namespace eval hook {
+	proc add args {}
+	proc run args {}
+}
 
 #### New code:
 
-proc ctcomp::btags {w op args} {
-	switch -- $op {
-		insert {
-			eval [list BindtagsInsert $w] $args
-		}
-		delete {
-			if {[llength $args] != 1]} {
-				return -code error "Wrong # args: should be\
-					\"btags window delete tag\""
-			}
-			set btags [bindtags $w]
-			set ix [lsearch -exact $btags [lindex $args 0]]
-			if {$ix >= 0} {
-				bindtags $win [lreplace $btags $ix $ix]
-			}
-			bindtags $win
-		}
-		replace {
-		}
-		default {
-			return -code error "Bad operation \"$op\":\
-				must be insert or delete"
-		}
-	}
-}
+proc ctcomp::initialize iw {
+	set btags [bindtags $iw]
+	set ix [lsearch -exact $btags $iw]
+	bindtags $iw [linsert $btags $ix ChatTextCompInactive]
 
-proc ctcomp::BindtagsInsert {win tag args} {
-	set ix -1
-
-	foreach {opt val} $args {
-		switch -- $opt {
-			-before {
-				set ix [lsearch -exact [bindtags $win] $val]
-				incr ix -1
-			}
-			-after {
-				set ix [lsearch -exact [bindtags $win] $val]
-				incr ix 1
-			}
-			-at {
-				set ix $val
-			}
-			default {
-				return -code error "Bad option \"$opt\":\
-					must be one of -before, -after or -at"
-			}
-		}
-	}
+	reset_state $iw
 }
 
-proc ctcomp::initialize iw {
-	bindtags $iw [linsert [bindtags $iw] 0 ChatTextCompInactive]
-}
-
 proc ctcomp::activate iw {
 	set btags [bindtags $iw]
 	set ix [lsearch -exact $btags ChatTextCompInactive]
@@ -109,68 +97,56 @@
 	set btags [bindtags $iw]
 	set ix [lsearch -exact $btags ChatTextCompActive]
 	bindtags $iw [lreplace $btags $ix $ix ChatTextCompInactive]
-}
 
-proc ctcomp::offer_next w {
-	puts [info level 0]
+	reset_state $iw
 }
 
-proc ctcomp::offer_prev w {
-	puts [info level 0]
-}
-
-proc ctcomp::_cancel w {
-	puts [info level 0]
-}
-
-#### Legacy code:
-
 proc ctcomp::prepare {chatid type} {
 	variable options
-	set token [namespace current]::state$chatid
-	variable $token
-	upvar 0 $token state
 
-	array set state [list chatid $chatid]
-
 	set iw [chat::input_win $chatid]
 	set cw [chat::chat_win $chatid]
 
-	set btoken [string map {% %%} $token] ;# % is special in bindings
+	variable $iw
+	upvar 0 $iw state
+	set state(chatid) $chatid
 
-	bind $iw $options(next_match) \
-		[namespace code [list match next for $btoken]]
+	initialize $iw
 
-	bind $iw $options(prev_match) \
-		[namespace code [list match prev for $btoken]]
+	# Kind of destructor for per-chat state:
+	bind $iw <Destroy> +[list [namespace current]::cleanup $iw %W]
 
-	bind $iw $options(cancel_match) \
-		[namespace code [list cancel $btoken]]
+	# TODO the color must be tweakable via option DB:
+	$iw tag configure ctcomp/submatch -background pink
+}
 
-	set prev [bind $iw <Key>]
-	bind $iw <Key> \
-		[namespace code [list keypress_any $btoken]]
-	bind $iw <Key> \
-		+$prev
+proc ctcomp::cleanup {w1 w2} {
+	if {![string equal $w1 $w2]} return
 
-	bind $iw <space> \
-		[namespace code [list keypress_space $btoken]]
+	variable $w1
+	unset $w1
+}
 
-	set prev [bind $iw <Return>]
-	bind $iw <Return> \
-		[namespace code [list keypress_return $btoken]]
-	bind $iw <Return> \
-		+$prev
+proc ctcomp::reset_state iw {
+	variable $iw
+	upvar 0 $iw state
 
-	# Set initial state -- inactive:
-	reset_state $token
+	set state(active) 0
+	set state(matches) [list]
+	set state(last) ""
+	set state(what) ""
+}
 
-	# Kind of destructor for per-chat state:
-	bind $iw <Destroy> \
-		+[namespace code [list array unset $btoken]]
+proc ctcomp::accept iw {
+	$iw tag remove ctcomp/submatch comp_start comp_end
+	$iw mark unset comp_start
+	$iw mark unset comp_end
+}
 
-	# TODO the color must be tweakable via option DB:
-	$iw tag configure ctcomp/submatch -background pink
+proc ctcomp::cancel iw {
+	$iw delete comp_start comp_end
+	$iw mark unset comp_start
+	$iw mark unset comp_end
 }
 
 proc ctcomp::pattern what {
@@ -184,10 +160,15 @@
 	$t get $from insert
 }
 
-proc ctcomp::get_matches {"for" what "in" token} {
-	variable $token
-	upvar 0 $token state
+proc ctcomp::get_matches {"for" what "in" iw} {
+	variable $iw
+	upvar 0 $iw state
+	upvar 0 state(chatid) chatid
 
+	foreach item [hook::run chat_text_completion_complete_hook $chatid $what] {
+		set seen($item) {}
+	}
+
 	set t [chat::chat_win $state(chatid)]
 	set pos 1.0
 
@@ -204,13 +185,13 @@
 	lsort -dictionary [array names seen]
 }
 
-proc ctcomp::wraparound {"in" token} {
-	show info $token "Wrapped around"
+proc ctcomp::wraparound {"in" iw} {
+	show info $iw "Wrapped around"
 }
 
-proc ctcomp::advance {"to" where "in" token} {
-	variable $token
-	upvar 0 $token state
+proc ctcomp::advance {"to" where "in" iw} {
+	variable $iw
+	upvar 0 $iw state
 	upvar 0 state(last) last
 
 	switch -- $where {
@@ -218,46 +199,46 @@
 			incr last
 			if {$last > [llength $state(matches)]} {
 				set last 0
-				wraparound in $token
+				wraparound in $iw
 			}
 		}
 		prev {
 			incr last -1
 			if {$last < 0} {
 				set last [expr {[llength $state(matches)] - 1}]
-				wraparound in $token
+				wraparound in $iw
 			}
 		}
 		default {
-			error "bad match: $match; should be \"next\" or \"prev\""
+			return -code error "Bad match \"$match\":\
+				should be next or prev"
 		}
 	}
 }
 
-proc ctcomp::match {where "for" token} {
-	variable $token
-	upvar 0 $token state
+proc ctcomp::match {dir "in" iw} {
+	variable $iw
+	upvar 0 $iw state
 	upvar 0 state(chatid)  chatid
 	upvar 0 state(what)    what
 	upvar 0 state(matches) matches
 	upvar 0 state(last)    last
 
-	set iw [chat::input_win $chatid]
-	set cw [chat::chat_win  $chatid]
+	set cw [chat::chat_win $chatid]
 
 	if {!$state(active)} {
 		set what [yield from $iw]
 		if {[string length $what] == 0} return
 
-		set state(matches) [get_matches for $what in $token]
+		set state(matches) [get_matches for $what in $iw]
 		if {[llength $matches] == 0} {
-			show info $token "No match for $what"
+			show info $iw "No match for $what"
 			return
 		}
 
 		set last 0
 	} else {
-		advance to $where in $token
+		advance to $dir in $iw
 	}
 
 	set match [lindex $matches $last]
@@ -274,60 +255,73 @@
 	$iw mark gravity comp_end right
 
 	set state(active) 1
-
-	return -code break ;# prevent further keypress processing
 }
 
-proc ctcomp::cancel {token} {
+# $type should be either "info" or "error"
+proc ctcomp::show {type token msg} {
 	variable $token
-	upvar 0 $token state
+	upvar 0 ${token}(chatid) chatid
 
-	if {!$state(active)} return
+	set jid [chat::get_jid $chatid]
+	set cw [chat::chat_win $chatid]
 
-	set iw [chat::input_win $state(chatid)]
-
-	$iw delete comp_start comp_end
-	$iw mark unset comp_start
-	$iw mark unset comp_end
-
-	reset_state $token
+	chat::add_message $chatid $jid $type $msg {}
 }
 
-proc ctcomp::reset_state {token} {
-	variable $token
-	upvar 0 $token state
+#### Handling of bindtags (not currently used):
 
-	set state(active) 0
-	set state(matches) {}
-	set state(last) ""
-	set state(what) ""
+proc ctcomp::btags {w op args} {
+	switch -- $op {
+		insert {
+			eval [list BindtagsInsert $w] $args
+		}
+		delete {
+			if {[llength $args] != 1]} {
+				return -code error "Wrong # args: should be\
+					\"btags window delete tag\""
+			}
+			set btags [bindtags $w]
+			set ix [lsearch -exact $btags [lindex $args 0]]
+			if {$ix >= 0} {
+				bindtags $win [lreplace $btags $ix $ix]
+			}
+			bindtags $win
+		}
+		replace {
+		}
+		default {
+			return -code error "Bad operation \"$op\":\
+				must be insert or delete"
+		}
+	}
 }
 
-proc ctcomp::commit token {
-	variable $token
-	upvar 0 $token state
-	
-	#if {!$state(active)} return
-	if {!$state(active)} { return -code continue }
+proc ctcomp::BindtagsInsert {win tag args} {
+	set ix -1
 
-	set iw [chat::input_win $state(chatid)]
-
-	$iw tag remove ctcomp/submatch comp_start comp_end
-	$iw mark unset comp_start
-	$iw mark unset comp_end
-
-	reset_state $token
+	foreach {opt val} $args {
+		switch -- $opt {
+			-before {
+				set ix [lsearch -exact [bindtags $win] $val]
+				incr ix -1
+			}
+			-after {
+				set ix [lsearch -exact [bindtags $win] $val]
+				incr ix 1
+			}
+			-at {
+				set ix $val
+			}
+			default {
+				return -code error "Bad option \"$opt\":\
+					must be one of -before, -after or -at"
+			}
+		}
+	}
 }
 
-proc ctcomp::keypress_any token {
-	variable $token
-	upvar 0 $token state
-	
-	if {!$state(active)} return
+#### Unneeded reference code:
 
-	cancel $token
-}
-
 proc ctcomp::keypress_space token {
 	variable options
 	variable $token
@@ -353,62 +347,11 @@
 	return -code break
 }
 
-# $type should be either "info" or "error"
-proc ctcomp::show {type token msg} {
-	variable $token
-	upvar 0 ${token}(chatid) chatid
-
-	set jid [chat::get_jid $chatid]
-	set cw [chat::chat_win $chatid]
-
-	chat::add_message $chatid $jid $type $msg {}
-}
-
-proc ctcomp::on_event_spec_changed {where what op} {
-	return
-
-	variable $where
-	upvar 0 ${where}($what) this
-	upvar 0 ${where}(prev_$what) prev
-	if {![info exists prev]} { set prev "" }
-
-	if {$this == $prev} return ;# no change
-
-	if {$this == ""} { # empty value => remove binding
-		event delete $event $prev
-		set prev ""
-		return
-	}
-
-	if {[is_valid_event_spec $this]} {
-		event delete $event $prev
-		event add $event $this
-		set prev $this
-	} else {
-		set this $prev
-	}
-}
-
-proc ctcomp::is_valid_event_spec spec {
-	set f [frame .testframemustnotexist]
-
-	set ok [catch {bind $f $spec bogus}]
-
-	if {!$ok} {
-		global errorInfo
-		set errorInfo [::msgcat::mc "...testing event valididy..."]
-		bgerror [::msgcat::mc "Bad event: $options(binding)"]
-	}
-
-	destroy $f
-	return $ok
-}
-
 #### Action:
 
-wm geometry . 417x180
+wm geometry . 417x280
 
-text .cw -state disabled
+text .cw
 text .iw -height 3
 
 grid .cw -column 0 -row 0 -sticky news
@@ -419,11 +362,30 @@
 grid columnconfigure . 0 -weight 1
 
 if {[string equal $tcl_platform(platform) windows]} {
-console eval { wm protocol . WM_DELETE_WINDOW exit }
-console show
+	console eval { wm protocol . WM_DELETE_WINDOW exit }
+	console show
 }
 
-ctcomp::initialize .iw
+foreach line [split [string trim {
+	abbot
+	abbatisse
+	abba
+	foo
+	foobar
+	foobargrill
+	grill
+	grille pitch
+}] \n] {
+	.cw insert end [string trim $line]\n
+}
 
+.cw tag config info -foreground blue
+.cw tag config error -foreground red
+#.cw config -state disabled
+
+bind .iw <Escape> { destroy . }
+
+ctcomp::prepare {1 foo at bar.biz} chat
+
 focus -force .iw
 



More information about the Tkabber-dev mailing list