(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
(*  Soubor: NURIKABE.PAS                                                   *)
(*  Obsah: program na reseni vybarvovacich hlavolamu                       *)
(*  Autor: Mircosoft (http://mircosoft.mzf.cz)                             *)
(*  Posledni uprava: 11.12.2020                                            *)
(*  Pro kompilaci: nic                                                     *)
(*  Pro spusteni: nic                                                      *)
(*  Upozorneni: tyto zdrojove kody pouzivate na vlastni nebezpeci          *)
(* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *)
{Pravidla (viz https://en.wikipedia.org/wiki/Nurikabe_(puzzle) ):
- Hraci plocha je ctvercova sit obecnych rozmeru. Zadanim je prazdna plocha
  s nekolika cisly.
- Kazde policko muze byt bud vybarvene, nebo nevybarvene.
- Cela vybarvena oblast je souvisla.
- Souvislost znamena, ze se jednotliva policka dotykaji hranou, ne jenom
  rohem.
- Vybarvena oblast nikde netvori souvisle ctverce 2x2 policka.
- Nevybarvenych oblasti je tolik, kolik je zadanych cisel. Kazda nevybarvena
  oblast je souvisla a zacina na policku s cislem.
- Zadne dve nevybarvene oblasti se nesmi navzajem dotykat hranou. Dotyk rohem
  je dovoleny.
- Cilem je prijit na tvar vsech oblasti a spravne vybarvit hraci plochu.

 Program se pokousi tyhle hlavolamy resit. Umi jenom par jednoduchych
mechanickych postupu, nezvlada uvahy typu "tyhle dva vybarvene kousky se daji
propojit jedine tudy, protoze tamhle prekazi policko s cislem" nebo "s timhle
prazdnym polickem se muze spojit jedine tamhleta ctyrka, takze ji k nemu
musim protahnout a tamhleten volny kousek na druhe strane vybarvit".

 Pouzite algoritmy: prohledavani pole hrubou silou a rekurzivni pruchod
do sirky. Omlouvam se za vsechny ty globalni promenne a podobne prasarny,
programek jsem spichnul za jeden vecer a slo mi jenom o overeni principu.}

program lamohlav;
{$S+} {Rekurzivni prohledavani pole muze byt dost narocne na zasobnik, tak
radsi nechavam zapnutou kontrolu pretekani. V pripade chyby "stack overflow"
zvetsete tadyto prvni cislo:}
{$M 16384,0,655360}

const MaxSirka=10; MaxVyska=10;

type StavPolicka=(nevim, {ve vypisech znaceno '?', cilem je se jich zbavit}
                  prazdne,                   {'.'}
                  vybarvene);                {'#'}

var Zadani:array[1..maxvyska,1..maxsirka] of byte; {pole se zadanymi cisly,
                                    vyplnuje se na zacatku hlavniho programu}
    Sirka,Vyska:byte; {rozmery zadaneho hlavolamu}
    Vysledek:array[1..maxvyska,1..maxsirka] of stavpolicka; {pole pro
                                                   prubezne ukladani vysledku}
    {ruzne pomocne a pracovni promenne:}
    CislaOblasti:array[1..maxvyska,1..maxsirka] of integer;
    PoleBoolu,PoleBoolu2:array[1..maxvyska,1..maxsirka] of boolean;
    i,j,i2,j2,moznei,moznej:integer;
    KrokSePovedl,NecoSePovedlo:boolean;
    PocetPrazdnych,PocetVybarvenych,PocetNeznamych:word;


procedure Vypis(hlaska:string);
{vypise danou hlasku, za ni pole Vysledek a pocka na odklepnuti Enterem}
var i,j:integer;
    odpoved:string[30];
Begin
writeln(hlaska);
for i:=1 to vyska do
 begin
 for j:=1 to sirka do
  case vysledek[i,j] of prazdne:if zadani[i,j]=0 then write(' .')
                                                 else write(zadani[i,j]:2);
                        vybarvene:write(' #');
                        else write(' ?');
                        end;
 writeln;
 end;
write('(Enter = pokracovat, cokoli+Enter = konec)');
readln(odpoved);
if odpoved<>'' then halt;
End;{vypis}

procedure VyznacDosah(i,j,cislo:integer);
{rekurzivne prochazi pole Vysledek a kam se od zadaneho bodu da dojit po
prazdnych a neznamych polickach, tam v PoliBoolu nahazuje True}
Begin
if (cislo<=0)or(vysledek[i,j]=vybarvene)or(poleboolu[i,j]) then exit;
poleboolu[i,j]:=true;
if cislo>1 then begin
                if i>1 then vyznacdosah(i-1,j,cislo-1);
                if i<vyska then vyznacdosah(i+1,j,cislo-1);
                if j>1 then vyznacdosah(i,j-1,cislo-1);
                if j<sirka then vyznacdosah(i,j+1,cislo-1);
                end;
End;{vyznacdosah}

procedure OcislujOblasti;{Vsem oblastem priradi poradova cisla. Vybarvenym
dava kladna, prazdnym zaporna. Vysledky budou v poli CislaOblasti,
celkove pocty oblasti v PocetPrazdnych a PocetVybarvenych.}
var i,j:integer;
    CisloVybarvene,CisloPrazdne:integer;
 procedure OcislujOblast(y,x,cislo:integer; stav:stavpolicka);{rekurzivni}
 Begin
 if (cislaoblasti[y,x]<>0)or(vysledek[y,x]<>stav) then exit;
 cislaoblasti[y,x]:=cislo;
 if y>1 then ocislujoblast(y-1,x,cislo,stav);
 if y<vyska then ocislujoblast(y+1,x,cislo,stav);
 if x>1 then ocislujoblast(y,x-1,cislo,stav);
 if x<sirka then ocislujoblast(y,x+1,cislo,stav);
 End;{ocislujoblast}
Begin{ocislujoblasti}
fillchar(cislaoblasti,sizeof(cislaoblasti),0);
pocetprazdnych:=0; pocetvybarvenych:=0;
cislovybarvene:=1; cisloprazdne:=-1;
for i:=1 to vyska do
 for j:=1 to sirka do
  if (cislaoblasti[i,j]=0)
     and((vysledek[i,j]=vybarvene) {vybarvene oblasti muzeme cislovat libovolne}
         or(zadani[i,j]<>0)) {prazdne kousky nenapojene na zadana policka musime ignorovat}
    then case vysledek[i,j] of
          prazdne:begin
                  ocislujoblast(i,j,cisloprazdne,prazdne);
                  dec(cisloprazdne);
                  inc(pocetprazdnych);
                  end;
          vybarvene:begin
                    ocislujoblast(i,j,cislovybarvene,vybarvene);
                    inc(cislovybarvene);
                    inc(pocetvybarvenych);
                    end;
          end;
End;{ocislujoblasti}

procedure VyznacNeznameOkolo(y,x:integer; stav:stavpolicka);
{v PoliBoolu nastavi na True souvislou oblast o danem stavu zacinajici
na danych souradnicich a vsechna sousedici neznama policka (rekurzivne)}
Begin
if poleboolu[y,x] then exit;
if (vysledek[y,x]=nevim)or(vysledek[y,x]=stav) then poleboolu[y,x]:=true;
if vysledek[y,x]=stav then begin
                           if y>1 then vyznacneznameokolo(y-1,x,stav);
                           if y<vyska then vyznacneznameokolo(y+1,x,stav);
                           if x>1 then vyznacneznameokolo(y,x-1,stav);
                           if x<sirka then vyznacneznameokolo(y,x+1,stav);
                           end;
End;{vyznacneznameokolo}

{procedure VypisCislaOblasti;     jenom pro ladeni, uz se nepouziva
var i,j:integer;
Begin
for i:=1 to vyska do
 begin
 for j:=1 to sirka do write(cislaoblasti[i,j]:2);
 writeln;
 end;
End;{vypiscislaoblasti}

BEGIN
writeln('====================================');
{zadani:}
fillchar(zadani,sizeof(zadani),0);

{zadani 1 - male a jednoduche:
sirka:=4; vyska:=4;
zadani[2,1]:=1;
zadani[2,3]:=1;
zadani[3,4]:=2;
zadani[4,2]:=2;{}

{zadani 2 - tezke:
sirka:=7; vyska:=6;
zadani[1,1]:=4;
zadani[1,3]:=1;
zadani[1,7]:=1;
zadani[2,5]:=2;
zadani[4,5]:=3;
zadani[4,7]:=1;
zadani[6,3]:=3;
zadani[6,5]:=3;{}

{zadani 3 - tezke:
sirka:=6; vyska:=6;
zadani[1,2]:=1;
zadani[2,5]:=2;
zadani[3,1]:=3;
zadani[3,6]:=3;
zadani[4,4]:=1;
zadani[6,1]:=1;
zadani[6,4]:=2;{}

{zadani 4 - velke, ale jednoduche:}
sirka:=10; vyska:=10;
zadani[1,1]:=2; zadani[1,4]:=3; zadani[1,7]:=2; zadani[1,10]:=2;
zadani[3,3]:=1; zadani[3,6]:=3; zadani[3,8]:=1;
zadani[4,4]:=2; zadani[4,9]:=2;
zadani[5,2]:=4; zadani[5,8]:=4;
zadani[6,3]:=1;
zadani[7,1]:=2; zadani[7,4]:=2; zadani[7,7]:=2;
zadani[8,3]:=1;
zadani[9,4]:=1; zadani[9,6]:=1; zadani[9,8]:=2;
zadani[10,1]:=2;{}

{zadani 5 - tezke:
sirka:=10; vyska:=9;
zadani[1,1]:=2; zadani[1,10]:=2;
zadani[2,7]:=2;
zadani[3,2]:=2; zadani[3,5]:=7;
zadani[5,7]:=3; zadani[5,9]:=3;
zadani[6,3]:=2; zadani[6,8]:=3;
zadani[7,1]:=2; zadani[7,4]:=4;
zadani[9,2]:=1; zadani[9,7]:=2; zadani[9,9]:=4;{}

{pro jistotu kontrola:}
if (sirka>maxsirka)or(vyska>maxvyska)
  then begin
       writeln('Zadane rozmery prekracuji dovolene maximum ',maxsirka,'x',maxvyska,'.');
       halt;
       end;

{inicializace vysledku:}
for i:=1 to vyska do
 for j:=1 to sirka do
  if zadani[i,j]=0 then vysledek[i,j]:=nevim
                   else vysledek[i,j]:=prazdne;
vypis('Zadano:');

 repeat
 NecoSePovedlo:=false;

 {kdyz jsou vybarvena tri policka ctverce 2x2, ctvrte musi byt prazdne:}
 kroksepovedl:=false;
 for i:=1 to vyska-1 do
  for j:=1 to sirka-1 do
   begin
   pocetvybarvenych:=0;
   pocetneznamych:=0;
   for i2:=i to i+1 do
    for j2:=j to j+1 do
     begin
     case vysledek[i2,j2] of nevim:begin
                                   inc(pocetneznamych);
                                   moznei:=i2;
                                   moznej:=j2;
                                   end;
                             vybarvene:inc(pocetvybarvenych);
                             end;
     end;
   if (pocetvybarvenych=3)and(pocetneznamych=1) {jednoznacne reseni}
     then begin
          vysledek[moznei,moznej]:=prazdne;
          kroksepovedl:=true;
          end;
   end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Vyblokovani ctvrtych policek ctvercu:');
                      end;

 {vsechna policka, kam od zadneho zadaneho cisla nedosahneme, muzeme vybarvit:}
 kroksepovedl:=false;
 fillchar(poleboolu2,sizeof(poleboolu2),false);
 for i:=1 to vyska do
  for j:=1 to sirka do
   if zadani[i,j]<>0 then begin
                          fillchar(poleboolu,sizeof(poleboolu),false);
                          vyznacdosah(i,j,zadani[i,j]);
                          for i2:=1 to vyska do
                           for j2:=1 to sirka do
                            poleboolu2[i2,j2]:=poleboolu2[i2,j2] or poleboolu[i2,j2];
                          end;
 for i:=1 to vyska do
  for j:=1 to sirka do
   if not poleboolu2[i,j] and (vysledek[i,j]=nevim)
     then begin
          vysledek[i,j]:=vybarvene;
          kroksepovedl:=true;
          end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Vybarveni policek, na ktera se odnikud nedosahne:');
                      end;

 {policka mezi dvema prazdnymi policky patricimi k jinym oblastem
 budou urcite vybarvena:}
 kroksepovedl:=false;
 ocislujoblasti;
 for i:=2 to vyska-1 do
  for j:=2 to sirka-1 do
   if (vysledek[i,j]=nevim)
      and((vysledek[i-1,j]=prazdne)and(vysledek[i+1,j]=prazdne)     { A }
          and(cislaoblasti[i-1,j]<>cislaoblasti[i+1,j])             { * }
          and(cislaoblasti[i-1,j]<>0)and(cislaoblasti[i+1,j]<>0)    { B }
          or
          (vysledek[i,j-1]=prazdne)and(vysledek[i,j+1]=prazdne)
          and(cislaoblasti[i,j-1]<>cislaoblasti[i,j+1])           { A * B }
          and(cislaoblasti[i,j-1]<>0)and(cislaoblasti[i,j+1]<>0))
     then begin
          vysledek[i,j]:=vybarvene;
          kroksepovedl:=true;
          end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Vybarveni policek mezi dvema prazdnymi oblastmi - kolmo:');
                      end;

 {podobne pro sikmy smer:}
 kroksepovedl:=false;
 ocislujoblasti;
 for i:=1 to vyska-1 do
  for j:=1 to sirka-1 do
   begin
   if (vysledek[i,j]=prazdne)and(vysledek[i+1,j+1]=prazdne)    { A * }
      and(cislaoblasti[i,j]<>cislaoblasti[i+1,j+1])            { * B }
      and(cislaoblasti[i,j]<>0)and(cislaoblasti[i+1,j+1]<>0)
     then begin
          if vysledek[i+1,j]=nevim then begin
                                        vysledek[i+1,j]:=vybarvene;
                                        kroksepovedl:=true;
                                        end;
          if vysledek[i,j+1]=nevim then begin
                                        vysledek[i,j+1]:=vybarvene;
                                        kroksepovedl:=true;
                                        end;
          end;
   if (vysledek[i,j+1]=prazdne)and(vysledek[i+1,j]=prazdne)     { * A }
      and(cislaoblasti[i,j+1]<>cislaoblasti[i+1,j])             { B * }
      and(cislaoblasti[i,j+1]<>0)and(cislaoblasti[i+1,j]<>0)
     then begin
          if vysledek[i,j]=nevim then begin
                                      vysledek[i,j]:=vybarvene;
                                      kroksepovedl:=true;
                                      end;
          if vysledek[i+1,j+1]=nevim then begin
                                          vysledek[i+1,j+1]:=vybarvene;
                                          kroksepovedl:=true;
                                          end;
          end;
   end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Vybarveni policek mezi dvema prazdnymi oblastmi - sikmo:');
                      end;

 {pokud vybarvena oblast sousedi se samymi prazdnymi policky az na jedno
 nezname, musime ho vybarvit, protoze je to jedina cesta, kudy tu vybarvenou
 oblast muzeme propojit s ostatnimi:}
 kroksepovedl:=false;
 ocislujoblasti;
 if pocetvybarvenych>1 then
  begin
  for i:=1 to vyska do
   begin
   for j:=1 to sirka do
    if vysledek[i,j]=vybarvene
      then begin
           fillchar(poleboolu,sizeof(poleboolu),false);
           vyznacneznameokolo(i,j,vybarvene);
           pocetneznamych:=0;
           for i2:=1 to vyska do
            for j2:=1 to sirka do
             if poleboolu[i2,j2] and (vysledek[i2,j2]=nevim)
               then begin
                    inc(pocetneznamych);
                    moznei:=i2; moznej:=j2;
                    end;
           if pocetneznamych=1 then begin
                                    vysledek[moznei,moznej]:=vybarvene;
                                    kroksepovedl:=true;
                                    break;
                                    end;
           end;
   if kroksepovedl then break; {goto by bylo pohodlnejsi :-)}
   end;
  end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Napojeni vybarvenych oblasti s jednou pripojovaci cestou:');
                      end;

 {prazdne oblasti se nesmi dotykat, takze jakmile nejakou dokoncime, muzeme
 vsechno kolem ni vybarvit:}
 kroksepovedl:=false;
 for i:=1 to vyska do
  for j:=1 to sirka do
   if zadani[i,j]<>0
     then begin
          fillchar(poleboolu,sizeof(poleboolu),false);
          vyznacneznameokolo(i,j,prazdne);
          pocetprazdnych:=0;
          for i2:=1 to vyska do
           for j2:=1 to sirka do
            if poleboolu[i2,j2] and (vysledek[i2,j2]=prazdne)
              then inc(pocetprazdnych);
          if pocetprazdnych=zadani[i,j]
            then begin
                 for i2:=1 to vyska do
                  for j2:=1 to sirka do
                   if poleboolu[i2,j2] and (vysledek[i2,j2]=nevim)
                     then begin
                          vysledek[i2,j2]:=vybarvene;
                          kroksepovedl:=true;
                          end;
                 end;
          end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Vybarveni okoli dokoncenych prazdnych oblasti:');
                      end;

 {policka, ktera tvori jedinou moznou navaznost od zadaneho prazdneho policka
 do volneho prostoru, oznacime jako prazdna:}
 kroksepovedl:=false;
 for i:=1 to vyska do
  for j:=1 to sirka do
   if zadani[i,j]<>0
     then begin
          fillchar(poleboolu,sizeof(poleboolu),false);
          vyznacneznameokolo(i,j,prazdne);
          pocetprazdnych:=0;
          pocetneznamych:=0;
          for i2:=1 to vyska do
           for j2:=1 to sirka do
            if poleboolu[i2,j2] then
              case vysledek[i2,j2] of prazdne:inc(pocetprazdnych);
                                      nevim:begin
                                            inc(pocetneznamych);
                                            moznei:=i2;
                                            moznej:=j2;
                                            end;
                                      end;
          if (pocetprazdnych<zadani[i,j])and(pocetneznamych=1)
            then begin
                 vysledek[moznei,moznej]:=prazdne;
                 kroksepovedl:=true;
                 end;
          end;
 if kroksepovedl then begin
                      necosepovedlo:=true;
                      vypis('Prodlouzeni prazdnych oblasti:');
                      end;

 {kolik nam toho jeste zbyva:}
 pocetneznamych:=0;
 for i:=1 to vyska do
  for j:=1 to sirka do if vysledek[i,j]=nevim then inc(pocetneznamych);
 until (pocetneznamych=0) or not necosepovedlo;

if pocetneznamych=0 then writeln('Hura, povedlo se!')
                    else writeln('Dal to neumim.');
writeln('(Enter = konec)');
readln;
END.