#!/usr/bin/perl
# version Introspector RDF.

package VCG::Introspector;

use strict;
use vars qw($AUTOLOAD $VERSION $DEBUG $program);

use IPC::Run qw(run);

$VERSION = '0.5';
$DEBUG = 0;
$program = "/home/mdupont/vcgdotgnu/vcgengine/vcgengine/src/vcg2ppm";

=head1 NAME

VCG - Interface to the VCG graphing tool

=head1 SYNOPSIS


  use VCG;
  my $vcg = VCG->new(outfile=>'resulta.vcg');
  $vcg->add_node(title => 'aaa');
  $vcg->add_node(title => 'bbb', label='b');
  $vcg->add_node(title => 'ccc', color=>'yellow');

  $vcg->add_edge(source => 'aaa', target=>'bbb', label => 'Foo:Bar');

  $vcg->output_as_pbm('mygraph.pbm');

  $vcg->output_as_ps(filename=>'mygraph.ps');

  my $data = $vcg->as_ppm();
  open (OUTFILE, 'outfile.ppm') or die "error $!\n";
  print OUTFILE $data;
  close OUTFILE;

=head1 DESCRIPTION

This module provides an interface to to the vcg graphing tool. It supports a 
limited selection of options and file formats. The vcg graphing tool homepage 
is currently http://rw4.cs.uni-sb.de/users/sander/html/gsvcg1.html but is being actively
developed elsewhere.

This module is based on Leon Brocard's GraphViz module, it tries
to provide a similar interface to offer some sense of consistency.

VCG is now in active development and although Graph::Writer::VCG already exists,
this module provides a similar interface to graphviz and will be more closely tied
into vcg as it becomes more actively developed - see James Micheal DuPont's announcement
at http://mail.gnome.org/archives/dia-list/2003-February/msg00029.html.

=cut

=head1 METHODS

=head2 new

new objects are created using the constructor method 'new'.

This method accepts name attributes in the form :

my $vcg = VCG->new(outfile=>'foo.pbm')

my $vcg = VCG->new(title=>'Dia Dependancies Diagram',debug=>1);

my $vcg = VCG->new();

my %config = ( xmax => 700, ymax=>700, program=>'xvcg', x=>30, y=>30 );
my $vcg = VCG->new(%config);

my $vcg = VCG->new( outfile=>'diagram.ps', landscape=>1, paper=>'tabloid', spline=>1 );

=cut

sub new {
  my $class = shift;
  my %config = @_;

  my $self = \%config;;
  bless($self, $class);
  $self->{edges} = [];
  $self->{nodes} = [];
  $self->{title} ||= "untitled";
  $self->{outfile} ||= "vcg.out";
  $self->{program} ||= $program;
  $self->{error} = "none - everything is fine";

  $DEBUG = 1 if ($config{debug});

  return $self;
}

=head2 add_edge

add_edge allows you to add edges to your vcg object (edges are the lines or relationships between nodes).

In a Finite State Diagram, edges would represent transitions between states.

This method accepts the source, target and colour of the edge :

$vcg->add_edge( source=>'from_node', target=>'to_node');

$vcg->add_edge( source=>'aaa', target=>'bbb', color=>'grey');

=cut

sub add_edge {
  my $self = shift;
  my %args = @_;
  $args{color} ||= 'black';

  my $label = ""; #empty

  if (exists($args{label}))
    {
      $label = "label: \"". $args{label} ."\"";
    }

  my $edge = qq(edge: { $label sourcename: "$args{source}" targetname: "$args{target}"  color: $args{color}});


  push (@{$self->{edges}}, $edge);
  return 1;
}

=head2 add_node

add_node allows you to add nodes to your vcg object (nodes are the things connected, while edges are the connections).

In a Finite State Diagram, nodes would be the individual states.

This method accepts the label, title and background colour of the node :

$vcg->add_node( title=>'aaa' );

$vcg->add_node( label=>'aaa' );

$vcg->add_node( label=>'aaa', title=>'A', color=>'yellow' );


