File Coverage

blib/lib/Game/TextMapper.pm

Criterion	Covered	Total	%
statement	98	160	61.2
branch	4	40	10.0
condition	14	93	15.0
subroutine	26	29	89.6
pod	0	7	0.0
total	142	329	43.1

#!/usr/bin/env perl
# Copyright (C) 2009-2022  Alex Schroeder
#
# This program is free software: you can redistribute it and/or modify it under
# the terms of the GNU Affero General Public License as published by the Free
# Software Foundation, either version 3 of the License, or (at your option) any
# later version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
# details.
#
# You should have received a copy of the GNU Affero General Public License along
# with this program. If not, see .

package Game::TextMapper;

our $VERSION = 1.04;

use Game::TextMapper::Log;
use Game::TextMapper::Point;
use Game::TextMapper::Line;
use Game::TextMapper::Mapper::Hex;
use Game::TextMapper::Mapper::Square;
use Game::TextMapper::Smale;
use Game::TextMapper::Apocalypse;
use Game::TextMapper::Gridmapper;
use Game::TextMapper::Schroeder::Alpine;
use Game::TextMapper::Schroeder::Archipelago;
use Game::TextMapper::Schroeder::Island;
use Game::TextMapper::Traveller;

use Modern::Perl '2018';
use Mojolicious::Lite;
use Mojo::DOM;
use Mojo::Util qw(url_escape xml_escape);
use File::ShareDir 'dist_dir';
use Pod::Simple::HTML;
use Pod::Simple::Text;
use List::Util qw(none);
use Cwd;

# Commands for the command line!
push @{app->commands->namespaces}, 'Game::TextMapper::Command';

# Change scheme if "X-Forwarded-Proto" header is set (presumably to HTTPS)
app->hook(before_dispatch => sub {
  my $c = shift;
  $c->req->url->base->scheme('https')
      if $c->req->headers->header('X-Forwarded-Proto') } );

plugin Config => {
  default => {
    loglevel => 'warn',
    logfile => undef,
    contrib => undef,
  },
  file => getcwd() . '/text-mapper.conf',
};

my $log = Game::TextMapper::Log->get;
$log->level(app->config('loglevel'));
$log->path(app->config('logfile'));
$log->info($log->path ? "Logfile is " . $log->path : "Logging to stderr");

my $dist_dir = app->config('contrib') // dist_dir('Game-TextMapper');
$log->debug("Reading contrib files from $dist_dir");

get '/' => sub {
  my $c = shift;
  my $param = $c->param('map');
  if ($param) {
    my $mapper;
    if ($c->param('type') and $c->param('type') eq 'square') {
      $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
    } else {
      $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
    }
    $mapper->initialize($param);
    $c->render(text => $mapper->svg, format => 'svg');
  } else {
    my $mapper = new Game::TextMapper::Mapper;
    my $map = $mapper->initialize('')->example();
    $c->render(template => 'edit', map => $map);
  }
};

any '/edit' => sub {
  my $c = shift;
  my $mapper = new Game::TextMapper::Mapper;
  my $map = $c->param('map') || $mapper->initialize('')->example();
  $c->render(map => $map);
};

any '/render' => sub {
  my $c = shift;
  my $mapper;
  if ($c->param('type') and $c->param('type') eq 'square') {
    $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
  } else {
    $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  }
  $mapper->initialize($c->param('map'));
  $c->render(text => $mapper->svg, format => 'svg');
};

get '/:type/redirect' => sub {
  my $self = shift;
  my $type = $self->param('type');
  my $rooms = $self->param('rooms');
  my $seed = $self->param('seed');
  my $caves = $self->param('caves');
  my %params = ();
  $params{rooms} = $rooms if $rooms;
  $params{seed} = $seed if $seed;
  $params{caves} = $caves if $caves;
  $self->redirect_to($self->url_for($type . "random")->query(%params));
} => 'redirect';

# alias for /smale
get '/random' => sub {
  my $c = shift;
  my $bw = $c->param('bw');
  my $width = $c->param('width');
  my $height = $c->param('height');
  $c->render(template => 'edit', map => Game::TextMapper::Smale->new->generate_map($width, $height, $bw));
};

get '/smale' => sub {
  my $c = shift;
  my $bw = $c->param('bw');
  my $width = $c->param('width');
  my $height = $c->param('height');
  if ($c->stash('format')||'' eq 'txt') {
    $c->render(text => Game::TextMapper::Smale->new->generate_map($width, $height));
  } else {
    $c->render(template => 'edit',
	       map => Game::TextMapper::Smale->new->generate_map($width, $height, $bw));
  }
};

