#!/usr/bin/perl

# First try to get an easier Meta Grammar Editor
# Based on uDraw(Graph) (formerly daVinci)

use strict;
use AppConfig qw/:argcount :expand/;

my $config = AppConfig->new( "mg|f=s"     => {DEFAULT => 'frenchmg.xml'},
			     "smg!",
			     "mgconf|c=s",
			     "verbose|v!" => {DEFAULT => 0},
			     "uDraw=s"    => {DEFAULT => "$ENV{HOME}/uDrawGraph-3.1/bin/uDrawGraph"}
			   );

$config->args();                # parse remaining args

$config->mg(shift) if (@ARGV);

unless (-t STDIN) {
    unless (defined $config->mgconf()) {
	my ($base,$ext) = ($config->mg =~ /^(.+?)(\.\w+)?$/);
	my $mgconf = "$base.conf$ext";
	$config->mgconf($mgconf);
    }
    
    if (defined $config->mg() && $config->mg() =~ /\.smg$/) {
	$config->smg(1);
    }
}

MG::DaVinci->new($config);

package MG::DaVinci;
use XML::LibXML;
use Event qw/loop unloop/;
use IPC::Open2;
use Carp;

my %answers = (
	       'ok'             => qr/^ok/,
	       'node_select'    => qr/^node_selections_labels/,
	       'edge_select'    => qr/^edge_selection_label/,
	       'browser_select' => qr/^browser_answer/,
	      );


my %relations = (
		 'father'   => '>>',
		 'precedes' => '<',
		 'dominate' => '>>+'
		 );

sub new {
  my $this   = shift;
  my $class  = ref($this) || $this;
  my $config = shift;
  my $cmd    = $config->uDraw;
  my $self = { 'classes'         => {},
	       'parser'          => XML::LibXML->new(),
	       'config'          => $config,
	       'cmd'             => $cmd,
	       'selected_nodes'  => [],
	       'selected_cursor' => undef,
	       'selected_edge'   => [],
	       'hidden'          => [],
	       'disabled'        => [],
	       'connected'       => 0,
	       'msg'             => []	# msg to be sent to uDraw
	     };
  bless $self, $class;
  
  $self->parse_file($config->mg);

#  $self->open_file($config->mg);
    
  my ($fromChild,$toChild);
  
  $self->{pid} = open2($fromChild,$toChild,$self->{cmd},'-pipe')
    || croak "Could not start $self->{cmd}";

  # Set IO Event Watcher on $receiver for info coming from uDraw
  $self->{watcher} = 
    Event->io(desc => "reading data from uDraw",
	      fd   => $fromChild,
	      poll => 'r',
	      cb   => \&uDraw_handler,
	      data => $self);

  $self->{user_watcher} =
    Event->io(desc => "reading data from user",
	      fd   => \*STDIN,
	      poll => 'r',
	      cb   => \&user_handler,
	      data => $self);

  $self->{toChild}   = $toChild;
  $self->{fromChild} = $fromChild;

  loop;

}

sub verbose {
  my $self = shift;
  return unless $self->{'config'}->verbose;
  print STDERR @_,"\n";
}

sub warning {
  my $self = shift;
  print STDERR @_,"\n";
}

