二分図集錦

最近の状态は调整する必要があります...
テーマ比較水の説明は貼らない.
1、意外にも奇環が二分図に等しいとは思わなかった.点数は超小さく、直接2^n列挙して各点があちらにある.

var l,r:array[1..100]of longint;
    n,m,ans:longint;
procedure init;
var i,j,max:longint;
begin
 readln(n,m);
 for i:=1 to m do readln(l[i],r[i]);
 ans:=0;
 for i:=1 to (1<<n)-1 do begin
  max:=m;
  for j:=1 to m do
   if (i >> (l[j]-1) and 1) xor (i >> (r[j]-1) and 1)=0 then dec(max);
  if max>ans then ans:=max
 end;
 writeln(m-ans)
end;
begin
assign(input,'worry.in');reset(input);
assign(output,'worry.out');rewrite(output);
 init;
close(input);close(output)
end.

2、移動行(i,j)——>(i,j')、移動列(i,j)——>(i',j)
したがって、対角線が1であれば、行列ごとに座標が異なるので、行列が完全に一致していれば可能である.

var f:array[1..100]of longint;
    b:array[1..100,0..100]of longint;
    c:array[1..100]of boolean;
    ans,n,t:longint;
function edmonds(x:longint):boolean;
var i,ne:longint;
begin
 for i:=1 to b[x,0] do begin
  ne:=b[x,i];
  if c[ne] then begin
   c[ne]:=false;
   if (f[ne]=0)or(edmonds(f[ne])) then begin
    f[ne]:=x;
    exit(true)
   end
  end
 end;
 exit(false)
end;
procedure link(x,y:longint);
begin
 inc(b[x,0]);b[x,b[x,0]]:=y
end;
procedure init;
var i,j,x:longint;
begin
 readln(n);
 fillchar(b,sizeof(b),0);
 for i:=1 to n do begin
  for j:=1 to n do begin
   read(x);
   if x=1 then link(i,j)
  end;
  readln
 end;
 fillchar(f,sizeof(f),0);
 ans:=0;
 for i:=1 to n do begin
  fillchar(c,sizeof(c),true);
  if edmonds(i) then inc(ans)
 end;
 if ans=n then writeln('Y') else writeln('N')
end;
begin
assign(input,'move.in');reset(input);
assign(output,'move.out');rewrite(output);
 readln(t);
 for t:=1 to t do init;
close(input);close(output)
end.

3、重ポンド級、暴捜+マッチング
第四題:牛乳
【タイトル説明】
n*nメッシュに分かれた箱で、1つ1つに牛乳が1本含まれているか、何も入っていない可能性があります.スミスさんは行ごとに左から右に牛乳をメモし、列ごとに上から下に牛乳をメモした.各記録にはn個の数字が含まれており、0は牛乳がないことを示し、1は牛乳があることを示している.残念なことに、2 n本の記録の順番が狂って、数字がぼやけていることもあります.
元の箱の牛乳の状況と元の記録の順序を回復してください
 
【入力データ】
第1行nはメッシュサイズを表す
次の2 n行は、行ごとに1つの記録があり、1つの記録にはnの数字があり、0は牛乳がないことを示し、1は牛乳があることを示し、2は確定できないことを示している.
 
【出力データ】
第1行はn個の数を出力し、第i個の数aiは第ai条が第i行に対応する情報を記録することを示す
第1行はn個の数を出力し、第i個の数biは第bi条が第i列に対応する情報を記録することを示す
次のn行n列は元の箱の牛乳の情況を出力して、0は牛乳がないことを表して、1は牛乳があることを表します
解があることを保証し、複数の解がある場合はいずれかのグループを出力すればよい.
 
【入力サンプル】
5
01210
21120
21001
12110
12101
12101
00011
22222
11001
10010
 
【出力サンプル】
10 9 8 6 2
4 3 7 5 1
10010
11001
10010
10101
01110
 
