File Coverage

blib/lib/Games/RolePlay/MapGen.pm

Criterion	Covered	Total	%
statement	124	174	71.2
branch	49	96	51.0
condition	5	12	41.6
subroutine	14	18	77.7
pod	1	11	9.0
total	193	311	62.0

# vi:tw=0 syntax=perl:

package Games::RolePlay::MapGen;

use Carp;
use Storable;
use common::sense;

our $VERSION = '1.5008';

our $AUTOLOAD;

our %opp  = (n=>"s", e=>"w", s=>"n", w=>"e");
our %full = (n=>"north", e=>"east", s=>"south", w=>"west");

# known_opts {{{
our %known_opts = (
    generator              => "Basic",
    exporter               => "Text",
    bounding_box           => "50x50",
    tile_size              => 10,
    cell_size              => "20x20",

    nocolor => 0, # for the text map generator

    num_rooms              => "1d4+1",
    min_room_size          => "2x2",
    max_room_size          => "7x7",

    sparseness             => 10,
          same_way_percent => 90,
         same_node_percent => 30,
    remove_deadend_percent => 60,
);
# }}}

# _check_mod_path {{{
sub _check_mod_path  {
    my $this = shift;
    my $omod = shift;
       $omod =~ s/\:\:/\//g;

    for my $mod ($omod, map {$_ . "::$omod"} "Games::RolePlay::MapGen::Generator", "Games::RolePlay::MapGen::GeneratorPlugin",
            "Games::RolePlay::MapGen::Exporter", "Games::RolePlay::MapGen::ExporterPlugin") {

        return $mod if eval "require $mod";
    }

    return;
}
# }}}
# _check_opts {{{
sub _check_opts {
    my $this = shift;
    my @e    = ();

    # warn "checking known_opts";
    for my $k (keys %known_opts) {
        "set_$k"->($this, $known_opts{$k} ) unless defined $this->{$k};
    }

    for my $k ( keys %$this ) {
        unless( exists $known_opts{$k} ) {
            next if $k eq "objs";
            next if $k eq "_the_map";
            next if $k eq "_the_groups";

            push @e, "unrecognized option: '$k'";
        }
    }

    return "ERROR:\n\t" . join("\n\t", @e) . "\n" if @e;
    return;
}
# }}}

# AUTOLOAD {{{
sub AUTOLOAD {
    my $this = shift;
    my $sub  = $AUTOLOAD;

    # sub set_generator
    # sub set_exporter

    if( $sub =~ m/MapGen\:\:set_(generator|exporter)$/ ) {
        my $type = $1;
        my $modu = shift;

        delete $this->{objs}{$type} if $this->{objs}{$type};

        my $module = "Games::RolePlay::MapGen::" . (ucfirst $type) . "::$modu";
        croak "Couldn't locate module \"$modu\" during execution of $sub() $@" unless eval { "require $module" };

        # NOTE: why does this not have {objs}? 5/12/8
        $this->{$type} = $module;

        return;

    } elsif( $sub =~ m/MapGen\:\:add_(generator|exporter)_plugin$/ ) {
        my $type = $1;
        my $plug = shift;

        my $newn = "Games::RolePlay::MapGen::" . (ucfirst $type) . "Plugin::$plug";
        croak "Couldn't locate module \"$plug\" during execution of $sub()" unless eval { "require $newn" };

        push @{ $this->{plugins}{$type} }, $newn;

        return;

    } elsif( $sub =~ m/MapGen\:\:set_([\w\d\_]+)$/ ) {
        my $n = $1;

        croak "ERROR: set_$n() unknown setting during execution of $sub()" unless exists $known_opts{$n};

        $this->{$n} = shift;

        for my $o (qw(generator exporter)) {
            if( my $oo = $this->{objs}{$o} ) {

                # NOTE: how does this->{$n} relate to this->{objs}{$n} ... 5/12/8
                $oo->{o}{$n} = $this->{$n};
            }
        }

        return;
    }

    croak "ERROR: function $sub() not found";
}
sub DESTROY {}
# }}}
# new {{{
sub new {
    my $class = shift;
    my @opts  = @_;
    my $opts  = ( (@opts == 1 and ref($opts[0]) eq "HASH") ? {%{$opts[0]}} : {@opts} );
    my $this  = bless $opts, $class;

    if( my $e = $this->_check_opts ) { croak $e }

    return $this;
}
# }}}

