File Coverage

blib/lib/Game/HexDescribe.pm

Criterion	Covered	Total	%
statement	45	74	60.8
branch	5	16	31.2
condition	1	2	50.0
subroutine	12	16	75.0
pod	4	5	80.0
total	67	113	59.2

line

stmt

bran

cond

sub

pod

time

code

1

#!/usr/bin/env perl

2

# Copyright (C) 2018–2022 Alex Schroeder

3

#

4

# This program is free software: you can redistribute it and/or modify it under

5

# the terms of the GNU Affero General Public License as published by the Free

6

# Software Foundation, either version 3 of the License, or (at your option) any

7

# later version.

8

#

9

# This program is distributed in the hope that it will be useful, but WITHOUT

10

# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS

11

# FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more

12

# details.

13

#

14

# You should have received a copy of the GNU Affero General Public License along

15

# with this program. If not, see .

16

17

=encoding utf8

18

19

=head1 NAME

20

21

Game::HexDescribe - a web app to add random table driven data to map data

22

23

=head1 DESCRIPTION

24

25

Hex Describe is a web application which uses recursive random tables to create

26

the description of a map. A map in this context is a hex map. This is different

27

from other such tools like Tracery because a collection of locations on a maps

28

differ from a list of unrelated items. Neighbouring locations can share features

29

and thus a river can flow through many locations, a forest can cover many

30

locations, and so on.

31

32

On a technical level, Hex Describe is a web app based on the Mojolicious

33

framework. This class in particular uses L.

34

35

See L for more information.

36

37

=cut

38

39

package Game::HexDescribe;

40

41

our $VERSION = 1.02;

42

43

1

3714

use Modern::Perl;

1

2

1

9

44

1

575

use Mojolicious::Lite;

1

60553

1

6

45

1

19825

use Mojo::UserAgent;

1

2

1

5

46

1

25

use Mojo::Util qw(html_unescape);

1

1

1

33

47

1

5

use Mojo::ByteStream;

1

2

1

28

48

1

75

use Game::HexDescribe::Utils qw(init describe_text parse_table load_table

49

1

588

describe_map parse_map load_map);

1

2

50

1

5

use Game::HexDescribe::Log;

1

2

1

18

51

1

4

use Encode qw(decode_utf8);

1

2

1

32

52

1

442

use File::ShareDir qw(dist_dir);

1

20717

1

44

53

1

7

use Cwd;

1

1

1

4434

54

55

# Commands for the command line!

56

push @{app->commands->namespaces}, 'Game::HexDescribe::Command';

57

58

=head2 Configuration

59

60

As a Mojolicious application, it will read a config file called

61

F in the same directory, if it exists. As the default log

62

level is 'warn', one use of the config file is to change the log level using

63

the C key, and if you're not running the server in a terminal, using

64

the C key to set a file.

65

66

The default map and table are stored in the F directory. You can change

67

this directory using the C key. By default, the directory included with

68

the distribution is used. Thus, if you're a developer, you probably want to use

69

something like the following to use the files from the source directory.

70

71

{

72

loglevel => 'debug',

73

logfile => undef,

74

contrib => 'share',

75

};

76

77

The default map was created using Text Mapper's Alpine algorithm at one point in

78

time and the code has changed in the mean time, so it cannot be recreated

79

anymore.

80

81

=cut

82

83

plugin Config => {

84

default => {

85

loglevel => 'warn',

86

logfile => undef,

87

contrib => dist_dir('Game-HexDescribe'),

88

},

89

file => getcwd() . '/hex-describe.conf',

90

};

91

92

my $log = Game::HexDescribe::Log->get;

93

$log->level(app->config('loglevel'));

94

$log->path(app->config('logfile'));

95

$log->info($log->path ? "Logfile is " . $log->path : "Logging to stderr");

96

97

=head2 URLs

98

99

The code needs to know where Text Mapper and the Face Generator can be found.

You can add these to the same config file we mentioned above. This is what you

probably want as a developer:

