Games-RolePlay-MapGen
view release on metacpan or search on metacpan
MapGen/Editor.pm view on Meta::CPAN
# vi:filetype=perl:
package Games::RolePlay::MapGen::Editor;
# NOTE: I'm aware this is monolithic and heinous, please don't judge me. I
# intend to split this up into manageable chunks (aka modules) later. I'm new
# to GUI code and I'm surprised how big it gets.
#
# -Paul
use common::sense;
use GD;
use Glib qw(TRUE FALSE);
use Gtk2 -init; # -init tells import to ->init() your app
use Gtk2::Ex::Simple::Menu;
use Gtk2::Ex::Dialogs::ErrorMsg;
use Gtk2::Ex::Dialogs::Question;
use Gtk2::Ex::PodViewer;
use Gtk2::SimpleList;
use Games::RolePlay::MapGen;
use File::HomeDir;
use File::Spec;
use DB_File;
use Storable qw(freeze thaw);
use Data::Dump qw(dump);
use POSIX qw(ceil);
use MIME::Base64;
use POE::Component::Server::HTTP;
use POE::Kernel {loop => "Glib"};
use HTTP::Status;
use CGI qw(escapeHTML);
use Games::RolePlay::MapGen::MapQueue::Object;
use Games::RolePlay::MapGen::MapQueue;
use Games::RolePlay::MapGen::Editor::_MForm qw(make_form $default_restore_defaults);
use Games::RolePlay::MapGen::Tools qw( roll choice _door _group );
use version; our $VERSION = qv("1.0.0");
our $DEFAULT_GENERATOR = 'Basic';
our @GENERATORS = (qw( Basic Blank OneBigRoom Perfect SparseAndLoops ));
our @GENERATOR_PLUGINS = (qw( BasicDoors FiveSplit ));
our @DEFAULT_GENERATOR_PLUGINS = (qw( BasicDoors ));
our @FILTERS = (qw( BasicDoors FiveSplit ClearDoors ));
use vars qw($x); # like our, but at compile time so these constants work
use constant {
# the per-object index constants {{{
MAP => $x++, # the Games::RolePlay::MapGen object, the actual map arrays are in [MAP]{_the_map}
MQ => $x++, # the Games::RolePlay::MapGen::MapQueue object
WINDOW => $x++, # the Gtk2 window (Gtk2::Window)
MENU => $x++, # the main menubar (Gtk2::Ex::Simple::Menu)
MAREA => $x++, # the map area Gtk2::Image
VP_DIM => $x++, # the current dimensions (changes on resizes and things) of the Gtk2::Viewport holding the [MAREA]
SETTINGS => $x++, # a tied DB_File hashref full of settings
FNAME => $x++, # the current file name or undef
STAT => $x++, # the statusbar (Gtk2::Statusbar)
MP => $x++, # the current map pixbufs, cell size, and pixbuf dimensions
RCCM => $x++, # the right click context menus (there are two: [RCCM][0] for tiles and [RCCM][1] for closures)
O_LT => $x++, # the tile location currently moused-overed, O_ is for old, during the motion-notify, O_LT is the
# old location and LT is the new one, although, LT isn't a constant
SEL_S => $x++, # the selection start, set to O_LT when a button is pressed
SEL_E => $x++, # set to the end of the selection being dragged during the selection handler. really only used in
# the button release event to (possibly) select a single square when shift-clicking
SEL_W => $x++, # the currently "working" select rectangle, used to pop the end of SELECTION while *still* dragging
SELECTION => $x++, # the current selection rectangles [ [x1,y1,x2,y2], [...], ... ]
S_ARG => $x++, # the status-bar arguments: the current tile location (LT), tile type, and door info
# [\@lt, $tile->{type}, undef]; $sarg->[1] (type) is replaced with [$g->name, $g->desc] when
# $tile has a group... door info starts out as undef and changes to [dir=>desc] when there is a door
# moused-overed. Perhaps the best way to describe it is this huge block of examples:
# [[11, 9, "corridor"], undef, undef]
# [[12, 9, "corridor"], undef, ["s", ["wall"]]]
# [[6, 4, "room"], ["Room #1", "(4, 3) 10x8"], undef]
# [[6, 3, "room"], ["Room #1", "(4, 3) 10x8"], ["w", ["opening"]]]
# [[5, 5], ["Room #1", "(4, 3) 10x8"], undef]
# [[5, 5], ["Room #1", "(4, 3) 10x8"], ["e", ["opening"]]]
# [[6, 5, "room"], ["Room #1", "(4, 3) 10x8"], undef]
# [[6, 6, "room"], ["Room #1", "(4, 3) 10x8"], undef]
# [[6, 6], ["Room #1", "(4, 3) 10x8"], ["s", ["opening"]]]
# [[6, 7, "room"], ["Room #1", "(4, 3) 10x8"], ["n", ["opening"]]]
# [[6, 7], ["Room #1", "(4, 3) 10x8"], undef]
# [[6, 7], ["Room #1", "(4, 3) 10x8"], ["s", ["wall"]]]
# [[6, 8, "corridor"], undef, ["n", ["wall"]]]
# [[7, 8], undef, ["n", ["ordinary", "door"]]]
# [ [7, 7, "room"], ["Room #1", "(4, 3) 10x8"], ["s", ["ordinary", "door"]], ]
O_DR => $x++, # door info, [dir => desc], called O_DR since it's the "old" door. really only used to invoke a
# reddraw of the cursors when there *was* a door (O_DR) and there *nolonger* is one
SERVER => $x++, # the map server (if applicable) [port, PoCo::HTTPD]
# }}}
};
1;
# new {{{
sub new {
my $class = shift;
my $this = bless [], $class;
my $fname = "GRM Editor";
unless( File::Spec->case_tolerant ) {
$fname = lc $fname;
$fname =~ s/ /_/g;
substr($fname,0,0) = ".";
}
my @homedir = File::HomeDir->my_home;
push @homedir, "Application Data" if "@homedir" =~ m/Documents and Settings/i;
$fname = File::Spec->catfile(@homedir, $fname);
# warn "fname=$fname";
my %o; tie %o, DB_File => $fname or die $!;
MapGen/Editor.pm view on Meta::CPAN
callback => sub { $this->save_text_as },
},
],
},
_Close => {
item_type => '<StockItem>',
callback => sub { $this->blank_map },
accelerator => '<ctrl>W',
extra_data => 'gtk-close',
},
_Quit => {
item_type => '<StockItem>',
callback => sub { $this->quit },
accelerator => '<ctrl>Q',
extra_data => 'gtk-quit',
},
],
},
_Edit => {
item_type => '<Branch>',
children => [
'_Redraw' => {
callback => sub { warn "forced redraw"; $this->draw_map; $this->draw_map_w_cursor },
accelerator => '<ctrl>R',
},
'R_ender Settings'=> {
callback => sub { $this->render_settings },
},
'Server _Settings'=> {
callback => sub { $this->server_settings },
accelerator => '<ctrl>T',
},
Separator => {
item_type => '<Separator>',
},
_Preferences => {
item_type => '<StockItem>',
callback => sub { $this->preferences },
accelerator => '<ctrl>P',
extra_data => 'gtk-preferences',
},
],
},
_Help => {
item_type => '<LastBranch>',
children => [
_Help => {
item_type => '<StockItem>',
callback => sub { $this->help },
extra_data => 'gtk-help',
},
_About => {
item_type => '<StockItem>',
callback => sub { $this->about },
extra_data => 'gtk-about',
},
],
},
];
my $menu = $this->[MENU] = Gtk2::Ex::Simple::Menu->new (
menu_tree => $menu_tree,
default_callback => sub { $this->unknown_menu_callback },
);
$vbox->pack_start($menu->{widget}, 0,0,0);
$window->add_accel_group($menu->{accel_group});
my $marea = $this->[MAREA] = new Gtk2::Image;
my $scwin = Gtk2::ScrolledWindow->new;
my $vp = Gtk2::Viewport->new(undef,undef);
my $al = Gtk2::Alignment->new(0.5,0.5,0,0);
my $eb = Gtk2::EventBox->new;
$eb->set_has_tooltip(TRUE);
$eb->signal_connect( query_tooltip => sub {
my ($widget, $x, $y, $keyboard_mode, $tooltip) = @_;
my @cs = split('x', $this->[MAP]{cell_size});
my @tc = (int($x/$cs[0]), int($y/$cs[1]));
return FALSE unless $this->[MQ]->_check_loc(\@tc);
my @o = $this->[MQ]->objects_at_location(@tc);
return FALSE unless @o;
$tooltip->set_text(
join("\n",
map { my $d = $_->[0]->desc; my $v = ($_->[1]=~ s/(\d+)$/ $1/ ? $_->[1] : "living"); "$v: $d" }
sort {$a->[-1] <=> $b->[-1] || $a->[1] cmp $b->[1] }
map {my $x= [$_, $_->attr('var')]; push @$x, ($x->[1]=~m/^l/?0:1); $x} @o) );
return TRUE;
});
# This is so we can later determin the size of the viewport.
$this->[VP_DIM] = my $dim = [];
$vp->signal_connect( size_allocate => sub { my $r = $_[1]; $dim->[0] = $r->width; $dim->[1] = $r->height; 0; });
my $sb = $this->[STAT] = new Gtk2::Statusbar; $sb->push(1,'');
my $s_up = sub {
$sb->pop(1); return unless @_;
if( not ref $_[0] ) {
my @c = caller;
warn "caller=(@c)";
}
# @_ is just like $this->[S_ARG], but (stuff) instead of [stuff]
my $loc = shift; # so this is (x,y), not a tile object from the actual map
my $type = pop @$loc if @$loc == 3;
my $group = shift;
my $door = shift;
my $txt = '';
if( $loc ) {
$txt .= "tile: " . ($type ? "$type " : ''). sprintf('[%d,%d]', @$loc);
$txt .= ":$door->[0] (@{$door->[1]})" if $door;
MapGen/Editor.pm view on Meta::CPAN
map {
$min_x = $_->[0] if $_->[0] < $min_x;
[@$_, 'w']
}
@_
},
activate => sub { $this->closureconvert_to_wall(@{$_[1]{result}}) },
},
);
# NOTE: I'm writing these to later take arrays of closures instead of just singles...
# but for now, you can only select one closure at a time.
$this->[RCCM][1] = $this->_build_context_menu(
'convert to _wall' => {
enable => sub {
map { [ $_->[0], $_->[-1][-1] ] }
grep { $_->[1] } # this amounts to checking if there exists an {nb}{d}
map { my $t = $map->[ $_->[1] ][ $_->[0] ]; [ $t, $t->{od}{$_->[2]}, $t->{nb}{$_->[2]}, $_ ] }
grep { @$_ == 3 }
@_
},
activate => sub { $this->closureconvert_to_wall(@{$_[1]{result}}) },
},
'convert to _opening' => {
enable => sub {
map { [ $_->[0], $_->[-1][-1] ] }
grep { $_->[1] and $_->[0]{type} and $_->[1]{type} and (not($_->[2]) or ref($_->[2])) }
map { my $t = $map->[ $_->[1] ][ $_->[0] ]; [ $t, $t->{nb}{$_->[2]}, $t->{od}{$_->[2]}, $_ ] }
grep { @$_ == 3 }
@_
},
activate => sub { $this->closureconvert_to_opening(@{$_[1]{result}}) },
},
'convert to _door' => {
enable => sub {
map { [ $_->[0], $_->[-1][-1] ] }
grep { $_->[1] and $_->[0]{type} and $_->[1]{type} and (not($_->[2]) or not ref($_->[2])) }
map { my $t = $map->[ $_->[1] ][ $_->[0] ]; [ $t, $t->{nb}{$_->[2]}, $t->{od}{$_->[2]}, $_ ] }
grep { @$_ == 3 }
@_
},
activate => sub { $this->closureconvert_to_door(@{$_[1]{result}}) },
},
'door _properties' => {
enable => sub {
map { [ $_->[0], $_->[-1][-1] ] }
grep { ref $_->[1] }
map { my $t = $map->[ $_->[1] ][ $_->[0] ]; [ $t, $t->{od}{$_->[2]}, $_ ] }
grep { @$_ == 3 }
@_
},
activate => sub { $this->closure_door_properties(@{$_[1]{result}}) },
},
);
}
# }}}
# _build_context_menu {{{
sub _build_context_menu {
my $this = shift;
my $menu = new Gtk2::Menu->new;
@_ = @{$_[0]} if ref $_[0];
# TODO: this should become a module like _MForm.pm
my @a;
while( my($name, $opts) = splice @_, 0, 2 ) {
my $item = Gtk2::MenuItem->new_with_mnemonic($name);
push @a, sub { my @r = $opts->{enable}->(@_); $item->set_sensitive( $r[-1] ? 1 : 0 ); $opts->{result} = \@r; } if $opts->{enable};
push @a, sub { my @r = $opts->{disable}->(@_); $item->set_sensitive( $r[-1] ? 0 : 1 ); $opts->{result} = \@r; } if $opts->{disable};
$item->signal_connect( activate => $opts->{activate}, $opts ) if exists $opts->{activate};
$menu->append( $item );
}
$menu->{_a} = \@a;
$menu->show_all;
$menu;
}
# }}}
# right_click_map {{{
sub right_click_map {
my ($this, $event) = @_;
my @a;
if( my $s = $this->[SELECTION] ) {
my %already;
for my $r (@$s) {
for my $x ($r->[0] .. $r->[2]) {
for my $y ($r->[1] .. $r->[3]) {
next if $already{$x,$y};
$already{$x,$y} = push @a, [$x,$y];
}}
}
} else {
my @b;
if( my @o = (@{ $this->[O_LT] }) ) {
if( my $s2 = @{$this->[S_ARG]}[2] ) {
@b = (@o, $s2->[0]);
} else {
@b = @o;
}
} else {
return FALSE;
}
@a = (\@b);
}
$this->_build_rccm unless $this->[RCCM];
my @menus = @{ $this->[RCCM] };
my $menu = $menus[@{$a[0]}==3 ? 1:0];
$_->(@a) for @{$menu->{_a}};
$menu->popup(
undef, # parent menu shell
undef, # parent menu item
undef, # menu pos func
undef, # data
$event->button,
$event->time
);
}
( run in 0.469 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )