lib/LaTeX/TikZ/Set/Mod.pm

   1 package LaTeX::TikZ::Set::Mod;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Set::Mod - A set object that stores modifiers to be applied underneath.
   9
  10 =head1 VERSION
  11
  12 Version 0.01
  13
  14 =cut
  15
  16 our $VERSION = '0.01';
  17
  18 use Scope::Guard ();
  19
  20 use LaTeX::TikZ::Tools;
  21
  22 use LaTeX::TikZ::Scope;
  23
  24 use Any::Moose;
  25
  26 with qw(
  27  LaTeX::TikZ::Set
  28  LaTeX::TikZ::Set::Mutable
  29 );
  30
  31 has '_set' => (
  32  is       => 'rw',
  33  does     => 'LaTeX::TikZ::Set',
  34  init_arg => 'set',
  35  required => 1,
  36 );
  37
  38 sub set { $_[0]->_set }
  39
  40
  41 has '_mods' => (
  42  is       => 'ro',
  43  isa      => 'Maybe[ArrayRef[LaTeX::TikZ::Mod]]',
  44  init_arg => 'mods',
  45  default  => sub { [ ] },
  46 );
  47
  48 sub mods { @{$_[0]->_mods} }
  49
  50 my $ltm_tc  = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod');
  51 my $ltml_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Layer');
  52
  53 sub mod {
  54  my $set = shift;
  55
  56  push @{$set->_mods},
  57   map { $ltm_tc->check($_) ? $_ : $ltm_tc->coerce($_) }
  58    @_;
  59
  60  $set;
  61 }
  62
  63 sub add {
  64  my $set = shift;
  65
  66  my $kid = $set->_set;
  67  if ($kid->does('LaTeX::TikZ::Set::Mutable')) {
  68   $kid->add(@_);
  69  } else {
  70   require LaTeX::TikZ::Set::Sequence;
  71   $set->_set(LaTeX::TikZ::Set::Sequence->new(
  72    kids => [ $kid, @_ ],
  73   ));
  74  }
  75
  76  $set;
  77 }
  78
  79 {
  80  our %mods;
  81  our $last_mod = 0;
  82
  83  sub mods_unique {
  84   my ($set) = @_;
  85
  86   my (@mods, $has_layer);
  87 MOD:
  88   for my $mod ($set->mods) {
  89    $has_layer = 1 if $ltml_tc->check($mod);
  90    my $tag = $mod->tag;
  91    my $old = $mods{$tag} || [];
  92    for (@$old) {
  93     next MOD if $_->[0]->cover($mod);
  94    }
  95    push @{$mods{$tag}}, [ $mod, $last_mod++ ];
  96    push @mods,          $mod;
  97   }
  98
  99   if ($has_layer) {
 100    # Clips and mods don't propagate through layers. Hence if a layer is set,
 101    # force their reuse.
 102    @mods = map $_->[0], sort { $a->[1] <=> $b->[1] } map @$_, values %mods;
 103   }
 104
 105   return @mods;
 106  }
 107
 108  sub draw {
 109   my ($set, $tikz) = @_;
 110
 111   local $last_mod = $last_mod;
 112
 113   # Save a deep copy
 114   my %saved_idx = map { $_ => $#{$mods{$_}} } keys %mods;
 115   my $guard     = Scope::Guard->new(sub {
 116    for (keys %mods) {
 117     if (exists $saved_idx{$_}) {
 118      $#{$mods{$_}} = $saved_idx{$_};
 119     } else {
 120      delete $mods{$_};
 121     }
 122    }
 123   });
 124
 125   my @mods = $set->mods_unique;
 126
 127   my $body = $set->_set->draw($tikz);
 128
 129   if (@mods) {
 130    $body = LaTeX::TikZ::Scope->new
 131                              ->mod(map $_->apply($tikz), @mods)
 132                              ->body($body);
 133   }
 134
 135   $body;
 136  }
 137 }
 138
 139 __PACKAGE__->meta->make_immutable;
 140
 141 =head1 AUTHOR
 142
 143 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 144
 145 You can contact me by mail or on C<irc.perl.org> (vincent).
 146
 147 =head1 BUGS
 148
 149 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>.
 150 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 151
 152 =head1 SUPPORT
 153
 154 You can find documentation for this module with the perldoc command.
 155
 156     perldoc LaTeX::TikZ
 157
 158 =head1 COPYRIGHT & LICENSE
 159
 160 Copyright 2010 Vincent Pit, all rights reserved.
 161
 162 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 163
 164 =cut
 165
 166 1; # End of LaTeX::TikZ::Set::Mod