The Roomprops Perl Script

Download as FTP

(Back)



#! /usr/sbin/perl
# or #!/usr/local/bin/perl
#
# roomprops $Revision: 1.8 $
#
# (C)1996-1998 Kevin Bjorke (bjorke@botzilla.com)
#
# Permission to use and reproduce this script is hereby granted,
# providing that this header information is not removed.
#
# The script analyzes Palace mansion scripts (typically named "mansionscript"
# or "mansion.script" or even "PServer.dat," depending on the platform), and
# writes a Palace "iptscrae" cyborg script that can reproduce the set dressing
# of any given room on demand. The script is inserted into the OUTCHAT block
# of a user's Cyborg.ipt file. If a lot of props are used, the script will
# automatically be tuned to avoid flooding.
#
# (If this is all greek to you, check out the URL
# http://www.botzilla.com/house/ to find out about
# The Palace and Palace scripting)
#

#
# Usage: roomprops [roomName] [mansionScriptFileName] > destinationFile
#

require "bigint.pl";

#
# Figure out the room and script
#

$room	= ($#ARGV >= 0)	? $ARGV[0] : "Valhalla";
$script	= ($#ARGV >= 1) ? $ARGV[1] : "mansionscript";
@dd = split(" ",$room);
$command = join("",@dd) . "Props";

# some useful constants

$hiSigned = &babs(oct("0xA0000000"));
$nineBits = &bmul($hiSigned,2);
$delayTime = 10;		# seconds
$delPerProp = 8;		# every so many props
$safeNum = 10;
$timerLimit = 20;		# number of event it's safe to schedule
$aeBase = 300;			# ticks

#
# Okay here we go
#

$mansName = "unknown";

$inRoom=0;
$thisRoom=0;
$rmName="";
$nProps=0;

#
# subroutines
#

sub instructions {
    print ";\tInsert this entire code block inside the\n";
    print ";\t{braces} that enclose your ON OUTCHAT block.\n";
    print ";\tTo use it, type the command: \"$command\"\n\n";
}

sub begin_ipt {
    print "; Props from \"$room\"\n";
    print "\t{\n";
    print "\t\tCLEARLOOSEPROPS\n";
    print "\t\t$delayTime prpDly =\n" if (($delayTime>0)&&($nProps<=$safeNum));

}

sub wrap_ipt {
    if ($nProps<=$safeNum) {
	print "\t\t\"$room Props Restored\" CHATSTR =\n";
    } else {
	print "\t\t\"*Restoring $room Props*\" CHATSTR =\n";
    }
    print "\t} CHATSTR \"$command\" == IF\n";
    print "\n; end\n";
}

sub idelay {
    print "\t\tprpDly DELAY\n" if (($delayTime>0)&&($nProps<=$safeNum));
}

sub undress {
    print ";\t\t*** remember worn props for later *\n";
    print "\t\tNBRUSERPROPS n_tp =\n";
    print "\t\t{\n";
    print "\t\t\t0 nqp = \n";
    print "\t\t\tn_tp ARRAY npl = \n";
    print "\t\t\t{\n";
    print "\t\t\t\tnqp USERPROP npl nqp PUT\n";
    print "\t\t\t\tnqp ++\n";
    print "\t\t\t} { nqp n_tp < } WHILE\n";
    print "\t\t} n_tp IF\n";
    &idelay;
    print "\t\tNAKED\n";
}

sub redress_self {
    print ";\t* restore previously-worn props *\n";
    print "\t\t{\n";
    print "\t\t\t0 nqp = \n";
    print "\t\t\t{\n";
    print "\t\t\t\tnpl nqp GET DONPROP\n";
    print "\t\t\t\tnqp ++\n";
    print "\t\t\t} { nqp n_tp < } WHILE\n";
    print "\t\t} n_tp IF\n";
}

sub redress_2 {
    print ";\t* restore previously-worn props *\n";
    print "\t\t{\n";
    print "\t\t\t0 nqp = \n";
    print "\t\t\t\"NAKED \"\n";
    print "\t\t\t{\n";
    print "\t\t\t\tnpl nqp GET ITOA & \" DONPROP \" & \n";
    print "\t\t\t\tnqp ++\n";
    print "\t\t\t} { nqp n_tp < } WHILE\n";
    print "\t\t\tSTRTOATOM n_aet " . $ct . " * ALARMEXEC\n";
    print "\t\t} n_tp IF\n";
}

sub add_prop {
    local($origVal,$xPos,$yPos) = @_;
    local($v,$t,$a,$q);
    $v = &babs($origVal);
    $t = &bsub($hiSigned,$v);
    $a = &babs($t);
    if (&bcmp($t,$a)) {
	$v = &bsub($v,$nineBits);
    } else {
	$v =~ s/^\+//;
    }
    $q = join(" ",($v,$xPos,$yPos));
    @propList = (@propList,$q);
    $nProps ++;
}

sub write_prop {
    local($g,$ind) = @_;
    local($id,$x,$y) = split(" ",$g);
#    *** for some off reason, using ADDLOOSEPROP, E.g.
#    *** $id $2 $3 ADDLOOSEPROP
#    *** does not work. So we put the props on and drop them.
    print "\t" if ($ind);
    print "\t\t" . $id . " DONPROP $x $y DROPPROP\n";
}

##

open(SCRIPT,$script)	||	die(";Can't open \"$script\"\n");
    while (<SCRIPT>) {
	if (/SERVERNAME "(.*)"/) {
	    $mansName = $1;
	}
	if (/\bROOM\b/) {
	    $inRoom = 1;
	    $rmName = "";
	    $thisRoom = 0;
	} elsif (/ENDROOM/) {
	    $inRoom = 0;
	    $thisRoom = 0;
	} elsif (/NAME *"(.*)"/) {
	    if ($rmName eq "") {
		$rmName = $1;
		if ($rmName eq $room) {
		    $thisRoom = 1;
		}
	    }
	} elsif (/PROP PROPID (0x[0-9A-F]*) .*LOC (-?[0-9]*) *,(-?[0-9]*) *ENDPROP/) {
	    if ($thisRoom) {
		&add_prop(oct($1),$2,$3);
	    }
	} elsif (/PROP PROPID (-*[1-9]\d*) .*LOC ([0-9]*),([0-9]*) *ENDPROP/) {
	    if ($thisRoom) {
		&add_prop($1,$2,$3);
	    }
	} else {
	    # ignore
	}
    }
close(SCRIPT);

die(";No Props in \"$room\" of mansion \"$manName\"\n")	if ($nProps<=0);

print "; From \"$script\" - Mansion \"$mansName\"\n";
&instructions;
&begin_ipt;
&undress;
if ($nProps<=$safeNum) {
    foreach $pp ( sort(@propList) ) {
	&write_prop($pp,0);
    }
    print ";\t\t*** $nProps Props ***\n\n";
    &idelay;
    &redress_self;
} else {
    print ";\t\t*** \"n_aet\" is the delay between bursts, in \"ticks.\"\n";
    print ";\t\t*** The default, " . $aeBase . ", is " .
		($aeBase/60) . " seconds.\n";
    print "\t\t" . $aeBase . " n_aet =\n";
    $ct = 1;
    if ($nProps <= $timerLimit) {
	foreach $pp ( sort(@propList) ) {
	    print "\t\t{\n";
	    &write_prop($pp,1);
	    print "\t\t} n_aet " . $ct . " * ALARMEXEC\n";
	    $ct ++;
	}
    } else {
	$npp = int($nProps / $timerLimit);
	$xtr = $nProps % $timerLimit;
	$pc = 0;
	for ($tc=0; $tc < $timerLimit; $tc++) {
	    print "\t\t{\n";
	    for ($i=0; $i<$npp; $i ++) {
		&write_prop($propList[$pc],1);
		$pc ++;
	    }
	    if ($tc < $xtr) {
		&write_prop($propList[$pc],1);
		$pc ++;
	    }
	    print "\t\t} n_aet " . $ct . " * ALARMEXEC\n";
	    $ct ++;
	}
	print ";hmm, $pc didn't hit $nProps\n" if ($pc != $nProps);
    }
    &redress_2;
    $ct ++;
    print ";\t\t*** $nProps Props ***\n";
    print "\t\t{ \"*Done*\" SAY } n_aet " . $ct . " * ALARMEXEC\n";
}
&wrap_ipt;

# eof