Permut.pas

Un article de Wikipedia.

Version du 24 mars 2008 à 10:19 par Ziglooadmin (Discuter | Contributions)
(diff) ← Version précédente | voir la version courante (diff) | Version suivante → (diff)
program permut;
 
const SYSTRAP = $4E4F;
 
type node = 1..255;
     listnodeptr=^listnode;
     listnode = record
       node:node;
       next:listnodeptr;
     end;
     listlistnodeptr=^listlistnode;
     listlistnode = record
       listnodeptr:listnodeptr;
       next:listlistnodeptr;
     end;
     listlistlistnodeptr=^listlistlistnode;
     listlistlistnode = record
       size:node;
       listlistnodeptr:listlistnodeptr;
       next:listlistlistnodeptr;
     end;
     link = record
       node1:node;
       node2:node;
     end;
     listlinkptr=^listlink;
     listlink=record
       link:link;
       next:listlinkptr;
     end;
     listlistlinkptr=^listlistlink;
     listlistlink=record
       listlinkptr:listlinkptr;
       next:listlistlinkptr;
     end;
     listlistlistlinkptr=^listlistlistlink;
     listlistlistlink=record
       size:node;
       listlistlinkptr:listlistlinkptr;
       next:listlistlistlinkptr;
     end;
     UInt32 = 0..MaxInt;
 
var perms:listlistlistnodeptr;
    links:listlistlistlinkptr;
    listperm:listlistnodeptr;
    l,actual:listlistlinkptr;
    n,count,size:integer;
    s:node;
    c:char;
 
function TimGetSeconds:UInt32; inline(SYSTRAP,$A0F5);
function StrAToI(const S:string):integer; inline(SYSTRAP,$a0ce);
 
function fact(n:integer):integer;
begin
 if n >= 0 then
 begin
  if n = 0 then fact:=1
  else
   if n = 1 then fact:=1
   else fact:=n*fact(n-1);
 end
 else
  fact:=-1;
end;
 
function copyperm(perm:listnodeptr):listnodeptr;
var actual,copyactual:listnodeptr;
begin
 if perm <> nil then
 begin
  actual:=perm;
  new(copyactual);
  copyperm:=copyactual;
  while actual^.next <> nil do
  begin
   copyactual^.node:=actual^.node;
   new(copyactual^.next);
   copyactual:=copyactual^.next;
   actual:=actual^.next;
  end;
  copyactual^.node:=actual^.node;
  copyactual^.next:=nil;
 end
 else
  copyperm:=nil;
end;
 
function addnode(perm:listnodeptr;n:node;pos:integer):listnodeptr;
var actual,prec,newnode:listnodeptr;
    actualpos:integer;
begin
 if pos >= 0 then
 begin
  prec:=nil;
  actual:=perm;
  actualpos:=0;
  while (actual^.next <> nil) and (actualpos <> pos) do
  begin
   prec:=actual;
   actual:=actual^.next;
   actualpos:=actualpos+1;
  end;
  new(newnode);
  newnode^.node:=n;
  if actualpos = pos then
  begin
   if prec <> nil then
   begin
    prec^.next:=newnode;
    newnode^.next:=actual;
    addnode:=perm;
   end
   else
   begin
    newnode^.next:=perm;
    addnode:=newnode;
   end;
  end
  else
  begin
   actual^.next:=newnode;
   newnode^.next:=nil;
   addnode:=perm;
  end;
 end
 else
  addnode:=perm;
end;
 
function addnode2(list:listnodeptr;n:node):listnodeptr;
var actual:listnodeptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while (actual^.next <> nil) and (actual^.node <> n) do
   actual:=actual^.next;
  if actual^.node <> n then
  begin
   new(actual^.next);
   with actual^.next^ do
   begin
    node:=n;
    next:=nil;
   end;
  end;
  addnode2:=list;
 end
 else
 begin
  new(actual);
  with actual^ do
  begin
   node:=n;
   next:=nil;
  end;
  addnode2:=actual;
 end;
end;
 