{

text_mapper_url => 'http://localhost:3010',

face_generator_url => 'http://localhost:3020',

};

This assumes you are running the two locally. See L for Text

Mapper.

=cut

my $text_mapper_url = app->config('text_mapper_url') || 'https://campaignwiki.org/text-mapper';

$log->debug("Text Mapper URL: $text_mapper_url");

$Game::HexDescribe::Util::face_generator_url = app->config('face_generator_url') || 'https://campaignwiki.org/face';

$log->debug("Face Generator URL: $Game::HexDescribe::Util::face_generator_url");

$Game::HexDescribe::Util::text_mapper_url = app->config('text_mapper_url') || 'https://campaignwiki.org/text-mapper';

$log->debug("Text Mapper URL: $Game::HexDescribe::Util::text_mapper_url");

=head2 Entry Points

As this is a web app, the URLs you can call are basically the API it exposes.

Each URL can accept either I or I requests, or I.

=over 4

=item get /

The default entry point is where you I your map and table. B is the

map, B is the URL to an external table, B is the text of the table

if you want to paste it. See C below if you want to display the

result instead of allow the user to edit the form.

=cut

get '/' => sub {

my $c = shift;

my $map = $c->param('map') || load_map('default', app->config('contrib'));

my $url = $c->param('url');

my $table = $c->param('table');

$c->render(template => 'edit', map => $map, url => $url, table => $table);

} => 'edit';

=item get /load/random/smale

This shows you the I page again, with a new random map generated by Text

Mapper using the Smale algorithm.

=cut

get '/load/random/smale' => sub {

my $c = shift;

my $url = "$text_mapper_url/smale/random/text";

my $map = get_data($url);

$c->render(template => 'edit', map => $map, url=>'', table => '');

};

=item get /load/random/apocalypse

This shows you the I page again, with a new random map generated by Text

Mapper using the Apocalypse algorithm.

=cut

get '/load/random/apocalypse' => sub {

my $c = shift;

my $url = "$text_mapper_url/apocalypse/random/text";

my $map = get_data($url);

$c->render(template => 'edit', map => $map, url=>'', table => '');

};

=item get /load/random/traveller

This shows you the I page again, with a new random map generated by Text

Mapper using the Traveller algorithm.

=cut

get '/load/random/traveller' => sub {

my $c = shift;

my $url = "$text_mapper_url/traveller/random/text";

my $map = get_data($url);

$c->render(template => 'edit', map => $map, url=>'', table => '');

};

=item get /load/random/alpine

This shows you the I page again, with a new random map generated by Text

Mapper using the Alpine algorithm.

=cut

get '/load/random/alpine' => sub {

my $c = shift;

my $url = "$text_mapper_url/alpine/random/text";

my $map = get_data($url);

$c->render(template => 'edit', map => $map, url=>'', table => '');

};

=item get /stats/random/alpine

This uses a random map and the Alpine algorithm, and describes the map, and then

it presents you with some stats.

=cut

get '/stats/random/alpine' => sub {

my $c = shift;

my $url = "$text_mapper_url/alpine/random/text";

my $map_data = parse_map(get_data($url));

my %reverse_map;

for my $coords (keys %$map_data) {

for my $type (@{$map_data->{$coords}}) {

$reverse_map{$type} ||= 0;

$reverse_map{$type}++;

}

}

my $table = load_table('schroeder', app->config('contrib'));

my $descriptions = describe_map($map_data, parse_table($table), 0);

my %reverse_creatures;

for my $coords (keys %$descriptions) {

while ($descriptions->{$coords} =~ m!(.+?)!g) {

$reverse_creatures{$1} ||= 0;

$reverse_creatures{$1}++;

}

}

$c->render(template => 'stats',

map_stats => \%reverse_map,

creature_stats => \%reverse_creatures);

};

=item any /describe

This is where the actual map is described.

B is the map, B is the URL to an external table, B is the text

of the table, and a table will be loaded based on the B parameter. Current

valid values are I, I, I, I, and

I.

If we want to call this from the command line, we will need to request a map

