[shkola] Reshenie na wtora zadacha

Dokato se rowih iz Infoman popadnah na slednoto reshenie na wtora 
zadacha or dneshnite(wcherashnite) zadachi. Kodxt e na Pascal!

Reshenieto e mnogo podobno na moeto(w koeto w posledstwie otkrih edin 
propusk, kojto makar i da se oprawq s 2 reda kod bi mi wzel nqkoq i 
druga tochka ), koeto razkazah na nqkoi ot was.

Ivo
-- 
Ivaylo Riskov <ivaylo_riskov@xxxxxxx>

"Do not take life too seriously; you will never get out of it alive."

{ This is the input data;  N;  M;  Lines;  . . .
 40 4
 8 *
 * 28
 -4 4
 42 42


                           ZATWORENI OBLASTI
                           -----------------

     Oblast za chertane e kwadratna oblast s razmeri N x N piksela. Wseki pik-
 sel e opredelen s koordinatite si po x i po y - celi chisla ot 0 do N-1 i mo-
 zha da e ili cheren ili bql.  W oblastta za chertane mogat da se chertaqt 
prawi.
 Te biwat horizontalni,wertikalni ili diagonalni (pod 458 i 1358),  koito se
 zadawat sxotwetno s dwojka koordinati ot wida (*,b), (a,*), (a,b), kxdeto a
 e x-koordinatata na  presechnata tochka na  sxotwetnata prawa s x-osta, a b -
 y-koordinatata na presechnata tochka na prawata s y-osta. Dwojkata (0,0) zada-
 wa prawata (0,0)-(N-1,N-1). Presechnite tochki s koordinatnite osi mogat i da
 sa izwxn oblastta za chertaene. Chast ot oblastta e zatworena oblast,ako e og-
 radena otwsqkxde s chasti ot prawi. Pri zadaden razmer na kwadratnata oblast
 za chertaene N  i M na broj prawi, zadadeni po opisaniq nachin, da se sxstawi
 programa, koqto namira ploshttta na naj-golqmata po plosht zatworena oblast.
   REShENIE: Shte predstawim oblastta kato matrica N x N ot 16-bitowi stojnosti.
 Pxrwo shte inicializirame matricata s nuli  i sled towa posledowatelno shte 
pos-
 tawim w neq prawite ot whodniq fajl.  Wseki piksel, na kojto lezhi prawa, shte
 otbelqzwame w matricata s konstantata aLine. Shte namerim wsichkite oblasti na
 matricata kato q skanirame otgore nadolu i otlqwo nadqsno i ocwetqwame sxse-
 dnite pikseli, wxrhu koito nqma liniq (koito ne sa cherni) s nqkakxw cwqt.Ko-
 gato stignem liniq, uwelichawame s 1 nomera na cweta. Taka sledwashtata oblast
 ocwetqw. s drug cwqt i w krajna smetka wsqka oblast trqbwa da ostane ocwete-
 na s razlichen cwqt.  Po broq na kwadratchetata ocweteni s wseki ot cwetowete
 mozhem da namerim naj-golqmata oblast i ploshttta j.  Sxsedni narichame 
kwadrat-
 chetata otgore, otdolu, otlqwo i otdqsno na tekushtoto. Ponezhe ocwetqwanite 
ob-
 lasti mogat da imat trixgxlni steni,  ako ocwetqwame s edin i sxsht cwqt samo
 sxsednite pikseli, ponezhe skanirame otlqwo nadqsno,  mozhe da se poluchi taka,
 che dwa sxsedni piksela ot edna i sxshta oblast da imat razlichen cwqt.  Zatowa
 sled kato edin piksel se ocweti,se prowerqwa dali sxsedniqt mu piksel wlqwo
 ima drug cwqt i ako ima,  tozi piksel se boqdiswa s cweta na drugiq i obshtiq
 broj izpolzwani cwetowe se namalqwa s edno,zashtoto uwelichawaneto na broq cwe-
 towe se e okazalo greshna stxpka.  Towa mozhe da se poluchi samo ako pri skani-
 raneto se preminawa otlqwo nadqsno i se premine prez diagonalna liniq naklo-
 nena na 458, koqto e stena na oblast, koqto se zapochnata da se ocwetqwa. Za
 poweche podrobnosti razgledajte programata. Ponezhe broq na oblastite mozhe da
 ne se sxbere w 1 bajt, se izpolzwa word.  Programata e realizirana do N=500
 stiga razbira se broq na oblastite da ne nadwishawa 32767 (zaradi problemi s
 pametta).  Sled kato wsichki oblasti se namerqt, se premahwat tezi, koito ne
 sa zatworeni. Edna oblast ne e zatworena, ako nqkoj nein piksel granichi sxs
 stena ot oblastta za chertane.
}

CONST InFileName  = 'in1.txt';
      OutFileName = '';

      MaxN = 500;
      aLine = MaxInt;

TYPE EdinRed = array[0..MaxN] of integer;
     TOblastiSize = array[1..MaxInt] of word;

VAR N,BrOblasti: integer;
    K: array[0..MaxN] of ^EdinRed;
    OblastiSize: ^TOblastiSize;


