procedure pzoom;
var i,j,y,x:byte;
begin
for i:=1 to delt do
     for j:=1 to delt do
          for y:=1 to zoomy do
               for x:=1 to zoomx do
                    putpixel(zoomx*(i-1)+x,zoomy*(j-1)+y,pict[i,j]);
end;

var
  zoomx, zoomy: real;

procedure pzoom;
var i,j,y,x:byte;
begin
  for i:=1 to delt do
    for j:=1 to delt do begin
      setfillstyle(solidfill, pict[i, j]);
      bar(trunc(zoomx*(i-1)), trunc(zoomy*(j-1)), trunc(zoomx*i-1), trunc(zoomy*j-1));
    end;
end;

uses WinCrt, Graph;


procedure GrInit;
var
  gd, gm, ge : integer;
begin

  gd := Detect;

  InitGraph(gd, gm, '');

  ge := GraphResult;

  if ge <> grOk then begin
    writeln('Graph Rrror : ', GraphErrorMsg(ge));
    readkey;
    Halt(1);
  end;

end;

procedure ScaleChange(scale : integer);
var
  A, B : Word;
begin
  GetAspectRatio(A, B);
  SetAspectRatio(A + scale, B + scale);
end;

procedure ShowImage;
begin
  Circle(GetMaxX div 2, GetMaxY div 2, 50);
end;

begin

  GrInit;

  ShowImage;

  Delay(2000); ScaleChange(-5000);  ClearDevice; ShowImage;
  Delay(2000); ScaleChange(+5000);  ClearDevice; ShowImage;

  readkey;

  CloseGraph;
  
end.

  ShowImage; readln; { <-- Здесь }

  Delay(2000); ScaleChange(+5000);  ClearDevice; ShowImage; readln; { <-- И здесь }

  GetAspectRatio(A, B); { <--- Отношение высоты к ширине A/B = 10000/10000 = 1:1}
  SetAspectRatio(A + scale, B + scale); { <--- Установил отношение A/B = 15000/15000 = 1:1 }

{$mode objfpc}

uses Crt, WinCrt, Graph;

type

  TCoordinate = LongInt;

const

  mx : TCoordinate = 0;
  my : TCoordinate = 0;
  cx : TCoordinate = 0;
  cy : TCoordinate = 0;

type

  TColor = 0..15;

  TInfo  = TColor;

  TRastr = array of array of TInfo;

  TImage = Object

    src, rslt : TRastr; // исходная и конечная матрицы

    sx, sy    : Integer; // размеры исходной матрицы

    x1, y1, x2, y2 : TCoordinate; // координаты захвата изображения

    zoom      : Integer; // текущее состояние картинки (0 - исходное состояние)

    constructor Init(x_1, y_1, x_2, y_2 : TCoordinate);
    destructor  Done;

    (*
      захват изображения,
      (x_1, y_1) - левая верхняя точка
      (x_2, y_2) - правая нижняя точка
    *)

    procedure GetSourceRastr; // заполнение исходной матрицы
    procedure GetResultRastr(up : boolean); // получение рузультирующей матрицы

    procedure ShowCentre;

  end;

constructor TImage.Init(x_1, y_1, x_2, y_2 : TCoordinate);
begin

  x1 := x_1;
  y1 := y_1;

  x2 := x_2;
  y2 := y_2;

  sx := x2 - x1 + 1;
  sy := y2 - y1 + 1;

  SetLength(src, sx, sy);

  zoom := 0;

end;

destructor TImage.Done;
begin
  SetLength(src, 0, 0);
  SetLength(rslt, 0, 0);
end;

procedure TImage.GetSourceRastr;
var
  x, y : TCoordinate;
begin

  for x := 0 to sx - 1 do
   for y := 0 to sy - 1 do
    src[x, y] := GetPixel(x + x1, y + y1);
end;

procedure TImage.GetResultRastr(up : boolean);
var
  x, y, rx, ry : TCoordinate;
  scale : integer;
begin

  case up of
    true  : scale := +2;
    false : scale := -2;
  end;

  if scale + zoom < 0 then exit; // уменьшить меньше исходного нельзя

  zoom := zoom + scale;

  if up then begin

    SetLength(rslt, sx * 2, sy * 2);

    for x := 0 to sx - 1 do
     for y := 0 to sx - 1 do
      for rx := 2 * x to 2 * x + 1 do
       for ry := 2 * y to 2 * y + 1 do
        rslt[rx, ry] := src[x, y];


    sx := sx * 2; 
    sy := sy * 2; 

    SetLength(src, 0, 0);
    SetLength(src, sx , sy);

    src := rslt;

  end else begin

    SetLength(rslt, sx div 2, sy div 2);

    x  := 0;
    rx := 0;

    while (x <= sx - 1) do begin

      y  := 0;
      ry := 0;

      while (y <= sy - 1) do begin
        rslt[rx, ry] := src[x, y];
        inc(y, 2);
        inc(ry);
      end;

      inc(x, 2);
      inc(rx);

    end;

    sx := sx div 2;
    sy := sy div 2;

    SetLength(src, 0, 0);
    SetLength(src, sx, sy);

    src := rslt;

  end;

end;

procedure TImage.ShowCentre;
var
  x, y : TCoordinate;
begin
  for x := 0 to sx - 1 do
   for y := 0 to sy - 1  do
    PutPixel(x + cx - sx div 2, y + cy - sy div 2, src[x, y]);
end;

procedure GrInit;
var
  gd, gm, ge : SmallInt;
begin

  gd := Detect;

  InitGraph(gd, gm, '');

  ge := GraphResult;

  if ge <> grOk then begin

    writeln('GraphError : ', GraphErrorMsg(ge));
    readkey;
    Halt(1);

  end;

  mx := GetMaxX;
  my := GetMaxY;

  cx := mx div 2;
  cy := my div 2;

end;

var

  Image : TImage;
  ch    : char;

begin

  clrscr;
  GrInit;

  // рисуем что-то ...

  SetFillStyle(1, BLUE);
  SetColor(RED);
  //Rectangle(cx - 10, cy - 10, cx + 10, cy + 10);
  Bar3D(cx - 10, cy - 10, cx + 10, cy + 10, 7, true);
  FloodFill(cx, cy, RED);
  SetColor(YELLOW);
  Circle(cx, cy, 5);

  // нарисовали

  Image.Init(cx - 50, cy - 50, cx + 50, cy + 50); // захватываем область

  Image.GetSourceRastr; // получаем исходную матирцу

  repeat

    ch := readkey;

    case ch of
      'w','W' : Image.GetResultRastr(true); // увеличение
      's','S' : Image.GetResultRastr(false); // уменьшение
    end;

    ClearDevice;

    Image.ShowCentre; // показвыаем

  until ch = #27;  // если ESC то выход

  Image.Done; 

  Readkey;

  CloseGraph;
end.

procedure TImage.ShowCentre;
var
  x, y : TCoordinate;
  csd_x, csd_y: TCoordinate;
begin
  csd_x := cx - sx div 2;
  csd_y := cy - sy div 2;

  for x := 0 to sx - 1 do
    for y := 0 to sy - 1  do
      if src[x, y] <> getbkcolor then { <--- Здесь !!! }
        PutPixel(x + csd_x, y + csd_y, src[x, y]);
end;