hamilton.pas

图论算法

        repeat
          checkVertex := Tvertex(NotconnectiveVertexs[i]);
          isExist := false;
          for j := 0 to connectiveVertexs.count - 1 do
            begin
              if isConnective(Tvertex(connectiveVertexs[j]),checkVertex)  then
                begin
                  isExist := true;
                  connectiveVertexs.add(checkVertex);
                  NotconnectiveVertexs[i] := nil;
                  break;
                end;
            end;
          inc(i);
        until i >= NotconnectiveVertexs.count;
        NotconnectiveVertexs.pack;
      until (connectiveVertexNum = connectiveVertexs.count)
            or (NotconnectiveVertexs.count = 0 );
     end;
   if NotconnectiveVertexs.count >= 1 then
      begin
        if (NotconnectiveVertexs.count = 1)
           or SubgraphConnexion(NotconnectiveVertexs) then
           begin
             result := 2;
             vertexlist1 := connectiveVertexs;
             vertexlist2 := NotconnectiveVertexs;
             exit;
           end
        else result := 3;
      end;
  end;

  connectiveVertexs.free;
  NotconnectiveVertexs.free;
end;

function MergesubHamiltonCircuit(circuit1, circuit2:Tlist;vertex1,virtualvertexA,virtualvertexB:Tvertex):Tlist;
var newCircuit:Tlist;
    theindex:integer;
    Vertex1pos1,Vertex2pos1:integer;//vertex1,vertex2
    Vertex1pos2,Vertex2pos2:integer;//vertex1,vertex2
    virtualvertexpos1,virtualvertexpos2:integer;
    i,j:integer;
    m,mstep:integer;
begin
  result := nil;
  Vertex1pos1 := circuit1.indexof(Vertex1);
  virtualvertexpos1 := circuit1.indexof(virtualvertexA);

  Vertex1pos2 := circuit2.indexof(Vertex1);
  virtualvertexpos2 := circuit2.indexof(virtualvertexB);

  newCircuit := Tlist.create;

  m := Vertex1pos1;
  If (Vertex1pos1 - virtualvertexpos1 = 1) Or
     (virtualvertexpos1 - Vertex1pos1 = circuit1.Count - 1)
  Then mstep := 1 Else mstep := -1;
  For i := 1 To circuit1.Count-1 do
    begin
      newCircuit.Add(circuit1[m]);
      m := m + mstep;
      If (m > circuit1.Count-1) And (mstep = 1) Then m := 0;
      If (m < 0) And (mstep = -1) Then m := circuit1.Count - 1;
    end;
  m := virtualvertexpos2;
  If (virtualvertexpos2 - Vertex1pos2 = 1) Or
     (Vertex1pos2 - virtualvertexpos2 = circuit2.Count - 1)
  Then mstep := 1 Else mstep := -1;
  m := m + mstep;
  If (m > circuit2.Count-1) And (mstep=1) Then m := 0;
  If (m < 0) And (mstep= -1) Then m := circuit2.Count -1 ;
  For i := 1 To circuit2.Count - 3 do
    begin
      m := m + mstep;
      If (m > circuit2.Count-1) And (mstep=1) Then m := 0;
      If (m < 0) And (mstep= -1) Then m := circuit2.Count -1 ;
      newCircuit.Add(circuit2[m]);
    end;
  result := newCircuit;
end;

function checkisolateVertex21(theVertexlist:Tlist;deleteVertex1,deleteVertex2:Tvertex):boolean;
var isolatenum:integer;
    isolateVertex:array[1..2] of Tvertex;
    i,j :integer;
    isconnective:boolean;
    isolateVertexRoot:Tvertex;
    conflictnum:integer;
    function realdegree(theVertex:Tvertex):integer;
    var i:integer;
    begin
      result := theVertex.Neighbourcount;
      with theVertex do
        begin
          for i := 1 to Neighbourcount do
            if not NE[i].considervisible then
               result := result - 1
            else if isDelete and (thevertexlist.indexof(NV[i])= -1) then
               result := result - 1;
        end;
    end;
begin
  result := true;
  isolatenum := 0;
  for i := 0 to theVertexlist.count - 1 do
    begin
      if realdegree(Tvertex(theVertexlist[i])) = 1 then
         begin
           inc(isolatenum);
           if isolatenum < 3 then isolateVertex[isolatenum] := Tvertex(theVertexlist[i]);
         end;
    end;
  if isolatenum >= 3 then result := false
  else
    begin
      if isolatenum = 2 then
         begin
           isconnective := false;
           for i:= 1 to 2 do
             if deleteVertex1.isConsiderVisibleNV(isolateVertex[i]) then
                isconnective :=true;
           if not isconnective then
              begin
                result := false;
                exit;
              end;
           isconnective := false;
           for i:= 1 to 2 do
             if deleteVertex2.isConsiderVisibleNV(isolateVertex[i]) then
                isconnective :=true;
           if not isconnective then
              begin
                result := false;
                exit;
              end;
         end;
      for j := 1 to isolatenum do
        begin
          with isolateVertex[j] do
          for i := 1 to Neighbourcount do
            if (NV[i] <> deleteVertex1) and (NV[i] <> deleteVertex2) then
               isolateVertexRoot := NV[i];
          conflictnum := 0;
          with isolateVertexRoot do
          for i := 1 to Neighbourcount do
            if (NV[i] <> isolateVertex[j]) and
               (NV[i] <> deleteVertex1) and (NV[i] <> deleteVertex2) then
               begin
                 if realdegree(NV[i]) <= 2 then
                    conflictnum := conflictnum + 1;
               end;
          if conflictnum >= 2 then
             begin
               result := false;
               break;
             end;
        end;
    end;
