I need to implement a fast compare according to a fixed partial ordering. I have about 50 objects (imagine vertices on a DAG, ie a directed acyclic graph). If an object A is preferred to B, we write this as A>B (on the graph imagine a directed edge from A to B).

I need to do millions of comparisons, so my plan was to create a hash of hashes, and $pref->{A}{B} is +1, 0, -1, or undef depending on if A>B, A=B, A<B or A and B are not comparable. (Is this a good idea?)

Also, the input describing the (fixed) partial order is in the form of a array of strings, eg: 

('xx < yy < zz > aa', 'bb < yy = aa > cc')

[download]
This is to be interpreted as a sequence of pairwise comparisons, so the above strings give six different paired comparisons as follows: 
xx<yy; yy<zz; zz>aa; bb<yy; yy=aa; aa>cc;

[download]
This information along with other implied information due to reflexivity: we know yy>xx because xx<yy, and transitivity we know xx<yy and yy<zz so we can infer that xx<zz. (On the graph a vertex xx < yy if there is any directed path from yy to xx).

So two things to be done

I have solved the problem, and here is my code, but I find it very ugly. Would love to see something nicer. 

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 contraditor
+y
          unless $pref->{$a}{$b} == $c;         #       so error messa
+ge
        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";
}

[download]

In reply to Partial Order by b4swine

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.