Informatika gyűjtemény

Egy szinttel feljebb fn_lovag.pas

2004050607080910

<<  23. óra  >>

<<  Lovagok és lókötők  >>

NézetNyomtat

fn_lovag.pas (Vissza)
Az alábbi letöltési lehetőségek közül választhatsz: (segítség)
Karakterkódolás:
Sortörés:
Típus: text/plain
Tartalmaz szöveget
Karakterkódolás: us-ascii
Méret: 4 KB
program lovag;

var n,m,h,p :longint;
    a :array[1..502,1..502] of byte;
    t,t1 :text;

procedure beolvas;
var i,j,b,c,d :longint;
    e,e1 :char;
begin
    readln(t,n,m);
    for i:=1 to 502 do
    begin
        for j:=1 to 502 do
        begin
            a[i,j]:=0;
        end;
    end;
    for i:=1 to m do
    begin
        read(t,b);
        read(t,e1);
        read(t,e);
        if e='T' then
        begin
            read(t,c);
            if (c<>b) then
            begin
                a[i,b]:=1;
                a[i,c]:=1;
            end;
        end
        else if e='L' then
        begin
            read(t,c);
            a[i,b]:=1;
            a[i,c]:=1;
            a[i,n+1]:=1;
        end
        else if e='S' then
        begin
            read(t,c,d);
            a[i,b]:=(a[i,b]+1) mod 2;
            a[i,c]:=(a[i,c]+1) mod 2;
            a[i,d]:=(a[i,d]+1) mod 2;
            a[i,n+1]:=1;
       end
       else if e='D' then
       begin
           read(t,c,d);
           a[i,b]:=(a[i,b]+1) mod 2;
           a[i,c]:=(a[i,c]+1) mod 2;
           a[i,d]:=(a[i,d]+1) mod 2;
       end;
       if i<m then readln(t);
    end;
    {writeln;
    for i:=1 to m do
    begin
        for j:=1 to n+1 do
        begin
            write(a[i,j],' ');
        end;
        writeln;
    end;}
end;

procedure gauss;
var i,j,k,l,o,max,min :longint;
    aa :array[1..502] of byte;
begin
    o:=0;
    if n>m then max:=n else max:=n;
    if n<m then min:=n else min:=m;
    for i:=1 to n do
    begin
        if i-o<=n then
        begin
            if a[i-o,i]=1 then
            begin
                for j:=1 to m do
                begin
                    if i-o<>j then
                    begin
                        if a[j,i]=1 then
                        begin
                            for k:=1 to n+1 do
                            begin
                                a[j,k]:=(a[j,k]+a[i-o,k]) mod 2;
                            end;
                        end;
                    end;
                end;
            end
            else
            begin
                j:=i-o;
                while (a[j,i]<>1) and (j<=m) do
                begin
                    j:=j+1;
                end;
                if j<=m then
                begin
                    for k:=1 to n+1 do
                    begin
                        aa[k]:=a[j,k];
                    end;
                    for k:=1 to n+1 do
                    begin
                        a[j,k]:=a[i-o,k];
                    end;
                    for k:=1 to n+1 do
                    begin
                        a[i-o,k]:=aa[k];
                    end;
                    for j:=1 to m do
                    begin
                        if i-o<>j then
                        begin
                            if a[j,i]=1 then
                            begin
                                for k:=1 to n+1 do
                                begin
                                    a[j,k]:=(a[j,k]+a[i-o,k]) mod 2;
                                end;
                            end;
                        end;
                     end;
                end
                else o:=o+1;
            end;
        end;
    end;
    {writeln;
    for i:=1 to m do
    begin
        for j:=1 to n+1 do
        begin
             write(a[i,j],' ');
        end;
        writeln;
    end;}
end;

procedure lo;
var i,j,s :longint;
    x :array[1..502] of char;
    y :array[1..502] of longint;
begin
    for i:=1 to 502 do
    begin
        x[i]:='-';
    end;
    for i:=1 to m do
    begin
        s:=0;
        for j:=1 to n do
        begin
            if a[i,j]=1 then s:=s+1;
        end;
        y[i]:=s;
    end;
    for i:=1 to m do
    begin
        if y[i]=1 then
        begin
            for j:=1 to n do
            begin
                if a[i,j]=1 then
                begin
                    if a[i,n+1]=1 then x[j]:='T'
                    else x[j]:='L';
                end;
            end;
        end;
    end;
    for i:=1 to n do
    begin
        write(t1,x[i],' ');
    end;
end;




begin
assign(t,'D-large.in');
reset(t);
assign(t1,'D-large.out');
rewrite(t1);
readln(t,h);
for p:=1 to h do
begin
    beolvas;
    if p<>1 then writeln(t1);
    write(t1,'Case',' #',p,':',' ');
    gauss;
    lo;
end;
close(t);
close(t1);
end.



(Vissza)