#!/usr/bin/tclsh
# get emacs in tcl mode

# Put this file in the directory pointed to by $Mmucl(rc_dir)
# to have it automatically loaded on startup. For windows users
# rc_dir is the main mmucl directory

# It's hard to know what a good font is for the text widget
# .mudwin in winmmucl. If the default looks terrible, play around
# with the fonts to find somthing that looks good.

# With large fonts in windows point size 8 seems about right. Point
# size ten fonts look reasonably good with small fonts.

if {[winfo exists .mudwin]} {
    if {$tcl_platform(platform)=="windows"} {
	.mudwin configure -font {fixed 8 normal}
	.mudwin tag configure 0 -font {fixed 8 normal}
	# should be bold
	.mudwin tag configure 1 -font {fixed 8 bold}
    }
}

# Monitor pops up a window that keeps track
# of your hp, gp, and xp. This procedure probably only works
# on RoD, but it provides a template for doing something
# similar on other muds. Calling monitor once will turn it on
# and calling monitor again will turn it off.

# Try adding different things to it like an exit button
# or have expand it to monitor more than just hp and gp.
# Since hp, gp, and xp are global variables you can use
# them in other aliases, actions, etc.

proc monitor {} {
    global hp gp xp

    if {![winfo exists .monitor]} {
	action {Hp: ([0-9]+)(.+)Gp: ([0-9]+)(.+) Xp: ([0-9]+)} \
	    {
		set hp @1
		set gp @3
		set xp @5
		if {$hp<1000} {
		    .monitor.hp configure -foreground red
		} else {
		    .monitor.hp configure -foreground forestgreen}}
	toplevel .monitor
	wm title .monitor "Monitor"
	pack [label .monitor.lhp -text "Hp:"] \
	    [label .monitor.hp -textvariable hp] \
	    [label .monitor.lgp -text "Gp:"] \
	    [label .monitor.gp -textvariable gp] \
	    [label .monitor.lxp -text "Xp:"] \
	    [label .monitor.xp -textvariable xp] -side left 
	    
    } else {
	unaction {Hp: ([0-9]+)(.+)Gp: ([0-9]+)(.+) Xp: ([0-9]+)}
	catch {unset hp gp xp}
	destroy .monitor
    }
}

# This proc sets up actions to autometically kill defined monsters
# if you walk into a room with them. It handles multiple monsters
# of the same kind and will send a clean up command after combat.\
# This is set up for LP style muds but could be easily modified.

# Example: auto_kill {"militia man" "militia men" man} hunt q
# (q is an alias I have on the mud that buries corpses.)

proc auto_kill {mlist attack cleanup} {

    action "(\[a-z ]+) is here." \
        "if {\[lsearch [list $mlist] \[string tolower \"@1\"]]!=-1} { 
	   set mon_num 1
           writemud \"$attack @1\"
           set Wait 1
         }"
    
    action "(\[a-z]+) (\[a-z ]+) are here." \
	"if {\[lsearch [list $mlist] \[string tolower \"@2\"]]!=-1} {
             set mon_num \[todigit @1]
             writemud \"$attack @2\"
             set Wait 1
         }"
    
    action "You killed (\[a-z ]+)." \
	"if {\[lsearch [list $mlist] \[string tolower \"@1\"]]!=-1} {
           incr mon_num -1
           if {\$mon_num<1} {
             writemud \"$cleanup\"
             set Wait 0
           } else {writemud \"$attack @1\"}
         }"
}

# This is used by an action in auto_kill.
proc todigit {str} {
    set numbers {zero one two three four five six seven eight nine}
    return [lsearch -exact $numbers [string tolower $str]]
}

# hilite searches for a pattern and adds tags to it. Use the ansi color
# tags or define your own.  Only works in winmmucl of course. 
# Use an action to call it.
#action {[a-z]+ tells you: .+} {hilite {@0} {33 44 1}}

# Needs a little more work.
proc hilite {string tags} {
   
    # Get a line that fits in the text widget to search for.
    set first [string range [lindex [split $string \n] 0] 0 \
		   [expr {[.mudwin cget -width]-1}]]

    set i1 [.mudwin search -backwards $first end]
    
    # find the end index.
    set i2 "$i1 +[string length $string] chars"
    
    if {$i1=={}} {return}
	
    foreach tag [.mudwin tag names $i1] {
	.mudwin tag remove $tag $i1 $i2
    }
    foreach tag $tags {
	    .mudwin tag add $tag $i1 $i2
    }
    
}

