#!/usr/bin/tclsh8.5
# incremental search
# script in Tcl programming language
# suggest/dynamic menu  on wiki.tcl.tk title words
foreach p [list Tk http dns] {
	if {[catch {package require $p} err]} {
		set path [file dirname [info nameofexecutable]]
		set path [file join $path teacup.exe]
		if {[file exists $path]} {
			puts "try <$path update>"
		}
		error "missing package $p"
	}
}

proc ipadr {x} {
	dns::configure -nameserver 208.67.222.222
	set tok [dns::resolve taipu.de.]
	dns::wait $tok
	if {![string equal ok [dns::status $tok]]} {
		puts [dns::status $tok]
		error dns-error
	}
	set res [dns::address $tok]
	dns::cleanup $tok
	return $res
}
wm title . "resolve taipu.de."
wm dei .
set ::u [format "%s://%s/f" http [ipadr taipu.de.]]
#puts ::u=$::u

set ::post 0
wm title . "wiki.tcl.tk/# launcher"
set ::hierarchical 1
checkbutton .lh -text "hierarchical toplevel widgets" -variable ::hierarchical
pack .lh
radiobutton .rg -text get -variable ::post -value 0
label .lget -textvariable ::getlist_m
radiobutton .rp -text post -variable ::post -value 1

set ::getlist [list]
trace variable ::getlist w {show_info ::getlist_m}
proc show_info {dest args} {
	#puts dest=$dest
	#puts args=<$args>
	foreach {varname dummy access} $args break
	set len [llength [set $varname]]
	set sum 0
	foreach x [set [set varname]] {
		incr sum $x
	}
	set mean [expr {$sum/$len}]
	set $dest [format "%03d msec, mean %03d, times %d" $x $mean $len]
}

