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