DUzun's Web
Programare, proiecte personale, divertisment

USES crt,USudoku,windos,strings,dos;

var name: string;

    nr: longint;

    st: array[domen,domen] of 0..n*n;

    nf: integer;

​

Procedure GenFil;

    var f: text;

        fn,ns: string;

        i: byte;

        DirInfo: TSearchRec;

Begin

    if nr=0 then

    repeat

        str(nr,ns);

        for i:=1 to 5-length(ns) do ns:='0'+ns;

        fn:='St'+ns+'.sdk';

        FindFirst(fn, faanyfile, DirInfo);

        inc(nr);

    until DosError <> 0

    else begin

        str(nr,ns);

        for i:=1 to 5-length(ns) do ns:='0'+ns;

        fn:='St'+ns+'.sdk';

        inc(nr);

    end;

    Assign(f,fn);

    rewrite(f);

    for y:=1 to n*n do

    begin

        for x:=1 to n*n do write(f,HexChr(st[x,y]));

        writeln(f);

    end;

    close(f);

end;

​

procedure reduce;

begin

    for x:=1 to n*n do for y:=1 to n*n do

    begin

        z:=n*n+1;

        repeat

            dec(z);

        until (z=0)or(tabla[x,y,z]=1);

        st[x,y]:=z;

    end;

end;

​

procedure genereaza;

    var chek:boolean;

    procedure rand;

        const mnv=n*n*n*n;

        var nv:0..mnv;

    begin

        nv:=0;

        repeat

            nv:=nv+1;chek:=true;

            x:=random(n*n)+1;

            y:=random(n*n)+1;

            z:=random(n*n)+1;

            if tabla[x,y,z]=2 then

            begin

                bif(x,y,z,cl[5]);

                st[x,y]:=z;

                chek:=false;

            end;

        until not chek or (nv=mnv);

    end;

​

begin

    randomize;

    repeat

        repeat

        rand;

        rezolva;

        until comp or chek;

        if not comp then

        begin

            anula;

            delete;

            for x:=1 to n*n do

                for y:=1 to n*n do

                    st[x,y]:=0;

        end;

    until comp;

end;

​

Procedure addtof(flr:integer);

    const dn=2*n*n+1;

    var f: text;

        fn,ns: string;

        i,nf: byte;

        doc: array[1..dn,1..dn]of char;

​

    Procedure Fereastra;

        var e: array[0..24] of char;

            x, y: array[1..100] of byte;

            i, j: byte;

​

        procedure writeif(x,y:byte;c:char);

        begin

            if ord(c)=32 then doc[x,y] := hexchr(st[x div 2,y div 2])

            else doc[x,y] := c;

            gotoxy(x,y);

            write(c);

        end;

​

    begin

        e[0]:=#201; e[5]:=#186; e[10]:=#199; e[15]:=#204; e[20]:=#200;

        e[1]:=#205; e[6]:=#32;  e[11]:=#196; e[16]:=#205; e[21]:=#205;

        e[2]:=#209; e[7]:=#179; e[12]:=#197; e[17]:=#216; e[22]:=#207;

        e[3]:=#203; e[8]:=#186; e[13]:=#215; e[18]:=#206; e[23]:=#202;

        e[4]:=#187; e[9]:=#186; e[14]:=#182; e[19]:=#185; e[24]:=#188;

​

        for i:=1 to 2*n*n do

        begin

            x[i]:=((i-1)mod 2)+1+(((i-1)mod(2*n))+1)div(2*n)+i div(2*n*n);

            y[i]:=5*x[i];

        end;

​

        writeif(1,1,e[0]);

​

        for i:=1 to 2*n*n do

        begin

            writeif(i+1,1,e[x[i]]);

            writeif(1,i+1,e[y[i]]);

        end;

​

        for i:=1 to 2*n*n do

            for j:=1 to 2*n*n do

                writeif(i+1,j+1,e[x[i]+y[j]]);

    end;

​

    Procedure store;

        var i,j:byte;

    begin

        writeln(f,nf);

        for i:=1 to dn do

        begin

            for j:=1 to dn do

                write(f,doc[j,i]);

            writeln(f);

        end;

        writeln(f);

    end;

​

    Begin

        fn:='Sudoku.doc';

        Assign(f,fn);rewrite(f);

        nf:=0;

        repeat

            inc(nf);

            anula;

            for x:=1 to n*n do

                for y:=1 to n*n do

                    st[x,y]:=0;

            genereaza;

            Fereastra;

            store;

            writeln(nf);

        until nf=flr;

        close(f);

    end;

​

Procedure attr;

begin

    cl[25]:=textattr;

    cl[1]:=$1f;

    for i:=2 to 25 do

        cl[i] := fonc(cl[1]);

​

    cl[2] := fonc(cl[1])+$2;

    cl[3] := fonc(cl[1])+$9;

    cl[4] := fonc(cl[1])+$d;

    cl[5] := fonc(cl[1])+$b;

    textattr := cl[1];

    clrscr;

    nr:=0;

​

    for x:=1 to n*n do

        for y:=1 to n*n do

            st[x,y]:=0;

end;

​

begin

    attr;

    Write('Nr. de stadii: ');readln(nf);

    addtof(nf);

    {

    repeat

        anula;

        for x:=1 to n*n do

            for y:=1 to n*n do

                st[x,y]:=0;

        genereaza;

        genfil;

    until keypressed;

    }

end.

​

​