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.04;

42

43

6

1436958

use Modern::Perl;

6

15

6

57

44

6

7636

use Mojolicious::Lite;

6

2063583

6

31

45

6

165079

use Mojo::UserAgent;

6

15

6

41

46

6

229

use Mojo::Util qw(html_unescape);

6

29

6

268

47

6

27

use Mojo::ByteStream;

6

10

6

248

48

6

684

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

49

6

4033

describe_map parse_map load_map markdown);

6

20

50

6

35

use Game::HexDescribe::Log;

6

9

6

129

51

6

23

use Encode qw(decode_utf8);

6

8

6

213

52

6

3122

use File::ShareDir qw(dist_dir);

6

140724

6

431

53

6

50

use Cwd;

6

26

6

32437

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';

$Game::HexDescribe::Util::text_mapper_url = $text_mapper_url;

$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");

=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.

The config file key C can be used to host the entire application on a

specific path. Example C file:

{

loglevel => 'debug',

logfile => undef,

contrib => 'share',

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

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

under => 'hex-describe',

};

Command line to start it:

morbo --mode development --listen http://*:3000 script/hex-describe

The result is that Hex Describe is now available via

C.

=cut

my $under = app->config('under');

under $under if $under;

=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. B determines the table to load. Current valid values are

I, I, I, I, and I. B

returns Markdown and no map. B determines whether images are kept in the

HTML output. B determines whether the map is kept in the HTML output.

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 $show = $c->param('show');

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');

} elsif ($show) {

$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);

} else {

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

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

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

222

$_ = shift;

1

3

return "" unless $_;

1

4

s/ /_/g;

1

3

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

1

4

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

1

3

$_;

}

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

771							use.
772
773							=cut
774
775							sub get_table {
776	3			3	1	6	my $c = shift;
777	3					7	my $load = $c->param('load');
778	3					124	my $url = $c->param('url');
779	3					115	my $table = '';
780	3	50				11	$table .= get_data($url) if $url;
781	3	50				22	$table .= load_table($load, app->config('contrib')) if $load;
782							# the table in the text area comes at the end and overrides the defaults
783	3		50			23104	$table .= $c->param('table') \|\| '';
784	3	100				292	return $url, $table if wantarray;
785	2					9	return $table;
786							}
787
788							=item add_links
789
790							After we get the SVG map from Text Mapper, we need to add links to the hex
791							descriptions. Text Mapper already allows us to define an URL such that I
792							get linked to that URL. This feature is of no use to us because we're not using
793							labels. Basically, we want to add links to the I. This function
794							does that: it goes through the SVG and adds appropriate anchor elements.
795
796							=cut
797
798							sub add_links {
799	0			0	1		my $svg = shift;
800	0						$svg =~ s/<\?xml[^>]>\s//g; # remove processing instruction
801	0						my $dom = Mojo::DOM->new($svg);
802							$dom->find('g#coordinates text')
803							->each(sub {
804	0			0			my $text = $_->text;
805	0						$text =~ s/\.//; # strip dot
806	0						$_->wrap(qq{})});
	0
807	0						return "$dom";
808							}
809
810							=item helper example
811
812							This Mojolicious helper is used on the help page to make all the examples
813							clickable.
814
815							=cut
816
817							helper example => sub {
818							my ($c, $block) = @_;
819							my $result = $block->();
820							my $url;
821							if ($result =~ /^\d\d\d\d/m) {
822							my $map = join("\n", grep(/^\d\d\d\d\|^include/, split(/\n/, $result)));
823							my $table = join("\n", grep(!/^\d\d\d\d\|^include/, split(/\n/, $result)));
824							$url = $c->url_for('edit')->query(map => $map,
825							load => 'none',
826							table=> html_unescape($table));
827							} else {
828							my ($key) = $result =~ /^;(.*)/m;
829							$url = $c->url_for('nomap')->query(input => "[$key]\n" x 10,
830							load => 'none',
831							table=> html_unescape($result));
832							}
833							return Mojo::ByteStream->new(qq( $result Try it. ));
834							};
835
836							=back
837
838							=head2 Finally
839
840							Start the app at the very end. The rest is templates for the various web pages.
841
842							=cut
843
844							app->start \|\| 1;
845
846							__DATA__