Версия для печати темы

Автор: Bokul 22.08.2006 9:46

Подскажите, пожалуйста, алгоритм масштабирования рисунков. Рисунок представляет собой двумерный массив, каждый елемент которого определяет цвет соответствующего пикселя на рисунке.

Автор: Bokul 22.08.2006 11:46

С увеличениям в целое количество раз я вроде разобрался.
Вот такую операцию надо проделивать для каждого елемента массива( каждой точки начального рисунка).

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;

Автор: Бродяжник 22.08.2006 12:22

Копайте в сторону билинейной фильтрации. Кое-что можно найти.

Автор: volvo 22.08.2006 12:25

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;

Автор: klem4 22.08.2006 20:52

Если конечно не обязательно работать с матрицой пикселов, то есть и стандартные методы изменение масштаба картинки, вот например :

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.

Автор: volvo 22.08.2006 21:18

klem4,
а не работает Это во-первых.
Объясни мне, в чем разница в изображениях:

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

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

Автор: klem4 22.08.2006 21:23

Автор: volvo 22.08.2006 21:35

Конечно... А ничего другого я и не ждал... Смотри:

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

Автор: klem4 22.08.2006 21:55

И правда, соотношение то не меняется, но у меня картинка сначала увеличивается (расширяется) а потом приходит в начальное состояние.

Автор: Bokul 23.08.2006 8:01

Автор: klem4 23.08.2006 16:33

Автор: Бродяжник 23.08.2006 18:35

Bokul
Чтобы это объяснить поподробнее, мне надо самому вспомнить. Для этого надо полезть в Интернет, порыться там, вытащить пару документов...
Вкратце суть та, что, к примеру, увеличиваем рисунок в полтора раза. То есть из двух пикселов делаем три. Первый исходный пиксел переходит в первый выходной, один в один. Второй исходный - в третий выходной, один в один. Между ними надо вставить еще один пиксел. Так вот его цвет определяется, как усредненное значение между цветами соседних исходных пикселов. Что-то вроде этого. При этом, ясное дело, картинка слегка размывается. И в обратную сторону примерно то же самое. Если из двух пикселов делаем один, то его цвет усредняем.
Но об этом лучше почитать толковое описание, а не мои импровизации.

Автор: Archon 23.08.2006 19:33

Вот, что я нашёл в обучалках асфиксии. На аглицком наречии, но всё же довольно неплохо написано.

Автор: klem4 25.08.2006 2:37

Вот, реализовал свою идею Грубовато конечно, до билинейной фильрации тут далеко :D

Управление W - увеличить, S - уменьшить

{$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.

Автор: volvo 25.08.2006 3:16

Я вот никак не могу понять, чего она так подтормаживает? Вроде же не такой большой объем вычислений... Я, конечно, знал, что динамические массивы медленнее статических, но не настолько же...

Автор: klem4 25.08.2006 3:18

Думаю по тому, что картинка отображается попиксельно, хотя ... ? Возможно имеет смысл отрисовывать ее сначала на невидимой видеостранице, а потом работать с GetImage/PutImage ... Только увеличит ли это скорость


добавлено : фактически результирующая матрица rslt вообще не нужна, можно в момент ее получения не запоминать элемент, а сразу отрисосвывть пиксел на невидимой странице, а потом запоминать все что получилось с помощью GetImage

Автор: volvo 25.08.2006 3:37

Ха... Да, ты прав... Это именно отрисовка тормозит, я уж грешным делом подумал, что сам пересчет...

Ан нет... Добавил к твоей программе ведение лога - все встало на свои места:



Прикрепленные файлы
 log.txt ( 406 байт ) Кол-во скачиваний: 241

Автор: Bokul 25.08.2006 3:51

klem4, не мог бы ты выложить файл с твоим кодом, а то при копировании все переносы строк исчезают?

Автор: volvo 25.08.2006 4:05

Кстати, вот так будет ГОРАЗДО быстрее (PutPixel - очень "дорогая" в смысле времени операция):

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;

Автор: klem4 25.08.2006 13:15

Bokul, держи


Прикрепленные файлы
 SCALERELAEASE.pas ( 3.94 килобайт ) Кол-во скачиваний: 275

Автор: Bokul 25.08.2006 22:32

klem4, и с этим кодом у меня проблемы... теперь появляется круг в квадратике и все, никакой реакции на клаву, приходится снимать через диспетчер задач. Компилятор - Free Pascal 2.0.2, может это у меня проблемы? Кто-нибудь еще пробивал запускать?

Автор: volvo 25.08.2006 23:03

В FPC 2.0.0 прекрасно отрабатывает...
(только я запускаю прямо из Windows Explorer-а, не из IDE FreePascal-я)

Автор: klem4 25.08.2006 23:48

ммм Переключи клаву в режим латинских букв (кода картинка появится) ? Мне приходится менять.

Автор: Bokul 26.08.2006 3:46

Автор: Bokul 26.08.2006 4:05

Автор: volvo 26.08.2006 4:30

У тебя полный дистрибутив? Тогда в файле /DOC/REF.PDF (3.3.1 Arrays -> Dynamic Arrays)

Если не качал полный комплект документации - есть OnLine версия... То же самое - здесь:
http://www.freepascal.org/docs-html/ref/refsu14.html#x36-390003.3.1

Автор: Bokul 26.08.2006 4:36

Спасибо , почитаем.