@prog cmd-@rp
1 99999 d
1 i
(  
    cmd-@rp version 1.0.2

    This file is part of the MUF Globals by, Peter A Torkelson.
    Copyright [C] 1992, 1993, 1994  Peter Torkelson.
 
    This 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.
 
    This software is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
 
    You should have received a copy of the GNU General Public License
    along with this software; see the file COPYING.  If not, write to
    the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
    You may contact the author by:
       e-mail:  wfire@tcp.com
)
(

Input format:

    <prop>:<value>	    Sets value of a prop.
    
    :object <reg-name>      Changes object writing to.
    
    : <comment>
    
    :list <listname>	    Following values into props listname1 .. listnameN
    <list lines> ...
    :listend

    :if <prop>:<val>        If this prop has this value, do this.
    :else                   otherwise, do this.
    :endif

Todo:
    :concat <propname>      Take a few lines and concat them into one prop.
    <lines> ...
    :propend

    :listformat old|new     Either output in the system std [new] list
                            format, or in the old list format.
    #help

Command line:
    
    rp <object>
    rp #help
    rp #dump <object>
    
)
( ------------------------------------------------------------------------- )
(
CHANGE HISTORY:
    1.0.2    11/13/94     Added Copyleft
    1.0.1    11/3/93      Added if/then/else construct
)
( ------------------------------------------------------------------------- )
var     cur-obj
var     cur-list
var     cur-list-pos

( ------------------------------------------------------------------------- )
: sls
    dup not
    if
        exit 
    then
    
    1 strcut
    swap

    dup " " stringcmp not 
    if
        pop 
        sls
    else  
        swap
        strcat 
        exit 
    then
;

: sts
    dup not     
    if 
        exit
    then
    
    dup strlen 1 - strcut

    dup " " stringcmp not 
    if
        pop 
        sts
    else  
        strcat 
    then
;

: strip-all sls sts ;

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

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

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

: prefix-cmd ( s1 s2 -- [ 0 ] [ str 1 ] )
    over over prefix
    if
        strlen strcut swap pop
        1
    else
        pop pop
        0
    then
;

: write-msg ( -- )
    "Writing to "
    cur-obj @ name strcat "(#" strcat cur-obj @ int intostr strcat ")." strcat 
    tell-me
;

: write-list-msg ( -- )
    "Writing to list " cur-list @ strcat " on " strcat
    cur-obj @ name strcat "(#" strcat cur-obj @ int intostr strcat ")." strcat 
    tell-me
;

( ------------------------------------------------------------------------- )
: do-list-add-loop
    (begin)
        read
        dup  strip ":listend" stringcmp 0 = not
        over strip ":endlist" stringcmp 0 = not and
        (while)
        not if exit then
        
        cur-obj @ swap 
        
        cur-list @ cur-list-pos @ intostr strcat 
        swap 
    
        0 addprop
        
        ( inc )
        cur-list-pos @ 1 + cur-list-pos !
    (repeat)
    do-list-add-loop
;

: do-list-del-loop
    (begin)
        cur-obj @ cur-list @ cur-list-pos @ intostr strcat getpropstr
        (while)
        not if exit then
    
        ( delete line )
        cur-obj @ cur-list @ cur-list-pos @ intostr strcat remove_prop
        
        ( inc )
        cur-list-pos @ 1 + cur-list-pos !
    (repeat)
    do-list-del-loop
;

: do-list ( listname -- i )
    strip-all cur-list !
    1 cur-list-pos !
    
    write-list-msg
    
    do-list-add-loop
    pop 
    
    ( Erase any remaining text )
    do-list-del-loop
    
    1
;

: do-object ( objectname -- i )
    strip-all 
    
    dup match
    dup #-1 dbcmp if 
        pop "I can't find object " swap strcat "." strcat tell-me 0 exit then
    dup #-2 dbcmp if 
        pop "Don't know which "    swap strcat "." strcat tell-me 0 exit then
    dup #-3 dbcmp if 
        pop pop "Can't write to 'home'." tell-me 0 exit then
  
    swap pop
    dup owner me @ dbcmp not
    if
        name "Can't write to: " swap strcat tell-me 0 exit
    then
    
    cur-obj !
    
    write-msg
    1
;

: do-prop ( s -- i )
    ":" split 
    
    ( No prop name, dump as comment )
    swap strip-all swap
    over not
    if
        pop pop
        1
        exit
    then
    
    ( if value create prop, else kill prop )
    dup
    if      (Addprop)
        cur-obj @ -3 rotate
        0 addprop
    else    (removeprop)
        pop cur-obj @ swap remove_prop
    then
    
    1
;

( 0: none, 1: doing IF/else, 2: skipping IF/else )
var if-mode

: do-if ( s -- 1 )
    strip

    ( split the arg )
    ":" split strip

    over over swap "If <" swap strcat "> : <" strcat swap strcat ">." strcat
        tell-me
    
    ( get the prop, compare it )
    swap strip cur-obj @ swap getpropstr
    stringcmp 0 =
    if 1 else 2 then
    if-mode !
    1
;

: do-command ( s -- i )
    dup ":" prefix
    if
        dup ": "        prefix-cmd  if pop pop 1                 exit then

        if-mode @
        if
            dup ":else" prefix-cmd  
            if
                pop pop
                if-mode @ 1 = if 2 else 1 then if-mode !
                1 exit
            then
            dup ":endif" prefix-cmd
            if
                pop pop
                0 if-mode !
                1 exit
            then
        then

        if-mode @ 2 = not
        if
            dup ":quit"     prefix-cmd  if pop pop 0                 exit then
            dup ":list "    prefix-cmd  if do-list          swap pop exit then
            dup ":object "  prefix-cmd  if do-object        swap pop exit then
            dup ":if "      prefix-cmd  if do-if            swap pop exit then
        then
        
        "Bad input line: " swap strcat tell-me
        0
    else
        if-mode @ 2 = not 
        if
            do-prop
        then
    then
;

: main-loop
    (begin)
        read
    
        do-command
        if main-loop then
    (until)
;

: main ( s -- )
    
    ( setup )
    pop
    me @ cur-obj !

    0 if-mode !
    
    write-msg
    
    ( run )
    main-loop
    
    "Done." tell-me
;

.
c
q
@register #me cmd-@rp=tmp/prog1
@set $tmp/prog1=L
@set $tmp/prog1=2


