File Coverage

blib/lib/Games/ScottAdams/Action.pm

Criterion	Covered	Total	%
statement	98	104	94.2
branch	27	38	71.0
condition	5	9	55.5
subroutine	16	16	100.0
pod	0	13	0.0
total	146	180	81.1

# $Id: Action.pm,v 1.5 2006/11/04 10:11:11 mike Exp $

# Action.pm - an action in a Scott Adams game.

package Games::ScottAdams::Action;
use strict;


sub new {
    my $class = shift();
    my($verb, $noun, $num) = @_;

    return bless {
	verb => $verb,
	noun => $noun,
	num => $num,		# 0-based index into Game's list of actions
				### I don't think we actually use this
	comment => undef,	# optional comment to be written through
	cond => [],		# array of conditions to be satisfied
	res => [],		# array of results to be executed
    }, $class;
}


sub verb {
    my $this = shift();
    return $this->{verb};
}

sub noun {
    my $this = shift();
    return $this->{noun};
}

sub comment {
    my $this = shift();
    my($name) = @_;

    my $old = $this->{comment};
    if (defined $name) {
	$this->{comment} = $name;
    }
    return $old;
}


# We'd like to compile these up front so we can complain about
# unrecognised condition and actions while we still know where we are
# in the source file.  Unfortunately, we can't do it in general as the
# action may refer to the names of rooms or items that have not yet
# been defined.  So all we can do at this stage is remember them for
# later.
#
sub add_cond {
    my $this = shift();
    my($text) = @_;

    push @{ $this->{cond} }, $text;
}


sub add_result {
    my $this = shift();
    my($text) = @_;

    push @{ $this->{res} }, $text;
}


# PRIVATE to the compile() method.
sub ARG_NONE { 0 }		# no argument
sub ARG_NUM { 1 }		# argument specifies a flag
sub ARG_ROOM { 2 }		# argument identifies a room
sub ARG_ITEM { 3 }		# argument identifies an item
sub ARG_ITEMROOM { 4 }		# arguments identify an item and a room
sub ARG_ITEMITEM { 5 }		# arguments identify two items

use vars qw(%_cond %_res);	# Global as they need to be visible to "sad"
%_cond = (
	     carried =>		[ 1, ARG_ITEM ],
	     here =>		[ 2, ARG_ITEM ],
	     accessible =>	[ 3, ARG_ITEM ],
	     at =>		[ 4, ARG_ROOM ],
	     '!here' =>		[ 5, ARG_ITEM ],
	     '!carried' =>	[ 6, ARG_ITEM ],
	     '!at' =>		[ 7, ARG_ROOM ],
	     flag =>		[ 8, ARG_NUM ],
	     '!flag' =>		[ 9, ARG_NUM ],
	     loaded =>		[ 10, ARG_NONE ],
	     '!loaded' =>	[ 11, ARG_NONE ],
	     '!accessible' =>	[ 12, ARG_ITEM ],
	     exists =>		[ 13, ARG_ITEM ],
	     '!exists' =>	[ 14, ARG_ITEM ],
	     counter_le =>	[ 15, ARG_NUM ],
#	     counter_ge =>	[ 16, ARG_NUM ],
	     counter_gt =>	[ 16, ARG_NUM ],
		#   ###	The documentation accompanying the scottfree
		#	interpreter says that condition 16 tests for
		#	current counter's value greater than or equal
		#	to the argument, but inspection of the source
		#	shows that it actually tests for strictly
		#	greater-than.
	     '!moved' =>	[ 17, ARG_ITEM ],
	     moved =>		[ 18, ARG_ITEM ],
	     counter_eq =>	[ 19, ARG_NUM ],
	     );

%_res = (
	    get =>		[ 52, ARG_ITEM ],
	    drop =>		[ 53, ARG_ITEM ],
	    moveto =>		[ 54, ARG_ROOM ],
	    destroy =>		[ 55, ARG_ITEM ],
	    set_dark =>		[ 56, ARG_NONE ],
	    clear_dark =>	[ 57, ARG_NONE ],
	    set_flag =>		[ 58, ARG_NUM ],
	    destroy2 =>		[ 59, ARG_ITEM ],
		# Same as 55 in ScottFree
	    clear_flag =>	[ 60, ARG_NUM ],
	    die =>		[ 61, ARG_NONE ],
	    put =>		[ 62, ARG_ITEMROOM ],
	    game_over =>	[ 63, ARG_NONE ],
	    look =>		[ 64, ARG_NONE ],
	    score =>		[ 65, ARG_NONE ],
	    inventory =>	[ 66, ARG_NONE ],
	    set_0 =>		[ 67, ARG_NONE ],
	    clear_0 =>		[ 68, ARG_NONE ],
	    refill_lamp =>	[ 69, ARG_NONE ],		### UNTESTED
	    clear_screen =>	[ 70, ARG_NONE ],		### UNTESTED
	    save_game =>	[ 71, ARG_NONE ],
	    swap =>		[ 72, ARG_ITEMITEM ],
	    continue =>		[ 73, ARG_NONE ],		### UNTESTED
		# Automatic -- is there ever any need to use it explicitly?
	    superget =>		[ 74, ARG_ITEM ],		### UNTESTED
	    put_with =>		[ 75, ARG_ITEMITEM ],
	    look2 =>		[ 76, ARG_NONE ],		### UNTESTED
		# Same as 64 in ScottFree
	    decrease_counter =>	[ 77, ARG_NONE ],
	    print_counter =>	[ 78, ARG_NONE ],
	    set_counter =>	[ 79, ARG_NUM ],
	    swap_loc_default =>	[ 80, ARG_NONE ],
	    select_counter =>	[ 81, ARG_NUM ],		### UNTESTED
		# Current counter is swapped with specified backup counter
	    add_counter =>	[ 82, ARG_NUM ],		### UNTESTED
	    subtract_counter =>	[ 83, ARG_NUM ],		### UNTESTED
	    print_noun =>	[ 84, ARG_NONE ],
	    print_noun_nl =>	[ 85, ARG_NONE ],
	    nl =>		[ 86, ARG_NONE ],
	    swap_loc =>		[ 87, ARG_NUM ],
	    pause =>		[ 88, ARG_NONE ],
	    special =>		[ 89, ARG_NUM ],
		# This is special -- see ../../../../scottfree/Definition
	    );


