hamiltonbackup.pas

图论算法

unit hamilton;

interface
{$DEFINE  DEBUG2}
uses Classes,Forms,SysUtils,Graphics,VE;

var
  isPause:boolean;
  isRuning:boolean;
  Circuits:Tlist;
  Hamiltoncircuit:Tlist;
  function GetHamiltonCircuit:boolean;
  function checkHamiltonian:boolean;
implementation
uses FForm;

function CompareCircuits(Item1, Item2: Pointer): Integer;
begin
  result := 0;
  if Tlist(Item1).count > TList(Item2).count then
     result := -1
  else if Tlist(Item1).count < TList(Item2).count then
     result := 1;
end;

procedure findCircuits(theVertexlist:Tlist);
var untakenVertice:Tlist;
    pathrecord:Tlist;
    throughVertex,selectVertex:Tvertex;
    throughVertexindex:integer;
    i,j,k:integer;
    p:Tvertex;

    procedure getNeighbourVertice(theVertex:Tvertex;var NeighbourVertice:Tlist);//get neighbour vertice of theVertex , put them into NeighbourVertice
    var i:integer;
    begin
      NeighbourVertice.clear;
      with theVertex do
        for i := 1 to Neighbourcount do
          if NEConsiderVisible(i) then
             if (not isdelete) or (theVertexlist.indexof(NV[i]) > -1) then
               NeighbourVertice.add(NV[i]);
    end;

    procedure findnextcircuitpath(Root:Tvertex;Root_pathrecord:Tlist);
     var Root_permitedneighbourVertice:Tlist;
         pathrecord:Tlist;
         p,q,r:Tvertex;
         i,j,k:integer;
     begin
       Root_permitedneighbourVertice := Tlist.create;
       pathrecord := Tlist.create;
       for i:= 0 to Root_pathrecord.count -1 do pathrecord.add(Root_pathrecord[i]);
       getNeighbourVertice(Root,Root_permitedneighbourVertice);

       //decide next neighbour vertex
       for i:= 0 to pathrecord.count -1 do
         begin
           r := Tvertex(pathrecord[i]);
           if r <> root then
             for j := 0 to Root_permitedneighbourVertice.count -1 do
               begin
                 q := Tvertex(Root_permitedneighbourVertice[j]);
                 if (r = q) or (r.isConsiderVisibleNV(q))
                    or (theVertexlist.indexof(q) < throughVertexindex) then
                   begin
                     if q = SelectVertex then
                       begin
                         pathrecord.add(selectVertex);
                         circuits.add(pathrecord);
                         Root_permitedneighbourVertice.free;
                         exit;
                       end
                     else
                       begin
                         Root_permitedneighbourVertice[j] := nil;
                       end;
                   end;//if (r = q) or (q.labelno < throughVertex.labelno)
               end;//for j := 0 to Root_permitedneighbourVertice.count -1 do
           Root_permitedneighbourVertice.pack;
           if Root_permitedneighbourVertice.count = 0 then
              begin
                Root_permitedneighbourVertice.free;
                pathrecord.free;
                exit;
              end;
         end;//for i:= 0 to pathrecord.count -1 do

       for i := 0 to Root_permitedneighbourVertice.count - 1 do
         begin
           p := Tvertex(Root_permitedneighbourVertice[i]);
           pathrecord.add(p);

           findnextcircuitpath(p, pathrecord);

           pathrecord.remove(p);
         end;
       Root_permitedneighbourVertice.free;
       pathrecord.free;
     end;
begin
  untakenVertice := Tlist.create;
  pathrecord := Tlist.create;
  for i := 0 to theVertexlist.count-1 do
    begin
      throughVertex := Tvertex(theVertexlist[i]);
      throughVertexindex := theVertexlist.indexof(throughVertex);
      getNeighbourVertice(throughVertex,untakenVertice);
      for k := 0 to i - 1 do //remove already through vertex
        if untakenVertice.indexof(theVertexlist[k]) > -1 then
           untakenVertice.remove(theVertexlist[k]);

      while untakenVertice.count > 1 do
        begin
          selectVertex := untakenVertice[0];
          untakenVertice.remove(untakenVertice[0]);
         for j := 0 to untakenVertice.count -1 do
           begin
             p := TVertex(untakenVertice[j]);

             pathrecord.Add(throughVertex);
             pathrecord.Add(p);

             findnextcircuitpath(p,pathrecord);

             pathrecord.clear;
           end;
        end;//while untakenVertice.count > 1 do

        untakenVertice.clear;
    end;

  untakenVertice.free;
  pathrecord.free;

