Deliantra/Deliantra/MapWidget.pm

=head1 NAME

Crossfire::MapWidget - Gtk2 widget displaying cf maps

=head1 SYNOPSIS

  use Crossfire::MapWidget;

=head1 DESCRIPTION

=head2 METHODS

=over 4

=cut

package Crossfire::MapWidget;

use strict;

use Glib;
use Gtk2;
use Storable ();

use Crossfire;

use Glib::Object::Subclass
   'Gtk2::DrawingArea',
   signals => {
      stack_change => {
         flags       => [qw/run-last/],
         return_type => undef,
         param_types => ["Glib::Int", "Glib::Int", "Glib::Scalar"],
         class_closure => \&set,
      },
   };

use List::Util qw(min max);

#my ($TILE_MINX, $TILE_MINY, $TILE_MAXX, $TILE_MAXY);
#
#for (values %TILE) {
#   $TILE_MAXX = max $TILE_MAXX, $_->{w} - 1;
#   $TILE_MAXY = max $TILE_MAXY, $_->{h} - 1;
#}
#
#for (values %ARCH) {
#   for (; $_; $_ = $_->{more}) {
#      $TILE_MINX = min $TILE_MINX, $_->{x};
#      $TILE_MINY = min $TILE_MINY, $_->{y};
#      $TILE_MAXX = max $TILE_MAXX, $_->{x};
#      $TILE_MAXY = max $TILE_MAXY, $_->{y};
#   }
#}

sub INIT_INSTANCE {
   my ($self) = @_;

   $self->signal_connect (destroy => sub {
      my ($self) = @_;

      $self->{tip}->destroy if $self->{tip};

      %$self = ();

      0
   });
   $self->signal_connect (realize => sub {
      my ($self) = @_;

      $self->{window} = $self->window;

      1
   });

   $self->set_redraw_on_allocate (0);
   $self->double_buffered (0);

   $self->{tooltip} = -1; # need focus in first

   # reduces unnecessary redraws
   $self->signal_connect (focus_in_event  => sub { $self->enable_tooltip;  1 });
   $self->signal_connect (focus_out_event => sub { $self->disable_tooltip; 1 });

   $self->signal_connect_after (enter_notify_event => sub { $self->update_tooltip; 0 });
   $self->signal_connect_after (leave_notify_event => sub { $self->update_tooltip; 0 });

   $self->signal_connect (size_request => sub {
      $_[1]->width  (TILESIZE);
      $_[1]->height (TILESIZE);

      1
   });

   $self->signal_connect (expose_event => sub { $self->expose ($_[1]); 1 });

   $self->signal_connect_after (configure_event => sub {
      $self->set_viewport ($self->{x}, $self->{y});

      0
   });

   $self->signal_connect (button_press_event => sub {
      my ($self, $event) = @_;

      my ($x, $y) = ($event->x, $event->y);

      if ($_[1]->button == 2 && !$self->{in_drag}) {
         $self->disable_tooltip;

         $_[0]->grab_focus;
         $self->{in_drag} = [$self->{x}, $self->{y}, $x, $y];
         return 1;
      }

      0
   });

   $self->signal_connect (motion_notify_event => sub {
      my ($self) = @_;

      $self->update_tooltip;

      if (my $di = $self->{in_drag}) {
         my ($x, $y) = $self->get_pointer;

         $self->set_viewport (
            $di->[0] + $di->[2] - $x,
            $di->[1] + $di->[3] - $y,
         );

         return 1;
      }

      0
   });

   $self->signal_connect (button_release_event => sub {
      my ($self) = @_;

      $self->enable_tooltip 
         if delete $self->{in_drag};

      0
   });

   # gtk+ supports no motion compression, a major lacking feature. we have to pay for the
   # workaround with incorrect behaviour and extra server-turnarounds.
   $self->add_events ([qw(button_press_mask button_release_mask button-motion-mask
                          pointer-motion-mask pointer-motion-hint-mask
                          enter-notify-mask leave-notify-mask)]);
   $self->can_focus (1);

#   $self->signal_connect (key_press_event => sub { $self->handle_key ($_[1]->keyval, $_[1]->state) });
}

sub enable_tooltip {
   my ($self) = @_;

   $self->{tooltip}++;
   $self->update_tooltip;
}

sub disable_tooltip {
   my ($self) = @_;

   $self->{tooltip}--;
   $self->update_tooltip;
}

