lib/LaTeX/TikZ/Scope.pm

   1 package LaTeX::TikZ::Scope;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Scope - An object modeling a TikZ scope or layer.
   9
  10 =head1 VERSION
  11
  12 Version 0.02
  13
  14 =cut
  15
  16 our $VERSION = '0.02';
  17
  18 use Sub::Name ();
  19
  20 use LaTeX::TikZ::Tools;
  21
  22 use Any::Moose;
  23
  24 =head1 ATTRIBUTES
  25
  26 =head2 C<mods>
  27
  28 =cut
  29
  30 has '_mods' => (
  31  is       => 'rw',
  32  isa      => 'Maybe[ArrayRef[LaTeX::TikZ::Mod::Formatted]]',
  33  init_arg => 'mods',
  34  default  => sub { [ ] },
  35 );
  36
  37 sub mods { @{$_[0]->_mods} }
  38
  39 has '_mods_cache' => (
  40  is       => 'ro',
  41  isa      => 'Maybe[HashRef[LaTeX::TikZ::Mod::Formatted]]',
  42  init_arg => undef,
  43  default  => sub { +{ } },
  44 );
  45
  46 =head2 C<body>
  47
  48 =cut
  49
  50 has 'body' => (
  51  is       => 'ro',
  52  isa      => 'LaTeX::TikZ::Scope|ArrayRef[Str]',
  53  required => 1,
  54  init_arg => 'body',
  55 );
  56
  57 my $my_tc   = LaTeX::TikZ::Tools::type_constraint(__PACKAGE__);
  58 my $ltmf_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Mod::Formatted');
  59 my $body_tc = __PACKAGE__->meta->find_attribute_by_name('body')
  60                                ->type_constraint;
  61
  62 around 'BUILDARGS' => sub {
  63  my ($orig, $class, %args) = @_;
  64
  65  my $mods = $args{mods};
  66  if (defined $mods and ref $mods eq 'ARRAY') {
  67   for my $mod (@$mods) {
  68    $mod = $ltmf_tc->coerce($mod);
  69   }
  70  }
  71
  72  $class->$orig(%args);
  73 };
  74
  75 sub BUILD {
  76  my $scope = shift;
  77
  78  my $cache = $scope->_mods_cache;
  79
  80  my @unique_mods;
  81  for my $mod ($scope->mods) {
  82   my $tag = $mod->tag;
  83   next if exists $cache->{$tag};
  84   $cache->{$tag} = $mod;
  85   push @unique_mods, $mod;
  86  }
  87  $scope->_mods(\@unique_mods);
  88 }
  89
  90 =head1 METHODS
  91
  92 =head2 C<flatten>
  93
  94 =cut
  95
  96 sub flatten {
  97  my ($scope) = @_;
  98
  99  do {
 100   my $body = $scope->body;
 101   return $scope unless $my_tc->check($body);
 102   $scope = $scope->new(
 103    mods => [ $scope->mods, $body->mods ],
 104    body => $body->body,
 105   );
 106  } while (1);
 107 }
 108
 109 my $inter = Sub::Name::subname('inter' => sub {
 110  my ($lh, $rh) = @_;
 111
 112  my (@left, @common, @right);
 113  my %where;
 114
 115  --$where{$_} for keys %$lh;
 116  ++$where{$_} for keys %$rh;
 117
 118  while (my ($key, $where) = each %where) {
 119   if ($where < 0) {
 120    push @left,   $lh->{$key};
 121   } elsif ($where > 0) {
 122    push @right,  $rh->{$key};
 123   } else {
 124    push @common, $rh->{$key};
 125   }
 126  }
 127
 128  return \@left, \@common, \@right;
 129 });
 130
 131 =head2 C<instantiate>
 132
 133 =cut
 134
 135 sub instantiate {
 136  my ($scope) = @_;
 137
 138  $scope = $scope->flatten;
 139
 140  my ($layer, @clips, @raw_mods);
 141  for ($scope->mods) {
 142   my $type = $_->type;
 143   if ($type eq 'clip') {
 144    unshift @clips, $_->content;
 145   } elsif ($type eq 'layer') {
 146    confess("Can't apply two layers in a row") if defined $layer;
 147    $layer = $_->content;
 148   } else { # raw
 149    push @raw_mods, $_->content;
 150   }
 151  }
 152
 153  my @body = @{$scope->body};
 154
 155  my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
 156
 157  if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
 158   $body[0]     = "\\draw$mods_string $1"; # Has trailing semicolon
 159   $mods_string = undef;                   # Done with mods
 160  }
 161
 162  for (0 .. $#clips) {
 163   my $clip        = $clips[$_];
 164   my $clip_string = "\\clip $clip ;";
 165   my $mods_string = ($_ == $#clips and defined $mods_string)
 166                      ? $mods_string : '';
 167   unshift @body, "\\begin{scope}$mods_string",
 168                  $clip_string;
 169   push    @body, "\\end{scope}",
 170  }
 171
 172  if (not @clips and defined $mods_string) {
 173   unshift @body, "\\begin{scope}$mods_string";
 174   push    @body, "\\end{scope}";
 175  }
 176
 177  if (defined $layer) {
 178   unshift @body, "\\begin{pgfonlayer}{$layer}";
 179   push    @body, "\\end{pgfonlayer}";
 180  }
 181
 182  return @body;
 183 }
 184
 185 =head2 C<fold>
 186
 187 =cut
 188
 189 sub fold {
 190  my ($left, $right, $rev) = @_;
 191
 192  my (@left, @right);
 193
 194  if ($my_tc->check($left)) {
 195   $left = $left->flatten;
 196
 197   if ($my_tc->check($right)) {
 198    $right = $right->flatten;
 199
 200    my ($only_left, $common, $only_right) = $inter->(
 201     $left->_mods_cache,
 202     $right->_mods_cache,
 203    );
 204
 205    my $has_different_layers;
 206    for (@$only_left, @$only_right) {
 207     if ($_->type eq 'layer') {
 208      $has_different_layers = 1;
 209      last;
 210     }
 211    }
 212
 213    if (!$has_different_layers and @$common) {
 214     my $x = $left->new(
 215      mods => $only_left,
 216      body => $left->body,
 217     );
 218     my $y = $left->new(
 219      mods => $only_right,
 220      body => $right->body,
 221     );
 222     return $left->new(
 223      mods => $common,
 224      body => fold($x, $y, $rev),
 225     );
 226    } else {
 227     @right = $right->instantiate;
 228    }
 229   } else {
 230    $body_tc->assert_valid($right);
 231    @right = @$right;
 232   }
 233
 234   @left = $left->instantiate;
 235  } else {
 236   if ($my_tc->check($right)) {
 237    return fold($right, $left, 1);
 238   } else {
 239    $body_tc->assert_valid($_) for $left, $right;
 240    @left  = @$left;
 241    @right = @$right;
 242   }
 243  }
 244
 245  $rev ? [ @right, @left ] : [ @left, @right ];
 246 }
 247
 248 use overload (
 249  '@{}' => sub { [ $_[0]->instantiate ] },
 250 );
 251
 252 __PACKAGE__->meta->make_immutable;
 253
 254 =head1 SEE ALSO
 255
 256 L<LaTeX::TikZ>.
 257
 258 =head1 AUTHOR
 259
 260 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 261
 262 You can contact me by mail or on C<irc.perl.org> (vincent).
 263
 264 =head1 BUGS
 265
 266 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>.
 267 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 268
 269 =head1 SUPPORT
 270
 271 You can find documentation for this module with the perldoc command.
 272
 273     perldoc LaTeX::TikZ
 274
 275 =head1 COPYRIGHT & LICENSE
 276
 277 Copyright 2010 Vincent Pit, all rights reserved.
 278
 279 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 280
 281 =cut
 282
 283 1; # End of LaTeX::TikZ::Scope