sub uDraw_handler {
  my $self   = shift;
  my $handle = $self->w->fd;
  my $mg     = $self->w->data;
  my $info   = <$handle>;
  chomp $info;

  if ($info =~ /^context\((.+)\)/) {
    $mg->{context} = label_unquote($1);
  } if ($info =~ /^ok$/) {
    if (!$mg->{connected}) {
      $mg->verbose("Connection established");
      $mg->{connected} = 1;
      ## We can now display the Meta Grammar
      $mg->display;
    } else {
      ## upon confirmation of execution of current message
      ## the next one is sent
      $mg->try_next_pending($info);
    }
  } elsif ($info =~ /^quit$/) {
    $mg->exit;
  } elsif ($info =~ /^communication_error/) {
    $mg->warning("Communication error with uDraw for '$mg->{'msg'}[0][0]'");
    ## To be robust send next command
    $mg->send_next_pending;
  } elsif ($info =~ /^node_selections_labels\(\[(.*)\]\)/) {
    my @selected = map(label_unquote($_),split(/,/,$1));
    $mg->verbose("Selected nodes @selected");
    $mg->reset_cursor;
    my @old = @{$mg->{selected_nodes}};
    undef $mg->{classes}{$_}{selected} foreach (@old);
    $mg->{selected_nodes} = [@selected];
    $mg->{classes}{$_}{selected} = 1 foreach (@selected);
    $mg->set_cursor(0);
    $mg->update_class_visual(@old,@selected);
    $mg->try_next_pending($info);

  } elsif ($info =~ /^edge_selection_label\((.*)\)/) {
    my $selected = label_unquote($1);
    $mg->verbose("Selected edge $selected");
    $mg->{selected_edge} = $selected;
    $mg->try_next_pending($info);
  } elsif ($info =~ /^menu_selection\((.+)\)/) {
    $mg->menu_handler(label_unquote($1));
    $mg->try_next_pending($info);
  } elsif ($info =~ /^popup_selection_node\((.+),(.+)\)/) {
    $mg->popup_handler(label_unquote($1),label_unquote($2));
    $mg->try_next_pending($info);
  } elsif ($info =~ /^browser_answer\((.+),(.+)\)/){
    my $file = label_unquote($1);
    $mg->open_file($file) if ($file);
    $mg->try_next_pending($info);
  } else {
    $mg->verbose($info);
  }
}

sub menu_handler {
  my ($self, $menu) = @_;
  $self->verbose("Handling menu $menu");
  if ($menu =~ /^\#\%exit/og) {
    $self->clean_kill;
  } elsif ($menu =~ /^\#\%open/og) {
    $self->open_browser_file;
  } elsif ($menu =~ /^\#\%save$/og) {
    $self->save_file;
  } elsif ($menu =~ /^nextsel/) {
    $self->which_class('+');
  } elsif ($menu =~ /^prevsel/) {
    $self->which_class('-');
  } 
}

sub popup_handler {
  my ($self, $class, $menu) = @_;
  $self->verbose("Handling popup $menu on $class");
  if ($menu =~ /^hide/og) {
    $self->hide($class);
  } elsif ($menu =~ /^show/og) {
    $self->show($class);
  } elsif ($menu =~ /^parents/og) {
    my @nodes = $self->class_supers($class,0);
    $self->select_nodes(@nodes);
    $self->focus($nodes[0]) if (@nodes);
  } elsif ($menu =~ /^children/og) {
    my @nodes = $self->class_children($class,0);
    $self->select_nodes(@nodes);
    $self->focus($nodes[0]) if (@nodes);
  } elsif ($menu =~ /^disable/og) {
    $self->disable($class);
  } elsif ($menu =~ /^enable/og) {
    $self->enable($class);
  } elsif ($menu =~ /^delete/og) {
    $self->class_delete($class);
  }
}


