• Жизнь бактерий
  LIFE
  
  Условие  Комментарии  Решение  Тестовые файлы  Оглавление

Описание
Игра «Жизнь» является упрощенной моделью развития колонии бактерий. Игровое поле для этой игры представляет собой прямоугольник M×N клеток. В начальный момент времени в некоторых клетках находятся бактерии. За один шаг игры некоторые бактерии могут погибнуть, а некоторые родиться на свободных клетках в соответствии со следующими правилами:

• бактерия, у которой есть не более одной соседки, погибает «от скуки»

• бактерия, у которой есть более трех соседок, погибает «от тесноты»

• на свободной клетке, у которой есть ровно три соседние бактерии, рождается новая бактерия

Все эти правила применяются одновременно ко всем клеткам игрового поля. Клетки считаются соседними, если у них есть хотя бы одна общая точка

Задание
Напишите программу, которая:

• по заданной колонии находит ее предка, то есть колонию, чьим следующим поколением она является, либо сообщает, что это невозможно

• находит колонию, у которой нет предка, и которая погибает не ранее, чем через L шагов, либо сообщает, что такой колонии не существует

Входные данные
Если во входном файле записана матрица M×N (2≤M,N≤15), то программа должна решать пункт 1 задачи для колонии бактерий, задаваемой этой матрицей. Бактерии обозначаются символом "*", а пустые клетки - символом "." (точка). Если во входном файле заданы три числа М, N и L (2≤М,N≤10; 0≤L≤10), то программа должна решать пункт 2 для этих параметров

Выходные данные
Если искомая колония существует, то ее следует вывести в выходной файл в формате, приведенном в описании входных данных к пункту 1. В противном случае ваша программа должна записать в выходной файл сообщение "NOT POSSIBLE"


Например:

Пример для пункта 1

LIFE.IN
...
***
...

LIFE.OUT
.*.
.*.
.*.



Пример для пункта 2

LIFE.IN
2 2 10

LIFE.OUT
*.
**





Решение
 
{$A+,B-,D+,E-,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 63384,0,655360}
 
program life_bacteria;
uses crt;
var xx, yy: integer;
    r, n, pa: array [0..16, 0..16] of byte;
    m, m1, p: array [0..16, 0..16] of boolean;
    x1, x2, y1, y2: integer;
    tim: longint absolute $0000:$046C;
    tims: longint;
    flipDone: boolean;
 
const ItNeeds: array [false..true] of byte = (3,2);
 
procedure ReadField;
var i: integer;
    s: string;
