########################################################################
# mmucl_tk.tcl - library for using Mmucl in Tk
#
# Copyright (C) 1997-1999 Mark Patton
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#########################################################################

source [file join $config(lib_dir) lib balloon.tcl]
source [file join $config(lib_dir) lib tkconf.tcl]

namespace eval mmucl {}

proc mmucl::gui_init {} {
    variable Mmucl
    global config tcl_platform

    array set Mmucl {
	hist_cur        ""
    }
    
    lappend Mmucl(dump) key

    if {[lsearch -exact [package names] Tk] == -1} {
	set version [info tclversion]
	set lib [file join [file dirname [info library]] \
		libtk${version}[info sharedlibextension]]
	
	if {[file exists $lib]} {
	    load $lib Tk
	} else {
	    regsub -- {\.} $version "" version
	    set lib [file join [file dirname [info library]] \
		    libtk${version}[info sharedlibextension]]

	    if {[file exists $lib]} {
		load $lib Tk
	    } else {
		error "Cannot find Tk shared lib."
	    }
	}
    }

    foreach img [glob [file join $config(lib_dir) images *.*]] {
	image create photo img_[file rootname [file tail $img]] -file $img
    }
    
    if {[string equal $tcl_platform(platform) unix]} {
	toplevel .icon
	label .icon.l -image img_mmucl -bd 0
	pack .icon.l
	wm iconwindow . .icon
    }

    tkconf::init [file join $config(lib_dir) .tkconf]
    tkconf::init [file join $config(rc_dir) .tkconf]
    
    wm title . "Mmucl Tk"
    wm protocol . WM_DELETE_WINDOW mmucl::MCexit

    bind Entry <Control-u> {%W delete 0 insert}
    bind Text <Control-u> {%W delete "insert linestart" insert}

    rename gui_init ""
    return
}

proc mmucl::MCbell {} {
    bell
    return
}

proc mmucl::user_entry {w} {
    variable Mmucl
    
    text $w -height 1 -wrap char

    set Mmucl(entry) $w
    set Mmucl(entry_fg) [$w cget -foreground]

    bind $w <Key-Return> {mmucl::entry_parse %W; break}
    bind $w <Key-Up> {mmucl::hist_scroll_up %W; break}
    bind $w <Key-Down> {mmucl::hist_scroll_down %W; break}
    bind $w <KeyPress> {mmucl::check_expand %W}
    
    bind $w <Tab> break

    bindtags $w [concat mmucl [bindtags $w]]

    return $w 
}

proc mmucl::check_expand {w} {
    set offset [string length [$w get 1.0 "end -1 chars"]]

    set width [$w cget -width]
    set height [$w cget -height]

    if {[expr {(($offset - 1) / $width) + 1}] < $height} {
        $w configure -height [incr height -1]   
    } elseif {[expr {($offset / $width) + 1}] > $height} {
	$w configure -height [incr height 1]
    }

    return
}

proc mmucl::toolbar {w} {
    variable Mmucl

    frame $w -class Toolbar
    
    button $w.con -command mmucl::tk_connect -image img_connect 
    balloon_add $w.con "Connect to mud"
    button $w.load -image img_load -command {mmucl::tk_source}
    balloon_add $w.load "Load a file"
    button $w.send -image img_send -command {mmucl::tk_textin}
    balloon_add $w.send "Send a file"
    button $w.save -image img_save -command {mmucl::tk_dump}
    balloon_add $w.save "Save state"
    button $w.char -image img_char -command {mmucl::tk_edit char}
    balloon_add $w.char "Edit characters"
    button $w.alias -image img_alias -command {mmucl::tk_edit alias}
    balloon_add $w.alias "Edit aliases"
    button $w.action -image img_action -command {mmucl::tk_edit action}
    balloon_add $w.action "Edit actions"
    button $w.sub -image img_sub -command {mmucl::tk_edit sub}
    balloon_add $w.sub "Edit subs"
    button $w.key -image img_bind -command {mmucl::tk_edit key}
    balloon_add $w.key "Edit keys"

    pack $w.con $w.load $w.send $w.save $w.char $w.alias $w.action $w.sub \
	$w.key -side left 

    return $w
}

