File Coverage

blib/lib/Game/TextMapper/Schroeder/Archipelago.pm
Criterion Covered Total %
statement 15 93 16.1
branch 0 22 0.0
condition 0 29 0.0
subroutine 5 13 38.4
pod 0 5 0.0
total 20 162 12.3


line stmt bran cond sub pod time code
1             # Copyright (C) 2009-2021 Alex Schroeder
2             #
3             # This program is free software: you can redistribute it and/or modify it under
4             # the terms of the GNU Affero General Public License as published by the Free
5             # Software Foundation, either version 3 of the License, or (at your option) any
6             # later version.
7             #
8             # This program is distributed in the hope that it will be useful, but WITHOUT
9             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
10             # FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
11             # details.
12             #
13             # You should have received a copy of the GNU Affero General Public License along
14             # with this program. If not, see .
15              
16             =encoding utf8
17              
18             =head1 NAME
19              
20             Game::TextMapper::Archipelago - work in progress
21              
22             =head1 DESCRIPTION
23              
24             This is an unfinished idea.
25              
26             =cut
27              
28             package Game::TextMapper::Schroeder::Archipelago;
29 1     1   14 use Game::TextMapper::Log;
  1         1  
  1         29  
30 1     1   4 use Modern::Perl '2018';
  1         2  
  1         6  
31 1     1   124 use Mojo::Base -base;
  1         3  
  1         5  
32 1     1   120 use Role::Tiny::With;
  1         2  
  1         59  
33             with 'Game::TextMapper::Schroeder::Base';
34 1     1   25 use List::Util qw'shuffle min max';
  1         2  
  1         1401  
35              
36             my $log = Game::TextMapper::Log->get;
37              
38             has 'bottom' => 0;
39             has 'top' => 10;
40             has 'radius' => 5;
41             has 'width' => 30;
42             has 'height' => 10;
43             has 'concentration' => 0.1;
44             has 'eruptions' => 0.03;
45             has 'world' => sub { { } };
46             has 'altitude' => sub { {} };
47              
48             sub flat {
49 0     0 0   my $self = shift;
50 0           $log->debug("initializing altitude map");
51             # initialize the altitude map; this is required so that we have a list of
52             # legal hex coordinates somewhere
53 0           for my $y (1 .. $self->height) {
54 0           for my $x (1 .. $self->width) {
55 0           my $coordinates = coordinates($x, $y);
56 0           $self->altitude->{$coordinates} = 0;
57 0           $self->world->{$coordinates} = "height0";
58             }
59             }
60             }
61              
62             sub ocean {
63 0     0 0   my $self = shift;
64 0           $log->debug("placing ocean and water");
65 0           for my $coordinates (sort keys %{$self->altitude}) {
  0            
66 0 0         if ($self->altitude->{$coordinates} <= $self->bottom) {
67 0           my $ocean = 1;
68 0           for my $i ($self->neighbors()) {
69 0           my ($x, $y) = $self->neighbor($coordinates, $i);
70 0           my $legal = $self->legal($x, $y);
71 0           my $other = coordinates($x, $y);
72 0 0 0       next if not $legal or $self->altitude->{$other} <= $self->bottom;
73 0           $ocean = 0;
74             }
75 0 0         $self->world->{$coordinates} = $ocean ? "ocean" : "water";
76             }
77             }
78             }
79              
80             sub eruption {
81 0     0 0   my $self = shift;
82 0           my $cx = int $self->width * rand();
83 0           my $cy = int $self->height * (rand() + rand()) / 2;
84 0           $log->debug("eruption at " . $self->coordinates($cx, $cy));
85 0           my $top = 1 + int($self->top * $cx / $self->width);
86 0 0 0       $top-- if $top > 2 and rand() < 0.6;
87 0           for my $coordinates (keys %{$self->altitude}) {
  0            
88 0           my $d = $self->distance($self->xy($coordinates), $cx, $cy);
89 0 0         if ($d <= $top) {
90 0           my $h = $top - $d;
91 0 0         $self->altitude->{$coordinates} = $h if $h > $self->altitude->{$coordinates};
92 0           $self->world->{$coordinates} = "height" . $self->altitude->{$coordinates};
93             }
94             }
95             }
96              
97             sub generate {
98 0     0 0   my $self = shift;
99 0           my $step = shift;
100 0     0     my @code = (sub { $self->flat() });
  0            
101 0           for (1 .. $self->width * $self->height * $self->eruptions) {
102 0     0     push(@code, sub { $self->eruption() });
  0            
103             }
104 0     0     push(@code, sub { $self->ocean() });
  0            
105              
106             # $step 0 runs all the code; note that we can't simply cache those results
107             # because we need to start over with the same seed!
108 0           my $i = 1;
109 0           while (@code) {
110 0           shift(@code)->();
111 0 0         return if $step == $i++;
112             }
113             }
114              
115             sub generate_map {
116 0     0 0   my $self = shift;
117             # If provided, the arguments override the defaults
118 0   0       $self->width(shift // $self->width);
119 0   0       $self->height(shift // $self->height);
120 0   0       $self->concentration(shift // $self->concentration);
121 0   0       $self->eruptions(shift // $self->eruptions);
122 0   0       $self->top(shift // $self->top);
123 0   0       $self->bottom(shift // $self->bottom);
124 0   0       my $seed = shift||time;
125 0           my $url = shift;
126 0   0       my $step = shift||0;
127              
128             # For documentation purposes, I want to be able to set the pseudo-random
129             # number seed using srand and rely on rand to reproduce the same sequence of
130             # pseudo-random numbers for the same seed. The key point to remember is that
131             # the keys function will return keys in random order. So if we loop over the
132             # result of keys, we need to look at the code in the loop: If order is
133             # important, that wont do. We need to sort the keys. If we want the keys to be
134             # pseudo-shuffled, use shuffle sort keys.
135 0           srand($seed);
136              
137             # keys for all hashes are coordinates such as "0101".
138 0           $self->generate($step);
139              
140             # when documenting or debugging, do this before collecting lines
141 0 0         if ($step > 0) {
142             # add a height label at the very end
143 0 0         if ($step) {
144 0           for my $coordinates (keys %{$self->altitude}) {
  0            
145 0           $self->world->{$coordinates} .= ' "' . $self->altitude->{$coordinates} . '"';
146             }
147             }
148             }
149              
150 0           local $" = "-"; # list items separated by -
151 0           my @lines;
152 0           push(@lines, map { $_ . " " . $self->world->{$_} } sort keys %{$self->world});
  0            
  0            
153             # push(@lines, map { "$_ trail" } @$trails);
154 0           push(@lines, "include gnomeyland.txt");
155              
156             # when documenting or debugging, add some more lines at the end
157 0 0         if ($step > 0) {
158             # visualize height
159             push(@lines,
160             map {
161 0           my $n = int(255 / $self->top * $_);
  0            
162 0           qq{height$_ attributes fill="rgb($n,$n,$n)"};
163             } (0 .. $self->top));
164             # visualize water flow
165 0           push(@lines, $self->arrows());
166             }
167              
168 0           push(@lines, "# Seed: $seed");
169 0 0         push(@lines, "# Documentation: " . $url) if $url;
170 0           my $map = join("\n", @lines);
171 0           return $map;
172             }
173              
174             1;