=cut

my %names;
my %nameof;
my %strings;
my %seen; #what have we seen?

sub add_unique_node {
  my $self = shift;

  my %args = @_;

  if (exists($args{id}))
    {
      if (!$seen{$args{id}}++)
	{
	  #touched for the very first time.
	    return add_node $self, %args;
	}
      return 0;
    }
  return 0;
}


sub add_node {
  my $self = shift;
  my %args = @_;
  $args{color} ||= 'white';
  $args{label} ||= $args{title};
  my $node = qq(node: { title: "$args{title}" color: $args{color} label: "$args{label}"});
  push (@{$self->{nodes}}, $node);
  return 1;
}

=head2 get_vcg_version

You can get the version and copyright message as a string using the vcg object (requires vcg be installed)

my $version = $vcg->get_vcg_version() or die "couldn't get version : $vcg->error() \n";


=cut

sub get_vcg_version {
  my $self = shift;
  my $version;
  my $error;
  run [$self->{program}, '-version'], \undef, \$version, \$self->{error};
  return $version;
}


######################################################################################
# generate the vcg grammar for the graph

sub _get_graph {
  my $self = shift;
  my $nodes = join ("\n",@{$self->{nodes}});
  my $edges =  join ("\n",@{$self->{edges}});
  my $values = "";
  foreach my $field (qw/xmax ymax x y/) {
    $values .= "$field:$self->{$field} " if ( defined $self->{$field} );
  }

  my $graph = <<end;
graph: { title: "$self->{title}"

  layout_downfactor: 1
  layout_upfactor: 1
  layout_nearfactor: 1
  layout_splinefactor: 70
  spreadlevel: 1
  treefactor: 0.500000
  node_alignment: center
  orientation: top_to_bottom
  late_edge_labels: no
  display_edge_labels: yes
  dirty_edge_labels: no
$values
$nodes
$edges
}
end
  return $graph;
}

=head2 as_ps, as_pbm, as_ppm, as_vcg, as_plainvcg

The VCG object allows you to access the output of the vcg tool directly, suitable for using with graphic libraries - although some libraries or older versions may not be able to cope with these formats.

You can access the output in any of postscript, pbm, ppm, vcg (annotated) and vcg (plain) :

my $image_as_ppm = $vcg->as_ppm(); # string of image as formatted as ppm

my $vcg_with_coords = $vcg->as_vcg(); # handy for building a pixmap or something or converting to dia xml for example

=head2 output_as_ps, output_as_pbm, output_as_ppm

The VCG object allows you to output straight to a file through the vcg tool in any of postscript, pbm and ppm. This functionality requires that the vcg tool be installed.

$vcg->output_as_ps('my_diagram.ps'); # now open the file in the gimp or import into LaTeX and you can get this free Mad Scientist (TM) white coat and bunsen burner.

=head2 output_as_vcg, output_as_plainvcg

The VCG object also allows you to output straight to file in annotated vcg with coordinates, or plain vcg syntax. The plain syntax does not require the vcg tool to be installed.

$vcg->output_as_plainvcg('compiler_graph.vcg'); # just in case you want to generate a diagram but don't have vcg installed.

$vcg->output_as_vcg('compiler_graph_with_coords.vcg'); # lovely jubbly

=cut

######################################################################################
# Generate magic methods to save typing