//Circuits length sort
  circuits.sort(CompareCircuits);
end;

procedure brushCircuit(thecircuit:Tlist;thecolor:Tcolor;thewidth:integer);
var i:integer;
    curredge:TEdge;
begin
  For i := 0 To thecircuit.Count - 2 do
    begin
      curredge := Tvertex(thecircuit[i]).getConsiderVisibleNE(Tvertex(thecircuit[i+1]));
      if curredge <> nil then curredge.colorwidth(thecolor,thewidth);
    end;
 curredge := Tvertex(thecircuit.first).getConsiderVisibleNE(Tvertex(thecircuit.last));
 if curredge <> nil then curredge.colorwidth(thecolor,thewidth);
end;

function MergeCircuit(circuit1, circuit2:Tlist):Tlist;
var publicnum:integer;
    newCircuit:Tlist;
    curredge,publicedge:Tedge;
    theindex:integer;
    publicVertexpair:array[1..2] of Tvertex;
    publicVertexpos1:array[1..2] of integer;
    publicVertexpos2:array[1..2] of integer;
    i,j:integer;
    m,mstep:integer;
begin
  result := nil;
  publicnum := 0;
  for i := 0 to circuit1.count - 1 do
    begin
      theindex := Circuit2.indexof(Circuit1[i]);
      if theindex > -1 then
         begin
           if publicnum < 2 then
              begin
                inc(publicnum);
                publicVertexpair[publicnum] := Tvertex(Circuit1[i]);
                publicVertexpos1[publicnum] := i;
                publicVertexpos2[publicnum] := theindex;
              end
           else
              begin
                publicnum := 0;
                break;
              end;
         end;
    end;
  if publicnum <> 2 then exit;
  publicedge := publicVertexpair[1].getConsiderVisibleNE(publicVertexpair[2]);
  if publicedge <> nil then
     begin
       newCircuit := Tlist.create;

       m := publicVertexpos1[1];
       If (publicVertexpos1[1] - publicVertexpos1[2] = 1) Or
          (publicVertexpos1[2] - publicVertexpos1[1] = circuit1.Count - 1)
       Then mstep := 1 Else mstep := -1;
       For i := 1 To circuit1.Count 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 := publicVertexpos2[2];
       If (publicVertexpos2[2] - publicVertexpos2[1] = 1) Or
          (publicVertexpos2[1] - publicVertexpos2[2] = circuit2.Count - 1)
         Then mstep := 1 Else mstep := -1;
       For i := 1 To circuit2.Count - 2 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;
end;

function norelevant(Circuit1,circuit2:Tlist):boolean; //true : 0,1 vertex or two adjacent vertex , false:others
var publicnum:integer;
    publicVertexpos1:array[1..2] of integer;
    i:integer;
begin
  result := true;
  publicnum := 0;
  for i := 0 to circuit1.count - 1 do
    begin
      if Circuit2.indexof(Circuit1[i]) > -1 then
         begin
           if publicnum < 2 then
              begin
                inc(publicnum);
                publicVertexpos1[publicnum] := i;
              end
            else
              begin
                result := false;
                exit;
              end;
         end;
    end;
  if publicnum = 2 then
     begin
       If (publicVertexpos1[2] - publicVertexpos1[1] = 1) Or
          (publicVertexpos1[2] - publicVertexpos1[1] = circuit1.Count - 1)
         then result := true  else result := False;
     end;
end;

