perllib/Graph/AdjacencyMap/Heavy.pm

   1 package Graph::AdjacencyMap::Heavy;
   2
   3 # THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
   4 # THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
   5 # ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
   6
   7 use strict;
   8
   9 # $SIG{__DIE__ } = sub { use Carp; confess };
  10 # $SIG{__WARN__} = sub { use Carp; confess };
  11
  12 use Graph::AdjacencyMap qw(:flags :fields);
  13 use base 'Graph::AdjacencyMap';
  14
  15 require overload; # for de-overloading
  16
  17 require Data::Dumper;
  18
  19 sub __set_path {
  20     my $m = shift;
  21     my $f = $m->[ _f ];
  22     my $id = pop if ($f & _MULTI);
  23     if (@_ != $m->[ _a ] && !($f & _HYPER)) {
  24         require Carp;
  25         Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
  26                       scalar @_, $m->[ _a ]);
  27     }
  28     my $p;
  29     $p = ($f & _HYPER) ?
  30         (( $m->[ _s ] ||= [ ] )->[ @_ ] ||= { }) :
  31         (  $m->[ _s ]                   ||= { });
  32     my @p = $p;
  33     my @k;
  34     while (@_) {
  35         my $k = shift;
  36         my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
  37         if (@_) {
  38             $p = $p->{ $q } ||= {};
  39             return unless $p;
  40             push @p, $p;
  41         }
  42         push @k, $q;
  43     }
  44     return (\@p, \@k);
  45 }
  46
  47 sub __set_path_node {
  48     my ($m, $p, $l) = splice @_, 0, 3;
  49     my $f = $m->[ _f ] ;
  50     my $id = pop if ($f & _MULTI);
  51     unless (exists $p->[-1]->{ $l }) {
  52         my $i = $m->_new_node( \$p->[-1]->{ $l }, $id );
  53         $m->[ _i ]->{ defined $i ? $i : "" } = [ @_ ];
  54         return defined $id ? ($id eq _GEN_ID ? $$id : $id) : $i;
  55     } else {
  56         return $m->_inc_node( \$p->[-1]->{ $l }, $id );
  57     }
  58 }
  59
  60 sub set_path {
  61     my $m = shift;
  62     my $f = $m->[ _f ];
  63     if (@_ > 1 && ($f & _UNORDUNIQ)) {
  64         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
  65         else { $m->__arg(\@_) }
  66     }
  67     my ($p, $k) = $m->__set_path( @_ );
  68     return unless defined $p && defined $k;
  69     my $l = defined $k->[-1] ? $k->[-1] : "";
  70     return $m->__set_path_node( $p, $l, @_ );
  71 }
  72
  73 sub __has_path {
  74     my $m = shift;
  75     my $f = $m->[ _f ];
  76     if (@_ != $m->[ _a ] && !($f & _HYPER)) {
  77         require Carp;
  78         Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
  79                       scalar @_, $m->[ _a ]);
  80     }
  81     if (@_ > 1 && ($f & _UNORDUNIQ)) {
  82         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
  83         else { $m->__arg(\@_) }
  84     }
  85     my $p = $m->[ _s ];
  86     return unless defined $p;
  87     $p = $p->[ @_ ] if ($f & _HYPER);
  88     return unless defined $p;
  89     my @p = $p;
  90     my @k;
  91     while (@_) {
  92         my $k = shift;
  93         my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
  94         if (@_) {
  95             $p = $p->{ $q };
  96             return unless defined $p;
  97             push @p, $p;
  98         }
  99         push @k, $q;
 100     }
 101     return (\@p, \@k);
 102 }
 103
 104 sub has_path {
 105     my $m = shift;
 106     my $f = $m->[ _f ];
 107     if (@_ > 1 && ($f & _UNORDUNIQ)) {
 108         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
 109         else { $m->__arg(\@_) }
 110     }
 111     my ($p, $k) = $m->__has_path( @_ );
 112     return unless defined $p && defined $k;
 113     return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" };
 114 }
 115
 116 sub has_path_by_multi_id {
 117     my $m = shift;
 118     my $f = $m->[ _f ];
 119     my $id = pop;
 120     if (@_ > 1 && ($f & _UNORDUNIQ)) {
 121         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
 122         else { $m->__arg(\@_) }
 123     }
 124     my ($e, $n) = $m->__get_path_node( @_ );
 125     return undef unless $e;
 126     return exists $n->[ _nm ]->{ $id };
 127 }
 128
 129 sub _get_path_node {
 130     my $m = shift;
 131     my $f = $m->[ _f ];
 132     if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
 133         @_ = sort @_ if ($f & _UNORD);
 134         return unless exists $m->[ _s ]->{ $_[0] };
 135         my $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
 136         my $k = [ $_[0], $_[1] ];
 137         my $l = $_[1];
 138         return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l );
 139     } else {
 140         if (@_ > 1 && ($f & _UNORDUNIQ)) {
 141             if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
 142             else { $m->__arg(\@_) }
 143         }
 144         $m->__get_path_node( @_ );
 145     }
 146 }
 147
 148 sub _get_path_id {
 149     my $m = shift;
 150     my $f = $m->[ _f ];
 151     my ($e, $n);
 152     if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
 153         @_ = sort @_ if ($f & _UNORD);
 154         return unless exists $m->[ _s ]->{ $_[0] };
 155         my $p = $m->[ _s ]->{ $_[0] };
 156         $e = exists $p->{ $_[1] };
 157         $n = $p->{ $_[1] };
 158     } else {
 159         ($e, $n) = $m->_get_path_node( @_ );
 160     }
 161     return undef unless $e;
 162     return ref $n ? $n->[ _ni ] : $n;
 163 }
 164
 165 sub _get_path_count {
 166     my $m = shift;
 167     my $f = $m->[ _f ];
 168     my ($e, $n) = $m->_get_path_node( @_ );
 169     return undef unless $e && defined $n;
 170     return
 171         ($f & _COUNT) ? $n->[ _nc ] :
 172         ($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1;
 173 }
 174
 175 sub __attr {
 176     my $m = shift;
 177     if (@_) {
 178         if (ref $_[0] && @{ $_[0] }) {
 179             if (@{ $_[0] } != $m->[ _a ]) {
 180                 require Carp;
 181                 Carp::confess(sprintf
 182                               "Graph::AdjacencyMap::Heavy: arguments %d expected %d\n",
 183                               scalar @{ $_[0] }, $m->[ _a ]);
 184             }
 185             my $f = $m->[ _f ];
 186             if (@{ $_[0] } > 1 && ($f & _UNORDUNIQ)) {
 187                 if (($f & _UNORDUNIQ) == _UNORD && @{ $_[0] } == 2) {
 188                     @{ $_[0] } = sort @{ $_[0] }
 189                 } else { $m->__arg(\@_) }
 190             }
 191         }
 192     }
 193 }
 194
 195 sub _get_id_path {
 196     my ($m, $i) = @_;
 197     my $p = defined $i ? $m->[ _i ]->{ $i } : undef;
 198     return defined $p ? @$p : ( );
 199 }
 200
 201 sub del_path {
 202     my $m = shift;
 203     my $f = $m->[ _f ];
 204     if (@_ > 1 && ($f & _UNORDUNIQ)) {
 205         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
 206         else { $m->__arg(\@_) }
 207     }
 208     my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
 209     return unless $e;
 210     my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0;
 211     if ($c == 0) {
 212         delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n };
 213         delete $p->[-1]->{ $l };
 214         while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
 215             delete $p->[-1]->{ $k->[-1] };
 216             pop @$p;
 217             pop @$k;
 218         }
 219     }
 220     return 1;
 221 }
 222
 223 sub del_path_by_multi_id {
 224     my $m = shift;
 225     my $f = $m->[ _f ];
 226     my $id = pop;
 227     if (@_ > 1 && ($f & _UNORDUNIQ)) {
 228         if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
 229         else { $m->__arg(\@_) }
 230     }
 231     my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
 232     return unless $e;
 233     delete $n->[ _nm ]->{ $id };
 234     unless (keys %{ $n->[ _nm ] }) {
 235         delete $m->[ _i ]->{ $n->[ _ni ] };
 236         delete $p->[-1]->{ $l };
 237         while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
 238             delete $p->[-1]->{ $k->[-1] };
 239             pop @$p;
 240             pop @$k;
 241         }
 242     }
 243     return 1;
 244 }
 245
 246 sub paths {
 247     my $m = shift;
 248     return values %{ $m->[ _i ] } if defined $m->[ _i ];
 249     wantarray ? ( ) : 0;
 250 }
 251
 252 1;
 253 __END__