sub AUTOLOAD {
  my $self = shift;
  my $type = ref($self)
    or die "$self is not an object";

  my $name = $AUTOLOAD;
  $name =~ s/.*://;   # strip fully-qualified portion
  return if $name =~ /DESTROY/;

  my $filename = shift() unless (scalar @_ % 2);
  my %args = @_;
  $filename ||= $args{filename};
  $filename ||= $self->{outfile};

  my $vcg = $self->_get_graph();
  my $output;

  my @vcg_args = ($filename);
  push (@vcg_args,  "-scale $self->{scale}") if (defined $self->{scale}) ;
  push (@vcg_args,  "-spline") if (defined $self->{spline}) ;
  push (@vcg_args,  "-paper $self->{paper}") if (defined $self->{paper}) ;
  push (@vcg_args,  "-portrait") if (defined $self->{portrait}) ;
  push (@vcg_args,  "-landscape") if (defined $self->{landscape}) ;

  if ($name =~ /^as_(ps|pbm|ppm|plainvcg|vcg)/) {
    my $filetype = $1;
    unshift(@vcg_args,"-$filetype".'output');
    if ($filetype eq "plainvcg") {
      $output = $vcg;
    } else {
      unlink $filename if (-f $filename);

      run [$self->{program}, @vcg_args , "- "], \$vcg, \$output;

      warn $output if ($DEBUG);

      open (FILE,$filename) or die "unable to open $filename : $!\n";
      my $data = join ('',(<FILE>));
      close FILE;
      if (-f $filename) { unlink $filename or die "unable to remove tempory file $filename : $! \n"; }
      $output = $data;
    }
  } elsif ($name =~ /output_as_(ps|pbm|ppm|plainvcg|vcg)$/){
    my $filetype = $1;
    unshift(@vcg_args,"-$filetype".'output');
    if ($filetype eq "plainvcg") {
      open OUTFILE,">$filename" or die "couldn't open $filename for output : $!\n";
      print OUTFILE $vcg;
      close OUTFILE;
      $output = 1;
    } else {
      unlink $filename if (-f $filename);
      run [$self->{program}, @vcg_args , "- "], \$vcg, \$output;
    }
  } else {
    die "Method $name not defined!";
  }
  return $output;
}


##########################################################################

=head1 SEE ALSO

  GraphViz : http://www.graphviz.org

  GraphViz perl module

  Graph::Writer::VCG perl module

  vcg/xvcg : man pages

=head1 AUTHOR

Aaron Trevena E<lt>F<aaron@droogs.org>E<gt>

Introspector and RDF Support :
James Michael DuPont E<lt>F<mdupont777@yahoo.com>E<gt>

=head1 COPYRIGHT

Copyright (C) 2003, James Michael DuPont,  Aaron Trevena, Leon Brocard

This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.

=cut

1;

##########################################################################
##########################################################################

package RedlandHandler;
use strict;
use warnings;
use strict;
use warnings;
use RDF::Redland;
use RDF::Redland::Serializer;
use Data::Dumper;
use Data::BFDump qw[Dumper];
use URI;
#use VCG::Introspector;


#sub findallnodes
#21 lines matching "sub" in buffer vcgout.pl.



#    232:sub main
       #     15:sub new
       #     65:sub open_output
       #     33:sub read_storage; 
       # maybe    131:sub findallnodes
       #     53:sub serialize
       #    186:sub finish
       #    174:sub print_output


#     77:sub new_storage
#     95:sub getfields



#    202:sub export_vcg  # new functoin for writing vcg



use strict;
use warnings;
use RDF::Redland;
use RDF::Redland::Serializer;
use Data::Dumper;
use Data::BFDump qw[Dumper];
use URI;

sub new
{
    my $class = shift;
    my $filename  = shift;


    my $self = {
	filename => $filename,
	datamodel => {
	    predicates=>{}
	},
	nodes => {
	}
    };

    return bless $self, $class;
}


sub serialize
{
    my $self = shift;
    my $name = shift;
    my $serializer=new RDF::Redland::Serializer("ntriples");

    $serializer->set_namespace();

    $serializer->serialize_model_to_file($name, undef, $self->{model});
}


sub open_output
{
    my $self = shift;

    $self->{vcg} = VCG::Introspector->new(scale=>100);

}

sub new_storage
{
    my $self = shift;
    warn "Creating storage\n";
    $self->{storage}=new RDF::Redland::Storage("hashes", "test", 
						  "new='yes',hash-type='bdb',dir='.'");

    die "Failed to create RDF::Redland::Storage\n" unless $self->{storage}; 
    # this gives the term "self storage a new meaning"

    warn "\nCreating model\n";
    $self->{model}=new RDF::Redland::Model($self->{storage}, "");
    die "Failed to create RDF::Redland::Model for storage\n" unless $self->{model};
}