proc mmucl::option_menu {w} {
    menu $w

    $w add checkbutton -label Reconnect -variable mmucl::Mmucl(cfg,reconnect)
    $w add checkbutton -label "Keep line" -variable mmucl::Mmucl(cfg,keep_line)
    $w add checkbutton -label Actions -variable mmucl::Mmucl(cfg,actions)
    $w add checkbutton -label "Action By Line" \
	    -variable mmucl::Mmucl(cfg,action_by_line)
    $w add checkbutton -label Subs -variable mmucl::Mmucl(cfg,subs)
    $w add checkbutton -label "Strip ANSI" \
	    -variable mmucl::Mmucl(cfg,strip_ansi)
    $w add checkbutton -label "Local echo" -variable mmucl::Mmucl(cfg,echo)
    $w add cascade -label "Echo color" -menu $w.colors
    
    menu $w.colors
    foreach color {red green yellow blue magenta cyan grey} {
	$w.colors add radiobutton -label $color -value $color \
	    -variable mmucl::Mmucl(cfg,echo_color)
    }

    return $w
}

proc mmucl::entry_parse {w} {
    variable Mmucl

    meta_parse [$w get 1.0 "end -1 chars"]
    
    if {$Mmucl(cfg,keep_line)} {
	$w tag add sel 1.0 1.end
    } else {
	$w delete 1.0 end
    }
    
    return
}

proc mmucl::hist_scroll_up {w} {
    variable Mmucl

    if {$Mmucl(hist_loc)} {
	if {$Mmucl(hist_loc) == [llength $Mmucl(history)]} {
	    set Mmucl(hist_cur) [$w get 1.0 "end -1 chars"]
	}	
	$w delete 1.0 end
	$w insert 1.0 [lindex $Mmucl(history) [incr Mmucl(hist_loc) -1]]
    }

    return
}

proc mmucl::hist_scroll_down {w} {
    variable Mmucl
    
    if {[incr Mmucl(hist_loc)] > [llength $Mmucl(history)]} {
	incr Mmucl(hist_loc) -1
    } else {
	$w delete 1.0 end
	if {$Mmucl(hist_loc) == [llength $Mmucl(history)]} {
	    $w insert 1.0 $Mmucl(hist_cur)
	} else {
	    $w insert 1.0 [lindex $Mmucl(history) $Mmucl(hist_loc)]
	}
    }

    return
}

proc mmucl::tk_script {script descript} {
    global errorInfo

    if {[catch $script error]} {
	set act [tk_dialog .err "Error: $descript" $error error 0 Ok\
		"Print stack trace"]
	
	if {$act == 1} {
	    MCecho "Stack trace:"
	    MCecho $errorInfo
	}

	return 0
    }

    return 1
}

# ugly
proc mmucl::tk_connect {} {
    variable Mmucl
    
    if {[winfo exists .con]} {
	raise .con
	return
    }
    
    toplevel .con
    wm title .con Connect

    frame .con.f -relief groove -bd 2
    grid [label .con.f.hostl -text Host:]
    grid [entry .con.f.host] -row 0 -column 1
    grid [label .con.f.portl -text Port:] 
    grid [entry .con.f.port] -row 1 -column 1
    
    .con.f.host insert end $Mmucl(host)
    .con.f.port insert end $Mmucl(port)

    if {![info exists Mmucl(tmpchar)]} {
	set Mmucl(tmpchar) ""
    }

    # if characters defined, make a character selection area
    if {[llength [set chars [lsort [MCchar names]]]]} {
	grid [label .con.f.lchar -text Char:]

        set m [eval tk_optionMenu .con.f.char mmucl::Mmucl(tmpchar) $chars]
	$m add separator
	$m add command -label None -command {set mmucl::Mmucl(tmpchar) ""}
	set Mmucl(tmpchar) ""

	grid .con.f.char -row 2 -column 1
	
	# hack to update host and port on char selection.
	bind $m <ButtonRelease> {
	    .con.f.host delete 0 end
	    .con.f.port delete 0 end
	    
	    after 10 {
		if {![string equal $mmucl::Mmucl(tmpchar) ""]} {
		    .con.f.host insert 0 \
			[lindex [mmucl::MCchar set $mmucl::Mmucl(tmpchar)] 0]
		    .con.f.port insert 0 \
			[lindex [mmucl::MCchar set $mmucl::Mmucl(tmpchar)] 1]
		}
	    }
	}
    }
    
    frame .con.b
    pack [button .con.b.ok -text Connect \
	    -command mmucl::tk_connect_do] -side left
    pack [button .con.b.quit -text Cancel -command {destroy .con}] -side left
  
    pack .con.f .con.b
    wm geometry .con +[winfo pointerx .]+[winfo pointery .]
    wm resizable .con 0 0

    return
}