# Bind the keypad to movement and records the directions
# moved in name of variable given
proc map {var} {

    set dirs {sw s se w e nw n ne}	
    set keys {KP_End KP_Down KP_Next KP_Left KP_Right KP_Home \
		  KP_Up KP_Prior}
    
    if {[bind .input <KP_End>]!=""} {
	foreach k $keys {
	    bind .input <$k> {}
	}
    } else {
	foreach d $dirs k $keys {
	    bind .input <$k> "writemud $d\;lappend $var $d"
	}
    }
}

# Walk is meant to be used to make a character walk in circles
# Each dir given in the list is sent to the mud after wait.
# walk called with no arguments turns it off
# and cancels all after's which may not be a good idea.

# Notice this is hooked together, using the global variable Wait,
# with auto_kill
# If auto_kill is on during a walk, walk makes sure combat
# is over before moving.

proc walk {{ dirs {}} {wait 4000} {count 0}} {
    global Wait

    if {$dirs=={}} {after cancel [after info];catch {unset Wait};return}
    
    set script "
       if {\[info exists Wait]} {
          if {\$Wait} {walk [list $dirs] $wait $count;return}
       }
       writemud [lindex $dirs $count]
       if {[expr {$count+1}]==[llength $dirs]} {
           walk [list $dirs] $wait
       } else {
           walk [list $dirs] $wait [expr {$count+1}]
       }"

    after $wait $script
}

# You can make certain keys execute commands with bindings.

bind .input <Key-F1> {monitor}
bind .input <Key-F2> {auto_map}

#################################################################
# The following few procedures implement a basic auto-mapping system.
# It works pretty well and allows you to save postcript files of the
# maps. The only real flaw is that you must type a direction and then
# wait for the room description to appear. Typing in several directions
# before the mud sends the descriptions will screw everything up.
# Basically an action just calls a function make_room which, given
# the room exits, draws the room on the map canvas. Going up or down
# spawns new maps. Note that the directions must be e,w,s,,se,sw not
# north, east etc. The code's pretty ugly should be cleaned up at some
# point.

# do the initialization set up the action etc.
proc auto_map {{x 300} {y 300}} {
    global Map
    
    if {![winfo exists .map0.canvas]} {
	action {\[([newsud,]+)\]} {make_room @1} 
	set Map(level) 0  ;# Current level of the map
	set Map(roomx) $x ;# X position of room in canvas.
	set Map(roomy) $y ;# Y position of room in canvas
	make_map
    } else {
	unaction {*[newsud,]*}
	catch {unset Map}
    }
}

# draw a map at a specific level
proc make_map {} {
    upvar \#0 Map(level) level

    toplevel .map$level
    wm title .map$level "Map level $level"

    canvas .map$level.canvas -scrollregion {0c 0c 30c 30c} \
	-width 15c -height 15c -xscrollcommand ".map$level.hscroll set"\
	-yscrollcommand ".map$level.vscroll set"

    scrollbar .map$level.vscroll -orient vertical \
	-command ".map$level.canvas yview"
    scrollbar .map$level.hscroll -orient horiz \
	-command ".map$level.canvas xview"

    # Make a menu.
    frame .map$level.menu -relief raised -borderwidth 2

    menubutton .map$level.menu.file -text "File" \
	-menu .map$level.menu.file.m 
    
    menu .map$level.menu.file.m -tearoff 0 
    
    .map$level.menu.file.m add command -label "Clear" \
	-command ".map$level.canvas delete all"
    
    .map$level.menu.file.m add command -label "Save" -command "\
	tkSave {Save map as a postrcript file.} \
           \".map$level.canvas postscript -file\" \
           {{{Postcript} {.ps}} {{All Files} {*}}}"
	
    .map$level.menu.file.m add command -label "Exit" \
	-command "destroy .map$level"

    pack .map$level.menu.file -side left
    grid .map$level.menu -row 0 -column 0 -sticky "ew"
    grid .map$level.canvas -row 1 -column 0 -columnspan 2 -sticky "news"
    grid .map$level.hscroll -row 2 -column 0 -columnspan 2 -sticky "ew"
    grid .map$level.vscroll -row 1 -column 2 -sticky "ns"
    grid columnconfigure .map$level 0 -weight 1
    grid rowconfigure .map$level 1 -weight 1
}

