]> git.vpit.fr Git - perl/modules/LaTeX-TikZ.git/blob - lib/LaTeX/TikZ/Mod/Layer.pm
271e0ee37454736f2d8f2951242f6ac5a5649b9f
[perl/modules/LaTeX-TikZ.git] / lib / LaTeX / TikZ / Mod / Layer.pm
1 package LaTeX::TikZ::Mod::Layer;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 LaTeX::TikZ::Mod::Layer - A modifier that specifies a drawing layer.
9
10 =head1 VERSION
11
12 Version 0.01
13
14 =cut
15
16 our $VERSION = '0.01';
17
18 use Scalar::Util ();
19 use List::Util   ();
20
21 use LaTeX::TikZ::Mod::Formatted;
22
23 use LaTeX::TikZ::Interface;
24
25 use Any::Moose;
26 use Any::Moose 'Util::TypeConstraints';
27
28 =head1 RELATIONSHIPS
29
30 This class consumes the L<LaTeX::TikZ::Mod> role, and as such implements the L</tag>, L</covers>, L</declare> and L</apply> methods.
31
32 =cut
33
34 with 'LaTeX::TikZ::Mod';
35
36 =head1 ATTRIBUTES
37
38 =head2 C<name>
39
40 =cut
41
42 has 'name' => (
43  is       => 'ro',
44  isa      => 'Str',
45  required => 1,
46 );
47
48 =head2 C<above>
49
50 =cut
51
52 subtype 'LaTeX::TikZ::Mod::LevelList'
53      => as 'ArrayRef[LaTeX::TikZ::Mod::Layer]';
54
55 coerce 'LaTeX::TikZ::Mod::LevelList'
56     => from 'Str'
57     => via { [ __PACKAGE__->new(name => $_) ] };
58
59 coerce 'LaTeX::TikZ::Mod::LevelList'
60     => from 'ArrayRef[Str]'
61     => via { [ map __PACKAGE__->new(name => $_), @$_ ] };
62
63 has '_above' => (
64  is       => 'ro',
65  isa      => 'LaTeX::TikZ::Mod::LevelList',
66  init_arg => 'above',
67  default  => sub { [ ] },
68  coerce   => 1,
69 );
70
71 sub above { @{$_[0]->_above} }
72
73 =head2 C<below>
74
75 =cut
76
77 has '_below' => (
78  is       => 'ro',
79  isa      => 'LaTeX::TikZ::Mod::LevelList',
80  init_arg => 'below',
81  default  => sub { [ ] },
82  coerce   => 1,
83 );
84
85 sub below { @{$_[0]->_below} }
86
87 has '_score' => (
88  is       => 'ro',
89  isa      => 'Int',
90  init_arg => undef,
91  lazy     => 1,
92  builder  => '_build_score',
93 );
94
95 =head1 METHODS
96
97 =cut
98
99 my %layers;
100
101 around 'new' => sub {
102  my ($orig, $self, %args) = @_;
103
104  my $name = $args{name};
105  if (defined $name) {
106   $self->meta->find_attribute_by_name('name')
107              ->type_constraint->assert_valid($name);
108   my $layer = $layers{$name};
109   if (defined $layer) {
110    confess("Can't redefine layer '$name'") if keys(%args) > 1;
111    return $layer;
112   }
113  }
114
115  return $self->$orig(%args);
116 };
117
118 sub BUILD {
119  my ($self) = @_;
120
121  my $name = $self->name;
122  $layers{$name} = $self;
123  Scalar::Util::weaken($layers{$name});
124 }
125
126 sub DEMOLISH {
127  my ($self) = @_;
128
129  delete $layers{$self->name};
130 }
131
132 =head2 C<tag>
133
134 =cut
135
136 sub tag {
137  my ($self) = @_;
138
139  ref($self) . '/' . $self->name;
140 }
141
142 =head2 C<covers>
143
144 =cut
145
146 sub covers { $_[0]->name eq $_[1]->name }
147
148 =head2 C<score>
149
150 =cut
151
152 {
153  our %score;
154
155  sub score {
156   my $layer = $_[0];
157
158   my $name = $layer->name;
159
160   return $score{$name} if exists $score{$name};
161
162   my (@lower, $min);
163   for ($layer->above) {
164    my $cur = $_->score;
165    if (defined $cur) {
166     $min = $cur if not defined $min or $min < $cur;
167    } else {
168     push @lower, $_;
169    }
170   }
171
172   my (@higher, $max);
173   for ($layer->below) {
174    my $cur = $_->score;
175    if (defined $cur) {
176     $max = $cur if not defined $max or $max < $cur;
177    } else {
178     push @higher, $_;
179    }
180   }
181
182   if (defined $min) {
183    if (defined $max) {
184     confess("Order mismatch for $name") unless $min < $max;
185     $score{$name} = ($min + $max) / 2;
186    } else {
187     my $i = List::Util::max(values %score);
188     $score{$_} = ++$i for $name, @higher;
189    }
190   } elsif (defined $max) {
191    my $i = List::Util::min(values %score);
192    $score{$_} = --$i for @lower, $name;
193   } else {
194    my $i = 0;
195    $score{$_} = ++$i for @lower, $name, @higher;
196   }
197
198   $score{$name}
199  }
200
201 =head2 C<declare>
202
203 =cut
204
205  sub declare {
206   shift;
207
208   return unless @_;
209
210   local %score = (main => 0);
211
212   $_->score for @_;
213
214   my @layers = sort { $score{$a} <=> $score{$b} }
215                 map { ref() ? $_->name : $_ }
216                  keys %score;
217
218   my @intro = map "\\pgfdeclarelayer{$_}",
219                grep $_ ne 'main',
220                 @layers;
221
222   return (
223    @intro,
224    "\\pgfsetlayers{" . join(',', @layers) . "}",
225   );
226  }
227 }
228
229 =head2 C<apply>
230
231 =cut
232
233 sub apply {
234  my ($self) = @_;
235
236  LaTeX::TikZ::Mod::Formatted->new(
237   type    => 'layer',
238   content => $self->name,
239  )
240 }
241
242 LaTeX::TikZ::Interface->register(
243  layer => sub {
244   shift;
245
246   my $name = shift;
247   __PACKAGE__->new(name => $name, @_);
248  },
249 );
250
251 __PACKAGE__->meta->make_immutable(
252  inline_constructor => 0,
253 );
254
255 =head1 SEE ALSO
256
257 L<LaTeX::TikZ>, L<LaTeX::TikZ::Mod>.
258
259 =head1 AUTHOR
260
261 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
262
263 You can contact me by mail or on C<irc.perl.org> (vincent).
264
265 =head1 BUGS
266
267 Please report any bugs or feature requests to C<bug-latex-tikz at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=LaTeX-TikZ>.
268 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
269
270 =head1 SUPPORT
271
272 You can find documentation for this module with the perldoc command.
273
274     perldoc LaTeX::TikZ
275
276 =head1 COPYRIGHT & LICENSE
277
278 Copyright 2010 Vincent Pit, all rights reserved.
279
280 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
281
282 =cut
283
284 1; # End of LaTeX::TikZ::Mod::Layer