function delnode(list:listnodeptr;n:node):listnodeptr;
var actual,prev:listnodeptr;
begin
 if list <> nil then
 begin
  prev:=nil;
  actual:=list;
  while (actual^.next <> nil) and (actual^.node <> n) do
  begin
   prev:=actual;
   actual:=actual^.next;
  end;
  if actual^.node = n then
  begin
   if prev <> nil then
   begin
    if actual^.next <> nil then
     prev^.next:=actual^.next
    else
     prev^.next:=nil;     
    dispose(actual);
    delnode:=list;
   end
   else
   begin
    if actual^.next <> nil then
     prev:=actual^.next
    else
     prev:=nil;     
    dispose(actual);
    delnode:=prev;
   end;
  end
  else
   delnode:=list;
 end
 else
  delnode:=nil;
end;
 
procedure erasenode(list:listnodeptr);
var actual,prev:listnodeptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while actual^.next <> nil do
  begin
   prev:=actual;
   actual:=actual^.next;
   dispose(prev);
  end;
  dispose(actual);
 end;
end;
 
function nodesize(list:listnodeptr):integer;
var actual:listnodeptr;
    result:integer;
begin
 result:=0;
 if list <> nil then
 begin
  actual:=list;
  while actual^.next <> nil do
  begin
   result:=result+1;
   actual:=actual^.next;
  end;
  result:=result+1;
 end;
 nodesize:=result;
end;
 
function permutation(n:node):listlistnodeptr;
var actualperms:listlistlistnodeptr;
    actuallistperm,copylistperm,lastcopylistperm:listlistnodeptr;
    i:node;
    reverse:boolean;
    pos:integer;
begin
 if perms = nil then
 begin
  new(perms);
  with perms^ do
  begin
   size:=1;
   new(listlistnodeptr);
   with listlistnodeptr^ do
   begin
    new(listnodeptr);
    with listnodeptr^ do
    begin
     node:=1;
     next:=nil;
    end;
    next:=nil;
   end;
   next:=nil;
  end;
 end;
 if n>= 1 then
 begin
  actualperms:=perms;
  while (actualperms^.next <> nil) and (actualperms^.size <> n) do
   actualperms:=actualperms^.next;
  if n = actualperms^.size then
  begin 
   permutation:=actualperms^.listlistnodeptr;
  end
  else if n = actualperms^.size+1 then
  begin
   new(actualperms^.next);
   with actualperms^.next^ do
   begin
    size:=n;
    new(listlistnodeptr);
    permutation:=listlistnodeptr;
    copylistperm:=listlistnodeptr;
    next:=nil;
   end;
   reverse:=true;
   actuallistperm:=actualperms^.listlistnodeptr;
   while actuallistperm^.next <> nil do
   begin
    for i:=1 to n do
    begin
     if reverse then pos:=n-i
     else pos:=i-1;
     copylistperm^.listnodeptr:=addnode(copyperm(actuallistperm^.listnodeptr),n,pos);
     new(copylistperm^.next);
     copylistperm:=copylistperm^.next;
    end;
    actuallistperm:=actuallistperm^.next;
    reverse:=not reverse;
   end;
   for i:=1 to n do
   begin
    if reverse then pos:=n-i
    else pos:=i-1;
    copylistperm^.listnodeptr:=addnode(copyperm(actuallistperm^.listnodeptr),n,pos);
    new(copylistperm^.next);
    lastcopylistperm:=copylistperm;
    copylistperm:=copylistperm^.next;
   end;
   dispose(lastcopylistperm^.next);
   lastcopylistperm^.next:=nil;
  end
  else
   begin
   actuallistperm:=permutation(n-1);
   permutation:=permutation(n);
   end;
 end
 else
   permutation:=nil; 
end;
 
procedure permprint(perm:listnodeptr);
var actual:listnodeptr;
begin
 write('[');
 if perm <> nil then
 begin
  actual:=perm;
  while actual^.next <> nil do
  begin
   write(actual^.node,',');
   actual:=actual^.next;
  end;
  write(actual^.node);
 end;
 write(']');
end;
 
procedure listpermprint(listperm:listlistnodeptr);
var actual:listlistnodeptr;
    n:integer;
