@prog cmd-@quota
1 99999 d
1 i
(  
    cmd-@quota / cmd-@dig / cmd-@action / cmd-@create / cmd-@open

    This file is part of the MUF Globals by, Peter A Torkelson.
    Copyright [C] 1992, 1993, 1994, 1997  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
)

(
Building quota system.

Version 2.1.0, 2/3/97

TO DO:
    BUG: Can specify garbage by #dbref to @open/@action
    BUG: Does not handle @chown
    Functionality of Furry's @quota [ #55920 ]
    @quota #set <player>=<quota>
    @quota #rooms/exits/things <player>=<quota>
    @dig <room>=<parent>,<exit>,<backlink>=<regname>
    _prefs/create-traditional?:yes    
)
( ------------------------------------------------------------------------- )
(
CHANGE HISTORY:

2.1.0   2/3/97
        Added default parent room on trigger as ~default_parent

2.0.1   11/13/94
        GNU Copyleft

2.0.0   1/10/94 
        Combined old create.muf, exit.muf, and dig.muf into one
        program. Added @quota support as well.
        Added support for quota breakdown by type.

)

$include $lib/wfcommand

( ------------------------------------------------------------------------- )
( defines and the like )
$define prog-dbref prog             $enddef
$define tell-me    me @ swap notify $enddef

( If you want a breakdown of each type for quotas, use this: )
( $define QUOTA_BREAKDOWN "true" $enddef )

( If you want wizard to be unrestriced, add this in: )
( $define WIZARDS_NOT_ENFORCED "true" $enddef )

$ifdef __muck=Furry
$define QUOTA_BREAKDOWN "true" $enddef
$define WIZARDS_NOT_ENFORCED "true" $enddef
$endif

$define TYPE_THING  1               $enddef
$define TYPE_EXIT   2               $enddef
$define TYPE_ROOM   3               $enddef

$ifdef QUOTA_BREAKDOWN
$define ROOM_QUOTA  "@quota/rooms"  $enddef
$define EXIT_QUOTA  "@quota/exits"  $enddef
$define THING_QUOTA "@quota/things" $enddef
$else
$define QUOTA_PROP  "~build_limit" $enddef
$endif

