From: Vincent Pit <vince@profvince.com>
Date: Mon, 31 Jan 2011 12:50:26 +0000 (+0100)
Subject: Introduce LaTeX::TikZ::Set::Chain
X-Git-Tag: rt87282~17
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=95aada0ec5b3c5a0d78ed0ad53436b0e70860bc7;p=perl%2Fmodules%2FLaTeX-TikZ.git

Introduce LaTeX::TikZ::Set::Chain
---

diff --git a/MANIFEST b/MANIFEST
index a4f505f..d8f33ed 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -26,6 +26,7 @@ lib/LaTeX/TikZ/Scope.pm
 lib/LaTeX/TikZ/Set.pm
 lib/LaTeX/TikZ/Set/Arc.pm
 lib/LaTeX/TikZ/Set/Arrow.pm
+lib/LaTeX/TikZ/Set/Chain.pm
 lib/LaTeX/TikZ/Set/Circle.pm
 lib/LaTeX/TikZ/Set/Container.pm
 lib/LaTeX/TikZ/Set/Line.pm
diff --git a/lib/LaTeX/TikZ.pm b/lib/LaTeX/TikZ.pm
index 362d136..1d2306c 100644
--- a/lib/LaTeX/TikZ.pm
+++ b/lib/LaTeX/TikZ.pm
@@ -88,7 +88,7 @@ The two TikZ concepts of I<clips> and I<layers> have been unified with the modif
 Creates a L<LaTeX::TikZ::Set::Union> object out of the paths C<@kids>.
 
     # A path made of two circles
-    Tikz->path(
+    Tikz->union(
            Tikz->circle(0, 1),
            Tikz->circle(1, 1),
           )
@@ -97,6 +97,23 @@ Creates a L<LaTeX::TikZ::Set::Union> object out of the paths C<@kids>.
            'even odd rule',
           );
 
+=head3 C<< Tikz->join($connector, @kids) >>
+
+Creates a L<LaTeX::TikZ::Set::Chain> object that joins the paths C<@kinds> with the given C<$connector> which can be, according to L<LaTeX::TikZ::Set::Chain/connector>, a string, an array reference or a code reference.
+
+    # A stair
+    Tikz->join('-|', map [ $_, $_ ], 0 .. 5);
+
+=head3 C<< Tikz->chain($kid0, $link0, $kid1, $link1, ... $kidn) >>
+
+Creates a L<LaTeX::TikZ::Set::Chain> object that chains C<$kid0> to C<$kid1> with the string C<$link0>, C<$kid1> to C<$kid2> with C<$link1>, and so on.
+
+    # An heart-like shape
+    Tikz->chain([ 0, 1 ]
+     => '.. controls (-1, 1.5)    and (-0.75, 0.25) ..' => [ 0, 0 ]
+     => '.. controls (0.75, 0.25) and (1, 1.5)      ..' => [ 0, 1 ]
+    );
+
 =head3 C<< Tikz->seq(@kids) >>
 
 Creates a L<LaTeX::TikZ::Set::Sequence> object out of the sequences or paths C<@kids>.