begin
 writeln('Permutations :');
 if listperm <> nil then
 begin
  n:=1;
  actual:=listperm;
  while actual^.next <> nil do
  begin
   write(n:3,':');
   permprint(actual^.listnodeptr);
   write(' ');
   if (n-1) mod 2 = 1 then writeln;
   actual:=actual^.next;
   n:=n+1;
  end;
  write(n:3,':');
  permprint(actual^.listnodeptr);
  writeln;
 end
 else
  writeln('-');
 writeln;
end;
 
function isequal(linka,linkb:link):boolean;
begin
 if (linka.node1 = linkb.node1) and
    (linka.node2 = linkb.node2) or
    (linka.node1 = linkb.node2) and
    (linka.node2 = linkb.node1) then
   isequal:=true
  else
   isequal:=false;
end;
 
function linksize(links:listlinkptr):integer;
var actual:listlinkptr;
    size:integer;
begin
 if links <> nil then
 begin
  size:=1;
  actual:=links;
  while actual^.next <> nil do
  begin
   size:=size+1;
   actual:=actual^.next;
  end;
  linksize:=size;
 end
 else
  linksize:=0;
end;
 
function addlink(list:listlinkptr;l:link):listlinkptr;
var actual:listlinkptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while (actual^.next <> nil) and not isequal(actual^.link,l) do
   actual:=actual^.next;
  if not isequal(actual^.link,l) then
  begin
   new(actual^.next);
   with actual^.next^ do
   begin
    link:=l;
    next:=nil;
   end;
  end;
  addlink:=list;
 end
 else
 begin
  new(actual);
  with actual^ do
  begin
   link:=l;
   next:=nil;
  end;
  addlink:=actual;
 end;
end;
 
function dellink(list:listlinkptr;l:link):listlinkptr;
var actual,prev:listlinkptr;
begin
 if list <> nil then
 begin
  prev:=nil;
  actual:=list;
  while (actual^.next <> nil) and not isequal(actual^.link,l) do
  begin
   prev:=actual;
   actual:=actual^.next;
  end;
  if isequal(actual^.link,l) then
  begin
   if prev <> nil then
   begin
    if actual^.next <> nil then
     prev^.next:=actual^.next
    else
     prev^.next:=nil;     
    dispose(actual);
    dellink:=list;
   end
   else
   begin
    if actual^.next <> nil then
     prev:=actual^.next
    else
     prev:=nil;     
    dispose(actual);
    dellink:=prev;
   end;
  end
  else
   dellink:=list;
 end
 else
  dellink:=nil;
end;
 
procedure eraselink(list:listlinkptr);
var actual,prev:listlinkptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while actual^.next <> nil do
  begin
   prev:=actual;
   actual:=actual^.next;
   dispose(prev);
  end;
  dispose(actual);
 end;
end;
 
function haslink(list:listlinkptr;l:link):boolean;
var actual:listlinkptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while (actual^.next <> nil) and not isequal(actual^.link,l) do
   actual:=actual^.next;
  if not isequal(actual^.link,l) then
   haslink:=false
  else
   haslink:=true;
 end
 else
  haslink:=false;
end;
 
function issame(list1,list2:listlinkptr):boolean;
var actual:listlinkptr;
begin
 if linksize(list1) = linksize(list2) then
 begin
  if list1 <> nil then
  begin
   actual:=list1;
   while (actual^.next <> nil) and haslink(list2,actual^.link) do
   begin
    actual:=actual^.next;
   end;
   if haslink(list2,actual^.link) then
    issame:=true
   else
    issame:=false;
  end
  else
   issame:=true;
 end
 else
   issame:=false
end;
 
function copylink(list:listlinkptr):listlinkptr;
var actual,copyactual:listlinkptr;
begin
 if list <> nil then
 begin
  actual:=list;
  new(copyactual);
  copylink:=copyactual;
  while actual^.next <> nil do
  begin
   copyactual^.link.node1:=actual^.link.node1;
   copyactual^.link.node2:=actual^.link.node2;
   new(copyactual^.next);
   copyactual:=copyactual^.next;
   actual:=actual^.next;
  end;
  copyactual^.link.node1:=actual^.link.node1;
  copyactual^.link.node2:=actual^.link.node2;
  copyactual^.next:=nil;
 end
 else
  copylink:=nil;