Procedure ReadData; { Prochita whodnite danni i chertae liniite w matricata K }

   Procedure HorizontalLine(y:integer);
   Var x: integer;
   Begin { Nanasq w K horizontalna prawa (0,y)-(N-1,y) }
     if y in[0..N-1] then
       for x:= 0 to N-1 do
         k[x]^[y]:= aLine;
   End;

   Procedure VerticalLine(x:integer);
   Var y: integer;
   Begin { Nanasq w K wertikalna prawa (x,0)-(x,N-1) }
     if x in[0..N-1] then
       for y:= 0 to N-1 do
         k[x]^[y]:= aLine;
   End;

   Procedure DiagonalLine(x,y:integer);
   Begin { Nanasq w K diagonalna prawa (x,0)-(0,y) na 1358 ili na 458 }
     if (x = y) and (x<>0) then
       begin { prawata e na 1358 }
         x:=x; y:=0;
         repeat
           if (x>=0) and (y>=0) and (x<=N-1) and (y<=N-1) then
             k[x]^[y]:=aLine;
           x:= x-1; y:= y+1;
         until x < 0;
       end
     else
       begin { prawata e na 458 }
         x:=x; y:=0;
         repeat
           if (x>=0) and (y>=0) and (x<=N-1) and (y<=N-1) then
             k[x]^[y]:=aLine;
           x:= x+1; y:= y+1;
         until x > N-1;
       end
   End;

   Procedure GetCislo(var s: string; var c:integer);
   Var sign: integer; { Izwlicha chisloto, s koeto zapochwa niza s }
   Begin
     s:=s+'@';
     if s[1]='-' then
       begin delete(s,1,1); sign:=-1; end
     else sign:=1;

     c:=0;
     while S[1] in['-','0'..'9'] do
       begin c:= c*10 + ord(S[1])-48; delete(S,1,1); end;
     c:=sign*c;
   End;

Var F: Text;
    M,a,b: integer;
    S: string;
Begin
  Assign(F,InFileName); Reset(F);
  ReadLn(F,N,M);
  for N:= 0 to N-1 do
    begin New(K[N]); FillChar(K[N]^,SizeOf(K[N]^),0); end;
  Inc(N);

  for M:= 1 to M do
    begin { Prochita i chertae w rabotnata oblast M-te linni ot whodniq fajl }
      ReadLn(F,S);
      if S[1] = '*' then
        begin
          delete(S,1,2);
          GetCislo(s,b);
          HorizontalLine(b);
        end
      else
        if S[length(S)] = '*' then
          begin
             GetCislo(s,a);
             VerticalLine(a);
          end
      else
        begin
          GetCislo(s,a);
          delete(s,1,1);
          GetCislo(s,b);
          DiagonalLine(a,b);
        end;
    end;
  Close(F);
End;


Procedure FindOblasti;

  Function Min(a,b:integer): integer;
  Begin if A<B then Min:=A else Min:=B; end;

  Function Get(x,y:integer): integer;
  Begin
    if (x<0) or (X>N-1) or (y<0) or (y>N-1) or
       (K[x]^[y]=0) or (K[x]^[y]=aLine) then Get:=aLine
    else Get:=K[x]^[y];
  End;

Var x,y,m,Left,Up: integer;
Begin
  BrOblasti:=0;
  for y:= 0 to N-1 do
    for x:= 0 to N-1 do
      if K[x]^[y]<>aLine then
      begin
        Left:= Get(x-1,y);
        Up:=   Get(x,y-1);
        m:= Min(Left,Up);
        if m = aLine then
          begin Inc(BrOblasti); K[x]^[y]:=BrOblasti; end
        else
          begin
            K[x]^[y]:=m;
            if (Left > m) and (Left<>aLine) then
              begin Dec(BrOblasti); K[x-1]^[y]:=m; end
          end;
      end;
End;


Procedure FindOblastiSize;
Type TFalshiviOblasti = array[1..MaxInt] of boolean;
Var i,x,y,obl: integer;
    FalshivaOblast: ^TFalshiviOblasti;
Begin
  New(OblastiSize);
  FillChar(OblastiSize^,SizeOf(OblastiSize^),0);
  New(FalshivaOblast);
  FillChar(FalshivaOblast^,SizeOf(FalshivaOblast^),false);
  {Calculate all oblasti size}
  for x:= 0 to N-1 do
    for y:= 0 to N-1 do
      begin
        Obl:=k[x]^[y];
        if (x=0) or (y=0) or (x=N-1) or (y=N-1) then
          if Obl <> aLine then
            FalshivaOblast^[Obl]:=true;
        Inc(OblastiSize^[Obl]);
      end;
  {Remove falshivite oblasti}
  for I:= 1 to BrOblasti do
    if FalshivaOblast^[i] then
      OblastiSize^[i]:=0;
  Dispose(FalshivaOblast);
End;

Procedure WriteSolutionToFile;
Var F: Text;
    MaxOblastSize,i: word;
Begin
  Assign(F,OutFileName); Rewrite(F);
  MaxOblastSize:=0;
  for i:= 1 to BrOblasti do
    if OblastiSize^[i] > MaxOblastSize then
      MaxOblastSize:= OblastiSize^[i];
  WriteLn(F,MaxOblastSize);
  Close(F);
End;


BEGIN
  ReadData;
  FindOblasti;
  FindOblastiSize;
  WriteSolutionToFile;
END..

Other related posts: