File Coverage

blib/lib/Games/RolePlay/MapGen/GeneratorPlugin/BasicDoors.pm

Criterion	Covered	Total	%
statement	88	88	100.0
branch	38	44	86.3
condition	20	29	68.9
subroutine	6	6	100.0
pod	0	2	0.0
total	152	169	89.9

# vi:tw=0 syntax=perl:

package Games::RolePlay::MapGen::GeneratorPlugin::BasicDoors;

use common::sense;
use Carp;
use Games::RolePlay::MapGen::Tools qw( roll _door choice );

$Games::RolePlay::MapGen::known_opts{       "open_room_corridor_door_percent" } = { door => 95, secret =>  2, stuck => 25, locked => 50 };
$Games::RolePlay::MapGen::known_opts{     "closed_room_corridor_door_percent" } = { door =>  5, secret => 95, stuck => 10, locked => 30 };
$Games::RolePlay::MapGen::known_opts{   "open_corridor_corridor_door_percent" } = { door =>  1, secret => 10, stuck => 25, locked => 50 };
$Games::RolePlay::MapGen::known_opts{ "closed_corridor_corridor_door_percent" } = { door =>  1, secret => 95, stuck => 10, locked => 30 };
$Games::RolePlay::MapGen::known_opts{ "max_span"                              } = 50;

1;

# new {{{
sub new {
    my $class = shift;
    my $this  = [qw(door)]; # you have to be the types of things you hook

    return bless $this, $class;
}
# }}}
# doorgen {{{
sub doorgen {
    my $this   = shift;
    my $opts   = shift;
    my $map    = shift;
    my $groups = shift;

    my $minor_dirs = {
        n => [qw(e w)],
        s => [qw(e w)],

        e => [qw(n s)],
        w => [qw(n s)],
    };

    my $max_span = $opts->{max_span} / ($opts->{tile_size} || 1);
       $max_span = 1 unless $max_span > 0;

     # warn "max_span=$max_span";

    for my $i ( 0 .. $#$map ) {
        my $jend = $#{ $map->[$i] };

        for my $j ( 0 .. $jend ) {
            my $t = $map->[$i][$j];

            if( $t->{type} ) {
                for my $dir (qw(n e s w)) { my $opp = $Games::RolePlay::MapGen::opp{$dir};
                    my $n = $t->{nb}{$dir};
                    next unless $n and $n->{type};

                    unless( $t->{_bchkt}{$dir} ) {
                        my ($ttype, $ntype) = ($t->{type}, $n->{type});

                        if( $ttype eq "room" and $ntype eq "room" ) {
                            if( $t->{group}{name} eq $n->{group}{name} ) {
                                next;

                            } else {
                                $ntype = "corridor";
                            }
                        }

                        my $tkey  = ( $t->{od}{$dir} ? "open" : "closed" );
                           $tkey .= "_" . join("_", reverse sort( $ttype, $ntype ));
                           $tkey .= "_door_percent";

                        my $chances = $opts->{$tkey};
                        die "chances error for $tkey" unless defined $chances;

                        if( (my $r = roll(1, 10000)) <= (my $c = $chances->{door}*100) ) {
                            my ($span, $nspn) = $this->_find_span($dir=>$opp, $t=>$n);

                            $_->{_bchkt}{$dir} = 1 for @$span;
                            $_->{_bchkt}{$opp} = 1 for @$nspn;

                            next unless @$span <= $max_span;

                            $_->{od}{$dir} = 0 for @$span;
                            $_->{od}{$opp} = 0 for @$nspn;

                            $t = choice(@$span);
                            $n = $t->{nb}{$dir};

                            my $d1 = sprintf("%40s: (%5d, %5d)", $tkey, $r, $c);
                            my $d2 = sprintf("(%2d, %2d, $dir)", $j, $i);

                            $t->{od}{$dir} = $n->{od}{$opp} = &_door(

                                (map {$_ => ((roll(1, 10000) <= $chances->{$_}*100) ? 1:0) } qw(locked stuck secret)),

                                open_dir => {
                                    major => &choice( $dir, $opp ),
                                    minor => &choice( @{$minor_dirs->{$dir}} ),
                                },
                            );
                        }

                        # $t->{_bchkt}{$dir} = 1; # handled above in the span now
                    }
                }
            }
        }
    }

    delete $_->{_bchkt} for map(@$_, @$map); # btw, bchkt stands for: basic doors checked tile [direction]
}
# }}}
# _find_span {{{
sub _find_span {
    my $this = shift;
    my $dir  = shift;
    my $opp  = shift;
    my $t    = shift;
    my $n    = shift;
    my $span = [$t];
    my $nspn = [$n];

    warn "WARNING: something is fishy $t->{x},$t->{y}:$dir nb!> $n->{x},$n->{y}:$opp" unless $t->{nb}{$dir} == $n;
    warn "WARNING: something is fishy $t->{x},$t->{y}:$dir {x},$n->{y}:$opp" unless $n->{nb}{$opp} == $t;

    my ($ud, $pd) = (qw(n s));
       ($ud, $pd) = (qw(e w)) if $dir eq "n" or $dir eq "s";

    my $ls = 0;
    while( $ls != int @$span ) { $ls = int @$span;
        $t = $span->[0];
        $n = $nspn->[0]; warn "WARNING: something is fishy" unless $n->{nb}{$opp} == $t and $t->{nb}{$dir} == $n;
        if( $t->{od}{$ud} == 1 and (my $c = $t->{nb}{$ud}) ) {
            if( $n->{od}{$ud} == 1 and (my $d = $n->{nb}{$ud}) ) {
                if( $c->{od}{$dir} == 1 ) {
                    unshift @$span, $c;
                    unshift @$nspn, $d;
                }
            }
        }

        $t = $span->[$#{ $span }];
        $n = $nspn->[$#{ $nspn }]; warn "WARNING: something is fishy" unless $n->{nb}{$opp} == $t and $t->{nb}{$dir} == $n;
        if( $t->{od}{$pd} == 1 and (my $c = $t->{nb}{$pd}) ) {
            if( $n->{od}{$pd} == 1 and (my $d = $n->{nb}{$pd}) ) {
                if( $c->{od}{$dir} == 1 ) {
                    push @$span, $c;
                    push @$nspn, $d;
                }
            }
        }
    }

    return ($span, $nspn);
}
# }}}

__END__