@program #8625
1 1000 d
i
( lexit2.muf -- formatted list of exits for room or other object )
( a free program coded by Tony Belding <tbelding@htcomp.net> -- October 2000 )
 
$include $lib/syvel-funcs
$include $ansihack
 
$def colorize dup .obj-color swap dup me @ swap controls if .color-unparseobj else name then strcat
$def nocolorize me @ over controls if .color-unparseobj else name then
 
LVAR targ
LVAR ectr
LVAR pctr
 
: help
  "Help for 'exits' comand...." .tell
  "  exits          = show exits and paths of current room" .tell
  "  exits <target> = show exits and paths on specified object" .tell
  "You must control the room or target object." .tell
  "You will only see the dbref code of exits or destinations you control." .tell
;
 
: smart-truncate  ( string int -- string )
  over ansi_strlen over > if
    swap dup "^WHITE^(" instr 1 - strcut ( int str1 str2 )
    "^YELLOW^/" swap strcat
    rot over ansi_strlen  ( str1 str2 int str2-len )
    -  ( str1 str2 cliplen )
    rot swap  ( str2 str1 cliplen )
    ansi_strcut pop
    swap strcat
  else pop then
;
 
: unparseobj-max ( dbref int -- string )
  over .color-unparseobj dup ansi_strlen 3 pick <= if
    swap pop swap pop exit
  then
  ( object max string )
  3 pick name strlen strcut swap pop
  ( object max string2 )
  over over ansi_strlen - 1 -
  ( object max string2 strlen1 )
  4 pick name swap strcut pop
  ( object max string2 string1 )
  "^yellow^/" strcat swap strcat
  ( object max finalstring )
  -3 rotate pop pop
;  
 
: main
  dup if
    dup "#help" instr if
      help exit
    then
    match dup ok? if
      targ !
    else
      "object not found" abort
    then
  else
    loc @ targ !
  then
  me @ targ @ controls not if
    "^yellow^Sorry, you don't control &o."
    targ @ name "&o" subst
    .ansi_tell exit
  then
  "Listing exits and paths of " targ @ colorize strcat ":" strcat .ansi_tell
  0 ectr !
  0 pctr !
  targ @ exits
  begin dup ok? while
    ectr @ 1 + ectr !
    ( exit )
    dup 36 unparseobj-max
    ( exit string )
    "^ ^ " strcat
    "-" 38 leftfitstr
    "> " strcat
    ( exit string )
    over getlink dup ok? if
      dup .obj-color swap 36 unparseobj-max strcat
    else
      pop "^red^*NO DEST*"
    then
    ( exit string string2 )
    strcat
    "^green^E^ ^ " swap strcat
    .ansi_tell
  next repeat pop
    
  targ @ "/@u/d/" nextprop
  begin dup while
    pctr @ 1 + pctr !
    dup "/" explode
    begin dup 1 > while
      swap pop 1 -
    repeat
    pop ""
    ( pathprop prop string )
    targ @ 4 pick "/na" strcat getpropstr dup if  ( pathprop prop string name )
      strcat
    else
      pop over toupper strcat
    then
    ( pathprop prop string )
    "^WHITE^(^purple^" strcat
    over strcat "^white^)^ ^ " strcat
    37 smart-truncate
    "^purple^P^ ^ " swap strcat
    "-" 40 leftfitstr
    "> " strcat
    ( pathprop prop string )
    targ @ 4 pick getprop
    dup ok? if
      dup .obj-color swap 36 unparseobj-max strcat
    else
      pop "*NOTHING*"
    then
    strcat .ansi_tell
    pop
  targ @ swap nextprop repeat pop
  
  "^green^&e ^ ^exits and ^purple^&p^ ^ paths listed."
  ectr @ intostr "&e" subst
  pctr @ intostr "&p" subst
  .ansi_tell
;
 
( end of listing )
.
c
q