@tel #2150=me
@set #2150=_docs:@list #2150=1-14
@edit #2150
1 1000 del
i
( header, 14 lines -- Super-Indexer.muf, programmed by Jordan Greywolf
Version 2.1 -- Last Updated: 29 Jul 94
This program is meant to be used for a "help" or "news" action, with
online editing to facilitate easy access by the owner.  Just link an
action to this program, and use {action} #help to get more information.
You are welcome to transport this program to your own MUCK, as long as
I am still credited.  This program requires level M3 to function, due to
usage of the "nextprop-rtn" function, if the program owner will always equal
the trigger owner.  Otherwise, if this is meant for general usage, a W
bit will be required, as this program uses protected properties.
:
Uses FB5.31 and supports MPI.  This version also uses the "lmgr" [list
manager] libraries.
)
lvar arg
lvar displayline

$include $lib/lmgr
$include $lib/editor
$include $lib/strings
$def LMGRgetcount lmgr-getcount
$def LMGRgetrange lmgr-getrange
$def LMGRputrange lmgr-putrange
$def LMGRdeleterange lmgr-deleterange

: tell  ( s -- : displays text to user )
  me @ swap notify
;

( special prop string handling routines )

: addprop-rtn ( d s1 s2 i -- )
  rot "/-" "/" subst rot rot addprop
;

: remove_prop-rtn ( d s1 -- )
  "/-" "/" subst remove_prop
;

: getpropstr-rtn ( d s1 -- s2 )
  "/-" "/" subst getpropstr
;

: parseprop-rtn ( d s1 s2 i -- )
  rot "/-" "/" subst rot rot parseprop
;

: nextprop-rtn ( d s1 -- s2 )
  "/-" "/" subst nextprop "/" "/-" subst
;

( end of prop string handling routines )

: LMGRdeletelist
  over over LMGRgetcount
  1 4 rotate 4 rotate LMGRdeleterange
;

: LMGRgetlist
  over over LMGRgetcount
  rot rot 1 rot rot
  LMGRgetrange
;

: lsedit-loop  ( listname dbref {rng} mask currline cmdstr -- )
    EDITORloop
    dup "save" stringcmp not if
        pop pop pop pop
        3 pick 3 + -1 * rotate
        over 3 + -1 * rotate
        dup 5 + pick over 5 + pick
        over over LMGRdeletelist
        1 rot rot LMGRputrange
        4 pick 4 pick LMGRgetlist
        dup 3 + rotate over 3 + rotate
        "< List saved. >" tell
        "" lsedit-loop exit
    then
    dup "abort" stringcmp not if
        "< list not saved. >" tell
        pop pop pop pop pop pop pop pop pop exit
    then
    dup "end" stringcmp not if
        pop pop pop pop pop pop
        dup 3 + rotate over 3 + rotate
        over over LMGRdeletelist
        1 rot rot LMGRputrange
        "< list saved. >" tell exit
    then
;

: lsedit-rtn ( s -- : edits proplist for entry )
  "/-" "/" subst ( insert "buffer" dashes )
  trigger @ ( put trigger dbref under propname on stack )
"<    Welcome to the list editor.  You can get help by entering '.h'     >"
tell
"< '.end' will exit and save the list.  '.abort' will abort any changes. >"
tell
"<    To save changes to the list, and continue editing, use '.save'     >"
tell
    over over LMGRgetlist
    "save" 1 ".i $" lsedit-loop
;

: display-list-rtn ( s -- : shows proplist )
  "/-" "/" subst ( insert dashes for "buffer" )
  ( note: remainder of routine does not use standard getpropstr-rtn,
    due to use of numeric proplists )
  dup "#" strcat trigger @ swap getpropstr atoi
  ( get number of lines in list )
  1 ( counter on stack )
  ( stack: propname[s] numlines[i] counter[i] )
  begin
    over over < if ( exit if counter exceeds maximum number )
      pop pop pop break
    then
    trigger @ 4 pick "#/" strcat 3 pick intostr strcat
    "Super-Indexer.muf" 1 parseprop
    tell
    1 + ( increment counter )
  repeat