end;
 
function alllinks(size:node):listlinkptr;
var n1,n2:node;
    actual,prev:listlinkptr;
begin
 if size > 1 then
 begin
  new(actual);
  alllinks:=actual;
  for n1:=1 to size do
   for n2:=1 to size do
    if n2 > n1 then
    begin
     actual^.link.node1:=n1;
     actual^.link.node2:=n2;
     new(actual^.next);
     prev:=actual;
     actual:=actual^.next;
   end;
   prev^.next:=nil;
   dispose(actual);
 end
 else
  alllinks:=nil;
end;
 
function addlistlink(list:listlistlinkptr;l:listlinkptr):listlistlinkptr;
var actual:listlistlinkptr;
begin
 if list <> nil then
 begin
  actual:=list;
  while (actual^.next <> nil) and not issame(actual^.listlinkptr,l) do
   actual:=actual^.next;
  if not issame(actual^.listlinkptr,l) then
  begin
   new(actual^.next);
   with actual^.next^ do
   begin
    listlinkptr:=l;
    next:=nil;
   end;
  end;
  addlistlink:=list;
 end
 else
 begin
  new(actual);
  with actual^ do
  begin
   listlinkptr:=l;
   next:=nil;
  end;
  addlistlink:=actual;
 end;
end;
 
function dellistlink(list:listlistlinkptr;l:listlinkptr):listlistlinkptr;
var actual,prev:listlistlinkptr;
begin
 if list <> nil then
 begin
  prev:=nil;
  actual:=list;
  while (actual^.next <> nil) and not issame(actual^.listlinkptr,l) do
  begin
   prev:=actual;
   actual:=actual^.next;
  end;
  if issame(actual^.listlinkptr,l) then
  begin
   if prev <> nil then
   begin
    if actual^.next <> nil then
     prev^.next:=actual^.next
    else
     prev^.next:=nil;     
    dispose(actual);
    dellistlink:=list;
   end
   else
   begin
    if actual^.next <> nil then
     prev:=actual^.next
    else
     prev:=nil;     
    dispose(actual);
    dellistlink:=prev;
   end;
  end
  else
   dellistlink:=list;
 end
 else
  dellistlink:=nil;
end;
 
function listlinksize(links:listlistlinkptr):integer;
var size:integer;
    actual:listlistlinkptr;
begin
 if links <> nil then
 begin
  size:=0;
  actual:=links;
  while actual^.next <> nil do
  begin
   size:=size+1;
   actual:=actual^.next;
  end;
  size:=size+1;
  listlinksize:=size;
 end
 else
  listlinksize:=-1;
end;
 
function toperm(perm:listnodeptr;n:node):integer;
var pos:integer;
    actual:listnodeptr;
begin
 if perm <> nil then
 begin
  if n >= 1 then
  begin
   pos:=1;
   actual:=perm;
   while (actual^.next <> nil) and (n <> pos) do
   begin
    actual:=actual^.next;
    pos:=pos+1;
   end;
   if n = pos then
    toperm:=actual^.node
   else
    toperm:=0;
  end
  else
   toperm:=0;
 end
 else
  toperm:=0;
end;
 
function linkperm(links:listlinkptr;perm:listnodeptr):listlinkptr;
var actual,copyactual:listlinkptr;
begin
 if links <> nil then
 begin
  if perm <> nil then
  begin
   new(copyactual);
   linkperm:=copyactual;
   actual:=links;
   while actual^.next <> nil do
   begin
    with copyactual^ do
    begin
     link.node1:=toperm(perm,actual^.link.node1);
     link.node2:=toperm(perm,actual^.link.node2);
     new(next);
     copyactual:=next;
    end;
    actual:=actual^.next;
   end;
   with copyactual^ do
   begin
    link.node1:=toperm(perm,actual^.link.node1);
    link.node2:=toperm(perm,actual^.link.node2);
    next:=nil;
   end;
  end
  else
   linkperm:=copylink(links);
 end
 else
  linkperm:=nil;
end;
 