proc mmucl::tk_connect_do {} {
    variable Mmucl

    if {![string equal $Mmucl(tmpchar) ""]} {
	set res [tk_script [list MCchar load $Mmucl(tmpchar)] "Loading char"]
    } else {
	set res [tk_script [list MCconnect [.con.f.host get]\
		[.con.f.port get]] "Connecting to host"]
    }
    
    if {$res} {
	destroy .con
    }

    return
}

proc mmucl::tk_edit {proc} {
    set list 0
    switch -exact -- $proc {
	action {
	    set labels {Pattern: Script:}
	    set title "Edit Actions"
	} alias {
	    set labels {Name: Script:}
	    set title "Edit Aliases"
	} sub {
	    set labels {Pattern: Subspec:}
	    set title "Edit Subs"
	} key {
	    set labels {Event: Script:}
	    set title "Edit Keys"
	} char {
	    set labels {Name: Host: Port: Login:}
	    set title "Edit Characters"
	    set list 1
	}
    }

    set w .$proc

    if {[winfo exists $w]} {
	raise $w
	return
    }
  
    toplevel $w
    wm title $w $title

    form $w.form $labels MC$proc $list
    pack $w.form -side top -pady 3
 
    frame $w.b
    pack [button $w.b.help -text Help -command [list mmucl::MChelp $proc]]\
	    [button $w.b.exit -text Close -command [list destroy $w]] \
	    -side left
    pack $w.b -side bottom
    
    wm geometry $w +[winfo pointerx .]+[winfo pointery .]
    wm resizable $w 0 0

    return
}

proc mmucl::MCkey {args} {
    set syntax {
	 set      {{+ key} {? script}}
	 names    {{? pattern *}}
	 print    {{? pattern *}}
	 delete   {{- exact} {+ pattern}}
     }
     
     foreach name [bind mmucl] {
	 set keys($name) [lindex [bind mmucl $name] 2]
     }
     
     switch [check key $syntax $args 1] {
	 set {
	     if {[info exists arg(script)]} {
		 bind mmucl $arg(key) \
			 [list mmucl::key_exec $arg(key) $arg(script)]
	     } elseif {![info exist keys($arg(key))]} {
		 error "no such key"
	     } else {
		 return $keys($arg(key))
	     }
	 } names {
	     return [array names keys $arg(pattern)]
	 } delete {
	     if {[info exists arg(-exact)]} {
		 bind mmucl $arg(pattern) {}
	     } else {
		 foreach key [array names keys $arg(pattern)] {
		     bind mmucl $key {}
		 }
	     }
	 } print {
	     foreach key [array names keys $arg(pattern)] {
		 MCecho "$key bound to {$keys($key)}"
	     }
	 }
     }
    
    return
}

# evaluate a script bound to a key

proc mmucl::key_exec {key script} {
    set code [catch {mmucl eval $script} error]

    if {$code} {
	if {$code == [catch break]} {
	    return -code break
	}

	report error "key $key: $error"
    }
    
    return
}

proc mmucl::MChelp {{subject ""}} {
    global config ntki_embed

    if {![info exists ntki_embed]} {
	set ntki_embed 1
	uplevel #0 [list source [file join $config(lib_dir) lib ntkinfo.tcl]]
	ntki::init
    }
    
    ntki::win (mmucl)$subject
    
    return
}

# Modify the command line.

proc mmucl::MCcline {args} {
    variable Mmucl

    set w $Mmucl(entry)
    set syntax {
	delete {{? first 0} {? last end}}
	get {{? first 0} {? last end}} 
	insert {{+ first} {+ str}}
	history {}
	hide {{? bool 1}}
    }

    set opt [check cline $syntax $args 1]

    foreach index {arg(first) arg(last)} {
	if {![info exists $index]} {
	    continue
	}

	if {[string equal [set $index] insert]} {
	    continue;
	} elseif {[string equal [set $index] end]} {
	    set $index 1.end
	} elseif {[string is int -strict [set $index]]} {
	    set $index 1.[set $index]
	} else {
	    error "bad index"
	}
    }

    switch -exact $opt {
        delete {
	    $w delete $arg(first) $arg(last)
	} get {
	    return [$w get $arg(first) $arg(last)]
	} insert {
	    $w insert $arg(first) $arg(str)
	} history {
	    return $Mmucl(history)
	} hide {
	    if {$arg(bool)} {
		$w configure -foreground [$w cget -background]
	    } else {
		$w configure -foreground $Mmucl(entry_fg)
	    }
	}
    }

    return
}

