(
cmd-look
Copyright 1993-94 Peter "WhiteFire" Torkelson
$Author: wfire $
$Date: 1994/02/09 11:40:04 $
$Revision: 2.0 $
)

( {{{ Syntax and Properties )

(
look [at] [<object> [on|in|= <object>]]
look at <player>['s] <object>

Props:
    On a person:
    _remote_look?:<yes|no>
    _look/notify:yes|no|message
    _look/notify-contents:yes|no|message
    _look/notify-looker:yes|no|message
    _look/notify-awake:yes|no

    On an object:
    _remote_look?:<yes|no>
    _remote_desc:<description>

    On an exit:
    _look_transparent?:<yes|no>
    _look_through?:<yes|no>
    _show:[ndsc]    n - name
                    d - description
                    s - success
                    c - contents



    _look/dark-sleepers?:yes|no
)

( }}} )
( {{{ TO DO )

(
    Erma support.
    Fake contents items.
    Obvious Exits
    Contents format
    Short descriptions.
    Improve error messages for through looking...
)

( }}} )
( {{{ Change log )

(
$Log: cmd-look,v $
# Revision 2.0  1994/02/09  11:40:04  wfire
# Put the file into Folding mode for esier editing.
# Made the matching code return clearer errors.
#
# Revision 1.9  1994/02/09  10:43:22  wfire
# Added support for exit-like matching to _details/
# Added partial name support to _details/
# Added support for @idesc.
#
# Revision 1.8  1994/02/09  06:49:08  wfire
# Now using the new lib/wfcommand
# Added #version to show the MUF version #.
#
# Revision 1.7  1994/02/09  05:51:34  wfire
# Now handles dbrefs and ints in $regnames.
#
# Revision 1.6  1994/01/09  10:58:06  wfire
# Fixed various bugs, including [but not limited to] a
#   serious problem with COMMAND @ returning the wrong thing
#   for muf. Its now consistant with what goes to MPI.
# MPI is now enabled for look-notify messages.
# Controls is used so we now have Realms Wizard support.
# Awake-notify has been added.
#
# Revision 1.5  1993/10/08  23:59:54  wfire
# Added support for the new FB _detail/ and made it standard over _thing/
# Added look-notify options.
# Added dark-sleepers.
#
# Revision 1.4  1993/09/14  02:35:27  wfire
# Fixed bug with registered @commands in _thing/s
# Added support for MPI in all messages.
#
# Revision 1.3  1993/09/07  00:52:03  wfire
# Added logging I hope. :]
#
)

( }}} )
( {{{ $Includes )

$include $lib/wfcommand

( }}} )
( {{{ Global variables )

lvar    is-remote-look
lvar    is-look-through
lvar    on-object
lvar    through-object
lvar    object
lvar    at-flag
lvar    show-fields

( }}} )
( {{{ Utility code )

: tell-me me @ swap notify ;

( ------------------------------------------- )
: yes? ( d s -- i )
    getpropstr 1 strcut pop "y" stringcmp 0 =
;

: no? ( d s -- i )
    getpropstr 1 strcut pop "n" stringcmp 0 =
;

( ------------------------------------------- )
: debug 
    me @ "_look_debug?" yes?
    if
        tell-me
    else
        pop
    then
;        

( ------------------------------------------- )
: split ( s s1 -- s s )
    over swap instr dup
    if
        1 - strcut 1 strcut swap pop
    else
        pop ""
    then    
;

( ------------------------------------------- )
: split-str ( s s1 -- s s )
    over over instring dup
    if
        rot swap 1 - strcut  (s1 sa sb)
        rot strlen strcut swap pop
    else
        pop pop ""
    then    
;

( ------------------------------------------- )
: prefix ( s s2 -- i )
    dup strlen strncmp 0 =
;

( ------------------------------------------- )
: dbref-or-reg ( obj str -- dbref )

    ( if leading @, strip )
    dup "@" prefix
    if 1 strcut swap pop then

    ( _reg/<regname> )
    dup "$" prefix
    if
        1 strcut swap pop ( get rid of $ )
        "_reg/" swap strcat 
       
        ( dbref property )     
        BEGIN
            over ok? not
            if
                pop pop "" BREAK
            then

            over over getprop
            dup not if pop "" then
 
            dup dbref?
            if
                int
            then

            dup int?
            if
                intostr
            then

            dup
            if
                swap pop swap pop
                BREAK
            then
            pop

            ( next ... )
            swap location swap
        REPEAT

    else
        ( don't need the dbref )
        swap pop
    then

    ( Just in case, remove leading # )
    dup "#" prefix
    if 1 strcut swap pop then

    ( convert to dbref )
    dup number?
    if
        atoi dbref
    else
        pop #-1
    then
;

( }}} )
( {{{ Parse )

: parse ( s -- i )
    strip
    
    dup not 
    if
        "here"
    then    
    
    ( 
    Check for "at" prefix 
    )
    dup "at " prefix
    if
        3 strcut swap pop
        strip
        1
    else
        command @ "at" instring not not
    then
    at-flag !
    
    (
    In/On/= check
    )
    dup "=" split strip
    dup not if pop pop dup " in " split-str then
    dup not if pop pop dup " on " split-str then
    
    rot pop
    
    dup not
    at-flag @ and
    if
        (
        look at player's object
        )
        pop
        dup "'s " split-str
        dup not if pop pop dup " " split then
        dup 
        if
            swap
        then    
    then
    
    strip on-object ! strip object !

    on-object @ not not is-remote-look !
;

( }}} )
( {{{ Matching code )

: match-ok? ( s d -- i )
    dup #-1 dbcmp
    if
        pop
        "I don't see " swap strcat

        (
        If were are looking for something on another object,
        print a more useful error message.
        )
        " here."
        on-object @ ok?
        if
            on-object @ me @ location dbcmp not
            if
                pop
                " on " on-object @ name strcat "." strcat
            then
        then 
        strcat

        tell-me
        0 exit
    then

    dup  #-2 dbcmp
    over #-3 dbcmp or
    if
        pop
        "I don't know which " swap strcat " you mean!" strcat tell-me
        0 exit
    then
    
    pop pop 1
;

( ------------------------------------------- )
lvar partial-detail
lvar detail-list     ( either erma's _look/t-* or the server _details/ )

: detail-match ( -- i )
    "" partial-detail !

    on-object @ detail-list @ object @ strcat getpropstr
    if 
        detail-list @ object @ strcat object ! 
        1 exit
    then

    detail-list @
    BEGIN
        on-object @ swap nextprop
        dup detail-list @ strlen strcut pop detail-list @ stringcmp 0 =
        WHILE

        ( working name )
        dup detail-list @ strlen strcut swap pop

        ";" swap strcat ";" strcat
        
        ( Full match )
        dup ";" object @ ";" strcat strcat
        instr
        if
            pop object ! 1 exit
        then

        ( partial match )
        dup ";" object @ strcat instr
        over " " object @ strcat instr or
        if
            partial-detail @
            if
                pop pop -1 exit ( ambigous )
            then

            over partial-detail !
        then

        ( Next ... )
        pop

    REPEAT

    pop

    partial-detail @
    if
        partial-detail @ object !
        1 exit
    then

    0
;

: check-prop ( -- i )
    on-object @ "_thing/" object @ strcat getpropstr
    if 
        "_thing/" object @ strcat object ! 
        1 exit
    then

    ( Server and WF standard )
    "_details/" detail-list !
    detail-match dup
    if
        exit
    else
        pop
    then

    ( Erma's )
    "_look/t-" detail-list !
    detail-match dup
    if
        exit
    else
        pop
    then

    0
;

( ------------------------------------------- )
: find

    (
    Find out where to look
    )
    
    #-1 through-object !
    
    on-object @ not
    if
        #-1 on-object !
    else
        on-object @ match 
        on-object @ over match-ok? not
        if
            pop 0 exit
        then
        
        on-object !
    
        (
        ----- Transparent exits
        )
        on-object @ exit?
        on-object @ getlink room? and
        if
            on-object @ through-object !
            on-object @ getlink on-object !
        then
    then

    (
    Find what it is they want there.
    )
    on-object @ #-1 dbcmp not
    if
        on-object @ object @ rmatch
    else    
        object @ 1 strcut swap "#" stringcmp 0 =
	over number? and
        if
	    atoi dbref 
	    dup ok? not if pop #-1 then
	else
            pop object @ match ( look everywhere! :)
	then
    then    

    dup #-1 dbcmp
    if
        (
        ----- Check for prop...
        )
        on-object @ #-1 dbcmp
        if
            loc @ on-object !
        then

        check-prop

        dup -1 =
        if
            pop pop
            "I don't know which " object @ strcat " you mean!" strcat tell-me
            0 exit
        then

        if
            pop 1 exit
        then
    then
     
    object @ over match-ok? not    
    if
        pop 0 exit
    then
    object !
    
    on-object @ #-1 dbcmp
    if
        object @ room?
        object @ me @ location dbcmp or ( incase your inside something )
        if
            object @
        else
            object @ location
        then
        on-object !
    then
    
    (
    -----
    )
    1
;

( }}} )
( {{{ Look ok? )

: look-ok?

    (
    Can alwase look at things on the curent room or your person.
    )
    on-object @ loc @ dbcmp
    on-object @ me  @ dbcmp or
    if
        1 exit
    then    

    (
    look at <objects>'s object... Remote Look
    )
    on-object @ location me  @ dbcmp    
    on-object @ location loc @ dbcmp	or
    is-remote-look @			and
    if
        on-object @ "_remote_look?" no?
        if
            "You can't see that clearly." tell-me
            0 exit
        then

        object @ string?
        if
            1 exit
        then
    
        on-object @ "_remote_look?" yes?
        object @    "_remote_look?" yes? or not
        if
            "You can't see that clearly." tell-me
            0 exit
        then
    
        1 exit
    then
    
    (
    Through exits
    )
    through-object @
    if
        through-object @ "_look_through?" yes?
        on-object @ "_remote_look?"       no? not and
        not
        if
            "You can't see through that." tell-me
            0 exit
        else
            1 exit
        then
    then
    
    (
    Exits in parent room, on objects, etc.
    )
    object @ exit? 
    if
        object @ name ";" split pop
        match object @ dbcmp
        if
            1 exit
        then
    then
    
    (
    Wizards or owners look at objects anywhere...
    )
    object @ owner me @ dbcmp
    me @ "w" flag?              or
    if
        1 exit
    else
        "You may not view that remotely." tell-me
        0 exit
    then
    
    (
    ...
    )
    "LOOK ERROR: I don't understand this!" tell-me
    0
;

( }}} )
( {{{ Do look )

: showing-inside? ( -- i )
    object @ dbref? not if 0 exit then
    object @ room? if 0 exit then
    object @ me @ location dbcmp
;

lvar run-program
lvar run-arg
lvar run-string
lvar run-tmp-command

: run-prog (d s -- )
    run-arg !
    run-program !
    
    ">> Running: " run-program @ unparseobj strcat 
    " with \"" strcat run-arg @ strcat "\"" strcat
    debug
    
    object @ dbref?
    if
        object @ trigger !
    else
        on-object @ trigger !
    then    
    
    ( swap call )
    
    #-10101  ( pop off to here )
    "GARBAGE" ( put some junk on the stack. )
    "GARBAGE"    
    "GARBAGE"    
    "GARBAGE"    
    "GARBAGE"    
    
    command @ run-tmp-command ! run-string @ command !
    run-arg @ run-program @ call
    run-tmp-command @ command !
    
    ( Cleanup the stack )
    begin 
        dup dbref?
        if
            #-10101 dbcmp not
        else
            pop 1
        then
        while
    repeat    
    
    trig trigger !
;

( ------------------------------------------- )
: show-field  ( s ) ( propname commandname )

    dup run-string !

    object @ string? if on-object @ else object @ then -3 rotate

    1 parseprop

    dup "@" prefix
    if
        " " split swap
        
        ( find program )
        object @ string? if on-object @ else object @ then
        swap
        dbref-or-reg
    
        ( run program )
        dup program?
        if
            dup "L" flag?
            over owner me @ dbcmp or
            if
                swap run-prog
            else
                pop
                tell-me
            then
        else
            pop
            tell-me
        then    
    else
        tell-me
    then
;

( ------------------------------------------- )
: show-desc
    object @ desc
    if
        "_/de" "(@Desc)" show-field
    else
        "You see nothing special." tell-me
    then    
;

( ------------------------------------------- )
: can-see-dbref? ( d -- )
    me @ "s" flag?  if pop 0 exit then
    me @ "w" flag?  if pop 1 exit then

    me @ over controls if pop 1 exit then
    
    dup "a" flag?   if pop 1 exit then
    dup "c" flag?   if pop 1 exit then
        "l" flag?   if     1 exit then
    0    
;

( ------------------------------------------- )
: show-objname ( d -- )
    dup can-see-dbref?
    if
        dup unparseobj
    else
        dup name
    then

    me @ "_look/notify-awake" getpropstr 1 strcut pop "y" stringcmp 0 =
    if
        over player?
        if
            over awake?
            if
            	" [awake]"
            else
                " [asleep]"
            then
            strcat

$ifndef __version<Muck2.2fb5.0
        else
            over "z" flag?
            3 pick thing? and
            if
                over owner name " [" swap strcat "'s " strcat strcat
                over awake? if "awake]" else "asleep]" then  
                strcat
            then
$endif
        then
    then

    swap pop

    tell-me
;

( ------------------------------------------- )
: show-ofield  ( prop command )   
    object @ string? if on-object @ else object @ then -3 rotate

$ifdef __version<Muck2.2fb5.0
    pop getpropstr
$else
    1 parseprop
$endif

    dup 
    if
        me @ name " " strcat swap strcat
        loc @ swap me @ swap notify_except 
    else
        pop
    then    
;

( ------------------------------------------- )
lvar first-item
lvar sleepers-dark

: show-ok? ( d -- i )
    dup me @ dbcmp          ( Don't show yourself )
    if pop 0 exit then
    
    dup room?               ( Don't show rooms )
    if pop 0 exit then
    
    dup owner me @ dbcmp    ( If its yours, show it. )
    if pop 1 exit then
                        
    dup "d" flag?           ( Don't show dark objects ) 
    object @ owner me @ dbcmp not and  ( Unless its your object its on/in )
    if pop 0 exit then
                            ( Don't show things in dark rooms )
    object @ room? object @ "d" flag? and
    if pop 0 exit then
                            ( Don't show !l programs.  )
    dup program? over "l" flag? not and
    me @ "w" flag? not and
    if pop 0 exit then

                            ( Don't show dark player as per flag... )
    dup player?
    sleepers-dark @ and
    if
	dup awake? not if pop 0 exit then
    then
    
    pop
    1
;

( ------------------------------------------- )
: show-contents ( s ) 
    1 first-item !

    object @ contents
    begin
        dup ok?
        while
        
        dup show-ok?
        if
            first-item @
            if
                object @ player?
                showing-inside? not and
                if
                    "Carrying:"
                else
                    "Contents:" 
                then    
                
                tell-me 
                0 first-item !
            then
                
            dup show-objname
        then
        
        next
    repeat    

    pop
;

( ------------------------------------------- )
: do-room   
    show-fields @ "n" instr
    if
        object @ show-objname
    then
        
    show-fields @ "d" instr
    if
        showing-inside?
        if 
            "_/ide" "(@Idesc)" show-field
        else
            "_/de" "(@Desc)" show-field
        then
    then    
    
    ( succ/fail )
    show-fields @ "s" instr
    if
        object @ getlockstr "*UNLOCKED*" stringcmp 0 = 
        if
            "_/sc"  "(@Succ)" show-field
            "_/osc" "(@Osucc)" show-ofield
        else
            me @ object @ locked?
            if
                "_/fl"  "(@Fail)"  show-field
                "_/ofl" "(@Ofail)" show-ofield
            else
                "_/sc"  "(@Succ)" show-field
                "_/osc" "(@Osucc)" show-ofield
            then
        then
    then    

    show-fields @ "c" instr
    if
        show-contents
    then
;

( ------------------------------------------- )
: do-inside
    "ndc" show-fields ! ( no @succ stuff )
    do-room
;

( ------------------------------------------- )
: do-string
    object @ "(Look-Thing-Desc)" show-field
;

( ------------------------------------------- )
: do-thing  
    
    ( on-object==player && object->"_remote_desc" && [on-obj != me || at-flag])
    
    on-object @ player?
    object @ "_remote_desc" getpropstr      and
    on-object @ me @ dbcmp not
    at-flag @                               or and
    if
        "_remote_desc" "(Look-Remote-Desc)" show-field
    else
        show-desc
    then    
    show-contents
    exit 
;

( ------------------------------------------- )
: do-transparent
    
    "_/de" "(@Desc)" show-field
    
    object @ "_show" getpropstr 
    dup not if pop object @ "show" getpropstr then
    dup not if pop "ndsc" then
    show-fields !
    
    object @ 
    object @ getlink object !
    do-room
    object !
;

( ------------------------------------------- )
: do-exit
    
    object @ getlink room?              
    object @ "_look_transparent?" yes?  and
    if
        object @ getlink "_remote_look?" no? not
        if
            do-transparent
            exit
        then
    then

    do-thing
;

( ------------------------------------------- )
: are-sleepers-dark?
    me @ "_look/dark-sleepers?" getpropstr
    dup not 
    if 
        pop 
        object @ string? if on-object @ else object @ then
	"_look/dark-sleepers?" envpropstr swap pop
    then

    1 strcut pop toupper
    "Y" stringcmp 0 =
;

( ------------------------------------------- )
: do-look
    "ndsc" show-fields !
    are-sleepers-dark? sleepers-dark !

    showing-inside?     if  do-inside   exit then
    object @ string?    if  do-string   exit then
    object @ room?      if  do-room     exit then
    object @ player?    if  do-thing    exit then
    object @ thing?     if  do-thing    exit then
    object @ program?   if  do-thing    exit then
    object @ exit?      if  do-exit     exit then

    "LOOK ERROR: Unknown object type!" tell-me
;

( }}} )
( {{{ Look-Notify )

: has-notify? ( def-format object property -- format bool )
    ( getpropstr )
    "(look-notify)" 1 parseprop

    dup 1 strcut pop "n" stringcmp 0 = not
    over and
    if
        ( use default? )
        dup 1 strcut pop "y" stringcmp 0 = not
        if
            swap        
        then
        pop 1
    else
        pop pop "" 0  ( no notify )
    then
;

( ------------------------------------------- )
: notify-looker ( owner-name object-name -- )
    (
    _look/notify-looker
    )
    "<%name has a look notify on %obj>" me @ "_look/notify-looker" has-notify?
    if
        swap "%obj" subst
        swap "%name" subst
        me @ swap notify
    else
        pop
    then        
;

( ------------------------------------------- )
: do-look-notify ( -- )

    (
    _look/notify
    )
    object @ string? not
    if
        "<%name just looked at %obj>" object @ "_look/notify" has-notify?
        if
            me @ name "%name" subst
            object @ player? if "you" else object @ name then 
                "%obj" subst
            object @ owner swap notify

            object @ owner name object @ name notify-looker
        else
            pop
        then
    then

    (
    _look/notify-contents
    )
    object @ string?
    if
        "<%name just looked at %obj on %on>" 
        on-object @ "_look/notify-contents" has-notify?
        if
            me @ name "%name" subst
            object @ "[" swap strcat "]" strcat "%obj" subst
            on-object @ player? 
                if "you" else on-object @ name then
                "%on" subst

            on-object @ owner swap notify

            on-object @ owner name
            on-object @ name
            notify-looker
        then
    else
        object @ #0 dbcmp not
        if
            "<%name just looked at %obj on %on>" 
            object @ location "_look/notify-contents" has-notify?
            if
                me @ name "%name" subst
                object @ name "%obj" subst
                object @ location player? 
                    if "you" else object @ location name then
                    "%on" subst
    
                object @ location owner swap notify
    
                object @ location owner name
                object @ location name
                notify-looker
            then
        then
    then
;

( }}} )
( {{{ Main )

: main

    preempt
    
    (
    Phase Zero: Commands [help and such]
    )
    dup strip "#h" prefix 
    if
        " " split swap pop strip
        prog swap lib-command-help
        exit
    then
    
    dup strip "#v" prefix
    if
        "cmd-look (c) 1993-94 Peter A. Torkelson" tell-me
        "$Date: 1994/02/09 11:40:04 $" tell-me
        "$Version: 1 $" tell-me
        "$Revision: 2.0 $" tell-me
        exit
    then

    ( 
    Phase I:   Parse the command line 
    )
    parse
    
    ">> look " 
    at-flag @ if "at " strcat then
    object @ strcat
    on-object @ if " on " strcat on-object @ strcat then
    "." strcat debug
    
    ( 
    Phase II:  Find what we are to look at 
    )
    find 
    not
    if
        exit
    then    
    
    ">> look "
    at-flag @ if "at " strcat then
    object @ dbref?
    if
        object @ unparseobj strcat
    else
        "[" object @ strcat "]" strcat strcat
    then
    on-object @ 
    if " on " strcat on-object @ unparseobj strcat then
    through-object @ 
    if " through " strcat through-object @ unparseobj strcat then
    "." strcat debug

    ( 
    Phase III: Check permissions
    )
    look-ok?
    if
        ">> This look is ok." debug
    else
        ">> This look is NOT ok." debug
        exit
    then
        
    ( 
    Phase IV:  Do the look 
    )
    ">> Look start." debug
    do-look
    ">> Look done." debug

    (
    Phase V:   Do look notify
    )
    do-look-notify    
;

( }}} )
( {{{ Emacs local variables )
(
Local variables:
folded-file: t
eval: (fold-set-marks "( {{{" "( }}} )")
end:
)
( }}} )