#!/usr/bin/perl # Copyright (C) 2007 Alex Schroeder # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the # Free Software Foundation, Inc. # 59 Temple Place, Suite 330 # Boston, MA 02111-1307 USA use CGI qw/:standard/; use strict; =head1 Old School Hex Mapper A CGI script that will accept a map written using ASCII characters and create an SVG map. =cut # $Id: old-school-hex.pl,v 1.17 2007/06/08 23:36:23 alex Exp $ package Hex; use Class::Struct; struct Hex => { x => '$', y => '$', type => '$', road => '$', map => 'Mapper', }; sub at { my ($self, $x, $y) = @_; return $self->x == $x && $self->y == $y; } sub str { my $self = shift; return '(' . $self->x . ',' . $self->y . ')'; } my $dx = 100*sqrt(3); my $dy = 100; sub svg { my $self = shift; my $x = $self->x; my $y = $self->y; my $type = $self->type; my $data = sprintf(qq{ \n} . qq{ } . qq{%d, %d} . qq{\n}, $x * $dx + $y * $dx / 2, $y * 3 / 2 * $dy, $type, $x * $dx + $y * $dx / 2, $y * 3 / 2 * $dy - $dy * 2 / 3, $x, $y); if ($self->road) { foreach my $tile ($self->straight_roads, $self->road_start, $self->bent_roads, $self->very_bent_roads) { $data .= sprintf(qq{ \n}, $x * $dx + $y * $dx / 2, $y * 3 / 2 * $dy, $tile->{name}, $tile->{angle}, $x * $dx + $y * $dx / 2, $y * 3 / 2 * $dy); } } return $data; } =head3 @connect The connection data to connect to neighbouring hexes. The array is indexed as follows: 2 3 1 4 0 5 =cut my $connect = [[-1, +1, 0], [-1, 0, 60], [ 0, -1, 120], [+1, -1, 180], [+1, 0, 240], [ 0, +1, 300]]; =head3 neighbor Return the neighboring hex specified by number: 2 3 1 4 0 5 =cut sub neighbor { my ($self, $num) = @_; my $x = $self->x + @$connect[$num]->[0]; my $y = $self->y + @$connect[$num]->[1]; my $hex = $self->map->get($x, $y); # warn "getting ($x,$y) -> $hex\n"; return $hex; } =head3 neighbors Return a list of all neighboring hexes. This returns an array of exactly six elements indexed by direction. An undefined elements means that there is no neighbour in this direction. These are the directions: 2 3 1 4 0 5 =cut sub neighbors { my $self = shift; return map { $self->neighbor($_); } 0..5; } =head3 angle Return the angle between the current hex and the one provided. Basically this is the direction times 60. These are the directions: 2 3 1 4 0 5 =cut sub angle { my ($self, $obj1, $obj2) = @_; if (ref($obj1) eq 'Hex') { my $dx = $obj1->x - $self->x; my $dy = $obj1->y - $self->y; foreach my $conn (@$connect) { return $conn->[2] if $conn->[0] == $dx && $conn->[1] == $dy; } } elsif (defined($obj2)) { return ($obj2 - $obj1) * 60; } die "Unknown objects $obj1 and $obj2"; } =head3 neighboring_roads Return a list of all neighboring hexes containing roads. =cut sub neighboring_roads { my $self = shift; my @result; foreach my $hex ($self->neighbors) { push(@result, $hex) if $hex && $hex->road; } return @result; } =head3 straight_roads Look at surrounding hexes to determine if there is a straight road running through the current hex. Return a list of hash-references, each hash containing two keys: The name of the tile to use and the angle to rotate it by. =cut sub straight_roads { my $self = shift; my @hex = $self->neighbors; my @roads; foreach my $dir ([0,3], [1,4], [2,5]) { my $from = $dir->[0]; my $to = $dir->[1]; # warn join(', ', $self->str, $from, $to, $hex[$from], $hex[$to]), "\n"; if ($hex[$from] && $hex[$to] && $hex[$from]->road && $hex[$to]->road) { push(@roads, {name => "road180", angle => $self->angle($hex[$from])}); } } return @roads; } =head3 road_start Look at surrounding hexes to determine if there is but a single road leaving the hex. Return the angle you need to rotate the tile by in order to draw the road. =cut sub road_start { my $self = shift; my @hexes = $self->neighboring_roads; # warn sprintf("%s has %d neighbors\n", $self->str, $#hexes+1); return () if $#hexes != 0; # more than one neighboring hex has a road, or none return {name=>'road-start', angle=>$self->angle($hexes[0])}; } =head3 bent_roads Look at surrounding hexes to determine if there are two neighbors with roads at a 120° angle. Return the angle you need to rotate the tile by in order to draw the road. =cut sub bent_roads { my $self = shift; my @hexes = $self->neighboring_roads; return () if $#hexes > 2; # only works for three or less neighboring hexes with roads my @hex = $self->neighbors; my @roads = (); foreach my $dir ([0,2], [1,3], [2,4], [3,5], [4,0], [5,1]) { my $from = $dir->[0]; my $to = $dir->[1]; if ($hex[$from] && $hex[$to] && $hex[$from]->road && $hex[$to]->road) { push(@roads, {name => "road120", angle => $self->angle($hex[$from])}); } } return @roads; } =head3 very_bent_roads Look at surrounding hexes to determine if there are two neighbours at a 60° angle. Only hexes with two neighboring roads are candidates. Return the angle you need to rotate the tile by in order to draw the road. FIXME: Is this required? =cut sub very_bent_roads { my $self = shift; my @hexes = $self->neighboring_roads; return () if $#hexes != 1; # only works for exactly two neighboring hexes with roads my @hex = $self->neighbors; my @roads = (); foreach my $dir ([0,1], [1,2], [2,3], [3,4], [4,5], [5,0]) { my $from = $dir->[0]; my $to = $dir->[1]; if ($hex[$from] && $hex[$to] && $hex[$from]->road && $hex[$to]->road) { push(@roads, {name => "road60", angle => $self->angle($hex[$from])}); } } return @roads; } package Mapper; use Class::Struct; struct Mapper => { hexes => '@', }; my %char = ( 'n' => 'hill', 'o' => 'town', 'O' => 'city', '"' => 'grass', '.' => 'empty', '-' => 'road', ); sub chars { return join("\n", map { $_ . ' - ' . $char{$_} } keys %char); } my $example = q{" " o " " n " " . n-n O-. . n-"-" . }; sub example { return $example; } my $dx = 100*sqrt(3); my $dy = 100; # data goes where the first empty line is my $doc = sprintf(qq{ Old School Hex Map }, -$dx/2, -$dy/2, -$dx/2, $dy/2, 0, $dy, $dx/2,$dy/2, $dx/2, -$dy/2, 0, -$dy); sub initialize { my ($self, $map) = @_; my $y = 0; foreach (split(/\n/, $map)) { my $i = 0; my $hex; my $offset = int(-$y/2); foreach my $c (split(//, $_)) { if ($char{$c}) { # skip every second character depending on the row if (($i + $y) % 2) { my $x = $offset + int(($i - 1)/2); die "the road at ($x,$y) doesn't belong to the current hex " if $hex->x != $x || $hex->y != $y; # warn sprintf("$i: adding road to ($x,$y) at %s\n", $hex->str); $hex->road(1); } else { my $x = $offset + int($i/2); # warn "$i: creating $char{$c} ($c) hex ($x,$y)\n"; $hex = Hex->new(x => $x, y => $y, type => $char{$c}, map => $self); $self->add($hex); } } $i++; } $y++; } } sub add { my ($self, $hex) = @_; push(@{$self->hexes}, $hex); } # This implementation is *very* slow. sub get { my ($self, $x, $y) = @_; foreach my $hex (@{$self->hexes}) { if ($hex->at($x, $y)) { return $hex; } } # warn "did not find ($x,$y)\n"; return undef; } sub svg { my ($self) = @_; my $data; foreach my $hex (@{$self->hexes}) { $data .= $hex->svg(); } $doc =~ s/\n\n/\n$data/; return $doc; } package main; =head2 The Coordinate System The coordinates of the hex map use a slanted Y axis: 0,-1 1,-1 2,-1 -1,0 0,0 1,0 2,0 -1,1 0,1 1,1 -1,2 0,2 1,2 -1,3 0,3 =cut sub print_map { print header(-type=>'image/svg+xml'); my $map = new Mapper; $map->initialize(shift); print $map->svg; } sub print_html { print (header(-type=>'text/html; charset=UTF-8'), start_html(-encoding=>'UTF-8', -title=>'Old School Hex Mapper', -author=>'kensanata@gmail.com'), h1('Old School Hex Mapper'), p('Submit your ASCII map of the area using the following characters:'), pre(Mapper->chars()), p('Notice how you need to use spaces to align the regions in the following example:'), pre(Mapper->example()), start_form(-method=>'GET'), p('ASCII map: '), p(textarea('map', Mapper::example(), 15, 60)), p(submit()), end_form(), hr(), p(address(a({-href=>'http://www.emacswiki.org/cgi-bin/alex/About'}, 'Alex Schröder'))), end_html()); } sub main { if (param('map')) { print_map(param('map')); } else { print_html(); } } main ();