# -*-tcl-*-

# This is an example mmucl.rc file providing many useful procedures.
# If this file is in your HOME/.mmucl directory, it is loaded on startup.
# Note that some of these examples may be specific to the mud I usually
# play on.
########################################################################

# Send str to the mud n times
proc rep {str n} {
    for {set i 0} {$i < $n} {incr i} {
	write $str
    }
}

# Make an alias targ that sets its arguments to the global
# variable "targ". That variable can be used in other scripts.

set targ ""
alias set targ {
    global targ

    if {![string equal $1 ""]} {
	set targ $0
    }
    
    echo [color target: {bold magenta}] $targ
}

# Create an alias that calls a command on the mud with
# the alias arguments if given or else the global
# variable targ.

proc mud_attack {cmd} {
    alias set $cmd \
    "global targ
    
    if {!\[string equal \$1 \"\"\]} {
	set targ \$0
    }
    
    write \"$cmd \$targ\""
}

# Find the last number in the argument string.
# Write everthing up to that number, except buffering
# white-space, to the mud that number times. 

alias set r {
    set num 1
    regexp {^\s*(.*?)\s*(\d+)\s*$} $0 x 0 num
    rep $0 $num
}

# Print out stack trace of last error

key set <Print> {
    echo [color "Stack Trace:" bold]
    echo $errorInfo
}

# Shortcut to execute another prog.

alias set % {
    echo [eval exec $0]
}

# Make an alias "!" that parse the history event
# matching it's first arg or prints out the history
# if given no args.

alias set ! {
    if {![string equal $1 ""]} {
	set ev [hist_event [string trim $0]]
	if {[string equal -length 1 $ev !]} {
	    error "recursive event"
	}
	parse $ev
    } else {
	set i -1
	foreach e [cline history] {
	    echo [incr i]: $e
	}
    }
}

# Return a command in the history that matches history event e.
# A history event can be:
#     a prefix of the command it matches
#     n, command number n (0 being the oldest)
#     -n, the current command - n (-1 would be the last command typed)

proc hist_event {e} {
    set hist [cline history]
    set rhist [lreverse $hist]

    set i [lsearch -glob $rhist [exact -glob -- $e]*]
   
    if {$i != -1} {
	return [lindex $rhist $i]
    } elseif {[regexp {^\d+$} $e]} {
	return [lindex $hist $e]
    }  elseif {[regexp {^-\d+$} $e]} {
	incr e [llength $hist]
	return [lindex $hist $e]
    } else {
	error "no such event"
    }
}

# Return list with elements in reverse order
proc lreverse {list} {
    set i [llength $list]
    set rev [list]

    while {$i} {
	lappend rev [lindex $list [incr i -1]]
    }
    
    return $rev
}

# This procedure creates either aliases for movement or sets
# up the keypad to do movement. The prepend argument allows
# a mud command like sneak to be called with direction arguments
# if desired. Move defaults to operating on aliases

proc move {args} {

    set syntax {
	on {{- kp alias} {? prepend ""}}
	off {{- kp alias}}
    }
    
    set dirs {
	nw KP_Home n KP_Up ne  KP_Prior w KP_Left e KP_Right sw KP_End
	s  KP_Down se  KP_Next u KP_Add d KP_Subtract in KP_Multiply
	out KP_Divide
    }

    switch -exact -- [check -opts move $syntax $args] {
	on {
	    foreach {dir key}  $dirs {
		set move [string trim "$arg(prepend) $dir"]

		if {$arg(kp)} {
		    key set <Key-$key> "write {$move}; break"
		} else {
		    alias set $dir [list write $move] 
		}
	    }
	} off {
	    foreach {dir key} $dirs {
		if {$arg(kp)} {
		    key delete -exact -- <Key-$key>
		} else {
		    alias delete -exact -- $dir
		}
	    }
	}
    }

    return
}

# Start or stop idling.
# If idle, send args given to the mud every 60 seconds
# and beep if someone talks to us.

alias set idle {
    set pattern {^%w tells you:|^%w asks you:}

    if {$1} {
	action set $pattern bell
	walk on [list $0] 60
    } else {
	action delete -exact -- $pattern
	walk off
    }
}

# Speedwalk like tintin.
# Example:
# "speedwalk 20e3su" would move you twenty east, three south, and up. 

proc speedwalk {path} {

    # These are the direction shortcuts
    array set dir {
	n n
	i ne
	e e
	l se
	s s
	k sw
	w w
	j nw
	o open
	c close
	u up
	d down
	z in
	x out
    }

    foreach c [split $path ""] {
	if {[string is integer -strict $c]} {
	    append n $c
	} else {
	    if {![info exists dir($c)]} {
		error "bad dir: $c"
	    }

	    if {![info exists n]} {
		set n 1
	    }

	    rep $dir($c) $n
	    unset n
	}
    }

    return
}

# Make an alias shortcut to speedwalk
alias set # {speedwalk $1}

# Play a sound located in the "sound" directory
# of ~/.mmucl. It should do some checks to determine
# what player to execute based on the file extension
# and platform.

proc sound {file} {
    global env

    exec play [file join $env(HOME) .mmucl sound $file] &

    return
}

# Turn a string like "one" into a digit.
proc todigit {str} {
    set numbers {zero one two three four five six seven eight nine}
    return [lsearch -exact $numbers [string tolower $str]]
}

# Walk sends each element of the list path, wrapping around when
# it reaches the end, to the mud with delay seconds between each
# write.

proc walk {args} {
    global _walk

    set syntax {
	on   {{+ path} {? delay 4}}
	delay   {{? delay}}
	suspend {{? bool}}
	off     {}
    }
    
    switch -exact -- [check -opts walk $syntax $args]  {   
	on {
	    if {[info exists _walk(id)]} {
		error "walk already running"
	    } elseif {[catch {concat $arg(path)}]} {
		error "path must be a list"
	    }
	    
	    set _walk(path) $arg(path)
	    set _walk(suspend) 0
	    set _walk(delay) [expr {$arg(delay) * 1000}]
	    
	    _walk_loop 0
	} delay  {
	    if {[info exists arg(delay)]} {
		set _walk(delay) [expr {$arg(delay) * 1000}]
	    } else {
		return $_walk(delay)
	    }
	} suspend {
	    if {[info exists arg(bool)]} {
		set _walk(suspend) [string is true $arg(bool)] 
	    } else {
		return $_walk(suspend)
	    }
	} off {
	    catch {
		after cancel $_walk(id)
		unset _walk
	    }
	}
    }

    return
}

proc _walk_loop {pos} {
    global _walk

    if {!$_walk(suspend)} {
	write [lindex $_walk(path) $pos]
	set pos [expr {[incr pos] % [llength $_walk(path)]}]
    }

    set _walk(id) [after $_walk(delay) _walk_loop $pos]
    return
}

# This proc sets up actions to autometically kill defined monsters
# if you walk into a room with them in it. It handles multiple monsters
# of the same kind and will send a clean up command after combat.

# When combat starts it sets the global variable targ to the monster
# being attacked, suspends a walk if there is one, and sends
# "attack name" to the mud.
# When combat ends the cleanup command is sent and the walk,
# if there is one, resumes.

# mlist is a list of monster names to attack.
# It has to include all names from "name is here",
# "three names are here", and "you killed name".

# Example: auto_kill {man "militia man" "militia men"} hunt "bury all"

proc ak {args} {
    global _ak

    set syntax {
	on {{+ mlist} {+ attack} {+ cleanup}}
	off {}
    }
    
    set one_here_pat {^%s is here}
    set many_here_pat {^%w %s are here}
    set killed_pat {^You killed %s.}

    switch -exact -- [check -opts ak $syntax $args] {
	on {
	    set _ak(mlist) [string tolower $arg(mlist)]
	    set _ak(num) 0
	    set _ak(attack) $arg(attack)
	    set _ak(cleanup) $arg(cleanup)

	    action set $one_here_pat {_ak_event $1 1}
	    action set $many_here_pat {_ak_event $2 [todigit $1]}
	    action set $killed_pat {_ak_event $1 0}
	} off {
	    catch {unset _ak}
	    action delete -exact -- $one_here_pat
	    action delete -exact -- $many_here_pat
	    action delete -exact -- $killed_pat
	}
    }

    return
}

proc _ak_event {m num} {
    global _ak targ
    
    if {[lsearch -exact $_ak(mlist) [string tolower $m]] != -1} {
	set targ $m
        if {$num} {
            set _ak(num) $num
            write "$_ak(attack) $m"
	    walk suspend 1
        } else {
            if {[incr _ak(num) -1] < 1} {
                write $_ak(cleanup)
                walk suspend 0
            } else {
                write "$_ak(attack) $m"
	    }
        }
    }

    return
}

# simulate rolling (n * die) + const

proc roll {n die {const 0}} {
    set roll 0

    while {[incr n -1] > -1} {
	incr roll [expr {int($die * rand()) + 1}]
    }

    return [incr roll $const]
}

# Log mud output to a file.

proc log {args} {
    global _log_fd
    
    set syntax {
	open  {{+ file}}
	close {}
    }
    
    switch -exact -- [check -opts log $syntax $args] {
	open {
	    if {[info exist _log_fd]} {
		error "already logging"
	    } else {
		set _log_fd [open $arg(file) w+]
		puts $_log_fd [clock format [clock seconds]]\n
		rxp_action set .+ "puts -nonewline $_log_fd \$0"
		key set <Key-Return> "puts $_log_fd \[cline get\]"
	    }
	} close {
	    key delete <Key-Return>
	    rxp_action delete -exact .+
	    close $_log_fd
	    unset _log_fd
	}
    }
    
    return
}

# Monitor sets up an action that keeps the elements of
# the global array status updated from the mud. The pattern
# of the action is mud specific.
# It also sets up a trace on hp that calls hp_check.

proc monitor {args} {
    global status

    set syntax {
	on {}
	off {}
    }
    
    switch -exact -- [check -opts monitor $syntax $args] {
	on {

	    action set {^Hp: %d*Gp: %d*Xp: %d} {
		global status
    
		set status(hp) $1
		set status(gp) $2
		set status(xp) $3
	    }

	    #set status(hp) 0
	    trace variable status(hp) w hp_check
	} off {
	    action delete -exact -- {^Hp: %d Gp: %d Xp: %d}
	    trace vdelete status(hp) w hp_check
	}
    }

    return
}  

# Called when the variable hp is changed to determine if
# any action should be taken. Could be overwritten
# in a char init file to do something else.

proc hp_check {args} {
    global status

    # Bail out if hp is low.
    if {$status(hp) < 500} {
	write quit
    }
}


# channel - lets you define your own channels to
# chat with people on a mud.
# When you create a channel a command and alias
# of the channel's name is created.

proc channel {args} {
    global _channel
    
    set syntax {
        create {{+ name} {? members {}}}
        destroy {{+ name}}
        names {{? glob *}}
        dump  {{+ name} {+ file }}
    }
    
    switch -exact [check -opts channel $syntax $args] {
        create {
            set _channel($arg(name)) $arg(members)
            interp alias {} $arg(name) {} _channel_cmd $arg(name)
            alias set $arg(name) "{$arg(name)} msg \$0"
        } destroy {
	    interp alias {} $arg(name) ""
	    unset _channel($arg(name))
	    alias delete -exact -- $arg(name)
        } names {
            return [array names _channel $arg(glob)]
        } dump {
            set fd [open $arg(file) "w+"]
            puts $fd [list channel create $arg(name) \
		    [list $_channel($arg(name))]]
            flush $fd
            close $fd
        }
    }

    return
}

# The command created by channel
proc _channel_cmd {name args} {
    global _channel

    set syntax {
        add {{+ name}}
        remove {{+ name}}
        names {}
        msg {{+ msg}}
    }
    
    switch -exact [check -opts $name $syntax $args] {
        add {
            lappend _channel($name) $arg(name)
        } remove {
            set i [lsearch -exact $_channel($name) $arg(name)]
            if {$i != -1} {
                set _channel($name) [lreplace $_channel($name) $i $i]
            }
        } names {
            return $_channel($name)
        } msg {
            foreach member $_channel($name) {
                write "tell $member \[$name\]: $arg(msg)"
            }
        }
    }
    
    return    
}

# Load in the Tk toolkit if not already loaded.

proc loadTk {} {
    if {[lsearch -exact [package names] Tk] == -1} {
	load {} Tk  
	wm withdraw .
    }
}

# Here's an example using the Tk toolkit.
# tk_monitor toggles a window that keeps track
# of your hp, gp, and xp using the monitor procedure
# defined above.

proc tk_monitor {} {
    loadTk

    if {[winfo exists .monitor]} {
	monitor off
	destroy .monitor
	return
    }

    monitor on
    toplevel .monitor
    wm title .monitor Monitor

    pack [label .monitor.lhp -text Hp:] \
	    [label .monitor.hp -textvariable status(hp)] \
	    [label .monitor.lgp -text Gp:] \
	    [label .monitor.gp -textvariable status(gp)] \
	    [label .monitor.lxp -text Xp:] \
	    [label .monitor.xp -textvariable status(xp)] -side left 
}

# Return a pattern determined by the switch given
# (glob is default) that exactly matches str.

proc exact {args} {
    check mask {{- format glob regexp} {+ str}} $args

    if {$arg(format)} {
	set charmap {
	    ^ ^^
	    $ $$
	    % %%
	    * **
	    | ||
	}
    } elseif {$arg(regexp)} {
	set charmap {
	    * \\*
	    | \\|
	    \\  \\\\
            [  \\[
	    ]  \\]
	    (  \\(
	    )  \\)
	    \{ \\\}
	    \} \\\{
	    +  \\+
            .  \\.
	    ?  \\?
        }
    } else {
	set charmap {
	    * \\*
	    \\  \\\\
            [  \\[
	    ]  \\]
	    ?  \\?
        }
    }

    return [string map $charmap $arg(str)]
}

# do tab completion on procs and aliases
key set <Tab> complete

proc complete {} {
    set s [cline get 0 insert]
    set c [string index $s 0]

    if {[string equal $c [config set verbatim_char]]} {
	return
    }
    
    set sc [config set script_char]

    if {[string equal $c $sc]} {
	set prefix $sc
	set names [info commands [exact -glob -- [string range $s 1 end]]*]
    } else {
	set prefix ""
	set names [alias names [exact -glob -- $s]*]
    }

    if {[llength $names] == 1} {
	cline delete
	cline insert 0 [append prefix [lindex $names 0] " "]
    } else {
	if {[llength $names]} {
	    echo "Completions:"
	    echo $names
	}
	bell
    }

    return
}

# Send email to someone. :) Remember you have to point it at
# an smtp server if you're not running one. Note that this may
# block for a few minutes.

proc email {args} {
    set syntax {{+ to} {+ from} {+ subject} {+ msg} \
	    {? host localhost} {? port 25}}

    check email $syntax $args

    set sock [socket $arg(host) $arg(port)]

    gets $sock res
    if {![string match *220* $res]} {
	close $sock
	error $res
    }

    _email_send_and_check $sock "MAIL From: $arg(from)" 250
    _email_send_and_check $sock "RCPT To: $arg(to)"  250
    _email_send_and_check $sock DATA 354
    puts $sock "Subject: $arg(subject)"
    puts $sock $arg(msg)
    _email_send_and_check $sock . 250
    _email_send_and_check $sock QUIT 221
    
    close $sock
    return
}

proc _email_send_and_check {sock str code} {
    puts $sock $str
    flush $sock
    gets $sock res

    if {![string match *$code* $res]} {
	close $sock
	error $res
    }

    return
}
