Подскажите, пожалуйста, алгоритм масштабирования рисунков. Рисунок представляет собой двумерный массив, каждый елемент которого определяет цвет соответствующего пикселя на рисунке.
Bokul
22.08.2006 7:46
С увеличениям в целое количество раз я вроде разобрался. Вот такую операцию надо проделивать для каждого елемента массива( каждой точки начального рисунка).
Код
for y:=1 to zoomy do for x:=1 to zoomx do putpixel(zoomx*(i-1)+x,zoomy*(j-1)+y,pict[i,j]);
zoomx - во сколько надо увеличить по оси x zoomy - во сколько надо увеличить по оси y pict - изначальный рисунок
Вот полная процедура для увеличения рисунка.
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;
delt - размерность рисунка
Кому интересно проверить процедуру, может скачать прикрепленный файл с примером массива (рисунка) для использования, delt=50.
Но пока еще не понятно как увеличивать и уменьшать рисунок в не целое количество раз. Пока на ум приходит только такое: чтобы увеличить, например, в 2.5 раза надо сначала увеличить его в 5 раз, а потом уменьшить в 2. Вроде правильно, завтра попробую реализовать. Если у кого то есть замечания или предложения, буду рад если Вы ими поделитесь.
Бродяжник
22.08.2006 8:22
Копайте в сторону билинейной фильтрации. Кое-что можно найти.
volvo
22.08.2006 8: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 16: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;
klem4, а не работает Это во-первых. Объясни мне, в чем разница в изображениях:
ShowImage; readln; { <-- Здесь }
Delay(2000); ScaleChange(+5000); ClearDevice; ShowImage; readln; { <-- И здесь }
А во вторых, GetAspectRatio/SetAspectRatio меняют коэффициент сжатия изображения для всего экрана, а не для определенного его куска...
klem4
22.08.2006 17:23
Цитата
Объясни мне, в чем разница в изображениях:
У тебя одно и тоже выводится ?
volvo
22.08.2006 17: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 17:55
И правда, соотношение то не меняется, но у меня картинка сначала увеличивается (расширяется) а потом приходит в начальное состояние.
Bokul
23.08.2006 4:01
Цитата
Копайте в сторону билинейной фильтрации. Кое-что можно найти.
А поподробнее можна? volvo, спасибо, все отлично работает. klem4, у меня появляется на несколько секунд круг и все...
klem4
23.08.2006 12:33
Цитата
klem4, у меня появляется на несколько секунд круг и все...
По идее так и должно быть, не знаю почему у меня меняется Можно исправить чтобы все было по уму, но я думаю действительно не стоит, ибо Volvo прав,
Цитата
GetAspectRatio/SetAspectRatio меняют коэффициент сжатия изображения для всего экрана, а не для определенного его куска...
Щас появилась одна идея, если сделаю покажу ;)
Бродяжник
23.08.2006 14:35
Bokul Чтобы это объяснить поподробнее, мне надо самому вспомнить. Для этого надо полезть в Интернет, порыться там, вытащить пару документов... Вкратце суть та, что, к примеру, увеличиваем рисунок в полтора раза. То есть из двух пикселов делаем три. Первый исходный пиксел переходит в первый выходной, один в один. Второй исходный - в третий выходной, один в один. Между ними надо вставить еще один пиксел. Так вот его цвет определяется, как усредненное значение между цветами соседних исходных пикселов. Что-то вроде этого. При этом, ясное дело, картинка слегка размывается. И в обратную сторону примерно то же самое. Если из двух пикселов делаем один, то его цвет усредняем. Но об этом лучше почитать толковое описание, а не мои импровизации.
Archon
23.08.2006 15:33
Вот, что я нашёл в обучалках асфиксии. На аглицком наречии, но всё же довольно неплохо написано.
Цитата
For the horizontal area, I am going to calculate a certain step value. I will then trace along the bitmap, adding this step to my position, and placing the nearest pixel on to the screen. Let me explain this simpler ...
Let us say I have a 10 pixel wide bitmap. I want to squish it into 5 pixels. Along the bitmap, I would draw every second pixel to screen. In ascii :
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
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
24.08.2006 23:16
Я вот никак не могу понять, чего она так подтормаживает? Вроде же не такой большой объем вычислений... Я, конечно, знал, что динамические массивы медленнее статических, но не настолько же...
klem4
24.08.2006 23:18
Думаю по тому, что картинка отображается попиксельно, хотя ... ? Возможно имеет смысл отрисовывать ее сначала на невидимой видеостранице, а потом работать с GetImage/PutImage ... Только увеличит ли это скорость
добавлено : фактически результирующая матрица rslt вообще не нужна, можно в момент ее получения не запоминать элемент, а сразу отрисосвывть пиксел на невидимой странице, а потом запоминать все что получилось с помощью GetImage
volvo
24.08.2006 23:37
Ха... Да, ты прав... Это именно отрисовка тормозит, я уж грешным делом подумал, что сам пересчет...
Ан нет... Добавил к твоей программе ведение лога - все встало на свои места:
Bokul
24.08.2006 23:51
klem4, не мог бы ты выложить файл с твоим кодом, а то при копировании все переносы строк исчезают?
volvo
25.08.2006 0: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 9:15
Bokul, держи
Bokul
25.08.2006 18:32
klem4, и с этим кодом у меня проблемы... теперь появляется круг в квадратике и все, никакой реакции на клаву, приходится снимать через диспетчер задач. Компилятор - Free Pascal 2.0.2, может это у меня проблемы? Кто-нибудь еще пробивал запускать?
volvo
25.08.2006 19:03
В FPC 2.0.0 прекрасно отрабатывает... (только я запускаю прямо из Windows Explorer-а, не из IDE FreePascal-я)
klem4
25.08.2006 19:48
ммм Переключи клаву в режим латинских букв (кода картинка появится) ? Мне приходится менять.
Bokul
25.08.2006 23:46
Цитата
В FPC 2.0.0 прекрасно отрабатывает... (только я запускаю прямо из Windows Explorer-а, не из IDE FreePascal-я)
Цитата
ммм Переключи клаву в режим латинских букв (кода картинка появится) ? Мне приходится менять.
Не то, ни другое не подошло. Наверное у моего FreePascal какие-то проблемы с клавой в графическом режиме. Но я убрал проверку на нажатую клавишу (картинка теперь увеличивается/ уменьшается сама по себе) и все прекрасно заработало
Bokul
26.08.2006 0:05
Код
array of array SetLength
Я так понял что это объявления и установления длины динамического массива? Где можна почитать про использования динамических массивов в FreePascal'е?
volvo
26.08.2006 0:30
У тебя полный дистрибутив? Тогда в файле /DOC/REF.PDF (3.3.1 Arrays -> Dynamic Arrays)
Если не качал полный комплект документации - есть OnLine версия... То же самое - здесь: 3.3.1 Arrays
Bokul
26.08.2006 0:36
Спасибо , почитаем.
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.