@program intercom.muf 1 9999 d i ( intercom.muf version 1.0 by Wog Yet another intercom program! SETUP - [just an example. You can replace intercom, or int anywhere in this help header, if you please.] @action intercom; int=#0 @link intercom= @set intercom=_name:intercom * And optionally, if the $def below don't work for you * @set intercom=_prefix:~&110<~&170intercom~&110> ~&R [ Admitingly the quoting style for the above is inspired by Wolf's staffchat.muf ] ADMIN OPTIONS - int #default Makes the channel by 'on' or 'off' by default. `on' requires wizbit. int #default joined Makes the channel by 'joined' by default. int #default unjoined Does the opposite of above...; Keeps '#on' people. int #add Adds to channel... Will revert an 'int #ban'. int #remove Removes from channel... int #ban Same as above, except the only command that will work in default '#default joined' mode... int #for ={on|off} Turns channel on or off for CALLABLE INTERFACE - Use with #xxxx "function" call where #xxxx is the dbref of this program. --- Change History ---------------------------------- v 1.0a Jul 14 2000 Development Started v 1.0b Oct 18 2000 Most bug-fixes done. v 1.0c Mar 20 2001 Fixed bug with :[char] posing, and handling Warwick's say stuff. v 1.1 Apr 12 2001 Allow EXTENDED_ANSI mode for FB6 that uses $lib/ansi to add color to user messages, but uses TEXTATTR and friends otherwise. --- Distrubution Information ------------------------ Copyright {C} Charles "Wog" Reiss 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 of the License, or {at your option} any later version. This program 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. For a copy of the GPL: a> see: http://www.gnu.org/copyleft/gpl.html b> write to: the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA ) ( -- User-settable $defines -- ) (If $def'd require that the trigger action for this program to be located on a wiz-owned room...) $undef WIZ_TRIGGER_RESTRICT $def OWN_REFLIST ( use our own reflist stuffs... This will avoid any reflist size maximum problems. ) (Do we want color?) $undef USE_COLOR ( -- This is in the colorless version -- ) (Do we have FuzzBall version 6?) $undef __FB6 (Allow for "extended" ANSI -- using $lib/ansi under FB6. ) $undef EXTENDED_ANSI $define CLEAN_INTERVAL 86400 ( seconds = 1 day ) ( delay between ``cleanings'' of the reflist. ) ( This is too remove @toad'd players, and will be run after the command is run normally at this interval. ) $enddef ( Okay, we have three settable message formats: ) ( errors, messages [from commands], and broadcasts [anything on channel], and usage messages. [wrong syntax] ) ( Errors and messages are sent like : If you don't like that you can change it below, if you know what you're doing. ) ( usage messages are like: Usage: ) $ifdef USE_COLOR ( If we're using color, these are important: ) ( FOR FUZZBALL 6 ONLY: ) ( If you're setting up for tidle-ansi color, you minus well skip down past this section for the tidle-ansi section. ) $ifdef __FB6 ( FUZZBALL 6 colors... ) ( Colors are a textattr-compatible color. See 'man textattr' or 'mpi attr' for docs on their specification. ) ( > For errors {not fatal things, but like permission denied, etc.}: ) ( color of channel name in error message: ) $def ERROR_CNAME_COLOR "bold,white" ( bold white ) ( color of message in error: ) $def ERROR_MESG_COLOR "bold,red" ( bold red ) ( > For messages [from program commands; not others on channel]: ) ( Channel name in message:) $def MESG_CNAME_COLOR "bold,white" ( Content:) $def MESG_MESG_COLOR "bold,green" ( > Usage messages: ) ( Color of the Usage: in usage telling messages ) $def USAGE_COLOR "bold,magenta" ( bold magenta ) ( Of the content of the Usage:... output ) $def USAGE_MESG_COLOR "bold,yellow" ( bold yellow ) ( Or: in some usage messages: ) $def OR_USAGE_COLOR "bold,cyan" ( bold cyan ) ( > As a bonus of #who colors: ) $def WHO_LABEL_COLOR "bold,white" ( bold white ) $def WHO_NAMES_COLOR "reset,white" ( normal ) ( > Help colors: ) $def HELP_INFO "bold,cyan" $def HELP_LINE "bold,black" $def HELP_SEC "bold,magenta" $def HELP_CMD "bold,white" $def HELP_INFO "reset,white" $def HELP_MODE "bold,blue" $def HELP_HEAD "bold,green" ( For program use only; freely ignore.) $def color-add textattr ( End of that. ) ( > For messages displayed on channel: ) ( Prefix to use on them: ) ( This is overridable by a property; and is hard to set w/out muf knowledge, I know. ) $define PREFIX "<" "bold,red" textattr channel-name "bold,white" textattr "> " "bold,red" textattr strcat strcat $enddef (That's, bold red '<', followed by bright white channel name, followed by bold red '>' followed by a space, followed by a return to normal color. ) (Now, if you are using Fuzzball-6 colors you can just skip past this stuff...) $else ( FOR TIDLE ANSI / NOT FUZZBALL-6: ) ( Codes here are the standard ~& format. ) ( > For errors {like ``premission denied''; etc.} ) ( color of channel name on program errors [w/commands]) $def ERROR_CNAME_COLOR "~&170" ( bold white ) ( color of message in error ) $def ERROR_MESG_COLOR "~&110" ( bold red ) ( > For messages of the program {not channel messages}: ) ( channel name: ) $def MESG_CNAME_COLOR "~&170" ( bold white ) (actaul content: ) $def MESG_MESG_COLOR "~&120" ( bold green ) ( > Usage messages: ) ( Color of the Usage: ) $def USAGE_COLOR "~&150" ( bold magenta ) ( Color of the usage message: ) $def USAGE_MESG_COLOR "~&130" ( bold yellow ) ( Color of `Or:' in some usage messages: ) $def OR_USAGE_COLOR "~&150" ( bold magenta ) ( > #who colors: ) ( The ``People listening to this channel:'' string ) $def WHO_LABEL_COLOR "~&170" ( bold white ) ( The actaul names ) $def WHO_NAMES_COLOR "~&070" ( normal ) ( > For help colors, now: ) $def HELP_INFO "~&160" $def HELP_LINE "~&100" $def HELP_SEC "~&150" $def HELP_CMD "~&170" $def HELP_INFO "~&070" $def HELP_MODE "~&140" $def HELP_HEAD "~&120" ( > For messages on channel: ) (The prefix, overridable by a property. Yes it's a bit hard to set. ) $def PREFIX "~&110<~&170" channel-name "~&110> ~&R" strcat strcat (That's, bold red '<', followed by bright white channel name, followed by bold red '>' followed by a space, followed by a return to normal color. ) ( For program use only: ) $def color-add swap strcat ( End of that. ) $endif $else (Without color we still need prefix) ( FOR NON-COLOR ONLY: ) ( > For messages on the channel; the prefix, overridable by a property: ) ( [Yeah, it's not that easy to set w/out MUF knowledge] ) $def PREFIX "<" channel-name "> " strcat strcat ( " " ) $endif ( End of that part... ) ( -- Property $defs -- ) (These control the name of various properties on the trigger. ) $def in_list_prop "~list/in" $def banned_list_prop "~list/banned" $def joined_list_prop "~list/joined" $def off_list_prop "~list/off" ( Which is used depends on the ~default_on? setting... ) $def on_list_prop "~list/on" $def out_list_prop "~list/out" ( Same theory as above... ) $def default_on_prop "~default_on?" $def default_joined_prop "~default_joined?" $def admin_list "~admin" $def cname_prop "_name" $def prefix_prop "_prefix" (That's what the prefix is overriden with. ) $def clean_timestamp "~lastclean" (Periodically the reflists are ``cleaned'' for non-player dbrefs. This holds the timestamp of the last clean for use in determining the time of the next cleaning.) ( -- Help macros for color -- ) $ifdef USE_COLOR (only for color) $def c_head HELP_HEAD color-add $def c_line HELP_LINE color-add $def c_sec HELP_SEC color-add $def c_cmd HELP_CMD color-add $def c_info HELP_INFO color-add $def c_mode HELP_MODE color-add $else $define __nothing__ ( * do nothing * ) $enddef $def c_head __nothing__ $def c_line __nothing__ $def c_sec __nothing__ $def c_cmd __nothing__ $def c_norm __nothing__ $def c_mode __nothing__ $def c_info __nothing__ $endif ( -- $includes -- ) ( Library stuffs... ) $include $lib/case $ifndef OWN_REFLIST $include $lib/reflist ( we use reflists in the ...list_prop props. ) $endif $include $lib/look ( for short-list ) ( Stuff for color support. ) $ifdef USE_COLOR $ifndef __fb6 $ifdef __glowver $def __glowstyle__ $endif $ifdef __noen $def __glowstyle__ $endif $ifdef __smms $def __glowstyle__ $endif $ifndef __glowstyle__ $include $lib/ansi $def .tell me @ swap "~&R" strcat ansi_notify $else $def .tell me @ swap ansi_notify $endif $def notify ansi_notify $else $ifdef EXTENDED_ANSI $include $lib/ansi ( for ANSIFY_STRING ) $endif $def .tell me @ swap notify $endif $endif ( -- Some other program-wide $defs -- ) $ifdef USE_COLOR ( Error message teller: ) $define .etell channel-name ": " strcat ERROR_CNAME_COLOR color-add swap ERROR_MESG_COLOR color-add strcat .tell $enddef ( Regular message teller:) $define .mtell channel-name ": " strcat MESG_CNAME_COLOR color-add swap MESG_MESG_COLOR color-add strcat .tell $enddef $define .utell "Usage: " USAGE_COLOR color-add rot USAGE_MESG_COLOR color-add strcat .tell $enddef $define .orutell " Or: " OR_USAGE_COLOR color-add swap USAGE_MESG_COLOR color-add strcat .tell $enddef $else $define .etell channel-name ": " strcat swap strcat .tell $enddef $define .mtell channel-name ": " strcat swap strcat .tell $enddef $define .utell "Usage: " swap strcat .tell $enddef $define .orutell " Or: " swap strcat .tell $enddef $endif $ifdef OWN_REFLIST ( ref keeping stuffs... ) ( METHOD: listname/xxxx: yyy zzz .. where xxxx = db / 1000; yyy, etc. = db % 1000 ) : ptostr ( i -- "xxxx" ) dup intostr swap dup 10 < if pop "000" swap strcat else dup 100 < if pop "00" swap strcat else 1000 < if "0" swap strcat then then then ; : dtostr ( i -- "xxx" ) dup intostr swap dup 10 < if pop "00" swap strcat else 100 < if "0" swap strcat then then ; : REF-inlist? ( d s d -- i ) int dup 1000 / swap 1000 % ( d s i/ i% ) -4 rotate ptostr "/" swap strcat strcat ( i% d s' ) getpropstr dup not if pop pop 0 exit then ( i% s' ) swap dtostr instr ; : REF-add ( d s d -- ) int dup 1000 / swap 1000 % dtostr ( d s i/ s% ) -4 rotate ( s% d s i/ ) ptostr "/" swap strcat strcat ( s% d s' ) over over getpropstr ( s% d s' s/prop/ ) dup 5 pick instr if (Already there, no problem.) ( s% d s' s/prop/ ) pop pop pop pop else (Otherwise add it. ) ( s% d s' s/prop/ ) 4 rotate " " strcat strcat setprop then ; : REF-delete ( d s d -- ) int dup 1000 / swap 1000 % dtostr ( d s i/ s% ) -4 rotate ( s% d s i/ ) -3 rotate ( s% i/ d s ) "/" strcat rot ptostr strcat ( s% d s' ) over over getpropstr ( s% d s' s/prop/) dup 5 rotate instr dup not if ( d s' s/prop/ i ; not in list string ) pop pop pop pop else 1 - strcut 4 strcut swap pop strcat ( d s' s/prop/' ) dup not if pop 0 then setprop then ; : REF-first ( d s -- d ) over swap "/" strcat nextprop dup not if ( d s' ) pop pop #-1 else swap over getpropstr ( s' "xxx "... ) 3 strcut pop atoi swap dup ( i s' s' ) "/" rinstr strcut swap pop atoi 1000 * ( i i' ) + dbref then ; : REF-next ( d s d -- d' ) int dup 1000 / swap 1000 % ( d s i/ i% ) -4 rotate ( i% d s i/ ) dup -5 rotate ( i/ i% d s i/ ) ptostr ( i/ i% d s s/ ) 3 pick 3 pick ( i/ i% d s s/ d s ) "/" strcat rot strcat getpropstr ( i/ i% d s s/prop/ ) dup 5 rotate dtostr ( i/ d s s/prop/ s/prop/ s/i%/ ) instr dup not if ( i/ d s s/prop/ i' ) pop pop pop pop pop #-1 exit then 3 + strcut swap pop 3 strcut pop dup if atoi ( i/ d s i%' ) 4 rotate 1000 * + dbref ( d s d' ) rot rot pop pop exit else ( i/ d s "" ) pop rot ptostr "/" swap strcat strcat ( d s' ) over swap nextprop dup not if pop pop #-1 exit then ( d s'' ) swap over getpropstr 3 strcut pop dup not if pop pop #-1 exit then atoi ( s'' s ) swap dup "/" rinstr strcut swap pop atoi 1000 * ( i% i/x10^4 ) + dbref then ; $endif : channel-name ( -- s ) trigger @ cname_prop getpropstr dup not if pop trigger @ name dup ";" instr dup if 1 - strcut pop else pop then then ; : get-prefix ( -- ) trigger @ prefix_prop getpropstr dup if exit then pop prefix ; : purify-one ( d1 .. dn n t i -- d1 .. dn n t ; t will remain unaltered. ) 3 + ( for the t, n and copy ) dup pick ( get dbref ) ( d1 .. dn n t i di ) swap ( Now we could add one to compensate for di, and subtract one to compensate for the fact we want the next value up, but it would be pointless. ) begin ( d1 .. dn n t di x ) dup 4 > while dup rotate ( d1 .. dn n t di x dx ; note that dx is missing for d1 .. dn ) dup 4 pick dbcmp not if ( d1 .. dn n t di x dx ) over 0 swap - ( d1 .. dn n t di x dx -x ) ( Insert what we took back. ) rotate ( d1 .. dn n t di x ) else ( d1 .. dn n t di x dx ) pop ( Remove item, we don't want it. ) ( d1 .. dn n t di x ) 4 rotate 1 - -4 rotate ( Since we got rid of it decrement n ) ( d1 .. dn' n' t di x ) then ( Now we want to try the next-closest item... ) 1 - repeat pop pop ( d1 .. dn n t ) ; : purify-reflist ( {d} -- {d}' ; removes duplicate dbrefs from list. ) dup not if exit then (Note: We store the offest from the top of the list here. Our convience. ) 0 begin over over >= not while over over - ( Find location from list top. ) ( {d} i i' ) purify-one ( And one-loop. ) 1 + ( Go to next item up. ) repeat pop ; : clean-reflist ( d s -- ) over over REF-first begin dup #-1 dbcmp not while ( dd s d ) dup player? not if dup ( dd s d d ) -4 rotate ( d dd s d ) 3 pick 3 pick rot REF-next ( d dd s d' ) 3 pick 3 pick ( d dd s d' dd s ) 6 rotate REF-delete ( dd s d ) else 3 pick 3 pick rot REF-next ( dd s d ) then repeat pop pop pop ; : admin? ( d -- ) dup trigger @ controls trigger @ admin_list 4 rotate REF-inlist? or ; : default_on? ( -- i ) trigger @ default_on_prop getpropval ; : default_joined? ( -- i ) trigger @ default_joined_prop getpropval ; : _inlist? ( dbref list -- ) trigger @ swap rot REF-inlist? ; : in_banned_list? banned_list_prop _inlist? ; : in_joined_list? default_joined? if in_banned_list? not else joined_list_prop _inlist? then ; : in_on_list? default_on? if dup in_joined_list? if off_list_prop _inlist? not else pop 0 then else on_list_prop _inlist? then ; lvar mesg lvar omesg : broadcast ( mesg omesg -- ; Send message to all in channel. SHould be formated, including GET_PREFIX. ) mesg ! omesg ! online purify-reflist ( remove duplicates ) begin dup while 1 - swap dup in_on_list? if dup me @ dbcmp if mesg @ else omesg @ then notify else pop then repeat pop ; lvar saychar : say-prop-sub "sl" "/" subst "at" "@" subst "sq" "~" subst "co" ":" subst ; $def _sayprop "_say/" swap strcat $def sayprop _sayprop swap strcat me @ swap getpropstr : say-find-prop ( s -- s ) dup saychar @ sayprop dup not if pop "def" sayprop else swap pop then ; : handle-say ( s -- osay say ) dup 1 strcut swap say-prop-sub dup "_say/" swap strcat me @ swap propdir? if rot pop saychar ! else pop pop "def" saychar ! then "/quotes" say-find-prop dup not if pop "\"%m\"" then swap "%m" subst dup "/say" say-find-prop dup not if pop "say" then dup dup strlen 1 - strcut swap pop "," strcmp if "," strcat then " " strcat "You " swap strcat "/osay" say-find-prop dup not if pop "says" then dup dup strlen 1 - strcut swap pop "," strcmp if "," strcat then " " strcat me @ name " " strcat swap strcat 3 pick strcat -3 rotate swap strcat ( osay say ) ; : handle-pose ( s -- opose pose ) dup 1 strcut pop ".,; ':/()[]|-+=>" .utell pop exit then .pmatch dup #-1 dbcmp if "Invalid name!" .etell pop exit then default_joined? if dup in_banned_list? not if "That player is not banned, so it's pointless to #add them." .etell pop exit then else dup in_joined_list? if "That player is already on the channel!" .etell pop exit then then do-add "Added." .mtell ; : do-remove ( d -- ) trigger @ joined_list_prop 3 pick REF-delete remove-from-on-off-lists ; : cmd-remove ( s -- ) dup not if pop "#remove " .utell exit then default_joined? if "Everyone allowed by default. Please use #ban instead." .etell pop exit then .pmatch dup #-1 dbcmp if "Invalid name!" .etell pop exit then dup in_joined_list? not if "But that player isn't on this channel anyways!" .etell pop exit then do-remove "Removed." .mtell ; : do-ban ( d -- ) trigger @ banned_list_prop 3 pick REF-add remove-from-on-off-lists ; : cmd-ban dup not if pop "#ban " .utell exit then default_joined? not if "Ban only when everyone is allowed by default. Use #remove instead." .etell pop exit then .pmatch dup #-1 dbcmp if "Invalid name!" .etell pop exit then dup in_banned_list? if "But, that player is already banned!" .etell pop exit then do-ban "Banned." .mtell ; : do-unban ( d -- ) trigger @ banned_list_prop 3 pick REF-delete ; : cmd-unban dup not if pop "#unban " .utell exit then default_joined? not if "Unbanning is pointless here. Use #add instead." .etell pop exit then .pmatch dup #-1 dbcmp if "Invalid name!" .etell pop exit then dup in_banned_list? not if "But, that player isn't baneed!" .etell pop exit then do-unban "Unbanned." .mtell ; : cmd-for dup "*={off|on}" smatch not if pop "#for =on" .utell "#for =off" .orutell exit then "=" .split swap .pmatch dup #-1 dbcmp not if "Invalid name!" .etell pop exit then swap "on" strcmp not if "Turned on for " over name strcat "." strcat .mtell do-on else "Turned off for " over name strcat "." strcat .mtell do-off then ; : cmd-default dup "{on|off|joined|unjoined}" smatch not if pop "#default on" .utell "#default off" .orutell "#default joined" .orutell "#default unjoined" .orutell exit then case "on" strcmp not when me @ "W" flag? not if "Wizbit required to set it on by default." .etell exit then trigger @ default_on_prop 1 setprop end "off" strcmp not when trigger @ default_on_prop 0 setprop end "joined" strcmp not when trigger @ default_joined_prop 1 setprop end "unjoined" strcmp not when trigger @ default_joined_prop 0 setprop end endcase "Default set." .mtell ; : cmd-who "Listening to the " channel-name strcat " channel: " strcat $ifdef USE_COLOR WHO_LABEL_COLOR color-add $endif .tell listeners-string $ifdef USE_COLOR WHO_NAMES_COLOR color-add $endif .tell ; : cmd-help "intercom by Wog" c_head "---------------" c_line "This is the " channel-name strcat " channel." strcat c_mode " CMD #help" c_cmd " This screen." c_info "For channel members only:" c_sec " CMD #on" c_cmd " CMD #off" c_cmd " Turn the channel on or off." c_info " CMD " c_cmd " Send on the channel." c_info " CMD :" c_cmd " Pose on the channel." c_info " CMD #who" c_cmd " Lists all members of the channel." c_info "For administrators only:" c_sec " CMD #default on" c_cmd " CMD #default off" c_cmd " Make the channel on or off by default." c_info " CMD #default joined" c_cmd " CMD #default unjoined" c_cmd " Makes channel joined or unjoined by default." c_info " CMD #add " c_cmd " Adds to the channel." c_info " CMD #remove " c_cmd " Removes from the channel. Won't work if channel is #default joined." c_info " CMD #ban " c_cmd " Bans from the channel. Works even if #default joined." c_info " CMD #unban " c_cmd " Unbans from the channel." c_info "This channel is set to be " default_joined? if "joined" else "unjoined" then strcat " and " strcat default_on? if "on" else "off" then strcat " by default." strcat c_mode begin depth dup while rotate command @ "CMD" subst .tell repeat ; : handle-commands dup " " instr if " " .split else "" then swap tolower case "help" 1 strncmp not when pop cmd-help end me @ in_joined_list? if "who" strcmp not when pop cmd-who end "on" strcmp not when pop cmd-on end "off" strcmp not when pop cmd-off end else "{who|on|off}" smatch when pop "Permission denied." .etell exit end then me @ admin? if "add" strcmp not when cmd-add end "remove" strcmp not when cmd-remove end "ban" strcmp not when cmd-ban end "unban" strcmp not when cmd-unban end "for" strcmp not when cmd-for end "default" strcmp not when cmd-default end else "{add|remove|ban|unban|for|default}" smatch when pop "Permission denied." .etell exit end then default "Unknown command." .etell end endcase ; : clean-check ( -- ) trigger @ clean_timestamp getpropval systime swap - clean_interval >= if trigger @ default_on? if off_list_prop else on_list_prop then clean-reflist trigger @ default_joined? if banned_list_prop else joined_list_prop then clean-reflist trigger @ clean_timestamp systime setprop then ; : main dup "#" 1 strncmp not if 1 strcut swap pop dup "#" 1 strncmp if handle-commands exit then then me @ in_on_list? if send else me @ in_joined_list? if "You don't have this channel turned on!" .etell else "You aren't allowed on this channel!" .etell then then ; : _main $ifdef WIZ_TRIGGER_RESTRICT caller program? caller "W" flag? and trig owner "truewizard" flag? or not if "INTERCOM.MUF: Actions owned by wizzies only, please." .tell exit then $endif caller program? caller "W" flag? and not if "me" match me ! trig trigger ! background then main caller program? not if background 0 sleep clean-check then ; . c q @set intercom.muf=W @set intercom.muf=VIEWABLE