function recursiveSearch(theCircuits:Tlist;theVertexlist:Tlist):Tlist; //true : find a hamilton circuit
var i,j,k:integer;
    SearchCircuits:Tlist;
    SubCircuits:Tlist;
    currcircuit:Tlist;
    compareCircuit:Tlist;
    newCircuit:Tlist;
    curredge :Tedge;
    circuitsvertexnum:integer;
    vertexExist:boolean;
  procedure finalall;
    begin
      SearchCircuits.free;
      SubCircuits.free;
    end;
begin
  result := nil;
  SearchCircuits := Tlist.create;
  SubCircuits := Tlist.create;
  currcircuit :=  Tlist(theCircuits[0]);
  for i:=1 to theCircuits.count - 1 do SearchCircuits.add(theCircuits[i]);

  for i:=0 to SearchCircuits.count -1 do
    begin
      compareCircuit := Tlist(SearchCircuits[i]);
      newCircuit := MergeCircuit(currcircuit,compareCircuit);
      if newCircuit <> nil then
         begin
           SearchCircuits[i] := nil;
           if newCircuit.count = theVertexlist.count then
              begin
                result := newCircuit;
                finalall;
                exit;
              end;

           if SubCircuits.count > 0 then SubCircuits.clear;
           SubCircuits.add(newCircuit);
           for j := 0 to SearchCircuits.count -1 do
             begin
               if SearchCircuits[j] <> nil then
                  begin
                    if norelevant(newCircuit,SearchCircuits[j]) then
                       SubCircuits.add(SearchCircuits[j]);
                  end;
             end;
           if SubCircuits.count > 1 then
             for j := 0 to theVertexlist.count - 1 do
               begin
                 vertexExist := false;
                 for k := 0 to SubCircuits.count - 1 do
                   begin
                     if Tlist(SubCircuits[k]).indexof(theVertexlist[j]) > -1  then
                       begin
                         vertexExist := true;
                         break;
                       end;
                   end;
                 if not vertexExist then break;
               end
           else vertexExist := false;
           if vertexExist then
             begin
               result := recursiveSearch(SubCircuits,theVertexlist);
               if result <> nil then
                  begin
                    finalall;
                    exit;
                  end;
             end;
           newCircuit.free;
         end;//if newCircuit <> nil then
    end;

  finalall;
end;

function CheckConnexion(checkVertexlist:Tlist):Tlist;//return notconnectivevertexlist
var i,j:integer;
    connectiveVertexs:Tlist;
    NotconnectiveVertexs:Tlist;
    checkVertex:Tvertex;
    isExist:boolean;
    connectiveVertexNum:integer;
begin
  result := nil;
  if checkVertexlist.count <= 1 then exit;
  connectiveVertexs := Tlist.create;
  NotconnectiveVertexs := Tlist.create;
  connectiveVertexs.add(checkVertexlist.first);
  i := 1;
  repeat
    checkVertex := Tvertex(checkVertexlist[i]);
    isExist := false;
    for j := 0 to connectiveVertexs.count - 1 do
      begin
        if Tvertex(connectiveVertexs[j]).isConsiderVisibleNV(checkVertex) then
           begin
             isExist := true;
             connectiveVertexs.add(checkVertex);
             break;
           end;
      end;
    if not isExist then
      begin
        NotconnectiveVertexs.add(checkVertex);
      end;
    inc(i);
  until i >= checkVertexlist.count;
  if NotconnectiveVertexs.count > 0 then
  begin
   if connectiveVertexs.count = 1 then result := NotconnectiveVertexs
   else
     begin
      repeat
        connectiveVertexNum := connectiveVertexs.count;
        i := 0 ;
        repeat
          checkVertex := Tvertex(NotconnectiveVertexs[i]);
          isExist := false;
          for j := 0 to connectiveVertexs.count - 1 do
            begin
              if Tvertex(connectiveVertexs[j]).isConsiderVisibleNV(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 );
      if NotconnectiveVertexs.count > 0 then result := NotconnectiveVertexs;
     end;
   end;
  connectiveVertexs.free;
  if result= nil then NotconnectiveVertexs.free;
end;

function checkGraphConnexion(theVertexlist:Tlist;ConnexionNum:integer):boolean;
var i,j:integer;
    restVertexs:Tlist;