sub getfields
{
    my $self = shift;
    my $stmt = shift;
    die "you need to pass a statement" unless $stmt; # 
    my $subj =$stmt->subject;
    die "you need a subject of the  statement" unless $subj; # 

    my $str = $subj->uri->as_string;
    if ($str)
    {
	my $uri = RDF::Redland::Node->new_from_uri_string($str);
	
	# create the subject object
	my $s =Introspector::Learner::grokfield ($self,"subject",$stmt->subject);
	
	my $stmtq=RDF::Redland::Statement->new_from_nodes( $uri, undef,undef); 
	my $stream=$self->{model}->find_statements($stmtq);
	my $count = 0;
	while(!$stream->end) {

	    my $statement2=$stream->current;
	    $count ++;

	    $stream->next;
	}

	$stream=undef;

    }
	


}
# here we find the nodes on the first classfier attribute, 
# the tree code
# sub findallnodes
# {
#     my $self = shift;
#     my $uri = shift;

# #    print "Going to search for uri $uri in predicate\n";
#     my $statement=
# 	RDF::Redland::Statement->new_from_nodes(undef
# 						, 
# 						$uri ? RDF::Redland::Node->new_from_uri_string($uri) : undef, 
# 						undef);
    
#     my $stream=$self->{model}->find_statements($statement);

#     my @sub;

#     my %types;

# #    my %seen;

#     while(!$stream->end) {

# 	my $stmt   =$stream->current;
# 	my $subject=$stmt->subject;
# 	my $object =$stmt->object;
# 	my $pred   =$stmt->predicate;

# 	my $obj = $object->as_string();
# 	my $predicate =$pred->as_string();

# 	# FILTER 
# 	# 1 - 
# 	if ($predicate  =~ /node_fields:linenumber/)
# 	{
# 	    print  "$predicate : $obj\n";

# 	    if ($obj eq "0")
# 	    {
# 		next; # skip builtin object
# 	    }
# 	}

# #	foreach my $s ($subject) #,$object
# #	{
# #	    if (!$seen{$s->as_string()} = $s->as_string())
# #	    {
# #		$self->{vcg}->add_node(
# #			   label=>$s->as_string(),
# #			   title=>$s->as_string()
# #			   );
# #	    }
# #	}
# #	$self->{vcg}->add_edge(source=> $subject->as_string(),
# #			       target=>$object->as_string() ,label=>$pred->as_string());
# #	#$types{$object->as_string()}++;
# #	my $emit = $subject->as_string() . " " . $pred->as_string() . " " . $object->as_string() . ".\n";
# #	$emit =~ s/[\[\]]//g;
# #	$emit =~ s/\#//g;
# #	print $emit;
# #	print $stmt->as_string() . "\n";
# 	}
# 	$stream->next;
#     }

# #    $stream=undef;
#  }


sub print_output
{
    my $self = shift;
    my $filename  = shift;
#    my $uri=new RDF::Redland::URI("file:$filename");
#    my $serializer=new RDF::Redland::Serializer("rdfxml");
#   die "Failed to find serializer\n" if !$serializer;
#    $serializer->serialize_model_to_file("$filename", $uri, $model);
#    $serializer=undef;

  warn "open $filename file for output";
  open (FILE,">$filename") or die "couldn't open $filename file for output : $!\n";
 print FILE $self->{vcg}->_get_graph();

#    $self->{vcg}->output_as_vcg($filename) or die "can't write file to vcg : $! \n";
  close FILE;

}

sub finish
{
    my $self = shift;

    my $model = $self->{out}->{model};
    
    # TODO SOME FINAL PROCESSING

}

1;


####################################################
# export_vcg - output to file via VCG.pm and xvcg

#sub export_vcg {
#  my $self = shift;

#  require VCG;
#  require Data::Dumper;
#  my $extension = "plainvcg" ;
#  my %nodes   = ();
#  my $classes = $self->Classes;

  # node
