#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# $Id: DotSerializer.pm,v 1.30 2007/03/11 02:19:05 eric Exp $

use strict;
require Exporter;
#require AutoLoader;

$W3C::Rdf::RdfDB::REVISION = '$Id: DotSerializer.pm,v 1.30 2007/03/11 02:19:05 eric Exp $ ';

package Proxy;
use W3C::Util::Object;
@Proxy::ISA = qw(W3C::Util::NamedParmObject);

package W3C::Rdf::DotSerializer;
use vars qw($VERSION $DSLI @ISA @TODO @EXPORT_OK);
@ISA = qw(W3C::Util::NamedParmObject Exporter); # AutoLoader);
@TODO = qw();
@EXPORT_OK = qw();
$VERSION = 0.95;
$DSLI = 'adpO';

use W3C::Util::Exception;
use W3C::Rdf::Atoms qw($RDF_SCHEMA_URI);
use W3C::Util::NamespaceHandler qw(&staticUnmapNamespace &staticMakeUpPrefix);

sub new {
    my ($proto, @parms) = @_;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@parms);
    $self->{-rdfTag} = $self->{-atomDictionary}->getUri($RDF_SCHEMA_URI.'RDF')->getUri;
    if (!defined $self->{-namespaceHandler}) {
	$self->{-namespaceHandler} = new W3C::Util::NamespaceHandler(-importMap => $self->{-importMap}, 
								     -createNamespaces => $self->{-createNamespaces}, 
								     -namespaceCreativity => $self->{-namespaceCreativity});
    }
    $self->{NODES} = {};
    $self->{ARCS} = [];
    $self->{ADDED_NAMESPACES} = [];
    $self->{SHAPE_MAP} = {};
    $self->{COLOR_COUNTER} = [0,0,0];
    if (!exists $self->{-nsSeparator}) {
	$self->{-nsSeparator} = ':';
    }
    if (exists $self->{-rankdir}) {
	$self->{-RANKDIR} = "rankdir=$self->{-rankdir};\n";
    }
    return $self;
}

sub setIterator {
    my ($self, $iterator) = @_;
    $self->{-iterator} = $iterator;
}

sub getNamespaceHandler {
    my ($self) = @_;
    return $self->{-namespaceHandler};
}

sub nest {
    return 0;
}

sub collection {
    return 1;
}

sub getText {
    my ($self) = @_;
    my @ret;

    push @ret, "digraph dotfile{ 
node [fontname=arial,fontsize=10,color=Black,fontcolor=Blue];
edge [fontname=arial,fontsize=10,color=Darkgreen,fontcolor=Red];
$self->{-RANKDIR}
// -------------------- labels --------------------
";

    if (@{$self->{ADDED_NAMESPACES}}) {
	my @decls;
	foreach my $decl (@{$self->{ADDED_NAMESPACES}}) {
	    my ($prefix, $ns) = @$decl;
	    push (@decls, "$prefix: $ns");
	}
	push (@ret, '"ns-decls"[label="'.join ('\l', @decls)."\",shape=\"box\"];\n");
    }

    if (%{$self->{SHAPE_MAP}} && $self->{-typeLegend}) {
	foreach my $type (keys %{$self->{SHAPE_MAP}}) {
	    my $attrs = &_hashToAttrs($self->{SHAPE_MAP}{$type}); # {%{$self->{SHAPE_MAP}{$type}}, 'label' => $type});
	    push (@ret, "\"$type\"[$attrs];\n");
	}
    }

    push @ret, "

// -------------------- nodes --------------------
";

    foreach my $node (keys %{$self->{NODES}}) {
	#my ($shape, $nodeStr) = @{$self->{NODES}{$node}};
	my $nodeId = &nodeToXmlId($node);
	my $nodeAttrs = &_hashToAttrs($self->{NODES}{$node});
	push @ret, "\"$nodeId\"[$nodeAttrs];";
    }

    push @ret, "

// ------------------ subgraphs ------------------
";

    foreach my $node (keys %{$self->{SUBGRAPHS}}) {
	my ($nodes, $label) = @{$self->{SUBGRAPHS}{$node}};
	my $nodeId = &nodeToXmlId($node);
	my $nodesStr = join (' -> ', map {&nodeToXmlId($_)} @$nodes);
	push @ret, "subgraph cluster_$nodeId {
	style=filled;
	color=lightgrey;
	node [style=filled,color=white];
	$nodesStr;
//	label = \"$label\";
}";
    }