from Text Mapper, too.

text-mapper get /alpine.txt > map.txt

hex-describe get /describe --form map=@map.txt --form load=schroeder

Pipe through C to get text instead of HTML.

=cut

any '/describe' => sub {

my $c = shift;

my $map = $c->param('map');

my $labels = $c->param('labels');

my $markdown = $c->param('markdown');

my $faces = $c->param('faces');

my $table = get_table($c);

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), $faces);

if ($markdown) {

my $texts = [];

my $top = delete $descriptions->{TOP};

my $end = delete $descriptions->{END};

push(@$texts, $top) if $top;

for my $hex (sort keys %$descriptions) {

push(@$texts, "**$hex**: $descriptions->{$hex}");

}

push(@$texts, $end) if $end;

$c->render(text => markdown($texts), format => 'txt');

} else {

$map = add_labels($map) if $labels;

my $svg = get_post_data($text_mapper_url . '/render', map => $map);

$c->render(template => 'description',

svg => add_links($svg),

descriptions => $descriptions);

}

};

=item get /describe/random/smale

This variant is for when you want to just keep reloading and getting different

maps with different descriptions. Note that you may pass a C parameter,

which determines the map retrieved by Text Mapper. This allows you to refer to

an existing, random map, if you use the seed parameter in that URL. If you don't

provide a URL, a random map using the Smale algorithm will get used. The

description will be generated using the Seckler tables.

=cut

get '/describe/random/smale' => sub {

my $c = shift;

my $labels = $c->param('labels');

my $url = $c->param('url') || "$text_mapper_url/smale/random/text";

my $map = get_data($url);

my $table = load_table('seckler', app->config('contrib'));

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), 1); # with faces

$map = add_labels($map) if $labels;

my $svg = get_post_data("$text_mapper_url/render", map => $map);

$c->render(template => 'description',

svg => add_links($svg),

url => $url,

descriptions => $descriptions);

};

=item get /describe/random/alpine

Same thing for a map using the Alpine algorithm and the Schroeder random tables.

=cut

get '/describe/random/alpine' => sub {

my $c = shift;

my $labels = $c->param('labels');

my $seed = $c->param('seed');

my $url = $c->param('url');

if (not $url) {

$url = "$text_mapper_url/alpine/random/text";

$url .= "?seed=$seed" if $seed;

}

srand($seed) if $seed;

my $map = get_data($url);

my $table = load_table('schroeder', app->config('contrib'));

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), 1); # with faces

$map = add_labels($map) if $labels;

my $svg = get_post_data("$text_mapper_url/render", map => $map);

$c->render(template => 'description',

svg => add_links($svg),

url => $url,

descriptions => $descriptions);

};

=item get /describe/random/strom

Same thing for a map using the Smale algorithm and the Strom random tables.

=cut

get '/describe/random/strom' => sub {

my $c = shift;

my $labels = $c->param('labels');

my $url = $c->param('url') || "$text_mapper_url/smale/random/text";

my $map = get_data($url);

my $table = load_table('strom', app->config('contrib'));

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), 1); # with faces

$map = add_labels($map) if $labels;

my $svg = get_post_data("$text_mapper_url/render", map => $map);

$c->render(template => 'description',

svg => add_links($svg),

url => $url,

descriptions => $descriptions);

};

=item get /describe/random/johnston

Same thing for a map using the Apocalypse algorithm and the Johnston random tables.

=cut

get '/describe/random/johnston' => sub {

my $c = shift;

my $labels = $c->param('labels');

my $url = $c->param('url') || "$text_mapper_url/apocalypse/random/text";

my $map = get_data($url);

my $table = load_table('johnston', app->config('contrib'));

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), 1); # with faces

$map = add_labels($map) if $labels;

my $svg = get_post_data("$text_mapper_url/render", map => $map);

$c->render(template => 'description',

svg => add_links($svg),

url => $url,

descriptions => $descriptions);

};

=item get /describe/random/traveller

Same thing for a map using the Traveller algorithm and the Traveller random tables.