;

: display-entry-rtn ( s -- : shows entry or proplist for prop given )
  trigger @ over getpropstr-rtn dup ".l" stringcmp not if ( check for list )
    pop display-list-rtn
  else
    swap pop dup "." stringcmp not over not or if
      "(no text)" tell
    else
      tell
    then
  then
;

: tell-call ( s -- : as tell, but handles program calls )
  dup 1 strcut pop "@" strcmp not if ( check for @, program call )
    1 strcut swap pop ( remove @ )
    dup " " instr dup if ( check for argument/parameters )
      1 - strcut striplead striptail ( split off parameters )
    else
      pop ""             ( or make empty string )
    then
    swap
    dup 1 strcut pop "$" strcmp not if ( check for $, register )
      match ( find registered program )
    else
      atoi dbref ( convert to dbref )
    then
    dup program? not over "l" flag? not or if
      pop me @ swap notify ( just display text )
    else
      call ( call program, passing text as parameter )
    then
  else
    me @ swap notify
  then
;

: first-name ( d -- s : returns first part of dbref name )
  name dup ";" instr dup if
    1 - strcut pop
  else
    pop
  then
;

: lastchar ( s1 -- s2 : returns last character in string )
  dup strlen 1 - strcut swap pop
;

: capitalize ( s1 -- s2 : capitalizes first character of string )
  dup 1 strcut pop "abcdefghijklmnopqrstuvwxyz" swap instring not if
    ( check for non-alphabetical character in first part )
    2 strcut swap toupper swap strcat
  else
    1 strcut swap toupper swap strcat
  then
;

: me-authorized? ( -- 0|1 : checks to see if you can edit entries )
  trigger @ "_sndx/wizedit?" getpropstr 1 strcut pop "y" stringcmp not
  me @ "w" flag? and  ( if wizzes are authorized and you are a wiz ... )
  me @ trigger @ owner dbcmp or if ( ... or if you own the action )
    1
  else
    0
  then
;

: action-name ( -- s : returns action name )
  trigger @ first-name capitalize
;

: display-summary-rtn
  trigger @ "_sndx/summary" getpropstr-rtn ".l" stringcmp not if
    "_sndx/summary" display-entry-rtn
  else
    trigger @ "_sndx/summary" "Super-Indexer.muf" 1 parseprop-rtn
    tell-call
  then
;

: help-screen
  action-name " Help Screen" strcat tell
  "----------------------------------------------------------"
  action-name strlen 12 + strcut pop (trim divider)
  tell
  display-summary-rtn
  "." tell
  "To see a list of topics, type:" tell
  "'" action-name "'" strcat strcat tell
  "To get information on a particular topic, type:" tell
  "'" action-name " {topic}'" strcat strcat tell
  "To read a subtopic entry, use the format of:" tell
  "'" action-name " {topic} {subtopic}'" strcat strcat tell
  "To search the index for a particular subtopic entry, type:" tell
  "'" action-name " #find {subtopic}'" strcat strcat tell
  me-authorized? if
    me @ trigger @ owner dbcmp or if
      "For special editing commands, type:" tell
      "'" action-name " #commands'" strcat strcat tell
    then
  then
;

: commands-screen
  action-name " Commands Screen" strcat tell
  "--------------------------------------------------------------"
  action-name strlen 16 + strcut pop (trim divider)
  tell
  "--- Important:  Make sure all topic names consist of one word." tell
  "Indicating a subtopic is done by indicating the 'tree' of topics" tell
  "involved.  For instance, a 'roleplaying' topic might have a subtopic" tell
  "of 'combat', with a sub-sub-topic of 'melee'.  To make such an" tell
  "entry, you would (presuming the 'roleplaying' and 'combat' topics" tell
  "have already been added first) type:" tell
  action-name " #add roleplaying combat melee" strcat tell
  "--- If you delete a topic, all subtopics under it will be removed as" tell
  "well.  To make a topic category with no text, enter '.' for an empty" tell
  "field.  Any subtopics will still be listed." tell
  "The following commands are available:" tell
  action-name " #help           -- show basic help screen." strcat tell
  action-name " #commands       -- show this screen." strcat tell
  action-name " #wizedit        -- allows all Wizards to edit this setup"
  strcat tell
  action-name " #!wizedit       -- allows only trigger owner to edit setup"
  strcat tell
  action-name " #summary {text} -- sets summary shown on help screen."
  strcat tell
  action-name " #add {topic}    -- add topic {prompt for text}."
  strcat tell
  action-name " #edit {topic}   -- edit topic {prompt for text}."
  strcat tell
  action-name " #delete {topic} -- deletes topic or subtopic entry."
  strcat tell
  action-name " #move {topic}   -- moves entry to new topic {prompted}."
  strcat tell