push @ret, "
// -------------------- arcs --------------------
";

    return join ("\n", @ret, @{$self->{ARCS}}, '}', undef);
}

sub _hashToAttrs {
    my ($hash) = @_;
    my @ret;
    foreach my $key (keys %$hash) {
	push (@ret, "$key=\"$hash->{$key}\"");
    }
    return join (',', @ret);
}

sub startDocument {
    my ($self) = @_;
}

sub endDocument {
    my ($self) = @_;
}

use vars qw(%BNodesOut);
%BNodesOut = ();

sub showAtom {
    my ($self, $atom) = @_;
    if ($atom->isa('W3C::Rdf::String')) {
	my $DOT_STR_WIDTH = 500;
	my $nodeStr = $atom->getString();
	$nodeStr =~ s/\n/\\n/sxg;
	$nodeStr =~ s/\"/\\\"/sxg;
	$nodeStr = substr($nodeStr, 0, $DOT_STR_WIDTH);
	return {'label'=>$nodeStr, 'shape'=>'box'};
    } elsif ($atom->isa('W3C::Rdf::BNode')) {
	if ($self->{-allowAnonymousRefs}) {
	    my $outAtom = $BNodesOut{$atom};
	    if (!$outAtom) {
		$outAtom = $self->{-atomDictionary}->createBNode($self->{-resource});
		$BNodesOut{$atom} = $outAtom;
	    }
	    return {'label'=>'[genid'.$outAtom->getId().']', 'shape'=>'triangle'};
	}
	else {
	    return {'label'=>'', 'shape'=>'octagon'};
	}
    } elsif ($atom->isa('W3C::Rdf::Uri')) {
	my $atomStr = $atom->getUri();
	my $prefixed = $self->ensureNamespace($atomStr);
	return {'label'=>$prefixed, 'shape'=>'ellipse'};
    } elsif ($atom->isa('Proxy')) {
	if ($self->{-copyListEls}) {
	    return $self->showAtom($atom->{-orig});
	} else {
	    return {'label'=>'', 'shape'=>''};
	}
    } else {
	&throw(new W3C::Util::ProgramFlowException());
    }
}

sub _bend {
    my ($self, $type, $thing) = @_;
    my $atomStr = $type->getUri();
    my $prefixed = $self->ensureNamespace($atomStr);
    my $template = $self->{SHAPE_MAP}{$prefixed};
    if (!$template) {
	my $number = (%{$self->{SHAPE_MAP}} / 2);	
	my $color = sprintf("#%02x%02x%02x", 
			    &uniqueRangeInterpolation($self->{COLOR_COUNTER}[0], 2, 0, 64), 
			    &uniqueRangeInterpolation($self->{COLOR_COUNTER}[1], 2, 0, 64), 
			    &uniqueRangeInterpolation($self->{COLOR_COUNTER}[2], 2, 0, 64));
	$template = {'shape' => 'polygon', 'sides' => $number + 5, 
		     'color' => $color, 'fontcolor' => $color};
	&incrementBreadthFirstCounter($self->{COLOR_COUNTER});
	$self->{SHAPE_MAP}{$prefixed} = $template;
    }
    foreach my $key (keys %$template) {
	if (!($key eq 'color' && $thing->{'color'})) {
	    $thing->{$key} = $template->{$key};
	}
    }
}

# @@@ no worky
# 12 0 2 2
# 13 1 2 0

sub incrementBreadthFirstCounter {
    my ($digits) = @_;
    # Find current max digit;
    my $place = 0;
    my $value = 0;
    # [1 2 1]
    for (my $i = 0; $i < @$digits; $i++) {
	if ($value <= $digits->[$i]) {
	    $place = $i;
	    $value = $digits->[$i];
	}
    }
    for (my $i = 0; $i < @$digits; $i++) {
	if ($digits->[$i] < $value) {
	    $digits->[$i] = $value;
	    last;
	} else {
	    $digits->[$i] = 0;
	    if ($i == @$digits - 1) {
		$digits->[0] = $value+1;
	    }
	}
    }
}

# Interpolate $n into range from $ceiling to $floor, dividing by $points as
# many times as necessary to ensure a unique value.