=cut

get '/describe/random/traveller' => sub {

my $c = shift;

my $labels = $c->param('labels');

my $url = $c->param('url') || "$text_mapper_url/traveller/random/text";

my $map = get_data($url);

my $table = load_table('traveller', app->config('contrib'));

init();

my $descriptions = describe_map(parse_map($map), parse_table($table), 1); # with faces

$map = add_labels($map) if $labels;

my $svg = get_post_data("$text_mapper_url/render", map => $map);

$c->render(template => 'description',

svg => add_links($svg),

url => $url,

descriptions => $descriptions);

};

=item get /nomap

This shows you the I page for use cases without a map. Now you're using

Hex Describe like many of the existing random table driven text generators. This

is where you can test your tables. If you've changed the code for the I

table, for example, generate a few villages to see some examples:

[village]

[village]

[village]

[village]

[village]

B is your source text. This is no longer a map. B is the URL to an

external table, B is the text of the table if you want to paste it. See

C below if you want to display the result instead of allow the

user to edit the form.

=cut

get '/nomap' => sub {

my $c = shift;

my $input = $c->param('input') || '';

my $url = $c->param('url');

my $table = $c->param('table');

my $seed = $c->param('seed') || time;

srand($c->param('seed')) if $c->param('seed');

$c->render(template => 'nomap', input => $input, url => $url, table => $table, seed => $seed);

};

any '/nomap/markdown' => sub {

my $c = shift;

my $input = $c->param('input') || '';

my $table = get_table($c);

my $seed = $c->param('seed') || time;

srand($c->param('seed')) if $c->param('seed');

my $descriptions = describe_text($input, parse_table($table));

$c->render(text => markdown($descriptions), format => 'txt', seed => $seed);

} => 'nomap_markdown';

=item /rules

This lists all the rules we have and allows you to pick one.

=cut

get '/rules' => sub {

my $c = shift;

my $input = $c->param('input') || '';

my $url = $c->param('url');

my $table = $c->param('table');

$c->render(template => 'rules', input => $input, url => $url, table => $table);

};

any '/rules/list' => sub {

my $c = shift;

my $input = $c->param('input') || '';

my ($url, $table) = get_table($c);

# we cannot test for 'load' because a radiobutton is always selected

if ($c->param('url') or $c->param('table')) {

$c->render(template => 'ruleslist_post', input => $input,

url => $url, table => $table,

log => $c->param('log'),

rules => [keys %{parse_table($table)}]);

} else {

$c->render(template => 'ruleslist_get',

load => $c->param('load'),

log => $c->param('log'),

rules => [keys %{parse_table($table)}]);

}

} => 'ruleslist';

sub to_id {

1

261

$_ = shift;

1

5

return "" unless $_;

1

12

s/ /_/g;

1

7

s/[^0-9a-z_]//gi;

1

5

s/^(\d)/x$1/;

1

5

$_;

}

any '/rule' => sub {

my $c = shift;

my $rule = $c->param('rule');

my $n = $c->param('n') || 10;

my $input = "[$rule]\n" x $n;

my $table = get_table($c);

my $seed = $c->param('seed') || time;

srand($seed) if $seed;

my $descriptions = describe_text($input, parse_table($table), 1); # with redirects

$c->render(template => 'text', input => $input, load => $c->param('load'), seed => $seed,

n => $n, url => $c->param('url'), table => $c->param('table'),

rule => $rule, id => to_id($rule),

log => $c->param('log') ? $log->history : undef,

descriptions => $descriptions);

} => 'rule';

any '/rule/markdown' => sub {

my $c = shift;

my $rule = $c->param('rule');

my $n = $c->param('n') || 10;

my $input = $c->param('input') || "[$rule]\n" x $n;

my $table = get_table($c);

srand($c->param('seed')) if $c->param('seed');

my $descriptions = describe_text($input, parse_table($table), 1); # with redirects

$c->render(text => markdown($descriptions), format => 'txt');

} => 'rule_markdown';

