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