sub uniqueRangeInterpolation {
    my ($n, $points, $floor, $ceiling) = @_;

    # Funny corner case caused by subtracting 1 below.
    if ($n == 0 && $points == 2) {
	return $ceiling;
    }

    my $power = 1;
    my $offset = $n;
    # Iteration is cheaper than calling antilog functions for low n.
    while ($power < $n+1) {
	$offset = $n+1 - $power;
	$power = $power * $points;
    }
    my $step = ($ceiling - $floor)/$power;
    # Stretch offset fill space betwen power and next power.
    # This bypasses points hit by values of n resulting in lower powers.
    # example: (12, 3, 19, 100) => 85 and
    #          (13, 3, 19, 100) => 79 skip
    #          ( 4, 3, 19, 100) => 82
    $offset = int(($offset - 1) * $points/($points - 1) + 1);
    return int(($ceiling - $offset * $step) + .5);
}

sub serializeStatements {
    my ($self, $withThisSubject, $forceAbout) = @_;
#    my %ORDER = (
#		 "http://example.org/USorFrenchFlagColor" =>					    2, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#red" =>    4, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#white" =>  3, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#blue" =>   1, 
#		 "http://example.org/ItalianFlagColor" =>					    5, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#red1" =>   6, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#white1" => 7, 
#		 "file://na/home/eric/sources/public/perl/modules/W3C/Rdf/test/list.owl#green" =>  8, 
#		 );
#    $withThisSubject = [sort {$ORDER{$a->getSubject->toString} <=> $ORDER{$b->getSubject->toString}} @$withThisSubject];
    for (my $iStatement = 0; $iStatement < @$withThisSubject; $iStatement++) {
	my $statement = $withThisSubject->[$iStatement];
	#print STDERR $statement->getSubject->toString,"\n";
	my $p = $statement->getPredicate;
	my $s = $statement->getSubject;
	my $o = $statement->isa('W3C::Rdf::ListStatement') ? 
	    $statement->getObjects : $statement->getObject;

	my $sHash = $self->{NODES}{$s};
	if (!$sHash) {
	    $sHash = $self->{NODES}{$s} = $self->showAtom($s);
	}
	if ($self->{-typeShapes} && $p->getUri eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#type') {
	    my $atomStr = $o->getUri();
	    my $prefixed = $self->ensureNamespace($atomStr);
	    $self->_bend($o, $sHash);
	    if ($self->{-typeLabels}) {
		$sHash->{'label'}.="\\n$prefixed";
	    }
	} else {
	    my $pHash = $self->{PREDICATES}{$p};
	    if (!$pHash) {
		$pHash = $self->{PREDICATES}{$p} = $self->showAtom($p);
		$pHash->{'shape'} = 'ellipse';
	    }
	    if ($statement->isa('W3C::Rdf::ListStatement')) {
		# Create a local copy of the list. This is needed when some
		# nodes from the list appear in two Collections. We leave the
		# oversubscribed node in one and make arcs to it from the
		# corresponding spoofed nodes in other Collections.
		my $thisCollection = [];
		foreach my $listEl (@$o) {
		    if (exists $self->{NODES}{$listEl} && 0) {
			# Need to spoof the listEl.
			my $origListEl = $listEl;
			$listEl = new Proxy(-orig => $listEl);
			if ($self->{-copyListEls}) {
			} else {
			    my ($spoofedId, $origId) = (&nodeToXmlId($listEl), &nodeToXmlId($origListEl)); # , &_hashToAttrs($pHash));
			    push (@{$self->{ARCS}}, "\"$spoofedId\"->\"$origId\";"); # [$attrs];");
			}
		    }
		    $self->{NODES}{$listEl} = $self->showAtom($listEl);
		    $self->{NODES}{$listEl}{'style'} = 'filled';
		    $self->{NODES}{$listEl}{'color'} = 'white';
		    push (@$thisCollection, $listEl);
		}
		$self->{SUBGRAPHS}{$o->[0]} = [$thisCollection, 'Collection'];
		$o = $thisCollection->[0];
	    } else {
		if (!exists $self->{NODES}{$o}) {
		    $self->{NODES}{$o} = $self->showAtom($o);
		}
	    }
	    my ($sId, $oId, $attrs) = (&nodeToXmlId($s), &nodeToXmlId($o), &_hashToAttrs($pHash));
	    push (@{$self->{ARCS}}, "\"$sId\"->\"$oId\"[$attrs];");
	}
    }
}

sub nodeToXmlId {
    my ($node) = @_;
    $node = "$node";
    if ($node =~ m/(\w+)=[A-Z]+\(0x(\w+)\)/) {
	return "$1$2";
    } else {
	&throw(new W3C::Util::Exception(-message => "don't know how to turn \"$node\" into an XML ID"));
    }
}

