Deliantra/Deliantra/MapWidget.pm

=head1 NAME

Deliantra::MapWidget - Gtk2 widget displaying cf maps

=head1 SYNOPSIS

  use Deliantra::MapWidget;

=head1 DESCRIPTION

=head2 METHODS

=over 4

=cut

package Deliantra::MapWidget;

use strict;

use Glib;
use Gtk2;
use Storable ();

use Deliantra;

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,
      },
      swap_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);

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

      warn "" . $_[1]->state;#d#
      if (($_[1]->button == 2 || ($_[1]->button == 1 && $_[1]->state * ["mod1-mask", "meta-mask"]))
          && !$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 0, 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) {
         $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,
            - ($_->{_face} % CACHESTRIDE) * TILESIZE, - TILESIZE * int $_->{_face} / CACHESTRIDE,
            1, 1, 'nearest', 255
         );

         my $a = $_->{_virtual} || $_;

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

         my $text = "$a->{_name}";
         if (my $o = $ARCH{$a->{_name}}) {
            $text .= "<small>";
            for my $k (grep /^[^_]/, sort keys %$a) {
               if ($a->{$k} ne $o->{$k}) {
                  if ($Glib::VERSION < 1.103) {
                     my $t = "\n$k\t$a->{$k}";
                     $t =~ s/&/&amp;/g;
                     $t =~ s/</&lt;/g;
                     $t =~ s/>/&gt;/g;
                     $text .= $t;
                  } else {
                     $text .= Glib::Markup::escape_text ("\n$k\t$a->{$k}");
                  }
               }
            }
            $text .= "</small>";
         } else {
            $text .= Glib::Markup::escape_text ("\n<unknown archetype>");
         }

         $hbox->pack_start (my $label = new Gtk2::Label, 1, 1, 0);
         $label->set_markup ($text);
         $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} % CACHESTRIDE) * TILESIZE, $dy - TILESIZE * int $a->{_face} / CACHESTRIDE,
                  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} || {} };
}

# get head from _virtual tile, returning x, y, z and @$stack
sub get_head {
   my ($self, $virtual) = @_;

   my ($x, $y) = @$virtual{qw(_virtual_x _virtual_y)}
      or return;

   my $stack = $self->{map}{map}[$x][$y]
      or return;

   my ($z) = grep $stack->[$_] == $virtual->{_virtual}, 0..$#$stack
      or return;

   ($x, $y, $z, $self->get ($x, $y))
}

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

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

   Storable::dclone [
      map +{ %$_, ((exists $_->{_virtual}) ? (_virtual => 0+$_->{_virtual}) : ()) },
          @{ $self->{map}{map}[$x][$y] || [] }
   ]
}

# the caller promises us that he won't, in no circumstances,
# change the stack he gets.
sub get_ro {
   my ($self, $x, $y) = @_;

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

   [
      map +{ %$_, ((exists $_->{_virtual}) ? (_virtual => 0+$_->{_virtual}) : ()) },
          @{ $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"};
      unless ($face) {
         $face = $FACE{"blank.x11"}
            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"};
            unless ($face) {
               $face = $FACE{"blank.x11"}
                  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]);
      $self->signal_emit (swap_stack_change => $_->[0], $_->[1], $_->[2]);
      $_->[2] = $stack;
   }

   $self->invalidate_all;
}

=back

=head1 AUTHOR

Marc Lehmann <schmorp@schmorp.de>

=cut

1

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