       1 package Graph::Path;
       2 #
       3 # $RCSfile: Path.pm,v $
       4 # $Date: 2015/02/28 20:49:06 $
       5 # $Revision: 1.25 $
       6 #
       7 # Author: Manish Sud <msud@san.rr.com>
       8 #
       9 # Copyright (C) 2015 Manish Sud. All rights reserved.
      10 #
      11 # This file is part of MayaChemTools.
      12 #
      13 # MayaChemTools is free software; you can redistribute it and/or modify it under
      14 # the terms of the GNU Lesser General Public License as published by the Free
      15 # Software Foundation; either version 3 of the License, or (at your option) any
      16 # later version.
      17 #
      18 # MayaChemTools is distributed in the hope that it will be useful, but without
      19 # any warranty; without even the implied warranty of merchantability of fitness
      20 # for a particular purpose.  See the GNU Lesser General Public License for more
      21 # details.
      22 #
      23 # You should have received a copy of the GNU Lesser General Public License
      24 # along with MayaChemTools; if not, see <http://www.gnu.org/licenses/> or
      25 # write to the Free Software Foundation Inc., 59 Temple Place, Suite 330,
      26 # Boston, MA, 02111-1307, USA.
      27 #
      28
      29 use strict;
      30 use Carp;
      31 use Exporter;
      32 use Storable ();
      33 use Scalar::Util ();
      34
      35 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
      36
      37 @ISA = qw(Exporter);
      38 @EXPORT = qw();
      39 @EXPORT_OK = qw();
      40
      41 %EXPORT_TAGS = (all  => [@EXPORT, @EXPORT_OK]);
      42
      43 # Setup class variables...
      44 my($ClassName, $ObjectID);
      45 _InitializeClass();
      46
      47 # Overload Perl functions...
      48 use overload '""' => 'StringifyPath',
      49
      50   '==' => '_PathEqualOperator',
      51   'eq' => '_PathEqualOperator',
      52
      53   'fallback' => undef;
      54
      55 # Class constructor...
      56 sub new {
      57   my($Class, @VertexIDs) = @_;
      58
      59   # Initialize object...
      60   my $This = {};
      61   bless $This, ref($Class) || $Class;
      62   $This->_InitializePath();
      63
      64   if (@VertexIDs) { $This->AddVertices(@VertexIDs); }
      65
      66   return $This;
      67 }
      68
      69 # Initialize object data...
      70 #
      71 sub _InitializePath {
      72   my($This) = @_;
      73
      74   @{$This->{Vertices}} = ();
      75 }
      76
      77 # Initialize class ...
      78 sub _InitializeClass {
      79   #Class name...
      80   $ClassName = __PACKAGE__;
      81 }
      82
      83 # Add a vertex to path after the end vertex...
      84 #
      85 sub AddVertex {
      86   my($This, $VertexID) = @_;
      87
      88   if (!defined $VertexID ) {
      89     carp "Warning: ${ClassName}->AddVertex: No vertex added: Vertex ID must be specified...";
      90     return undef;
      91   }
      92   push @{$This->{Vertices}}, $VertexID;
      93
      94   return $This;
      95 }
      96
      97 # Add vertices to the path after the end vertex...
      98 #
      99 sub AddVertices {
     100   my($This, @VertexIDs) = @_;
     101
     102   if (!@VertexIDs) {
     103     carp "Warning: ${ClassName}->AddVertices: No vertices added: Vertices list is empty...";
     104     return undef;
     105   }
     106   push @{$This->{Vertices}}, @VertexIDs;
     107
     108   return $This;
     109 }
     110
     111 # Add a vertex to path after the end vertex...
     112 #
     113 sub PushVertex {
     114   my($This, $VertexID) = @_;
     115
     116   return $This->AddVertex($VertexID);
     117 }
     118
     119 # Add vertices to the path after the end vertex...
     120 #
     121 sub PushVertices {
     122   my($This, @VertexIDs) = @_;
     123
     124   return $This->AddVertices(@VertexIDs);
     125 }
     126
     127 # Remove end vertex from path...
     128 #
     129 sub PopVertex {
     130   my($This) = @_;
     131
     132   if (!@{$This->{Vertices}}) {
     133     carp "Warning: ${ClassName}->PopVertex: No vertex removed: Path is empty...";
     134     return undef;
     135   }
     136   pop @{$This->{Vertices}};
     137
     138   return $This;
     139 }
     140
     141 # Remove start vertex from path...
     142 #
     143 sub ShiftVertex {
     144   my($This) = @_;
     145
     146   if (!@{$This->{Vertices}}) {
     147     carp "Warning: ${ClassName}->ShiftVertex: No vertex removed: Path is empty...";
     148     return undef;
     149   }
     150   shift @{$This->{Vertices}};
     151
     152   return $This;
     153 }
     154
     155 # Add a vertex to path before the start vertex...
     156 #
     157 sub UnshiftVertex {
     158   my($This, $VertexID) = @_;
     159
     160   if (!defined $VertexID ) {
     161     carp "Warning: ${ClassName}->UnshiftVertex: No vertex added: Vertex ID must be specified...";
     162     return undef;
     163   }
     164   unshift @{$This->{Vertices}}, $VertexID;
     165
     166   return $This;
     167 }
     168
     169 # Add vertices to the path before the start vertex...
     170 #
     171 sub UnshiftVertices {
     172   my($This, @VertexIDs) = @_;
     173
     174   if (!@VertexIDs) {
     175     carp "Warning: ${ClassName}->UnshiftVertices: No vertices added: Vertices list is empty...";
     176     return undef;
     177   }
     178   unshift @{$This->{Vertices}}, @VertexIDs;
     179
     180   return $This;
     181 }
     182
     183 # Get length...
     184 #
     185 sub GetLength {
     186   my($This) = @_;
     187
     188   return scalar @{$This->{Vertices}};
     189 }
     190
     191 # Get start vertex...
     192 #
     193 sub GetStartVertex {
     194   my($This) = @_;
     195
     196   if (!$This->GetLength()) {
     197     return undef;
     198   }
     199   my($Index) = 0;
     200   return $This->_GetVertex($Index);
     201 }
     202
     203 # Get end vertex...
     204 #
     205 sub GetEndVertex {
     206   my($This) = @_;
     207
     208   if (!$This->GetLength()) {
     209     return undef;
     210   }
     211   my($Index);
     212
     213   $Index = $This->GetLength() - 1;
     214   return $This->_GetVertex($Index);
     215 }
     216
     217 # Get start and end vertices...
     218 #
     219 sub GetTerminalVertices {
     220   my($This) = @_;
     221
     222   return ( $This->GetStartVertex(), $This->GetEndVertex() ),
     223 }
     224
     225 # Get path vertices...
     226 #
     227 sub GetVertices {
     228   my($This) = @_;
     229
     230   return wantarray ? @{$This->{Vertices}} : scalar @{$This->{Vertices}};
     231 }
     232
     233 # Get a specific vertex from path with indicies starting from 0...
     234 #
     235 sub GetVertex {
     236   my($This, $Index) = @_;
     237
     238   if ($Index < 0) {
     239     croak "Error: ${ClassName}->GetValue: Index value must be a positive number...";
     240   }
     241   if ($Index >= $This->GetLength()) {
     242     croak "Error: ${ClassName}->GetValue: Index vaue must be less than length of path...";
     243   }
     244   if (!$This->GetLength()) {
     245     return undef;
     246   }
     247   return $This->_GetVertex($Index);
     248 }
     249
     250 # Get a vertex...
     251 #
     252 sub _GetVertex {
     253   my($This, $Index) = @_;
     254
     255   return $This->{Vertices}[$Index];
     256 }
     257
     258 # Get path edges as pair of vertices or number of edges...
     259 #
     260 sub GetEdges {
     261   my($This) = @_;
     262
     263   if ($This->GetLength < 1) {
     264     return undef;
     265   }
     266   # Set up edges...
     267   my($Index, $VertexID1, $VertexID2, @Vertices, @Edges);
     268
     269   @Edges = ();
     270   for $Index (0 .. ($#{$This->{Vertices}} - 1) ) {
     271     $VertexID1 = $This->{Vertices}[$Index];
     272     $VertexID2 = $This->{Vertices}[$Index + 1];
     273     push @Edges, ($VertexID1, $VertexID2);
     274   }
     275
     276   return wantarray ? @Edges : ((scalar @Edges)/2);
     277 }
     278
     279 # Is it a cycle?
     280 #
     281 sub IsCycle {
     282   my($This) = @_;
     283   my($StartVertex, $EndVertex);
     284
     285   ($StartVertex, $EndVertex) = $This->GetTerminalVertices();
     286
     287   return ($StartVertex == $EndVertex) ? 1 : 0;
     288 }
     289
     290 # For a path to be an independent path, it must meet the following conditions:
     291 #   . All other vertices are unique.
     292 #
     293 sub IsIndependentPath {
     294   my($This) = @_;
     295
     296   # Make sure it has at least two vertices...
     297   if ($This->GetLength() < 2) {
     298     return 0;
     299   }
     300
     301   # Check frequency of occurence for non-terminal vertices...
     302   my($VertexID, $IndependenceStatus, @Vertices, %VerticesMap);
     303
     304   @Vertices = $This->GetVertices();
     305   shift @Vertices; pop @Vertices;
     306
     307   %VerticesMap = ();
     308   $IndependenceStatus = 1;
     309
     310   VERTEXID: for $VertexID (@Vertices) {
     311     if (exists $VerticesMap{$VertexID} ) {
     312       $IndependenceStatus = 0;
     313       last VERTEXID;
     314     }
     315     $VerticesMap{$VertexID} = $VertexID;
     316   }
     317   return $IndependenceStatus;
     318 }
     319
     320 # For a path to be an independent cyclic path, it must meet the following conditions:
     321 #   . Termimal vertices are the same
     322 #   . All other vertices are unique.
     323 #
     324 sub IsIndependentCyclicPath {
     325   my($This) = @_;
     326
     327   # Make sure it's a cycle...
     328   if (!($This->GetLength() >= 3 && $This->IsCycle())) {
     329     return 0;
     330   }
     331   return $This->IsIndependentPath();
     332 }
     333
     334 # Is it a path object?
     335 sub IsPath ($) {
     336   my($Object) = @_;
     337
     338   return _IsPath($Object);
     339 }
     340
     341 # Copy path...
     342 #
     343 sub Copy {
     344   my($This) = @_;
     345   my($NewPath);
     346
     347   $NewPath = Storable::dclone($This);
     348
     349   return $NewPath;
     350 }
     351
     352 # Reverse order of vertices in path...
     353 #
     354 sub Reverse {
     355   my($This) = @_;
     356   my(@VertexIDs);
     357
     358   @VertexIDs = (); push @VertexIDs, @{$This->{Vertices}};
     359
     360   @{$This->{Vertices}} = (); push @{$This->{Vertices}}, reverse @VertexIDs;
     361
     362   return $This;
     363 }
     364
     365 # Get vertices common between two paths...
     366 #
     367 sub GetCommonVertices {
     368   my($This, $Other) = @_;
     369   my($VertexID, @CommonVertices, %OtherVerticesMap);
     370
     371   # Setup a vertices hash for a quick look up...
     372   %OtherVerticesMap = ();
     373   for $VertexID ($Other->GetVertices()) {
     374     $OtherVerticesMap{$VertexID} = $VertexID;
     375   }
     376
     377   @CommonVertices = ();
     378   for $VertexID ($This->GetVertices()) {
     379     if ($OtherVerticesMap{$VertexID}) {
     380       push @CommonVertices, $VertexID
     381     }
     382   }
     383   return wantarray ? @CommonVertices : scalar @CommonVertices;
     384 }
     385
     386 # Join the existing path with a new path specifed using a path object of a list of
     387 # verticies.
     388 #
     389 sub Join {
     390   my($This, @Values) = @_;
     391
     392   return $This->_Join(@Values);
     393 }
     394
     395 # Join the existing path with a new path specifed using a path object at a specified
     396 # vertex.
     397 #
     398 sub JoinAtVertex {
     399   my($This, $Other, $CenterVertexID) = @_;
     400
     401   # Make sure CenterVertexID is end vertex in This and start vertex in Other before
     402   # joining them...
     403   if ($This->GetEndVertex() != $CenterVertexID) {
     404     $This->Reverse();
     405   }
     406   if ($Other->GetStartVertex() != $CenterVertexID) {
     407     $Other->Reverse();
     408   }
     409   return $This->_Join($Other);
     410 }
     411
     412 # Join the existing path with a new path specifed using a path object of a list of
     413 # verticies.
     414 #
     415 # Notes:
     416 #  . Paths must have a common terminal vertex.
     417 #  . Based on the common terminal vertex found, new path vertices are added to the
     418 #    current path in one of the four ways:
     419 #    . New path at end of current path with same vertices order : EndVertex = NewStartVertex
     420 #    . New path at end of current path with reversed vertices order: EndVertex = NewEndVertex
     421 #    . New path at front of current path with same vertices order: StartVertex = NewEndVertex
     422 #    . New path at front of current path with reversed vertices order: StartVertex = NewStartVertex
     423 #
     424 sub _Join {
     425   my($This, @Values) = @_;
     426
     427   if (!@Values) {
     428     return;
     429   }
     430
     431   # Get a list of new vertex IDs..
     432   my($NewPath, $FirstValue, $TypeOfFirstValue, @NewVertexIDs);
     433
     434   $NewPath = $This->Copy();
     435
     436   @NewVertexIDs = ();
     437   $FirstValue = $Values[0];
     438   $TypeOfFirstValue = ref $FirstValue;
     439   if ($TypeOfFirstValue =~ /^(SCALAR|HASH|CODE|REF|GLOB)/) {
     440     croak "Error: ${ClassName}->JoinPath: Trying to add vertices to path object with a reference to unsupported value format...";
     441   }
     442
     443   if (_IsPath($FirstValue)) {
     444     # It's another path object...
     445     push @NewVertexIDs,  @{$FirstValue->{Vertices}};
     446   }
     447   elsif ($TypeOfFirstValue =~ /^ARRAY/) {
     448     # It's array reference...
     449     push @NewVertexIDs,  @{$FirstValue};
     450   }
     451   else {
     452     # It's a list of values...
     453     push @NewVertexIDs,  @Values;
     454   }
     455   my($StartVertex, $EndVertex, $NewStartVertex, $NewEndVertex);
     456
     457   ($StartVertex, $EndVertex) = $NewPath->GetTerminalVertices();
     458   ($NewStartVertex, $NewEndVertex) = ($NewVertexIDs[0], $NewVertexIDs[$#NewVertexIDs]);
     459
     460   if (!($EndVertex == $NewStartVertex || $EndVertex == $NewEndVertex || $StartVertex == $NewEndVertex || $StartVertex == $NewStartVertex)) {
     461     carp "Warning: ${ClassName}->JoinPath: Paths can't be joined: No common terminal vertex found...";
     462     return undef;
     463   }
     464
     465   if ($EndVertex == $NewStartVertex) {
     466     # Take out EndVertex and add new path at the end...
     467     pop @{$NewPath->{Vertices}};
     468     push @{$NewPath->{Vertices}}, @NewVertexIDs;
     469   }
     470   elsif ($EndVertex == $NewEndVertex) {
     471     # Take out EndVertex and add new path at the end with reversed vertex order...
     472     pop @{$NewPath->{Vertices}};
     473     push @{$NewPath->{Vertices}}, reverse @NewVertexIDs;
     474   }
     475   elsif ($StartVertex == $NewEndVertex) {
     476     # Take out NewEndVertex and add new path at the front...
     477     pop @NewVertexIDs;
     478     unshift @{$NewPath->{Vertices}}, @NewVertexIDs;
     479   }
     480   elsif ($StartVertex == $NewStartVertex) {
     481     # Take out NewStartVertex and add new path at the front...
     482     shift @NewVertexIDs;
     483     unshift @{$NewPath->{Vertices}}, reverse @NewVertexIDs;
     484   }
     485
     486   return $NewPath,
     487 }
     488
     489 # Compare two paths...
     490 #
     491 sub _PathEqualOperator {
     492   my($This, $Other) = @_;
     493
     494   if (!(defined($This) && _IsPath($This) && defined($Other) && _IsPath($Other))) {
     495     croak "Error: ${ClassName}->_PathEqualOperator: Path equal comparison failed: Both object must be paths...";
     496   }
     497
     498   if ($This->GetLength() != $Other->GetLength()) {
     499     return 0;
     500   }
     501   my($ThisID, $OtherID, $ReverseOtherID);
     502
     503   $ThisID = join('-', @{$This->{Vertices}});
     504   $OtherID = join('-', @{$Other->{Vertices}});
     505   $ReverseOtherID = join('-', reverse(@{$Other->{Vertices}}));
     506
     507   return ($ThisID =~ /^($OtherID|$ReverseOtherID)$/) ? 1 : 0;
     508 }
     509
     510 # Return a string containing vertices in the path...
     511 sub StringifyPath {
     512   my($This) = @_;
     513   my($PathString);
     514
     515   $PathString = "Path: " . join('-', @{$This->{Vertices}});
     516
     517   return $PathString;
     518 }
     519
     520 # Is it a path object?
     521 sub _IsPath {
     522   my($Object) = @_;
     523
     524   return (Scalar::Util::blessed($Object) && $Object->isa($ClassName)) ? 1 : 0;
     525 }
     526