#
#	tkMOO
#	plugins/rose.tcl
#

# tkMOO-light is Copyright (c) Andrew Wilson 1994,1995,1996,1997
# 
#	All Rights Reserved
#
# Permission is hereby granted to use this software for private, academic
# and non-commercial use. No commercial or profitable use of this
# software may be made without the prior permission of the author.
# 
# THIS SOFTWARE IS PROVIDED BY ANDREW WILSON ``AS IS'' AND ANY
# EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED.  IN NO EVENT ANDREW WILSON BE LIABLE FOR
# ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# 
# FIXME: the callback is supplied by the server.  it's possible
# for someone to create an exit named '@recycle #foo' and have that
# string sent back to the server.  Ordinarily the server-side code
# will strip following words from the exit name, but if ever the
# value does get into the client (if someone writes an alternative
# FO, which manages to be trusted by the XDR) then we need to beware
# of possible problems.  We need to ensure single word callback.
# The worst case under MOO then becomes someone naming an exit to
# '@quit', which in itself might be a cool VR thing.
# I'm not sure if xmcp11 does error checking in-client, it probably
# doesn't in which case sending a bad value would result in the client
# breaking in some unspecified way.

# FIXME: no support as yet for non canonical (+ u/d/out) exit names.

client.register rose client_connected
client.register rose client_disconnected
client.register rose start

preferences.register location {Special Forces} {
    { {directive UseRose}
        {type boolean}
        {default Off}
        {display "Display rosette"} }
}

proc rose.client_connected {} {
    set default_usage 0
    set use $default_usage
    catch {
      set use [string tolower [worlds.get [worlds.get_current] UseRose]]
    }

    if { [string tolower $use] == "on" } {
        rose.create
    }
    return [modules.module_deferred]
}

proc rose.client_disconnected {} {
    rose.destroy
    return [modules.module_deferred]
}

proc rose.clip {string width} {
    if { [string length $string] <= $width } {
	return $string
    } {
	return "[string range $string 0 [expr $width -3]]..."
    }
}

proc rose.start {} {
    global rose_font rose_width 
    # wups, only valid in tk8
#    set rose_font "Times 10"
    set rose_font "-*-times-medium-r-*-*-10-*-*-*-*-*-*-*"
    set rose_width 20
}

proc rose.create {} {
    global rose_font rose_width 
    set r .rose
    frame $r -bd 2 -relief groove

    frame $r.l

    frame $r.l.top

    button $r.l.top.nw -text "nw" \
	-bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font
    button $r.l.top.n  -text "n" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font
    button $r.l.top.ne -text "ne" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font
    pack configure $r.l.top.nw -side left  -in $r.l.top
    pack configure $r.l.top.ne -side right -in $r.l.top
    pack configure $r.l.top.n              -in $r.l.top

    frame $r.l.mid

    button $r.l.mid.w -text "w" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font

    label $r.l.mid.location -bd 1 -padx 0 -pady 0 \
	-width $rose_width -font $rose_font -anchor s

    button $r.l.mid.e -text "e" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font

    pack configure $r.l.mid.w -side left -in $r.l.mid
    pack configure $r.l.mid.e -side right -in $r.l.mid
    pack configure $r.l.mid.location -in $r.l.mid -fill y

    frame $r.l.bot

    button $r.l.bot.sw -text "sw" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font
    button $r.l.bot.s  -text "s" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font
    button $r.l.bot.se -text "se" -bd 1 \
	-highlightthickness 0 \
	-padx 0 -pady 0 -width $rose_width -font $rose_font

    pack configure $r.l.bot.sw -side left  -in $r.l.bot
    pack configure $r.l.bot.se -side right -in $r.l.bot
    pack configure $r.l.bot.s              -in $r.l.bot

    pack configure $r.l.top -side top -in $r.l -fill x
    pack configure $r.l.bot -side bottom -in $r.l -fill x
    pack configure $r.l.mid -in $r.l -fill x

    pack configure $r.l -side left -in $r

    # 
    frame $r.r
    pack configure $r.r -side left -in $r

    window.add_toolbar $r
    window.repack
}

proc rose.destroy {} {
    set r .rose
    if { [winfo exists $r] == 1 } {
        window.remove_toolbar $r
        destroy $r
    }
}

proc xmcp11.do_xrose {} {
    if { [xmcp11.authenticated silent] == 1 } { 
        rose.set_rose
    }
}

proc mcp.do_xrose {} {
    if { [mcp.authenticated] == 1 } { 
        rose.set_rose
    }
}

proc rose.set_rose {} {
    global rose_font rose_width 
    set r .rose
    set frame(nw) top
    set frame(n) top
    set frame(ne) top

    set frame(w) mid
    set frame(e) mid

    set frame(sw) bot
    set frame(s) bot
    set frame(se) bot

    set links {}

    set which [request.current] 
    foreach direction {n ne e se s sw w nw} {
        set dir ""
        catch { set dir [request.get $which $direction] }
        if { $dir != "" } {
            regexp {^(#[0-9]+):(.+)$} $dir null oid title
            $r.l.$frame($direction).$direction configure -text [rose.clip $title $rose_width] -command "io.outgoing $direction" -state normal
	    lappend links $oid
        } {
	    $r.l.$frame($direction).$direction configure -text "$direction" -command "" -state disabled
	}
    }

    foreach slave [pack slaves $r.r] {
	set slaves [pack slaves $slave]
#	puts "destroying $slaves"
	destroy $slaves
#	puts "destroying $slave"
	destroy $slave
    }

    set i -1 

    # FIXME: this list shouldn't be hard coded

    foreach direction {u d out} {
        set dir ""
        catch { set dir [request.get $which $direction] }
        if { $dir != "" } {
#	puts "direction= $direction, dir= $dir"
            regexp {^(#[0-9]+):(.+)$} $dir null oid title

	    if { [lsearch -exact $links $oid] == -1 } {

		lappend links $oid
	        incr i
	        set column [expr $i % 2]
                catch { frame $r.r._$column; 
	                pack configure $r.r._$column -side left -fill y \
			    -in $r.r }

#	        puts "$r.r._$column.$direction $dir"
	        set b [button $r.r._$column.$direction -bd 1 -padx 0 -pady 0 \
	            -highlightthickness 0 \
		    -width $rose_width -font $rose_font]

#		    bind $b <Destroy> "puts \"destroying %W\""

                $r.r._$column.$direction configure \
		    -text [rose.clip $title $rose_width] \
		    -command "io.outgoing $direction"

	        pack configure $r.r._$column.$direction \
		    -side top \
		    -in $r.r._$column

	    }
	}
    }

    # location

    # FIXME will break if an exit is named 'location'

    set location ""
    catch { set location [request.get $which location] }
    regexp {^(#[0-9]+):(.+)$} $location null oid title
    $r.l.mid.location configure -text [rose.clip $title $rose_width]

    catch { map.you_are_here $oid }
}