proc mmucl::tk_source {} {
    set file [tk_getOpenFile -title "Load a file"]
    
    if {![string equal $file ""]} {
	tk_script [list mmucl invokehidden source $file] "Loading script"
    }
    
    return
}

proc mmucl::tk_textin {} {
    set file [tk_getOpenFile -title "Send a file"]
    
    if {![string equal $file ""]} {
	tk_script [list MCtextin $file] "Sending file"
    }
    
    return
}

proc mmucl::tk_dump {} {
    set file [tk_getSaveFile -title "Save state to file"]
   
    if {![string equal $file ""]} {
	tk_script [list MCdump -all -- $file] "Saving state"
    }

    return
}

proc mmucl::tk_exit {} {
    set s [tk_messageBox -type yesno -message "Really quit?" -icon question]
    
    if {[string equal $s yes]} {
	MCexit
    }
    
    return
}

proc mmucl::form {w labels proc list} {
    frame $w -class Form
    frame $w.sel
    pack [listbox $w.sel.list -yscroll [list $w.sel.yscroll set]] -side left
    pack [scrollbar $w.sel.yscroll -command [list $w.sel.list yview]] \
	      -side left -fill y

    frame $w.edit
    frame $w.edit.buts
    pack [button $w.edit.buts.add -text Add \
	      -command [list mmucl::form_add $w $proc $list]] -side left
    pack [button $w.edit.buts.delete -text Delete \
	      -command [list mmucl::form_delete $w $proc]] -side left
    frame $w.edit.f
    
    set i 0
    foreach label $labels {
	grid [label $w.edit.f.l$i -text $label] -sticky w -column 0
	grid [entry $w.edit.f.e$i] -row $i -sticky ew -column 1
	incr i
    }
    
    pack $w.edit.f $w.edit.buts -side top
    pack $w.sel $w.edit -side left
   
    bind $w.edit.f.e[incr i -1] <Key-Return> \
	    [list mmucl::form_add $w $proc $list]
    bind $w.sel.list <ButtonRelease-1> \
	[list mmucl::form_show_selection $w $proc $list]

    form_listbox_update $w $proc

    return $w
}

proc mmucl::form_show_selection {w proc list} {
    set i [$w.sel.list curselection]

    if {![string equal $i ""]} {
	set i [$w.sel.list get $i]

	if {$list} {
	    form_set_entries $w [concat [list $i] [$proc set $i]]
	} else {
	    form_set_entries $w [list $i [$proc set $i]]
	}
    }

    return
}

proc mmucl::form_add {w proc list} {
    set e [form_get_entries $w]
    
    if {$list} {
	set script [list $proc set [lindex $e 0] [lrange $e 1 end]] 
    } else {
	set script  [concat [list $proc] set $e]
    }

    # assumes MCname procs...
    tk_script $script "Adding [string range $proc 2 end]"
    form_listbox_update $w $proc

    return
}

proc mmucl::form_delete {w proc} {
    set i [$w.sel.list curselection]
    
    if {![string equal $i ""]} {
	set i [$w.sel.list get $i]
	$proc delete -exact -- $i
	form_listbox_update $w $proc
    }
    
    return
}

proc mmucl::form_listbox_update {w proc} {
    form_set_entries $w {}

    $w.sel.list delete 0 end
    foreach i [lsort [$proc names]] {
        $w.sel.list insert end $i
    }

    return
}

proc mmucl::form_get_entries {w} {
    set num_entries [expr {[llength [winfo children $w.edit.f]]/2}]

    for {set i 0} {$i < $num_entries} {incr i} {
	lappend list [$w.edit.f.e$i get]
    }
    return $list
}

proc mmucl::form_set_entries {w list} {
    set num_entries [expr {[llength [winfo children $w.edit.f]] / 2}]

    for {set i 0} {$i < $num_entries} {incr i} {
 	$w.edit.f.e$i delete 0 end
 	$w.edit.f.e$i insert end [lindex $list $i]
    }

    return
}