{}
{      Gary R. Waissi, Copyright (C) (1990,1991)           }
{}
{ This Unit contains the Max-Flow algorithm. The Max-Flow  }
{ algorithm is applied to an acyclic network generated by  }
{ any acyclic network generator (like the Dinic Algorithm  }
{ or the new algorithm that this program uses (see Unit    }
{ MxiSUb2) for an implementation of that algorithm.        }

{ NBF 1.102-ALGORITHM for maximal flow                     }
{ For description of the algorithm see the paper:          }
{ An New Max-Flow Algorithm with an Efficient Parallel     }
{ Implementation, presented at the ORSA/TIMS Philadelphia  }
{ October 1990, submitted for publication February 1990.   }
{                                                          }
{ NOTE: This implementation uses only the BACKWARD MAIN    }
{ STEP as a demonstration.                                 }
{ The sequential implementation of the original algorithm  }
{ can be accomplished by modifying this program as         }
{ follows: Replicate the BACKWARD MAIN as a FORWARD MAIN   }
{ and applying these MAIN steps sequentially, first        }
{ applying the FORWARD MAIN and  then the BACKWARD MAIN.   }
{}

UNIT MxiSub1;

INTERFACE

  uses DOS,CRT,MxiSub2,MxiSub3,MxiSub4;
  Procedure MaximalFlow;

IMPLEMENTATION

{ NBF ALGORITHM for maximal flow }

  Procedure MaximalFlow;  
    var MAXI,OK_FIRST:boolean;
        PassReverse,PassForward:boolean;
        Surplus:integer;

    Procedure SwitchTailHead;
      var A:integer;
      begin
        A:=Arc^.TailNode;
        Arc^.TailNode:=Arc^.HeadNode;
        Arc^.HeadNode:=A;
      end;

    Procedure IncludeToDelNodes;
      begin
         Node^.DelNodesSet:=true;
         DelNodes:=DelNodes+1;
      end;

    Procedure IncludeToDnodes;
      begin
        Node^.DnodesSet:=true; Node^.DelNodesSet:=false;
        DNodes:=DNodes+1; DelNodes:=DelNodes-1;
      end;

    Procedure FindNodePotentials;
      begin
        LocateNode(NodeTreeRoot,I);
        if (I=so) then Node^.Rho:=Node^.Beta
        else if (I=T) then Node^.Rho:=Node^.Alpha
        else if (Node^.Alpha<Node^.Beta) then Node^.Rho:=Node^.Alpha
        else Node^.Rho:=Node^.Beta;
        if (Node^.Rho=0) and not Node^.DelNodesSet then 
          IncludeToDelNodes;
      end;

    Procedure Blocking;
      begin
        if not (I=so) and not (I=T) then
        begin
          if (Node^.FlowIn>Node^.FlowOut) then Node^.BlockingStatus:=1
          else if (Node^.FlowIn<Node^.FlowOut) then Node^.BlockingStatus:=2
          else if (Node^.FlowIn=Node^.FlowOut) then Node^.BlockingStatus:=3;
        end;
      end;

    Procedure PruneTheNetwork;
      var SourcePotential,SinkPotential:integer;
      Procedure Prune1;
        begin
          if (Node^.Alpha<=Node^.Beta) and not (Node^.NodeNumber=T)
            then Node^.Rho:=Node^.Alpha
          else if (Node^.NodeNumber=T) then Node^.Rho:=Node^.Alpha;
          if (Node^.Rho=0) and not Node^.DelNodesSet
            and not Node^.DnodesSet then IncludeToDelNodes;
        end;

      Procedure Prune2;
        begin
          if (Node^.Beta<=Node^.Alpha) and not (Node^.NodeNumber=so)
            then Node^.Rho:=Node^.Beta
          else if (Node^.NodeNumber=so) then Node^.Rho:=Node^.Beta;
          if (Node^.Rho=0) and not Node^.DelNodesSet
            and not Node^.DnodesSet then IncludeToDelNodes;
        end;

      Procedure PruneFirst;
        begin
          J:=Arc^.HeadNode;
          LocateNode(NodeTreeRoot,J);
          Node^.Alpha:=Node^.Alpha-Arc^.Kappa;
          Prune1;
          IncludeToDarcs;
          Node^.FlowIn:=Node^.FlowIn-Arc^.ArcFlow;
          LocateNode(NodeTreeRoot,I);
          Node^.Beta:=Node^.Beta-Arc^.Kappa;
          Prune2;
          Node^.FlowOut:=Node^.FlowOut-Arc^.ArcFlow;
        end;

      Procedure PruneSecondly;
        begin
          J:=Arc^.TailNode;
          LocateNode(NodeTreeRoot,J);
          Node^.Beta:=Node^.Beta-Arc^.Kappa;
          Prune2;
          IncludeToDarcs;
          Node^.FlowOut:=Node^.FlowOut-Arc^.ArcFlow;
          LocateNode(NodeTreeRoot,I);
          Node^.Alpha:=Node^.Alpha-Arc^.Kappa;
          Prune1;
          Node^.FlowIn:=Node^.FlowIn-Arc^.ArcFlow;
        end;

      begin  (* PruneTheNetwork *)
        I:=1;
        repeat
          repeat
            LocateNode(NodeTreeRoot,I);
            if (Node^.DelNodesSet) and (Node^.Beta>0) then
            begin
              if not Node^.DnodesSet then IncludeToDnodes;
              for Z:=1 TO jmax DO
              begin
                  LocateArc(ArcTreeRoot,Z);
                  if (Arc^.TailNode=I) then
                    begin
                      LocateNode(NodeTreeRoot,I);
                      if (Arc^.EplusSet or Arc^.EminusSet) and not
                         (Arc^.DarcsSet) then PruneFirst;
                    end
                  else if (Arc^.HeadNode=I) and not (Arc^.DarcsSet) then
                    begin
                      LocateNode(NodeTreeRoot,I);
                      J:=Arc^.TailNode;
                      IncludeToDarcs;
                      Node^.FlowIn:=Node^.FlowIn-Arc^.ArcFlow;
                      LocateNode(NodeTreeRoot,J);
                      Node^.FlowOut:=Node^.FlowOut-Arc^.ArcFlow;
                    end;
                end;
              end
            else if (Node^.DelNodesSet) and (Node^.Alpha>0) then
              begin
                if not Node^.DnodesSet then IncludeToDnodes;
                for Z:=1 TO jmax DO
                begin
                  LocateArc(ArcTreeRoot,Z);
                  if (Arc^.HeadNode=I) then
                    begin
                      LocateNode(NodeTreeRoot,I);
                      if (Arc^.EplusSet or Arc^.EminusSet) and not
                         (Arc^.DarcsSet) then PruneSecondly;
                    end
                  else if (Arc^.TailNode=I) and not (Arc^.DarcsSet) then
                    begin
                      LocateNode(NodeTreeRoot,I);
                      J:=Arc^.HeadNode;
                      IncludeToDarcs;
                      Node^.FlowOut:=Node^.FlowOut-Arc^.ArcFlow;
                      LocateNode(NodeTreeRoot,J);
                      Node^.FlowIn:=Node^.FlowIn-Arc^.ArcFlow;
                    end;
                end;
              end
            else if (Node^.DelNodesSet) then
              begin
                if not Node^.DnodesSet then IncludeToDnodes;
                for Z:=1 TO jmax DO
                begin
                  LocateArc(ArcTreeRoot,Z);
                  if (Arc^.TailNode=I) or (Arc^.HeadNode=I) then
                    if not (Arc^.DarcsSet) then IncludeToDarcs;
                end;
              end;
            LocateNode(NodeTreeRoot,so);
            SourcePotential:=Node^.Rho;
            LocateNode(NodeTreeRoot,T);
            SinkPotential:=Node^.Rho;
            if (SourcePotential=0) or (SinkPotential=0) then MAXI:=true;
            I:=I+1;
          until MAXI or (I=imax+1) or (DelNodes=0);
          if (DelNodes<>0) then I:=1;
        until MAXI or (DelNodes=0);
      end;

    Procedure AssignFlow;
      Procedure AssignFirst;
        Procedure AssignForward;
          begin
            Arc^.Kappa:=Arc^.ArcCapacity-Arc^.ArcFlow;
            Arc^.ArcFlow:=Arc^.Kappa;
            Arc^.ArcCapacity:=Arc^.Kappa;
          end;
        Procedure AssignReverse;
          begin
            Arc^.Kappa:=Arc^.ArcFlow;
            Arc^.ArcFlow:=Arc^.Kappa;
            Arc^.ArcCapacity:=Arc^.Kappa;
            SwitchTailHead;
          end;
        begin
          for J:=1 TO jmax DO
          begin
            LocateArc(ArcTreeRoot,J);
            Arc^.TemporaryFlow:=Arc^.ArcFlow;
            Arc^.TemporaryCapacity:=Arc^.ArcCapacity;
            if (Arc^.EplusSet) then AssignForward
            else if (Arc^.EminusSet) then AssignReverse
            else Arc^.ArcFlow:=0;
          end;
        end;

      Procedure AssignSecondly;
        begin
          for J:=1 TO jmax DO
          begin
            LocateArc(ArcTreeRoot,J);
            I:=Arc^.TailNode;
            LocateNode(NodeTreeRoot,I);
            Node^.FlowOut:=Node^.FlowOut+Arc^.ArcFlow;
            Node^.Beta:=Node^.FlowOut;
            I:=Arc^.HeadNode;
            LocateNode(NodeTreeRoot,I);
            Node^.FlowIn:=Node^.FlowIn+Arc^.ArcFlow;
            Node^.Alpha:=Node^.FlowIn;
          end;
          for I:=1 TO imax DO FindNodePotentials;
        end;

      begin  (* AssignFlow *)
        AssignFirst; AssignSecondly;
        PruneTheNetwork;
        for J:=1 TO jmax DO
          begin
            LocateArc(ArcTreeRoot,J);
            if not Arc^.DarcsSet then Arc^.Kappa:=0
            else if Arc^.DarcsSet then Arc^.ArcFlow:=0;
          end;
        for I:=1 TO imax DO
        begin
          LocateNode(NodeTreeRoot,I);
          Node^.Alpha:=0; Node^.Beta:=0; Node^.Rho:=0;
          if not (Node^.DnodesSet) then Blocking;
        end;
      end;

    Procedure MakeNewAssignment;
      begin
        for J:=1 TO jmax DO
        begin
          LocateArc(ArcTreeRoot,J);
          if not (Arc^.DarcsSet) then
            begin
              if (Arc^.EplusSet) then
                begin
                  Arc^.ArcFlow:=Arc^.TemporaryFlow+Arc^.ArcFlow;
                  Arc^.TemporaryFlow:=Arc^.ArcFlow;
                  Arc^.ArcFlow:=Arc^.Kappa;
                  Arc^.Kappa:=0;
                end
              else if (Arc^.EminusSet) then
                begin
                  Arc^.ArcFlow:=Arc^.TemporaryFlow-Arc^.ArcFlow;
                  Arc^.TemporaryFlow:=Arc^.ArcFlow;
                  Arc^.ArcFlow:=Arc^.Kappa;
                  Arc^.Kappa:=0;
                end
              else
                begin
                  Arc^.TemporaryFlow:=Arc^.ArcFlow;
                  Arc^.ArcFlow:=0;
                  Arc^.Kappa:=0;
                end;
            end;
        end;
        for I:=1 TO imax DO
        begin
          LocateNode(NodeTreeRoot,I);
          if not (Node^.DnodesSet) then
            begin
              Node^.FlowIn:=Node^.Alpha;
              Node^.FlowOut:=Node^.Beta;
              Blocking;
              Node^.Alpha:=0; Node^.Beta:=0; Node^.Rho:=0;
            end;
        end;
      end;

    Procedure ChangeBack;
      begin
        for J:=1 TO jmax DO
        begin
          LocateArc(ArcTreeRoot,J);
          Arc^.ArcCapacity:=Arc^.TemporaryCapacity;
          if (Arc^.EplusSet) then
            Arc^.ArcFlow:=Arc^.TemporaryFlow+Arc^.ArcFlow
          else if (Arc^.EminusSet) then
            begin
              Arc^.ArcFlow:=Arc^.TemporaryFlow-Arc^.ArcFlow;
              SwitchTailHead;
            end
          else Arc^.ArcFlow:=Arc^.TemporaryFlow;
        end;
      end;
   
    Procedure Surp1;
      begin
        Node^.FlowIn:=Node^.FlowIn-Surplus;
        Node^.Alpha:=Node^.Alpha+Surplus;
      end;

    Procedure Surp2;
      begin
        Node^.FlowOut:=Node^.FlowOut-Surplus;
        Node^.Beta:=Node^.Beta+Surplus;
      end;

    Procedure ChangeSurplus1;
      begin
        Surp1;
        LocateNode(NodeTreeRoot,G);
        Surp2;
      end;

    Procedure ChangeSurplus2;
      begin
        Surp2;
        LocateNode(NodeTreeRoot,G);
        Surp1;
      end;

    Procedure ChangeFlow1;
      begin
        Arc^.ArcFlow:=Arc^.ArcFlow-Excess;
        Arc^.Kappa:=Arc^.Kappa+Excess;
        Surplus:=Excess;
        if PassForward then ChangeSurplus1
        else if PassReverse then ChangeSurplus2;
        LocateNode(NodeTreeRoot,G);
        Node^.BlockingStatus:=3;
        LocateNode(NodeTreeRoot,I);
        Blocking;
      end;

    Procedure ChangeFlow2;
      begin
        Arc^.Kappa:=Arc^.Kappa+f1;
        Arc^.ArcFlow:=0;
        Excess:=Excess-f1;
        Surplus:=f1;
        if PassForward then ChangeSurplus1
        else if PassReverse then ChangeSurplus2;
        LocateNode(NodeTreeRoot,I);
        Blocking;
      end;

    Procedure FlowChange;
      begin
        f1:=Arc^.ArcFlow;
        if (f1>=Excess) then ChangeFlow1
        else if (f1<Excess) and (f1>0) then ChangeFlow2;
      end;

    Procedure NoForwardPass;
      begin
        for J:=1 TO jmax DO
        begin
          LocateArc(ArcTreeRoot,J);
          if (Arc^.TailNode=so) and (Arc^.HeadNode=T) then
            Arc^.ArcFlow:=Arc^.ArcCapacity
          else Arc^.ArcFlow:=0;
          OK_FIRST:=true;
        end;
      end;

    Procedure DoBackwardPass;
      var ReduceToBFNodes,ReduceToPFandBALNodes,ReduceFromSource:boolean;
      Procedure BackwardReduce;
        begin
          J:=1;
          begin
            repeat
              LocateArc(ArcTreeRoot,J);
              if not (Arc^.DarcsSet) and (Arc^.HeadNode=G) then
              begin
                I:=Arc^.TailNode;
                LocateNode(NodeTreeRoot,I);
                if not (Node^.DnodesSet) then
                begin
                  if ReduceToBFNodes and not (I=so) and (Node^.BlockingStatus=2)
                    then FlowChange
                  else if ReduceToPFandBALNodes and not (I=so) then FlowChange
                  else if ReduceFromSource and (I=so) then FlowChange;
                end;
              end;
              LocateNode(NodeTreeRoot,G);
              J:=J+1;
            until (J=jmax+1) or (Node^.BlockingStatus=3);
          end;
        end;

      Procedure BackPass;
          Procedure B_pass2;
            begin
              Excess:=Node^.FlowIn-Node^.FlowOut;
              if (Excess>0) then
                begin
                  BackwardReduce;
                  ReduceToBFNodes:=false; ReduceToPFandBALNodes:=true;
                  if not (Node^.BlockingStatus=3) then BackwardReduce;
                  ReduceToPFandBALNodes:=false; ReduceFromSource:=true;
                  if not (Node^.BlockingStatus=3) then BackwardReduce;
                  ReduceToBFNodes:=true; ReduceFromSource:=false;
                end;
              C:=C-1;
            end;


        begin  (*  BackPass  *)
          repeat
            LocateNode(NodeTreeRoot,G);
            if (Node^.BlockingStatus=3) or
               (Node^.BlockingStatus=2) or
               (Node^.BlockingStatus=0) then C:=C-1
            else B_pass2;
            G:=Level[C];
          until (C=0);
        end;

      begin  (* DoBackwardPass *)
        PassReverse:=true;
        ReduceToBFNodes:=true;
        ReduceToPFandBALNodes:=false;
        ReduceFromSource:=false;
        C:=cmax-1;
        G:=Level[C];
        if (cmax=1) then NoForwardPass
        else BackPass;
        PassReverse:=false;
      end;   (* DoBackwardPass *)

    Procedure DoForwardPass;
      var ReduceToBFandBALNodes, ReduceToSink:boolean;
      Procedure ForwardReduce;
        begin
          J:=1;
          begin
            repeat
              LocateArc(ArcTreeRoot,J);
              if not (Arc^.DarcsSet) and (Arc^.TailNode=G) then
                begin
                  I:=Arc^.HeadNode;
                  LocateNode(NodeTreeRoot,I);
                  if not (Node^.DnodesSet) then
                  begin
                    if ReduceToBFandBALNodes and not (I=T) then FlowChange
                    else if ReduceToSink and (I=T) then FlowChange;
                  end;
                end;
              LocateNode(NodeTreeRoot,G);
              J:=J+1;
            until (J=jmax+1) or (Node^.BlockingStatus=3);
          end;
          ReduceToBFandBALNodes:=false; ReduceToSink:=true;
        end;

      Procedure ForPass;
      begin
        repeat
          begin 
            LocateNode(NodeTreeRoot,G);
            if (Node^.BlockingStatus=3) or
               (Node^.BlockingStatus=1) or
               (Node^.BlockingStatus=0) then C:=C+1
            else
            begin
              Excess:=Node^.FlowOut-Node^.FlowIn;
              if (Excess>0) then
              begin
                ForwardReduce;
                if not (Node^.BlockingStatus=3) then ForwardReduce;
                ReduceToBFandBALNodes:=true; ReduceToSink:=false;
              end;
            end;
          end;
          G:=Level[C];
        until (C=cmax);
      end;

      begin  (* forward pass *)
        PassForward:=true;
        ReduceToBFandBALNodes:=true; ReduceToSink:=false;
        C:=1;
        G:=Level[C];
        ForPass;
        PassForward:=false;
      end;   (* forward pass *)

    begin    (* NBF Algorithm for MaximalFlow *)
      PassReverse:=false; PassForward:=false; MAXI:=false; OK_FIRST:=false;
      nr:=0;
      AssignFlow;
      if not MAXI then
        begin
          repeat
            DoBackwardPass;
            if not OK_FIRST or MAXI then DoForwardPass
            else if OK_FIRST then MAXI:=true;
            nr:=nr+1;
            for I:=1 TO imax DO
            begin
              LocateNode(NodeTreeRoot,I);
              if not (Node^.DnodesSet) then FindNodePotentials;
            end;
            PruneTheNetwork;
            if not MAXI then MakeNewAssignment;
          until MAXI;
        end;
      ChangeBack;
    end;

  end.