(
  tport
  Version: 2.1.0
  Restricted Teleport.

  2.1.1 10/25/96 - Fixed #public to be wiz only.
  2.1.0 9/21/95 - Added msummon/#summon.
  2.0.0 ?/?/? - total rewrite from QWest tport program.

  Properties:
 
  [ total list on #0 ]
  @tport/locations/<symname>:<dbref>
  @tport/plocations/<symname>:<dbref> - public locations
  
  [ on player ]
  @tport/locations/<symname>:<dbref> - known locations
  _tport/lock:<dbreflist>  
  _tport/summon-<dbref>:<systime> - Player last summoned at...
  
  [ On room ]
  @tport/location:<symname>
  _tport/lock:<lock>
  _tport/name:<shows up on lists>
 
  [ On room or environment ]
  _prefs/tport_ok?:yes|no

  Commands:

  tport <symname>            *  - Teleport to symname
  tport <player>             *  - Teleport to a player.

  [ Public Teleports: ]
  tport #public <symname>    *  - <wiz> location everone can jump to  
  tport #!public <symname>      - <wiz> remove a location
  tport #public              *  - list public jump locations

  [ Personal Managment: ]
  tport #list                *  - list your known destinations.
  tport #listall             *  - <wiz> list all destinations
  tport #forget <symname>    *  - forget a location
  tport #learn               *  - Learn here if its a location
  tport #plock <lockexpr>    *  - Set your personal lock.

  [ Room Managment: ]
  tport #show                *  - show info for curent room.
  tport #create <symname>[=<listname>] 
                             *  - Create a teleport patern here that shows
                                  as listname.
  tport #lock <lockexpr>     *  - Set a room lock.
  tport #destroy             *  - Remove teleport pattern here.

  [ Summoning: ]
  tport #summon <player>     *  - Summons player to you.
  msummon <player>           *  - Same as above.
    
)

$define FROMMSG     "You think of the distant teleport pattern %word, and the world around you changes!" 
$enddef
$define FROMMSG_PLR "You think of %dest, and the world around you changes!" 
$enddef
$define FROMOMSG    "concentrates on a distant place, and fades from sight." 
$enddef
$define TOOMSG      "fades into existance on the teleport pattern." $enddef
$define TOOMSG_PLR  "fades into existance next to %dest." $enddef

( ----------------------------------------------------------------- $include )
$include $lib/command

( ----------------------------------------------------------------- VARS )
var cmd-option
var cmd-arg1
var cmd-arg2
var tport-isglobal
var tport-dest
var tport-summon

( ----------------------------------------------------------------- UTIL )
: tell-me me @ swap notify ;


( ----------------------------------------------------------------- PARSE )
( Varous general functions.. )
: cmd-parse ( s -- s1 s2 s3 )

    strip

    ( *s1* if it starts with a # strip off the option.. )
    dup 1 strcut pop "#" stringcmp 0 =
    over 1 strcut swap pop 1 strcut pop number? not and
    if
        dup " " instr
        dup
        if
            strcut 
            strip
            swap
            strip
        else
            pop
            ""
            swap
        then
        
        1 strcut swap pop (strip #/-)
    else
        ""
    then
    
    swap ( stack: s1 s )
    
    ( *s3* Is there a =? )
    dup "=" instr
    dup
    if
        1 -
        strcut 
        1 strcut swap pop ( strip = )
        strip
        swap
    else
        pop
        ""
        swap
    then
    
    ( stack: s1 s3 s )
    
    ( *s2* Finish it.. )
    strip swap
;

( ----------------------------------------------------------------- Funcs )
: controls? ( d d -- i )
    ( wizard controlls all )
    dup "w" flag? if pop pop 1 exit then

    ( What you own )
    swap owner dbcmp
;

: loc-name-ok? ( s -- i )
    ( Null string not valid. )
    dup not if pop 0 exit then

    ( check first character )
    dup 1 strcut pop "_.@~" swap instr
    if
        pop 0 exit
    then

    ( Nothing silly like propdirs .. )
    dup " " instr
    over "/" instr or
    over ":" instr or
    if
        0 exit
    then

    dup .pmatch player?
    if
        0 exit
    then

    1
;

var list-prefix
var list-object

: show-list ( object prefix -- )

    list-prefix !
    list-object !

    list-prefix @

    BEGIN
        list-object @ swap nextprop
        dup list-prefix @ strlen strcut pop list-prefix @ stringcmp 0 =
        WHILE
       
        ( dest address )
        dup list-prefix @ strlen strcut swap pop " - " strcat

        ( actual destination )
        over list-object @ swap getpropstr 
        atoi dbref 
        dup ok?
        if
            dup "_tport/name" getpropstr dup
            if
                me @ "w" flag? 
                3 pick owner me @ dbcmp or
                if 
                    over unparseobj " [" swap strcat "]" strcat strcat 
                then
                swap pop
            else
                pop unparseobj
            then
        else
            pop "** INVALID **"
        then
        strcat
        tell-me

    REPEAT    

    pop

    "> Done" tell-me
;

: parse-msg ( s -- 's )
    me @ name "%name" subst
    cmd-arg1 @ "%word" subst
    tport-dest @ name "%dest" subst
;

: parse-omsg ( s -- 's )
    parse-msg
    me @ name " " strcat swap strcat
;

( 
  Args: player to, player from.
  Returns: 0 = Ok!, 1 = Summon timed out, 2 = No summon.
)
var tmp-person
var tmp-to
: summon-ok? ( d d -- i )
    tmp-person ! tmp-to !

    tmp-to @ player? not
    if
        2
        exit
    then

    tmp-to @ "_tport/summon-" tmp-person @ intostr strcat getprop
    dup int?
    if
        dup 0 =
        if
            pop
            2 exit
        then

        systime swap - 300 ( 5 minutes ) >
        if
            1
        else
            0
        then
    else
        pop 
        2
    then
;

: loc-exists? ( s -- i )
    dup #0 swap "@tport/plocations/" swap strcat getpropstr
    if
        pop 1
        exit
    then

    #0 swap "@tport/locations/" swap strcat getpropstr
    if
        1
        exit
    then

    0
;

( ----------------------------------------------------------------- COMMANDS )
var summoned

: do-teleport 
    (
    Teleport, find location
    )
    cmd-arg1 @ .pmatch

    dup player?
    if
        tport-dest ! 0 tport-isglobal !
    else
        pop

        me @ "@tport/locations/" cmd-arg1 @ strcat getpropstr
        dup not
        if
            pop
            #0 "@tport/plocations/" cmd-arg1 @ strcat getpropstr
            1
        else
            0
        then            
  
        tport-isglobal !

        dup not
        if
            "> \"" cmd-arg1 @ strcat "\" is an unknown pattern." strcat tell-me
            pop exit
        then

        atoi dbref tport-dest !
    then

    (
    Teleport, verify location.
    )
    tport-dest @ room? not
    tport-dest @ player? not and
    if
        "> \"" cmd-arg1 @ strcat "\" has an invalid destination." strcat
            tell-me
        exit
    then    

    tport-isglobal @ not
    tport-dest @ player? not and
    if
        tport-dest @ "@tport/location" getpropstr cmd-arg1 @ stringcmp 0 = not
        if
            "> The teleport pattern there has changed." tell-me
            exit
        then
    then

    (
    Check locking conditions in destination and summoning
    )
    tport-dest @ me @ summon-ok? summoned !
    tport-dest @ "_tport/summon-" me @ intostr strcat remove_prop

    tport-dest @ "_tport/lock" getprop
    dup lock?
    summoned @ 0 = not and
    if
        me @ swap testlock not
        if
            tport-dest @ player? 
            if
                "> You may not teleport to " tport-dest @ name strcat "." 
                    strcat
            else
                "> The teleport pattern is warded against you." 
            then
            tell-me
            exit
        then
    else
        pop
        tport-dest @ player?
        if
            
            summoned @ 0 =
            if
                "> Accepting " tport-dest @ name strcat "'s summons." strcat
                    tell-me
            else
                summoned @ 1 =
                if
                    "> " tport-dest @ name strcat "'s invitation timed out."
                        strcat tell-me
                    exit
                else
                    "> " tport-dest @ name strcat " is not setup for teleport."
                        strcat tell-me
                    exit
                then
            then
        then
    then
 
    (
    Do teleport
    )
    loc @ me @ FROMOMSG parse-omsg notify_except
    tport-dest @ player?
    if
        FROMMSG_PLR parse-msg tell-me
        tport-dest @ me @ TOOMSG_PLR parse-omsg notify_except
        tport-dest @ location tport-dest !
    else
        FROMMSG parse-msg tell-me
        tport-dest @ me @ TOOMSG parse-omsg notify_except
    then
    me @ tport-dest @ moveto
;

: do-list
    me @ "_tport/lock" getprop
    dup lock?
    if
        "> Personal Lock: " swap prettylock strcat tell-me
    else
        pop
    then

    "> Personal destinations." tell-me
    me @ "@tport/locations/" show-list
    "> Done."
;

: do-learn
    loc @ "@tport/location" getpropstr
    dup not
    if
        "> There is no teleport pattern here." tell-me
        pop exit
    then

    dup loc-name-ok? not
    if
        "> The teleport pattern here is not working." tell-me
        pop exit
    then

    dup "@tport/locations/" swap strcat me @ swap
    loc @ int intostr 0 addprop

    "> Teleport destination \"" swap strcat "\" added." strcat tell-me
;

: do-help
    prog cmd-arg1 @ lib-help
;

: do-addpublic
    me @ "w" flag? not
    if
        "> This command is restricted to wizards." tell-me
        exit
    then

    ( Name ok? )
    cmd-arg1 @ loc-name-ok? not
    if
	"> \"" cmd-arg1 @ strcat "\" is not a valid name." strcat tell-me
	exit
    then

    cmd-arg1 @ loc-exists?
    if
        "> That location already exists." tell-me
        exit
    then

    #0 "@tport/plocations/" cmd-arg1 @ strcat loc @ int intostr 0 addprop

    "> Teleport destination \"" cmd-arg1 @ strcat "\" added." strcat tell-me
;

: do-public
    cmd-arg1 @ if do-addpublic exit then

    "> Public destinations." tell-me
    #0 "@tport/plocations/" show-list
    "> Done."
;

: do-listall
    me @ "w" flag? not
    if
        "> This command is restricted to wizards." tell-me
        exit
    then

    "> All non-public patterns." tell-me
    #0 "@tport/locations/" show-list
    "> Done."
;

: do-show
    loc @ "@tport/location" getpropstr 
    dup if dup loc-name-ok? else dup then
    if
        "> This room has a teleport pattern with the name \""
            swap strcat "\"." strcat tell-me

        me @ "w" flag?
        me @ loc @ owner dbcmp or
        if
            loc @ "_tport/name" getpropstr dup
            if
                "> Shows on lists as: " swap strcat tell-me
            else
                pop
            then

            loc @ "_tport/lock" getprop 
            dup lock?
            if
                "> Locked to: " swap prettylock strcat tell-me
            else
                pop
            then
        then
    else
        "> This room does not have a teleport pattern." tell-me
        pop exit
    then
;

: do-create
    loc @ me @ controls? not
    if
        "> You do not own this room." tell-me
        exit
    then

    cmd-arg1 @ loc-name-ok? not
    if
        "> That is an invalid name for a teleport pattern." tell-me
	exit
    then

    cmd-arg1 @ loc-exists?
    if
        "> The pattern name \"" cmd-arg1 @ strcat "\" is already in use."
            strcat tell-me
        exit
    then

    loc @ "@tport/location" getpropstr
    if
        "> This room already has a teleport pattern." tell-me
        exit
    then

    loc @ "@tport/location" cmd-arg1 @ 0 addprop
    #0 "@tport/locations/" cmd-arg1 @ strcat loc @ int intostr 0 addprop
    cmd-arg2 @
    if
        loc @ "_tport/name" cmd-arg2 @ 0 addprop
    then

    "> Teleport pattern \"" cmd-arg1 @ strcat "\" created." strcat tell-me
;

: do-destroy
    loc @ me @ controls? not
    if
        "> You do not own this room." tell-me
        exit
    then

    loc @ "@tport/location" getpropstr not
    if
        "> This room does not have a teleport pattern." tell-me
        exit
    then

    #0 "@tport/locations/" loc @ "@tport/location" getpropstr strcat
        remove_prop
    loc @ "@tport/location" remove_prop
    loc @ "_tport/name" remove_prop
    loc @ "_tport/lock" remove_prop

    "> Teleport pattern destroyed." tell-me
;

: do-lock
(
    "> Command disabled due to server bug, type the following to" tell-me
    "> set the lock manualy:" tell-me
    "> @propset here=lock:_tport/lock:" cmd-arg1 @ strcat tell-me
    exit
)
    loc @ me @ controls? not
    if
        "> You do not own this room." tell-me
        exit
    then

    cmd-arg1 @ not
    if
        loc @ "_tport/lock" remove_prop
        "> Lock removed." tell-me
    then

    cmd-arg1 @ parselock
    dup not
    if
        pop
        "> Invalid lock." tell-me
        exit
    then

    dup loc @ swap "_tport/lock" swap setprop
    "> Lock set to: " swap prettylock strcat tell-me
;

: do-forget
    me @ "@tport/locations/" cmd-arg1 @ strcat getpropstr
    not
    if
        "> You didn't know any such location." tell-me
  	exit
    then

    me @ "@tport/locations/" cmd-arg1 @ strcat remove_prop
    "> Forgotten." tell-me
;

: do-plock
(
    "> Command disabled due to server bug, type the following to" tell-me
    "> set the lock manualy:" tell-me
    "> @propset me=lock:_tport/lock:" cmd-arg1 @ strcat tell-me
    exit
)
    cmd-arg1 @ not
    if
        me @ "_tport/lock" remove_prop
        "> Lock removed." tell-me
        exit
    then

    cmd-arg1 @ parselock
    dup not
    if
        pop
        "> Invalid lock." tell-me
        exit
    then

    dup me @ swap "_tport/lock" swap setprop
    "> Personal lock set to: " swap prettylock strcat tell-me
;

: do-summon
(
    "> tport #summon stub code... Called with: " cmd-arg1 @ strcat tell-me
)
    cmd-arg1 @ .pmatch

    dup player? not
    if
    	pop
        "> " cmd-arg1 @ strcat " is not a player." strcat tell-me
	exit
    then

    tport-summon !

    tport-summon @ me @ dbcmp
    if
	"> Can not summon yourself." tell-me
        exit
    then

    tport-summon @ awake? not
    if
        "> Let " tport-summon @ name strcat " sleep!" strcat tell-me
        exit
    then

    me @ tport-summon @ summon-ok? 0 =
    if
        "> You already summoned them!" tell-me
        exit
    then

    ( SO DO IT! )
    ( set the time the summons was made... )
    systime me @ "_tport/summon-" tport-summon @ intostr strcat
        rot setprop
    ( Tell them they were summoned... )
    "> " me @ name strcat " would like you to teleport to them." strcat 
        tport-summon @ swap notify
    "> Type \"tport " me @ name strcat "\" to go to them." strcat
        tport-summon @ swap notify
    "> You asked " tport-summon @ name strcat " to teleport to you." strcat
        tell-me
;

( ----------------------------------------------------------------- MAIN )

: main

    cmd-parse ( #s1 s2=s4 )
    cmd-arg2 ! cmd-arg1 ! cmd-option !

    (
    msummon special case...
    )
    command @ "msummon" stringcmp 0 =
    if
        cmd-option @ "help" stringcmp 0 =
        if
            "summon" cmd-arg1 !
        else
            cmd-arg1 @
            if
                "summon" cmd-option !
            else
                "help" cmd-option !
                "summon" cmd-arg1 !
            then
        then
    then

    (
    If no args, complain
    )
    cmd-option @ not cmd-arg1 @ not and
    if
        "> See tport #help for usage." tell-me
        exit
    then

    (
    Call apropriate command
    )
    cmd-option @ not                            if do-teleport exit then
    cmd-option @ "learn"          stringcmp 0 = if do-learn exit then
    cmd-option @ "list"           stringcmp 0 = if do-list exit then
    cmd-option @ "help"           stringcmp 0 = if do-help exit then
    cmd-option @ "public"         stringcmp 0 = if do-public exit then
    cmd-option @ "show"           stringcmp 0 = if do-show exit then
    cmd-option @ "create"         stringcmp 0 = if do-create exit then
    cmd-option @ "destroy"        stringcmp 0 = if do-destroy exit then
    cmd-option @ "listall"        stringcmp 0 = if do-listall exit then
    cmd-option @ "lock"           stringcmp 0 = if do-lock exit then
    cmd-option @ "forget"         stringcmp 0 = if do-forget exit then
    cmd-option @ "plock"          stringcmp 0 = if do-plock exit then
    cmd-option @ "summon"	  stringcmp 0 = if do-summon exit then

    "> \"#" cmd-option @ strcat 
        "\" is an unknown command. Try \"tport #help\" for help." strcat 
        tell-me
;


