[Vayrus]

Приветствую, необходима помощь в перечислении уникальных цветов в изображении, подсчет количества пикселей определенных цветов и выражение в % соотношении 15 превалирующих... С подсчетом вроде как проблем нет, но решил объединить с подсчетом пикселей, в итоге получилось следующее, но выкидывает ошибку, сильно не вдавался, но, видимо сказывается мое полное нубство в массивах, и вообще по работе с пикселами:

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47

procedure TForm1.Button9Click(Sender: TObject);   type   TColorInfo = record     Color: TColor;     count: integer;   end;   var   i: integer;   col: TColor;   //   multiArray: Array [0 .. 1000000] of TColorInfo;     procedure AddValue(aCol: TColor);   var     i: integer;     curr: TColorInfo;   begin     for i := Low(multiArray) to High(multiArray) do     begin       curr := multiArray[i];       if curr.Color = aCol then       begin         inc(curr.count);         BREAK;       end;       Application.ProcessMessages;     end;     //     multiArray[i + 1].Color := aCol;     multiArray[i + 1].count := 1;   end;   begin   for i := 0 to Image1.Height - 1 do   begin     for j := 0 to Image1.Width - 1 do     begin       col := Image1.Canvas.Pixels[j, i];       AddValue(col);       Application.ProcessMessages;     end;     Application.ProcessMessages;   end;   // end;

До кучи чужой оптимизированный алго подсчета уникальных цветов:

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36

procedure TForm1.Button1Click(Sender: TObject); const   len = 2097152; // 2^24 div 8 var   x, y, adr, abyte, count: integer;   cbyte, bit: byte;   scan: pByteArray;   cnt: array of byte; begin   SetLength(cnt, len);   count := 0;   FillChar(cnt[0], len, #0);   with TBitmap.Create do   begin     Assign(Image1.Picture.Graphic);     PixelFormat := pf24bit;     for y := 0 to Height - 1 do     begin       scan := ScanLine[y];       for x := 0 to Width - 1 do       begin         adr := scan[x * 3 + 0] shl 16 + scan[x * 3 + 1] shl 8 + scan[x * 3 + 2];         abyte := adr div 8;         bit := 1 shl (adr mod 8);         cbyte := cnt[abyte];         if cbyte and bit = 0 then         begin           cnt[abyte] := cbyte or bit;           inc(count);         end;       end;     end;     Free;   end;   Label1.caption := 'Количество цветов: ' + IntToStr(count); end;

[M.A.D.M.A.N.]

Я бы так сделал:

Код:

1 2 3 4 5 6

var   colorCount: array[TColor] of integer; ...   for x...     for y...       inc(colorCount[bitmap.canvas.pixels[x, y]]);

Правда едрить сколько памяти оно сожрет.

[Vayrus]

Сообщение от M.A.D.M.A.N.

Я бы так сделал:

Код:

Правда едрить сколько памяти оно сожрет.

Памяти у меня много)) так что пока без оптимизации можно обойтись, главное, чтобы работало. А вообще, итоговый результат состоит в том, чтобы получить соотношение "цвета" кожи человека на изображении к другим цветам или количество пикселей "коричневого цвета" (с цветом кожи - это диапозон оттенков) к остальной сумме пикселей, вроде как то так

[AlexSku]