end;

function splitandfind(theVertexlist:Tlist):Tlist;
var i,j,k:integer;
    vertex1,vertex2:Tvertex;
    deletevertexlist:Tlist;
    vertexlistA,vertexlistB:Tlist;
    beSplited:boolean;
    VirtualVertexA,VirtualVertexB:TVertex;
    VirtualEdge1A,VirtualEdge2A,VirtualEdge1B,VirtualEdge2B :Tedge;
    subHamiltonCircuitA,subHamiltonCircuitB:Tlist;
    subHamiltonCircuit :Tlist;
    maxcircuit:Tlist;
    publicEdge:Tedge;
    splitnum:integer;
    procedure finalfree;
    var i :integer;
      begin
        for i:= 0 to Circuits.count -1 do
          Tlist(Circuits[i]).free;
        Circuits.clear;
        deletevertexlist.free;
      end;
    function haveDelete(deletevertex1,deletevertex2:Tvertex):boolean;
    var i:integer;
    begin
      result := false;
      for i := 0 to theVertexlist.count - 1 do
        begin
          if Tvertex(theVertexlist[i]).isvirtual then
             begin
               if (Tvertex(theVertexlist[i]).NeighbourVertex.indexof(deletevertex1) > -1)
                 and (Tvertex(theVertexlist[i]).NeighbourVertex.indexof(deletevertex2) > -1) then
                 begin
                   result := true;
                   break;
                 end;
             end;
        end;
    end;
    function realdegree(theVertex:Tvertex):integer;
    var i:integer;
    begin
      result := theVertex.Neighbourcount;
      if result > 2 then
        with theVertex do
          begin
            for i := 1 to Neighbourcount do
              if not NE[i].considervisible then
                 result := result - 1
              else if isDelete and (thevertexlist.indexof(NV[i])= -1) then
                 result := result - 1;
          end;
    end;