【友情のヒント】
なし
 
【データ約定】
30%のデータはn≦5を満たす
100%データが1≦n≦10を満たす
楼教主論文の問題.
最初は無邪気に考えて、10!秒が過ぎて、それから20だと気づきました!のです...
しかし、行が確定すると、列間には制約関係がなく、後ろの10!実際にはマッチングをしていますが、これは実際には最大マッチングで実現できます.
しかし、実際には行を検索するたびに列が一致するのは、直接検索するよりも遅い.
mtのスレッドを見て、1行検索するたびに、一致して、大量の枝を切って、スピードが速いです.
そこで,長い最適化過程に足を踏み入れた.
まず、行を検索するたびに、エッジを1回連続して、一致して、タイムアウトは4.5 sに超えます.
検索を前後に変更すると、結果は10.4 sになります(mtが後から前になる理由がやっと分かりました.あまりにも厚かましいです)
検索しながら動的にエッジを接続し、一致します.
やはりタイムアウトして2つの点があって、しかし最も遅いのは1.9 sだけです
一晩反省して、毎回私はマッチングしないで、マッチングが破壊された点だけに対して拡張の道を探して、急に速くなって、ただ1つの点を超えて、しかも最も遅いのは1.43 sだけです
しかし、その点はなかなか調整できず、mtよりもはるかに遅いので、おそらくmtの大好きなビット演算で最適化するしかないでしょう..
まず私のです.

{$inline on}
var b:array[1..10,1..10]of longint;
    map:array[1..20,0..20]of boolean;
    b1:array[1..20,0..20]of longint;
    c:array[1..20]of boolean;
    a:array[1..20,1..10]of longint;
    f,g,t,f1:array[0..20]of longint;
    n:longint;
function edmonds(x:longint):boolean;inline;
var i,ne:longint;
begin
 for i:=1 to b1[x,0] do begin
  ne:=b1[x,i];
  if (c[ne]) and (map[x,ne]) and (f[ne]=0) then begin
   c[ne]:=false;
   if (g[ne]=0)or(edmonds(g[ne])) then begin
    g[ne]:=x;t[x]:=ne;
    exit(true)
   end
  end
 end;
 exit(false)
end;
procedure link(x,y:longint);inline;
begin
 inc(b1[x,0]);b1[x,b1[x,0]]:=y
end;
function change(x:longint):boolean;inline;
var i,j,k,ans:longint;
begin
 if x=0 then exit(true);
 for i:=1 to n do if (not(map[i,t[i]]))or(f[t[i]]<>0) then g[t[i]]:=0;
 for i:=1 to n do
 if not(map[i,t[i]])or(f[t[i]]<>0) then begin
  fillchar(c,sizeof(c),true);
  if not edmonds(i) then exit(false);
 end;
 exit(true)
end;
procedure getout;inline;
var i,k,j:longint;
begin
 for i:=1 to n do write(f1[i],' ');writeln;
 for i:=1 to n do write(t[i],' ');writeln;
 for i:=1 to n do
  for k:=1 to n do
   if a[t[i],k]<>2 then b[k,i]:=a[t[i],k];
 for i:=1 to n do begin
  for j:=1 to n do if b[i,j]<>2 then write(b[i,j]) else write(0);
  writeln
 end;
 close(input);close(output);
 halt
end;
procedure dfs(x:longint);inline;
var i,j,k:longint;
    b2:array[1..10]of longint;
    map1:array[1..20,0..20]of boolean;
    g1,t1:array[0..20]of longint;
begin
 if not change(x-1) then exit;
 if x>n then
  getout;
 for i:=n<<1 downto 1 do
  if f[i]=0 then begin
   f[i]:=x;f1[x]:=i;
   b2:=b[x];map1:=map;g1:=g;t1:=t;
   for j:=1 to n do begin
    if a[i,j]<>2 then begin b[x,j]:=a[i,j]; end;
    for k:=1 to b1[j,0] do
     if (a[b1[j,k],x]<>2)and(b[x,j]<>2)and(a[b1[j,k],x]<>b[x,j]) then map[j,b1[j,k]]:=false;
   end;
   dfs(x+1);
   b[x]:=b2;map:=map1;g:=g1;t:=t1;
   f[i]:=0;
  end
