IllogiGames/Cv dungeon
Jump to navigation
Jump to search
This is a "dungeon compiler" for converting more or less readable room and link specifications into a single-page click-link adventure game. It makes it possible to have a meaningful inventory list and have things happen which have consequences later in the game. It's documented (more or less) here. It, or a variant of it, is what is used to translate The Stench and Celestial Pirates part 1 and 2. The version here is some random version. More specific versions may be uploaded into subdirectories of each of the aforementioned games.
Needless to say, to run this you should snip it out from between the <nowiki> tags, save it in a file, set the 'x' bit, and execute it. (That's if you're on Linux. If you're on Windows consult your system administrator for advice.)
#!/usr/bin/perl -w
use strict;
#
# Convert the single file source using symbolic names to
# a single file using offsets
#
# Update log
#
# Jul 15 2014 S: Added attributes and item tags, jazzed up expression parsing to be slightly less broken. Nested parens should work a bit
# better, '!=' might work now.
#
my $filename = "the-stench-1-rooms.html";
my $index_only = 0;
my $sort_rooms = 0;
my $cv_to_singlefile = 1;
my $cv_to_multifile = 0;
my %room_names; # Room IDs based on definition order
my %room_used;
my @room_array;
my $debug = 0;
my $optimize = 0;
my %alpha_room_ids; # Room IDs based on alphabetical order
my %shared_ilist_for_state; # Map of state number to inventory list number
my $keep_comments; # Set => well, you know ... keep the comments.
# State related variables and stuff
my %state_names; # Map of state names to numbers
my @state_ilists; # Inventory lists for the states, indexed by state number
my @state_attributes; # Attribute lists for the states, indexed by state number
my %simple_macros; # All macros are entered in the simple-macros table
my %macro_args; # A macro with arguments has an entry in the args table, as well
my $last_state_number = -1;
my %tag_to_inventory_item; # Short tags for inventory items -- used in finding sets of states with given attributes
my %inventory_item_to_tag;
my %tag_to_attribute; # Index attribute tags
#
# Some random numbers -- generated by C's 'random' function, which is supposed to be pretty good.
#
#
# NB -- this was supposed to help with the 'scramble' function, which is used to build the (static) links in the
# desert maze. It didn't. The result still stinks. Either the concept is NG or a better way of generating random
# links is needed.
#
my @randoms = (1804289383, 846930886, 1681692777, 1714636915, 1957747793, 424238335, 719885386, 1649760492, 596516649, 1189641421, 1025202362,
1350490027, 783368690, 1102520059, 2044897763, 1967513926, 1365180540, 1540383426, 304089172, 1303455736, 35005211, 521595368,
294702567, 1726956429, 336465782, 861021530, 278722862, 233665123, 2145174067, 468703135, 1101513929, 1801979802, 1315634022,
635723058, 1369133069, 1125898167, 1059961393, 2089018456, 628175011, 1656478042, 1131176229, 1653377373, 859484421, 1914544919,
608413784, 756898537, 1734575198, 1973594324, 149798315, 2038664370, 1129566413, 184803526, 412776091, 1424268980, 1911759956,
749241873, 137806862, 42999170, 982906996, 135497281, 511702305, 2084420925, 1937477084, 1827336327, 572660336, 1159126505,
805750846, 1632621729, 1100661313, 1433925857, 1141616124, 84353895, 939819582, 2001100545, 1998898814, 1548233367, 610515434,
1585990364, 1374344043, 760313750, 1477171087, 356426808, 945117276, 1889947178, 1780695788, 709393584, 491705403, 1918502651,
752392754, 1474612399, 2053999932, 1264095060, 1411549676, 1843993368, 943947739, 1984210012, 855636226, 1749698586, 1469348094,
1956297539, 1036140795, 463480570, 2040651434, 1975960378, 317097467, 1892066601, 1376710097, 927612902, 1330573317, 603570492,
1687926652, 660260756, 959997301, 485560280, 402724286, 593209441, 1194953865, 894429689, 364228444, 1947346619, 221558440,
270744729, 1063958031, 1633108117, 2114738097, 2007905771, 1469834481, 822890675, 1610120709, 791698927, 631704567, 498777856,
1255179497, 524872353, 327254586, 1572276965, 269455306, 1703964683, 352406219, 1600028624, 160051528, 2040332871, 112805732,
1120048829, 378409503, 515530019, 1713258270, 1573363368, 1409959708, 2077486715, 1373226340, 1631518149, 200747796, 289700723,
1117142618, 168002245, 150122846, 439493451, 990892921, 1760243555, 1231192379, 1622597488, 111537764, 338888228, 2147469841,
438792350, 1911165193, 269441500, 2142757034, 116087764, 1869470124, 155324914, 8936987, 1982275856, 1275373743, 387346491,
350322227, 841148365, 1960709859, 1760281936, 771151432, 1186452551, 1244316437, 971899228, 1476153275, 213975407, 1139901474,
1626276121, 653468858, 2130794395, 1239036029, 1884661237, 1605908235, 1350573793, 76065818, 1605894428, 1789366143, 1987231011,
1875335928, 1784639529, 2103318776, 1597322404, 1939964443, 2112255763, 1432114613, 1067854538, 352118606, 1782436840, 1909002904,
165344818, 1395235128, 532670688, 1351797369, 492067917, 1504569917, 680466996, 706043324, 496987743, 159259470, 1359512183,
480298490, 1398295499, 1096689772, 2086206725, 601385644, 1172755590, 1544617505, 243268139, 1012502954, 1272469786, 2027907669,
968338082, 722308542, 1820388464, 933110197, 6939507, 740759355, 1285228804, 1789376348, 502278611, 1450573622, 1037127828,
1034949299, 654887343, 1529195746, 392035568, 1335354340, 87755422, 889023311, 1494613810, 1447267605, 1369321801, 745425661,
396473730, 1308044878, 1346811305, 1569229320, 705178736, 1590079444, 434248626, 1977648522, 1470503465, 1402586708, 552473416,
1143408282, 188213258, 559412924, 1884167637, 1473442062, 201305624, 238962600, 776532036, 1238433452, 1273911899, 1431419379,
620145550, 1665947468, 619290071, 707900973, 407487131, 2113903881, 7684930, 1776808933, 711845894, 404158660, 937370163,
2058657199, 1973387981, 1642548899, 1501252996, 260152959, 1472713773, 824272813, 1662739668, 2025187190, 1967681095, 1850952926,
437116466, 1704365084, 1176911340, 638422090, 1943327684, 1953443376, 1876855542, 1069755936, 1237379107, 349517445, 588219756,
1856669179, 1057418418, 995706887, 1823089412, 1065103348, 625032172, 387451659, 1469262009, 1562402336, 298625210, 1295166342,
1057467587, 1799878206, 1555319301, 382697713, 476667372, 1070575321, 260401255, 296864819, 774044599, 697517721, 2001229904,
1950955939, 1335939811, 1797073940, 1756915667, 1065311705, 719346228, 846811127, 1414829150, 1307565984, 555996658, 324763920,
155789224, 231602422, 1389867269, 780821396, 619054081, 711645630, 195740084, 917679292, 2006811972, 1253207672, 570073850,
1414647625, 1635905385, 1046741222, 337739299, 1896306640, 1343606042, 1111783898, 446340713, 1197352298, 915256190, 1782280524,
846942590, 524688209, 700108581, 1566288819, 1371499336, 2114937732, 726371155, 1927495994, 292218004, 882160379, 11614769,
1682085273, 1662981776, 630668850, 246247255, 1858721860, 1548348142, 105575579, 964445884, 2118421993, 1520223205, 452867621,
1017679567, 1857962504, 201690613, 213801961, 822262754, 648031326, 1411154259, 1737518944, 282828202, 110613202, 114723506,
982936784, 1676902021, 1486222842, 950390868, 255789528, 1266235189, 1242608872, 1137949908, 1277849958, 777210498, 653448036,
1908518808, 1023457753, 364686248, 1309383303, 1129033333, 1329132133, 1280321648, 501772890, 1781999754, 150517567, 212251746,
1983690368, 364319529, 1034514500, 484238046, 1775473788, 624549797, 767066249, 1886086990, 739273303, 1750003033, 1415505363,
78012497, 552910253, 1671294892, 1344247686, 1795519125, 661761152, 474613996, 425245975, 1315209188, 235649157, 1448703729,
1679895436, 1545032460, 430253414, 861543921, 677870460, 932026304, 496060028, 828388027, 1144278050, 332266748, 1192707556,
31308902, 816504794, 820697697, 655858699, 1583571043, 559301039, 1395132002, 1186090428, 1974806403, 1473144500, 1739000681,
1498617647, 669908538, 1387036159, 12895151, 1144522535, 1812282134, 1328104339, 1380171692, 1113502215, 860516127, 777720504,
1543755629, 1722060049, 1455590964, 328298285, 70636429, 136495343, 1472576335, 402903177, 1329202900, 1503885238, 1219407971,
2416949, 12260289, 655495367, 561717988, 1407392292, 1841585795, 389040743, 733053144, 1433102829, 1887658390, 1402961682,
672655340, 1900553541, 400000569, 337453826, 1081174232, 1780172261, 1450956042, 1941690360, 410409117, 847228023, 1516266761,
1866000081, 1175526309, 1586903190, 2002495425, 500618996, 1989806367, 1184214677, 2004504234, 1061730690, 1186631626, 2016764524,
1717226057, 1748349614, 1276673168, 1411328205, 2137390358, 2009726312, 696947386, 1877565100, 1265204346, 1369602726, 1630634994,
1665204916, 1707056552, 564325578, 1297893529, 1010528946, 358532290, 1708302647, 1857756970, 1874799051, 1426819080, 885799631,
1314218593, 1281830857, 1386418627, 1156541312, 318561886, 1243439214, 70788355, 1505193512, 1112720090, 1788014412, 1106059479,
241909610, 1051858969, 1095966189, 104152274, 1748806355, 826047641, 1369356620, 970925433, 309198987, 887077888, 530498338,
873524566, 37487770, 1541027284, 1232056856, 1745790417, 1251300606, 959372260, 1025125849);
my $rand_count = $#randoms;
while (1) {
my $a1 = shift;
if (! defined $a1) { last; }
if ($a1 eq "-index") {
$index_only = 1;
} elsif ($a1 eq "-sort" ) {
$sort_rooms = 1;
} elsif ($a1 eq "-single" ) {
$cv_to_singlefile = 1;
$cv_to_multifile = 0;
} elsif ($a1 eq "-multi" ) {
$cv_to_singlefile = 0;
$cv_to_multifile = 1;
} elsif ($a1 eq "-debug" ) {
$debug = 1;
} elsif ($a1 eq "-f" ) {
$filename = shift;
} elsif ($a1 eq "-opt") {
$optimize = 1;
} elsif ($a1 eq "-keep_comments") {
$keep_comments = 1;
} else {
die "Argument $a1 not understood\n";
}
}
# ****************************************************************
# Print a string if we're in debug mode
sub dprint ($) {
my ($str) = @_;
if ($debug) {
print STDERR $str;
}
}
# ****************************************************************
# Return the next random number in the random table
my $randtable_nv = 0;
sub rand_next () {
my $rv = $randoms[$randtable_nv];
$randtable_nv ++;
if ($randtable_nv > $#randoms) { $randtable_nv = 0; } # Wrap if we fall off the end
return $rv;
}
# ****************************************************************
# Find the member of a permutation. This is pretty bizarre, but I hope the purpose
# will make sense.
#
# It takes three numbers for arguments: Permutation, length, and member:
#
# permutation_next (perm#, length, member):
#
# perm# -- the permutation. Each time it's called with the same value of perm# it uses the
# same permutation.
# length -- Length of the permutation
# member -- The member of the permutation. (The member *value* _not_ the index.)
#
# It searches the permutation for 'member', and returns the *next* value in the permutatoin.
#
# The purpose is generating a random shuffle of rooms. You decide on a permutation number for
# the shuffle, and decide how many rooms are in the shuffle, and then for each room, you
# call it with the permutation number, the length, and the room number. And you link to
# the room number it returns, which is the next room in the shuffle.
#
# The first time it's called for a permutation number it computes the permutation, using
# our random number table (or something else which always returns the same sequence of
# random numbers), and stores it in a hash for later re-use.
my @permutations;
my @perm_lengths;
sub permutation_next ($$$) {
my ($pindex,$ln,$member) = @_;
if ($debug) { print STDERR "permutation_next ($pindex, $ln, $member)\n"; }
if (!defined $permutations[$pindex]) {
my @p = (0..$ln-1); # Build a sequence
foreach my $i (1..$#p) { # Shuffle it
my $j = rand_next() % ($i+1);
($p[$j],$p[$i]) = ($p[$i],$p[$j]) # Swap 'em
}
if ($debug) {
print STDERR " .. Perm $pindex not defined, so we built it\n";
my $sep = " ";
foreach my $pv (@p) {
print STDERR "${sep}${pv}";
$sep = ", ";
}
print STDERR "\n";
}
$permutations[$pindex] = \@p; # Retain a pointer to it
}
my $p = $permutations[$pindex];
if ($#$p + 1 != $ln) { die "Whoops! Permutation $pindex has last index $#$p, passed length is $ln; member is $member\n"; }
foreach my $m (0..$#$p) {
if ($$p[$m] == $member) {
my $next = ($m + 1) % $ln;
if ($debug) { print STDERR " .. Next index $next; returning $$p[$next]\n"; }
return $$p[$next];
}
}
die "permutation_next($pindex, $ln, $member) fell off the end of the permutation\n";
}
# ****************************************************************
# Find all states with a particular set of tags (items or attributes)
# Returns the list of states it found
sub sef_find_states_with_tags ($$) {
my ($lineno, $args) = @_;
dprint "sef_find_states_with_tags at line $lineno with args '$args'\n";
my @found_states;
my @states = sort {$a <=> $b} values %state_names; # Get the list of all states
my $scount = scalar(@states);
dprint " .. sef_find_states_with_tags: We will search $scount states\n";
my @tags = split /,/,$args; # And all the tags we were passed
foreach my $t (@tags) {
@found_states = (); # Clear the found states list for each new tag
my $is_inventory_item = 1; # Assume it's from the inventory
my $item = $tag_to_inventory_item{$t};
if (! $item) {
$is_inventory_item = 0; # Wasn't in the inventory -- must be an attribute
$item = $tag_to_attribute{$t};
}
if (! $item) {
die "sef_find_states_with_tags: line $lineno: Can't find tag $t in inventory or value list\n";
}
foreach my $s (@states) { # For each state...
my $foundit = 0;
my $l;
if ($is_inventory_item) {
$l = $state_ilists[$s]; # Get the inventory list for the state
} else {
$l = $state_attributes[$s]; # It's an attribute, so get the attribute list
}
foreach my $f (@$l) { # Iterate over the inventory or attribute list and see if the specified item is on it
if ($f eq $item) {
$foundit = 1;
last;
}
}
if ($foundit) { # Did we find the attribute/inventory item in the state's lists?
dprint " .. sef_find_states_with_tags: State $s looks good\n";
push @found_states, $s;
}
}
@states = @found_states; # Reduce to the ones we found before we go around the loop again
}
$scount = scalar(@found_states);
dprint " .. sef_find_states_with_tags: Found $scount states which matched\n";
return \@found_states;
}
# ****************************************************************
# Parse the state list operators
#
sub state_expr_operator_parser ($$$$) {
my ($lineno, $lhs, $op, $rhs) = @_;
dprint "state_expr_operator_parser: '$lhs', '$op', '$rhs'\n";
if ($lhs =~ /^\s*\[\s*(.*)\s*\]\s*$/) { $lhs = $1; }
if ($rhs =~ /^\s*\[\s*(.*)\s*\]\s*$/) { $rhs = $1; }
my @left_list = split /,/,$lhs;
my @right_list = split /,/,$rhs;
if ($op eq "+" || $op eq "|") {
foreach my $right_val (@right_list) {
my $foundit = 0;
foreach my $j (@left_list) {
if ($j eq $right_val) {
$foundit = 1;
last;
}
}
if (!$foundit) { # If it's not already on the left hand list, append it
push @left_list, $right_val;
}
}
return join ",", @left_list;
} elsif ($op eq "\&") {
my @final; # The final list
foreach my $left_val (@left_list) {
my $foundit = 0;
foreach my $j (@right_list) {
if ($j eq $left_val) {
$foundit = 1;
last;
}
}
if ($foundit) { # If it's on both lists add it to the final list
push @final, $left_val;
}
}
return join ",", @final;
} elsif ($op eq "-") {
my @final; # The final list
foreach my $left_val (@left_list) {
my $foundit = 0;
foreach my $j (@right_list) {
if ($j eq $left_val) {
$foundit = 1;
last;
}
}
if (!$foundit) { # If it's on on the left list but not the right list, append it to the result
push @final, $left_val;
}
}
return join ",", @final;
} else {
die "state_expr_operator_parser, line $lineno: Don't understand operator '$op'\n";
}
}
# ****************************************************************
# Generate the state functions
my $last_state_expr;
sub state_expr_function_parser ($$$) {
my ($lineno, $func, $args) = @_;
dprint "state_expr_function_parser, line $lineno, func='$func', args='$args'\n";
my @found_states;
if ($func eq "%all") {
@found_states = sort {$a <=> $b} values %state_names;
} elsif ($func eq "%with") {
my $states_ptr = sef_find_states_with_tags ($lineno, $args);
@found_states = @$states_ptr;
} elsif ($func eq "%without") {
my $with_states = sef_find_states_with_tags ($lineno, $args); # Find all the states _with_ the item, then we'll invert the list
foreach my $s (sort {$a <=> $b} values %state_names) {
my $has_it = 0;
foreach my $wstate (@$with_states) {
if ($wstate eq $s) {
$has_it = 1;
last;
}
}
if (! $has_it) { # Wasn't on the 'with' list?
push @found_states, $s; # Then it goes on the 'without' list.
}
}
# Toggle is hard -- we need to parse an expression out which may contain commas
# We don't. We assume there will be no parens or brackets in the 'toggle' terms, and
# that there won't be any commas outside brackets and parens in the 'expr' term, and
# use that to split it up.
} elsif ($func eq "%toggle") {
if ($args !~ /^(.*?) , ([^\(\)\[\]]*)$/x) { # We expect an expression, a comma, and a comma separated simple list of state names
die "state_expr_function_parser: line $lineno: can't parse 'toggle' function arguments '$args'\n";
}
my ($sexpr,$pair_str) = ($1,$2);
my $state_str = state_expression_parser ($lineno, $sexpr);
if ($state_str =~ /^\[(.*)\]$/) { # Strip brackets (which should be there)
$state_str = $1;
}
@found_states = split /,/,$state_str; # The state list we'll return (not yet toggled)
my @pairs = split /,/,$pair_str; # And split the pairs up
if (scalar(@pairs) % 2) {
die "state_expr_function_parser at line $lineno: Toggle function needs a state list and a set of pairs; state names can't be odd\n";
}
my @swapped_pairs;
my $i;
for ($i = 0; $i < scalar(@pairs); $i += 2) {
$swapped_pairs[$i] = $pairs[$i+1]; # Swap 'em in the swapped array
$swapped_pairs[$i+1] = $pairs[$i];
}
foreach $i (0..$#found_states) { # Toggle the states we'll return
my $s = $found_states[$i];
foreach my $t (0..$#pairs) {
if ($s == $pairs[$t]) {
$found_states[$i] = $swapped_pairs[$t]; # Switch for the toggled pair member
last; # Important that we break here! Otherwise we'll toggle it right back!
}
}
}
# Just like toggle but we only go one way.
# In other words, this is a substitute function.
} elsif ($func eq "%map") {
if ($args !~ /^(.*?) , ([^\(\)\[\]]*)$/x) { # We expect an expression, a comma, and a comma separated simple list of state names
die "state_expr_function_parser: line $lineno: can't parse 'map' function arguments '$args'\n";
}
my ($sexpr,$pair_str) = ($1,$2);
my $state_str = state_expression_parser ($lineno, $sexpr);
if ($state_str =~ /^\[(.*)\]$/) { # Strip brackets (which should be there)
$state_str = $1;
}
@found_states = split /,/,$state_str; # The state list we'll return (not yet mapped)
my @pairs = split /,/,$pair_str; # And split the pairs up
if (scalar(@pairs) % 2) {
die "state_expr_function_parser at line $lineno: Map function needs a state list and a set of pairs; state names can't be odd\n";
}
my @mapped_pairs;
my $i;
for ($i = 0; $i < scalar(@pairs); $i += 2) {
$mapped_pairs[$i] = $pairs[$i+1]; # Map both members of each pair to the second member in the input pair
$mapped_pairs[$i+1] = $pairs[$i+1];
}
foreach $i (0..$#found_states) { # Map the states we'll return
my $s = $found_states[$i];
foreach my $t (0..$#pairs) {
if ($s == $pairs[$t]) {
$found_states[$i] = $mapped_pairs[$t]; # Switch for the mapped pair member
last; # Important that we break here! Otherwise we'll toggle it right back!
}
}
}
} else {
die "state_expr_function_parser: line $lineno: Don't understand function '$func'\n";
}
my $result = join ",", @found_states;
dprint "state_expr_function_parser --> $result\n";
return "[${result}]";
}
# ****************************************************************
# Parse a state expression. Surrounding brackets should already be stripped off.
# The line number argument is used in error messages.
#
# We have several special functions:
#
# %all() -- All states known to us
# %with(tag1,tag2,...) -- All states with inventory or attribute "tag1" and "tag2" and ...
# %without(tags) -- Same but without any of the items
# %toggle(sexpr, State1a, State1b, State2a, State2b, ... ) -- Evaluate sexpr, and State1a, etc, then swap 1a<->1b, 2a<->2b, etc
#
sub state_expression_parser ($$) {
my ($lineno, $sexpr) = @_;
dprint "state_expression_parser (at line $lineno): '$sexpr'\n";
if ($sexpr =~ /^\s*\(\s* ([^\(\)]*?) \s*\)\s*$/x) { # If there's a pair of parens around a paren-less expression, strip them
dprint " .. state_expression_parser: Stripped parens\n";
$sexpr = $1;
}
if ($sexpr =~ /^\s*\[\s* ([^\[\]]*?) \s*\]\s*$/x) { # If there's a pair of brackets around a bracket-less expression, strip them
dprint " .. state_expression_parser: Stripped brackets\n";
$sexpr = $1;
}
if ($sexpr =~ /^\s* \* \s*$/x) { # If it's just a "*" return the last one we expanded
return "[${last_state_expr}]";
}
while ($sexpr =~ /^\s* (.*?) \s* (\%\w+)? \s*\(\s* ([^\(\)]*?) \s*\)\s* (.*?) \s*$/x) { # Function or parenthesized subexpression
my ($lhs,$fname,$subex,$rhs) = ($1,$2,$3,$4);
dprint "state_expression_parser: Matched a function call: '$lhs', '$fname', '$subex', '$rhs'\n";
my $middle;
if ($fname) { # If it's a function call
$middle = state_expr_function_parser ($lineno, $fname, $subex);
} else { # In this case it's just a subexpression
$middle = &state_expression_parser ($lineno, $subex);
}
$sexpr = "${lhs}${middle}${rhs}";
}
#
# At this point all function calls have been evaluated, all subexpressions expanded. There should be no
# parens in the expression. From here on we just split it on operator boundaries and combine the
# halves.
#
if ($sexpr =~ /^(.*\S*) \s* ([\|]) \s* (.*?) \s*$/x) { # Note that the greedy '.*' on the left is needed to force left association
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &state_expression_parser ($lineno, $lhs);
$rhs = &state_expression_parser ($lineno, $rhs);
$sexpr = state_expr_operator_parser ($lineno, $lhs, $op, $rhs);
}
if ($sexpr =~ /^(.*\S*) \s* ([\&]) \s* (.*?) \s*$/x) { # Note that the greedy '.*' on the left is needed to force left association
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &state_expression_parser ($lineno, $lhs);
$rhs = &state_expression_parser ($lineno, $rhs);
$sexpr = state_expr_operator_parser ($lineno, $lhs, $op, $rhs);
}
if ($sexpr =~ /^(.*\S*) \s* ([\-\+]) \s* (.*?) \s*$/x) { # Note that the greedy '.*' on the left is needed to force left association
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &state_expression_parser ($lineno, $lhs);
$rhs = &state_expression_parser ($lineno, $rhs);
$sexpr = state_expr_operator_parser ($lineno, $lhs, $op, $rhs);
}
if ($sexpr =~ /^\[ ( [^\[\]]* ) \]$/x) { # Strip a pair of balanced brackets, if there are any
$sexpr = $1;
}
my @final_list;
$sexpr =~ s/\s//g; # Delete all white space
foreach my $s (split /,/,$sexpr) {
my $sn;
if ($s =~ /^\d*$/) { # If it's already a number, just use it.
$sn = $s;
} else { # Otherwise look it up
$sn = $state_names{$s};
}
if (! defined $sn) {
die "Line $lineno: State $s isn't defined, splitting and substituting '$sexpr'\n";
}
push @final_list, $sn;
}
my $str = join ",", @final_list;
return "[${str}]"; # Stick it in brackets when we return it
}
# ****************************************************************
# Given an expression of the form "[...]", strip the brackets and expand the
# expression into a comma separate list of state numbers.
#
# If it's not what we're expecting we just return it unchanged.
#
sub expand_state_expression ($$) {
my ($lineno, $sexpr) = @_;
my $input = $sexpr;
if ($sexpr !~ /^\s* \[ \s* (.*?) \s* \] \s*$/x) {
return $sexpr; # No match -- it's probably already a list of state IDs or numbers
}
$sexpr = $1; # Discard the brackets and surrounding blanks
$sexpr = state_expression_parser ($lineno, $sexpr); # This normally returns a bracketed list.
if ($sexpr =~ /^\[(.*)\]$/x) { # If it's a pair of brackets around something, strip them.
$sexpr = $1;
}
if ($debug) { print STDERR "expand_state_expression (line=$lineno): ${input} --> ${sexpr}\n"; }
$last_state_expr = $sexpr;
return $sexpr;
}
# ****************************************************************
# Compare a string against a string, or a string against a list of strings, in which
# case it returns true if the comparand matches anything on the list.
# It returns the value of the thing you passed in, or 0.
#
# We currently think all values must be numbers but if it turns out we're trying to pass
# random strings in we'll change the comparisons to work with strings.
#
# Pretty much all blanks are thrown away. The parsing is recursive descent (surprise).
#
# Lexing of '=' is sloppy indeed; it actually accepts '=', '==', '===', ...
#
# Expressions we interpret:
#
# expr == expr exprs evaluate to integers
# expr == [b,c,d...] True if expr is in the set [...].
# expr must be numeric. Returns true if expr==b OR expr==c OR expr==d OR...
# Note that the [] set construction does NOT NEST. You get one level. Be happy with it.
# expr {+,-.*,/,%} expr The obvious. Precedence is multiplication, addition, mod.
# ... (expr) ... Evaluates the inner expr then recurses. IOW they're parens, as you'd expect.
#
# ... <string>(expr) ... Evaluate "<string>(expr)" and substitute it. This takes care of function calls.
# Getting the balanced parens right is a pain.
# The "<string>" can be alphanumeric plus underscores, and can start with a ".".
# If macro calls start with "&" or "%" we will misparse them here.
#
# THERE IS NO UNARY MINUS. Deal with it.
sub eval_expr ($$;$) {
my ($lineno, $expr, $parent_expr) = @_;
if (!defined $parent_expr) { $parent_expr = "<null>"; }
chomp($expr);
dprint "eval_expr (line=$lineno, expr='$expr', parent expr='$parent_expr'\n";
$expr =~ s/^\s*(.*?)\s*$/$1/; # Strip leading and trailing whitespace. In the rest of this we assume it's been stripped.
while ($expr =~ /^\(\s* ([^\(\)]*?) \s*\)$/x) { # Is this an expression in parens, without any embedded parens?
$expr = $1; # If so just strip the parens (and whitespace). This is needed to properly handle subexpressions.
}
my $result;
if ($expr =~ /^! (.*)/x) { # Leading "!" is negation. Precedence is wobbly here.
return ! &eval_expr($lineno, $1, $expr);
}
if ($expr =~ /^([0-9a-z_]+)$/ix) { # A simple value. If it's a number you'll get a number back.
my $term = $1;
if ($term !~ /^[0-9]+$/x) { # If it's not a number you'll get barf.
die "eval_expr: Unexpected characters in term '$term' at line $lineno\n";
}
dprint "eval_expr: Simple value.\n";
$result = $term;
# Nested parens and function calls. This finds the first parenthesized subexpression which contains
# at least one nested subexpression, pulls out the first nested subexpression, evaluates it, pastes
# the result back in and then recurses to evaluate the whole thing.
#
# It also should pull out function calls nested in parens and evaluate them.
#
# Note that we'll see stuff like "... ( .. ) .. (a .. foo(bar) ( .. )b .. ) ..."
# This will identify the section from '(a' to ')b' and pull out the 'foo(bar)' as needing recursion.
# We need to allow the extra parens between )b and the subexpression or we'll miss it when there
# are two subexpressions within on nesting pair of parens
#
} elsif ($expr =~ /^( .* \( [^\)]*? ) # Leading paren for outer group (NOTE the '?' shortest-match character)
( # Subexpression we're doing to evaluate
(?: [\%\&\.]? \w+)? \s* # Optional function name
\( [^\(\)]+ \) # Inner paren group, which may be an argument list
)
( .* \) .* ) $/x) { # Trailing paren for outer group
my ($lhs,$middle,$rhs) = ($1,$2,$3);
dprint "eval_expr: Parenthesized expression, lexed out '$lhs', '$middle', '$rhs'\n";
$middle = &eval_expr ($lineno, $middle, $expr); # Evaluate the subexpression and recurse after pasting it back in
$result = &eval_expr ($lineno, "${lhs}${middle}${rhs}", $expr);
# At this point we should have no nested parentheses. There may be parens in the expression
# but there should be just one level of them.
#
# We next evaluate our special built in functions, and any other function-like objects we may know about
#
} elsif ($expr =~ /^\s*(.*)&scramble\s*\((.*?)\)(.*)/x) { # SPECIAL -- "&scramble" returns a random value based on the input
my ($lhs,$subex,$rhs) = ($1,$2,$3);
dprint "eval_expr: Scramble function call\n";
$subex = &eval_expr($lineno, $subex, $expr);
if ($subex !~ /^[0-9]*$/x) { die "eval_expr: Line $lineno: '$expr' has botched scramble argument -- evals to '$subex'\n"; }
my $rv = $randoms[$subex % scalar(@randoms)];
##my $rv = $subex; # Scrambling just made it all worse at 17, but it's OK at 13.
$result = &eval_expr($lineno, "${lhs}${rv}${rhs}");
} elsif ($expr =~ /^\s*(.*)&perm\s*\((.*?),(.*?),(.*?)\)(.*)/x) { # SPECIAL -- "&perm" returns the next value in a shuffled sequence
my ($lhs,$a1,$a2,$a3,$rhs) = ($1,$2,$3);
dprint "eval_expr: Perm function call\n";
$a1 = &eval_expr($lineno, $a1, $expr);
$a2 = &eval_expr($lineno, $a2, $expr);
$a3 = &eval_expr($lineno, $a3, $expr);
my $rv = permutation_next ($a1, $a2, $a3);
$result = &eval_expr($lineno, "${lhs}${rv}${rhs}", $expr);
# Set membership operator
#
} elsif ($expr =~ /^(?: (.*?) # Expr on the left
\s* ( != | ==? ) \s*
)?
( \[ .*? \] ) # Set on the right
$/x) {
$result = 0;
my ($lhs, $op, $rhs) = ($1, $2, $3);
if (! defined $lhs) { # Bare state string?
$result = expand_state_expression ($lineno, $rhs);
$result =~ s/\[(.*)\]/$1/; # Strip brackets which expand_state_expression wraps around stuff
} else { # In this case it's a state membership check, which will eval to a boolean
dprint "eval_expr: Set membership: '$lhs', '$op', '$rhs'\n";
$lhs = &eval_expr ($lineno, $lhs, $expr); # Recurse in case the LHS is more complicated than a simple number
dprint "eval_expr (at $lineno, expr='$expr'): Calling expand_state_expression with '$rhs'\n";
$rhs = expand_state_expression ($lineno, $rhs);
dprint "eval_expr: expand_state_expression returned '$rhs'\n";
foreach my $r (split /,/, $rhs) {
$r = &eval_expr ($lineno, $r, $expr); # Recurse in case we think of a use for an expression in a set
if ($lhs eq $r) {
$result = 1;
last;
}
}
if ($op eq "!=") { # If it's a !=, negate the result
$result = ! $result;
}
}
# We've evaluated all function calls. If there are any parens left, they are just for grouping.
# We evaluate them now. We check first to see if there are any leftover function calls; if there
# are we blew the parsing somewhere.
#
} elsif ($expr =~ /^.*\w\s* # End of a function name (the \w) and trailing blanks
\( .* \) # Argument list
.* $/x) {
die "eval_expr line $lineno: We found a function call in '$expr', parent expression '$parent_expr'-- we thought we'd already substituted all of them.\n";
} elsif ($expr =~ /^(.*?) # A parenthesized subexpression (the '?' character is optional here)
\( ([^\(\)]+) \) # Subexpression bounded by parens, with no parens inside
(.*) $/x) {
my ($lhs,$middle,$rhs) = ($1,$2,$3);
dprint "eval_expr: parenthesized subexpression: '$lhs', '$middle', '$rhs'\n";
$middle = &eval_expr ($lineno, $middle, $expr); # Evaluate the subexpression and recurse after pasting it back in
$result = &eval_expr ($lineno, "${lhs}${middle}${rhs}", $expr);
# Simple comparison
#
} elsif ($expr =~ /^(.*?) \s* ( != | ==?) \s* (.*?)$/x) { # Comparison of two simple values
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &eval_expr ($lineno, $lhs, $expr);
$rhs = &eval_expr ($lineno, $rhs, $expr);
$result = $lhs == $rhs;
if ($op eq "!=") {
$result = ! $result;
}
# Arithmetic stuff
#
} elsif ($expr =~ /^\s*(.*?)(%)(.*?)\s*$/x) { # Mod -- lowest precedence of the numeric operators
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &eval_expr ($lineno, $lhs, $expr);
$rhs = &eval_expr ($lineno, $rhs, $expr);
$result = $lhs % $rhs;
} elsif ($expr =~ /^\s*(.*)([-+])(.*?)\s*$/x) { # Plus and minus. Need greedy matching on the left to force left association.
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &eval_expr ($lineno, $lhs, $expr);
$rhs = &eval_expr ($lineno, $rhs, $expr);
if ($op eq "+") {
$result = $lhs + $rhs;
} else {
$result = $lhs - $rhs;
}
} elsif ($expr =~ /^\s*(.*)([\*\/])(.*?)\s*$/x) { # Times and division -- highest precedence of the ones we interpret
my ($lhs,$op,$rhs) = ($1,$2,$3);
$lhs = &eval_expr ($lineno, $lhs, $expr);
$rhs = &eval_expr ($lineno, $rhs, $expr);
if ($op eq "\*") {
$result = $lhs * $rhs;
} else {
$result = $lhs / $rhs;
}
} else {
die "eval_expr: near line $lineno: Don't understand '$expr'\n" .
" containing expr = '${parent_expr}'";
}
if ($debug) { print STDERR "Eval_expr returning $result\n"; }
return $result;
}
# ****************************************************************
# Define a macro, with or without an argument list
sub define_macro ($) {
my ($inp) = @_;
if ($inp =~ /^\s*(.*?)\((.*?)\)\s+(.*?)\s*$/x) { # Macro with an argument list
my ($al,$to) = ($2,$3);
if ($debug) { print STDERR "define_macro: Defining '$1' with args '$al' and body '$to'\n"; }
$simple_macros{$1} = $3;
my @args = split /,/, $al;
$macro_args{$1} = \@args;
} elsif ($inp =~ /^\s*(.*?)\s+(.*?)\s*$/x) { # Macro with no argument list
if ($debug) { print STDERR "define_macro: Defining '$1' with body '$2'\n"; }
$simple_macros{$1} = $2;
} else {
die "define_macro: Didn't understand '$inp'\n";
}
}
# ****************************************************************
# Preprocess macro definitions in one line. Returns true if it eats the line.
my $pp_defining = 0;
my $pp_defining_state = 0;
my $pp_name = undef;
my $pp_text = "";
my $pp_state_name;
my $pp_base_state_name;
my $pp_new_inventory = [""]; # One blank line for the header text
my $pp_new_attributes = [];
my %pp_new_inventory_flags;
my %pp_new_attribute_flags;
sub preprocess_defs ($$) {
my ($lineno, $line) = @_;
if ($debug) { print STDERR "preprocess_defs(line $lineno) processing '$line'\n"; }
if ($pp_defining) {
if ($line =~ /^\#defend/x) { # If it's the end of the def, record it.
if ($pp_defining_state) {
die "preprocess_defs (line=$lineno): Defining a state, encountered a defend: '$line'\n";
}
$simple_macros{$pp_name} = $pp_text;
$pp_name = undef;
$pp_text = "";
$pp_defining = 0;
} elsif ($line =~ /^\#endstate/x) {
if (! $pp_defining_state) {
die "preprocess_defs (line=$lineno): Defining a macro, encountered an endstate: '$line'\n";
}
my $pp_state_number = $state_names{$pp_state_name}; # Get the state number for the state
if (! defined $pp_state_number) { # Allocate it if necessary
$last_state_number++;
$pp_state_number = $last_state_number;
$state_names{$pp_state_name} = $pp_state_number;
}
my $in_header = 0;
my $htext;
my $ftext; # Footer text
my $share_ilist = 1; # If there are no changes to the ilist we should share it
foreach my $l (split /\n/,$pp_text) {
if ($l =~ /^\s* h: (.*?) \s*$/x) {
$share_ilist = 0; # Any change to the inventory list => we can't share it
dprint "process_defs: Header text line '$l'\n";
$in_header = 1;
$htext = $1;
} elsif ($l =~ /^\s* f: (.*?) \s*$/x) {
$share_ilist = 0; # Any change to the inventory list => we can't share it
dprint "process_defs: Footer text line '$l'\n";
$in_header = 0;
$ftext = $1;
} elsif ($l =~ /^\s* \+: (?: \s* (.*?) \s*\|)? (.*?) \s*$/x) {
$share_ilist = 0; # Any change to the inventory list => we can't share it
$in_header = 0;
my ($tag,$item) = ($1,$2);
if (defined $tag && $tag =~ /^\s*$/) { $tag = undef; }
if ($item && $item =~ /^\s*$/) { $item = undef; }
dprint "process_defs: Inventory addition line '$l'\n";
if (defined $tag) { # Does the line have a tag? If so there's some special handling
dprint "proprocess_defs: Adding inventory item; tag='$tag'\n";
if ($item) { # Do we have an inventory string?
dprint "proprocess_defs: Adding tagged inventory item '$item'\n";
my $old = $tag_to_inventory_item {$tag};
if ($old) {
if ($old ne $item) {
die "At $lineno: Tag '$tag' was '$old', redefined to be '$item'\n";
}
}
$tag_to_inventory_item{$tag} = $item;
$inventory_item_to_tag{$item} = $tag;
}
}
if (! $item) {
$item = $tag_to_inventory_item{$tag};
if (!$item) {
die "Line $lineno: Inventory item tag '$tag' without an item, and no previous tag definition\n";
}
}
push @$pp_new_inventory, $item;
$pp_new_inventory_flags{$item} = 1;
} elsif ($l =~ /^\s* \-: (?: \s* (.*?) \s*\|)? (.*?) \s*$/x) {
$share_ilist = 0; # Any change to the inventory list => we can't share it
$in_header = 0;
my ($tag,$item) = ($1,$2);
if (! $item) {
$item = $tag_to_inventory_item{$tag};
if (! $item) {
die "Line $lineno: '$l': Can't figure out what you're trying to delete\n";
}
}
$pp_new_inventory_flags{$item} = -1;
} elsif ($l =~ /^\s* \+a: \s* (?: (.*?) \s*\|)? (.*?) \s*$/x) { # Attribute line
$in_header = 0;
my ($tag,$item) = ($1,$2);
if (defined $tag && $tag =~ /^\s*$/) { $tag = undef; }
if ($item && $item =~ /^\s*$/) { $item = undef; }
if (defined $tag) { # Does the line have a tag? If so there's some special handling
if ($item) { # Do we have an inventory string?
my $old = $tag_to_attribute {$tag};
if ($old) {
if ($old ne $item) {
die "At $lineno: Attribute tag '$tag' was '$old', redefined to be '$item'\n";
}
}
$tag_to_attribute{$tag} = $item;
}
}
if (! $item) {
$item = $tag_to_attribute{$tag};
if (!$item) {
die "Line $lineno: Attribute item tag '$tag' without an item, and no previous tag definition\n";
}
}
push @$pp_new_attributes, $item;
$pp_new_attribute_flags{$item} = 1;
} elsif ($l =~ /^\s* \-a: (?: \s* (.*?) \s*\|)? (.*?) \s*$/x) {
$in_header = 0;
my ($tag,$item) = ($1,$2);
if (! $item) {
$item = $tag_to_attribute{$tag};
if (! $item) {
die "Line $lineno: '$l': Can't figure out what you're trying to delete\n";
}
}
$pp_new_attribute_flags{$item} = -1;
} elsif ($in_header) {
$htext .= "\n$l";
} else {
die "Parsing state (line=$lineno): Didn't understand '$l'\n";
}
}
if ($pp_base_state_name) {
my $osn = $state_names{$pp_base_state_name}; # Old state number
my $oin = $shared_ilist_for_state{$osn}; # The old inventory number
if (! defined $oin) { # If it isn't sharing, use its state number
$oin = $osn;
}
if ($share_ilist) { # Are we sharing the base state's list?
$shared_ilist_for_state{$pp_state_number} = $oin; # Share the one it shared!
}
my $old_inventory = $state_ilists[$osn]; # But use the actual state's lists to diff from
if (!defined $old_inventory) {
die "Line $lineno: Building state $pp_state_name from $pp_base_state_name: No old inventory list found\n";
}
$$pp_new_inventory[0] = $$old_inventory[0]; # Default to the header text from the old inventory list
foreach my $i (1..$#$old_inventory) { # Any old inventory item which hasn't already been added or deleted, we should add.
my $item = $$old_inventory[$i];
if (! $pp_new_inventory_flags{$item}) {
push @$pp_new_inventory, $item;
}
}
my $old_attributes = $state_attributes[$osn];
if (!defined $old_attributes) {
die "Line $lineno: Building state $pp_state_name from $pp_base_state_name: No old attribute list found\n";
}
foreach my $i (0..$#$old_attributes) { # Any old inventory item which hasn't already been added or deleted, we should add.
my $item = $$old_attributes[$i];
if (! $pp_new_attribute_flags{$item}) {
push @$pp_new_attributes, $item;
}
}
} elsif ($share_ilist) {
die "State ${pp_state_name}, ${pp_state_number}: We're supposed to share the ilist but there's no base state\n";
}
if ($htext) { # If we have new header text, pick it up now (overwrite any old header)
$$pp_new_inventory[0] = $htext;
}
if ($debug) { print STDERR "Set state $pp_state_name inventory to $#$pp_new_inventory elements, first is $$pp_new_inventory[0]\n"; }
if (1 || !$share_ilist) {
if ($debug) { print STDERR "State $pp_state_name, number $pp_state_number, got its own inventory list (but may not get a room for it)\n"; }
$state_ilists[$pp_state_number] = $pp_new_inventory; # Save the list if we're not sharing.
$state_attributes[$pp_state_number] = $pp_new_attributes;
} elsif ($debug) {
if ($debug) { print STDERR "State $pp_state_name, number $pp_state_number, is sharing ilist $shared_ilist_for_state{$pp_state_number} \n"; }
}
$pp_text = "";
$pp_defining = 0;
$pp_defining_state = 0;
$pp_state_name = undef;
$pp_base_state_name = undef;
$pp_new_inventory = [""];
$pp_new_attributes = [];
%pp_new_inventory_flags = ();
%pp_new_attribute_flags = ();
} elsif ($line =~ /^#/ &&
($line !~ /^\#(?:end)?if/ && $line !~ /\#\?/ && $line !~ /^\#else/x)) { # We skip the conditionals for now.
die "Line $lineno: Unexpected preprocessor directive while defining a macro or state: '$line'\n";
} else {
if ($pp_text ne "") {
$pp_text .= "\n";
}
$pp_text .= "${line}";
}
return 1;
} elsif ($line =~ /^\#defbegin/x) {
if ($line =~ /^\#defbegin\s+(.*?)\((.*?)\)\s*$/x) { # Macro with an argument list
my ($al) = ($2);
$pp_name = $1;
if ($debug) { print STDERR "preprocess_defs: Defining macro '$pp_name' with args '$al'\n"; }
my @args = split /,/, $al;
$macro_args{$pp_name} = \@args;
$pp_defining = 1;
} elsif ($line =~ /^\#defbegin\s+(.*?)\s*$/x) {
$pp_name = $1;
if ($debug) { print STDERR "preprocess_defs: Defining macro '$pp_name' with no arguments\n"; }
$pp_defining = 1;
} else {
die "preprocess_defs: Line $lineno: Didn't understand line $line\n";
}
return 1;
} elsif ($line =~ /^\#define\s*(.*)/x) {
define_macro ($1);
return 1;
} elsif ($line =~ /^\#state\s* \( # State begin tag
\s* (.*?) \s* # State name
(?:,\s* (.*?) \s*)? # Optional name of state on which to build it
\)\s*$/x) {
$pp_state_name = $1;
$pp_base_state_name = $2;
$pp_defining_state = 1;
$pp_defining = 1;
} elsif ($line =~ /^\#(?:end)?if/ || $line =~ /\#\?/ || $line =~ /^\#else/x) { # We skip the conditionals for now.
return 0;
} elsif ($line =~ /^\#[a-zA-Z]/x) {
die "preprocess_defs: line $lineno: Didn't understand '$line'\n";
}
return 0;
}
# ****************************************************************
# Expand all macros in an array of lines and return the newly expanded
# array along with a flag indicating whether we did anything
#
sub expand_macros_once ($$$) {
my ($lineno,$input,$show) = @_;
my $expanded_something = 0;
my @output = ();
foreach my $i (0..$#$input) { # We don't use "foreach <elt> (array)" 'cause it gives us a live copy of the line, I think
my $l = $$input[$i];
my $expanded_this_line = 0;
#
# Expand the simple ones...
#
foreach my $k (keys %simple_macros) {
if ($l !~ /\Q$k\E\b/) { next; } # We do NOT require a word break BEFORE the macro, only after
$expanded_this_line = 1;
my $v = $simple_macros{$k};
if ($macro_args{$k}) {
if ($l !~ /(\Q$k\E\s*\((.*?)\))/) {
die "Argument list missing, expanding macro '$k' near line $lineno\n";
}
my $sub_for = $1;
my @actuals = split /,/,$2;
my $formals = $macro_args{$k};
if ($#$formals != $#actuals) { die "expand_macro_once(line ~ $lineno) Wrong number of arguments for '$k', expanding '$l'\n"; }
foreach my $j (0..$#$formals) { # As with the macro defs, we don't require a word break *before* the arg.
my $formal = $$formals[$j];
my $actual = $actuals[$j];
$v =~ s/\Q${formal}\E\b/${actual}/g; # Substitute into the macro definition
}
$l =~ s/\Q$k\E\s*\(.*?\)/$v/; # Do NOT use '/g' here, as we need to re-eval the actuals every time
} else {
$l =~ s/\Q$k\E\b/$v/g;
}
}
foreach my $k (keys %state_names) {
if ($l !~ /\Q$k\E\b/) { next; } # We require a word boudary at the END of the state name, not the beginning!!
my $v = $state_names{$k};
$l =~ s/\Q$k\E\b/$v/g;
}
# We may have a multiline expansion. To make sure things work right we need to split it into lines.
if (!$expanded_this_line) { # If we didn't expand it just put it on the output intact
push @output, $l; # If we try to split it we kill blank lines.
} else {
$expanded_something = 1; # If we expanded it, split it into lines
my @lines = split /\n/,$l;
foreach my $j (0..$#lines) {
chomp (my $piece = $lines[$j]);
if ($j != $#lines || $piece ne "") { # Do NOT push the 'extra' blank line we get courtesy of split
push @output, "$piece";
}
}
}
}
return ($expanded_something,\@output);
}
# ****************************************************************
# Expand all macros in an array of lines repeatedly until it settles down
sub expand_macros ($$$) {
my ($lineno,$lines,$show) = @_;
my $expanded_something = 1;
while ($expanded_something) {
$expanded_something = 0;
($expanded_something, $lines) = expand_macros_once ($lineno, $lines, $show);
}
return $lines;
}
# ****************************************************************
# Handle conditionals. We do this very late so all expansions have already
# been done, and we can, consequently, conditionalize on the current state.
# We do this a line at a time because the room parser is doing its own substitutions
# a line at a time, and we need to get hold of the lines *after* that substitution
# has been done, since that's what puts the current state values into the text.
#
# An if/else/endif can span macro boundaries, which is weird; it's because we
# process the conditionals after macro expansion.
#
# Returns 1 if it eats the line, 0 otherwise.
#
# Nesting is the obvious, with else/endif associated with the nearest if.
#
#
# We're not called from a recursive descent parser here and we have no convenient way
# to recurse so we're just going to handle the nesting manually
#
my $pp_nest_level = 0;
my @saved_pp_start_line;
my @saved_pp_condition_skipping;
my @saved_pp_inside_if;
my @saved_pp_skip_else;
my @saved_pp_skip_whole_thing;
my $pp_start_line;
my $pp_condition_skipping;
my $pp_inside_if;
my $pp_skip_else;
my $pp_skip_whole_thing; # Set => we're skipping a nested if construct
sub handle_conditions ($$) {
my ($lineno, $line) = @_;
my $result = 0;
if ($debug) { print STDERR "handle_conditions(lineno=$lineno): '$line'\n"; }
if ($line =~ /^#if\b/ && $pp_inside_if) { # Whoops -- recursion time!
push @saved_pp_start_line, $pp_start_line;
push @saved_pp_condition_skipping, $pp_condition_skipping;
push @saved_pp_inside_if, $pp_inside_if;
push @saved_pp_skip_else, $pp_skip_else;
push @saved_pp_skip_whole_thing, $pp_skip_whole_thing;
if ($pp_condition_skipping) { $pp_skip_whole_thing = 1; } # If not skipping leave this set to whatever it was set to
$pp_start_line = undef;
$pp_condition_skipping = undef;
$pp_inside_if = undef;
$pp_skip_else = undef;
$pp_nest_level++;
}
if (! $pp_inside_if) {
if ($line =~ /^#else/ || $line =~ /^#endif/) {
die "WHOOPS -- line $lineno, text '$line': else or endif not inside an if\n";
}
if ($line =~ /^#if\b/) {
if ($debug) { print STDERR "Found 'if' at line $lineno\n"; }
$pp_start_line = $lineno;
$result = 1;
$pp_inside_if = 1;
$pp_skip_else = 1;
if ($line =~ /^#if\s*\((.*)\)\s*$/) {
my $ok = eval_expr ($lineno,$1);
if (! $ok) {
$pp_condition_skipping = 1;
$pp_skip_else = 0; # We will NOT skip the else
}
} else {
die "handle_conditions: Somewhere around $lineno: Didn't understand '$line'\n";
}
}
} elsif ($line =~ /^#elseif\b/) {
$result = 1;
if ($line =~ /^#elseif\s*\((.*)\)\s*$/) {
$pp_condition_skipping = $pp_skip_else; # If we had an accepted if, then we're skipping all else clauses
if (! $pp_condition_skipping) { # Not just skipping -> check the condition
$pp_condition_skipping = ! eval_expr ($lineno,$1);
}
if (! $pp_condition_skipping) {
$pp_skip_else = 1; # We want to skip any further 'else' clauses in this if, if we don't skip this one.
}
} else {
die "handle_conditions: Somewhere around $lineno: Didn't understand '$line'\n";
}
} elsif ($line =~ /^#else\b/) {
$pp_condition_skipping = $pp_skip_else;
$result = 1;
} elsif ($line =~ /^#endif\b/) {
$pp_condition_skipping = 0;
$pp_skip_else = 0;
$pp_inside_if = 0;
$result = 1;
if ($pp_nest_level) { # Time to pop the old state back
$pp_start_line = pop @saved_pp_start_line;
$pp_condition_skipping = pop @saved_pp_condition_skipping;
$pp_inside_if = pop @saved_pp_inside_if;
$pp_skip_else = pop @saved_pp_skip_else;
$pp_skip_whole_thing = pop @saved_pp_skip_whole_thing;
$pp_nest_level --;
}
} elsif ($pp_condition_skipping || $pp_skip_whole_thing) {
$result = 1;
} else { # In this case we're in an 'if' but we're not skipping it.
$result = 0;
}
return $result;
}
# ****************************************************************
# Call as: parse_room_worker ($sub_for, $to_term, $room_p, $room_start_line, $show);
#
# We have one (or more) builtin macro(s) as well. We expand them here after all
# other expansions are done, because we want to be able to look up room names, and
# the room names are built from the state tag which is substituted in here when
# we instantiate the room.
#
# .RINDEX (room-name) ... Expands into the (final, optimized) room number for "room-name"
# Note that if "room-name" is written as "Smoof-fooble-X" where "X" is
# the current room state, "X" must be substituted BEFORE .RINDEX is
# expanded, or it won't work.
#
my $roomno;
##my @room;
my @from_strings;
my @to_strings;
sub parse_room_worker ($$$) {
my ($room, $room_start_line, $show) = @_;
my $lineno = $room_start_line;
my $get_room_name = 1;
my $parsed_room = "";
if ($debug) {
print STDERR "parse_room_worker called for room at line $room_start_line with $#from_strings translations\n";
foreach my $t (0..$#from_strings) {
print STDERR " $from_strings[$t] --> $to_strings[$t]\n";
}
}
$roomno++;
foreach my $raw_l (@$room) {
$lineno++;
my $line = $raw_l; # Copy it so we don't bash the original
if (scalar(@from_strings)) { # If we've got some substitutions to perform
foreach my $s (0..$#from_strings) {
my $f = $from_strings[$s];
my $t = $to_strings[$s];
$line =~ s/\b${f}\b/${t}/g; # For the state tags we require a word break before AND after
}
}
if (handle_conditions ($lineno,$line)) {
next;
}
if ($get_room_name) {
if ($line =~ /=/) { # If there's an equals, it's a substitution spec and not a room name.
next;
}
$get_room_name = 0;
if ($line !~ /^(?: \|\{\{ )?
( [a-z0-9-_]+ )
(?: \}\}= )?
/xi) {
if ($line =~ /Dummy/) { # This is the dummy room at the end. Discard it.
$get_room_name = 0;
$roomno --;
next;
}
die "Room name not found where expected on line $lineno\n";
}
my $rn = $1;
if (!$show) {
if ($room_names{$rn}) {
die "Room $rn already defined at line $lineno\n";
}
if ($debug) { print STDERR "Setting $rn to number $roomno\n"; }
$room_names{$rn} = $roomno;
} else {
if (!defined $room_names{$rn}) {
die "On show pass, and room $rn not defined when we got to it\n";
}
if ($roomno != $room_names{$rn}) {
die "On show pass, and room number of '$rn' changed from $room_names{$rn} to $roomno\n";
}
}
if ($cv_to_singlefile) {
if ($show && $optimize) {
$parsed_room .= "|$alpha_room_ids{$rn}=\n";
} else {
$parsed_room .= "|{{TheStenchIndex|${rn}}}=\n";
}
} else {
$parsed_room .= "$rn\n";
}
} else {
#
# Expand our builtin macro(s). They (or it) are wired in, hard coded, right here.
#
my $rname_macro;
$rname_macro = ".ILIST"; # Inventory list for a state. Parens mis-parse, so just give it a simple state name
while ($line =~ /\Q${rname_macro}\E\s*\((.*?)\)/) {
my $inum = $shared_ilist_for_state{$1};
if (! defined $inum) {
$inum = $1;
}
$line =~ s/\Q${rname_macro}\E\s*\((.*?)\)/$inum/;
}
$rname_macro = ".PERM"; # Permutation-next operation for maze building
while ($line =~ /\Q${rname_macro}\E\s*\(\s*(.*?)\s*,\s*(.*?)\s*,\s*(.*?)\s*\)/) {
my $inum = permutation_next($1, $2, $3);
if (! defined $inum) {
$inum = $3;
}
$line =~ s/\Q${rname_macro}\E\s*\((.*?)\)/$inum/;
}
$rname_macro = ".EXPR"; # Arbitrary expression. Parens probably mis-parse so this is kinda useless.
while ($line =~ /\Q${rname_macro}\E\s*\((.*)\)/) {
my ($subex) = ($1);
my $inum = eval_expr($lineno,$subex);
if (! defined $inum) {
$inum = $subex;
}
$line =~ s/\Q${rname_macro}\E\s*\((.*)\)/$inum/;
}
$rname_macro = ".RINDEX"; # That's "Room Index". Parens mis-parse.
while ($line =~ /\Q${rname_macro}\E\s*\((.*?)\)/) {
my $rn = $1;
my $rnum = $alpha_room_ids{$rn};
if (! defined $rnum) {
if ($show) { die "expand_macros_once, at line ${lineno}: ${rname_macro}(${1}): Room not defined\n"; }
$rnum = -1;
}
$room_used{$rn} = 1; # Macro argument counts as a use of the room name
$line =~ s/\Q${rname_macro}\E\s*\((.*?)\)/$rnum/;
}
$rname_macro = ".ERROR"; # Barf.
if ($show && $line =~ /\Q${rname_macro}\E/) {
die ".ERROR macro found at $lineno\n";
}
if ($line =~ /(.*?) \[\[\.\.\/ # Lex out a link. Start with stuff on the line before the link
(.*?) \| (.*) # The pipe link itself ($2 and $3)
\]\] (.*)/x) { # Trailing stuff on the line
my $line_prefix = $1;
my $rname = ucfirst($2);
my $link_text = $3;
my $line_suffix = $4;
if ($show && !defined($room_names{$rname})) {
print STDERR "Whoops! Room '$rname' at line $lineno is not defined!\n";
}
$room_used{$rname} = 1; # Note that someone links to this room
if ($cv_to_singlefile) {
if (! $optimize) {
$parsed_room .= "${line_prefix}{{Goto|{{TheStenchIndex|${rname}}}|${link_text}}}${line_suffix}\n";
} elsif ($show && defined $room_names{$rname}) {
$parsed_room .= "${line_prefix}{{Goto|$alpha_room_ids{$rname}|${link_text}}}${line_suffix}\n";
} else {
$parsed_room .= "${line_prefix}{{Goto|-1|${link_text}}}${line_suffix}\n";
}
} else {
$parsed_room .= "${line_prefix}[[../${rname}|${link_text}]]${line_suffix}\n";
}
} else {
$parsed_room .= "${line}\n";
}
}
}
push @room_array, $parsed_room;
}
# ****************************************************************
#
# Args:
#
# \@room_line_array
# \@subst_arrays
# $room_start_line
#
# Pass in an array of lines, which is the room spec, and an array of substititions
# to be made, where each sub is a pair "string", "string".
# It also takes a starting line number, so it can figure out what line number to complain
# about when there's an error.
sub parse_room ($$$) {
my ($room, $room_start_line, $show) = @_;
#
# I have no idea why, but we're getting an undef in slot 0 of room, apparently coming from nowhere.
# --> I was setting the list to undef (aka "(undef)") instead of "()" whoops
# if (0 && !defined $$room[0]) { shift @$room; }
if ($debug) {
my $n = 0;
print STDERR "Room (with $#$room + 1 lines):\n";
foreach my $l (@$room) {
$n++;
print STDERR "Line $n: '${l}'\n";
}
print STDERR "End room.\n";
}
$room = expand_macros ($room_start_line, $room, $show); # Expand everything in it so we can parse it after expansion
if ($debug) {
my $n = 0;
print STDERR "Room after macro expansion (with $#$room + 1 lines):\n";
foreach my $l (@$room) {
$n++;
print STDERR "Line $n: '${l}'\n";
}
print STDERR "End room.\n";
}
@from_strings = ();
@to_strings = ();
my @to_string_list;
my $line = $$room[0];
if ($debug) {
my $rl = scalar (@$room);
print STDERR "Room lines: $rl; Line: $line\n";
}
if ($line =~ /=/) { # Sub strings of form "A = B, ..."
my $how_many;
while (defined $line && $line =~ /^ \s*(.+?)\s* = \s*(.+?)\s*
(?:;(.*))? $/x
) {
my ($sub_for, $sub_to, $tail) = ($1,$2,$3);
#
# We'll now attempt to parse all bracketed subexpressions before we split the list
#
while ($sub_to =~ /(.*) (\[ [^\[\]]* \]) (.*)/x) {
my ($front, $mid, $back) = ($1, $2, $3);
$mid = expand_state_expression ($room_start_line, $mid);
$sub_to = "${front}${mid}${back}";
}
my @sub_to_list;
my @sub_exprs = split /,/,$sub_to; # This is a hack. If there are commas inside brackets we'll mess up.
foreach my $se (@sub_exprs) { # Expand each term in the comma separated list
$se = expand_state_expression ($room_start_line, $se);
foreach my $piece (split /,/, $se) { # And then split it and push the pieces
push @sub_to_list, $piece;
}
}
if (!defined $how_many) {
$how_many = scalar(@sub_to_list); # Note this. We use the number on the first list.
}
push @from_strings, $sub_for; # Array of from strings
push @to_string_list, \@sub_to_list; # Array of target lists
$line = $tail; # discard the head, which we've already used
}
foreach my $t (0..$how_many-1) { # For each target, set up the translations for one instantiation
foreach my $i (0..$#from_strings) { # Set up the global "to" list
my $tl = $to_string_list[$i];
$to_strings[$i] = $$tl[$t]; # Pick the current translation off the list for this 'from' variable
if (! defined $to_strings[$i]) {
$to_strings[$i] = $$tl[0]; # Use the first one if we've run off the end.
}
}
if ($debug) {
print STDERR "Substituting for one instantiation:\n";
foreach my $s (0..$#from_strings) {
print STDERR " $from_strings[$s] --> $to_strings[$s]\n";
}
}
parse_room_worker ($room, $room_start_line, $show);
}
} else {
if ($debug) { print STDERR "Calling parse_room_worker with no translation\n"; }
parse_room_worker ($room, $room_start_line, $show);
}
}
# ****************************************************************
sub parse_file ($) {
my ($show) = @_;
print STDERR "parse_file(show=$show)\n";
@room_array = ();
$roomno = -1;
my $room_line_no = 0;
my $lineno = 0;
my @room = ();
my $in_room = 0;
my $input_room_count = 0;
my $in_comment = 0;
open INFILE, $filename or die "Can't open input file";
while (my $line = <INFILE>) {
chomp($line);
$lineno++;
# Strip comments
if (! $keep_comments) {
if ($in_comment) { # Are we stripping a multiline comment?
if ($line =~ /-->(.*)/) { # Comment terminator?
my $tail = $1;
$in_comment = 0; # Done with that comment
$line =~ s/^.*?-->\s*//; # Strip the terminator from the front of the line
if ($line =~ /^\s*$/) { # Nothing but blanks left?
next; # Discard the line
}
} else { # No terminator => just discard the line and keep going
next;
}
}
if ($line =~ /<!--.*-->/) { # Remove balanced comments and surrounding blanks
$line =~ s/\s*<!--.*?-->\s*//g;
if ($line =~ /^\s*$/) { # If there was nothing but a comment skip the line
next;
}
}
if ($line =~ /<!--/) { # Remove comment start (and preceding blanks) and move to comment state
$line =~ s/\s*<!--.*//;
$in_comment = 1;
if ($line =~ /^\s*$/) { # If there's nothing on the line but blanks and a comment start, discard it
next;
}
}
} # if
if (preprocess_defs($lineno,$line)) {
next;
}
if ($line =~ /^(<!--\s*)?=============*(\s*-->)?$/) {
if ($debug) { print STDERR "Found a room divider\n"; }
$in_room = 1;
if (scalar(@room) > 0) { # Do we have an old one which needs to be parsed?
if ($debug) { print STDERR "At line $lineno: Looks like room was defined, with last line $#room, so we're parsing it\n"; }
parse_room (\@room, $room_line_no, $show);
$input_room_count ++;
}
@room = ();
$room_line_no = $lineno; # Starting line number for the next room
} elsif ($in_room) {
if ($debug) { print STDERR "Pushing line '$line' into room\n"; }
push @room, $line;
}
}
close INFILE or die "Error closing file $filename";
# If we had a last room which wasn't appended, append it now
if (scalar(@room) > 0) {
if ($debug) { print STDERR "At line $lineno: Looks like room was defined so we're parsing it\n"; }
parse_room (\@room, $room_line_no, $show);
$input_room_count ++;
@room = ();
}
#
# And now, add a "room" for each state, containing the inventory for that state
#
foreach my $s (sort keys %state_names) {
$room_line_no = $lineno;
@room = ();
my $snumber = $state_names{$s};
my $inv = $state_ilists[$snumber];
if (defined $shared_ilist_for_state{$snumber}) {
next; # Skip states that share someone else's inventory list
}
if (!defined $inv) {
print STDERR "Shared ilists:\n";
foreach my $k (keys %shared_ilist_for_state) {
print STDERR " $k --> $shared_ilist_for_state{$k}\n";
}
die "State $s, number $snumber, has no inventory list\n";
}
push @room, "================================================================";
$lineno++;
push @room, "01-Inventory-${snumber}";
$lineno++;
push @room, "<!-- Inventory for state $snumber -->";
$lineno++;
foreach my $line (@$inv) {
push @room, $line;
$lineno++;
}
push @room, ".NOINVENTORY";
$lineno++;
parse_room (\@room, $room_line_no, $show);
}
if ($show) {
if ($cv_to_singlefile) {
if (defined $simple_macros{".TITLE"}) {
chomp(my $ttext = $simple_macros{".TITLE"});
print "{{title|${ttext}}}\n";
}
print "{{#switch:{{Get}}\n";
}
my $output_room_count = 0;
foreach my $k (sort keys %room_names) {
if ($debug) { print STDERR "Printing room $k, key $room_names{$k}\n"; }
my $r = $room_array [$room_names{$k}];
$output_room_count++;
if ($cv_to_singlefile) {
if (! $optimize) {
print "<!--================================================================-->\n";
}
} else {
print "================================================================\n";
}
print $r;
}
if ($cv_to_singlefile) {
$output_room_count++;
print "<!--================================================================-->\n";
print "<!-- Dummy room to soak up gotos that get lost in space -->\n";
print "|\n";
if (defined $simple_macros{".DUMMY"}) {
my $rv = $simple_macros{".DUMMY"};
print "$rv\n";
} else {
print "''You have fallen through a hole in the air.''\n";
print "\n";
print "''This room does not exist.''\n";
print "\n";
print "''There is just one exit from the room.''\n";
print "\n";
print "* [[Special:Random|Leave the room]]\n";
print "* {{Goto|0|Start over}}\n";
print "\n";
print "{{TheStench}}\n";
}
print "}}\n";
}
print STDERR "Read $input_room_count rooms, emitted $output_room_count rooms\n";
}
}
# ****************************************************************
parse_file (0); # Build the index
# Build the sorted index, which we use for optimized output as well as for dumping the index
my $room_no = 0;
foreach my $r (sort keys %room_names) {
$alpha_room_ids{$r} = $room_no;
$room_no++;
}
# If we're building the file, do that now
if (! $index_only) {
parse_file (1);
my $had_orphans = 0;
foreach my $k (sort keys %room_names) {
if (! defined $room_used{$k}) {
if (!$had_orphans) {
print STDERR "Orphaned rooms:\n";
}
$had_orphans++;
print STDERR " ${k}\n";
}
}
my $had_undefs = 0;
foreach my $k (sort keys %room_used) {
if (! defined $room_names{$k}) {
if (!$had_undefs) {
print STDERR "Undefined rooms:\n";
}
$had_undefs ++;
print STDERR " ${k}\n";
}
}
print STDERR "Total undefined rooms: ${had_undefs}; Total orphaned rooms: ${had_orphans}\n";
}
# If we're building the index, dump it
if ($index_only) {
print "<noinclude>Template to convert room name to index</noinclude>\n";
print "{{#switch: {{{1}}}\n";
foreach my $r (sort keys %room_names) {
print "| $r = $alpha_room_ids{$r}\n";
$room_no++;
}
print "| -1}}\n\n";
print "<noinclude>[[Category:Templates]]</noinclude>\n";
}