function complink(l:listlinkptr;n:node):listlinkptr;
var result,actual:listlinkptr;
begin
 if n >= 2 then
 begin
  result:=alllinks(n);
  if l <> nil then
  begin
   actual:=l;
   while actual^.next <> nil do
   begin
    result:=dellink(result,actual^.link);
    actual:=actual^.next;
   end;
   result:=dellink(result,actual^.link);
  end;
  complink:=result;
 end
 else
  complink:=nil;
end;
 
function nblink(n:node):integer;
begin
 if n >= 0 then
  nblink:=n*(n-1) div 2
 else
  nblink:=0;
end;
 
procedure linkprint(l:link);
begin
 write('(');
 if l.node1 <= l.node2 then
  write(l.node1,',',l.node2)
 else
  write(l.node2,',',l.node1);
 write(')');
end;
 
procedure listlinkprint(links:listlinkptr);
var actual:listlinkptr;
begin
 write('[');
 if links <> nil then
 begin
  actual:=links;
  while actual^.next <> nil do
  begin
   linkprint(actual^.link);
   write(',');
   actual:=actual^.next;
  end;
  linkprint(actual^.link);
 end;
 writeln(']');
end;
 
procedure listlistlinkprint(links:listlistlinkptr);
var actual:listlistlinkptr;
begin
 if links <> nil then
 begin
  actual:=links;
  while actual^.next <> nil do
  begin
   listlinkprint(actual^.listlinkptr);
   actual:=actual^.next;
  end;
  listlinkprint(actual^.listlinkptr);
 end
 else
  writeln('-');
end;
 
function getlinks(size:node;n:integer):listlistlinkptr;
var actuallistlistlist:listlistlistlinkptr;
    actuallistlist,prevlistlist,result,temp:listlistlinkptr;
    actuallist,alllistlink,copylist:listlinkptr;
    permlist,actualpermlist:listlistnodeptr;
begin
 if links = nil then
 begin
  new(links);
  with links^ do
  begin
   size:=2;
   listlistlinkptr:=addlistlink(nil,nil);
   listlistlinkptr:=addlistlink(listlistlinkptr,complink(nil,2));
   next:=nil;
  end;
 end;
 if size >= 2 then
 begin
  if n < 0 then
   getlinks:=getlinks(size,0)
  else
   if n > nblink(size) then
    getlinks:=getlinks(size,nblink(size))
   else
   begin
     actuallistlistlist:=links;
     while (actuallistlistlist^.next <> nil) and (actuallistlistlist^.size <> size) do
      actuallistlistlist:=actuallistlistlist^.next;
     if actuallistlistlist^.size = size then
     begin
      actuallistlist:=actuallistlistlist^.listlistlinkptr;
      if actuallistlist <> nil then
      begin
       result:=nil;
       while actuallistlist^.next <> nil do
       begin
        if linksize(actuallistlist^.listlinkptr) = n then
         result:=addlistlink(result,actuallistlist^.listlinkptr);
        actuallistlist:=actuallistlist^.next;
       end;
       if linksize(actuallistlist^.listlinkptr) = n then
        result:=addlistlink(result,actuallistlist^.listlinkptr);
       if result <> nil then
        getlinks:=result
       // n list not found
       else
       begin
        if n > (nblink(size) div 2) then
        begin
         prevlistlist:=getlinks(size,nblink(size)-n);
         if prevlistlist <> nil then
         begin
          actuallistlist:=prevlistlist;
          result:=nil;
          while actuallistlist^.next <> nil do
          begin
           result:=addlistlink(result,complink(actuallistlist^.listlinkptr,size));
           actuallistlist:=actuallistlist^.next;
          end;
          result:=addlistlink(result,complink(actuallistlist^.listlinkptr,size));
          actuallistlist:=actuallistlistlist^.listlistlinkptr;
          while actuallistlist^.next <> nil do
           actuallistlist:=actuallistlist^.next;
          actuallistlist^.next:=result;
          getlinks:=getlinks(size,n);
         end
         else
         begin
          writeln('getlinks: generate error');
          getlinks:=nil;
         end;
        end
        // n <= nblink(size) div 2
        else
        begin
         prevlistlist:=getlinks(size,n-1);
         if prevlistlist <> nil then
         begin
          alllistlink:=alllinks(size);
          // temp will contain one more link than previous links found
          temp:=nil;
          actuallistlist:=prevlistlist;
          while actuallistlist^.next <> nil do
          begin
           actuallist:=alllistlink;
           while actuallist^.next <> nil do
           begin
            if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
             temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
            actuallist:=actuallist^.next;
           end;
           if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
            temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
           actuallistlist:=actuallistlist^.next;
          end;
          actuallist:=alllistlink;
          while actuallist^.next <> nil do
          begin
           if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
            temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
           actuallist:=actuallist^.next;
          end;
          if not haslink(actuallistlist^.listlinkptr,actuallist^.link) then
           temp:=addlistlink(temp,addlink(copylink(actuallistlist^.listlinkptr),actuallist^.link));
          // filter same links when permuted
          permlist:=permutation(size);
          result:=nil;
          while temp <> nil do
          begin
