lib/LaTeX/TikZ/Set/Chain.pm

   1 package LaTeX::TikZ::Set::Chain;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 LaTeX::TikZ::Set::Chain - A set object representing a connected path between several objects.
   9
  10 =head1 VERSION
  11
  12 Version 0.02
  13
  14 =cut
  15
  16 our $VERSION = '0.02';
  17
  18 use LaTeX::TikZ::Set::Point;
  19
  20 use LaTeX::TikZ::Interface;
  21 use LaTeX::TikZ::Functor;
  22
  23 use LaTeX::TikZ::Tools;
  24
  25 use Any::Moose;
  26 use Any::Moose 'Util::TypeConstraints' => [ qw<subtype as coerce from via> ];
  27
  28 =head1 RELATIONSHIPS
  29
  30 This class consumes the L<LaTeX::TikZ::Set::Path> and L<LaTeX::TikZ::Set::Container> roles, and as such implements the L</path>, L</kids> and L</add> methods.
  31
  32 =cut
  33
  34 with qw<
  35  LaTeX::TikZ::Set::Path
  36  LaTeX::TikZ::Set::Container
  37 >;
  38
  39 =head1 ATTRIBUTES
  40
  41 =head2 C<kids>
  42
  43 The L<LaTeX::TikZ::Set::Path> objects that form the chain.
  44
  45 =cut
  46
  47 subtype 'LaTeX::TikZ::Set::Chain::Elements'
  48      => as 'ArrayRef[LaTeX::TikZ::Set::Path]';
  49
  50 coerce 'LaTeX::TikZ::Set::Chain::Elements'
  51     => from 'ArrayRef[Any]'
  52     => via { [ map {
  53         blessed($_) && $_->does('LaTeX::TikZ::Set')
  54           ? $_
  55           : LaTeX::TikZ::Set::Point->new(point => $_)
  56        } @$_ ] };
  57
  58 has '_kids' => (
  59  is       => 'ro',
  60  isa      => 'LaTeX::TikZ::Set::Chain::Elements',
  61  init_arg => 'kids',
  62  default  => sub { [ ] },
  63  coerce   => 1,
  64 );
  65
  66 sub kids { @{$_[0]->_kids} }
  67
  68 =head2 C<connector>
  69
  70 A code reference that describes how two successive elements of the chain are linked.
  71 It is called repeatedly with these arguments :
  72
  73 =over 4
  74
  75 =item *
  76
  77 The current L<LaTeX::TikZ::Set::Chain> object.
  78
  79 =item *
  80
  81 The index C<$i> of the current position in the chain, starting at C<0> for the link between the two first elements.
  82
  83 =item *
  84
  85 The C<$i>-th L<LaTeX::TikZ::Set> object in the chain.
  86
  87 =item *
  88
  89 The C<$i+1>-th L<LaTeX::TikZ::Set> object in the chain.
  90
  91 =back
  92
  93 You can also pass a string, which will be upgraded to a code reference constantly returning that string ; or an array reference, which will be turned into a code reference returning the C<$i>-th element of the array when asked for the C<$i>-th link.
  94
  95 =cut
  96
  97 subtype 'LaTeX::TikZ::Set::Chain::Connector'
  98      => as 'CodeRef';
  99
 100 coerce 'LaTeX::TikZ::Set::Chain::Connector'
 101     => from 'Str'
 102     => via { my $conn = $_; sub { $conn } };
 103
 104 coerce 'LaTeX::TikZ::Set::Chain::Connector'
 105     => from 'ArrayRef[Str]'
 106     => via { my $conns = $_; sub { $conns->[$_[1]] } };
 107
 108 has 'connector' => (
 109  is       => 'ro',
 110  isa      => 'LaTeX::TikZ::Set::Chain::Connector',
 111  required => 1,
 112  coerce   => 1,
 113 );
 114
 115 has '_links' => (
 116  is       => 'ro',
 117  isa      => 'ArrayRef[Str]',
 118  init_arg => undef,
 119  default  => sub { [ ] },
 120 );
 121
 122 =head1 METHODS
 123
 124 =head2 C<add>
 125
 126 =cut
 127
 128 my $ltsp_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set::Path');
 129
 130 sub add {
 131  my $set = shift;
 132
 133  $ltsp_tc->assert_valid($_) for @_;
 134  return $set unless @_;
 135
 136  my $kids  = $set->_kids;
 137  my $links = $set->_links;
 138  my $conn  = $set->connector;
 139
 140  push @$kids, shift @_ unless @$kids;
 141  return $set unless @_;
 142
 143  my $prev  = $kids->[-1];
 144  for my $i (0 .. $#_) {
 145   my $next = $_[$i];
 146   my $link = $set->$conn($#$kids, $prev, $next);
 147   confess('Invalid connector') unless defined $link and not blessed $link;
 148   push @$links, $link;
 149   push @$kids,  $next;
 150   $prev = $next;
 151  }
 152
 153  $set;
 154 }
 155
 156 sub BUILD {
 157  my ($set) = @_;
 158
 159  my @kids  = $set->kids;
 160  return unless @kids >= 2;
 161
 162  my $links = $set->_links;
 163  my $conn  = $set->connector;
 164
 165  my $prev  = $kids[0];
 166  for my $i (1 .. $#kids) {
 167   my $next = $_[$i];
 168   my $link = $set->$conn($i - 1, $prev, $next);
 169   confess('Invalid connector') unless defined $link and not blessed $link;
 170   push @$links, $link;
 171   $prev = $next;
 172  }
 173 }
 174
 175 =head2 C<path>
 176
 177 =cut
 178
 179 sub path {
 180  my $set = shift;
 181
 182  my @kids  = $set->kids;
 183  return '' unless @kids;
 184
 185  my $links = $set->_links;
 186  my $conn  = $set->connector;
 187
 188  my $path = $kids[0]->path(@_);
 189  for my $i (1 .. $#kids) {
 190   my $link = ' ' . $links->[$i - 1] . ' ';
 191   $link    =~ s/\s+/ /g;
 192   $path   .= $link . $kids[$i]->path(@_);
 193  }
 194
 195  return $path;
 196 }
 197
 198 =head2 C<begin>
 199
 200 =cut
 201
 202 sub begin {
 203  my $set = shift;
 204
 205  my @kids = $set->kids;
 206  return undef unless @kids;
 207
 208  $kids[0]->begin;
 209 }
 210
 211 =head2 C<end>
 212
 213 =cut
 214
 215 sub end {
 216  my $set = shift;
 217
 218  my @kids = $set->kids;
 219  return undef unless @kids;
 220
 221  $kids[-1]->end;
 222 }
 223
 224 LaTeX::TikZ::Interface->register(
 225  join => sub {
 226   shift;
 227   my $conn = shift;
 228
 229   __PACKAGE__->new(
 230    kids      => \@_,
 231    connector => $conn,
 232   );
 233  },
 234  chain => sub {
 235   shift;
 236   confess("The 'chain' command expects an odd number of arguments")
 237                                                                   unless @_ % 2;
 238
 239   my @kids = shift;
 240   my @links;
 241   for (my $i = 0; $i < @_; $i += 2) {
 242    push @links, $_[$i];
 243    push @kids,  $_[$i + 1];
 244   }
 245
 246   __PACKAGE__->new(
 247    kids      => \@kids,
 248    connector => \@links,
 249   );
 250  }
 251 );
 252
 253 LaTeX::TikZ::Functor->default_rule(
 254  (__PACKAGE__) => sub {
 255   my ($functor, $set, @args) = @_;
 256   $set->new(
 257    kids      => [ map $_->$functor(@args), $set->kids ],
 258    connector => $set->connector,
 259   );
 260  }
 261 );
 262
 263 __PACKAGE__->meta->make_immutable;
 264
 265 =head1 SEE ALSO
 266
 267 L<LaTeX::TikZ>, L<LaTeX::TikZ::Set::Path>.
 268
 269 =head1 AUTHOR
 270
 271 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 272
 273 You can contact me by mail or on C<irc.perl.org> (vincent).
 274
 275 =head1 BUGS
 276
 277 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>.
 278 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 279
 280 =head1 SUPPORT
 281
 282 You can find documentation for this module with the perldoc command.
 283
 284     perldoc LaTeX::TikZ
 285
 286 =head1 COPYRIGHT & LICENSE
 287
 288 Copyright 2011 Vincent Pit, all rights reserved.
 289
 290 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 291
 292 =cut
 293
 294 1; # End of LaTeX::TikZ::Set::Chain