Есть другой подход (реализация, правда, на MatLab'е):
what-color-is-green
two-dimensional-histograms
freehand-segmentation-in-the-a-b-plane
more-on-segmenting-in-a-b-space

Сначала пространство RGB перевести в Lab. Яркость L не нужна. По ab строим двумерные гистограммы. Автор (Steve Eddins) приводит алгоритмы ручного и автоматического распознавания зелёных шариков.

[Vayrus]

Спасибо конечно, но реализаций на Матлабе и ПХП полно, а вот на Дельфине нет(

[AlexSku]

Я же разбил задачу на кусочки. Вы хотите сказать, что на Delphi нельзя перевести RGB в Lab? Гистограмма это вообще элементарно, Ватсон: количество элементов в каждом интервале. и т.д.

[Vayrus]

Сообщение от AlexSku

Я же разбил задачу на кусочки. Вы хотите сказать, что на Delphi нельзя перевести RGB в Lab? Гистограмма это вообще элементарно, Ватсон: количество элементов в каждом интервале. и т.д.

Я хочу сказать, что для меня это дремучий лес не в плане знаний предмета, а в плане реализации... И с гистограммой проблем нет, нужно тока научиться их сравнивать, а вообще задача, как я уже говорил, ну сейчас уточню, сводится к поиску объекта определенной формы на изображении, т.е. просто есть он там или нет (и сколько раз встречается), при том само изображение может быть и черно-белым и зашумленным, а объект на нем может быть в другом ракурсе, повернут, сжат, удлинен, частично обрезан и т.п., т.е. это усложняет анализ, пытался обучить нейросеть для этого, но найденный пример оказался непригоден для использования с новым РАД Студио, да и библиотек соответствующих не оказалось...

Найденный пример получения гистограммы:

Код:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121

// Histogram   const   RedCanal = 0;   GreenCanal = 1;   BlueCanal = 2;   GrayCanal = 3;   type     TRGB24 = array [0 .. 2] of Byte;   ARGB24 = array [0 .. 0] of TRGB24;   PRGB24 = ^ARGB24;     TTypeCanal = Byte;     PHistogram = ^THistogram;     THistogram = object     m_Count: LongWord;     m_MaxColor: Byte;     m_Color: Array [0 .. 255] of LongWord;       Procedure GetData(BitMap: TBitmap; rc: TRect; tcnl: TTypeCanal);   end;   var   Hist: THistogram;   canal: TTypeCanal = RedCanal;     // end Histogram   // Histogram   Procedure DrawHistogram(canvas: TCanvas; Histogram: PHistogram; rc: TRect); var   x, dx, dy: Real;   y: LongWord;   i: Byte; begin   canvas.Brush.Color := clBlack;   canvas.Pen.Color := canvas.Brush.Color;   canvas.Pen.Style := psSolid;   canvas.Rectangle(rc);   dx := (rc.Right - rc.Left) / 256.0;   // dy := (rc.Bottom-rc.Top) / Histogram.m_Color[Histogram.m_MaxColor]; // ето правельно   dy := (rc.Right - rc.Left) / (Histogram.m_Count) * 30;   // но чтоби увидеть что гистограма одинаковая   x := rc.Left;   if (canal = GrayCanal) then     canvas.Brush.Color := clGray   else     canvas.Brush.Color := $FF shl (canal * 8);   canvas.Pen.Style := psClear;   for i := 0 to 255 do   begin     y := rc.Bottom - Round(Histogram.m_Color[i] * dy);     canvas.Rectangle(Round(x), y, Round(x + dx) + 1, rc.Bottom + 1);     x := x + dx;   end end;   Procedure THistogram.GetData(BitMap: TBitmap; rc: TRect; tcnl: TTypeCanal); var   x0, y0, rWidth, rHeight: LongInt;   i, x, y, Mx, My: LongInt;   LinePict: PRGB24;   Color: TRGB24;   colorI: Byte; begin   x0 := rc.Left;   y0 := rc.top;   rWidth := rc.Right - rc.Left - 1;   rHeight := rc.Bottom - rc.top - 1;   m_Count := rWidth * rHeight;   for i := 0 to 255 do     m_Color[i] := 0;   m_MaxColor := 0;   Mx := x0 + rWidth;   My := y0 + rHeight;   for y := y0 to My do   begin     LinePict := BitMap.ScanLine[y];     for x := x0 to Mx do     begin       Color := LinePict[x];       if (canal = GrayCanal) then         colorI := (Color[0] + Color[1] + Color[2]) div 3       else         colorI := Color[canal];       Inc(m_Color[colorI]);       if (m_Color[colorI] > m_Color[m_MaxColor]) then         m_MaxColor := colorI;     end;   end; end;   // Histogram End   //Using   procedure TForm1.Button12Click(Sender: TObject); var   BitMap: TBitmap;   rc, rcDraw: TRect; begin   BitMap := TBitmap.Create;   try     BitMap.Width := Image1.Picture.Width;     BitMap.Height := Image1.Picture.Height;     BitMap.canvas.Draw(0, 0, Image1.Picture.Graphic);     //     BitMap.PixelFormat := pf24bit;     rc := Rect(0, 0, BitMap.Width, BitMap.Height);     Hist.GetData(BitMap, rc, canal);     rcDraw := Rect(0, 0, Image3.Width, Image3.Height);     DrawHistogram(Image3.canvas, @Hist, rcDraw);   finally     BitMap.Free;   end; end;

[M.A.D.M.A.N.]

Дак персепртон тогда нужен, если образы отыскивать надо.

[Vayrus]

Сообщение от M.A.D.M.A.N.

Дак персепртон тогда нужен, если образы отыскивать надо.

ээээ чегось сказал?)))

а это разве не нейросеть, по-русски)?

ЗЫ
Отошли от темы немного, пока есть следующие ссылки, в которых реализовано то что мне нужно, только на ПХП:

http://xdan.ru/Kak-opredelit-preobla...obrajenii.html
http://xdan.ru/examples/colorator.php (то что нужно перевести на Делфи по данной теме)

http://www.delphisources.ru/forum/sh...d.php?p=112794 (почти то что нужно, но не все преобладающие цвета)
http://habrahabr.ru/post/117040/ (что хочу сделать в итоге)

[AlexSku]

Сообщение от Vayrus

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

Это совсем по-другому решается. Берутся небольшие преобразования (сдвиг, поворот, масштабирование) и считается корреляция.

[Vayrus]

Сообщение от AlexSku

Это совсем по-другому решается. Берутся небольшие преобразования (сдвиг, поворот, масштабирование) и считается корреляция.

пока нужно то что по первой ссылке...

[AlexSku]

А там очень простой алгоритм: подсчёт с дискретизацией. Во-первых, координаты берутся по сетке, напр., 5 пикселей (видимо, алгоритм медленный), во-вторых, цвет делится на h33 (51), округляется, затем умножается на h33, т.е. выбирается шаг для гистограммы.

[Vayrus]

Вот все что есть на данный момент:
https://dl.dropboxusercontent.com/u/...porndetect.rar

Реализовано:
1. Определение уникальных цветов
2. Бинаризация, фильтры
3. Гистограммы (3 варианта)

Что осталось (самое важное):
1. Определение соотношения "цвета кожи" к остальным цветам в %
2. Поиск объекта (в данном случае груди или какой-нибудь стилизованной формы груди) на любом изображении обнаженной натуры, т.е. необходимо количество совпадений с шаблоном и процент похожести на каждое совпадение.