sub overlay {
   my ($self, $name, $x, $y, $w, $h, $cb) = @_;

   if (my $ov = delete $self->{overlay}{$name}) {
      my ($x, $y, $w, $h) = @$ov;

      $self->queue_draw_area ($x - $self->{x}, $y - $self->{y}, $w, $h);
   }

   if ($w && $h) {
      $self->{overlay}{$name} = [$x, $y, $w, $h, $cb];

      $self->queue_draw_area ($x - $self->{x}, $y - $self->{y}, $w, $h);
   }
}

sub update_tooltip {
   my ($self) = @_;

   if ($self->{tooltip} >= 0
       && $self->mapped
       && $self->get_toplevel->has_toplevel_focus) {
      my $screen = $self->{window}->get_screen;

      if ($self->{window} == ($screen->get_display->get_window_at_pointer)[0]) {
         my ($pscreen, $x, $y) = $screen->get_display->get_pointer;

         if ($pscreen == $screen) {
            if (!$self->{tip}) {
               $self->{tip} = new Gtk2::Window "popup";
               $self->{tip}->can_focus (0);
               $self->{tip}->set_name ("gtk-tooltips");
               $self->{tip}->set_decorated (0);
               $self->{tip}->set_border_width (4);
               $self->{tip}->set_has_frame (0);
               $self->{tip}->set_resizable (0);
               $self->{tip}->set_transient_for ($self->get_toplevel);
            }

            my ($mx, $my) = $self->coord ($self->get_pointer);

            if ($self->{tipinfo}[0] != $mx || $self->{tipinfo}[1] != $my) {
               $self->fill_tooltip ($mx, $my);

               $self->{tipinfo} = [$mx, $my];

               $self->overlay (_tooltip => $mx * TILESIZE, $my * TILESIZE, TILESIZE, TILESIZE, sub {
                  my ($self, $x, $y) = @_;

                  $self->{window}->draw_rectangle ($_ & 1 ? $self->style->black_gc : $self->style->white_gc, 0,
                                                   $x + $_, $y + $_,
                                                   TILESIZE - 1 - $_ * 2, TILESIZE - 1 - $_ * 2)
                     for 0..3;
               });

               my $req = $self->{tip}->size_request;
               $self->{tip}->resize ($req->width, $req->height);
            }

            $self->{tip}->move ($x + TILESIZE, $y);
            $self->{tip}->show_all;

            return;
         }
      }
   }

   $self->overlay ("_tooltip");
   delete $self->{tipinfo};
   (delete $self->{tip})->destroy if $self->{tip};
}

sub fill_tooltip {
   my ($self, $x, $y) = @_;

   $self->{tip}->remove ($self->{tip}->get_children)
      if $self->{tip}->get_children;

   $self->{tip}->add (my $frame = new Gtk2::Frame "($x|$y)");

   if ($x < 0 || $x >= $self->{map}{width}
       || $y < 0 || $y >= $self->{map}{height}) {
     $frame->add (new Gtk2::Label "<off-map>");
   } else {
      $frame->add (my $vbox = new Gtk2::VBox 1, 1);

      #TODO: fill tooltip via signal, defaulting to this:

      # fill tooltip with info about $x, $y
      my $as = $self->{map}{map}[$x][$y] || [];
      for (reverse @$as) {
         my $a = $_->{_virtual} || $_;

         $vbox->add (my $hbox = new Gtk2::HBox 0, 2);

         # this is awful, is this really the best way?
         my $pb = new Gtk2::Gdk::Pixbuf 'rgb', 1, 8, TILESIZE, TILESIZE;
         $pb->fill (0x00000000);
         
         $TILE->composite ($pb,
            0, 0,
            TILESIZE, TILESIZE,
            - ($a->{_face} % 64) * TILESIZE, - TILESIZE * int $a->{_face} / 64,
            1, 1, 'nearest', 255
         );

         $hbox->add (my $img = new_from_pixbuf Gtk2::Image $pb);
         $img->set_alignment (0, 0.5);

         $hbox->add (my $label = new Gtk2::Label $a->{_name});
         $label->set_alignment (0, 0.5);
      }
   }
}

sub set_viewport {
   my ($self, $x, $y) = @_;

   my $area = $self->allocation;

   $x = max 0, min $self->{width}  - $area->width , $x;
   $y = max 0, min $self->{height} - $area->height, $y;

   $self->window->scroll ($self->{x} - $x, $self->{y} - $y);

   ($self->{x}, $self->{y}) = ($x, $y);
}