#  $self->{vcg}->add_node(label=>$node, title=>$node);
#  $self->{vcg}->add_edge(source=>$source, target=>$target ,label=>$label );

#  $self->{vcg}->add_node(label=>$node, title=>$node);
#  $self->{vcg}->add_edge(source=>$nodes{$Dependancy->Parent}, target=>$nodes{$Dependancy->Child});

#}

sub parse
{
    my $self = shift;
    my $filename = shift;

    my $model = $self->{model};

    my $count =0;
    warn "\nParsing URI (file) $filename\n";
    my $uri=new RDF::Redland::URI("file:$filename");
    my $parser=new RDF::Redland::Parser("ntriples", "text/plain"); #//"raptor", "ntriples

#    $self->{model}=new RDF::Redland::Model($self->{storage}, "");

    die "Failed to find parser\n" if !$parser;
    my $stream=$parser->parse_as_stream($uri,$uri);
    while(!$stream->end) {
	my $stmt = $stream->current();

	my $subject=$stmt->subject;
	my $object =$stmt->object;
	my $pred   =$stmt->predicate;


	my $obj = $object->as_string();
	my $predicate =$pred->as_string();
	my $subjStr  = $subject->as_string();

	foreach my $x ($obj,$predicate,$subjStr)
	{
	    $x =~  s/.*\#//g; # the prefix is byebye
	    $x =~  s/file://g;
	    $x =~  s/node_fields://g;
	    $x =~  s/node_modifiers://g;
	    $x =~  s/node_types://g;
	    $x =~  s/([\[:\]])//g;
	}


##  add the object types in

	if ($predicate  =~ /tree-code-ref/)
	{
	    $self->{object_types}->{$subjStr} =  $obj;
	}

	if (!$self->filter($stmt))
	{
	    print "Filtered".  $stmt->as_string() . "\n";
	    $stream->next();
	    $count++;
	    next;
	}
	else
	{
	    $self->{subjects}->{$subjStr}->{count}++;
	    {
		foreach my $s ($subjStr, $obj)
		{
		    $self->{subjects}->{$s}->{count}++;
		}
		$self->{vcg}->add_edge(
				   source=> $subjStr,
				   target=>$obj ,
				   label=>$predicate);

	    }

	    $stream->next();
	    $count++;
	}
    }
    $stream=undef;
    warn "Parsing added $count statements\n";
}


# hashs

sub attr
{
    my ($self,$subjStr,$predicate,$obj) =@_;
    $self->{attributes}->{$subjStr}->{$predicate}=$obj;
    return 0;
}

sub filter
{
    my $self = shift;
    my $stmt   =shift;

    my $subject=$stmt->subject;
    my $object =$stmt->object;
    my $pred   =$stmt->predicate;

    my $obj = $object->as_string();
    my $predicate =$pred->as_string();
	my $subjStr  = $subject->as_string();

	foreach my $x ($obj,$predicate,$subjStr)
	{
	    $x =~  s/.*\#//g; # the prefix is byebye
	    $x =~  s/file://g;
	    $x =~  s/node_fields://g;
	    $x =~  s/node_modifiers://g;
	    $x =~  s/node_types://g;
	    $x =~  s/([\[:\]])//g;
	}


    # tree codes
    if ($predicate  =~ /name$/)   {   
	#collect names
	$names{$subjStr}=$obj;
	$nameof{$obj}=$subjStr;
	print "names : $subjStr $obj\n";
	return 0;
    }
    if ($predicate  =~ /strg/)   {   
	#collect string
	$strings{$subjStr}=$obj;
	print "strings : $subjStr $obj\n";

	return 0;
    }



## TYPES :
    if ($predicate  =~ /unql/)   {   return $self->attr($subjStr,$predicate,$obj);    }   ## unqualified
    if ($predicate  =~ /type/)   {   return $self->attr($subjStr,$predicate,$obj);    }   ## type 
    if ($predicate  =~ /ptd/)   {    return $self->attr($subjStr,$predicate,$obj);    }    ## pointer

    if ($predicate  =~ /tree-code-ref/)   {   return 0 }

    if ($predicate  =~ /modifier/)   {   return $self->attr($subjStr,$predicate,$obj);     }
    if ($predicate  =~ /low/)   {   return $self->attr($subjStr,$predicate,$obj);     }
    if ($predicate  =~ /high/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /min/)   {   return $self->attr($subjStr,$predicate,$obj);     }
    if ($predicate  =~ /max/)   {   return $self->attr($subjStr,$predicate,$obj);     }
    if ($predicate  =~ /prec/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /lngt/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /algn/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /size/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /line/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /filename/)   {   return $self->attr($subjStr,$predicate,$obj);}
    if ($predicate  =~ /bpos/)   {   return $self->attr($subjStr,$predicate,$obj);    }
    if ($predicate  =~ /scpe/)   {   return $self->attr($subjStr,$predicate,$obj);    } # reverse
    if ($predicate  =~ /used/)   {   return $self->attr($subjStr,$predicate,$obj);    } # reverse
    if ($predicate  =~ /linenumber/)
    {
#	print  "$predicate : $obj\n";
	if ($obj eq "0")
	{
	    return 0;
	}
	else
	{
	    return $self->attr($subjStr,$predicate,$obj);    # reverse
	}

    }
    return 1;
}