set ::postlist [list]
trace variable ::postlist w {show_info ::postlist_m}
label .lpost -textvariable ::postlist_m
pack .rg .lget .rp .lpost -side top
set browser firefox
entry .e -textvariable browser
pack .e
label .h -text "Type any discriminating letter"
pack .h
button .b -text "starting point" -command {next . 0 ""  [tx]}
pack .b
label .ltyped -textvariable ::taip -justify left
pack .ltyped 
proc previous {current parent} {
	catch {focus -force $parent; wm deiconify $parent}
	wm withdraw $current
}
proc kp {w a d k nn {toggle 1}} {
#	puts kp<[llength $d]><[llength $k]>
	set i [lsearch -exact $d $a]
	if {$i>-1} {
		append ::taip $a
	#puts "found $a @ index $i"
		set prefix [string range [wm title $w] 0 end-1]$a[lindex $k $i]
	#puts prefix<$prefix>
		if {[winfo exists $w$i]} {
			wm deiconify $w$i
		} else {
			set dest [lindex $nn $i]
#puts dest=$dest
			if {[string equal $dest {}]} {
				next $w $i $prefix [tx $prefix]
			} else {
	append ::taip \u2022$dest\n
				set url http:
				append url //wiki.tcl.tk/$dest
				if {[catch { exec [.e get] $url & } err]} {
					puts err=$err
				}
			}
		}
	} else {
		if {$toggle} {
			set A [string tolower $a]
			if {[string equal $a $A]} {
				set A [string toupper $a]
				if {![string equal $A $a]} {
					kp $w $A $d $k $nn 0
				} else {
					append ::taip ^$a
				}
			}
		} else {
			append ::taip ^$a
		}
		
	}
} 
proc enter {w} {
	if {[regexp -nocase toplevel [winfo class $w]]} {
		#$w configure -bg yellow
		#raise $w
		focus -force $w
	}
	return -code break
}
proc next {parent index  prefix data} {
	set pos [string first \n\n $data]
set ::x $data
	array set m {}
	if {$pos>-1} {
		incr pos -1
		set suffix [string range $data 0 $pos]
#puts suffix<$suffix>
		incr pos 3
#puts <[string range $data $pos end]>
		set v ""
#set ::t [string range $data $pos end]
		foreach kv [split [string range $data $pos end] \n] {
			foreach {k v} [split $kv \t] break
#puts k<$k>v<$v>
			set m($k) $v
			set v ""
		}
	} else {
		set suffix $data
	}
	if {$::hierarchical} {
		#nested toplevels
		set top $parent.-$index
		regsub {^\.\.} $top . top
	} else {
		set top $parent-$index
	}
	if {[winfo exists $top]} {
		wm deiconify $top
		return
	} else {
		set top [toplevel $top -highlightthickness 2 -highlightcolor blue -highlightbackground pink]
		wm title $top $prefix\u2026
		if {![string equal {} $prefix]} {
			wm resizable $top 0 0
		}
		#wm overrideredirect $top 1
	}
	#bind $top <Enter> {enter %W}
	#bind $top <Leave> [list $top configure -bg black]
	bind $top <Key-Left> [list previous $top $parent]
	bind $top <Key-BackSpace> [list previous $top $parent]
	set i 0
	set fc [frame $top.f -bg white]
	set canv $fc.c
	set sv [scrollbar $fc.s -orient vertical -command [list $canv yview]]
	# to have scrollable frame, put frame inside srollable canvas
	set ft [frame $top.g -bg white]
	set left [frame $ft.l -bg white -padx 4]
	set mid [frame $ft.m -padx 4]
	set right [frame $ft.r -padx 4]
	set dd [list]
	set keys [list]
#puts suffix<$suffix>
#puts mid=$mid
	foreach n [split $suffix \n] {
#puts n=$n
		if {[regexp {\t} $n]} {
#puts n=$n
			foreach {ss ff} [split $n \t] break
			if {[string length $ss]==0} {
				set ss \t
			}
		} else {
			set ss $n
			set ff ""
		}
	#puts ss<<$ss>>ff<$ff>
		if {[string length $ff]} {
			set info $m($ff)
		} else {
			set info ""
		}
		pack [label $mid.$i -text $info -justify left] -anchor w
		lappend nn $ff
		pack [label $right.$i -text $ff -justify right] -anchor e
		if {[regexp {\$$} $ss]} {
			set z [string range $ss 1 end-1]
			set n $z
			append n \u2026
			lappend keys $z
		} else {
			set n [string range $ss 1 end]
			lappend keys $n
		}
		set fr [frame $left.$i -bg white -padx 1]
		# the unique discriminating char
		set d [string range $ss 0 0]
		lappend dd [regsub % $d %%] ;# quote special character of bind
		label $fr.p -text $prefix -justify left -bg white
		label $fr.d -text $d -justify center -bg #ffeeee -width [expr {[string equal $d \t]} ? 3 : 1]
		label $fr.s -text $n -justify left -bg white
		pack $fr.p $fr.d $fr.s -side left
		#pack $fr -side top -anchor w
		pack $fr -anchor nw
		bind $fr <Enter> [list $fr configure -bd 0px -bg red -cursor none]
		bind $fr <Leave> [list $fr configure -bd 0px -bg white -cursor ""]
		incr i
	}
	update idletasks ;# ? unless used on 2-liners the last line is not rendered
	pack $left $mid $right -side left
	pack $right -side left -padx 1

	set h [winfo reqheight $left]
	incr h -4 ;# highlightthickness
	update idletasks ;# width of $ft needed
	set ftw [winfo reqwidth $ft]
#puts >>>$ftw<<<$ft
	foreach {maxw maxh}  [wm maxsize .] break
	incr maxh -20
	set scrollable 1
	if {[expr {$h>$maxh}]} {
		#$top configure -height $maxh
	} else {
		#$canv configure -height $h -width $ftw
		set scrollable 0
	}
	if {$scrollable} {
		set canv [canvas $canv -bg black -highlightthickness 0]
		$canv configure -height $maxh -width $ftw
		$canv create window 1 0 -window $ft -anchor nw
		set w [winfo reqwidth $left]
		$canv configure -scrollregion [list 0 0 $w $h]
		$canv configure -yscrollcommand [list $sv set]
		pack $canv -side left -padx 2 -pady 2
		pack $sv -side left -expand yes -fill y
		pack $fc -padx 2 -pady 2 -expand yes -fill both
	} else {
		pack $ft -padx 1 -pady 1
	}
#puts scrollable=$scrollable
	if {$i} {
		bind $top <Key> [list kp $top %A $dd $keys $nn]
		set ::yd $dd
		set ::yk $keys
	}
set ::dd $dd
set ::kk $keys
set ::nn $nn
	#array unset m
	focus $top
}
proc tx {{x {}}} {
	#if {[scan $x %c j]==1} {puts <$j>}
#puts x=<$x>
	# append minus to preserve trailing blank
	set q $x-
	set q [::http::mapReply $q]
	set url $::u
#puts url=$url
	if {$::post} {
		set fault [catch {set t [time {set n [http::geturl $url -query x=$q]}]} err]
	} else {
		append url ?x=$q
		set fault [catch {set t [time {set n [http::geturl $url]}]} err]
	}
#puts q=<$q>
#puts url=<$url>
	set t [expr {[lindex $t 0]/1000}]
	if {$::post} {lappend ::postlist $t} else {lappend ::getlist $t}
	if {$fault} {
		#puts err=$err
		tk_messageBox -icon error -message $err -title "request failed"
		http::cleanup $n
		return
	}
       	set data [::http::data $n]
       	http::cleanup $n
	#puts [encoding convertfrom utf-8 $data]
	return [encoding convertfrom utf-8 $data]
}

next . 0 ""  [tx]