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