begin
  deletevertexlist := Tlist.create;
  beSplited := false;
  for i := 0 to theVertexlist.count - 2 do
    begin
      //except
      application.processmessages;
      if not isruning then break;

      vertex1 := Tvertex(theVertexlist[i]);
      if vertex1.isVirtual then continue;
      if realdegree(vertex1) = 2 then continue;
      for j := i + 1 to theVertexlist.count - 1 do
        begin
          vertex2 := Tvertex(theVertexlist[j]);
          if vertex2.isVirtual then continue;
          if realdegree(vertex2) = 2 then continue;
          for k := 0 to theVertexlist.count - 1 do
            if (theVertexlist[k] <> vertex1) and (theVertexlist[k] <> vertex2) then
              deletevertexlist.add(theVertexlist[k]);
          splitnum := getsubgraph(deletevertexlist,vertexlistA,vertexlistB);
          if splitnum = 2 then
             begin
               if haveDelete(vertex1,vertex2) then
                  begin
                    vertexlistA.free;
                    vertexlistB.free;
                    continue;
                  end;
               beSplited := true;
               publicEdge := vertex1.getConsiderVisibleNE(vertex2);
               if publicEdge <> nil then publicEdge.ConsiderVisible := false;
               break;
             end
          else if splitnum = 3 then
             begin
               beSplited := true;
               break;
             end;
          deletevertexlist.clear;
        end;
      if beSplited then break;
    end;

  if beSplited then
    begin
      if splitnum = 3 then
         begin
           result := nil;
           finalfree;
           exit;
         end;
      if not checkisolateVertex21(vertexlistA,vertex1,vertex2) then
         begin
           vertexlistA.free;
           vertexlistB.free;
           result := nil;
           finalfree;
           exit;
         end
      else if not checkisolateVertex21(vertexlistB,vertex1,vertex2) then
         begin
           vertexlistA.free;
           vertexlistB.free;
           result := nil;
           finalfree;
           exit;
         end;

      vertex1.isDelete := True;
      vertex2.isDelete := True;
      vertexlistA.add(vertex1);
      vertexlistA.add(vertex2);
      VirtualVertexA := Tvertex.create(nil,0,0,-1);
      vertexlistA.add(VirtualVertexA);
      VirtualEdge1A := Tedge.create(nil,vertex1,VirtualVertexA);
      VirtualEdge2A := Tedge.create(nil,vertex2,VirtualVertexA);
      edgelist.add(VirtualEdge1A);
      edgelist.add(VirtualEdge2A);

      vertexlistB.add(vertex1);
      vertexlistB.add(vertex2);
      VirtualVertexB := Tvertex.create(nil,0,0,-1);
      vertexlistB.add(VirtualVertexB);
      VirtualEdge1B := Tedge.create(nil,vertex1,VirtualVertexB);
      VirtualEdge2B := Tedge.create(nil,vertex2,VirtualVertexB);
      edgelist.add(VirtualEdge1B);
      edgelist.add(VirtualEdge2B);

      subHamiltonCircuitA := splitandfind(vertexlistA);
      if subHamiltonCircuitA = nil then
         result := nil
      else
       begin
        subHamiltonCircuitB := splitandfind(vertexlistB);
        if subHamiltonCircuitB = nil then
         begin
           subHamiltonCircuitA.free;
           result := nil;
         end
        else
         begin //merge subHamiltonCircuitA with subHamiltonCircuitB
           subHamiltonCircuit := MergesubHamiltonCircuit(subHamiltonCircuitA,subHamiltonCircuitB,vertex1,VirtualVertexA,VirtualVertexB);
           subHamiltonCircuitA.free;
           subHamiltonCircuitB.free;
           result := subHamiltonCircuit;
         end;
       end;
      vertex1.removeNeighbourVertex(VirtualVertexA);
      vertex1.removeNeighbourVertex(VirtualVertexB);
      vertex2.removeNeighbourVertex(VirtualVertexA);
      vertex2.removeNeighbourVertex(VirtualVertexB);
      VirtualVertexA.free;
      VirtualVertexB.free;
      edgelist.remove(VirtualEdge1A);
      edgelist.remove(VirtualEdge2A);
      edgelist.remove(VirtualEdge1B);
      edgelist.remove(VirtualEdge2B);
      VirtualEdge1A.free;
      VirtualEdge2A.free;
      VirtualEdge1B.free;
      VirtualEdge2B.free;

      vertexlistA.free;
      vertexlistB.free;
    end
  else
    begin
      for i:= 0 to Circuits.count -1 do
        Tlist(Circuits[i]).free;
      Circuits.clear;
      findCircuits(theVertexlist);
      //
      if not isruning then
         begin
           result := nil ;
           finalfree;
           exit;
         end;

      if Circuits.count = 0 then
         begin
           result := nil ;
           finalfree;
           exit;
         end;
      if Circuits.count = 1 then
         begin
           maxcircuit := Circuits.first;
           If maxcircuit.Count = theVertexlist.count Then
             begin
               subHamiltonCircuit := Tlist.create;
               for i := 0 to maxcircuit.count -1 do
                 subHamiltonCircuit.add(maxcircuit[i]);
               result := subHamiltonCircuit;
               finalfree;
               exit;
             end
           else
             begin
               result := nil;
               finalfree;
               exit;
             end;
         end;

      isgodwild := false;
      isgodreturn := false;
      repeat
        gods.clear;   //wild search
        godbegintime := time;
        result := recursiveSearch(Circuits,theVertexlist);
        if result <> nil then
          begin
           break;
          end
        else
          begin
           Tlist(Circuits[0]).free;
           Circuits.delete(0);
          end;
        if not isRuning then
           begin
             result := nil;
             break;
           end;
      until circuits.count < 2;
    end;
  finalfree;
end;

function GetHamiltonCircuit:boolean;
var maxcircuit:Tlist;
    i,j:integer;
    curredge : Tedge;

    procedure finalfree;
    var i :integer;
      begin
        Hamiltoncircuit.free;
        for i:= 0 to Circuits.count -1 do
          Tlist(Circuits[i]).free;
        gods.free;
        Circuits.free;
      end;
begin
  result := false;
  Circuits := Tlist.create;
  gods := Tlist.create;
  Hamiltoncircuit := Tlist.create;

  //except
  if (vertexlist.count > 24) and (edgelist.count > 48) then
     FindForm.puthint(clBlack,12,'开始搜索,请耐心等待两分钟...  按ESC键停止');

  Hamiltoncircuit := splitandfind(vertexlist);

  for i := 0 to vertexlist.count - 1 do
    with Tvertex(vertexlist[i]) do
    begin
      if isDelete then
         begin
           IsDelete := false;
           ConnectiveDegree := 0;
         end;
    end;
  for i := 0 to edgelist.count - 1 do
    with Tedge(edgelist[i]) do
      if not considervisible then considervisible := true;

  if Hamiltoncircuit <> nil then
     begin
       brushCircuit(Hamiltoncircuit,clREd,2);
       result := true;
     end;
  finalfree;
end;

end.