diff --git a/lib/LaTeX/TikZ/Interface.pm b/lib/LaTeX/TikZ/Interface.pm
index 356a42e..b735828 100644
--- a/lib/LaTeX/TikZ/Interface.pm
+++ b/lib/LaTeX/TikZ/Interface.pm
@@ -71,6 +71,7 @@ sub load {
 
  require LaTeX::TikZ::Set::Union;     # union
  require LaTeX::TikZ::Set::Sequence;  # seq
+ require LaTeX::TikZ::Set::Chain;     # chain, join
 
  require LaTeX::TikZ::Set::Point;     # point
  require LaTeX::TikZ::Set::Line;      # line
diff --git a/lib/LaTeX/TikZ/Set/Chain.pm b/lib/LaTeX/TikZ/Set/Chain.pm
new file mode 100644
index 0000000..8795de1
--- /dev/null
+++ b/lib/LaTeX/TikZ/Set/Chain.pm
@@ -0,0 +1,268 @@
+package LaTeX::TikZ::Set::Chain;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+LaTeX::TikZ::Set::Chain - A set object representing a connected path between several objects.
+
+=head1 VERSION
+
+Version 0.02
+
+=cut
+
+our $VERSION = '0.02';
+
+use LaTeX::TikZ::Set::Point;
+
+use LaTeX::TikZ::Interface;
+use LaTeX::TikZ::Functor;
+
+use LaTeX::TikZ::Tools;
+
+use Any::Moose;
+use Any::Moose 'Util::TypeConstraints' => [ qw<subtype as coerce from via> ];
+
+=head1 RELATIONSHIPS
+
+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.
+
+=cut
+
+with qw<
+ LaTeX::TikZ::Set::Path
+ LaTeX::TikZ::Set::Container
+>;
+
+=head1 ATTRIBUTES
+
+=head2 C<kids>
+
+The L<LaTeX::TikZ::Set::Path> objects that form the chain.
+
+=cut
+
+subtype 'LaTeX::TikZ::Set::Chain::Elements'
+     => as 'ArrayRef[LaTeX::TikZ::Set::Path]';
+
+coerce 'LaTeX::TikZ::Set::Chain::Elements'
+    => from 'ArrayRef[Any]'
+    => via { [ map {
+        blessed($_) && $_->does('LaTeX::TikZ::Set')
+          ? $_
+          : LaTeX::TikZ::Set::Point->new(point => $_)
+       } @$_ ] };
+
+has '_kids' => (
+ is       => 'ro',
+ isa      => 'LaTeX::TikZ::Set::Chain::Elements',
+ init_arg => 'kids',
+ default  => sub { [ ] },
+ coerce   => 1,
+);
+
+sub kids { @{$_[0]->_kids} }
+
+=head2 C<connector>
+
+A code reference that describes how two successive elements of the chain are linked.
+It is called repeatedly with these arguments :
+
+=over 4
+
+=item *
+
+The current L<LaTeX::TikZ::Set::Chain> object.
+
+=item *
+
+The index C<$i> of the current position in the chain, starting at C<0> for the link between the two first elements.
+
+=item *
+
+The C<$i>-th L<LaTeX::TikZ::Set> object in the chain.
+
+=item *
+
+The C<$i+1>-th L<LaTeX::TikZ::Set> object in the chain.
+
+=back
+
+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.
+
+=cut
+
+subtype 'LaTeX::TikZ::Set::Chain::Connector'
+     => as 'CodeRef';
+
+coerce 'LaTeX::TikZ::Set::Chain::Connector'
+    => from 'Str'
+    => via { my $conn = $_; sub { $conn } };
+
+coerce 'LaTeX::TikZ::Set::Chain::Connector'
+    => from 'ArrayRef[Str]'
+    => via { my $conns = $_; sub { $conns->[$_[1]] } };
+
+has 'connector' => (
+ is       => 'ro',
+ isa      => 'LaTeX::TikZ::Set::Chain::Connector',
+ required => 1,
+ coerce   => 1,
+);
+
+has '_links' => (
+ is       => 'ro',
+ isa      => 'ArrayRef[Str]',
+ init_arg => undef,
+ default  => sub { [ ] },
+);
+
+=head1 METHODS
+
+=head2 C<add>
+
+=cut
+
+my $ltsp_tc = LaTeX::TikZ::Tools::type_constraint('LaTeX::TikZ::Set::Path');
+
+sub add {
+ my $set = shift;
+
+ $ltsp_tc->assert_valid($_) for @_;
+ return $set unless @_;
+
+ my $kids  = $set->_kids;
+ my $links = $set->_links;
+ my $conn  = $set->connector;
+
+ push @$kids, shift @_ unless @$kids;
+ return $set unless @_;
+
+ my $prev  = $kids->[-1];
+ for my $i (0 .. $#_) {
+  my $next = $_[$i];
+  my $link = $set->$conn($#$kids, $prev, $next);
+  confess('Invalid connector') unless defined $link and not blessed $link;
+  push @$links, $link;
+  push @$kids,  $next;
+  $prev = $next;
+ }
+
+ $set;
+}
+
+sub BUILD {
+ my ($set) = @_;
+
+ my @kids  = $set->kids;
+ return unless @kids >= 2;
+
+ my $links = $set->_links;
+ my $conn  = $set->connector;
+
+ my $prev  = $kids[0];
+ for my $i (1 .. $#kids) {
+  my $next = $_[$i];
+  my $link = $set->$conn($i - 1, $prev, $next);
+  confess('Invalid connector') unless defined $link and not blessed $link;
+  push @$links, $link;
+  $prev = $next;
+ }
+}
+
+=head2 C<path>
+
+=cut
+
+sub path {
+ my $set = shift;
+
+ my @kids  = $set->kids;
+ return '' unless @kids;
+
+ my $links = $set->_links;
+ my $conn  = $set->connector;
+
+ my $path = $kids[0]->path(@_);
+ for my $i (1 .. $#kids) {
+  my $link = ' ' . $links->[$i - 1] . ' ';
+  $link    =~ s/\s+/ /g;
+  $path   .= $link . $kids[$i]->path(@_);
+ }
+
+ return $path;
+}
+
+LaTeX::TikZ::Interface->register(
+ join => sub {
+  shift;
+  my $conn = shift;
+
+  __PACKAGE__->new(
+   kids      => \@_,
+   connector => $conn,
+  );
+ },
+ chain => sub {
+  shift;
+  confess("The 'chain' command expects an odd number of arguments")
+                                                                  unless @_ % 2;
+
+  my @kids = shift;
+  my @links;
+  for (my $i = 0; $i < @_; $i += 2) {
+   push @links, $_[$i];
+   push @kids,  $_[$i + 1];
+  }
+
+  __PACKAGE__->new(
+   kids      => \@kids,
+   connector => \@links,
+  );
+ }
+);
+
+LaTeX::TikZ::Functor->default_rule(
+ (__PACKAGE__) => sub {
+  my ($functor, $set, @args) = @_;
+  $set->new(
+   kids      => [ map $_->$functor(@args), $set->kids ],
+   connector => $set->connector,
+  );
+ }
+);
+
+__PACKAGE__->meta->make_immutable;
+
+=head1 SEE ALSO
+
+L<LaTeX::TikZ>, L<LaTeX::TikZ::Set::Path>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+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>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+    perldoc LaTeX::TikZ
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2011 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of LaTeX::TikZ::Set::Chain
diff --git a/t/00-load.t b/t/00-load.t
index 52955ab..061b3bb 100644
--- a/t/00-load.t
+++ b/t/00-load.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 34;
+use Test::More tests => 35;
 
 BEGIN {
  use_ok( 'LaTeX::TikZ' );
@@ -29,6 +29,7 @@ BEGIN {
  use_ok( 'LaTeX::TikZ::Set' );
  use_ok( 'LaTeX::TikZ::Set::Arc' );
  use_ok( 'LaTeX::TikZ::Set::Arrow' );
+ use_ok( 'LaTeX::TikZ::Set::Chain' );
  use_ok( 'LaTeX::TikZ::Set::Circle' );
  use_ok( 'LaTeX::TikZ::Set::Container' );
  use_ok( 'LaTeX::TikZ::Set::Line' );
diff --git a/t/01-api.t b/t/01-api.t
index b0d7b20..3e2f354 100644
--- a/t/01-api.t
+++ b/t/01-api.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 5 + 20 + 12;
+use Test::More tests => 5 + 22 + 12;
 
 use LaTeX::TikZ;
 
@@ -31,7 +31,7 @@ is(prototype('Tikz'), '', 'main::Tikz is actually a constant');
 my @methods = qw<
  formatter functor
  raw
- union seq
+ union seq chain join
  point line polyline closed_polyline rectangle circle arc arrow
  raw_mod
  clip layer
diff --git a/t/10-set.t b/t/10-set.t
index 9d20422..1476558 100644
--- a/t/10-set.t
+++ b/t/10-set.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 19 + 2 * 14;
+use Test::More tests => 28 + 2 * 21;
 
 use LaTeX::TikZ;
 
@@ -162,27 +162,102 @@ eval {
 like $@, failed_valid('Maybe[ArrayRef[LaTeX::TikZ::Set::Path]]'),
          'creating an union that contains a sequence croaks';
 
-my $path = eval {
+my $union = eval {
  Tikz->union($foo, $bar, $baz);
 };
 is $@, '', 'creating an union set doesn\'t croak';
 
-check $path, 'one path set', <<'RES';
+check $union, 'one union set', <<'RES';
 \draw foo bar baz ;
 RES
 
 eval {
- $path->add($foo);
+ $union->add($foo);
 };
-is $@, '', 'adding something to a path set doesn\'t croak';
+is $@, '', 'adding something to a union set doesn\'t croak';
 
-check Tikz->seq($path, $path), 'two identical path sets', <<'RES';
+check Tikz->seq($union, $union), 'two identical union sets', <<'RES';
 \draw foo bar baz foo ;
 \draw foo bar baz foo ;
 RES
 
 eval {
- $path->add($seq2);
+ $union->add($seq2);
 };
 like $@, failed_valid('LaTeX::TikZ::Set::Path'),
-         'adding a sequence to a path croaks';
+         'adding a sequence to a union croaks';
+
+my $join = eval {
+ Tikz->join('--' => $foo, $bar, $baz);
+};
+is $@, '', 'creating an chain set joined with a string doesn\'t croak';
+
+check $join, 'one chain set joined with a string', <<'RES';
+\draw foo -- bar -- baz ;
+RES
+
+eval {
+ $join->add($foo);
+};
+is $@, '', 'adding a set to a chain set joined with a string doesn\'t croak';
+
+check $join, 'one appended chain set joined with a string', <<'RES';
+\draw foo -- bar -- baz -- foo ;
+RES
+
+$join = eval {
+ Tikz->join(sub { ' ' } => $foo, $bar, $baz);
+};
+is $@, '', 'creating an chain set joined with a coderef doesn\'t croak';
+
+check $join, 'one chain set joined with a string', <<'RES';
+\draw foo bar baz ;
+RES
+
+eval {
+ $join->add($foo);
+};
+is $@, '', 'adding a set to a chain set joined with a coderef doesn\'t croak';
+
+check $join, 'one appended chain set joined with a coderef', <<'RES';
+\draw foo bar baz foo ;
+RES
+
+$join = eval {
+ Tikz->join([ '', '..', '--' ] => $foo, $bar, $baz);
+};
+is $@, '', 'creating an chain set joined with an arrayref doesn\'t croak';
+
+check $join, 'one chain set joined with a string', <<'RES';
+\draw foo bar .. baz ;
+RES
+
+eval {
+ $join->add($foo);
+};
+is $@, '', 'adding a set to a chain set joined with an arrayref doesn\'t croak';
+
+check $join, 'one appended chain set joined with an arrayref', <<'RES';
+\draw foo bar .. baz -- foo ;
+RES
+
+eval {
+ $join->add($bar);
+};
+like $@, qr/^Invalid connector/,
+         'adding too many sets to a chain set joined with an arrayref croaks';
+
+my $chain = eval {
+ Tikz->chain($foo => '--' => $bar => '->' => $baz);
+};
+is $@, '', 'creating an chain set with chain doesn\'t croak';
+
+check $chain, 'one chain set from chain', <<'RES';
+\draw foo -- bar -> baz ;
+RES
+
+eval {
+ Tikz->chain($foo, '--', $bar, '--');
+};
+like $@, qr/^The 'chain' command expects an odd number of arguments/,
+         'creating an union that contains a sequence croaks';
diff --git a/t/30-functor.t b/t/30-functor.t
index a5952ef..e455a9d 100644
--- a/t/30-functor.t
+++ b/t/30-functor.t
@@ -37,7 +37,11 @@ my $seq = Tikz->seq(
                  Tikz->raw('foo'),
                  Tikz->point(2),
                  Tikz->line(-1 => 3)
-                     ->clip(Tikz->circle(1, 1))
+                     ->clip(Tikz->circle(1, 1)),
+                 Tikz->union(
+                  Tikz->chain(4 => '--' => [ -3, 2 ]),
+                  Tikz->join('-|' => [ -1, 0 ], [ 0, 1 ]),
+                 ),
                 )
               ->clip(Tikz->rectangle([0, -1] => [2, 3]));
 
@@ -56,6 +60,7 @@ check $seq, 'the original sequence', <<'RES';
 \clip (1cm,0cm) circle (1cm) ;
 \draw (-1cm,0cm) -- (3cm,0cm) ;
 \end{scope}
+\draw (4cm,0cm) -- (-3cm,2cm) (-1cm,0cm) -| (0cm,1cm) ;
 \end{scope}
 RES
 
@@ -69,6 +74,7 @@ check $seq2, 'the translated sequence', <<'RES';
 \clip (0cm,1cm) circle (1cm) ;
 \draw (-2cm,1cm) -- (2cm,1cm) ;
 \end{scope}
+\draw (3cm,1cm) -- (-4cm,3cm) (-2cm,1cm) -| (-1cm,2cm) ;
 \end{scope}
 RES
 
@@ -96,6 +102,7 @@ check $seq2, 'the original sequence', <<'RES';
 \clip (0cm,1cm) circle (1cm) ;
 \draw (-2cm,1cm) -- (2cm,1cm) ;
 \end{scope}
+\draw (3cm,1cm) -- (-4cm,3cm) (-2cm,1cm) -| (-1cm,2cm) ;
 \end{scope}
 RES
 
@@ -104,6 +111,7 @@ check $seq3, 'the stripped sequence', <<'RES';
 \draw foo ;
 \draw (1cm,1cm) ;
 \draw (-2cm,1cm) -- (2cm,1cm) ;
+\draw (3cm,1cm) -- (-4cm,3cm) (-2cm,1cm) -| (-1cm,2cm) ;
 RES
 
 my $special = eval {
@@ -159,5 +167,6 @@ check $seq, 'a sequence translated by an origin', <<'RES';
 \clip (0cm,1cm) circle (1cm) ;
 \draw (-2cm,1cm) -- (2cm,1cm) ;
 \end{scope}
+\draw (3cm,1cm) -- (-4cm,3cm) (-2cm,1cm) -| (-1cm,2cm) ;
 \end{scope}
 RES
diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t
index b56e464..98b3e1f 100644
--- a/t/92-pod-coverage.t
+++ b/t/92-pod-coverage.t
@@ -15,7 +15,7 @@ my $min_pc = 0.18;
 eval "use Pod::Coverage $min_pc";
 plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
 
-plan tests => 34;
+plan tests => 35;
 
 my $moose_private = { also_private => [ qr/^BUILD$/, qr/^DEMOLISH$/ ] };
 
@@ -44,6 +44,7 @@ pod_coverage_ok( 'LaTeX::TikZ::Scope' );
 pod_coverage_ok( 'LaTeX::TikZ::Set' );
 pod_coverage_ok( 'LaTeX::TikZ::Set::Arc' );
 pod_coverage_ok( 'LaTeX::TikZ::Set::Arrow' );
+pod_coverage_ok( 'LaTeX::TikZ::Set::Chain', $moose_private );
 pod_coverage_ok( 'LaTeX::TikZ::Set::Circle' );
 pod_coverage_ok( 'LaTeX::TikZ::Set::Container' );
 pod_coverage_ok( 'LaTeX::TikZ::Set::Line' );