//           listlistlinkprint(temp);
//write('add ');
//listlinkprint(temp^.listlinkptr);
           result:=addlistlink(result,temp^.listlinkptr);
           copylist:=temp^.listlinkptr;
           actualpermlist:=permlist;
           while (actualpermlist^.next <> nil) and (temp <> nil) do
           begin
            actuallist:=linkperm(copylist,actualpermlist^.listnodeptr);
//writeln('temp');
//            listlistlinkprint(temp);
//writeln('perm');
//            permprint(actualpermlist^.listnodeptr);
//writeln('linkperm');
//            listlinkprint(actuallist);
//read(c);
            temp:=dellistlink(temp,actuallist);
            actualpermlist:=actualpermlist^.next;
           end;
           if temp <> nil then
           begin
            actuallist:=linkperm(copylist,actualpermlist^.listnodeptr);
//           listlinkprint(actuallist);
            temp:=dellistlink(temp,actuallist);
           end;
          end;
  //        result:=temp;
          if result <> nil then
          begin
           actuallistlist:=actuallistlistlist^.listlistlinkptr;
           while actuallistlist^.next <> nil do
            actuallistlist:=actuallistlist^.next;
           actuallistlist^.next:=result;
           getlinks:=result;
          end
          else
          begin
           writeln('getlinks: generate error 3');
           getlinks:=nil;
          end;
         end
         else
         begin
          writeln('getlinks: generate error 2');
          getlinks:=nil;
         end;
        end;
//        writeln('generated result');
       end;
      end
      // listlistlinkptr not initialized
      else
       begin
        writeln('getlinks:listlistlinkptr init error');
        getlinks:=nil;
       end;
     end
     //size not found
     else
     begin
      new(actuallistlistlist^.next);
      actuallistlistlist^.next^.size:=size;
      with actuallistlistlist^.next^ do
      begin
       listlistlinkptr:=addlistlink(nil,nil);
       listlistlinkptr:=addlistlink(listlistlinkptr,complink(nil,size));
       next:=nil;
      end;
      getlinks:=getlinks(size,n);
     end;
   end;
 end
 else
  getlinks:=nil;
end;
 
function nodes(links:listlinkptr):listnodeptr;
var actual:listlinkptr;
    result:listnodeptr;
begin
 result:=nil;
 if links <> nil then
 begin
  actual:=links;
  while actual^.next <> nil do
  begin
   with actual^ do
   begin
    result:=addnode2(result,link.node1);
    result:=addnode2(result,link.node2);
   end;
   actual:=actual^.next;
  end;
  with actual^ do
  begin
   result:=addnode2(result,link.node1);
   result:=addnode2(result,link.node2);
  end;
 end;
 nodes:=result;
end;
 
// neighbours of node
function gamma(links:listlinkptr;n:node):listnodeptr;
var actual:listlinkptr;
    result:listnodeptr;
begin
 result:=nil;
 if links <> nil then
 begin
  actual:=links;
  while actual^.next <> nil do
  begin
   with actual^ do
   begin
    if (link.node1 = n) and (link.node2 <> n) then
     result:=addnode2(result,link.node2);
    if (link.node2 = n) and (link.node1 <> n) then
     result:=addnode2(result,link.node1);
   end;
   actual:=actual^.next;
  end;
  with actual^ do
  begin
   if link.node1 = n then
    result:=addnode2(result,link.node2);
   if link.node2 = n then
    result:=addnode2(result,link.node1);
  end;
 end;
 gamma:=result;
