Informatika gyűjtemény

Egy szinttel feljebb komfel_javsize.pas

2004050607080910

<<  8. óra  >>

<<  Kömal fórum feladat  >>

NézetNyomtat

komfel_javsize.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: utf-8
Méret: 3 KB
program komfel; {Javította: EP 2009.11.14.}{SIZE param}

{$R+}

const   
    SIZE = 6;

var 
    a : array[1..512,1..64] of byte; {elemek}
    elemdb : integer; {lehetséges részhalmazok száma}
    tom : array[1..64] of byte; {a pillanatnyilag fedett mezők}
    y : array[1..SIZE*SIZE div 4+1] of integer; {BT döntési változók: a beválogatott részhalmazok}
    mdb : integer; {megoldások száma}



procedure elemgen;
var i,j,k : integer; {nem használunk globális ciklusváltozókat!!!}
begin
    for i:=1 to 512 do 
        for j:=1 to 64 do 
             a[i,j]:=0; 
    
    j:=0; {ebben lesz az előállított részhalmazok száma}

    for k:=0 to SIZE-2 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-2 do begin inc(j);   // ***
    a[j,i]:=1; a[j,i+1]:=1; a[j,i+2]:=1; a[j,i+SIZE]:=1; end; end;     // *

    for k:=0 to SIZE-2 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-2 do begin inc(j);   // ***
    a[j,i]:=1; a[j,i+1]:=1; a[j,i+2]:=1; a[j,i+SIZE+2]:=1; end; end;   //   *

    for k:=1 to SIZE-1 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-2 do begin inc(j);   // *
    a[j,i]:=1; a[j,i+1]:=1; a[j,i+2]:=1; a[j,i-SIZE]:=1; end; end;     // ***

    for k:=1 to SIZE-1 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-2 do begin inc(j);   //   *
    a[j,i]:=1; a[j,i+1]:=1; a[j,i+2]:=1; a[j,i-SIZE+2]:=1; end; end;   // ***

    for k:=0 to SIZE-3 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-1 do begin inc(j);   // *
    a[j,i]:=1; a[j,i+SIZE]:=1; a[j,i+2*SIZE]:=1;                           // *
    a[j,i+2*SIZE+1]:=1; end; end;                                       // **

    for k:=0 to SIZE-3 do begin for i:=k*SIZE+1 to k*SIZE+SIZE-1 do begin inc(j);   // **
    a[j,i]:=1; a[j,i+SIZE]:=1; a[j,i+2*SIZE]:=1;                           // *
    a[j,i+1]:=1; end; end;                                          // *

    for k:=0 to SIZE-3 do begin for i:=k*SIZE+2 to k*SIZE+SIZE do begin inc(j);   // **
    a[j,i]:=1; a[j,i+SIZE]:=1; a[j,i+2*SIZE]:=1;                           //  *
    a[j,i-1]:=1; end; end;                                          //  *

    for k:=0 to SIZE-3 do begin for i:=k*SIZE+2 to k*SIZE+SIZE do begin inc(j);   //  *
    a[j,i]:=1; a[j,i+SIZE]:=1; a[j,i+2*SIZE]:=1;                           //  *
    a[j,i+2*SIZE-1]:=1; end; end;                                       // **

    elemdb := j;
end;

procedure init;
var i : integer;
begin
    elemgen;
    for i:=1 to SIZE*SIZE do tom[i]:=0;
    for i:=1 to SIZE*SIZE div 4 do y[i]:=0;
    mdb := 0;
    writeln('elemek száma: ',elemdb);
end;


procedure dump(lol:integer);
var i,j : integer;
begin
    writeln('mdb: ',mdb);
    for i:= 1 to SIZE do write(y[i],' ');
    writeln;
    
    for i:= 1 to SIZE*SIZE do write(tom[i]);
    writeln;
    
    for i:= 1 to lol do
    begin
        write(y[i]:3,' : ');
        for j := 1 to SIZE*SIZE do
            if a[y[i],j]=1 then write(j,' ');
        writeln;
    end;
    writeln;        
    {readln;}   
end;

function joe(n:integer):boolean;
var ii,bulin:integer;
begin  
    bulin:=1;
    for ii:=1 to SIZE*SIZE do 
    begin 
        if (a[y[n],ii]=1) and (tom[ii]=1) then bulin:=0; 
    end;
    if bulin=0 then joe:=false else joe:=true;
end;

procedure ber(n:integer);
var i : integer; 
begin 
    for i := 1 to SIZE*SIZE do 
    begin 
        if a[n,i]=1 then tom[i]:=1; 
    end; 
end;

procedure kir(n:longint);
var i : integer; 
begin 
    for i := 1 to SIZE*SIZE do 
    begin 
        if a[n,i]=1 then tom[i]:=0; 
    end; 
end;


procedure helyez(lol:integer);
begin
    if lol<>0 then 
    begin
        if lol=(SIZE*SIZE div 4+1) then 
        begin
            inc(mdb);
            dump(SIZE*SIZE div 4);
            {exit;}
        end else 
        begin
            inc(y[lol]);
            while (y[lol] <= elemdb) do 
            begin
                if joe(lol) then 
                begin
                    ber(y[lol]); 
                    y[lol+1]:=y[lol];
                    
                    helyez(lol+1);
                    
                    kir(y[lol]);
                end; 
                
                inc(y[lol]);
            end;
            
        end;
    end;
end;



begin
    init;
    helyez(1);
end.
(Vissza)