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