end;
 
function hasnode(list:listnodeptr;n:node):boolean;
var actual:listnodeptr;
begin
 hasnode:=false;
 if list <> nil then
 begin
  actual:=list;
  while (actual^.next <> nil) and (actual^.node <> n) do
   actual:=actual^.next;
  if actual^.node = n then
   hasnode:=true;
 end;
end;
 
function limitlinks(link:listlinkptr;n:listnodeptr):listlinkptr;
var actual,result:listlinkptr;
begin
 result:=nil;
 if link <> nil then
 begin
  if n <> nil then
  begin
   actual:=link;
   while actual^.next <> nil do
   begin
    with actual^ do
    begin
     if hasnode(n,link.node1) and hasnode(n,link.node2) then
      result:=addlink(result,link);
    end;
    actual:=actual^.next;
   end;
   with actual^ do
   begin
    if hasnode(n,link.node1) and hasnode(n,link.node2) then
     result:=addlink(result,link);
   end;
  end
  else
   result:=copylink(link);
 end;
 limitlinks:=result;
end;
 
// clique
function omega(link:listlinkptr):listnodeptr;
var result,n,v,c:listnodeptr;
    l:listlinkptr;
    actual:node;
begin
 result:=nil;
 if link <> nil then
 begin
  n:=nodes(link);
  if nodesize(n) = 2 then
   with n^ do
   begin
    result:=addnode2(result,node);
    result:=addnode2(result,next^.node);
   end
  else
  begin
   while n <> nil do
   begin
    // clique candidat
    c:=nil;
    v:=gamma(link,n^.node);
    if nodesize(v) = 1 then
     c:=addnode2(c,v^.node)
    else
    begin
     l:=limitlinks(link,v);
     c:=omega(l);
     eraselink(l);
    end;
    c:=addnode2(c,n^.node);
 
    erasenode(v);
 
    if nodesize(c) > nodesize(result) then
    begin
     erasenode(result);
     result:=c;
    end
    else
     erasenode(c);
 
    n:=delnode(n,n^.node);
   end;
  end;
 end
 else
  result:=addnode2(result,1);
 omega:=result;
end;
 
procedure pause;
var c:char;
begin
 write('Introduisez un caractere');
 readln(c);
end;
 
procedure viewstats;
var n:node;
    a,count,size:integer;
    t:UInt32;
begin
 clrscr;
 writeln('Statistiques');
 writeln('------------');
 writeln;
 write('noeud ');
 write('arrete ');
 write('graphe ');
 write('perm. ');
 write('graphe diff.');
 writeln;
 for n:=1 to 38 do
  write('-');
 writeln;
 for n:=2 to 6 do
 begin
  // noeud
  write(n:5);
  // arrete
  write(nblink(n):7);
  // graphe
  write((1 shl nblink(n)):7);
  // permutation
  write(fact(n):6);
  // graphe different
  t:=timgetseconds;
  count:=0;
  for a:=0 to nblink(n) do
  begin
   size:=listlinksize(getlinks(n,a));
   count:=count+size;
  end;
  write(count:6);
  write(' (',timgetseconds-t,')');
  writeln;
 end;
 writeln;
 writeln;
 writeln('noeud  : n');
 writeln('arrete : n*(n-1)/2');
 writeln('graphe : 2^(n*(n-1)/2)');
 writeln('perm.  : n!');
 writeln('graphe diff. : permutation des graphes');
 writeln;
end;
 
procedure viewperm(n:node);
var i:integer;
    actual:listlistnodeptr;
begin
 clrscr;
 if (n >= 2) and (n <= 6) then
 begin
  actual:=permutation(n);
  i:=1;
  while actual^.next <> nil do
  begin
   write(i:4,': ');
   permprint(actual^.listnodeptr);
   if i mod 2 = 0 then
    writeln;
   if i mod 40 = 0 then
    pause;
   i:=i+1;
   actual:=actual^.next;
  end;  
  write(i:4,': ');
  permprint(actual^.listnodeptr);
  writeln;
 end
 else
  writeln('-');