# save_map {{{
sub save_map {
    my $this     = shift;
    my $filename = shift;

    $this->{_the_map}->disconnect_map;

    my $str;
    if( $filename ) {
        Storable::store($this, $filename);

    } else {
        $str = Storable::freeze($this);
    }

    $this->{_the_map}->interconnect_map;

    return $str;
}
# }}}
# load_map {{{
sub load_map {
    my $this     = shift;
    my $filename = shift;

    if( -f $filename ) {
        eval { %$this = %{ Storable::retrieve( $filename ) } }
            or die "ERROR while evaluating saved map from file: $@";

    } else {
        eval { %$this = %{ Storable::thaw( $filename ) } }
            or die "ERROR while evaluating saved map from string: $@";
    }

    require Games::RolePlay::MapGen::Tools; # This would already be loaded if we were the blessed ref that did the saving
    $this->{_the_map}->interconnect_map;    # bit it wouldn't be loaded otherwise!
}
# }}}
# legacy_load_map {{{
sub legacy_load_map {
    my $this     = shift;
    my $filename = shift;

    open my $load, "$filename" or die "couldn't open $filename for read: $!";
    local $/ = undef;
    my $entire_file = <$load>;
    close $load;

    eval $entire_file;
    die "ERROR while evaluating saved map: $@" if $@;

    require Games::RolePlay::MapGen::Tools; # This would already be loaded if we were the blessed ref that did the saving
    $this->{_the_map}->interconnect_map;    # bit it wouldn't be loaded otherwise!
}
# }}}
# generate {{{
sub generate {
    my $this = shift;
    my $err;

    __MADE_GEN_OBJ:
    if( my $gen = $this->{objs}{generator} ) {
        my $new_opts;

        ($this->{_the_map}, $this->{_the_groups}, $new_opts) = $gen->go( @_ );

        if( $new_opts and keys %$new_opts ) {
            for my $k (keys %$new_opts) {
                $this->{$k} = $new_opts->{$k};
            }
        }

        return;

    } else {
        die "ERROR: problem creating new generator object" if $err;
    }

    eval qq( require $this->{generator} );
    croak "ERROR locating generator module:\n\t$@\n " if $@;

    my $obj;
    my @opts = map(($_=>$this->{$_}), grep {defined $this->{$_} and $_ ne "objs"  and $_ ne "plugins" } keys %$this);

    eval qq( \$obj = new $this->{generator} (\@opts); );
    if( $@ ) {
        die   "ERROR generating generator:\n\t$@\n " if $@ =~ m/ERROR/;
        croak "ERROR generating generator:\n\t$@\n " if $@;
    }

    $obj->add_plugin( $_ ) for @{ $this->{plugins}{generator} };

    $this->{objs}{generator} = $obj;
    $err = 1;

    $this->_check_opts; # plugins, generators and exporters can add default options

    goto __MADE_GEN_OBJ;
}
# }}}
# export {{{
sub export {
    my $this = shift;
    my $err;

    __MADE_VIS_OBJ:
    if( my $vis = $this->{objs}{exporter} ) {

        return $vis->go( _the_map => $this->{_the_map}, _the_groups => $this->{_the_groups}, (@_==1 ? (fname=>$_[0]) : @_) );

    } else {
        die "problem creating new exporter object" if $err;
    }

    eval qq( require $this->{exporter} );
    croak "ERROR locating exporter module:\n\t$@\n " if $@;

    my $obj;
    my @opts = map(($_=>$this->{$_}), grep {defined $this->{$_} and $_ ne "objs"  and $_ ne "plugins" } keys %$this);

    eval qq( \$obj = new $this->{exporter} (\@opts); );
    if( $@ ) {
        die   "ERROR generating exporter:\n\t$@\n " if $@ =~ m/ERROR/;
        croak "ERROR generating exporter:\n\t$@\n " if $@;
    }

    $this->{objs}{exporter} = $obj;
    $err = 1;

    $this->_check_opts; # plugins, generators and exporters can add default options

    goto __MADE_VIS_OBJ;
}
# }}}

# import_xml {{{
sub import_xml {
    my $this = shift;
    my $that = shift; croak "no such file that=$that" unless -f $that;

    $this = $this->new unless ref $this;

    $this->set_generator( "XMLImport" );
    if( -f $that ) {
        $this->generate( xml_input_file => $that, @_ );

    } else {
        $this->generate( xml_input      => $that, @_ );
    }
    $this;
}
# }}}
# sub_map {{{
sub sub_map {
    my $this = shift;
    my $that = shift; croak "that's not a map" unless ref $that;
    my $ul   = shift; croak "upper left should be an arrayref two tuple" unless 2==eval {@$ul};
    my $lr   = shift; croak "lower right should be an arrayref two tuple" unless 2==eval {@$lr};

    $this = $this->new unless ref $this;
    $this->set_generator( "SubMap" );
    $this->generate( map_input => $that, upper_left=>$ul, lower_right=>$lr );
    $this;
}
# }}}
# size {{{
sub size {
    my $this = shift;
    my $map  = $this->{_the_map};

    my $x = @{$map->[0]};
    my $y = @$map;

    return ($x, $y) if wantarray;
    return [$x, $y];
}
# }}}

# {{{ FREEZE_THAW_HOOKS
FREEZE_THAW_HOOKS: {
    my $going;
    sub STORABLE_freeze {
        return if $going;
        my $this = shift;
        $going = 1;
        my $str = $this->save_map;
        $going = 0;
        return $str;
    }

    sub STORABLE_thaw {
        my $this = shift;
        $this->load_map($_[1]);
    }
}

# }}}

1;

__END__