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 with 'LaTeX::TikZ::Mod';
  29
  30 has 'name' => (
  31  is       => 'ro',
  32  isa      => 'Str',
  33  required => 1,
  34 );
  35
  36 subtype 'LaTeX::TikZ::Mod::LevelList'
  37      => as 'ArrayRef[LaTeX::TikZ::Mod::Layer]';
  38
  39 coerce 'LaTeX::TikZ::Mod::LevelList'
  40     => from 'Str'
  41     => via { [ __PACKAGE__->new(name => $_) ] };
  42
  43 coerce 'LaTeX::TikZ::Mod::LevelList'
  44     => from 'ArrayRef[Str]'
  45     => via { [ map __PACKAGE__->new(name => $_), @$_ ] };
  46
  47 has '_above' => (
  48  is       => 'ro',
  49  isa      => 'LaTeX::TikZ::Mod::LevelList',
  50  init_arg => 'above',
  51  default  => sub { [ ] },
  52  coerce   => 1,
  53 );
  54
  55 sub above { @{$_[0]->_above} }
  56
  57 has '_below' => (
  58  is       => 'ro',
  59  isa      => 'LaTeX::TikZ::Mod::LevelList',
  60  init_arg => 'below',
  61  default  => sub { [ ] },
  62  coerce   => 1,
  63 );
  64
  65 sub below { @{$_[0]->_below} }
  66
  67 has '_score' => (
  68  is       => 'ro',
  69  isa      => 'Int',
  70  init_arg => undef,
  71  lazy     => 1,
  72  builder  => '_build_score',
  73 );
  74
  75 my %layers;
  76
  77 around 'new' => sub {
  78  my ($orig, $self, %args) = @_;
  79
  80  my $name = $args{name};
  81  if (defined $name) {
  82   $self->meta->find_attribute_by_name('name')
  83              ->type_constraint->assert_valid($name);
  84   my $layer = $layers{$name};
  85   if (defined $layer) {
  86    confess("Can't redefine layer '$name'") if keys(%args) > 1;
  87    return $layer;
  88   }
  89  }
  90
  91  return $self->$orig(%args);
  92 };
  93
  94 sub BUILD {
  95  my ($self) = @_;
  96
  97  my $name = $self->name;
  98  $layers{$name} = $self;
  99  Scalar::Util::weaken($layers{$name});
 100 }
 101
 102 sub DEMOLISH {
 103  my ($self) = @_;
 104
 105  delete $layers{$self->name};
 106 }
 107
 108 sub tag {
 109  my ($self) = @_;
 110
 111  ref($self) . '/' . $self->name;
 112 }
 113
 114 sub cover { $_[0]->name eq $_[1]->name }
 115
 116 {
 117  our %score;
 118
 119  sub score {
 120   my $layer = $_[0];
 121
 122   my $name = $layer->name;
 123
 124   return $score{$name} if exists $score{$name};
 125
 126   my (@lower, $min);
 127   for ($layer->above) {
 128    my $cur = $_->score;
 129    if (defined $cur) {
 130     $min = $cur if not defined $min or $min < $cur;
 131    } else {
 132     push @lower, $_;
 133    }
 134   }
 135
 136   my (@higher, $max);
 137   for ($layer->below) {
 138    my $cur = $_->score;
 139    if (defined $cur) {
 140     $max = $cur if not defined $max or $max < $cur;
 141    } else {
 142     push @higher, $_;
 143    }
 144   }
 145
 146   if (defined $min) {
 147    if (defined $max) {
 148     confess("Order mismatch for $name") unless $min < $max;
 149     $score{$name} = ($min + $max) / 2;
 150    } else {
 151     my $i = List::Util::max(values %score);
 152     $score{$_} = ++$i for $name, @higher;
 153    }
 154   } elsif (defined $max) {
 155    my $i = List::Util::min(values %score);
 156    $score{$_} = --$i for @lower, $name;
 157   } else {
 158    my $i = 0;
 159    $score{$_} = ++$i for @lower, $name, @higher;
 160   }
 161
 162   $score{$name}
 163  }
 164
 165  sub declare {
 166   shift;
 167
 168   return unless @_;
 169
 170   local %score = (main => 0);
 171
 172   $_->score for @_;
 173
 174   my @layers = sort { $score{$a} <=> $score{$b} }
 175                 map { ref() ? $_->name : $_ }
 176                  keys %score;
 177
 178   my @intro = map "\\pgfdeclarelayer{$_}",
 179                grep $_ ne 'main',
 180                 @layers;
 181
 182   return (
 183    @intro,
 184    "\\pgfsetlayers{" . join(',', @layers) . "}",
 185   );
 186  }
 187 }
 188
 189 sub apply {
 190  my ($self) = @_;
 191
 192  LaTeX::TikZ::Mod::Formatted->new(
 193   type    => 'layer',
 194   content => $self->name,
 195  )
 196 }
 197
 198 LaTeX::TikZ::Interface->register(
 199  layer => sub {
 200   shift;
 201
 202   my $name = shift;
 203   __PACKAGE__->new(name => $name, @_);
 204  },
 205 );
 206
 207 __PACKAGE__->meta->make_immutable(
 208  inline_constructor => 0,
 209 );
 210
 211 =head1 AUTHOR
 212
 213 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 214
 215 You can contact me by mail or on C<irc.perl.org> (vincent).
 216
 217 =head1 BUGS
 218
 219 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>.
 220 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 221
 222 =head1 SUPPORT
 223
 224 You can find documentation for this module with the perldoc command.
 225
 226     perldoc LaTeX::TikZ
 227
 228 =head1 COPYRIGHT & LICENSE
 229
 230 Copyright 2010 Vincent Pit, all rights reserved.
 231
 232 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 233
 234 =cut
 235
 236 1; # End of LaTeX::TikZ::Mod::Layer