Informatika gyűjtemény

Egy szinttel feljebb lbetu.pas

2004050607080910

<<  8. óra  >>

<<  Kömal fórum feladat  >>

NézetNyomtat

lbetu.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: 3 KB
program lbetu;

var i:integer; xd:int64; //i:ciklusvalt xd:megoldasdbszam q:file
a:array[0..1337,1..64] of byte; d:integer; //a: elemek tombje, d:elemek szama
m:array[1..64] of byte; //eddig berakott helyek (amit lefedtunk)
y:array[0..18] of integer; //dontesi tomb

procedure ber(k:integer); //berak az m tombbe (k sorszamu elemet)
var c:integer; begin
for c:=1 to 64 do if a[k,c]=1 then m[c]:=1; end;

procedure kiv(k:integer); //kivesz az m tombbol (k sorszamu elemet)
var c:integer; begin
for c:=1 to 64 do if a[k,c]=1 then m[c]:=0; end;

function joe(l:integer):boolean; //be lehet e rakni ugy hogy elso ures helyet
var c,buli,lk:integer; begin buli:=1;    //fedje
for c:=1 to 64 do if (a[l,c]=1) and (m[c]=1) then buli:=0;
for c:=64 downto 1 do if m[c]=0 then lk:=c; //megkeressuk legkisebb helyet
if a[l,lk]=0 then buli:=0;
if buli=0 then joe:=false else joe:=true; end;

procedure elemcsin; //elemeket generaljuk
var c,k:integer; //ciklusvaltozok
begin
for c:=1 to 64 do m[c]:=0; for c:=0 to 18 do y[c]:=0;           //nullaz
for c:=0 to 1337 do for k:=1 to 64 do a[c,k]:=0; d:=0;
                                        //elem generalas, es darab szamlalas
for k:=0 to 6 do begin for c:=k*8+1 to k*8+6 do begin inc(d);   // ***
a[d,c]:=1; a[d,c+1]:=1; a[d,c+2]:=1; a[d,c+8]:=1; end; end;     // *
for k:=0 to 6 do begin for c:=k*8+1 to k*8+6 do begin inc(d);   // ---
a[d,c]:=1; a[d,c+1]:=1; a[d,c+2]:=1; a[d,c+8+2]:=1; end; end;   //   -
for k:=1 to 7 do begin for c:=k*8+1 to k*8+6 do begin inc(d);   // *
a[d,c]:=1; a[d,c+1]:=1; a[d,c+2]:=1; a[d,c-8]:=1; end; end;     // ***
for k:=1 to 7 do begin for c:=k*8+1 to k*8+6 do begin inc(d);   //   -
a[d,c]:=1; a[d,c+1]:=1; a[d,c+2]:=1; a[d,c-8+2]:=1; end; end;   // ---
for k:=0 to 5 do begin for c:=k*8+1 to k*8+7 do begin inc(d);   // *
a[d,c]:=1; a[d,c+8]:=1; a[d,c+16]:=1;                           // *
a[d,c+16+1]:=1; end; end;                                       // **
for k:=0 to 5 do begin for c:=k*8+1 to k*8+7 do begin inc(d);   // --
a[d,c]:=1; a[d,c+8]:=1; a[d,c+16]:=1;                           // -
a[d,c+1]:=1; end; end;                                          // -
for k:=0 to 5 do begin for c:=k*8+2 to k*8+8 do begin inc(d);   // **
a[d,c]:=1; a[d,c+8]:=1; a[d,c+16]:=1;                           //  *
a[d,c-1]:=1; end; end;                                          //  *
for k:=0 to 5 do begin for c:=k*8+2 to k*8+8 do begin inc(d);   //  -
a[d,c]:=1; a[d,c+8]:=1; a[d,c+16]:=1;                           //  -
a[d,c+16-1]:=1; end; end;                                       // --
end;

procedure kiir; //kiirunk fileba...
var c,k:integer; begin
//for c:=1 to 16 do begin for k:=1 to 64 do write(a[y[c],k]); writeln(); end;
writeln(); inc(xd); writeln(xd); end;

begin
elemcsin; xd:=0; i:=1; //elem csinal, file csin

while (i>0) do begin                          //amig nincs osszes megoldas
if i<17 then begin                    //ha meg nincs meg megoldas: backtrack
  inc(y[i]); {novel}
  while (y[i]<=d) and (not(joe(y[i]))) do inc(y[i]); {amig nem jo: novel}
  if y[i]>d then begin y[i]:=0; dec(i); kiv(y[i]); end {visszalep, vagy:}
  else begin ber(y[i]); inc(i); end; {berak, elorelep}
end else begin                        //ha megoldas: kiir, visszalep
  kiir; y[i]:=0; dec(i); kiv(y[i]); {kivesz, visszalep}
end;
end;

writeln(xd); //kiirdarabszam, filebezar
end.
(Vissza)