Tô màu

Nhấn vào đây để tải về
Nhắn tin cho tác giả
Báo tài liệu sai quy định
Xem toàn màn hình
Mở thư mục chứa tài liệu này
(Tài liệu chưa được thẩm định)
Nguồn: sưu tầm
Người gửi: Huỳnh Đức Duy (trang riêng)
Ngày gửi: 15h:05' 13-01-2012
Dung lượng: 97.5 KB
Số lượt tải: 2
Số lượt thích: 0 người
Bài toán tô màu

Uses Crt;
Const Max = 20;
Fi = `Tomau0.inp`;
Var A : Array[1..Max,1..Max] of 0..1;
Mau,LMau : Array[1..Max] of Byte;
N,i : Integer;
Somauxudung,SoMauMax : Integer;

Procedure TaoF;
Var i,j,x : Byte;f : Text;
Begin
Assign(f,fi); Rewrite(f);
Randomize;
Writeln(f,Max);
n := Max;
For i:=1 to n-1 do
For j:=i+1 to n do
Begin
x := random(2);
If x =1 then Writeln(f,i:4,j:4);
End;
Close(f);
End;

Procedure NhapFile;
Var i,j : Integer;
F : Text;
Begin
FillChar(A,Sizeof(A),0);
Assign(F,Fi); Reset(F);
Readln(F,N);
While not Eof(F) do
Begin
Read(F,i);
While not eoln(F) do
Begin
Read(F,j);
A[i,j] := 1; A[j,i] := 1;
End;
Readln(F);
End;
End;

Procedure Hien;
Var i,j : Integer;
Begin
Writeln;
For i:=1 to N do
Begin
For j:=1 to N do Write(A[i,j]:4);
Writeln;
End;
End;

Procedure Khoitri;
Begin
FillChar(Mau,sizeof(Mau),0);
SoMauMax := N;
Somauxudung := 1;
Mau[1] := 1;
End;

Function Kt(x,m : Integer): Boolean;{ Mau m gan cho dinh x }
Begin
For i:=1 to N do
If (A[x,i]=1) and (m=Mau[i]) then
Begin Kt := False;Exit;End;
Kt := True;
End;

Procedure Tomau(x : Integer); { To mau cho dinh x }
Var m,luu,Luumaux : Integer;
Begin
If x=N+1 then
Begin
LMau := Mau;
SoMauMax := Somauxudung;
Exit
End;
m := 1;
While m<=SoMauMax do
Begin
If (KT(x,m)) then
Begin
LuuMaux := Mau[x];
Mau[x] := m;
Luu := Somauxudung;
If Somauxudung Tomau(x+1);
Somauxudung := Luu;
Mau[x] := LuuMaux;
End;
Inc(m);
End;
End;

Procedure Thongbao;
Var i : Integer;
Begin
For i:=1 to N do
Writeln( ` Diem `,i:2,` to mau : `,LMau[i]);
End;

BEGIN
Clrscr;
{ TaoF;}
NhapFile;
Hien;
Khoitri;
Tomau(2);
Thongbao;
END.


Cách 2 : Greedy tô màu đỉnh nào có bậc cao trước

Uses Crt;
Const Max = 100;
Fi = `Tomau3.inp`;
Fo = `Tomau.out`;
Type KM = Array[1..Max] of Byte;
KA = Array[1..Max,1..Max] of 0..1;
Var M,B,L: KM;
A : KA;
N : Byte;

Procedure NhapF;
Var i,j : Byte;
F : Text;
Begin
Assign(F,Fi);
{$I-}Reset(F);{$I+}
If IoResult<>0 then
Begin
Writeln(`Loi File `,Fi);
Readln;
Halt;
End;
Readln(F,N);
For i:=1 to N do
For j:=1 to N do A[i,j] := 0;
For