sub set_map {
   my ($self, $map) = @_;

   $self->{map} = $map;

   $self->{width}  = $map->{width}  * TILESIZE;
   $self->{height} = $map->{height} * TILESIZE;
   
   $self->{x} =
   $self->{y} = 0;

   my $data = delete $map->{map};

   $map->{map} = [];

   for my $x (0 .. $map->{width} - 1) {
      my $col = $data->[$x];
      for my $y (0 .. $map->{height} - 1) {
         $self->set ($x, $y, delete $col->[$y]);
      }
   }

   delete $self->{tipinfo}; $self->update_tooltip;
   $self->invalidate_all;
}

sub coord {
   my ($self, $x, $y) = @_;

   (
      int +($self->{x} + $x) / TILESIZE,
      int +($self->{y} + $y) / TILESIZE,
   )
}

#sub handle_key {
#   my ($self, $key, $state) = @_;
#
#   $self->prefetch_cancel;
#
#   if ($state * "control-mask") {
#      if ($key == $Gtk2::Gdk::Keysyms{g}) {
#         my @sel = keys %{$self->{sel}};
#         $self->generate_thumbnails (@sel ? @sel : 0 .. $#{$self->{entry}});
#   }
#
#   1
#}

sub invalidate {
   my ($self, $x, $y, $w, $h) = @_;

   return unless $self->{window};

   $self->queue_draw_area (
      map $_ * TILESIZE, $x - 1 , $y - 1, $w + 2, $h + 2
   );
}

sub invalidate_all {
   my ($self) = @_;

   $self->queue_draw;
}

sub expose {
   my ($self, $event) = @_;

   no integer;

   my $ox = $self->{x}; my $ix = int $ox / TILESIZE;
   my $oy = $self->{y}; my $iy = int $oy / TILESIZE;

   # get_rectangles is buggy in older versions
   my @rectangles = $Gtk2::VERSION >= 1.104
                    ? $event->region->get_rectangles : $event->area;

   for my $area (@rectangles) {
      my ($x, $y, $w, $h) = $area->values; # x y w h

      my @x = ((int ($ox + $x) / TILESIZE) .. int +($ox + $x + $w + TILESIZE - 1) / TILESIZE);
      my @y = ((int ($oy + $y) / TILESIZE) .. int +($oy + $y + $h + TILESIZE - 1) / TILESIZE);

      my $window = $self->{window};

      my $pb = new Gtk2::Gdk::Pixbuf 'rgb', 0, 8, TILESIZE * (@x + 1), TILESIZE * (@y + 1);
      $pb->fill (0xff69b400);

      for my $x (@x) {
         my $dx = ($x - $x[0]) * TILESIZE;
         my $oss = $self->{map}{map}[$x];

         for my $y (@y) {
            my $dy = ($y - $y[0]) * TILESIZE;

            for my $a (@{$oss->[$y]}) {
               $TILE->composite ($pb,
                  $dx, $dy,
                  TILESIZE, TILESIZE,
                  $dx - ($a->{_face} % 64) * TILESIZE, $dy - TILESIZE * int $a->{_face} / 64,
                  1, 1, 'nearest', 255
               );
            }
         }
      }

      $pb->render_to_drawable ($window, $self->style->black_gc,
               0, 0,
               $x[0] * TILESIZE - $ox, $y[0] * TILESIZE - $oy,
               TILESIZE * @x, TILESIZE * @y,
               'max', 0, 0);
   }

   $_->[4]->($self, $_->[0] - $self->{x}, $_->[1] - $self->{y})
      for values %{ $self->{overlay} || {} };
}

sub get {
   my ($self, $x, $y) = @_;

   return unless $x >= 0 && $x < $self->{map}{width}
              && $y >= 0 && $y < $self->{map}{height};

   Storable::dclone $self->{map}{map}[$x][$y] || []
}

