@program #183
1 1000 d
i
$include $ansihack
$def header "NewObviousExits.muf -- Syvel @ KnownSpace -- 2/17/97"
(
ObviousExits
 
  Shows all actions and exits in a room.
  Actions will only be shown on rooms/environments with the property:
    _showactions?:yes
  Any exit with the prop '_action?:yes' will be forced shown in the
  action list, DARK or not.
  Any exit with the prop '_exit?:yes' will be forced shown in the
  exit list, DARK or not.
  DARK exits not normally shown.
  Exits linked to programs are considered actions.
  Exits linked to rooms are considered exits.
  Everything else is skipped unless it has a '_exit?' or '_action?' prop.
 
  Porting:      This program is free software; you can redistribute it and/or
                modify it under the terms of the GNU General Public License as
                published by the Free Software Foundation; either version 2,
                or <at your option> any later version.
)
$include $lib/syvel-funcs
$include $lib/case
($include $cmd/path)
$include $lib/userprop
 
$def maxidle 300
 
lvar OK
lvar SHOWIT
lvar WIDTH
 
: initialize ( -- )
  78 WIDTH !
  prog "contents/width" getpropstr dup if
    atoi WIDTH !
  else
    pop
  then
  trig "contents/width" envpropstr swap pop dup if
    atoi WIDTH !
  else
    pop
  then
;
 
: parse-action ( s -- s )
  ( do parsing )
  "^BROWN^(^YELLOW^" "(" subst
  "^BROWN^[^YELLOW^" "[" subst
  "^BROWN^<^YELLOW^" "<" subst
  "^BROWN^)^AQUA^" ")" subst
  "^BROWN^]^AQUA^" "]" subst
  "^BROWN^>^AQUA^" ">" subst
;
 
: main ( -- )
  initialize
 
  ( Actions Loop )
  TRIGGER @ "_showactions?" envpropstr swap pop .yes? if
    0 OK !
    "^CYAN^Obvious Actions: ^YELLOW^" TRIGGER @ exits
    begin
      dup #-1 dbcmp not while
      (dup unparseobj "Checking: " swap strcat .ansi_tell)
      0 SHOWIT !
      dup "_action?" getpropstr dup if
        .yes? if
          1 SHOWIT !
        then
      else
        pop
      then
 
      dup "D" flag? not if
        dup getlink dup #-1 dbcmp if
          pop
        else
          program? if
            1 SHOWIT !
          then
        then
      then
 
      dup "_exit?" getpropstr dup if
        .yes? if
          0 SHOWIT !
        then
      else
        pop
      then
 
      SHOWIT @ 1 = if
        dup name ";" explode 1 -
        begin
          dup 0 > while
          rot pop
          1 -
        repeat pop ME @ "C" flag? if parse-action then
        rot swap over over strcat
        ansi_strlen WIDTH @ > if
          swap dup ansi_strlen 1 - ansi_strcut pop .ansi_tell
          "                 ^YELLOW^" swap
        then
        "^AQUA^, ^YELLOW^" strcat strcat swap
        1 OK !
      then
      next
    repeat pop
    OK @ 1 = if
      dup ansi_strlen 2 - ansi_strcut pop .ansi_tell
    else
      pop
    then
  then
 
  ( Exits Loop )
 
  0 OK !
  "^CYAN^Obvious Exits: ^GREEN^" TRIGGER @ exits
  begin
    dup #-1 dbcmp not while
    (dup unparseobj "Checking: " swap strcat .ansi_tell)
    0 SHOWIT !
    dup "_exit?" getpropstr dup if
      .yes? if
        1 SHOWIT !
      then
    else
      pop
    then
 
    dup "D" flag? not if
      dup getlink dup #-1 dbcmp if
        pop
      else
        room? if
          1 SHOWIT !
        then
      then
    then
 
    dup "_showexit?" getpropstr .yes? if
      1 SHOWIT !
    then
    dup "_action?" getpropstr dup if
      .yes? if
        0 SHOWIT !
      then
    else
      pop
    then
 
    SHOWIT @ 1 = if
      dup name ";" explode 1 -
      begin
        dup 0 > while
        rot pop
        1 -
      repeat pop me @ "C" flag? if
        parse-action
      then
      rot swap over over strcat
      ansi_strlen WIDTH @ > if
        swap dup ansi_strlen 1 - ansi_strcut pop .ansi_tell
        "               ^GREEN^" swap
      then
      "^GRAY^,^GREEN^ " strcat strcat swap
      1 OK !
    then
    next
  repeat pop
  UPrivilege? not if
    me @ prog owner dbcmp if
      "^RED^Not registered with $lib/userprop.  Paths not shown." .ansi_tell
    then
  else
    ( paths loop )
(   TRIGGER @ path-list
    begin
      dup while
      "|" .split swap .sps .sts dup TRIGGER @ swap path-match
      dup "/d" strcat TRIGGER @ swap ugetpropstr .yes?
      not if
        "/na" strcat TRIGGER @ swap ugetpropstr dup if
          " ^BROWN^(^YELLOW^" rot dir-prop toupper strcat "^BROWN^)" strcat strcat
        else
          pop
        then
        rot swap over over strcat ansi_strlen WIDTH @ > if
          swap dup ansi_strlen 1 - ansi_strcut pop .ansi_tell
          "               ^AQUA^" swap
        then
        "^GRAY^,^AQUA^ " strcat strcat swap
        1 OK !
      else
        pop pop
      then
    repeat pop )
  then
    
  OK @ 1 = if
    dup ansi_strlen 2 - ansi_strcut pop .ansi_tell
  else
    pop
  then
;
.
c
q