//Остров разбит на правильные шестиугольные ячейки площади 1 различной высоты над уровнем моря.
//Найти максимальный объем воды, которая не стечет в море после долгих проливных дождей.

type
  TCell= record                        //ячейка
    cx, cy, cz: integer;               //cx, cy - координаты, cz - высота ячейки
    next: integer;                     //следующая ячейка, куда течет вода, (если -1, то вытекает наружу)
    head: integer;                     //голова ручья (если -1, то это голова ручья, вытекающего наружу)
    end;

var
  c: array of TCell;                   //отсортированные по высоте ячейки
  ndx: array of array of integer;      //индекс для быстрого поиска ячейки в массиве c по паре координат (x,y)
  h: array[0..4, 0..4] of integer= (   //карта высот ячеек
    (0,1,5,5,0),
     (3,5,1,5,0),
    (6,1,2,4,6),
     (6,6,1,4,0),
    (0,3,4,4,0));

//сортирует массив c
procedure SortCells;
var
  i, j, k: integer;
  t: TCell;
begin;
  k:=Length(c)-1;
  if k<=0 then exit;
  j:=k; i:=j;
  repeat;
    dec(i);
    if c[i].cz>c[j].cz then j:=i;
    until i<=0;
  if j<>k then begin;
    t:=c[j]; c[j]:=c[k]; c[k]:=t;
    end;

  i:=k-1;
  while i>0 do begin;
    j:=i; dec(i);
    if c[i].cz>c[j].cz then begin;
      repeat;
        inc(j);
        until not (c[i].cz>c[j].cz);
      dec(j);
      t:=c[i];
      for k:=i to j-1 do c[k]:=c[k+1];
      c[j]:=t;
      end;
    end;
  end;

//читает карту высот, вызывает SortCells, формирует ndx
procedure ReadCells;
var
  x, y, xcount, ycount, i: integer;
begin;
  ycount:=Length(h);
  xcount:=Length(h[0]);
  SetLength(c, ycount*xcount);
  for y:=0 to ycount-1 do for x:=0 to xcount-1 do with c[y*xcount + x] do begin;
    cx:=x; cy:=y; cz:=h[y,x];
    end;
  SortCells;
  SetLength(ndx, ycount, xcount);
  for i:=0 to Length(c)-1 do ndx[c[i].cy, c[i].cx]:=i;
  end;

//для i-той ячейки возвращает позицию в массиве c ее j-того соседа, или -1
function Neighbour(i, j: integer): integer;
var
  x, y, d: integer;
begin;
  Result:=-1;
  x:=c[i].cx;
  y:=c[i].cy;
  d:=0; if y and 1=0 then d:=-1;
  case j of
    0: begin; x:=x+d; y:=y-1; end;
    1: begin; x:=x+d+1; y:=y-1; end;
    2: x:=x-1;
    3: x:=x+1;
    4: begin; x:=x+d; y:=y+1; end;
    5: begin; x:=x+d+1; y:=y+1; end;
    else begin; x:=-1; y:=-1; end;
    end;
  if (y>=0) and (y<Length(ndx)) and (x>=0) and (x<Length(ndx[0])) then Result:=ndx[y,x];
  end;

//считает ячейки в интервале [0..last] из которых не течет до высоты ячейки с[last+1]
function CountCells(first, last: integer): integer;
var
  i, j, n, k, sum: integer;
begin;
  Result:=0;
  //вычисляем значения next для ячеек c[first..last]
  for i:=first to last do begin;
    c[i].next:=i;
    for j:=0 to 5 do begin;
      n:=Neighbour(i,j);
      if n<0 then c[i].next:=-1
      else if n<i then begin;
        repeat;
          k:=n; n:=c[n].next;
          until (k=n) or (n<0);
        if n<0 then c[i].next:=-1 else c[n].next:=i;
        end;
      end;
    end;
  //инициализация перед подсчетом - каждый сам себе голова
  for i:=0 to last do c[i].head:=i;
  //считаем количество ячеек в каждом ручье, с учетом того, что они могут сливаться
  for i:=0 to last do begin;
    sum:=0; n:=i;
    repeat;
      k:=c[n].head;
      if k<>n then begin; //если у очередной ячейки определена голова, то это слияние ручьев
        if c[k].head<0 then n:=-1; //если из головы течет наружу, то и это ручей течет туда же
        break;
        end;
      c[n].head:=i; inc(sum); //запомнили голову ручья и ячейка пошла на ум
      k:=n; n:=c[n].next;
      until (k=n) or (n<0);
    if n<0 then c[i].head:=-1 else Result:=Result+sum; //если не вытекло, то прибавим, что в уме
    end;
  end;

//считает общий объем воды, как сумму объемов в каждом срезе
function FillCells: integer;
var
  i, j, dz: integer;
begin;
  Result:=0;
  ReadCells;
  j:=0;
  for i:=0 to Length(c)-2 do begin;
    dz:=c[i+1].cz - c[i].cz; //высота очередного среза
    if dz>0 then begin;
      Result:=Result + dz * CountCells(j,i); //добавили объем среза [j..i]
      j:=i+1;
      end;
    end;
  end;

procedure TForm1.Button1Click(Sender: TObject);
begin;
  Memo1.Lines.Add(IntToStr(FillCells));
  end;

procedure SetLevel(i, level: integer);
var
  j, n: integer;
begin;
  for j:=0 to 5 do begin;
    n:=Neighbour(i,j);
    if (n<0) or (c[n].head<=level) then continue;
    if c[n].cz>level then c[n].next:=n
    else begin;
      c[n].head:=level;
      SetLevel(n, level);
      end;
    end;
  end;

function FillCells2: integer;
var
  i, x, y, z: integer;
begin;
  Result:=0;
  ReadCells;
  x:=Length(h[0])-1;
  y:=Length(h)-1;
  z:=c[Length(c)-1].cz;
  for i:=0 to Length(c)-1 do begin;
    c[i].next:=-1;
    c[i].head:=z;
    end;
  for i:=0 to Length(c)-1 do with c[i] do
    if (cx=0) or (cx=x) or (cy=0) or (cy=y) or (next=i) then SetLevel(i, c[i].cz);
  for i:=0 to Length(c)-1 do with c[i] do
    if head>cx then Result:=Result + (head-cx);
  end;

procedure TForm1.Button2Click(Sender: TObject);
begin;
  Memo1.Lines.Add(IntToStr(FillCells));
  end;

procedure SetLevel(i, level: integer);
var
  j, n: integer;
begin;
  for j:=0 to 5 do begin;
    n:=Neighbour(i,j);
    if n>=0 then with c[n] do if head>=level then begin;
      if cz>level then begin;
        head:=cz;
        next:=n;
        end
      else if head>level then begin;
        head:=level;
        SetLevel(n, level);
        end;
      end;
    end;
  end;

function FillCells2: integer;
var
  i, x, y, z: integer;
begin;
  Result:=0;
  ReadCells;
  x:=Length(h[0])-1;
  y:=Length(h)-1;
  z:=c[Length(c)-1].cz;
  for i:=0 to Length(c)-1 do with c[i] do begin;
    if (cx=0) or (cx=x) or (cy=0) or (cy=y) then begin;
      next:=i;
      head:=cz;
      end
    else begin;
      next:=-1;
      head:=z;
      end;
    end;
  for i:=0 to Length(c)-1 do with c[i] do if next=i then SetLevel(i, c[i].cz);
  for i:=0 to Length(c)-1 do with c[i] do Result:=Result + (head-cz);
  end;