('xx < yy < zz > aa', 'bb < yy = aa > cc')
####
xxaa; bbcc;
####
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";
}