( lib-wfdesc [c] 1991-93 Whitefire Version 2.2.3 ----- Function list: %sub[[,]] %env[[,]] %list[[,]] %hour[[,]] %time[[,]] -- Lynx compatible. %random[[,]] %rand -- Lynx compatible. %clist[[,]] %concat -- Lynx compatible. %from[#,] %; %nl[] -- Lynx compatible. Logic: %if[,[,]] -- Lynx compatible. %pick[,,...] %true[] %false[] %not[] %and[,] %or[,] %xor[,] %strcmp[,] %yes[] -- Lynxism 2.0 %no[] -- Lynxism 2.0 Misc: %wday[[,]] %month[[,]] %date[[,]] -- Lynx compatible. %null %run[#[,]] %awake? %asleep? %strip[] %stripprog[] %[] ----- Props: _desc_search?:yes _proploc_ok?:yes -- Lynxism 2.0 _desc_proploc: _proploc:... ----------------------------------------------------- Changes ----------------------------------------------------- 2.2.3, Fixed a bug with %[c]list not dealing with a non-existant list very well. :] %case[], at Kimi's prodding. 2.2.2, Fixed a bug where lists don't work with _desc_proploc: 2.2.1, Made debuging stuff $ifdefs, saves hugely on instuction counts. Added a number of efficiency feeps brining used CPU time on a test case from 16 seconds to 10. %list and %clist now only search for the first prop, it assumes the rest of the list is on that. 2.2.0, Fixed $ to look first on the trigger object. Fixed cases like %sub[%run[,]] where it would try and take the "%run[" as the %sub[]'s and the "]" as the %sub's arguments. Fixed %time[] and %date[] wich were off by one in their selection. Debug mode added. %[] substitutions added, effectivly maps to: %env[_var/] %pick[,,...] Selects the first non-empty argument. 2.1.0, Added %run, %awake? and %asleep? Made a new entry point into the library. [lib-eval-print] Worked on some compatibility issues with Lynx'es program. Matching now supports * and a regular 'match' call now. Should support most $programs that way too. 2.0.2, %null, turns into litarly nothing. Prefered over %sub[]. 2.0.1, altered pronoun substitutions making %n read the players actual name and %%n read the '%n' prop. 2.0.0, total rewrite and addition of the following functions: %if, %true, %false, %not, %and, %or, %xor, %strcmp, %yes, %no, %wday, %month, %date. ) ( ----------------------------------------------------- $includes ) ( ----------------------------------------------------- Varibles ) lvar cur-obj lvar tmp-dbref lvar tmp-listname lvar tmp-range lvar tmp-value $ifdef DESC-DEBUG lvar debug-mode lvar debug-eval-level $endif $define MAX_EVAL_DEPTH 50 $enddef ( ----------------------------------------------------- ) ( ----------------------------------------------------- Debug utility ) $ifdef DESC-DEBUG : debug-level debug-eval-level @ intostr " - " strcat swap strcat ; $endif ( ----------------------------------------------------- ) ( ----------------------------------------------------- More Misc utility ) : npop ( x1 .. xn n -- ) dup if swap pop 1 - npop else pop then ; ( ------------------------------------------- ) : split ( s s1 -- s s ) over swap instr dup if 1 - strcut 1 strcut swap pop else pop "" then ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- Property code ) lvar got-prop-from : yes-prop? ( d s -- i ) getpropstr 1 strcut pop "y" stringcmp 0 = ; : no-prop? ( d s -- i ) getpropstr 1 strcut pop "n" stringcmp 0 = ; ( Ok to search this object? ) : search-ok? ( d -- i ) dup ok? not if pop 0 exit then trigger @ owner "w" flag? over owner trigger @ owner dbcmp or over owner me @ dbcmp or over "_desc_search?" yes-prop? or over "_proploc_ok?" yes-prop? or swap pop ; ( get a property from the environment, restricted ) : renvprop ( d s -- s ) over ok? not if pop pop "" exit then over over getpropstr dup if swap pop swap got-prop-from ! exit then pop swap location dup search-ok? not if pop pop "" exit then swap renvprop ; : envprop ( d s -- s ) envpropstr swap got-prop-from ! ; ( ----------------------------------------------------- proploc ) lvar obj lvar prop : proploc-loop ( s1 s2 ... sn n -- s ) dup if 1 - swap ( s1 s2 ... sn n s ) ( strip any leading # ) dup 1 strcut swap "#" stringcmp 0 = if swap then pop ( a valid dbref? ) atoi dup if dbref dup ok? if dup owner obj @ owner dbcmp obj @ owner "w" flag? or if dup got-prop-from ! prop @ getpropstr dup if ( s1 s2 .. sn n s ) over 2 + 0 swap - rotate npop exit then then then then pop ( dumby value ) proploc-loop else pop "" exit then ; : proploc ( d p -- s ) prop @ swap prop ! swap obj @ swap obj ! ( first, check obj ) obj @ prop @ getpropstr dup not if pop ( check _proploc ) obj @ "_proploc" getpropstr " " explode proploc-loop else obj @ got-prop-from ! then swap obj ! swap prop ! ; ( ----------------------------------------------------- getprop ) ( Handle _desc_proploc and _proploc ) : getprop ( d s -- s ) over "_desc_proploc" getpropstr dup number? if atoi dbref dup got-prop-from ! over getpropstr dup if swap pop swap pop exit else pop then else pop then over over proploc dup not if pop renvprop else swap pop swap pop then ; : stdprop ( s -- s ) cur-obj @ swap getprop ; : stdxprop ( d s -- s ) over search-ok? if over got-prop-from ! getpropstr else swap pop stdprop then ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- More Misc utility ) ( ----------------------------------------------------- smart pronoun sub ) : pro_sub ( s -- s ) cur-obj @ player? if cur-obj @ else me @ then swap ( %%n -> %n prop. %n -> actual name ) over "%n" getprop dup not if pop over name then "%%n" subst over name "%n" subst over name "%N" subst ( Preserve misc %s. ) "%%" "%" subst "%s" "%%s" subst "%S" "%%S" subst "%o" "%%o" subst "%O" "%%O" subst "%p" "%%p" subst "%P" "%%P" subst "%n" "%%n" subst "%N" "%%N" subst pronoun_sub ; ( ----------------------------------------------------- logic code ) : is-true? ( s -- i ) dup "false" stringcmp 0 = if pop 0 exit then dup "no" stringcmp 0 = if pop 0 exit then not not (str-bool) ; : bool-token ( i -- s ) if "true" else "false" then ; ( ----------------------------------------------------- list-size ) : list-size ( d s -- i ) 1 begin over over intostr strcat 4 pick swap stdxprop while 1 + repeat swap pop swap pop 1 - ; ( ----------------------------------------------------- list-partial-select ) : list-partial-select ( dbref listname value range -- s ) tmp-range ! tmp-value ! tmp-listname ! tmp-dbref ! tmp-value @ begin tmp-dbref @ tmp-listname @ 3 pick intostr strcat stdxprop dup not while pop 1 - dup 0 <= ( wrap around ) if pop tmp-range @ then dup tmp-value @ = ( back where we started, give up ) if "" break then repeat swap pop ; ( ----------------------------------------------------- find-char ) : find-char ( s s -- i s ) 10000 swap ( sf i sc ) begin dup while 1 strcut swap 4 pick swap instr dup not if pop continue then dup 4 pick < ( i-new < i-loc ) if rot pop swap else pop then repeat pop dup 10000 = ( not found ) if pop pop -1 "" else swap over 1 - strcut swap pop 1 strcut pop then ; ( ----------------------------------------------------- call program ) lvar call-return lvar call-program lvar call-arg : call-prog ( d s -- s ) call-arg ! call-program ! call-program @ program? not if "" exit then call-program @ "l" flag? not if "" exit then #-10101 ( pop off to here ) -1 ( put some junk on the stack. ) -1 -1 -1 -1 call-arg @ call-program @ call ( Save return value ) dup string? not if "" then call-return ! ( Cleanup the stack ) begin dup dbref? if #-10101 dbcmp not else pop 1 then while repeat call-return @ ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- break-arg ) lvar plevel : break-arg-match ( s -- i ) "" swap 0 plevel ! ( dst src ) begin dup "[]," find-char dup not ( No match ) if pop pop pop pop 0 exit then dup "," stringcmp 0 = (GOT IT!) plevel @ not and if pop strcut rot rot strcat swap break then dup "[" stringcmp 0 = if (Getting colder) plevel @ 1 + plevel ! then dup "]" stringcmp 0 = (Getting warmer) if plevel @ 1 - plevel ! then ( move characters here ) pop strcut rot rot strcat swap repeat ( figure position here ) ( dst src ) pop strlen ; : break-arg ( s -- s s ) dup break-arg-match dup if 1 - strcut 1 strcut swap pop ( yank "," ) else pop "" then ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- Match ] ) : match-paren ( s -- i ) ( "]" instr ) "" swap 1 plevel ! ( dst src ) begin plevel @ while dup "]" instr dup not if pop 10000 then over "[" instr dup not if pop 10000 then over over <= if ( ] ) pop dup 10000 = ( oops ) if pop pop pop 0 exit then plevel @ 1 - plevel ! else ( [ ) plevel @ 1 + plevel ! swap pop then ( move characters here ) strcut rot rot strcat swap repeat ( figure position here ) ( dst src ) pop strlen ; ( ----------------------------------------------------- Parse command ) $ifdef DESC-DEBUG lvar debug-prefix $endif : 2args ( s -- arg1 arg2 ) break-arg ; : 3args ( s -- arg1 arg2 ) 2args 2args ; : parse-cmd ( src i -- src iarg1 sarg2 ) strcut swap pop ( remove command prefix ) dup match-paren dup not if pop "" swap strcat -1 "" exit then 1 - strcut 1 strcut swap pop swap ( src args ) $ifdef DESC-DEBUG debug-mode @ if debug-prefix @ over strcat "]" strcat debug-level me @ swap notify then $endif ( %command[] ) dup not if (src args) -1 swap exit then ( "," split ) 2args ( %command[]) dup not if pop -1 swap exit then ( %command[] ) ( %command[<#dbref,>] ) over 1 strcut pop "#" stringcmp 0 = if swap (src sarg2 arg1) 1 strcut swap pop ( Pull "#" ) atoi dbref swap exit then ( %command[<*player,>] ) over 1 strcut pop "*" stringcmp 0 = if swap (src sarg2 arg1) 1 strcut swap pop ( Pull "*" ) .pmatch swap exit then ( %command[<$regname,>] ) over 1 strcut pop "$" stringcmp 0 = if swap (src sarg2 arg1) 1 strcut swap pop ( Pull "*" ) "_reg/" swap strcat trigger @ swap envpropstr swap ok? if atoi dbref else pop #-1 then swap exit then ( %command[] ) swap match swap exit ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- Misc eval stuff ) lvar eval-ptr : do-eval eval-ptr @ execute ; : prefix ( s s2 -- i ) dup strlen strncmp 0 = ; : prefix-cmd ( s s2 -- [ s 0 ] [ src iarg1 sarg2 1 ] ) $ifdef DESC-DEBUG dup debug-prefix ! $endif over over prefix if strlen parse-cmd 1 else pop 0 then ; : prefix-scmd ( s s2 -- [ s 0 ] [ src sarg 1 ] ) $ifdef DESC-DEBUG dup debug-prefix ! $endif over over prefix if strlen strcut swap pop ( remove command prefix ) dup match-paren dup not if pop ( dst sa ) "" swap strcat ( dst+err src sarg ) "" 1 exit then 1 - strcut 1 strcut swap pop swap ( src args ) $ifdef DESC-DEBUG debug-mode @ if debug-prefix @ over strcat "]" strcat debug-level me @ swap notify then $endif 1 else pop 0 then ; : ins-characters ( dst src str -- dst src ) rot swap strcat swap ; : pass-characters ( dst src i -- dst src ) strcut rot rot strcat swap ; ( ----------------------------------------------------- ) ( ----------------------------------------------------- Eval %functions ) ( ----------------------------------------------------- %from[] ) : do-from ( dst src iarg1 sarg2 -- dst src ) swap dup search-ok? if cur-obj @ swap cur-obj ! else pop cur-obj @ then swap do-eval swap cur-obj ! (insert into the source so it can get parsed.) ins-characters ; ( ----------------------------------------------------- %list[] ) : do-list ( dst src iarg1 sarg2 -- dst src ) do-eval tmp-listname ! tmp-dbref ! ( Initialize got-prop-from ) tmp-dbref @ tmp-listname @ "1" strcat stdxprop not if exit then "" 1 ( s i ) begin tmp-listname @ over intostr strcat got-prop-from @ swap getpropstr dup while ( s i s ) over 1 = not if "%;" swap strcat then rot swap strcat swap 1 + repeat pop pop swap strcat ; ( ----------------------------------------------------- %clist[] ) : do-clist ( dst src iarg1 sarg2 -- dst src ) do-eval tmp-listname ! tmp-dbref ! ( Initialize got-prop-from ) tmp-dbref @ tmp-listname @ "1" strcat stdxprop not if exit then "" 1 ( s i ) begin tmp-listname @ over intostr strcat got-prop-from @ swap getpropstr dup while ( s i s ) strip over 1 = not if " " swap strcat then rot swap strcat swap 1 + repeat pop pop swap strcat ; ( ----------------------------------------------------- %sub[] ) : do-sub ( dst src iarg1 sarg2 -- dst src ) do-eval dup not if pop pop exit then swap dup search-ok? not if (Default) pop stdprop else (From ) swap getpropstr then (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %env[] ) : do-env ( dst src iarg1 sarg2 -- dst src ) do-eval dup not if pop pop exit then swap dup search-ok? not if pop cur-obj @ then swap envprop (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %rand[] ) : do-rand ( dst src iarg1 sarg2 -- dst src ) do-eval over over list-size random swap % 1 + intostr strcat stdxprop (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %time[] ) : do-time ( dst src iarg1 sarg2 -- dst src ) do-eval over over list-size time rot pop 60 * + (get number of minutes into day) swap ( s im il ) 1440 (minutes in day) swap / (size of time slice) / (wich slice) 1 + intostr strcat stdxprop (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %date[] ) : do-date ( dst src iarg1 sarg2 -- dst src ) do-eval over over list-size systime timesplit -8 rotate 7 npop ( Get number of days into year ) swap ( listname days listsize ) ( days / [ 366 / listsize] -- the actual formula not in RPN. :) 366 ( days in year ) swap / (size of time slice) / (wich slice) 1 + intostr strcat stdxprop (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %hour[] ) : hour ( -- i[1-24] ) "_desc_hour" stdprop dup number? if atoi exit else pop time rot rot pop pop then dup not if pop 24 then ( 0 -> 24 ) ; : do-hour ( dst src iarg1 sarg2 -- dst src ) do-eval hour 24 list-partial-select (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %wday[] ) : do-wday ( dst src iarg1 sarg2 -- dst src ) do-eval systime timesplit pop -7 rotate 6 npop 7 list-partial-select (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %month[] ) : do-month ( dst src iarg1 sarg2 -- dst src ) do-eval systime timesplit 4 pick -9 rotate 8 npop 12 list-partial-select (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %true[] ) : do-true ( dst src sarg -- dst src ) do-eval is-true? bool-token swap strcat ; ( ----------------------------------------------------- %false[] ) : do-false ( dst src sarg -- dst src ) do-eval is-true? not bool-token swap strcat ; ( ----------------------------------------------------- %or[] ) : do-or ( dst src sarg -- dst src ) 2args do-eval swap do-eval swap is-true? swap is-true? or bool-token swap strcat ; ( ----------------------------------------------------- %and[] ) : do-and ( dst src sarg -- dst src ) 2args do-eval swap do-eval swap is-true? swap is-true? and bool-token swap strcat ; ( ----------------------------------------------------- %xor[] ) : do-xor ( dst src sarg -- dst src ) 2args do-eval swap do-eval swap is-true? swap is-true? bitxor bool-token swap strcat ; ( ----------------------------------------------------- %strcmp[] ) : do-strcmp ( dst src sarg -- dst src ) 2args do-eval swap do-eval swap stringcmp 0 = bool-token swap strcat ; ( ----------------------------------------------------- %if[] ) : do-if ( dst src sarg -- dst src ) 3args rot do-eval is-true? not if swap then pop do-eval swap strcat ; ( ----------------------------------------------------- %yes[] ) : do-yes ( dst src sarg -- dst src ) do-eval tolower "yes" swap prefix bool-token swap strcat ; ( ----------------------------------------------------- %no[] ) : do-no ( dst src sarg -- dst src ) do-eval tolower "no" swap prefix bool-token swap strcat ; ( ----------------------------------------------------- %run[] ) : do-run ( dst src iarg1 sarg2 -- dst src ) do-eval call-prog (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %strip[] ) : do-strip ( dst src sarg -- dst src ) do-eval strip ins-characters ; ( ----------------------------------------------------- %stripprog[] ) : do-stripprog ( dst src sarg -- dst src ) do-eval dup 1 strcut pop "@" stringcmp 0 = if " " split swap pop then ins-characters ; ( ----------------------------------------------------- %[] ) : do-var ( dst src sarg -- dst src ) do-eval dup if "_var/" swap strcat trigger @ swap envpropstr swap pop then (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %pick[] ) : do-pick ( dst src sarg -- dst src ) BEGIN dup WHILE 2args swap do-eval dup is-true? if swap pop break else pop then REPEAT (insert into the source so it can get parsed.) swap strcat ; ( ----------------------------------------------------- %case[] ) : do-case ( dst src sarg -- dst src ) ( Get 'key' value ) "," split swap do-eval swap ( key argstr ) BEGIN dup WHILE "," split swap ":" split swap ( key argstr text value ) ( value == key || "default" || "def" ) 4 pick over stringcmp 0 = over "default" stringcmp 0 = or over "def" stringcmp 0 = or if pop ( value ) swap pop ( argstr ) swap pop ( key ) swap strcat ( add to input stream ) exit then ( Prepare for next step ) pop pop REPEAT pop pop ; ( ----------------------------------------------------- Main loop and such ) lvar eval-depth : eval-loop ( s -- s ) eval-depth @ 1 + dup eval-depth ! MAX_EVAL_DEPTH > if pop "" exit then dup "%" instr not if exit then $ifdef DESC-DEBUG debug-mode @ if debug-eval-level @ 1 + debug-eval-level ! "Eval enter {" over strcat "}" strcat debug-level me @ swap notify then $endif "" swap ( Stack: dest src ) BEGIN dup "%" instr dup WHILE ( Move everying up to the next % into the destination ) 1 - pass-characters ( Do we have a statment? ) ( Substitutions: ) "%sub[" prefix-cmd if do-sub continue then "%env[" prefix-cmd if do-env continue then "%[" prefix-scmd if do-var continue then (List functions: ) "%list[" prefix-cmd if do-list continue then "%clist[" prefix-cmd if do-clist continue then "%concat[" prefix-cmd if do-clist continue then "%rand[" prefix-cmd if do-rand continue then "%time[" prefix-cmd if do-time continue then "%date[" prefix-cmd if do-date continue then "%random[" prefix-cmd if do-rand continue then "%hour[" prefix-cmd if do-hour continue then "%wday[" prefix-cmd if do-wday continue then "%month[" prefix-cmd if do-month continue then (Misc functions: ) "%from[" prefix-cmd if do-from continue then "%run[" prefix-cmd if do-run continue then "%strip[" prefix-scmd if do-strip continue then "%stripprog[" prefix-scmd if do-stripprog continue then (Logic functions: ) "%true[" prefix-scmd if do-true continue then "%false[" prefix-scmd if do-false continue then "%not[" prefix-scmd if do-false continue then "%and[" prefix-scmd if do-and continue then "%xor[" prefix-scmd if do-xor continue then "%or[" prefix-scmd if do-or continue then "%strcmp[" prefix-scmd if do-strcmp continue then "%if[" prefix-scmd if do-if continue then "%yes[" prefix-scmd if do-yes continue then "%no[" prefix-scmd if do-no continue then "%pick[" prefix-scmd if do-pick continue then "%case[" prefix-scmd if do-case continue then ( else pass the % along and try again ) 1 pass-characters REPEAT pop strcat dup "%" instr not if exit then ( no more functions left, do direct substitutions ) "%;" "%nl[]" subst ( fer lynx. :) "" "%null" subst trigger @ owner awake? if "awake" "%awake?" subst "" "%asleep?" subst else "" "%awake?" subst "asleep" "%asleep?" subst then $ifdef DESC-DEBUG debug-mode @ if "Eval exit {" over strcat "}" strcat debug-level me @ swap notify debug-eval-level @ 1 - debug-eval-level ! then $endif ; : lib-eval 'eval-loop eval-ptr ! trigger @ cur-obj ! $ifdef DESC-DEBUG trigger @ "_desc_debug?" yes-prop? debug-mode ! 0 debug-eval-level ! $endif 0 eval-depth ! eval-loop pro_sub ; ( -------------------------------------------------------------------------- ) ( -------------------------------------------------------------------------- ) ( print.muf - 1991 Whitefire Version 1.0.0 A PRISM MUF Group program. To do: Support printing to a room. ) : print-loop ( s .. s i -- ) dup if swap me @ swap notify 1 - print-loop else pop exit then ; : lib-print ( d s -- ) "%;" explode print-loop pop ; : lib-eval-print lib-eval me @ swap lib-print ; ( -------------------------------------------------------------------------- ) ( -------------------------------------------------------------------------- ) ( notify.muf - 1991 Whitefire Version 1.0.0 A PRISM MUF Group program. ) ( ------------------------------------- do-subst ) : do-subst ( d1 s -- s ) over "%n" proploc dup not if pop over name then "%%n" subst over name "%n" subst over name "%N" subst over swap pronoun_sub swap pop ; ( ------------------------------------- tell ) : tell ( d1 d2 s -- ) 3 pick swap do-subst notify pop ; ( ------------------------------------- ) : look-notify lib-eval "%%;" "%;" subst trigger @ owner swap do-subst me @ swap lib-print trigger @ "_desc_notify_looked" proploc dup if me @ trigger @ owner rot tell me @ "_desc_notify_looker" proploc dup if trigger @ owner me @ rot tell else pop then else pop then ; ( -------------------------------------------------------------------------- ) ( -------------------------------------------------------------------------- ) ( default function is look-notify ) PUBLIC look-notify ( s -- ) PUBLIC lib-print ( d s -- ) PUBLIC lib-eval ( s -- s ) PUBLIC lib-eval-print ( s -- )