get '/smale/random' => sub {
  my $c = shift;
  my $bw = $c->param('bw');
  my $width = $c->param('width');
  my $height = $c->param('height');
  my $map = Game::TextMapper::Smale->new->generate_map($width, $height, $bw);
  my $svg = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir)
      ->initialize($map)
      ->svg();
  $c->render(text => $svg, format => 'svg');
};

get '/smale/random/text' => sub {
  my $c = shift;
  my $bw = $c->param('bw');
  my $width = $c->param('width');
  my $height = $c->param('height');
  my $text = Game::TextMapper::Smale->new->generate_map($width, $height, $bw);
  $c->render(text => $text, format => 'txt');
};

sub alpine_map {
  my $c = shift;
  # must be able to override this for the documentation
  my $step = shift // $c->param('step');
  # need to compute the seed here so that we can send along the URL
  my $seed = $c->param('seed') || int(rand(1000000000));
  my $url = $c->url_with('alpinedocument')->query({seed => $seed})->to_abs;
  my @params = ($c->param('width'),
		$c->param('height'),
		$c->param('steepness'),
		$c->param('peaks'),
		$c->param('peak'),
		$c->param('bumps'),
		$c->param('bump'),
		$c->param('bottom'),
		$c->param('arid'),
		$c->param('wind'),
		$seed,
		$url,
		$step,
      );
  my $type = $c->param('type') // 'hex';
  if ($type eq 'hex') {
    return Game::TextMapper::Schroeder::Alpine
	->with_roles('Game::TextMapper::Schroeder::Hex')->new()
	->generate_map(@params);
  } else {
    return Game::TextMapper::Schroeder::Alpine
	->with_roles('Game::TextMapper::Schroeder::Square')->new()
	->generate_map(@params);
  }
}