sub set {
   my ($self, $x, $y, $as) = @_;

   my $data = $self->{map}{map};

   my $prev_as = $data->[$x][$y] || [];

   my ($x1, $y1, $x2, $y2) = ($x, $y) x 2;

   # remove possible overlay tiles
   for my $a (@$prev_as) {
      next if $a->{_virtual};

      if (my $more = $a->{_more}) {
         for (@$more) {
            my ($x, $y) = @$_;

            $x1 = min $x1, $x; $y1 = min $y1, $y;
            $x2 = max $x2, $x; $y2 = max $y2, $y;
            
            $data->[$x][$y] = [ grep $_->{_virtual} != $a, @{ $data->[$x][$y] } ];
         }
      }
   }

   # preserve our overlay tiles, put them on top
   $as = [
      (grep !$_->{_virtual}, @$as),
      (grep  $_->{_virtual}, @$prev_as),
   ];

   for my $a (@$as) {
      next if $a->{_virtual};

      my $o = $ARCH{$a->{_name}} || $ARCH{empty_archetype}
         or (warn "archetype $a->{_name} is unknown at ($x|$y)\n"), next;

      my $face = $FACE{$a->{face} || $o->{face} || "blank.111"}
         or (warn "no gfx found for arch '$a->{_name}' at ($x|$y)\n"), next;

      $a->{_face} = $face->{idx};

      if ($face->{w} > 1 || $face->{h} > 1) {
         # bigfaces

         $x2 = max $x2, $x + $face->{w} - 1;
         $y2 = max $y2, $y + $face->{h} - 1;

         for my $ox (0 .. $face->{w} - 1) {
            for my $oy (0 .. $face->{h} - 1) {
               next unless $ox || $oy;

               push @{ $a->{_more} }, [$x+$ox, $y+$oy];
               push @{ $data->[$x+$ox][$y+$oy] }, {
                  _virtual   => $a,
                  _virtual_x => $x,
                  _virtual_y => $y,
                  _face      => $face->{idx} + $ox + $oy * $face->{w},
               };
            }
         }

      } elsif ($o->{more}) {
         # linked faces, slowest and most annoying

         while ($o = $o->{more}) {
            my $face = $FACE{$o->{face} || "blank.111"}
               or (warn "no gfx found for arch '$a->{_name}' at ($x*|$y*)\n"), next;

            $x1 = min $x1, $x + $o->{x}; $y1 = min $y1, $y + $o->{y};
            $x2 = max $x2, $x + $o->{x}; $y2 = max $y2, $y + $o->{y};

            push @{ $a->{_more} }, [$x + $o->{x}, $y + $o->{y}];
            push @{ $data->[$x+$o->{x}][$y+$o->{y}] }, {
               _virtual   => $a,
               _virtual_x => $x,
               _virtual_y => $y,
               _face      => $face->{idx},
            };
         }
      }
   }

   $data->[$x][$y] = $as;

   $self->queue_draw_area (
      $x1 * TILESIZE - $self->{x}, $y1 * TILESIZE - $self->{y},
      ($x2 - $x1 + 1) * TILESIZE, ($y2 - $y1 + 1) * TILESIZE,
   );

   delete $self->{tipinfo}; $self->update_tooltip;

}

sub change_begin {
   my ($self, $title) = @_;

   $self->{change} ||= {
      title => $title,
   };
   $self->{change}{nest}++;
}

sub change_stack {
   my ($self, $x, $y, $as) = @_;

   $self->{change}{map}[$x][$y] ||= [$x, $y, $self->{map}{map}[$x][$y]];

   $self->signal_emit (stack_change => $x, $y, $as);
}

sub change_end {
   my ($self) = @_;

   --$self->{change}{nest} and return;

   my $change = delete $self->{change};

   delete $change->{nest};

   $change->{set} = [
      grep $_,
         map @$_,
            grep $_,
               @{ delete $change->{map} || [] }
   ];

   @{ $change->{set} } or return;

   $change
}

sub change_swap {
   my ($self, $change) = @_;

   for (@{ $change->{set} }) {
      my $stack = $self->get ($_->[0], $_->[1]);
      $self->set ($_->[0], $_->[1], $_->[2]);
      $_->[2] = $stack;
   }

   $self->invalidate_all;
}

=back

=head1 AUTHOR

Marc Lehmann <schmorp@schmorp.de>

=cut

1

