use strict;
use warnings;
my $pref = {};
#
# Argument is a list of comparison chain strings
#
my $err;
sub PartialOrder
{ #
  # preference: a>b means prefer(a,b)
  #
  sub markpref
  { my ($a, $c, $b) = @_;
    $err='';
    if (exists $pref->{$a})                     # we knew about a
    { if (exists $pref->{$a}{$b})               #   and b
      { return $err = "ERROR contradictory $a $b"#     but contraditory
          unless $pref->{$a}{$b} == $c;         #       so error message
        return 1;                               #     else nothing to do
      }                                         #   but not about b
      $pref->{$a}{$b} = $c;                     #     so add info
    }
    else                                        # nothing known about a
    { $pref->{$a} = {$b => $c, $a => 0};        #   so set info
    }
    return 0;
  }
  
  sub prefer
  { my ($a, $c, $b) = @_;
    $err = '';
    if ($c == 1)
    { return $err="ERROR: $a>$a" if $a eq $b;   # error
      return $err if markpref @_;
      return $err if markpref $b, -1, $a;
      #
      # Now add all the extended relations
      #
      while (my ($x, $v) = each %{$pref->{$b}})
      { if ($v>=0 and $x ne $b) { return $err if prefer($a, 1, $x) }
      }
      
      while (my ($x, $v) = each %{$pref->{$a}})
      { if ($v<=0 and $x ne $a) { return $err if prefer($x, 1, $b) }
      }
    }
    else        # $c == 0
    { if ($a eq $b) { return 0;  }
      return $err if markpref @_;
      return $err if markpref $b, 0, $a;
      while (my ($x, $v) = each %{$pref->{$b}})
      { if ($v>0)       { return $err if prefer($a, 1, $x) }
        elsif ($v<0)    { return $err if prefer($x, 1, $a) }
        else            { return $err if prefer($x, 0, $a) }
      }
      while (my ($x, $v) = each %{$pref->{$a}})
      { if ($v>0)       { return $err if prefer($b, 1, $x) }
        elsif ($v<0)    { return $err if prefer($x, 1, $b) }
        else            { return $err if prefer($x, 0, $b) }
      }
    }
    return 0;
  }
  # Compute all neighbor relationships
  #
  for (@_)
  { my $chain = $_;
    $chain =~ s/ //g;
    my @seq = split /([>=<])/, $chain;
    my $x = shift @seq;
    while (my $c = shift @seq)
    { my $z = shift @seq;
      if ($c eq '>')    { return $err if prefer($x, 1, $z); }
      elsif ($c eq '=') { return $err if prefer($x, 0, $z); }
      elsif ($c eq '<') { return $err if prefer($z, 1, $x); }
      else { return "Error in preferences\n" }
      $x = $z;
  } }
}
##########################################################
#
# A Example
#
die if PartialOrder('xx < yy < zz > aa', 'bb < yy = aa > cc');

sub compare
{ my ($x, $y) = @_;
  return $pref->{$x}{$y} if exists $pref->{$x}{$y};
  return undef;
}


print "Comparison Table:\n   aa bb cc xx yy zz\n";
for my $a (qw(aa bb cc xx yy zz))
{ print "$a ";
  for my $b(qw(aa bb cc xx yy zz))
  { my $c = compare $a, $b;
    $c =  qw(- = + .)[defined $c ? 1+$c : 3];
    print " $c ";
  }
  print "\n";
}