begin
  fillChar (m, sizeof(m), 0);
  yy := 0; xx := 0;
  while not SeekEof (input) do
  begin
    readln (s);
    while s[length(s)] = ' ' do dec (s[0]);
    while (s[1] = ' ') and (s[0]>#1) do s := copy (s, 2, length(s)-1);
    if s[1] in ['*','.'] then
      begin
        if xx = 0 then xx := length (s);
        inc (yy);
        for i := 1 to xx do
          if s[i] = '*' then m[i, yy] := true else m[i, yy] := false;
      end;
  end;
end;
 
procedure NoSol;
begin
  assign (output, 'life.out'); rewrite (output);
    writeln('NOT POSSIBLE');
  close (output);
  halt;
end;
 
procedure PrintOut;
var i, j: integer;
begin
  assign (output, 'life.out'); rewrite (output);
  if FlipDone then begin i := xx; xx := yy; yy := i;end;
  for j := 1 to yy do
  begin
    for i := 1 to xx do
    begin
     if FlipDone then
       begin
         if p[j, i] then write('*') else write('.');
       end else
       begin
         if p[i, j] then write('*') else write('.');
       end;
    end;
    writeln;
  end;
  close (output);
  halt;
end;
 
procedure Print;
var i, j: integer;
    c: char;
begin
  clrscr;
  for j := 1 to yy do
  begin
    for i := 1 to xx do
     if p[i, j] then write('*') else write(#249);
    writeln;
  end;
  c := readkey;
  if c = #27 then halt;
  if c = #32 then
      c := c;
end;
 
procedure FindNulls;
var i, j: integer;
begin
  fillChar (r, sizeof(r), 1);
end;
 
procedure FindEdges;
var i, j: integer;
begin
  x1 := xx + 1;
  x2 := 0;
  y1 := yy + 1;
  y2 := 0;
  for i := 1 to xx do
    for j := 1 to yy do
      if r[i, j] > 0 then
        begin
          if i < x1 then x1 := i;
          if i > x2 then x2 := i;
          if j < y1 then y1 := j;
          if j > y2 then y2 := j;
        end;
end;
 
Function CheckLine (j:integer): boolean;
var u, i: integer;
    a: boolean;
begin
 if j = 0 then begin CheckLine := true; exit; end;
  CheckLine := false;
  for i := x1 to x2 do
      begin
       u := n[i,j];
        a := false;
        if p[i, j] and ((u=2) or (u=3)) then a := true;
        if (not p[i, j]) and (u=3) then a := true;
        if a <> m[i, j] then exit;
      end;
  CheckLine := true;
end;
 
Function CheckPartLine (j:integer): boolean;
var u, i: integer;
    a: boolean;
begin
 if j = 0 then begin CheckPartLine := true; exit; end;
 CheckPartLine := false;
  for i := x2-1 to x2 do
      begin
       u := n[i,j];
        a := false;
        if p[i, j] and ((u=2) or (u=3)) then a := true;
        if (not p[i, j]) and (u=3) then a := true;
        if a <> m[i, j] then exit;
      end;
  CheckPartLine := true;
end;
 
procedure CheckIt;
begin
  if CheckLine(y2) and (CheckLine(y2-1)) then PrintOut;
end;
 
procedure Rec (x, y: byte);
label NoAdd, NoSkip;
begin
  if tim - tims > 520 then NoSol;
  if m[x-1, y-1] and (not p[x-1, y-1]) and (n[x-1, y-1] < 2) then exit;
  if m[x, y-1] and (not p[x, y-1]) and (n[x, y-1] = 0) then exit;
  if x > x2 then
   begin
     if y = y2 then
          begin
            CheckIt;
            exit;
          end;
     if y > y1 then if not CheckLine (y-1) then exit;
     rec (x1, y+1);
     exit;
   end;
  if r[x, y] = 0 then Goto NoAdd;
  if m[x-1, y-1] and (n[x-1, y-1] >= 3) then Goto NoAdd;
  if (not m[x-1, y-1]) then
      if p[x-1, y-1] then
         begin
           if n[x-1, y-1] = 1 then Goto NoAdd;
           if n[x-1, y-1] = 2 then Exit;
         end else
         begin
           if n[x-1, y-1] = 2 then Goto NoAdd;
         end;
  if m[x-1, y] and (n[x-1, y] = 3) then Goto NoAdd;
  if m[x, y-1] and (n[x, y-1] = 3) then Goto NoAdd;
  if m[x+1, y-1] and (n[x+1, y-1] = 3) then Goto NoAdd;
  n[x, y] := byte(p[x-1,y-1]) + byte(p[x,y-1]) + byte(p[x+1,y-1]) +
             byte(p[x-1,y]);
  if m[x,y] and (n[x, y] > 3) then exit;
  p[x, y] := true;
  inc (n[x-1, y-1]); inc (n[x, y-1]); inc (n[x+1, y-1]); inc (n[x-1, y]);
  rec (x+1, y);
  p[x, y] := false;
  dec (n[x-1, y-1]); dec (n[x, y-1]); dec (n[x+1, y-1]); dec (n[x-1, y]);
 
NoAdd:
  n[x, y] := byte(p[x-1,y-1]) + byte(p[x,y-1]) + byte(p[x+1,y-1]) +
             byte(p[x-1,y]);
  if m[x, y] and (not p[x,y]) and (n[x, y] < 3 - pa[x,y]) then exit;
  if m[x-1, y-1] then
       if n[x-1, y-1] < ItNeeds [p[x-1, y-1]] then goto NoSkip;
  if not m[x-1, y-1] then
        begin
          if n[x-1, y-1] = 3 then goto NoSkip;
        end;
   Rec (x+1, y);
NoSkip:
end;
 
procedure FindPa;
var i, j: integer;
begin
  fillChar (pa, SizeOf (pa), 0);
  for i := 1 to xx do
    for j := 1 to yy do
      pa [i, j] := r[i+1, j] + r[i-1, j+1] + r[i, j+1] + r[i+1, j+1];
end;
 
procedure Flip;
var i, j: integer;
begin
  for I := 1 to 15 do
    for j := 1 to 15 do
      m1[i, j] := m[j, i];
  i := xx; xx := yy; yy := i;
  m := m1;
end;
 
procedure TaskA;
var i, j: integer;
begin
  ReadField;
  FindNulls;
  FindEdges;
  if (x2-x1) > (y2-y1) then
       begin
         FlipDone := true;
         Flip;
         FindNulls;
         FindEdges;
       end;
  FindPA;
  FillChar (p, sizeof(p), 0);
  FillChar (n, sizeof(n), 0);
  Rec (x1, y1);
  NoSol;
end;
 
procedure TaskB;
var i, j, l: integer;
begin
  read (yy, xx, l); close (input);
  assign (output, 'life.out'); rewrite (output);
  if (xx = 2) then
    begin
      writeln ('**');
      writeln ('*.');
      if yy = 3 then writeln('.*') else
      for i := 3 to yy do
        if i mod 2 = 1 then writeln('..') else writeln('*.');
      close (output);
      halt;
    end;
  FillChar (p, sizeof(p), 0);
  if yy = 2 then
   begin
     p[1,1] := true;
     p[2,1] := true;
     p[1,2] := true;
     if xx = 3 then p[3,2] := true else
     begin
       for i := 4 to xx do
        if i mod 2 = 0 then p[i,1] := true;
     end;
   end else
   begin
     for i := 1 to xx do
      for j := 1 to yy do
       if (i mod 2 = 1) and (j mod 2 = 1) then p[i,j] := true;
     p[2, 2] := true;
   end;
  printout;
 
end;
 
procedure FindOut;
var c: char;
begin
  assign (input, 'life.in'); reset (input);
  read (c);
  if c in ['*','.'] then
    begin
      close (input);
      reset (input);
      TaskA;
      exit;
    end;
  close (input);
  reset (input);
  TaskB;
end;
 
begin
  tims := tim;
  flipdone := false;
  FindOut;
end.

© Особенности национальных задач по информатике