;

: check-for-command ( s1 -- s2 i : if string is a command line, breaks down
                      command, stores argument in variable 'arg', and returns
                      a 1.  Otherwise, returns string with a 0.)
  striplead striptail
  dup 1 strcut pop "#" strcmp not if ( "#" indicates a command )
    1 strcut swap pop ( dispose of # character )
    dup " " instr dup if ( check for argument, separated by space )
      1 - strcut striplead arg !  ( store as "argument" variable )
    else
      pop
    then
    3 strcut pop ( abbreviate command to 3 characters )
    1 ( "1" indicates command )
  else
    0 ( "0" indicates no command )
  then
;

: set-wizedit-rtn ( : sets the "wizedit?" flag/feature on )
  trigger @ "_sndx/wizedit?" "yes" 1 addprop
  "All Wizards are now authorized to edit this index setup." tell
;

: unset-wizedit-rtn ( : unsets the "wizedit?" flag/feature )
  trigger @ "_sndx/wizedit?" remove_prop
  "Only the trigger/action owner may edit this index setup now." tell
;

: set-summary-rtn ( : sets the "summary" seen on the help screen )
  arg @ dup not if
    pop
    "You must specify the body of the text for the summary." tell
    "Use in the format of:" tell
    "'" action-name " #summary {text}'" strcat strcat tell
    "The current 'summary' setting is:" tell
    trigger @ "_sndx/summary" getpropstr-rtn dup ".l" stringcmp not if
      pop "_sndx/summary" display-list-rtn
    else
      tell
    then
    exit
  then
  dup "." strcmp not if
    pop "" "Summary text erased." tell
  else
    dup ".l" stringcmp if
      "Summary text set to:" tell arg @ tell
    then
  then
  trigger @ "_sndx/summary" rot 1 addprop-rtn
  arg @ ".l" stringcmp not if
    "Entering list editor for summary." tell
    "_sndx/summary" lsedit-rtn exit
  else
    trigger @ "_sndx/summary#" remove_prop-rtn
  then
;

: process-topic-name ( : uses "arg" variable )
  arg @ " " "  " subst (remove multiple spaces) striplead striptail
  "/" " " subst ( replace spaces with slashes )
  "/" "//" subst ( remove double slashes )
  " " strcat " " "# " subst ( replace trailing # with space )
  striptail
  arg !
;

: add-entry-rtn ( : add a new entry.  Variable "arg" holds the topic name. )
  arg @ not if
    "You must specify the name of the topic/subtopic you wish to add." tell
    "For example, to add a topic on 'roleplaying', you would type:" tell
    "'" action-name " #add roleplaying'" strcat strcat tell
    "To add a subtopic for a topic, you type in a line containing the" tell
    "topic first, then the subtopic which you are adding." tell
    "Example:" tell
    "'" action-name " #add roleplaying combat'" strcat strcat tell
    "You may also use this command to rewrite an existing entry." tell
    "Note: slashes ('/') also work as spacers." tell
    exit
  then
  ( first check to see if entry already exists )
  process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn if
    "An entry for '" arg @ "' already exists." strcat strcat tell
    "_sndx/entry/" arg @ strcat display-entry-rtn
    "Operation cancelled." tell exit
  else
    ( check to see if entry is subtopic )
    arg @ "/" instr if
      ( check to make sure "parent" topic{s} exist )
      ( first, remove last item, which is the new entry )
      arg @ dup "/" rinstr 1 - strcut pop
      trigger @ "_sndx/entry/" rot strcat getpropstr-rtn not if
        "The entry for '" arg @ "' cannot be added yet." strcat strcat tell
        "You must first make the 'parent' topics that this is a" tell
        "subtopic of, before this can be added." tell
        exit
      then
    then
  then
  "Entry will be saved as: '" arg @ "'." strcat strcat tell
  "Please enter text for new entry, '.' for blank entry, or '.Q' to quit."
  tell
  "To make entry using list editor (lsedit), type '.L'." tell
  read
  dup 2 strcut pop ".q" stringcmp not if
    "Operation cancelled." tell exit
  then
  trigger @ "_sndx/entry/" arg @ strcat 3 pick 1 addprop-rtn
  dup ".l" stringcmp not if
    "Entering List Editor." tell
    "_sndx/entry/" arg @ strcat lsedit-rtn exit
  else
    "_sndx/entry/" arg @ strcat "#" strcat remove_prop-rtn
  then
  "Entry text saved as:" tell
  dup "." strcmp not if
    pop "{no text}"
  then
  tell
;
: edit-entry-rtn ( : edit an entry.  Variable "arg" holds the topic name. )
  arg @ not if
    "You must specify the name of the topic/subtopic you wish to edit." tell
    "For example, to edit a topic on 'roleplaying', you would type:" tell
    "'" action-name " #add roleplaying'" strcat strcat tell
    exit
  then
  ( first check to make sure entry already exists )
  process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn dup if
    dup ".l" stringcmp not if  ( check for proplist )
      pop "_sndx/entry/" arg @ strcat lsedit-rtn
    else
      "Entry for '" arg @ "':" strcat strcat tell
      tell ( show entry on stack without parsing )
      "Please enter new text for entry, '.' for blank entry, or '.Q' to quit."
      tell
      "To make entry using list editor (lsedit), type '.L'." tell
      read
      dup 2 strcut pop ".q" stringcmp not if
      "Operation cancelled." tell exit
      then
      trigger @ "_sndx/entry/" arg @ strcat 3 pick 1 addprop-rtn
      dup ".l" stringcmp not if
        "Entering List Editor." tell
        "_sndx/entry/" arg @ strcat lsedit-rtn exit
      else
        "_sndx/entry/" arg @ strcat "#" strcat remove_prop-rtn
      then
      "Entry text saved as:" tell
      dup "." strcmp not if
        pop "{no text}"
      then
      tell
    then
  else
    pop "No entry exists for '" arg @ "'." strcat strcat tell
    "Operation cancelled." tell
  then
;

: delete-entry-rtn ( : deletes an entry )
  arg @ not if
    "You must specify the topic or subtopic you wish to delete." tell
    "Example:" tell
    "'" action-name " #delete roleplaying combat'" strcat strcat tell
    exit
  then
  process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn not if
    "No entry for '" arg @ "' currently exists." strcat strcat tell
    exit
  then
  trigger @ "_sndx/entry/" arg @ "/" strcat strcat nextprop-rtn if
    "This entry has subtopics.  Deleting this entry will remove all"
    " subtopic entries as well." strcat tell
  then
  "Entry for '" arg @ "':" strcat strcat tell
  "_sndx/entry/" arg @ strcat display-entry-rtn
  "Do you wish to delete this entry? (Y/N)" tell
  read
  "y" stringcmp if
    "Operation cancelled." tell exit
  then
  trigger @ "_sndx/entry/" arg @ strcat remove_prop-rtn
  trigger @ "_sndx/entry/" arg @ "#" strcat strcat remove_prop-rtn
  "Entry for '" arg @ "' deleted." strcat strcat tell
;

 : move-entry-rtn ( : moves an entry to new topic name )
  arg @ not if
    "You must specify the topic or subtopic you wish to move." tell
    "Example:" tell
    "'" action-name " #move roleplaying combat'" strcat strcat tell
    exit
  then
  process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn not if
    "No entry for '" arg @ "' currently exists." strcat strcat tell
    exit
  then
  trigger @ "_sndx/entry/" arg @ "/" strcat strcat nextprop-rtn if
    "This entry has subtopics.  You cannot move this entry until"
    " all subtopics have been moved or deleted first." strcat tell
    exit
  then
  "Entry for '" arg @ "':" strcat strcat tell
  "_sndx/entry/" arg @ strcat display-entry-rtn
  "Enter full new topic name to move entry text to, or .Q to quit." tell
  read
  dup 2 strcut pop ".q" stringcmp not if
    "Operation cancelled." tell exit
  then
  arg @ swap arg ! process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn if
    "Target entry already exists with text of:" tell
    "_sndx/entry/" arg @ strcat display-entry-rtn
    "Do you wish to replace entry text anyway? (Y/N)" tell
    read
    "y" stringcmp if
      "Operation cancelled." tell exit
    then
  then
  arg @ "/" instr if
    ( check to make sure "parent" topic{s} exist )
    ( first, remove last item, which is the new entry )
    arg @ dup "/" rinstr 1 - strcut pop
    trigger @ "_sndx/entry/" rot strcat getpropstr-rtn not if
      "The entry for '" arg @ "' cannot be added yet." strcat strcat tell
      "You must first make the 'parent' topics that this is a" tell
      "subtopic of, before this can be added." tell
      exit
    then
  then
  trigger @ "_sndx/entry/" 3 pick strcat getpropstr-rtn
  trigger @ "_sndx/entry/" arg @ strcat 3 pick 1 addprop-rtn
  ".l" stringcmp if ( if it's NOT .l, just treat it like normal )
    trigger @ "_sndx/entry/" 3 pick strcat remove_prop-rtn
    trigger @ "_sndx/entry/" rot strcat "#" strcat remove_prop-rtn
  else
    ( otherwise, we've got to move the entire list! )
    ( stack: oldtopic[s]  -- lvar arg: newtopic[s] )
    trigger @ "_sndx/entry/" 3 pick "#" strcat strcat getpropstr-rtn
    ( stack: oldtopic[s] numlines[i] )
    ( copy total counter to new topic position )
    trigger @ "_sndx/entry/" arg @ "#" strcat strcat 3 pick 1 addprop-rtn
    atoi ( convert to integer so we can do a loop )
    1 ( loop counter )
    begin ( stack: oldtopic[s] numlines[i] counter[i] )
      over over < if ( check to see if numlines < counter )
        pop pop break ( remove numlines and counter and exit )
      then
      trigger @ "_sndx/entry/" 5 pick "#" strcat strcat
      "/-" "/" subst ( "buffer" propname )
      "/" strcat 3 pick intostr strcat
      getpropstr ( get old topic line )
      ( stack: oldtopic[s] numlines[i] counter[i] line[s] )
      trigger @ "_sndx/entry/" arg @ "#" strcat strcat
      "/-" "/" subst ( "buffer" propname )
      "/" strcat 4 pick intostr
      strcat rot 1 addprop ( copy to new topic )
      1 + ( increment counter )
    repeat
    trigger @ "_sndx/entry/" 3 pick strcat remove_prop-rtn
    trigger @ "_sndx/entry/" rot strcat "#" strcat remove_prop-rtn
  then
  "Old entry removed, and new one added as '" arg @ "'." strcat strcat tell
;

: get-last-part ( s1 -- s2 : returns last part of property name )
  dup "/" rinstr 1 - strcut swap pop 1 strcut swap pop
;

: search-topic-tree ( s1 -- s1 s2 : returns propname if found )
                    ( recursive tree search )
  trigger @ over "/" strcat
  nextprop-rtn ( find first entry in subtree )
  begin
    dup not if
      break
    then
    dup lastchar "#" strcmp if
      dup get-last-part arg @ instring if ( check for match )
        break
      then
      search-topic-tree
      dup not if
        pop
       else
        swap pop break
      then
    then
    trigger @ swap nextprop-rtn
  repeat
;

: find-topic-entry ( s1 -- 0|1 : returns entry text, stores topic name in
                     lvar "arg" )
  arg !
  process-topic-name
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn not if
    0
  else
    1
  then
;

: empty-line ( erases lvar displayline )
  "" displayline !
;

: print-line ( : displays contents of displayline )
  displayline @ striplead striptail tell
;

: put-on-line ( s -- : adds string to displayline )
  "                  " strcat 19 strcut pop
  " " strcat ( chop at 19, with spacer )
  displayline @ swap strcat dup displayline !
  strlen 79 > if
    print-line empty-line
  then
;

: display-topic-entry ( s -- : shows text for entry, and subtopics )
  arg @ " " "/" subst ( substitute spaces back for slashes )
  toupper
  dup tell
  "--------------------------------------------------------------" swap strlen
  strcut pop tell
  trigger @ "_sndx/entry/" arg @ strcat getpropstr-rtn
  dup ".l" stringcmp not if ( check for list )
    "_sndx/entry/" arg @ strcat display-list-rtn
  else
    trigger @ "_sndx/entry/" arg @ strcat "Super-Indexer.muf" 1 parseprop-rtn
    tell-call ( show entry text )
  then
  trigger @ "_sndx/entry/" arg @ "/" strcat strcat nextprop-rtn dup if
    "SUBTOPICS:" tell
    empty-line
    begin
       dup lastchar "#" strcmp if
         dup get-last-part capitalize put-on-line
       then
       trigger @ swap nextprop-rtn
       dup not if
         break
       then
    repeat
    print-line
  then
;

: find-entry ( : search the topic "tree" for a subtopic name )
  arg @ not if
    "You must specify a name for the particular topic you want to find." tell
    "The purpose of this command is to find an entry that you may know" tell
    "the subtopic name of, but not necessarily the parent topic(s) that" tell
    "it fits under.  This command will execute a search of the 'tree'" tell
    "of possible topics and subtopics and return the first exact match." tell
    exit
  then
  process-topic-name
  "_sndx/entry" ( start with base )
  search-topic-tree swap pop
  dup not if
    pop "No match found." tell
  else
    12 strcut swap pop (trim off "_sndx/entry/") arg ! display-topic-entry
  then
;

: handle-command ( s -- : handles special commands.  Variable "arg"
                   used for optional arguments/parameters for commands. )
  dup 1 strcut pop "h" stringcmp not if
    pop help-screen exit
  then
  dup "fin" stringcmp not if
    pop find-entry exit
  then
  me-authorized? not if   ( check for authorization )
    pop "That command is not available." tell exit
  then
  dup "com" stringcmp not if
    pop commands-screen exit
  then
  dup "wiz" stringcmp not if
    pop set-wizedit-rtn exit
  then
  dup "!wi" stringcmp not if
    pop unset-wizedit-rtn exit
  then
  dup "sum" stringcmp not if
    pop set-summary-rtn exit
  then
  dup "add" stringcmp not if
    pop add-entry-rtn exit
  then
  dup "edi" stringcmp not if
    pop edit-entry-rtn exit
  then
  dup "del" stringcmp not if
    pop delete-entry-rtn exit
  then
  dup "mov" stringcmp not if
    pop move-entry-rtn exit
  then
  pop "That command is not available." tell exit
;

: show-topics ( : shows summary, and topics )
  action-name " Topics" strcat tell
  "--------------------------------------------------------------"
  action-name strlen 7 + strcut pop tell
  display-summary-rtn
  "." tell
  "TOPICS:" tell
  trigger @ "_sndx/entry/" nextprop-rtn dup not if
    "{none currently entered}" tell
  else
    empty-line
    begin
       dup lastchar "#" strcmp if ( skip proplists )
         dup get-last-part capitalize put-on-line
       then
       trigger @ swap nextprop-rtn
       dup not if
         break
       then
    repeat
    print-line
  then
;

: main
  dup not if
    show-topics exit
  then
  check-for-command if
    handle-command exit
  then
  find-topic-entry if
    display-topic-entry
  else
    "No entry for that topic could be found." tell
    "Type '" action-name "' for a list of topics." strcat strcat tell
  then
;
.
compile
quit