any '/rule/show' => sub {

my $c = shift;

my $rule = $c->param('rule');

my $load = $c->param('load');

my $table = get_table($c);

$table =~ s!\r!!g;

$table =~ s!&!&!gm;

$table =~ s!

$table =~ s!>!>!gm;

$table =~ s!\[([^][\n]+)\]!"[$1]"!gme;

my $jump = 0;

if ($c->param('url') or $c->param('table')) {

$jump = 1;

$table =~ s!^;(.+)!";$1"!gme;

} else {

$table =~ s!^;(.+)!";

. "\" href=\"" . $c->url_for('rule')->query(load => $load, rule => $1)

. "\">$1"!gme;

}

$c->render(template => 'show',

id => to_id($rule),

rule => $rule,

jump => $jump,

load => $load,

table => $table);

} => 'rule_show';

=item any /describe/text

This is where the text input is rendered. B is the text, B is the

URL to an external table. If not provided, B is the text of the table. If

neither is provided, the default table is used.

To call this from the command line:

hex-describe get /describe/text --form input=[village] --form load=schroeder

Pipe through C to get text instead of HTML.

=cut

any '/describe/text' => sub {

my $c = shift;

my $rule = $c->param('rule');

my $load = $c->param('load');

my $n = $c->param('n');

my $input = $c->param('input');

my $url = $c->param('url');

my $table = $c->param('table');

my $seed = $c->param('seed');

srand($seed) if $seed;

my $data = get_table($c); # must be scalar context

$c->render(template => 'text', input => $input, load => $load, seed => $seed,

n => $n, url => $url, table => $table,

rule => $rule, id => to_id($rule),

log => $c->param('log') ? $log->history : undef,

descriptions => describe_text($input, parse_table($data)));

};

=item get /default/map

This shows you the default map.

=cut

get '/default/map' => sub {

my $c = shift;

$c->render(text => load_map('default', app->config('contrib')), format => 'txt');

};

=item get /schroeder/table

This shows you the table by Alex Schroeder.

=cut

get '/schroeder/table' => sub {

my $c = shift;

$c->render(text => load_table('schroeder', app->config('contrib')), format => 'txt');

};

=item get /seckler/table

This shows you the table by Peter Seckler.

=cut

get '/seckler/table' => sub {

my $c = shift;

$c->render(text => load_table('seckler', app->config('contrib')), format => 'txt');

};

=item get /strom/table

This shows you the table by Matt Strom.

=cut

get '/strom/table' => sub {

my $c = shift;

$c->render(text => load_table('strom', app->config('contrib')), format => 'txt');

};

=item get /johnston/table

This shows you the table by Josh Johnston.

=cut

get '/johnston/table' => sub {

my $c = shift;

$c->render(text => load_table('johnston', app->config('contrib')), format => 'txt');

};

=item get /traveller/table

This shows you the Traveller table by Vicky Radcliffe and Alex Schroeder.

=cut

get '/traveller/table' => sub {

my $c = shift;

$c->render(text => load_table('traveller', app->config('contrib')), format => 'txt');

};

=item get /rorschachhamster/table

Für die deutschen Tabellen von Rorschachhamster Alex Schroeder.

=cut

get '/rorschachhamster/table' => sub {

my $c = shift;

$c->render(text => load_table('rorschachhamster', app->config('contrib')), format => 'txt');

};

=item get /source

This gets you the source code of Hex Describe in case the source repository is

no longer available.

=cut

get '/source' => sub {

my $c = shift;

seek(DATA,0,0);

local $/ = undef;

$c->render(text => , format => 'txt');

};

=item get /authors

This lists the contributors to Hex Describe.

=cut

get '/authors' => sub {

my $c = shift;

$c->render(template => 'authors');

};

=item get /help

This shows you a little tutorial. Unlike this documentation, which is for

programmers, the tutorial is for the users of the app.

=cut

get '/help' => sub {

my $c = shift;

$c->render(template => 'help');

};

=back

=head2 Code

This chapter is used to document the code.

=over 4

=item get_data

