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      => '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  my $body = $args{body};
  73  if ($my_tc->check($body)) {
  74   push @$mods, $body->mods;
  75   $args{body} = $body->body;
  76  }
  77
  78  $args{mods} = $mods;
  79
  80  $class->$orig(%args);
  81 };
  82
  83 sub BUILD {
  84  my $scope = shift;
  85
  86  my $cache = $scope->_mods_cache;
  87
  88  my @unique_mods;
  89  for my $mod ($scope->mods) {
  90   my $tag = $mod->tag;
  91   next if exists $cache->{$tag};
  92   $cache->{$tag} = $mod;
  93   push @unique_mods, $mod;
  94  }
  95  $scope->_mods(\@unique_mods);
  96 }
  97
  98 =head1 METHODS
  99
 100 =cut
 101
 102 my $inter = Sub::Name::subname('inter' => sub {
 103  my ($lh, $rh) = @_;
 104
 105  my (@left, @common, @right);
 106  my %where;
 107
 108  --$where{$_} for keys %$lh;
 109  ++$where{$_} for keys %$rh;
 110
 111  while (my ($key, $where) = each %where) {
 112   if ($where < 0) {
 113    push @left,   $lh->{$key};
 114   } elsif ($where > 0) {
 115    push @right,  $rh->{$key};
 116   } else {
 117    push @common, $rh->{$key};
 118   }
 119  }
 120
 121  return \@left, \@common, \@right;
 122 });
 123
 124 =head2 C<instantiate>
 125
 126 =cut
 127
 128 sub instantiate {
 129  my ($scope) = @_;
 130
 131  my ($layer, @clips, @raw_mods);
 132  for ($scope->mods) {
 133   my $type = $_->type;
 134   if ($type eq 'clip') {
 135    unshift @clips, $_->content;
 136   } elsif ($type eq 'layer') {
 137    confess("Can't apply two layers in a row") if defined $layer;
 138    $layer = $_->content;
 139   } else { # raw
 140    push @raw_mods, $_->content;
 141   }
 142  }
 143
 144  my @body = @{$scope->body};
 145
 146  my $mods_string = @raw_mods ? ' [' . join(',', @raw_mods) . ']' : undef;
 147
 148  if (@raw_mods and @body == 1 and $body[0] =~ /^\s*\\draw\b\s*([^\[].*)\s*$/) {
 149   $body[0]     = "\\draw$mods_string $1"; # Has trailing semicolon
 150   $mods_string = undef;                   # Done with mods
 151  }
 152
 153  for (0 .. $#clips) {
 154   my $clip        = $clips[$_];
 155   my $clip_string = "\\clip $clip ;";
 156   my $mods_string = ($_ == $#clips and defined $mods_string)
 157                      ? $mods_string : '';
 158   unshift @body, "\\begin{scope}$mods_string",
 159                  $clip_string;
 160   push    @body, "\\end{scope}",
 161  }
 162
 163  if (not @clips and defined $mods_string) {
 164   unshift @body, "\\begin{scope}$mods_string";
 165   push    @body, "\\end{scope}";
 166  }
 167
 168  if (defined $layer) {
 169   unshift @body, "\\begin{pgfonlayer}{$layer}";
 170   push    @body, "\\end{pgfonlayer}";
 171  }
 172
 173  return @body;
 174 }
 175
 176 =head2 C<fold>
 177
 178 =cut
 179
 180 sub fold {
 181  my ($left, $right, $rev) = @_;
 182
 183  my (@left, @right);
 184
 185  if ($my_tc->check($left)) {
 186
 187   if ($my_tc->check($right)) {
 188
 189    my ($only_left, $common, $only_right) = $inter->(
 190     $left->_mods_cache,
 191     $right->_mods_cache,
 192    );
 193
 194    my $has_different_layers;
 195    for (@$only_left, @$only_right) {
 196     if ($_->type eq 'layer') {
 197      $has_different_layers = 1;
 198      last;
 199     }
 200    }
 201
 202    if (!$has_different_layers and @$common) {
 203     my $x = $left->new(
 204      mods => $only_left,
 205      body => $left->body,
 206     );
 207     my $y = $left->new(
 208      mods => $only_right,
 209      body => $right->body,
 210     );
 211     return $left->new(
 212      mods => $common,
 213      body => fold($x, $y, $rev),
 214     );
 215    } else {
 216     @right = $right->instantiate;
 217    }
 218   } else {
 219    $body_tc->assert_valid($right);
 220    @right = @$right;
 221   }
 222
 223   @left = $left->instantiate;
 224  } else {
 225   if ($my_tc->check($right)) {
 226    return fold($right, $left, 1);
 227   } else {
 228    $body_tc->assert_valid($_) for $left, $right;
 229    @left  = @$left;
 230    @right = @$right;
 231   }
 232  }
 233
 234  $rev ? [ @right, @left ] : [ @left, @right ];
 235 }
 236
 237 use overload (
 238  '@{}' => sub { [ $_[0]->instantiate ] },
 239 );
 240
 241 __PACKAGE__->meta->make_immutable;
 242
 243 =head1 SEE ALSO
 244
 245 L<LaTeX::TikZ>.
 246
 247 =head1 AUTHOR
 248
 249 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 250
 251 You can contact me by mail or on C<irc.perl.org> (vincent).
 252
 253 =head1 BUGS
 254
 255 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>.
 256 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 257
 258 =head1 SUPPORT
 259
 260 You can find documentation for this module with the perldoc command.
 261
 262     perldoc LaTeX::TikZ
 263
 264 =head1 COPYRIGHT & LICENSE
 265
 266 Copyright 2010 Vincent Pit, all rights reserved.
 267
 268 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 269
 270 =cut
 271
 272 1; # End of LaTeX::TikZ::Scope