Ondrejove zápalky<\b>
Ondrej sa od mladi rád hrával so zápalkami

{ ONDREJOVE_ZAPALKY.PAS     Copyright (c) TrSek alias Zdeno Sekerak }
{ Riesenie problemu z ksp.sk                                        }
{ Napíšte program, ktorý dostane na vstupe 4 čísla A,B,C,D - počty  }
{ modrých, zelených, červených a ružových zápaliek a zistí,         }
{ či sa dá z nich postavi mnohouholník. Ak sa dá, vypíšte aj farby }
{ zápaliek v poradí, v akom sú uložené na jeho obvode.              }
{ Ak je možností, ako pouklada zápalky, viacero, vypíšte žubovožnú }
{ z nich.                                                           }
{                                                                   }
{ Datum:13.07.2013                             http://www.trsek.com }
 
program Ondrejove_zapalky;
uses crt,dos,graph;
 
type TPole = array[1..40] of integer;
     TPoleXY = array[1..40,1..2] of integer;
 
var m,z,c,r:byte;
     pole:TPole;
    upole:TPoleXY;
    mam:boolean;
    GraphDriver, GraphMode:integer;
 
 
{ skontrolujem ci sa zapalky nebudu krizovat }
{ tento test by bolo vhodne este doplnit }
function TestTah(por:byte):boolean;
var i:integer;
begin
  TestTah:=true;
  for i:=1 to por-1 do begin
    if((upole[i,1]=upole[por,1]) and
       (upole[i,2]=upole[por,2])) then
       TestTah:=false;
  end;
end;
 
 
{ procedura spaja gotoxy a write }
procedure writexy(x,y:integer; s:string);
begin
  gotoxy(x,y);
  write(s);
end;
 
 
{ vykresli vysledok }
procedure Vykresli(por:byte;pole:TPole);
var  i:integer;
   x,y:integer;
  krok:integer;
begin
  cleardevice;
 
  x:=Trunc(GetMaxX/2); y:=Trunc(GetMaxY/2);
  krok:=30;
 
  for i:=1 to por do begin
    { modra hore }
    if( pole[i]=1 )then begin
        line(x,y,x,y-krok);
        y:=y-krok;
    end;
 
    { modra hore }
    if( pole[i]=11 )then begin
        line(x,y,x,y+krok);
        y:=y+krok;
    end;
 
    { zelena vpravo }
    if( pole[i]=2 )then begin
        line(x,y,x+krok,y);
        x:=x+krok;
    end;
 
    { zelena vlavo }
    if( pole[i]=12 )then begin
        line(x,y,x-krok,y);
        x:=x-krok;
    end;
 
    { cervena hore }
    if( pole[i]=3 )then begin
        line(x,y,x+krok,y-krok);
        x:=x+krok; y:=y-krok;
    end;
 
    { cervena dole }
    if( pole[i]=13 )then begin
        line(x,y,x-krok,y+krok);
        x:=x-krok; y:=y+krok;
    end;
 
    { ruzova dole }
    if( pole[i]=4 )then begin
        line(x,y,x+krok,y+krok);
        x:=x+krok; y:=y+krok;
    end;
 
    { ruzova hore }
    if( pole[i]=14 )then begin
        line(x,y,x-krok,y-krok);
        x:=x-krok; y:=y-krok;
    end;
  end;
end;
 
 
{ otestuje spravnost vygenerovaneho riesenia }
procedure Otestuj(por:byte;pole:TPole);
var i:integer;
  x,y:integer;
  ok:boolean;
begin
  x:=0; y:=0;
  ok:=true;
 
  { nastavuje pomyselne suradnice x,y }
  { najprv zapise do pola a potom zavola test }
  for i:=1 to por do begin
    { modra hore }
    if( pole[i]=1 )then begin
        inc(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { modra dole }
    if( pole[i]=11 )then begin
        dec(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { zelena vpravo }
    if( pole[i]=2 )then begin
        inc(x);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { zelena vlavo }
    if( pole[i]=12 )then begin
        dec(x);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { cervena hore }
    if( pole[i]=3 )then begin
        inc(x); inc(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { cervena dole }
    if( pole[i]=13 )then begin
        dec(x); dec(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { ruzova dole }
    if( pole[i]=4 )then begin
        inc(x); dec(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { ruzova hore }
    if( pole[i]=14 )then begin
        dec(x); inc(y);
        upole[i,1]:=x;
        upole[i,2]:=y;
    end;
 
    { tak a teraz skontrolujem ci sa zapalky nebudu krizovat }
    { ak je false tak by kludne mohla skoncil procedura }
    if( TestTah(i)=false )then begin
        ok:=false;
        break;
    end;
  end;
 
  { ak nikdy nezmenil ok na false tak je dobre }
  if( ok )then
    Vykresli(por,pole);
 
  { tento ich len vykresli stlac TAB a pocka na stlacenie }
  if( ok )then
    if((x=0) and (y=0))then
    begin
      OutTextXY(10,10,'Stlac TAB');
      repeat until (readkey=#9);
    end;
end;
 
 
{ rekurzivna procedura ktora vygeneruje vsetky }
{ mozne usporiadania zapaliek }
procedure Gener(m,z,c,r,por:byte; pole:TPole);
begin
 inc(por);
 
 { pridame modru ak este su }
 if( m>0 )then begin
    pole[por]:=1;
    Gener(m-1,z,c,r,por,pole);
    pole[por]:=11;
    Gener(m-1,z,c,r,por,pole);
 end;
 
 { pridame zelenu ak este su }
 if( z>0 )then begin
    pole[por]:=2;
    Gener(m,z-1,c,r,por,pole);
    pole[por]:=12;
    Gener(m,z-1,c,r,por,pole);
 end;
 
 { pridame cervenu ak este su }
 if( c>0 )then begin
    pole[por]:=3;
    Gener(m,z,c-1,r,por,pole);
    pole[por]:=13;
    Gener(m,z,c-1,r,por,pole);
 end;
 
 { pridame ruzovu ak este su }
 if( r>0 )then begin
    pole[por]:=4;
    Gener(m,z,c,r-1,por,pole);
    pole[por]:=14;
    Gener(m,z,c,r-1,por,pole);
 end;
 
 { ak dosiel az a vycerpal vsetky zapalky   }
 { otestuje ci z tohoto intervalu to pojde  }
 if((m=0) and (z=0) and (c=0) and (r=0))then
     Otestuj(por-1,pole);
end;
 
begin
  ClrScr;
  mam := false;
  m:=2;z:=2;c:=2;r:=2;
  WriteLn('Ondrejove zapalky');
  {
  Write('Zadaj pocet modrych zapaliek:');   ReadLn(m);
  Write('Zadaj pocet zelenych zapaliek:');  ReadLn(z);
  Write('Zadaj pocet cervenych zapaliek:'); ReadLn(c);
  Write('Zadaj pocet ruzovych zapaliek:');  ReadLn(r);
  }
 
  DetectGraph( GraphDriver, GraphMode );
  GraphDriver := Detect;
  InitGraph( GraphDriver, GraphMode, '' );
 
  Gener(m,z,c,r,0,pole);
  OutTextxy(10,10,'Stlac enter');
  repeat until keypressed;
  CloseGraph;
 
  if( mam=false )then
      WriteLn('Z tychto zapaliek sa mnohouholnik postavit neda');
end.