This is is the basic work horse to get data from a URL. It is used to download

the table from a URL, if provided. This uses a simple GET request.

=cut

sub get_data {

0

my $url = shift;

0

$log->debug("get_data: $url");

0

my $ua = Mojo::UserAgent->new;

0

my $res = $ua->get($url)->result;

0

return decode_utf8($res->body) if $res->is_success;

0

$log->error("get_data: " . $res->code . " " . $res->message);

}

=item get_post_data

This is is used to get data from a URL when we need a POST request instead of a

GET request. We need this for Text Mapper when rendering the map since we send

the entire map to Text Mapper in order to render it. A simple GET request will

not do.

=cut

sub get_post_data {

0

my $url = shift;

0

my %data = @_;

0

$log->debug("get_post_data: $url");

0

my $ua = Mojo::UserAgent->new;

0

my $tx = $ua->post($url => form => \%data);

0

my $error;

0

if (my $err = $tx->error) {

0

if ($err->{code}) {

0

$error = $err->{code} . " " . $err->{message};

} else {

0

$error = $err->{message};

}

} else {

0

my $res = $ua->post($url => form => \%data)->result;

0

return decode_utf8($res->body) if $res->is_success;

0

$error = $res->code . " " . $res->message;

}

0

$log->error("get_post_data: $error");

0

return "

There was an error when attempting to load the map ($error).

";

}

=item get_table

This function gets a Mojolicious Controller object and looks for C,

C, C and C parameters in order to determine the table data to

742							use.
743
744							=cut
745
746							sub get_table {
747	2			2	1	4	my $c = shift;
748	2					8	my $load = $c->param('load');
749	2					100	my $url = $c->param('url');
750	2					103	my $table = '';
751	2	50				8	$table .= get_data($url) if $url;
752	2	50				18	$table .= load_table($load, app->config('contrib')) if $load;
753							# the table in the text area comes at the end and overrides the defaults
754	2		50			10980	$table .= $c->param('table') \|\| '';
755	2	100				182	return $url, $table if wantarray;
756	1					5	return $table;
757							}
758
759							=item add_links
760
761							After we get the SVG map from Text Mapper, we need to add links to the hex
762							descriptions. Text Mapper already allows us to define an URL such that I
763							get linked to that URL. This feature is of no use to us because we're not using
764							labels. Basically, we want to add links to the I. This function
765							does that: it goes through the SVG and adds appropriate anchor elements.
766
767							=cut
768
769							sub add_links {
770	0			0	1		my $svg = shift;
771	0						$svg =~ s/<\?xml[^>]>\s//g; # remove processing instruction
772	0						my $dom = Mojo::DOM->new($svg);
773							$dom->find('g#coordinates text')
774							->each(sub {
775	0			0			my $text = $_->text;
776	0						$text =~ s/\.//; # strip dot
777	0						$_->wrap(qq{})});
	0
778	0						return "$dom";
779							}
780
781							=item helper example
782
783							This Mojolicious helper is used on the help page to make all the examples
784							clickable.
785
786							=cut
787
788							helper example => sub {
789							my ($c, $block) = @_;
790							my $result = $block->();
791							my $url;
792							if ($result =~ /^\d\d\d\d/m) {
793							my $map = join("\n", grep(/^\d\d\d\d\|^include/, split(/\n/, $result)));
794							my $table = join("\n", grep(!/^\d\d\d\d\|^include/, split(/\n/, $result)));
795							$url = $c->url_for('edit')->query(map => $map,
796							load => 'none',
797							table=> html_unescape($table));
798							} else {
799							my ($key) = $result =~ /^;(.*)/m;
800							$url = $c->url_for('nomap')->query(input => "[$key]\n" x 10,
801							load => 'none',
802							table=> html_unescape($result));
803							}
804							return Mojo::ByteStream->new(qq( $result Try it. ));
805							};
806
807							=back
808
809							=head2 Finally
810
811							Start the app at the very end. The rest is templates for the various web pages.
812
813							=cut
814
815							app->start;
816
817							__DATA__