add Graph::GEXF while it's not on CPAN

Signed-off-by: franck cuny <franck@lumberjaph.net>

6 files changed, 338 insertions, 0 deletions

diff --git a/lib/Graph/GEXF/Role/Attributes.pm b/lib/Graph/GEXF/Role/Attributes.pm
new file mode 100644
index 0000000..e03f5b1
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Attributes.pm
@@ -0,0 +1,60 @@
+package Graph::GEXF::Role::Attributes;
+
+use MooseX::Role::Parameterized;
+
+parameter for => (
+    is       => 'ro',
+    required => 1,
+);
+
+parameter with_method => (
+    is      => 'ro',
+    default => 0,
+);
+
+role {
+    my $p = shift;
+
+    foreach my $type (@{$p->for}) {
+
+        my $attr_name  = $type . '_attributes';
+        my $total_attr = 'attributes_' . $type . '_total';
+        my $set_attr   = 'set_' . $type . '_attribute';
+        my $get_attr   = 'get_' . $type . '_attribute';
+        my $list_attr  = 'attributes_' . $type . '_list';
+        my $has_attr   = 'has_' . $type . '_attribute';
+
+        has $attr_name => (
+            traits  => ['Hash'],
+            is      => 'rw',
+            isa     => 'HashRef',
+            lazy    => 1,
+            default => sub { {} },
+            handles => {
+                $total_attr => 'count',
+                $set_attr   => 'set',
+                $get_attr   => 'get',
+                $list_attr  => 'keys',
+                $has_attr   => 'exists',
+            }
+        );
+
+        if ($p->with_method) {
+            my $method_name = 'add_' . $type . '_attribute';
+
+            method $method_name => sub {
+                my ($self, $name, $type, $default_value) = @_;
+                my $id = $self->$total_attr();
+                my $attr = {
+                    id      => $id,
+                    title   => $name,
+                    type    => $type,
+                    default => [$default_value],
+                };
+                $self->$set_attr($name => $attr);
+            };
+        }
+    }
+};
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Color.pm b/lib/Graph/GEXF/Role/Viz/Color.pm
new file mode 100644
index 0000000..d7c30f1
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Color.pm
@@ -0,0 +1,32 @@
+package Graph::GEXF::Role::Viz::Color;
+
+use Moose::Role;
+use Moose::Util::TypeConstraints;
+
+subtype RGBColor => as 'Num' => where { $_ >= 0 && $_ <= 255 };
+subtype Alpha => as 'Num' => where { $_ > 0 and $_ <= 1 };
+
+my $_has_colors  = 0;
+
+has [qw/r g b/] => (
+    is      => 'rw',
+    isa     => 'RGBColor',
+    default => 0,
+    trigger => sub {$_has_colors++},
+    traits  => ['Chained'],
+);
+
+has a => (
+    is      => 'rw',
+    isa     => 'Alpha',
+    default => 1,
+    traits  => ['Chained'],
+);
+
+sub has_colors { $_has_colors }
+
+no Moose::Util::TypeConstraints;
+no Moose::Role;
+
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Position.pm b/lib/Graph/GEXF/Role/Viz/Position.pm
new file mode 100644
index 0000000..c9e79c3
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Position.pm
@@ -0,0 +1,18 @@
+package Graph::GEXF::Role::Viz::Position;
+
+use Moose::Role;
+
+my $_has_position = 0;
+
+has [qw/x y z/] => (
+    is      => 'rw',
+    isa     => 'Num',
+    trigger => sub { $_has_position++ },
+    traits  => ['Chained'],
+);
+
+sub has_position { $_has_position }
+
+no Moose::Role;
+
+1;
diff --git a/lib/Graph/GEXF/Role/Viz/Shape.pm b/lib/Graph/GEXF/Role/Viz/Shape.pm
new file mode 100644
index 0000000..b092d6d
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Shape.pm
@@ -0,0 +1,39 @@
+package Graph::GEXF::Role::Viz::Shape;
+
+use Moose::Util::TypeConstraints;
+use MooseX::Role::Parameterized;
+
+enum EdgeShape => qw(solid doted dashed double);
+enum NodeShape => qw(disc square triangle diamond);
+
+parameter for => (
+    is       => 'ro',
+    required => 1,
+);
+
+role {
+    my $p = shift;
+
+    my ( $type, $default );
+
+    $type = ucfirst( $p->for ) . 'Shape';
+
+    if ( $p->for eq 'node' ) {
+        $default = 'disc';
+    }
+    else {
+        $default = 'solid';
+    }
+
+    has shape => (
+        is      => 'rw',
+        isa     => $type,
+        default => $default,
+        traits  => ['Chained'],
+    );
+};
+
+no Moose::Util::TypeConstraints;
+
+1;
+
diff --git a/lib/Graph/GEXF/Role/Viz/Size.pm b/lib/Graph/GEXF/Role/Viz/Size.pm
new file mode 100644
index 0000000..aef1574
--- /dev/null
+++ b/lib/Graph/GEXF/Role/Viz/Size.pm
@@ -0,0 +1,21 @@
+package Graph::GEXF::Role::Viz::Size;
+
+use MooseX::Role::Parameterized;
+
+parameter as => (
+    is       => 'ro',
+    required => 1,
+);
+
+role {
+    my $p = shift;
+
+    has $p->as => (
+        is      => 'rw',
+        isa     => 'Num',
+        default => '1.0',
+        traits  => ['Chained'],
+    );
+};
+
+1;
diff --git a/lib/Graph/GEXF/Role/XML.pm b/lib/Graph/GEXF/Role/XML.pm
new file mode 100644
index 0000000..cf12170
--- /dev/null
+++ b/lib/Graph/GEXF/Role/XML.pm
@@ -0,0 +1,168 @@
+package Graph::GEXF::Role::XML;
+
+use Moose::Role;
+
+use XML::Simple;
+
+has gexf_ns => (
+    is      => 'ro',
+    isa     => 'Str',
+    default => 'http://www.gexf.net/1.2draft'
+);
+
+has gexf_version => (
+    is      => 'ro',
+    isa     => 'Num',
+    default => '1.2'
+);
+
+sub to_xml {
+    my $self = shift;
+
+    my $graph = $self->_init_graph();
+
+    foreach (qw/node edge/) {
+        $self->_add_attributes( $graph, $_ );
+    }
+
+    $self->_add_nodes($graph);
+
+    my $xml_out = XMLout($graph, AttrIndent => 1, keepRoot => 1);
+    $xml_out;
+}
+
+sub _add_attributes {
+    my ($self, $graph, $type) = @_;
+
+    my $list_attr = 'attributes_' . $type . '_list';
+    my $get_attr  = 'get_' . $type . '_attribute';
+
+    my $attributes;
+    $attributes->{class} = $type;
+
+    foreach my $attr_id ($self->$list_attr) {
+        my $attribute = $self->$get_attr($attr_id);
+        push @{$attributes->{attribute}},
+          { id      => $attribute->{id},
+            type    => $attribute->{type},
+            title   => $attribute->{title},
+            default => $attribute->{default},
+          };
+    }
+
+    push @{$graph->{gexf}->{graph}->{attributes}}, $attributes;
+}
+
+sub _init_graph {
+    my $self = shift;
+
+    # XXX this need some refactoring
+    return {
+        gexf => {
+            xmlns   => $self->gexf_ns,
+            version => $self->gexf_version,
+            meta    => {creator => ['Graph::GEXF']},
+            graph   => {
+                mode            => $self->graph_mode,
+                defaultedgetype => $self->edge_type,
+            }
+        }
+    };
+}
+
+sub _add_nodes {
+    my ( $self, $graph ) = @_;
+
+    my $edges_id = 0;
+
+    foreach my $node_id ( $self->all_nodes ) {
+        my $node = $self->get_node($node_id);
+        my ( $node_desc, $edges ) = $self->_create_node($node);
+        push @{ $graph->{gexf}->{graph}->{nodes}->{node} }, $node_desc;
+        foreach my $edge (@$edges) {
+            push @{ $graph->{gexf}->{graph}->{edges}->{edge} }, $edge;
+        }
+    }
+}
+
+sub _create_node {
+    my ( $self, $node ) = @_;
+
+    my $label = $node->label || $node->id;
+
+    my $node_desc = { id => $node->id, label => $label };
+
+    foreach my $attr_id ( $node->attributes_node_list ) {
+        my $attr = $node->get_node_attribute($attr_id);
+        push @{ $node_desc->{attvalues}->{attvalue} },
+          { for => $attr->{id}, value => $attr->{value} };
+    }
+
+    $self->_add_visualizations_elements($node, $node_desc);
+
+    my @edges =
+      map { $self->_create_edge( $node->get_edge($_) ) } $node->all_edges;
+
+    return ($node_desc, \@edges);
+}
+
+sub _create_edge {
+    my ( $self, $edge ) = @_;
+    my $edge_desc = {
+        id     => $edge->id,
+        source => $edge->source,
+        target => $edge->target,
+        weight => $edge->weight,
+    };
+
+    $self->_add_shape($edge, $edge_desc);
+    
+    return $edge_desc;
+}
+
+sub _add_visualizations_elements {
+    my ( $self, $node, $node_desc ) = @_;
+
+    return unless $self->has_visualization;
+
+    foreach (qw/colors size shape position/){
+        my $method = "_add_$_";
+        $self->$method($node, $node_desc);
+    }
+}
+
+sub _add_colors {
+    my ( $self, $element, $element_desc ) = @_;
+
+    return unless $element->has_colors;
+    push @{ $element_desc->{'viz:color'} },
+      $self->_add_viz_elements( $element, qw/r g b a/ );
+}
+
+sub _add_size {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:size'}}, {value => $element->size};
+}
+
+sub _add_shape {
+    my ($self, $element, $element_desc) = @_;
+    push @{$element_desc->{'viz:shape'}}, {value => $element->shape};
+}
+
+sub _add_position {
+    my ($self, $element, $element_desc) = @_;
+
+    return unless $element->has_position;
+    push @{ $element_desc->{'viz:position'} },
+      $self->_add_viz_elements( $element, qw/x y z/ );
+}
+
+sub _add_viz_elements {
+    my ( $self, $element, @attrs ) = @_;
+    my %hash = map { $_ => $element->$_ } @attrs;
+    \%hash;
+}
+
+no Moose::Role;
+
+1;