sub ensureNamespace {
    my ($self, $name) = @_;
    my $namespaceHandler = $self->{-namespaceHandler};
    my ($ns, $prefix, $remainder) = $namespaceHandler->unmapNamespace($name, undef);

    if (defined($ns)) {
	# Tag name is already known from a parent element.
    } else {
	# Tag name is not known so we need to create one.

	if (my $importer = $self->{-importMap}) {
	    # Look in the importMap for one.
	    ($ns, $prefix, $remainder) = $importer->unmapNamespace($name, undef);
	}
	if (!defined($ns) && $self->{-createNamespaces}) {
	    # Resort to making one up.
	    eval {
		($ns, $prefix, $remainder) = &staticMakeUpPrefix($name, $self->{-namespaceCreativity});
	    }; if ($@) {
		if (my $ex = &catch('W3C::Util::NoViableLocalnameException')) {
		    ($ns, $prefix, $remainder) = ($name, 'ns', '');
		} else {
		    &throw();
		}
	    }
	}

	if (defined($ns)) {

	    # Make sure imported or made up namespace does not collide.
	    my ($base, $ordinal) = ($prefix, 0);
	    while (($namespaceHandler && $namespaceHandler->getNamespace($prefix))) {
		$prefix = $base.'-'.$ordinal;
		$ordinal++;
	    }

	    # Add the new namespace.
	    $namespaceHandler->addNamespace($prefix, $ns, {});
	    # Note that we will have to write a decl for it.
	    push (@{$self->{ADDED_NAMESPACES}}, [$prefix, $ns]);
	} else {
	    &throw(new W3C::Util::Exception(-message => "unable to map \"$name\" to a namespace"));
	}
    }

    if (!$prefix) { # may add defaultNS at some point || $prefix eq $defaultPrefix) {
	return ("$remainder");
    } else {
	return ("${prefix}$self->{-nsSeparator}$remainder");
    }
}

1;

__END__

=head1 NAME

W3C::Rdf::DotSerializer - serialize RDF graphs in dot format

=head1 SYNOPSIS

  use W3C::Rdf::Atoms;
  use W3C::Rdf::RdfDB;
  require W3C::Rdf::DotSerializer;
  my $atoms = new W3C::Rdf::Atoms();
  my $rdfDB = new W3C::Rdf::RdfDB(-atomDictionary => $atoms);
  my $algae2 = new W3C::Rdf::Algae2(-atomDictionary => $atoms);
  my $serializer = new W3C::Rdf::DotSerializer(-atomDictionary => $atoms);
  my $iterator = $rdfDB->makeSerializerIterator($statements, $algae2);
  $iterator->iterate($serializer);
  print $serializer->getText();

=head1 DESCRIPTION

C<W3C::Rdf::RdfDB>'s C<W3C::Rdf::RdfDB::SerializerIterator> calls
C<W3C::Rdf::DotSerializer> to generate dot (AT&T Graphvis) files. These files
render traditional circles and arrows diagrams of the RDF graph.

This module is part of the W3C::Rdf CPAN module.

=head1 CONSTRUCTOR

=over 4

=item new ( ATOMS [, FLAGS] )

Creates an C<W3C::Rdf::DotSerializer>.  This must be passed an Atoms dictionary.
Attitional flags:

=back

=head1 METHODS

=over 4

=item collection()

Return whether this serializer has special code for collections. If so,
C<serializeStatements> may be called with a C<W3C::Rdf::Atoms::ListStatement>.

=item nest()

Return whether this serializer can express nested descriptions.

=item startDocument()

Follow SAX convention except there is no document locator (the serializer is
the actual owner of the document).

=item endDocument()

Follow SAX convention.

=item serializeStatements( STATEMENTS, [ ITERATOR ] )

Take a set of statements to be serialized. The C<ITERATOR> is only used if the
serializer attempts to serialize nested (statements with a subject of the
current object). The C<STATENTS> may also be ListStatemens, in which case
special code serializes a collection.

=item getText()

Return a scalar with the serialized RDF. The caller will likely write this to
a file and execute a dot command like:

  C<dot -T png -o graph.png graph.dot>

=back

=head1 AUTHOR

Eric Prud'hommeaux <eric@w3.org>

=head1 SEE ALSO

L<W3C::Rdf::RdfDB>

=cut