( ------------------------------------------------------------------------- )
( variables )
( cmd-name #cmd-command cmd-arg1=cmd-arg2 )
var cmd-name                ( Name of the command we are running.. )
var cmd-command
var cmd-arg1
var cmd-arg2
var cmd-register
var obj                  ( used a lot to store the newly created object. )

( ------------------------------------------------------------------------- )
( ------------------------------------------------------------------------- )
: ok_name?
    dup not                                 if pop 0 exit then
    dup 1 strcut pop "*" stringcmp 0 =      if pop 0 exit then
    dup 1 strcut pop "#" stringcmp 0 =      if pop 0 exit then
    dup "=" instr                           if pop 0 exit then
    dup "&" instr                           if pop 0 exit then
    dup "|" instr                           if pop 0 exit then
    ( Check for ! at the start of each word )
    dup " !" instr                          if pop 0 exit then
    dup 1 strcut pop "!" stringcmp 0 =      if pop 0 exit then
    dup "me" stringcmp 0 =                  if pop 0 exit then
    dup "home" stringcmp 0 =                if pop 0 exit then
    dup "here" stringcmp 0 =                if pop 0 exit then
      
    pop 1 exit
;

(
Quota related functions.
)
var check-type

: get-quota ( player type - amount )
    check-type !

$ifdef QUOTA_BREAKDOWN
    check-type @ TYPE_THING = if THING_QUOTA then
    check-type @ TYPE_EXIT  = if EXIT_QUOTA  then
    check-type @ TYPE_ROOM  = if ROOM_QUOTA  then
$else
    QUOTA_PROP
$endif

    swap over getpropstr dup not
    if
        pop #0 swap getpropstr
    else
        swap pop
    then
    atoi
;

( i1 - number of objects, i2 - type of object )
( 1 - thing, 2 - exit, 3 - room )
: check-quota ( i1 i2 -- i )

    check-type !
    ( STACK: #wanted )

    (
    Wizards get off the hook?
    )
$ifdef WIZARDS_NOT_ENFORCED
    me @ "w" flag? if pop 1 exit then
$endif

    (
    We enforcing this type of quota?
    )
$ifdef QUOTA_BREAKDOWN
    check-type @ TYPE_THING = if "_enforce_things?" then
    check-type @ TYPE_EXIT  = if "_enforce_exits?"  then
    check-type @ TYPE_ROOM  = if "_enforce_rooms?"  then
$else
    "_enforce_quota?"
$endif
    prog swap getpropstr 1 strcut pop "n" stringcmp 0 =
    if
        pop 1 exit ( no enforcement on this, bail )
    then

    (
    Get quota for this type of thing...
    )
    me @ check-type @ get-quota

    ( STACK: #wanted #allowed )

    (
    Now: get how many we have...
    )
    me @ stats pop pop pop 4 rotate pop
    ( rooms exits things )
$ifdef QUOTA_BREAKDOWN
    check-type @ TYPE_THING = if -3 rotate pop pop then
    check-type @ TYPE_EXIT  = if pop swap pop  then
    check-type @ TYPE_ROOM  = if pop pop then
$else
    + + ( rooms + exits + things )
$endif

   ( STACK: #wanted #allowed #have )
   ( [ #have + #wanted ] <= #allowed )
   rot + >= 
;

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

    strip swap strip swap
;

: right-justify ( string length )
    over strlen - 
    dup 0 >
    if
        "                                                                  "
        swap strcut pop swap strcat
    else
        pop
    then
;

( ------------------------------------------------------------------------- )
(                        @OPEN and @ACTION CODE                             )
( ------------------------------------------------------------------------- )
var source
var dest
var backlink

var action      ( Is this @action? Else @open )

$define exitname cmd-arg1     $enddef
$define register cmd-register $enddef

: do-backlink
    
    dest @ owner me @ dbcmp not
    me   @ "W" flag?        not and
    if
        "You may not back-link to that." tell-me
        exit
    then

    me @ pennies 1 < 
    if
        me @ "You don't have enough pennies to back-link." notify
        exit
    then

    backlink @ ok_name? not
    if
        me @ "That's a silly name for a back-link." notify
        exit
    then
    
    dest @ #-1 dbcmp
    if
        me @ "You must specify a destination for use with a back-link." notify
        exit
    then
    
    dest @ room?
    dest @ thing? or
    not
    if
        me @ "Destination for a back-link must be a room or a thing." notify
        exit
    then
    
    dest @ backlink @ newexit obj !
    me @ -1 addpennies
    
    obj @ source @ setlink

    me @ "Backlink created with number #" obj @ int intostr strcat 
         " on object " strcat dest @ unparseobj strcat
         "." strcat notify
;

: cmd-action ( -- )

    ( No #command for @action/open )
    cmd-command @
    if
        "#" cmd-command @ " is an unknown command. See `@" strcat
            cmd-name @ strcat " #help' for help." strcat tell-me
        exit
    then

    cmd-arg2 @ "," split backlink ! cmd-arg2 !

    (
    Are we @action or @open?
    )
    cmd-name @ "action" stringcmp 0 = if 1 else 0 then
    action !

    cmd-arg2 @

    ( 
    Arrange arguments for wichever command we get. 
    )
    action @
    if
        source !
        backlink @ dest ! "" backlink !
    else ( @open )
        dest !
        loc @ source !
    then

    (
    source checks
    ) 
    source @ dbref?
    if
        source @ owner me @ dbcmp not
        me @ "W" flag? not and
        if
            "You may not open an exit here." tell-me
            exit
        then
    else
        source @ 
        if
            source @ match source !
            source @ #-1 dbcmp
            if
                "I can't find that." tell-me
                exit
            then
            source @ #-2 dbcmp
            if
                "I can't tell wich one you mean." tell-me
                exit
            then
            source @ #-3 dbcmp
            source @ exit? or
            source @ program? or
            if
                "You can't attach to that." tell-me
                exit
            then
            
            (now is the object ok?)
            source @ owner me @ dbcmp not
            me @ "W" flag? not and
            if
                "You may not attach to that." tell-me
                exit
            then
        else
            me @ source !
        then    
    then
    
    ( 
    check destination... 
    )
    dest @
    if
        dest @ match dest !
        dest @ #-1 dbcmp
        if
            "I can't find that." tell-me
            exit
        then
        dest @ #-2 dbcmp
        if
            "I can't tell wich one you mean." tell-me
            exit
        then
        dest @ #-3 dbcmp
        if
            "You can't attach to that." tell-me
            exit
        then
    
        dest @ owner me @ dbcmp not
        dest @ "L" flag?        not and
        me   @ "W" flag?        not and
        if
            "You may not link to that." tell-me
            exit
        then
    else
        #-1 dest !
    then    
    
    me @ pennies 1 < 
    if
        me @ "You don't have enough pennies to do that." notify
        exit
    then
    
    ( Check the name )
    exitname @ ok_name? not
    if
        me @ "That's a silly name for an action/exit." notify
        exit
    then
    
    ( Check "~build_limit" here. )
    backlink @ if 2 else 1 then TYPE_EXIT check-quota not
    if
        me @ "You are at or over you limit of objects." notify
        exit
    then
    
    source @ exitname @ newexit obj !
    me @ -1 addpennies
    
    dest @ #-1 dbcmp not
    if
        obj @ dest @ setlink
    then
    
    action @
    if
        me @ "Action created with number #" obj @ int intostr strcat 
             " and attached to " strcat source @ unparseobj strcat
             "." strcat notify
        
        dest @     
        if
             me @ "Action linked to " dest @ unparseobj strcat "."
                  strcat notify
        then
    else
        me @ "Exit created with number #" obj @ int intostr strcat 
             " and linked to " strcat dest @ unparseobj strcat
             "." strcat notify
    then
    
    register @
    if
        me @ "_reg/" register @ strcat obj @ int intostr 0 addprop
        "Registered as $" register @ strcat "." strcat .tell-me
    then

    backlink @
    if
        do-backlink
    then
;

( ------------------------------------------------------------------------- )
(                                 @DIG CODE                                 ) 
( ------------------------------------------------------------------------- )

$define parent   cmd-arg2     $enddef
$define newname  cmd-arg1     $enddef
$define register cmd-register $enddef

: cmd-dig ( -- )

    ( No #command for @dig )
    cmd-command @
    if
        "#" cmd-command @ " is an unknown command. See `@" strcat
            cmd-name @ strcat " #help' for help." strcat tell-me
        exit
    then

    ( Parent room check. ) 
    parent @ 
    if
        parent @
        1 strcut swap "#" stringcmp 0 =
        if
            atoi dbref
        else
            pop parent @ match
        then
 
        dup room? 
        if
            ( The parent must be either link_ok, owned by you, or #0 )
            ( wizards can do anything. )
            dup "L" flag? over "A" flag? or not
            over owner me @ dbcmp not and
            me @ "W" flag? not and
            over #0 dbcmp not and
            if
                pop #-1
            then
        else
            pop #-1
        then
    
        dup #-1 dbcmp
        if
            pop
            me @ "Bad parent room." notify
            exit
        then
        
        parent !
    else
        loc @ #0 dbcmp
        if
            #0
        else
            loc @ location 
            dup "L" flag? over "A" flag? or 
            over owner me @ dbcmp or not
            if
                pop #0
            then
        then        
        parent !
    then    
   
    parent @ #0 dbcmp
(   me @ "W" flag? not and )
    #0 "~default_parent" getprop dbref? and
    if
        #0 "~default_parent" getprop parent !
    then
 
    me @ pennies 10 < 
    if
        me @ "You don't have enough pennies to do that." notify
        exit
    then
    
    ( Check the name )
    newname @ ok_name? not
    if
        me @ "That's a silly name for a room." notify
        exit
    then
    
    ( Check "~build_limit" here. )
    1 TYPE_ROOM check-quota not
    if
        me @ "You are at or over you limit of objects." notify
        exit
    then
    
    parent @ newname @ newroom obj !

    ( Pennies stuff here. )
    me @ -10 addpennies
    
    me @ obj @ name " created with room number #" strcat 
         obj @ int intostr strcat "." strcat notify
    me @ "Parent room set to " obj @ location unparseobj strcat "." strcat
        notify
    
    register @
    if
        me @ "_reg/" register @ strcat obj @ int intostr 0 addprop
        "Registered as $" register @ strcat .tell-me
    then
;

( ------------------------------------------------------------------------- )
(                               @CREATE CODE                                ) 
( ------------------------------------------------------------------------- )

$define cost     cmd-arg2     $enddef
$define newname  cmd-arg1     $enddef
$define register cmd-register $enddef

: cmd-create ( -- )

    ( No #command for @create )
    cmd-command @
    if
        "#" cmd-command @ " is an unknown command. See `@" strcat
            cmd-name @ strcat " #help' for help." strcat tell-me
        exit
    then

    ( Check pennies stuff here. )
    cost @ number?
    if
        cost @ atoi
        dup 10 < if pop 10 then (min cost 10 pennies)
        dup 505 > if pop 505 then (min cost 10 pennies)
        cost !
    else
        10 cost !
    then    
    me @ pennies cost @ < 
    if
        me @ "You don't have enough pennies to do that." notify
        exit
    then
    
    ( Check the name )
    newname @ ok_name? not
    if
        me @ "That's a silly name for a thing." notify
        exit
    then
    
    ( Check "~build_limit" here. )
    1 TYPE_THING check-quota not
    if
        me @ "You are at or over you limit of objects." notify
        exit
    then
    
    me @ newname @ newobject obj !

    ( Pennies stuff here. )
    me @ 0 cost @ - addpennies
    obj @ cost @ 5 / 2 - addpennies
    
    me @ obj @ name " created with number #" strcat obj @ int intostr strcat
         "." strcat notify

    register @
    if
        me @ "_reg/" register @ strcat obj @ int intostr 0 addprop
        "Registered as $" register @ strcat .tell-me
    then
;

( ------------------------------------------------------------------------- )
(                               @QUOTA CODE                                 ) 
( ------------------------------------------------------------------------- )
var s-rooms
var s-exits 
var s-things 
var s-programs
var report-for

: add-quota ( s type -- s )
    report-for @ swap get-quota
    intostr 4 right-justify "  Quota: " swap strcat strcat
;

: cmd-quota
    ( No #command for @create other than #quota )
    cmd-command @
    cmd-command @ "quota" stringcmp 0 = not 
    and
    if
        "#" cmd-command @ " is an unknown command. See `@" strcat
            cmd-name @ strcat " #help' for help." strcat tell-me
        exit
    then

    me @ "w" flag? 
    cmd-arg1 @     and
    if
        cmd-arg1 @ .pmatch dup player?
        if
            report-for !
        else
            "Could not find player " cmd-arg1 @ strcat "." strcat tell-me
            exit
        then
    else
        me @ report-for !
    then

    report-for @ stats ( total rooms exits things programs players garbage )
    pop pop s-programs ! s-things ! s-exits ! s-rooms ! pop

    "Quota Report for: " report-for @ unparseobj strcat tell-me
    "Things...: " s-things   @ intostr 4 right-justify strcat
$ifdef QUOTA_BREAKDOWN
        TYPE_THING add-quota
$endif
        tell-me
    "Rooms....: " s-rooms    @ intostr 4 right-justify strcat
$ifdef QUOTA_BREAKDOWN
        TYPE_ROOM add-quota
$endif
        tell-me
    "Exits....: " s-exits    @ intostr 4 right-justify strcat
$ifdef QUOTA_BREAKDOWN
        TYPE_EXIT add-quota
$endif
        tell-me
    "    Total: " s-things @ s-rooms @ s-exits @ + + intostr 
        4 right-justify strcat
$ifndef QUOTA_BREAKDOWN
        TYPE_THING add-quota
$endif
        tell-me
    "Programs.: " s-programs @ intostr 4 right-justify strcat
        tell-me
;

( ------------------------------------------------------------------------- )
(                    Main / Setup / Dispatch / Help                         )
( ------------------------------------------------------------------------- )

: do-help
    ( Set the name of the command as the default help )
    cmd-arg1 @
    if
        prog cmd-arg1 @ lib-help
    else
        prog cmd-name @ lib-help
    then
;

: do-feep ( -- )
"  Go placidly amid the noise and haste, and remeber what peace there" tell-me
"   may be in silence. As far as possible without surrender be on good" tell-me
"   terms with all persons. Speak your truth quietly and clearly;" tell-me
"   and listen to others, even the dull and ignorant; they to have" tell-me
"   their story." tell-me
"  Avoid loud and aggressive persons, they are vexations to the spirit." tell-me
"   If you compare yourself with others, you may become vain and" tell-me
"   bitter; for alwase there will be greater and lesser persons than" tell-me
"   yourself. Enjoy your achivements as well as your plans." tell-me
"  Keep interested in your own career, however humble; it is a real" tell-me
"   posession in the changing fortunes of time. Exercise caution in" tell-me
"   your business affairs; for the world is full of trickery. But" tell-me
"   let this not blind you to what virtue there is; many persons" tell-me
"   strive for high ideals; and everywhere life is full of heroism." tell-me
"  Be yourself. Especially do not frign affection. Neither be" tell-me
"   cynical about love; for in the face of all aridity and " tell-me
"   disenchantment it is perennial as the grass." tell-me
"  Take kindly the counsel of years, gracefuly surrendering the" tell-me
"   things of youth. Nurture strength of spirit to sheild you in" tell-me
"   sudden misfortune. But do not distress yourself with imaginings." tell-me
"   Many fears are born of fatigue and loneliness. Beyond a " tell-me
"   wholesome discipline, be gentle with yourself." tell-me
"  You are a child of the universe, no less than the trees and the" tell-me
"   stars; you have a right to be here. And whether or not it is" tell-me
"   clear to you, no doubt the universe is unfolding as it should." tell-me
"  Therefore be at peace with God, whatever you concieve him to" tell-me
"   be, and whatever your labors and aspirations, in the noisy " tell-me
"   confusion of life keep peace with your soul." tell-me
"  With all its sham, drudgery and broken dreams, it is still" tell-me
"   a beautiful world. Be careful. Strive to be happy. " tell-me
" " tell-me
" -- Desiderata" tell-me
;

: main 
    ( 
    What command are we? 
    )
    "" cmd-name !
    command @ 2 strcut pop 1 strcut swap pop
    dup "a" stringcmp 0 = if "action" cmd-name ! then
    dup "c" stringcmp 0 = if "create" cmd-name ! then
    dup "d" stringcmp 0 = if "dig"    cmd-name ! then
    dup "o" stringcmp 0 = if "open"   cmd-name ! then
    dup "q" stringcmp 0 = if "quota"  cmd-name ! then
    pop
    cmd-name @ not
    if
        "ERROR: Unknown command alias: " command @ strcat tell-me exit
    then

    (
    parse the command line
    )
    lib-command-parse
    cmd-arg2 ! cmd-arg1 ! cmd-command !
    cmd-arg2 @ "=" split cmd-register ! cmd-arg2 !
    
    cmd-command @ not cmd-arg1 @ not and
    cmd-name @ "quota" stringcmp 0 = not and
    if
        "See @" cmd-name @ strcat " #help for usage." strcat tell-me
        exit
    then

    cmd-command @ "feep"         stringcmp 0 = if do-feep exit then
    cmd-command @ "help"         stringcmp 0 = if do-help exit then
    cmd-command @ "h"            stringcmp 0 = if do-help exit then

    cmd-command @ "quota"        stringcmp 0 = if cmd-quota exit then
    cmd-name    @ "quota"        stringcmp 0 = if cmd-quota exit then

    me @ "B" flag? not
    if
        me @ "That command is restricted to authorized builders." notify
        exit
    then
    cmd-name    @ "action"       stringcmp 0 = if cmd-action exit then
    cmd-name    @ "create"       stringcmp 0 = if cmd-create exit then
    cmd-name    @ "dig"          stringcmp 0 = if cmd-dig exit then
    cmd-name    @ "open"         stringcmp 0 = if cmd-action exit then
;
.
c
q
@register #me cmd-@quota=tmp/prog1
@set $tmp/prog1=L
@set $tmp/prog1=W