sub main
{
#    my $test_file =shift (@ARGV) || die "missing first parameter (in file) "; # this is the file

    my $dir = shift (@ARGV);
    my $name = shift (@ARGV);

    my $baseuri  =shift (@ARGV) || undef; # this is the predicate/attribute to
    #to search for

    my $outfile =shift (@ARGV) || "output.vcg";

    print "out file is $outfile";
    my $introspector = RedlandHandler->new("");
    my $read =1;

    $introspector->open_output();

    if (($dir =~ /\.n3/) || ($dir =~ /\.nt/))
    {
#	$introspector->new_storage(".", $dir."storage");
	$introspector->parse($dir);
    }
    else
    {
	$introspector->read_storage($name,$dir);
#	$introspector->findallnodes($baseuri);
    }


    foreach my $k (keys %{$introspector->{subjects}})
    {

	my $count  = $introspector->{subjects}->{$k}->{count};

	my $objtype= $introspector->{object_types}->{$k};
	$objtype = $objtype || "<none>";
	if (($count) && ($count >= 1))
	{
	    my $str = "<>";
	    my $named_obj = $names{$k};
	    my $named_str ="";
	    if ($named_obj)
	    {
		$named_str = $strings{$named_obj};
		if (!$named_str)
		{
		    $named_str="";
		    my $old_named =$named_obj;
		    $named_obj = $names{$named_obj};
		    if ($named_obj)
		    {
			$named_str = $strings{$named_obj};
			print "FOUND DOUBLE NAME CHAIN $old_named -> $named_obj -> $named_str\n";

		    }
		    else
		    {
			$named_str = $named_str || "<NULL>";
		    }
		}
		print "names : $k -- $named_obj --> $named_str\n";

	    }

	    ###
	    my $attrstr ="";

	    my $subjHash = $introspector->{attributes}->{$k};

	    foreach my $a (keys %{$subjHash})
	    {
		my $attr= $subjHash->{$a};
		$attrstr.="$a -> $attr\n";
	    }

	    print "adding subject $k\n";

	    my $objectcount = $introspector->{subjects}->{$k}->{count};
	    if (!$named_str)
	    {
		$introspector->{vcg}->add_node(label=> $k ."/$objtype (". $objectcount.")\n$attrstr" , title=>$k);
	    }
	    else
	    {
		$introspector->{vcg}->add_node(label=> "$k/$objtype -> $named_str\n$attrstr" , title=>$k);
	    }
	}
    }


    # this goes over the data one more time
#    $introspector->serialize("test.n3");


# NOT NEEDED    $introspector->finish();



    if ($outfile) { $introspector->print_output($outfile); };

    $introspector= undef;
}

main;