end;
procedure init;
var i,j:longint;
    x:char;
begin
 readln(n);
 for i:=1 to n<<1 do begin
  for j:=1 to n  do begin
   read(x);a[i,j]:=ord(x)-48
  end;
  readln
 end;
 fillchar(f,sizeof(f),0);
 fillchar(b1,sizeof(b1),0);
 fillchar(map,sizeof(map),true);
 for i:=1 to n do map[i,0]:=false;
 for i:=1 to n do for j:=1 to n<<1 do link(i,j);
 for i:=1 to n do for j:=1 to n do b[i,j]:=2;f[0]:=1;
 dfs(1)
end;
begin
assign(input,'milk.in');reset(input);
assign(output,'milk.out');rewrite(output);
 init;
close(input);close(output)
end.

さらにmtの:

{$inline on}
program mt;
type
  l20 = array[0 .. 20] of longint;
  shortint = longint;
const
  inf = 'milk.in';
  ouf = 'milk.out';
var
  e, f, g, x, p: l20;
  v, u: array[1 .. 20] of boolean;
  a: array[1 .. 20, 1 .. 10] of shortint;
  b: array[1 .. 20, 0 .. 1] of longint;
  i, j, n, n2: longint;
  st: string;

function find(i: longint): boolean; inline;
var
  j: longint;
begin
  for j := 1 to n2 do
    if not v[j] and (e[j] and p[i] > 0) then begin
      v[j] := true;
      if (f[j] = 0) or find(f[j]) then begin
        f[j] := i; g[i] := j; exit(true)
        end;
      end;
  find := false
end;

function change: boolean; inline;
begin
  for i := 1 to n do
    if u[g[i]] or (e[g[i]] and p[i] = 0) then begin
      f[g[i]] := 0; g[i] := 0; v := u;
      if not find(i) then exit(false)
      end;
  change := true
end;

procedure dfs(d: longint); inline;
var
  i: longint; ee, ff, gg: l20;
begin
  if not change then exit;
  if d > n then begin
    for i := 1 to n do write(x[i], ' '); writeln;
    for i := 1 to n do write(g[i], ' '); writeln;
    for i := 1 to n do begin
      for j := 1 to n do
        if a[x[i], j] = 2 then write(a[g[j], i] and 1)
        else write(a[x[i], j] and 1);
      writeln
      end;
    close(input); close(output);
    halt
    end;
  ee := e; ff := f; gg := g;
  for i := n2 downto 1 do
    if not u[i] then begin
      x[d] := i; u[i] := true;
      for j := 1 to n2 do
        if not u[j] and (a[j, d] <> 2) then
          e[j] := e[j] and b[i, a[j, d]];
      dfs(d + 1); e := ee; f := ff; g := gg;
      u[i] := false;
      end;
end;

BEGIN
  assign(input, inf); reset(input);
  assign(output, ouf); rewrite(output);

  readln(n); n2 := n * 2;
  p[1] := 1;
  for i := 2 to n + 1 do p[i] := p[i - 1] shl 1;
  for i := 1 to n2 do begin
    readln(st);
    for j := 1 to n do begin
      a[i, j] := ord(st[j]) - ord('0');
      if a[i, j] <> 0 then b[i, 1] := b[i, 1] or p[j];
      if a[i, j] <> 1 then b[i, 0] := b[i, 0] or p[j];
      end;
    e[i] := p[n + 1] - 1;
    end;
  for i := 1 to n do begin
    f[i] := i; g[i] := i;
    end;
  dfs(1);
END.