sub compile {
    my $this = shift();
    my($game) = @_;

    my $verb = $game->resolve_verb($this->verb());
    my $noun = $this->noun();
    if ($verb == 0) {
	# This is a %occur, so the noun is a percentage probability
	$noun = 100 if !$noun;
    } else {
	$noun = $game->resolve_noun($noun);
    }

    my @condval = ( 150*$verb + $noun );
    foreach my $cond (@{ $this->{cond} }) {
	my($opcode, $arg) = _lookup($game, $cond, 'condition', \%_cond);
	$arg = 0 if !defined $arg;
	push @condval, $opcode + 20*$arg;
    }

    die "Oops!  SA format doesn't support >5 conditions in an action"
	if @condval > 6;

    # Now gather results, with parameters going on the end of @condval
    #warn "handling results:\n" . join ('', map {"\t$_\n"}
    #				       @{ $this->{res} });
    my @resval;
    foreach my $res (@{ $this->{res} }) {
	my($opcode, @arg) = _lookup($game, $res, 'result', \%_res);
	push @resval, [ $opcode, @arg ];
    }

    # Right.  This is slightly tricky.  We now want to pack all the
    # results, together with their parameters, into as few action
    # octuplets as possible.  We have four result slots available in
    # the first one, together with zero or more parameter slots
    # remaining in the condition area; thereafter, each action
    # octuplet offers four more result slots together with five
    # parameter slots in the condition area (which of course is one
    # more than we'll ever need.)
    my @conds;			# list of completed octuplets
    my $argslot = @condval;	# 0-based index within current octuplet
    my $resslot = 0;		# 0-based index into "virtual array"
    push @condval, map { 0 } 1..(8-@condval);

    for (my $i = 0; $i < @resval; $i++) {
	my $res = $resval[$i];
	my($opcode, @arg) = @$res;
	@arg = grep { defined } @arg;

	### Seems like 6 in next line should be 5.  Think harder.
	if ($argslot + @arg > 6 || $resslot == 4 ||
	    ($resslot == 3 && $i < @resval-1)) {
	    # Current octuplet is full: skip to next
	    my $cindex = 6 + int($resslot/2);
	    $condval[$cindex] +=
		($resslot % 2 == 0 ? 150 : 1) * 73;
	    push @conds, join(' ', @condval);
	    @condval = map { 0 } 1..8;
	    $argslot = 1;	# because slot 0 holds verb & noun
	    $resslot = 0;
	}

	my $cindex = 6 + int($resslot/2);
	$condval[$cindex] +=
	    ($resslot % 2 == 0 ? 150 : 1) * $opcode;
	$resslot++;
	foreach my $arg (@arg) {
	    if (!defined $arg) {
		print STDERR "", "arg in '@arg' (", scalar(@arg), ") undef\n";
	    }
	    $condval[$argslot] = 20*$arg;
	    $argslot++;
	}
    }

    push @conds, join(' ', @condval);
#print STDERR "", "returning conds: ", join(' -- ', @conds), "\n";
    return @conds;
}


sub _lookup {
    my($game, $text, $caption, $href) = @_;

    $text =~ s/^\s+//;
    my($op, $arg) = split /\s+/, $text, 2;
    if ($op eq 'msg') {
	# This check is a hack, but does spot an otherwise subtle bug
	die "Oops!  `msg' used as a condition (missing %result line?)"
	    if $caption eq 'condition';

	my $mnum = $game->resolve_message($arg);
	return ($mnum <= 51 ? $mnum : $mnum+50);
    }

    my $ref = $href->{$op};
    die "unrecognised $caption op '$op'"
	if !defined $ref;

    my($opcode, $argtype) = @$ref;
    if ($argtype == ARG_NONE) {
	return ($opcode);
    } elsif ($argtype == ARG_NUM) {
	# Numeric argument already has the right numeric value.
    } elsif ($argtype == ARG_ROOM) {
	$arg = $game->resolve_room($arg, 'action');
    } elsif ($argtype == ARG_ITEM) {
	$arg = $game->resolve_item($arg, 'action');
    } elsif ($argtype == ARG_ITEMROOM) {
	my($arg1, $arg2) = split /\s+/, $arg, 2;
	$arg1 = $game->resolve_item($arg1, 'action');
	$arg2 = $game->resolve_room($arg2, 'action');
	return ($opcode, $arg1, $arg2);
    } elsif ($argtype == ARG_ITEMITEM) {
	my($arg1, $arg2) = split /\s+/, $arg, 2;
	$arg1 = $game->resolve_item($arg1, 'action');
	$arg2 = $game->resolve_item($arg2, 'action');
	return ($opcode, $arg1, $arg2);
    } else {
	die "unsupported argument type $argtype for op '$op'";
    }

    return ($opcode, $arg);
}


1;