dinner.pas

本光盘是《国际大学生程序设计竞赛例题解（一）》的配套光盘

program Dinner_Problem;

const ifn='dinner.dat';
      ofn='dinner.out';
      maxn=500;

type knowtype=array[1..maxn] of boolean;
     leavetype=array[1..maxn] of boolean;

var know:array[1..maxn] of ^knowtype;
    leave,lea:leavetype;
    n,min:integer;

function degree(x:integer):integer;
var i,k:integer;
begin
  k:=0;
  for i:=1 to n do
    if not(lea[i]) and know[x]^[i] then inc(k);
  degree:=k;
end;

function connect(x:integer):integer;
var k:integer;
begin
  k:=0;
  repeat inc(k); until not(lea[k]) and know[x]^[k];
  connect:=k;
end;

function noknow:boolean;
var i,j:integer;
begin
  noknow:=false;
  for i:=1 to n-1 do
    for j:=i+1 to n do
      if know[i]^[j] and not(lea[i]) and not(lea[j]) then exit;
  noknow:=true;
end;

procedure save(p:integer);
begin
  leave:=lea;
  min:=p;
end;

function pass(x:integer):boolean;
var i:integer;
begin
  if lea[x] or (degree(x)=0) then pass:=false
  else pass:=true;
end;

function done(x:integer):boolean;
var i:integer;
begin
  done:=true;
  for i:=1 to n do
    if i<>x then
      if know[x]^[i] and (degree(i)=2) then
        if connect(i)<x then exit;
  done:=false;
end;

procedure try(p:integer);
var leabak:^leavetype;
    i,j,k:integer;
begin
  if p>min then exit;
  if noknow then save(p-1)
  else begin
    new(leabak);
    leabak^:=lea;
    i:=0;  k:=0;
    repeat
      inc(i);
      if lea[i] then continue;
      j:=degree(i);
      if j=1 then begin
        i:=connect(i);
        lea[i]:=true;
        i:=0;
        inc(k);
      end
      else
        if j>(n-p-k+1) div 2 then begin
          lea[i]:=true;
          i:=0;
          inc(k);
        end;
    until i=n;
    if k>0 then begin
      try(p+k);
      lea:=leabak^;
    end
    else
      for i:=1 to n do
        if pass(i) and not done(i) then begin
          lea[i]:=true;
          try(p+1);
          lea[i]:=false;
        end;
    dispose(leabak);
  end;
end;

procedure read_data;
var i,j:integer;
begin
  assign(input,ifn);
  reset(input);
    readln(n);
    for i:=1 to n do begin
      new(know[i]);
      for j:=1 to n do know[i]^[j]:=false;
    end;
    repeat
      readln(i,j);
      if (i=0) and (j=0) then continue;
      know[i]^[j]:=true;
      know[j]^[i]:=true;
    until (i=0) and (j=0);
  close(input);
end;

procedure search;
var i:integer;
begin
  fillchar(leave,sizeof(leave),false);
  fillchar(lea,sizeof(lea),false);
  min:=n;
  try(1);
end;

procedure write_data;
var i:integer;
begin
  assign(output,ofn);
  rewrite(output);
    writeln(min);
    for i:=1 to n do
      if leave[i] then write(i,' ');
    writeln;
  close(output);
end;

begin
  read_data;
  search;
  write_data;
end.