Revision:	1.31
Committed:	Mon Mar 20 01:39:00 2006 UTC (18 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.30:	+11 -2 lines
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	Crossfire::MapWidget - Gtk2 widget displaying cf maps
4
5	=head1 SYNOPSIS
6
7	use Crossfire::MapWidget;
8
9	=head1 DESCRIPTION
10
11	=head2 METHODS
12
13	=over 4
14
15	=cut
16
17	package Crossfire::MapWidget;
18
19	use strict;
20
21	use Glib;
22	use Gtk2;
23	use Storable ();
24
25	use Crossfire;
26
27	use Glib::Object::Subclass
28	'Gtk2::DrawingArea',
29	signals => {
30	stack_change => {
31	flags => [qw/run-last/],
32	return_type => undef,
33	param_types => ["Glib::Int", "Glib::Int", "Glib::Scalar"],
34	class_closure => \&set,
35	},
36	};
37
38	use List::Util qw(min max);
39
40	#my ($TILE_MINX, $TILE_MINY, $TILE_MAXX, $TILE_MAXY);
41	#
42	#for (values %TILE) {
43	# $TILE_MAXX = max $TILE_MAXX, $_->{w} - 1;
44	# $TILE_MAXY = max $TILE_MAXY, $_->{h} - 1;
45	#}
46	#
47	#for (values %ARCH) {
48	# for (; $_; $_ = $_->{more}) {
49	# $TILE_MINX = min $TILE_MINX, $_->{x};
50	# $TILE_MINY = min $TILE_MINY, $_->{y};
51	# $TILE_MAXX = max $TILE_MAXX, $_->{x};
52	# $TILE_MAXY = max $TILE_MAXY, $_->{y};
53	# }
54	#}
55
56	sub INIT_INSTANCE {
57	my ($self) = @_;
58
59	$self->signal_connect (destroy => sub {
60	my ($self) = @_;
61
62	$self->{tip}->destroy if $self->{tip};
63
64	%$self = ();
65
66	0
67	});
68	$self->signal_connect (realize => sub {
69	my ($self) = @_;
70
71	$self->{window} = $self->window;
72
73	1
74	});
75
76	$self->set_redraw_on_allocate (0);
77	$self->double_buffered (0);
78
79	$self->{tooltip} = -1; # need focus in first
80
81	# reduces unnecessary redraws
82	$self->signal_connect (focus_in_event => sub { $self->enable_tooltip; 1 });
83	$self->signal_connect (focus_out_event => sub { $self->disable_tooltip; 1 });
84
85	$self->signal_connect_after (enter_notify_event => sub { $self->update_tooltip; 0 });
86	$self->signal_connect_after (leave_notify_event => sub { $self->update_tooltip; 0 });
87
88	$self->signal_connect (size_request => sub {
89	$_[1]->width (TILESIZE);
90	$_[1]->height (TILESIZE);
91
92	1
93	});
94
95	$self->signal_connect (expose_event => sub { $self->expose ($_[1]); 1 });
96
97	$self->signal_connect_after (configure_event => sub {
98	$self->set_viewport ($self->{x}, $self->{y});
99
100	0
101	});
102
103	$self->signal_connect (button_press_event => sub {
104	my ($self, $event) = @_;
105
106	my ($x, $y) = ($event->x, $event->y);
107
108	if ($_[1]->button == 2 && !$self->{in_drag}) {
109	$self->disable_tooltip;
110
111	$_[0]->grab_focus;
112	$self->{in_drag} = [$self->{x}, $self->{y}, $x, $y];
113	return 1;
114	}
115
116	0
117	});
118
119	$self->signal_connect (motion_notify_event => sub {
120	my ($self) = @_;
121
122	$self->update_tooltip;
123
124	if (my $di = $self->{in_drag}) {
125	my ($x, $y) = $self->get_pointer;
126
127	$self->set_viewport (
128	$di->[0] + $di->[2] - $x,
129	$di->[1] + $di->[3] - $y,
130	);
131
132	return 1;
133	}
134
135	0
136	});
137
138	$self->signal_connect (button_release_event => sub {
139	my ($self) = @_;
140
141	$self->enable_tooltip
142	if delete $self->{in_drag};
143
144	0
145	});
146
147	# gtk+ supports no motion compression, a major lacking feature. we have to pay for the
148	# workaround with incorrect behaviour and extra server-turnarounds.
149	$self->add_events ([qw(button_press_mask button_release_mask button-motion-mask
150	pointer-motion-mask pointer-motion-hint-mask
151	enter-notify-mask leave-notify-mask)]);
152	$self->can_focus (1);
153
154	# $self->signal_connect (key_press_event => sub { $self->handle_key ($_[1]->keyval, $_[1]->state) });
155	}
156
157	sub enable_tooltip {
158	my ($self) = @_;
159
160	$self->{tooltip}++;
161	$self->update_tooltip;
162	}
163
164	sub disable_tooltip {
165	my ($self) = @_;
166
167	$self->{tooltip}--;
168	$self->update_tooltip;
169	}
170
171	sub overlay {
172	my ($self, $name, $x, $y, $w, $h, $cb) = @_;
173
174	if (my $ov = delete $self->{overlay}{$name}) {
175	my ($x, $y, $w, $h) = @$ov;
176
177	$self->queue_draw_area ($x - $self->{x}, $y - $self->{y}, $w, $h);
178	}
179
180	if ($w && $h) {
181	$self->{overlay}{$name} = [$x, $y, $w, $h, $cb];
182
183	$self->queue_draw_area ($x - $self->{x}, $y - $self->{y}, $w, $h);
184	}
185	}
186
187	sub update_tooltip {
188	my ($self) = @_;
189
190	if ($self->{tooltip} >= 0
191	&& $self->mapped
192	&& $self->get_toplevel->has_toplevel_focus) {
193	my $screen = $self->{window}->get_screen;
194
195	if ($self->{window} == ($screen->get_display->get_window_at_pointer)[0]) {
196	my ($pscreen, $x, $y) = $screen->get_display->get_pointer;
197
198	if ($pscreen == $screen) {
199	if (!$self->{tip}) {
200	$self->{tip} = new Gtk2::Window "popup";
201	$self->{tip}->can_focus (0);
202	$self->{tip}->set_name ("gtk-tooltips");
203	$self->{tip}->set_decorated (0);
204	$self->{tip}->set_border_width (4);
205	$self->{tip}->set_has_frame (0);
206	$self->{tip}->set_resizable (0);
207	$self->{tip}->set_transient_for ($self->get_toplevel);
208	}
209
210	my ($mx, $my) = $self->coord ($self->get_pointer);
211
212	if ($self->{tipinfo}[0] != $mx \|\| $self->{tipinfo}[1] != $my) {
213	$self->fill_tooltip ($mx, $my);
214
215	$self->{tipinfo} = [$mx, $my];
216
217	$self->overlay (_tooltip => $mx * TILESIZE, $my * TILESIZE, TILESIZE, TILESIZE, sub {
218	my ($self, $x, $y) = @_;
219
220	$self->{window}->draw_rectangle ($_ & 1 ? $self->style->black_gc : $self->style->white_gc, 0,
221	$x + $_, $y + $_,
222	TILESIZE - 1 - $_ * 2, TILESIZE - 1 - $_ * 2)
223	for 0..3;
224	});
225
226	my $req = $self->{tip}->size_request;
227	$self->{tip}->resize ($req->width, $req->height);
228	}
229
230	$self->{tip}->move ($x + TILESIZE, $y);
231	$self->{tip}->show_all;
232
233	return;
234	}
235	}
236	}
237
238	$self->overlay ("_tooltip");
239	delete $self->{tipinfo};
240	(delete $self->{tip})->destroy if $self->{tip};
241	}
242
243	sub fill_tooltip {
244	my ($self, $x, $y) = @_;
245
246	$self->{tip}->remove ($self->{tip}->get_children)
247	if $self->{tip}->get_children;
248
249	$self->{tip}->add (my $frame = new Gtk2::Frame "($x\|$y)");
250
251	if ($x < 0 \|\| $x >= $self->{map}{width}
252	\|\| $y < 0 \|\| $y >= $self->{map}{height}) {
253	$frame->add (new Gtk2::Label "<off-map>");
254	} else {
255	$frame->add (my $vbox = new Gtk2::VBox 1, 1);
256
257	#TODO: fill tooltip via signal, defaulting to this:
258
259	# fill tooltip with info about $x, $y
260	my $as = $self->{map}{map}[$x][$y] \|\| [];
261	for (reverse @$as) {
262	my $a = $_->{_virtual} \|\| $_;
263
264	$vbox->add (my $hbox = new Gtk2::HBox 0, 2);
265
266	# this is awful, is this really the best way?
267	my $pb = new Gtk2::Gdk::Pixbuf 'rgb', 1, 8, TILESIZE, TILESIZE;
268	$pb->fill (0x00000000);
269
270	$TILE->composite ($pb,
271	0, 0,
272	TILESIZE, TILESIZE,
273	- ($a->{_face} % 64) * TILESIZE, - TILESIZE * int $a->{_face} / 64,
274	1, 1, 'nearest', 255
275	);
276
277	$hbox->add (my $img = new_from_pixbuf Gtk2::Image $pb);
278	$img->set_alignment (0, 0.5);
279
280	$hbox->add (my $label = new Gtk2::Label $a->{_name});
281	$label->set_alignment (0, 0.5);
282	}
283	}
284	}
285
286	sub set_viewport {
287	my ($self, $x, $y) = @_;
288
289	my $area = $self->allocation;
290
291	$x = max 0, min $self->{width} - $area->width , $x;
292	$y = max 0, min $self->{height} - $area->height, $y;
293
294	$self->window->scroll ($self->{x} - $x, $self->{y} - $y);
295
296	($self->{x}, $self->{y}) = ($x, $y);
297	}
298
299	sub set_map {
300	my ($self, $map) = @_;
301
302	$self->{map} = $map;
303
304	$self->{width} = $map->{width} * TILESIZE;
305	$self->{height} = $map->{height} * TILESIZE;
306
307	$self->{x} =
308	$self->{y} = 0;
309
310	my $data = delete $map->{map};
311
312	$map->{map} = [];
313
314	for my $x (0 .. $map->{width} - 1) {
315	my $col = $data->[$x];
316	for my $y (0 .. $map->{height} - 1) {
317	$self->set ($x, $y, delete $col->[$y]);
318	}
319	}
320
321	delete $self->{tipinfo}; $self->update_tooltip;
322	$self->invalidate_all;
323	}
324
325	sub coord {
326	my ($self, $x, $y) = @_;
327
328	(
329	int +($self->{x} + $x) / TILESIZE,
330	int +($self->{y} + $y) / TILESIZE,
331	)
332	}
333
334	#sub handle_key {
335	# my ($self, $key, $state) = @_;
336	#
337	# $self->prefetch_cancel;
338	#
339	# if ($state * "control-mask") {
340	# if ($key == $Gtk2::Gdk::Keysyms{g}) {
341	# my @sel = keys %{$self->{sel}};
342	# $self->generate_thumbnails (@sel ? @sel : 0 .. $#{$self->{entry}});
343	# }
344	#
345	# 1
346	#}
347
348	sub invalidate {
349	my ($self, $x, $y, $w, $h) = @_;
350
351	return unless $self->{window};
352
353	$self->queue_draw_area (
354	map $_ * TILESIZE, $x - 1 , $y - 1, $w + 2, $h + 2
355	);
356	}
357
358	sub invalidate_all {
359	my ($self) = @_;
360
361	$self->queue_draw;
362	}
363
364	sub expose {
365	my ($self, $event) = @_;
366
367	no integer;
368
369	my $ox = $self->{x}; my $ix = int $ox / TILESIZE;
370	my $oy = $self->{y}; my $iy = int $oy / TILESIZE;
371
372	# get_rectangles is buggy in older versions
373	my @rectangles = $Gtk2::VERSION >= 1.104
374	? $event->region->get_rectangles : $event->area;
375
376	for my $area (@rectangles) {
377	my ($x, $y, $w, $h) = $area->values; # x y w h
378
379	my @x = ((int ($ox + $x) / TILESIZE) .. int +($ox + $x + $w + TILESIZE - 1) / TILESIZE);
380	my @y = ((int ($oy + $y) / TILESIZE) .. int +($oy + $y + $h + TILESIZE - 1) / TILESIZE);
381
382	my $window = $self->{window};
383
384	my $pb = new Gtk2::Gdk::Pixbuf 'rgb', 0, 8, TILESIZE * (@x + 1), TILESIZE * (@y + 1);
385	$pb->fill (0xff69b400);
386
387	for my $x (@x) {
388	my $dx = ($x - $x[0]) * TILESIZE;
389	my $oss = $self->{map}{map}[$x];
390
391	for my $y (@y) {
392	my $dy = ($y - $y[0]) * TILESIZE;
393
394	for my $a (@{$oss->[$y]}) {
395	$TILE->composite ($pb,
396	$dx, $dy,
397	TILESIZE, TILESIZE,
398	$dx - ($a->{_face} % 64) * TILESIZE, $dy - TILESIZE * int $a->{_face} / 64,
399	1, 1, 'nearest', 255
400	);
401	}
402	}
403	}
404
405	$pb->render_to_drawable ($window, $self->style->black_gc,
406	0, 0,
407	$x[0] * TILESIZE - $ox, $y[0] * TILESIZE - $oy,
408	TILESIZE * @x, TILESIZE * @y,
409	'max', 0, 0);
410	}
411
412	$_->[4]->($self, $_->[0] - $self->{x}, $_->[1] - $self->{y})
413	for values %{ $self->{overlay} \|\| {} };
414	}
415
416	sub get {
417	my ($self, $x, $y) = @_;
418
419	return unless $x >= 0 && $x < $self->{map}{width}
420	&& $y >= 0 && $y < $self->{map}{height};
421
422	Storable::dclone $self->{map}{map}[$x][$y] \|\| []
423	}
424
425	sub set {
426	my ($self, $x, $y, $as) = @_;
427
428	my $data = $self->{map}{map};
429
430	my $prev_as = $data->[$x][$y] \|\| [];
431
432	my ($x1, $y1, $x2, $y2) = ($x, $y) x 2;
433
434	# remove possible overlay tiles
435	for my $a (@$prev_as) {
436	next if $a->{_virtual};
437
438	if (my $more = $a->{_more}) {
439	for (@$more) {
440	my ($x, $y) = @$_;
441
442	$x1 = min $x1, $x; $y1 = min $y1, $y;
443	$x2 = max $x2, $x; $y2 = max $y2, $y;
444
445	$data->[$x][$y] = [ grep $_->{_virtual} != $a, @{ $data->[$x][$y] } ];
446	}
447	}
448	}
449
450	# preserve our overlay tiles, put them on top
451	$as = [
452	(grep !$_->{_virtual}, @$as),
453	(grep $_->{_virtual}, @$prev_as),
454	];
455
456	for my $a (@$as) {
457	next if $a->{_virtual};
458
459	my $o = $ARCH{$a->{_name}} \|\| $ARCH{empty_archetype}
460	or (warn "archetype $a->{_name} is unknown at ($x\|$y)\n"), next;
461
462	my $face = $FACE{$a->{face} \|\| $o->{face} \|\| "blank.111"}
463	or (warn "no gfx found for arch '$a->{_name}' at ($x\|$y)\n"), next;
464
465	$a->{_face} = $face->{idx};
466
467	if ($face->{w} > 1 \|\| $face->{h} > 1) {
468	# bigfaces
469
470	$x2 = max $x2, $x + $face->{w} - 1;
471	$y2 = max $y2, $y + $face->{h} - 1;
472
473	for my $ox (0 .. $face->{w} - 1) {
474	for my $oy (0 .. $face->{h} - 1) {
475	next unless $ox \|\| $oy;
476
477	push @{ $a->{_more} }, [$x+$ox, $y+$oy];
478	push @{ $data->[$x+$ox][$y+$oy] }, {
479	_virtual => $a,
480	_virtual_x => $x,
481	_virtual_y => $y,
482	_face => $face->{idx} + $ox + $oy * $face->{w},
483	};
484	}
485	}
486
487	} elsif ($o->{more}) {
488	# linked faces, slowest and most annoying
489
490	while ($o = $o->{more}) {
491	my $face = $FACE{$o->{face} \|\| "blank.111"}
492	or (warn "no gfx found for arch '$a->{_name}' at ($x\|$y)\n"), next;
493
494	$x1 = min $x1, $x + $o->{x}; $y1 = min $y1, $y + $o->{y};
495	$x2 = max $x2, $x + $o->{x}; $y2 = max $y2, $y + $o->{y};
496
497	push @{ $a->{_more} }, [$x + $o->{x}, $y + $o->{y}];
498	push @{ $data->[$x+$o->{x}][$y+$o->{y}] }, {
499	_virtual => $a,
500	_virtual_x => $x,
501	_virtual_y => $y,
502	_face => $face->{idx},
503	};
504	}
505	}
506	}
507
508	$data->[$x][$y] = $as;
509
510	$self->queue_draw_area (
511	$x1 * TILESIZE - $self->{x}, $y1 * TILESIZE - $self->{y},
512	($x2 - $x1 + 1) * TILESIZE, ($y2 - $y1 + 1) * TILESIZE,
513	);
514
515	delete $self->{tipinfo}; $self->update_tooltip;
516
517	}
518
519	sub change_begin {
520	my ($self, $title) = @_;
521
522	$self->{change} \|\|= {
523	title => $title,
524	};
525	$self->{change}{nest}++;
526	}
527
528	sub change_stack {
529	my ($self, $x, $y, $as) = @_;
530
531	$self->{change}{map}[$x][$y] \|\|= [$x, $y, $self->{map}{map}[$x][$y]];
532
533	$self->signal_emit (stack_change => $x, $y, $as);
534	}
535
536	sub change_end {
537	my ($self) = @_;
538
539	--$self->{change}{nest} and return;
540
541	my $change = delete $self->{change};
542
543	delete $change->{nest};
544
545	$change->{set} = [
546	grep $_,
547	map @$_,
548	grep $_,
549	@{ delete $change->{map} \|\| [] }
550	];
551
552	@{ $change->{set} } or return;
553
554	$change
555	}
556
557	sub change_swap {
558	my ($self, $change) = @_;
559
560	for (@{ $change->{set} }) {
561	my $stack = $self->get ($_->[0], $_->[1]);
562	$self->set ($_->[0], $_->[1], $_->[2]);
563	$_->[2] = $stack;
564	}
565
566	$self->invalidate_all;
567	}
568
569	=back
570
571	=head1 AUTHOR
572
573	Marc Lehmann <schmorp@schmorp.de>
574
575	=cut
576
577	1
578