# draw a room on the map, given the exits of the room
proc make_room {dirs} {
    global Mmucl
    upvar #0 Map(roomx) x Map(roomy) y Map(level) level

    # This isn't right all the time.
    set dir [lindex $Mmucl(history) [expr {$Mmucl(histloc)-1}]] 
    
    # rl has to be twice the dimension of a room
    set rl 20
    
    # Figure out the coordinates of the room from the
    # direction traveled to get there.
    
    if {[string match *e* $dir]} {
	set x [expr {$x + $rl}]
    } elseif {[string match *w* $dir]} {
	set x [expr {$x - $rl}]
    } 
    if {[string match *n* $dir]} {
	set y [expr {$y - $rl}]
    } elseif {[string match *s* $dir]} {
	set y [expr {$y + $rl}]
    }
    if  {[string match u* $dir]} {
	incr level
	if {[winfo exists .map$level]} {
	    raise .map$level
	} else {
	    make_map
	}
    } elseif {[string match d* $dir]} {
	incr level -1
	if {[winfo exists .map$level]} {
	    raise .map$level
	} else {
	    make_map
	}
    }

    # draw the room
    # room length
    set rl 10 
    
    .map$level.canvas create rectangle \
	$x $y [expr {$x + $rl}] [expr {$y + $rl}] -fill {}
 
    # do the lines.
    # I'm sure there's a much better way to figure out their coords.
    foreach exit [split $dirs ,] {
	switch $exit {
	    "e" {
		set x1 [expr {$x + $rl}]
		set y1 [expr {$y +$rl/2}]
		set x2 [expr {$x + $rl + $rl/2}]
		set y2 [expr {$y + $rl/2}]
	    } 
	    "w" {
		set x1 $x
		set y1 [expr {$y +$rl/2}]
		set x2 [expr {$x - $rl/2}]
		set y2 [expr {$y + $rl/2}]
	    }
	    "n" {
		set x1 [expr {$x + $rl/2}]
		set x2 [expr {$x + $rl/2}]
		set y1 $y
		set y2 [expr {$y - $rl/2}]
	    }
	    "s" {
		set x1 [expr {$x + $rl/2}]
		set x2 [expr {$x + $rl/2}]
		set y1 [expr {$y + $rl}]
		set y2 [expr {$y + $rl + $rl/2}]
	    } 
	    "ne" {
		set x1 [expr {$x + $rl}]
		set y1 $y
		set x2 [expr {$x + $rl + $rl/2}]
		set y2 [expr {$y - $rl/2}]
	    } 
	    "nw" {
		set x1 $x
		set y1 $y
		set x2 [expr {$x - $rl/2}]
		set y2 [expr {$y - $rl/2}]
	    }
	    "se" {
		set x1 [expr {$x + $rl}]
		set x2 [expr {$x + $rl + $rl/2}]
		set y1 [expr {$y + $rl}]
		set y2 [expr {$y + $rl + $rl/2}]
	    }
	    "sw" {
		set x1 $x
		set x2 [expr {$x - $rl/2}]
		set y1 [expr {$y + $rl}]
		set y2 [expr {$y + $rl + $rl/2}]
	    }
	    "u" {
		set x1 $x
		set x2 [expr {$x + 4}]
		set y1 $y
		set y2 [expr {$y + 4}]
		.map$level.canvas create rectangle\
			$x1 $y1 $x2 $y2 -fill yellow
		continue
	    }
	    "d" {
		set x1 [expr {$x + $rl}]
		set x2 [expr {$x + $rl - 4}]
		set y1 [expr {$y + $rl}]
		set y2 [expr {$y + $rl - 4}]
		.map$level.canvas create rectangle \
		    $x1 $y1 $x2 $y2 -fill black
		continue
	    }
	}
	.map$level.canvas create line $x1 $y1 $x2 $y2 -fill red
    }
}
