[Vayrus]

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

Код:

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;

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

Код:

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.]

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

Код:

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

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

[Vayrus]

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

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

Код:

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

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

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

[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? Гистограмма это вообще элементарно, Ватсон: количество элементов в каждом интервале. и т.д.

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

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

Код:

// 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. Поиск объекта (в данном случае груди или какой-нибудь стилизованной формы груди) на любом изображении обнаженной натуры, т.е. необходимо количество совпадений с шаблоном и процент похожести на каждое совпадение.