get '/alpine' => sub {
  my $c = shift;
  my $map = alpine_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/alpine/random' => sub {
  my $c = shift;
  my $map = alpine_map($c);
  my $type = $c->param('type') // 'hex';
  my $mapper;
  if ($type eq 'hex') {
    $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  } else {
    $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
  }
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

get '/alpine/random/text' => sub {
  my $c = shift;
  my $map = alpine_map($c);
  $c->render(text => $map, format => 'txt');
};

get '/alpine/document' => sub {
  my $c = shift;
  # prepare a map for every step
  my @maps;
  my $type = $c->param('type') || 'hex';
  # use the same seed for all the calls
  my $seed = $c->param('seed');
  if (not defined $seed) {
    $seed = int(rand(1000000000));
    $c->param('seed' => $seed);
  }
  for my $step (1 .. 18) {
    my $map = alpine_map($c, $step);
    my $mapper;
    if ($type eq 'hex') {
      $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
    } else {
      $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
    }
    my $svg = $mapper->initialize($map)->svg;
    $svg =~ s/<\?xml version="1.0" encoding="UTF-8" standalone="no"\?>\n//g;
    push(@maps, $svg);
  };
  $c->stash("maps" => \@maps);

  # The documentation needs all the defaults of Alpine::generate_map (but
  # we'd like to use a smaller map because it is so slow).
  my $width = $c->param('width') // 20;
  my $height = $c->param('height') // 5; # instead of 10
  my $steepness = $c->param('steepness') // 3;
  my $peaks = $c->param('peaks') // int($width * $height / 40);
  my $peak = $c->param('peak') // 10;
  my $bumps = $c->param('bumps') // int($width * $height / 40);
  my $bump = $c->param('bump') // 2;
  my $bottom = $c->param('bottom') // 0;
  my $arid = $c->param('arid') // 2;

  # Generate the documentation text based on the stashed maps.
  $c->render(template => 'alpine_document',
	     seed => $seed,
	     width => $width,
	     height => $height,
	     steepness => $steepness,
	     peaks => $peaks,
	     peak => $peak,
	     bumps => $bumps,
	     bump => $bump,
	     bottom => $bottom,
	     arid => $arid);
};

get '/alpine/parameters' => sub {
  my $c = shift;
  $c->render(template => 'alpine_parameters');
};

# does not handle z coordinates
sub border_modification {
  my ($map, $top, $left, $right, $bottom, $empty) = @_;
  my (@lines, @temp, %seen);
  my ($x, $y, $points, $text);
  my ($minx, $miny, $maxx, $maxy);
  # shift map around
  foreach (split(/\r?\n/, $map)) {
    if (($x, $y, $text) = /^(\d\d)(\d\d)\s+(.*)/) {
      $minx = $x if not defined $minx or $x < $minx;
      $miny = $y if not defined $miny or $y < $miny;
      $maxx = $x if not defined $maxx or $x > $maxx;
      $maxy = $y if not defined $maxy or $y > $maxy;
      my $point = Game::TextMapper::Point->new(x => $x + $left, y => $y + $top);
      $seen{$point->coordinates} = 1 if $empty;
      push(@lines, [$point, $text]);
    } elsif (($points, $text) = /^(-?\d\d-?\d\d(?:--?\d\d-?\d\d)+)\s+(.*)/) {
      my @numbers = $points =~ /\G(-?\d\d)(-?\d\d)-?/cg;
      my @points;
      while (@numbers) {
	my ($x, $y) = splice(@numbers, 0, 2);
	push(@points, Game::TextMapper::Point->new(x => $x + $left, y => $y + $top));
      }
      push(@lines, [Game::TextMapper::Line->new(points => \@points), $text]);
    } else {
      push(@lines, $_);
    }
  }
  # only now do we know the extent of the map
  $maxx += $left + $right;
  $maxy += $top + $bottom;
  # with that information we can now determine what lies outside the map
  @temp = ();
  foreach (@lines) {
    if (ref) {
      my ($it, $text) = @$_;
      if (ref($it) eq 'Game::TextMapper::Point') {
	if ($it->x <= $maxx and $it->x >= $minx
	    and $it->y <= $maxy and $it->y >= $miny) {
	  push(@temp, $_);
	}
      } else { # Game::TextMapper::Line
	my $outside = none {
	  ($_->x <= $maxx and $_->x >= $minx
	   and $_->y <= $maxy and $_->y >= $miny)
	} @{$it->points};
	push(@temp, $_) unless $outside;
      }
    } else {
      push(@temp, $_);
    }
  }
  @lines = @temp;
  # add missing hexes, if requested
  if ($empty) {
    for $x ($minx .. $maxx) {
      for $y ($miny .. $maxy) {
	my $point = Game::TextMapper::Point->new(x => $x, y => $y);
	if (not $seen{$point->coordinates}) {
	  push(@lines, [$point, "empty"]);
	}
      }
    }
    # also, sort regions before trails before others
    @lines = sort {
      (# arrays before strings
       ref($b) cmp ref($a)
       # string comparison if both are strings
       or not(ref($a)) and not(ref($b)) and $a cmp $b
       # if we get here, we know both are arrays
       # points before lines
       or ref($b->[0]) cmp ref($a->[0])
       # if both are points, compare the coordinates
       or ref($a->[0]) eq 'Game::TextMapper::Point' and $a->[0]->cmp($b->[0])
       # if both are lines, compare the first two coordinates (the minimum line length)
       or ref($a->[0]) eq 'Game::TextMapper::Line' and ($a->[0]->points->[0]->cmp($b->[0]->points->[0])
				      or $a->[0]->points->[1]->cmp($b->[0]->points->[1]))
       # if bot are the same point (!) …
       or 0)
    } @lines;
  }
  $map = join("\n",
	      map {
		if (ref) {
		  my ($it, $text) = @$_;
		  if (ref($it) eq 'Game::TextMapper::Point') {
		    Game::TextMapper::Point::coord($it->x, $it->y) . " " . $text
		  } else {
		    my $points = $it->points;
		    join("-",
			 map { Game::TextMapper::Point::coord($_->x, $_->y) } @$points)
			. " " . $text;
		  }
		} else {
		  $_;
		}
	      } @lines) . "\n";
  return $map;
}

any '/borders' => sub {
  my $c = shift;
  my $map = border_modification(map { $c->param($_) } qw(map top left right bottom empty));
  $c->param('map', $map);
  $c->render(template => 'edit', map => $map);
};

sub island_map {
  my $c = shift;
  # must be able to override this for the documentation
  my $step = shift // $c->param('step');
  # need to compute the seed here so that we can send along the URL
  my $seed = $c->param('seed') || int(rand(1000000000));
  my $url = $c->url_with('islanddocument')->query({seed => $seed})->to_abs;
  my @params = ($c->param('width'),
		$c->param('height'),
		$c->param('radius'),
		$seed,
		$url,
		$step,
      );
  my $type = $c->param('type') // 'hex';
  if ($type eq 'hex') {
    return Game::TextMapper::Schroeder::Island
	->with_roles('Game::TextMapper::Schroeder::Hex')->new()
	->generate_map(@params);
  } else {
    return Game::TextMapper::Schroeder::Island
	->with_roles('Game::TextMapper::Schroeder::Square')->new()
	->generate_map(@params);
  }
}

get '/island' => sub {
  my $c = shift;
  my $map = island_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/island/random' => sub {
  my $c = shift;
  my $map = island_map($c);
  my $type = $c->param('type') // 'hex';
  my $mapper;
  if ($type eq 'hex') {
    $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  } else {
    $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
  }
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

sub archipelago_map {
  my $c = shift;
  # must be able to override this for the documentation
  my $step = shift // $c->param('step');
  # need to compute the seed here so that we can send along the URL
  my $seed = $c->param('seed') || int(rand(1000000000));
  my $url = $c->url_with('archipelagodocument')->query({seed => $seed})->to_abs;
  my @params = ($c->param('width'),
		$c->param('height'),
		$c->param('concentration'),
		$c->param('eruptions'),
		$c->param('top'),
		$c->param('bottom'),
		$seed,
		$url,
		$step,
      );
  my $type = $c->param('type') // 'hex';
  if ($type eq 'hex') {
    return Game::TextMapper::Schroeder::Archipelago
	->with_roles('Game::TextMapper::Schroeder::Hex')->new()
	->generate_map(@params);
  } else {
    return Game::TextMapper::Schroeder::Archipelago
	->with_roles('Game::TextMapper::Schroeder::Square')->new()
	->generate_map(@params);
  }
}

get '/archipelago' => sub {
  my $c = shift;
  my $map = archipelago_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/archipelago/random' => sub {
  my $c = shift;
  my $map = archipelago_map($c);
  my $type = $c->param('type') // 'hex';
  my $mapper;
  if ($type eq 'hex') {
    $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  } else {
    $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
  }
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

sub gridmapper_map {
  my $c = shift;
  my $seed = $c->param('seed') || int(rand(1000000000));
  my $pillars = $c->param('pillars') // 1;
  my $rooms = $c->param('rooms') // 5;
  my $caves = $c->param('caves') // 0;
  srand($seed);
  return Game::TextMapper::Gridmapper->new()
      ->generate_map($pillars, $rooms, $caves);
}

get '/gridmapper' => sub {
  my $c = shift;
  my $map = gridmapper_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/gridmapper/random' => sub {
  my $c = shift;
  my $map = gridmapper_map($c);
  my $mapper = Game::TextMapper::Mapper::Square->new(dist_dir => $dist_dir);
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

get '/gridmapper/random/text' => sub {
  my $c = shift;
  my $map = gridmapper_map($c);
  $c->render(text => $map, format => 'txt');
};

sub apocalypse_map {
  my $c = shift;
  my $seed = $c->param('seed') || int(rand(1000000000));
  srand($seed);
  my $hash = $c->req->params->to_hash;
  return Game::TextMapper::Apocalypse->new(%$hash)
      ->generate_map();
}

get '/apocalypse' => sub {
  my $c = shift;
  my $map = apocalypse_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/apocalypse/random' => sub {
  my $c = shift;
  my $map = apocalypse_map($c);
  my $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

get '/apocalypse/random/text' => sub {
  my $c = shift;
  my $map = apocalypse_map($c);
  $c->render(text => $map, format => 'txt');
};

sub star_map {
  my $c = shift;
  my $seed = $c->param('seed') || int(rand(1000000000));
  srand($seed);
  my $hash = $c->req->params->to_hash;
  return Game::TextMapper::Traveller->new(%$hash)->generate_map();
}

get '/traveller' => sub {
  my $c = shift;
  my $map = star_map($c);
  if ($c->stash('format') || '' eq 'txt') {
    $c->render(text => $map);
  } else {
    $c->render(template => 'edit', map => $map);
  }
};

get '/traveller/random' => sub {
  my $c = shift;
  my $map = star_map($c);
  my $mapper = Game::TextMapper::Mapper::Hex->new(dist_dir => $dist_dir);
  my $svg = $mapper->initialize($map)->svg;
  $c->render(text => $svg, format => 'svg');
};

get '/traveller/random/text' => sub {
  my $c = shift;
  my $map = star_map($c);
  $c->render(text => $map, format => 'txt');
};

get '/help' => sub {
  my $c = shift;

  seek(DATA,0,0);
  local $/ = undef;
  my $pod = ;
  $pod =~ s/=head1 NAME\n.*=head1 DESCRIPTION/=head1 Text Mapper/gs;
  my $parser = Pod::Simple::HTML->new;
  $parser->html_header_after_title('');
  $parser->html_header_before_title('');
  $parser->title_prefix('');
  my $html;
  $parser->output_string(\$html);
  $parser->parse_string_document($pod);

  my $dom = Mojo::DOM->new($html);
  for my $pre ($dom->find('pre')->each) {
    my $map = $pre->text;
    $map =~ s/^    //mg;
    next if $map =~ /^perl/; # how to call it
    my $url = $c->url_for('render')->query(map => $map);
    $pre->replace("" . xml_escape($map) . "\n"
		  . qq{Render this example});
  }

  $c->render(html => $dom);
};

app->start;

__DATA__