@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=<this program>
    @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 - <All require control over trigger @ger action>
	int #default <on/off> 
		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 <name>
		Adds <name> to channel... Will revert an 'int #ban'.
	int #remove <name>
		Removes <name> from channel...
	int #ban <name>
		Same as above, except the only command that will work in
			default '#default joined' mode...
	int #for <name>={on|off}
		Turns channel on or off for <name>
	
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 <car@cs.brown.edu>

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?)
$def USE_COLOR
( -- This is in the tidle-color 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
  <channel-name>: <message>
  If you don't like that you can change it below, if you know what you're doing.
)
( usage messages are like: Usage: <command format> )
  

$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 ~&<A><F><B> 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
( "<channel> " )

$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
	".,; ':/()[]|-+=><?! " swap instr not if
		" " swap strcat
	then
	me @ name swap strcat dup
; 

: check-pose-say ( s -- otext text )
	dup 1 strcut swap ":" strcmp not if
		swap pop
		handle-pose
	else
		pop
		handle-say
	then
; 

: send
$ifdef __fb6
$ifdef extended_ansi
	ansify_string
$endif
$endif
	check-pose-say
	get-prefix
	dup
	( ot t p p )
	rot strcat
	( ot p t' )
	swap rot
	( t' p ot )
	strcat
	swap
	broadcast
; 

: listeners ( -- {d} ;  lists online listeners to a channel. )
	online
	0 begin
		({d} i )
		over over <= not while
		3 over + pick in_on_list? not if
			({d} i)
			3 over + rotate pop
			swap 1 - swap
		else
			1 +
		then
	repeat pop
	purify-reflist
; 

: listeners-string ( -- s ;  lists listeners to a channel )
	listeners dup if
		.short-list
	else
		pop
		"*no one*"
	then
; 

: do-on ( d -- )
	trigger @ default_on? if
		off_list_prop rot REF-delete
	else
		on_list_prop rot REF-add
	then
; 

: cmd-on ( s -- )
	me @ in_on_list? if
		"You are already on in this channel!" .etell exit
	then
	me @ do-on
	"Turned on." .mtell
; 

: do-off ( s -- )
	trigger @ default_on? if
		off_list_prop rot REF-add
	else
		on_list_prop rot REF-delete
	then
; 

: cmd-off ( s -- )
	me @ in_on_list? not if
		"You already have this channel turned off!" .etell exit
	then
	me @ do-off
	"Turned off." .mtell
; 

: remove-from-on-off-lists ( d -- )
	trigger @ default_on? if off_list_prop else on_list_prop then
	rot REF-delete
; 

: do-add ( d -- )
	trigger @ joined_list_prop rot REF-add
; 

: cmd-add ( s -- )
	dup not if
		"#add <name>" .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 <player>" .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 <player>" .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 <player>" .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 <player>=on" .utell "#for <player>=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 <message>" c_cmd
"    Send <message> on the channel." c_info
"  CMD :<message>" c_cmd
"    Pose <message> 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 <name>" c_cmd
"    Adds <name> to the channel." c_info
"  CMD #remove <name>" c_cmd
"    Removes <name> from the channel. Won't work if channel is #default joined."
 c_info
"  CMD #ban <name>" c_cmd
"    Bans <name> from the channel. Works even if #default joined." c_info
"  CMD #unban <name>" c_cmd
"    Unbans <name> 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