Модераторы: Snowy, MetalFan, bems, Poseidon
  

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Слайд шоу, TBitmap случайный выбор каждого pixels 
:(
    Опции темы
Алексей
Дата 20.2.2008, 10:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 112
Регистрация: 19.6.2006

Репутация: нет
Всего: нет
Нужно сделать слайд шоу, чтобы новая картинка замещала старую за счет случайного заполнения пикселей.
Проблема в том, что картинка заполняется не полностью. Все мои попытки это исправить привели лишь к зацикливанию.
Заранее спасибо.
Код

procedure TForm1.FormCreate(Sender: TObject);
var i:byte;
begin
   timer1.Enabled:=false;
   for i:=1 to 4 do
     begin
        Bm[i]:=TBitmap.Create;
        if OpenPictureDialog1.Execute then
        BM[i].LoadFromFile(OpenPictureDialog1.FileName);
     end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  randomize;
   p:=1+random(4);
   rand;
end;

procedure TForm1.rand;
    var i,j,k,n:integer;
    begin
      k:=0;
      n:=form1.Width*form1.Height;
        for k:=1 to n do
           begin
                  randomize;
                  i:=random(form1.ClientWidth);
                  j:=random(form1.ClientHeight);
                  if form1.Canvas.Pixels[i,j]<> BM[p].Canvas.Pixels[i,j] then
                       form1.Canvas.Pixels[i,j]:=BM[p].Canvas.Pixels[i,j]
          end;    
  end;
PM MAIL   Вверх
Alexeis
Дата 20.2.2008, 12:31 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 34
Всего: 459
Просто случайный Random будет закрашивать нереально долго, потому что будет очень много совпадений. При повторном выборе пикселя, нужно брать соседний, а если он уже выбран, то продолжать двигаться, пока не будет найден тот который еще не брали. 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
Алексей
Дата 20.2.2008, 16:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 112
Регистрация: 19.6.2006

Репутация: нет
Всего: нет
А, если не трудно, можно поподробней.  smile 
PM MAIL   Вверх
lukas
Дата 20.2.2008, 18:03 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 771
Регистрация: 23.2.2007

Репутация: 3
Всего: 15
есть еще вариант, сгенирировать заранее список координат пикселей... естественно в случайном порядке, а потом просто по нему пройтись.... список без повторений генерить очень легко.... для этого нужна 2 списка... 1 - с всевозможными вариантами, а второй пустой,.. Далее просто генерим случайный индекс из 1ого списка, и переводим элемент этого индекса во 2ой список, а из 1ого удаляем.... и так до тех пор, пока в первом списке ничего не останется...


--------------------
http://code.google.com/p/orionphp/ - opensource скриптовой язык Orion (аналог PHP) для freepascal/delphi.
PM MAIL WWW   Вверх
Alexeis
Дата 20.2.2008, 18:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 34
Всего: 459
Цитата(lukas @  20.2.2008,  17:03 Найти цитируемый пост)
есть еще вариант, сгенирировать заранее список координат пикселей... естественно в случайном порядке, а потом просто по нему пройтись.... список без повторений генерить очень легко.... для этого нужна 2 списка... 1 - с всевозможными вариантами, а второй пустой,.. Далее просто генерим случайный индекс из 1ого списка, и переводим элемент этого индекса во 2ой список, а из 1ого удаляем.... и так до тех пор, пока в первом списке ничего не останется... 

  Заранее неизвестен ни размер экрана, ни размер картинки, потому не катит smile .


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
lukas
Дата 20.2.2008, 19:45 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 771
Регистрация: 23.2.2007

Репутация: 3
Всего: 15
Alexeis, 

а причем тут заранее... мы же эти операции будем производить не заранее...  


--------------------
http://code.google.com/p/orionphp/ - opensource скриптовой язык Orion (аналог PHP) для freepascal/delphi.
PM MAIL WWW   Вверх
Alexeis
Дата 20.2.2008, 20:21 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Амеба
Group Icon


Профиль
Группа: Админ
Сообщений: 11743
Регистрация: 12.10.2005
Где: Зеленоград

Репутация: 34
Всего: 459
Цитата(lukas @  20.2.2008,  18:45 Найти цитируемый пост)
мы же эти операции будем производить не заранее...  

Цитата(lukas @  20.2.2008,  17:03 Найти цитируемый пост)
есть еще вариант, сгенирировать заранее список координат пикселей...

  Так определись заранее или не заранее. 


--------------------
Vit вечная память.

Обсуждение действий администрации форума производятся только в этом форуме

гениальность идеи состоит в том, что ее невозможно придумать
PM ICQ Skype   Вверх
bems
Дата 20.2.2008, 20:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Комодератор
Сообщений: 3400
Регистрация: 5.1.2006

Репутация: 18
Всего: 88
Цитата(Alexeis @  20.2.2008,  12:31 Найти цитируемый пост)
При повторном выборе пикселя, нужно брать соседний, а если он уже выбран, то продолжать двигаться, пока не будет найден тот который еще не брали.  

или если совпадение то увеличить размер области, переносимой за один раз. Типа сначала красим не пиксели, а круги еденичного диаметра. Если центр округа попал в уже перенесенную точку, то увеличиваем диаметр круга в Х раз. Этот Х подбираем методом тыка или вычисляем из площади битмапа.


--------------------
Обижено школьников: 8
PM MAIL   Вверх
Алексей
Дата 21.2.2008, 16:34 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 112
Регистрация: 19.6.2006

Репутация: нет
Всего: нет
Не могли бы вы чуть чуть набросать свои вариантыsmile Что-то я не совсем понимаю  smile 
PM MAIL   Вверх
lukas
Дата 21.2.2008, 17:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 771
Регистрация: 23.2.2007

Репутация: 3
Всего: 15
Alexeis, 

сорри.... я не то имел ввиду...  smile ... 

ну вот например:


Код

procedure RandomList(LS: TStrings): TStringList;
  Var
  I,Len,Id: Integer;
begin
Result := TStringList.Create;
 Len := LS.Count; 
   for i:=0 to Len - 1 do
     begin
          Id := Random(LS.Count);
          Result.Add(LS[Id]);
          LS.Delete(Id);
     end;
end;



--------------------
http://code.google.com/p/orionphp/ - opensource скриптовой язык Orion (аналог PHP) для freepascal/delphi.
PM MAIL WWW   Вверх
bems
Дата 21.2.2008, 18:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Комодератор
Сообщений: 3400
Регистрация: 5.1.2006

Репутация: 18
Всего: 88
вот пример с простым закрашиванием. Чтобы переделать на смену картинки нужно сравнения canvas.Pixels[x,y]=clRed переделать в проверку перенесена ли уже точка, и написать перенос окружности с битмапа на битмап. Хотя наверное можно заменить на квадрат

Код

procedure TForm1.BitBtn1Click(Sender: TObject);
var n,m,MaxM:integer;rct:TRect;x,y,id:integer;d:real;refr:integer;
begin
with img.Picture.Bitmap do
 begin
 d:=2;
 MaxM:=5;
 refr:=((width+height) div 2);
 canvas.Brush.Color:=clRed;
 canvas.Pen.Color:=clRed;
 for n:=1 to Width*Height do //заменить на проверку остались ли неперенесенные точки
  begin
  m:=0;
  repeat
   x:=random(Width);
   y:=random(Height);
   inc(m);
  until (canvas.Pixels[x,y]<>clRed) or (m>=MaxM);
  if (m=MaxM) and (canvas.Pixels[x,y]=clRed) then dec(MaxM);
  id:=round(d*1.5);
  if canvas.Pixels[x,y]=clRed then inc(x,id);
  if canvas.Pixels[x,y]=clRed then dec(y,id);
  if canvas.Pixels[x,y]=clRed then dec(x,id);
  if canvas.Pixels[x,y]=clRed then dec(x,id);
  if canvas.Pixels[x,y]=clRed then inc(y,id);
  if canvas.Pixels[x,y]=clRed then inc(y,id);
  if canvas.Pixels[x,y]=clRed then inc(x,id);
  if canvas.Pixels[x,y]=clRed then inc(x,id);
  if canvas.Pixels[x,y]=clRed then d:=d*2;
  rct.Left:=round(x-d/2);
  rct.Top:=round(y-d/2);
  rct.Right:=round(x+d/2);
  rct.Bottom:=round(y+d/2);
  canvas.Ellipse(rct);
  if n mod refr=0 then img.Refresh;
  end;
 end;
end;


img это TImage.

Это сообщение отредактировал(а) bems - 21.2.2008, 18:47


--------------------
Обижено школьников: 8
PM MAIL   Вверх
Алексей
Дата 22.2.2008, 00:41 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 112
Регистрация: 19.6.2006

Репутация: нет
Всего: нет
bems, когда запускаю пишет ошибку.

Код

Project Project1.exe raised exception class EAccessViolation with message 'Access violation at address 0044DA70 in module 'Project1.exe'. 
Read of address 00000168'. Process stoped. Use Step or Run to continue.


Это сообщение отредактировал(а) Алексей - 22.2.2008, 00:41
PM MAIL   Вверх
bems
Дата 22.2.2008, 14:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Комодератор
Сообщений: 3400
Регистрация: 5.1.2006

Репутация: 18
Всего: 88
поставь размеры img.picture.bitmap и введи критерий "перенесена вся картинка". 


--------------------
Обижено школьников: 8
PM MAIL   Вверх
diamondd
Дата 1.3.2008, 00:17 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 26
Регистрация: 11.9.2007

Репутация: нет
Всего: нет
может так?

Код

procedure TForm1.Rand;
var
  //объявляешь массив из точек
  ar: array of TPoint;
  Temp: TPoint;
  i,N,T: Integer;
begin
  //считаешь необходимое кол-во точек
  N:=Form1.Width*Form1.Height;
  //устанавливаешь длину массива
  SetLength(ar,N);
  //заполняешь массив всеми точками
  //от (0,0) до (Form1.Width-1,Form1.Height-1)
  for i:=0 to (N-1) do
    ar[i]:=Point(i mod Form1.Width,i div Form1.Width);
  Randomize;
  //далее просто каждую точку из массива
  //меняешь местами со случайной
  for i:=0 to (N-1) do
    begin
    T:=Random(N);
    Temp:=ar[i];
    ar[i]:=ar[T];
    ar[T]:=Temp
    end;
  //в результате получается массив со всеми точками в случайном порядке
  //а затем меняешь их местами как хочешь :)
end;
PM MAIL   Вверх
  
 Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Для новичков"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи

Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.
 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Для новичков | Следующая тема »

Подписаться на тему | Подписка на этот форум | Скачать/Распечатать тему


 




[ Время генерации скрипта: 0.0567 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
 По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.