end;
 
procedure viewgraphe(s:node;a:integer);
var i:integer;
    actual:listlistlinkptr;
begin
 clrscr;
 writeln('Graphe reduit');
 writeln('-------------');
 writeln;
 if (s >= 2) and (s <= 6) then
  if (a >= 0) and (a <= nblink(s)) then
  begin
   writeln('noeud ',s:1,' arrete ',a:2);
   writeln('-----------------');
   writeln;
   write('nombre : ');
   actual:=getlinks(s,a);
   writeln(listlinksize(actual));
   writeln;
   if actual <> nil then
   begin
    i:=9;
    while actual^.next <> nil do
    begin
     listlinkprint(actual^.listlinkptr);
     if i mod 20 = 0 then
      pause;
     i:=i+1;
     actual:=actual^.next;
    end;
    listlinkprint(actual^.listlinkptr);
   end
   else
   begin
    listlinkprint(nil);
   end;
  end
  else
   writeln('-')
 else
  writeln('-');
end;
 
procedure viewramsey;
var n:node;
    a:integer;
    l:listlistlinkptr;
    found,continue:boolean;
begin
 clrscr;
 writeln('Nombre de Ramsey(3,3)');
 writeln('---------------------');
 writeln;
 found:=false;
 n:=2;
 while (n <= 6) and not found do
 begin
  write('Noeud : ',n);
  continue:=true;
  a:=0;
  write(' arrete :');
  while (a <= (nblink(n) div 2)) and continue do
  begin
   write(' ',a);
   l:=getlinks(n,a);
   while (l^.next <> nil) and continue do
   begin
    if (nodesize(omega(l^.listlinkptr)) < 3) and (nodesize(omega(complink(l^.listlinkptr,n))) < 3) then
     continue:=false;
    l:=l^.next;
   end;
   if continue then
    if (nodesize(omega(l^.listlinkptr)) < 3) and (nodesize(omega(complink(l^.listlinkptr,n))) < 3) then
     continue:=false;
   if continue then
     a:=a+1
   else
    writeln(' non');
  end;
  if continue then
  begin
   found:=true;
   writeln(' oui');  
  end
  else
   n:=n+1;
 end;
 writeln;
 if found then
  writeln('Nombre de Ramsey(3,3) = ',n)
 else
  writeln('Ramsey(3,3) pas trouve pour n <= ',n);
 writeln;
end;
 
procedure viewmenu;
var s:string;
    n,a:integer;
    select:integer;
    continue:boolean;
begin
 continue:=true;
 while continue do
 begin
  repeat
   clrscr;
   writeln(' Menu');
   writeln(' ----');
   writeln;
   writeln(' 1: Permutations');
   writeln(' 2: Graphes reduits');
   writeln(' 3: Ramsey(3,3)');
   writeln(' 4: Statistique');
   writeln(' 9: Quitter');
   writeln;
   write(' Selection : ');
   readln(s);
   select:=StrAtoI(s);
  until select in [1..4,9];
  writeln;
  case select of
   1:
   begin
    repeat
     write('Nombre de noeuds [2..6] : ');
     readln(s);
     n:=StrAtoI(s);
    until n in [2..6];
    viewperm(n);
    pause;
   end;
   2:
   begin
    repeat
     write('Nombre de noeuds [2..6] : ');
     readln(s);
     n:=StrAtoI(s);
    until n in [2..6];
    repeat
     write('Nombre d''arretes [0..',nblink(n),'] : ');
     readln(s);
     a:=StrAtoI(s);
    until a in [0..nblink(n)];
    viewgraphe(n,a);
    pause;
   end;
   3:
   begin
    viewramsey;
    pause;
   end;
   4:
   begin
    viewstats;
    pause;
   end;
   9:
   begin
    continue:=false;
    writeln('A bientot');
    writeln;
  end;
  end; 
 end;
 pause;
end;
 
begin
 viewmenu;
end.
Récupérée de « http://zigloo.ch/index.php/Permut.pas »
Catégories: Source | Logiciel | Pascal | Palm
Permut.pas

Un article de Wikipedia.

Affichages

Outils personnels

Navigation

Rechercher

Boîte à outils