sub user_handler {
  my $self   = shift;
  my $handle = $self->w->fd;
  my $mg     = $self->w->data;
  my $info   = <$handle>;

  return if ($info =~ /^\s*$/);

  if ($info =~ /^last$/) {
    $info = $mg->{last};
  } else {
    $mg->{'last'} = $info;
  }

  my $select = ($info =~ s/^select\s+//);
  my @nodes  = ();

  if ($info =~ /^quit|exit$/){
    $mg->clean_kill;
  } elsif ($select && $info =~ /^class(?:es)?\s+(.*)/) {
    @nodes = split(/\s+/,$1);
  } elsif ($info =~ /^delete\s+class(?:es)?\s+(.*)/) {
    $select = 0;
    my @classes = map($mg->which_class($_),split(/\s+/,$1));
    $mg->class_delete(@classes);
  } elsif ($info =~ /^unselect\s+(?:s)?/) {
    $mg->select_nodes();
  } elsif ($info =~ /^focus\s+(\S+)?/) {
    my $class = $mg->which_class($1);
    @nodes = ($class);
    $mg->focus($class);
  } elsif ($info =~ /^(hide|show)\s+(.*)/) {
    $select = 0;
    my @classes = map($mg->which_class($_),split(/\s+/,$2));
    $mg->$1(@classes);
  } elsif ($info =~ /^(detach)\s+(.+)/) {
    $select = 0;
    my @classes = map($mg->which_class($_),split(/\s+/,$2));
    $mg->detach(@classes);
  } elsif ($info =~ /^restore/) {
    $select = 0;
    $mg->restore;
  } elsif ($info =~ /^content\s+(\S+)\s+(\S+)/) {
    my $class = $mg->which_class($1);
    @nodes = ($class);
    $mg->out($mg->node_content($class,$2));
  } elsif ($info =~ /^content\s+(\S+)/) {
    my $class = $mg->which_class($1);
    @nodes = ($class);
    $mg->out($mg->class_content($class));
  } elsif ($info =~ /^description\s+(\S+)/) {
    my $class = $mg->which_class($1);
    @nodes = ($class);
    $mg->out($mg->class_description($class));
  } elsif ($info =~ /^(supers|children)(\*?)\s+(\S+)/) {
    my $inherited = $2 ? 1 : 0;
    my $class = $mg->which_class($3);
    @nodes = ($1 eq 'supers') 
      ? $mg->class_supers($class,$inherited)
	: $mg->class_children($class,$inherited);
    $mg->tree_out($inherited,"$1$2 $class:",@nodes);
  } elsif ($info =~ /^(needs|provides)(\*?)\s+(\S+)/) {
    my $inherited = $2 ? 1 : 0;
    my $class = $mg->which_class($3);
    @nodes = ($class);
    $mg->tree_out($inherited,"$1$2 $class:",$mg->class_resources($class,$1,$inherited));
  } elsif ($info =~ /^nodes(\*?)\s+(\S+)/) {
    my $inherited = $1 ? 1 : 0;
    my $class = $mg->which_class($2);
    @nodes = ($class);
    $mg->tree_out($inherited,"nodes$1 $class:",$mg->class_nodes($class,$inherited));
  } elsif ($info =~ /^relations(\*?)\s+(\S+)/) {
    my $inherited = $1 ? 1 : 0;
    my $class = $mg->which_class($2);
    @nodes = ($class);
    $mg->tree_out($inherited,"relations$1 $class:",$mg->class_relations($class,$inherited));
  } elsif ($info =~ /^(need|provid)ing\s+(\S+)/) {
    my $kind = ($1 eq 'need') ? 'needs' : 'provides';
    @nodes = $mg->resource_in($2,$kind);
    $mg->out("$1"."ing $2:",@nodes);
  } elsif ($info =~ /^selected/) {
    @nodes = @{$mg->{selected_nodes}};
    $mg->out('Selected classes:',@nodes);
  } elsif ($info =~ /^open\s+(?:file\s+)?(\S+)/) {
    $select = 0;
    $mg->open_file($1);
  } elsif ($info =~ /^save\s+(?:file\s+)?/) {
    $select = 0;
    $mg->save_file;
  } elsif ($info =~ /^save\s+(?:file\s+)?as\s+(\S+)/) {
    $select = 0;
    $mg->save_file($1);
  } else {
    $select = 0;
    $mg->verbose("Bad user cmd: $info");
  }

  $mg->select_nodes(@nodes) if ($select && @nodes);

}

sub which_class {
  my ($self, $class) = @_;
  if ($class =~ /^\.$/) {	# . : return first selected class 
    return $self->{selected_nodes}[$self->{selected_cursor}];
  } elsif ($class =~ /^([+-])(\d*)$/) {	# + : forward/backward cursor
    my $pos = $self->reset_cursor;
    my $inc = $2 || 1;
    $inc = "$1$inc";
    $pos = ($pos + $inc) % @{$self->{selected_nodes}};
    return $self->set_cursor($pos);
  } elsif ($class =~ /^\*$/) {	# * : return all selected classes
    return @{$self->{selected_nodes}};
  } else {
    return $class;
  }
}

sub exit {
  my $self = shift;
  $self->out('Goodbye');
  $self->verbose("Connection ended");
  $self->{connected} = 0;
  close($self->{fromChild});
  close($self->{toChild});
  unloop;
  exit;
}

sub open_file {
  my ($self, $file) = @_;
  return unless (-r $file);
  $self->{selected_nodes} = [];
  $self->{hidden} = [];
  $self->{disabled} = [];
  $self->{classes} = {};
  undef $self->{selected_cursor};
  
  $self->{config}->file($file);
  $self->parse_file($file);
  $self->display;
}

sub save_file {
  my $self = shift;
  my $file = shift || $self->{config}->file;
  my $mgconf = $self->{config}->mgconf;
  $self->warning('File saving is not yet fully implemented');

  ## Saving configuration file
  my $info = XML::LibXML::Document->new('1.0','ISO-8859-1');
  my $root = XML::LibXML::Element->new('metaGrammar');
  foreach my $class (@{$self->{disabled}}) {
    my $elt = XML::LibXML::Element->new("class");
    $elt->setAttribute('name',$class);
    $elt->setAttribute('disabled','yes');
    $root->appendChild($elt);
  }
  $info->setDocumentElement($root);
  $info->toFile($mgconf,1);

  ## Saving file
  ## $self->{mg}->toFile('toto.xml',1);

}

######################################################################
## XML related methods

sub parse_file {
  my ($self, $file) = @_;
  if ($file =~ /\.xml$/) {
    $self->{'mg'} = $self->{'parser'}->parse_file($file);
  } elsif ($file =~ /\.smg$/) {
      open SMG, "-|", "smg2xml $file" || die "can't run smg2xml on $file";
      $self->{'mg'} = $self->{'parser'}->parse_fh(\*SMG);
      close(SMG);
  }
}


sub parse_mgconf {
  my $self   = shift;
  my $mgconf = $self->{config}->mgconf;
  $self->verbose("Loading conf file $mgconf");
  return unless (-r $mgconf);
  my $info = $self->{'parser'}->parse_file($mgconf);
  my @disabled = xvalues($info->findnodes('/metaGrammar/class[@disabled]/@name'));
  $self->verbose("Disabling @disabled");
  $self->disable(@disabled);
}

sub classes {
  my $self = shift;
  my @classes = $self->{mg}->findnodes( '/metaGrammar/class' );
}

sub class {
  ## use caching on classes for faster access
  my ($self, $name) = @_;
  unless (defined $self->{classes}{$name}{content}) {
    my @found = $self->{mg}->findnodes( "/metaGrammar/class[\@name='$name']" );
    $self->{classes}{$name}{content} = (@found) ? $found[0] : undef;
  }
  return $self->{classes}{$name}{content};
}

sub class_content {
  my $self = shift;
  my $class = $self->class(@_);
  return unless (defined $class);
  return $class->serialize;
}

sub class_description {
  my ($self, $class_name) = @_;
  my $class = $self->class($class_name);
  my @desc = $class->findnodes( "description" );
  return unless (@desc);
  return $desc[0]->serialize;
}


sub class_supers {
  my ($self, $name, $inherited) = @_;
  my $class = $self->class($name);
  my @supers = xvalues($class->findnodes( 'super/@name' ));
  if ($inherited) {
    push(@supers,
	 map( $self->class_supers($_,$inherited), 
	      @supers )
	);
    return [$name,@supers];
  }
  return @supers;
}

sub class_children {
  my ($self, $name, $inherited) = @_;
  my @down = xvalues($self->{mg}->findnodes("/metaGrammar/class[super[\@name='$name']]/\@name"));
  if ($inherited) {
    push(@down,map( $self->class_down($_,$inherited), @down));
    return [$name,@down];
  }
  return @down;
}

sub class_resources {
  my ($self, $name, $kind, $inherited) = @_;
  my $class = $self->class($name);
  my @resources = xvalues($class->findnodes( "$kind/\@name" ));
  if ($inherited) {
    push(@resources,
	 map( $self->class_resources($_,$kind,$inherited), 
	      $self->class_supers($name)
	    )
	);
    return [$name,@resources];
  }
  return @resources;
}

sub class_nodes {
  my ($self, $name, $inherited) = @_;
  my $class = $self->class($name);
  my @nodes = xvalues($class->findnodes( 'node/@name' ));
  if ($inherited) {
    push(@nodes,
	 map( $self->class_nodes($_,$inherited), 
	      $self->class_supers($name)
	    )
	);
    return [$name,@nodes];
  }
  return @nodes;
}

sub node_content {
  my ($self, $class_name, $node_name) = @_;
  my $class = $self->class($class_name);
  my @node = $class->findnodes( "node[\@name='$node_name']" );
  return unless (@node);
  return $node[0]->serialize;
}

sub class_relations {
  my ($self, $name, $inherited) = @_;
  my $class = $self->class($name);
  my @relations = $class->findnodes( 'relation' );
  my @out = ();
  foreach my $rel (@relations) {
    my $r = $rel->getAttribute('rel');
    my $n1 = $rel->getAttribute('arg1');
    my $n2 = $rel->getAttribute('arg2');
    push(@out,"[$n1 $r $n2]");
  }
  if ($inherited) {
    push(@out,
	 map( $self->class_relations($_,$inherited), 
	      $self->class_supers($name)
	    )
	);
    return [$name,@out];
  } 
  return @out;
}

sub class_delete {
  my $self       = shift;
  my @classes    = @_;
  my @nodedelete = ();
  my @edgedelete = ();
  foreach my $class (@classes) {
    push(@nodedelete,'delete_node('.quote($class).')');
    $self->reset_cursor if ($class eq $self->{selected_cursor});
    foreach my $child ($self->class_children($class)) {
      my $content =  $self->class($child);
      push(@edgedelete,'delete_edge('.quote("$child $class").')');
      my $super = ($content->findnodes("super[\@name='$class']"))[0];
      $content->removeChild($super);
      push(@classes,$child) unless ($content->findnodes('super'));
    }
  }
  foreach my $class (@classes) {
    $self->class($class)->unbindNode();
    delete $self->{classes}{$class};
  }
  $self->{selected_nodes} = [ grep( exists $self->{classes}{$_}, @{$self->{selected_nodes}}) ];
  $self->{disabled} = [ grep( exists $self->{classes}{$_}, @{$self->{disabled}}) ];
  $self->{hidden} = [ grep( exists $self->{classes}{$_}, @{$self->{hidden}}) ];
##  $self->verbose("DELETE @nodedelete @edgedelete");
  $self->verbose("deleted @classes");
  $self->update(\@nodedelete,\@edgedelete);
}

sub serialize {
  return map($_->serialize,@_);
}

sub xvalues {
  map($_->value,@_);
}

sub resource_in {
  my ($self, $resource, $kind) = @_;
  return xvalues($self->{mg}->findnodes( "/metaGrammar/class[$kind\[\@name='$resource']\]/\@name" ));
}

######################################################################
## user communication

sub out {
  my $self = shift;
  autoflush STDOUT 1;
  print join(' ',@_),"\n";
}

sub tree_out {
  my $self      = shift;
  my $inherited = shift;
  my $msg       = shift;
  autoflush STDOUT 1;
  if ($inherited) {
    print "$msg";
    tree_out_internal('',@_);
    print "\n";
  } else {
    $self->out($msg,@_);
  }
}

sub tree_out_internal {
  my $indent = shift;
  foreach my $arg (@_) {
    unless (ref($arg)) {
      print " $arg";
      next;
    }
    my ($new,@args) = @$arg;
    next unless (@args);
    print "\n$indent$new:";
    tree_out_internal("\t$indent",@args);
  }
}

######################################################################
## uDraw commands

sub label_unquote {
  my $label = shift;
  $label =~ /^\"(.*)\"$/;
  return $1;
}

sub display {
  my $self    = shift;
  my @classes = $self->classes;
  my @graph   = ();
  my @edges   = ();
  foreach my $class (@classes) {
    my $name = $class->getAttribute('name');
    push(@graph,class_node($name));
    foreach my $super ($class->findnodes('super')) {
      my $target = $super->getAttribute('name');
      push(@edges,super_edge($name,$target));
    }
  }
  
  ## Initialization
  $self->send('app_menu(control_file_events)');
  $self->send('app_menu(create_menus([menu_entry("nextsel","next")]))');
  $self->send('app_menu(create_menus([menu_entry("prevsel","prev")]))');
  $self->send('app_menu(activate_menus(["#%exit","#%open","nextsel","prevsel"]))');
##  $self->send('set(rules_first(true))');
  $self->title($self->{config}->mg());

  my $cmenu = build_menu('hide'     => 'hide',
			 'parents'  => 'parents',
			 'children' => 'children',
			 'disable'  => 'disable',
			 'delete'   => 'delete'
			);
  my $hmenu = build_menu('show'     => 'show',
			 'parents'  => 'parents',
			 'disable'  => 'disable',
			 'delete'   => 'delete'
			);
  my $dmenu = build_menu('hide'     => 'hide',
			 'parents'  => 'parents',
			 'children' => 'children',
			 'enable'   => 'enable',
			 'delete'   => 'delete'
			 );

  $self->send('visual(add_rules([nr("class",[a("COLOR","white"),m('.$cmenu.')])]))');
  $self->send('visual(add_rules([nr("hidden",[m('.$hmenu.')])]))');
  $self->send('visual(add_rules([nr("disabled",[a("COLOR","red"),m('.$dmenu.')])]))');

  ## Display graph
  $self->send("graph(new([".join(',',@graph)."]))");
  $self->update([],\@edges);
##  $self->update([],[$_]) foreach (@edges);

  ## Set info from mgconf file
  $self->parse_mgconf;
  $self->orientation('left_right');  
  $self->improve_all;
}

sub class_node {
  my $name  = shift;
  my $edges = join(',',@_);
  my $bit   = <<NODE;
l("$name",n("class",[a("OBJECT","$name")],[$edges]))
NODE
  chomp $bit;
  return $bit;
}

sub super_edge {
  my ($from, $to) = @_;
  my $bit = <<EDGE;
new_edge("$from $to","super",[],"$to","$from")
EDGE
  chomp $bit;
  return $bit;
}

sub build_menu {
  my @menu = @_;
  my @tmp  = ();
  while (@menu) {
    my $a = shift @menu;
    my $b = shift @menu;
    push(@tmp,'menu_entry('.quote($a).','.quote($b).')')
  }
  return '['.join(',',@tmp).']';
}

sub set_cursor {
  my ($self, $pos) = @_;
  $self->{selected_cursor} = $pos;
  my $class = $self->{selected_nodes}[$pos];
  $self->update_class_visual($class);
  $self->send("window(show_status(\"class $class\"))");
  $self->verbose("focus on $class");
  return $class;
}

sub reset_cursor {
  my $self = shift;
  return unless (defined $self->{selected_cursor});
  my $pos = $self->{selected_cursor};
  my $class = $self->{selected_nodes}[$pos];
  undef $self->{selected_cursor};
  $self->update_class_visual($class);
  return $pos;
}

sub clean_kill {
  shift -> send('menu(file(exit))');
}

sub send {
  my $self   = shift;
  my $msg    = shift;
  my $answer = shift || 'ok';	# kind of answer to be expected
  my $stack  = $self->{'msg'};
  $self->{toChild}->print($msg,"\n") unless (@{$stack});
  push(@{$stack},[$msg,$answer]);
}

sub send_first {
  my $self   = shift;
  my $msg    = shift;
  my $answer = shift || 'ok';	# kind of answer to be expected
  my $stack  = $self->{'msg'};
  $self->{toChild}->print($msg,"\n") unless (@{$stack});
  unshift(@{$stack},[$msg,$answer]);
}

sub send_next_pending {
  my $self  = shift;
  my $stack = $self->{'msg'};
  shift(@$stack);	# last msg was handled (ok or bad)
  # Send next pending instruction
  $self->{toChild}->print($stack->[0][0],"\n") if (@$stack);
}

sub check_answer {
  my ($self, $info) = @_;
  my $expected = $self->{'msg'}[0][1];
  return ($info =~ /^$answers{$expected}/);
}

sub try_next_pending {
  my $self = shift;
  $self->send_next_pending if ($self->check_answer(@_));
}

sub improve_all {
  my $self = shift;
  $self->send("menu(layout(improve_all))");
}

sub orientation {
  my ($self, $orientation) = @_;
  $self->send("menu(layout(orientation($orientation)))");
}

sub title {
  my ($self, $title) = @_;
  $self->send("window(title(\"$title\"))");
}

sub open_browser_file {
  my $self = shift;
  $self->send('window(file_browser(true,"browser","Open","","",[bt("MG Files","*.xml","to open a MG file"),bt("all Files","*","to open all files")],true))','browser_select');
}

sub update {
  my ($self, $nodes, $edges) = @_;
  $self->send("graph(update([".join(',',@$nodes)."],[".join(',',@$edges)."]))");
}

sub fit_scale_to_window {
  my $self = shift;
  $self->send('menu(view(fit_scale_to_window))');
}

sub select_nodes {
  my $self  = shift;
  my @nodes = @_;
  my $cmd   = join('','special(select_nodes(',qlist(@nodes),'))');
  $self->send($cmd,'node_select');
}

sub select_edge {
  my ($self, $from, $to) = @_;
  $self->send('special(select_edge('.quote("$from $to").'))','edge_select');
}

sub focus {
  my ($self, $node) = @_;
  $self->send('special(focus_node('.quote($node).'))');
}

sub select_parents {
  my $self = shift;
  my $selected = qlist(@{$self->{selected_nodes}});
  $self->send("menu(navigation(select_parents($selected)))",'node_select');
}

sub select_children {
  my $self = shift;
  my $selected = qlist(@{$self->{selected_nodes}});
  $self->send("menu(navigation(select_children($selected)))",'node_select');
}

sub disable {
  my $self  = shift;
  my @nodes = @_;
  $self->{classes}{$_}{disabled} = 1 foreach (@nodes);
  push(@{$self->{disabled}},@nodes);
  $self->{disabled} = [ sort @{$self->{disabled}}];

  $self->change_type('disabled',@nodes);
  $self->update_class_visual(map($self->weak_disable($_),@nodes),@nodes);
}

sub weak_disable {
  my ($self, $class) = @_;
  my @children = $self->class_children($class);
  my @l = @children;
  foreach my $child (@children) {
    next if ($self->{classes}{$child}{'wdisabled'});
    $self->{classes}{$child}{'wdisabled'} = 1;
    push(@l,$self->weak_disable($child));
  }
  return @l;
}

sub weak_enable {
  my ($self, $class) = @_;
  my @children = $self->class_children($class);
  my @l = @children;
  foreach my $child (@children) {
    next unless (defined $self->{classes}{$child}{'wdisabled'});
    undef $self->{classes}{$child}{'wdisabled'};
    push(@l,$self->weak_enable($child));
  }
  return @l;
}

sub enable {
  my $self  = shift;
  my @nodes = @_;
  $self->change_type('class',@nodes);
  undef $self->{classes}{$_}{disabled} foreach (@nodes);
  $self->{disabled} = [sort grep( $self->{classes}{$_}{disabled}, @{$self->{disabled}}) ];
  my @weak_enable = map($self->weak_enable($_),@nodes);
  $self->weak_disable($_) foreach @{$self->{disabled}};
  @weak_enable = grep( !defined($self->{classes}{$_}{wdisabled}), @weak_enable);
  $self->update_class_visual(@weak_enable,@nodes);
}

sub detach {
  my $self    = shift;
  my @classes = @_;
  ## to be done
  ## Should cut classes and descendants from current window
  ## and redisplay them in some new window
  ## however, what should we do for classes with multiple parents ?
}

sub attach {
  my $self    = shift;
  my @classes = @_;
  ## to be done
  ## should close current window and redisplay its content in main window
}

sub hide {
  my $self  = shift;
  my $nodes = qlist(@_);
  $self->send("menu(abstraction(hide_subgraph($nodes)))");
  $self->change_type('hidden',@_);
  $self->{classes}{$_}{hidden} = 1 foreach (@_);
  push(@{$self->{hidden}},@_);
  $self->{hidden} = [ sort @{$self->{hidden}}];
}

sub show {
  my $self  = shift;
  my $nodes = qlist(@_);
  $self->send("menu(abstraction(show_subgraph($nodes)))");
  $self->change_type('class',@_);
  undef $self->{classes}{$_}{hidden} foreach (@_);
  $self->{hidden} = [ sort grep($self->{classes}{$_}{'hidden'},@{$self->{hidden}}) ];
}

sub restore {
  my $self = shift;
  $self->send("menu(abstraction(restore_all_subgraphs))");
  my @hidden = @{$self->{hidden}};
  $self->change_type('class',@_);
  undef $self->{classes}{$_}{hidden} foreach (@hidden);
  $self->{hidden} = [];
}

sub change_attr {
  my $self  = shift;
  my $attrs = shift;
  my @nodes = @_;
  my @tmp = ();
  foreach my $attr (keys %$attrs) {
    push(@tmp,'a('.quote($attr).','.quote($attrs->{$attr}).')');
  }
  my $tmp = '['.join(',',@tmp).']';
  @tmp = ();
  foreach my $node (@nodes) {
    push(@tmp,'node('.quote($node).','.$tmp.')');
  }
  my $cmd = 'graph(change_attr(['.join(',',@tmp).']))';
  $self->send($cmd);
}

sub update_class_visual {
  my $self    = shift;
  my @classes = @_;
  my @tmp     = map($self->get_class_attr($_),@classes);
  my $cmd     = 'graph(change_attr(['.join(',',@tmp).']))';
##  $self->verbose("UPDATE $cmd\n");
  $self->send($cmd);
}

sub get_class_attr {
  my ($self, $class) = @_;
  my $info  = $self->{classes}{$class};
  my $shape = 'box';
  $shape = 'ellipse' if ($info->{selected} 
			 && $class eq $self->{selected_nodes}[$self->{selected_cursor}]);
  my $color = $info->{selected} 
    ? ( ($info->{disabled} || $info->{wdisabled}) ? 'brown' : 'green' )
      : ( $info->{disabled} 
	  ? 'red'
	  : ( $info->{wdisabled} ? 'orange' : 'white' )
	);
##  $self->verbose("VISUAL $class: COLOR $color SHAPE $shape");
  return 'node('.quote($class).',[a("COLOR",'.quote($color).'),a("_GO",'.quote($shape).')])';
}

sub change_type {
  my $self  = shift;
  my $type  = shift;
  my @nodes = shift;
  $self->send('graph(change_type('.qplist('node',map(($_ => $type),@nodes)).'))');
}

sub qplist {
  my $op  = shift;
  my @l   = @_;
  my @tmp = ();
  while (@l) {
    my $a = shift @l;
    my $b = shift @l;
    push(@tmp,$op.'('.quote($a).','.quote($b).')');
  }
  return '['.join(',',@tmp).']';
}

sub qlist {
  my @labels = @_;
  return "[".join(',',map("\"$_\"",@labels))."]";
}

sub quote {
  my $label = shift;
  return "\"$label\"";
}

__END__

=head1 NAME

mgviewer - display a graph representation of a Meta Grammar

=head1 SYNOPSIS

./mgviewer --uDraw=/home/toto/uDrawGraph-3.1/bin/uDrawGraph sample.smg

Assuming that you have installed uDraw in your home directory (and
that your home directory is /home/toto).

If you have an older version of uDraw named daVinci, the command
should look like

./mgviewer --uDraw=/home/toto/daVinci_V2.1/daVinci sample.smg

=head1 DESCRIPTION

mgviewer takes as input a file containing the Meta Grammar, either in xml, or
in simplified format (smg), and displays it using uDraw.

=head2 MENU

In menu B<Edit>, B<next> and B<prev> allow to navigate within a selection
of nodes.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2003-2007, INRIA.

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

=head1 AUTHOR

Eric de la Clergerie <Eric.De_La_Clergerie@inria.fr>

=cut
