Mihail_vb6 писал(а):и выдает палитру на основе наиболее частых цветов
Mihail_vb6 писал(а):https://kuler.adobe.com/explore/most-popular/
Mihail_vb6 писал(а):а можно ли сделать пока без округления?
Mihail_vb6 писал(а):или вообще эффективные варианты сортировки типа "пузырьком" и т.д.
Mihail_vb6 писал(а):p.s. в опере 15 открывается нормально
Mihail_vb6 писал(а):а можно ли сделать пока без округления? я хотел бы сначала получить точное количество цветов, а уже потом их округлять
Private Sub Analiz_Click()
Set oDict = CreateObject("Scripting.Dictionary")
Dim R, C, Z
For R = 1 To 480
Caption = "Обработка строки " & R
For C = 1 To 640
Z = Picture1.Point(R, C)
If Z >= 0 Then
If oDict.Exists(Z) Then
oDict.Item(Z) = oDict.Item(Z) + 1
Else
oDict.Add Z, 1
End If
End If
Next C, R
T = oDict.keys
ReDim M(UBound(T), 1)
For R = 0 To UBound(T)
M(R, 0) = T(R): M(R, 1) = oDict.Item(T(R))
Next R
S = M
Caption = "Сортировка"
QuickSortNonRecursive S, 1, 1
Caption = "Готово"
End Sub
Private Function QuickSortNonRecursive(SortArray(), Stolb, Optional Ubiv)
Dim i As Double, j As Double, lb As Double, ub As Double, N
Dim stack() As QuickStack, stackpos As Double, ppos As Double, pivot As Variant, swp, maxstack&
N = Stolb
Dim St As Integer
On Error GoTo er
ReDim stack(1 To 16)
stackpos = 1
stack(1).Low = LBound(SortArray)
stack(1).High = UBound(SortArray)
Do
'Взять границы lb и ub текущего массива из стека.
lb = stack(stackpos).Low
ub = stack(stackpos).High
stackpos = stackpos - 1
Do
'Шаг 1. Разделение по элементу pivot
ppos = (lb + ub) \ 2
i = lb: j = ub: pivot = SortArray(ppos, N)
Do
If IsMissing(Ubiv) Then
While SortArray(i, N) < pivot: i = i + 1: Wend
While pivot < SortArray(j, N): j = j - 1: Wend
Else
While SortArray(i, N) > pivot: i = i + 1: Wend
While pivot > SortArray(j, N): j = j - 1: Wend
End If
If i > j Then Exit Do
' If i <> j Then
For St = 1 To UBound(SortArray, 2)
swp = SortArray(i, St): SortArray(i, St) = SortArray(j, St): SortArray(j, St) = swp
Next St
'End If
i = i + 1
j = j - 1
' End If
Loop While i <= j
'Сейчас указатель i указывает на начало правого подмассива,
'j - на конец левого lb ? j ? i ? ub.
'Возможен случай, когда указатель i или j выходит за границу массива
'Шаги 2, 3. Отправляем большую часть в стек и двигаем lb,ub
If i < ppos Then 'правая часть больше
If i < ub Then
stackpos = stackpos + 1
stack(stackpos).Low = i
stack(stackpos).High = ub
End If
ub = j 'следующая итерация разделения будет работать с левой частью
Else
If j > lb Then
stackpos = stackpos + 1
stack(stackpos).Low = lb
stack(stackpos).High = j
End If
lb = i
End If
' If maxstack < stackpos Then maxstack = stackpos
Loop While lb < ub
Loop While stackpos
Exit Function
er: ReDim Preserve stack(1 To UBound(stack) * 2)
Resume
' Debug.Print maxstack
End Function
Private Sub Spisok_Click()
Dim R, C As Long
Список1.Clear
C = Topf
For R = 1 To C
Список1.AddItem S(R, 0) & " - " & S(R, 1)
Next R
End Sub
alex77755 писал(а):А зачем создавать массив из всех возможных цветов?
alex77755 писал(а):Ошибаюсь?
что цвета в видео надо округлять
а можно ли сделать пока без округления? я хотел бы сначала получить точное количество цветов
alex77755 писал(а):Я сделал анализ нескольких картинок. вполне адекватные результаты:
alex77755 писал(а):Единственное с чем не могу помочь в данном случае: получить в массив сразу массив цветов пикселей.
Mihail_vb6 писал(а):информация о цвете записана одним числом, т.е. просто массив длинных чисел вида "123456789"
Qwertiy писал(а):alex77755 писал(а):Я сделал анализ нескольких картинок. вполне адекватные результаты:
А что было на этих картинках и в каком формате? А что если взять кадр из какого-нибудь фильма? И ещё не забыть про то, что видео-кодеки создают артефакты сжатия, которые уже исказят результаты.
Long массив (640x480px) нужно подсчитать наиболее часто встречающиеся цвета пикселов
я хотел бы сначала получить точное количество цветов
alex77755 писал(а):И для чего автору это нужно я не вникаю.
Qwertiy писал(а):А что было на этих картинках и в каком формате? А что если взять кадр из какого-нибудь фильма? И ещё не забыть про то, что видео-кодеки создают артефакты сжатия, которые уже исказят результаты.
alex77755 писал(а):Цветов, конечно, осталось 256.
alex77755 писал(а):Но ТОП10 Всё-равно адекватны:
Надо брать gif
alex77755 писал(а):Там, по крайней мере стандартные цвета хоть и мало
alex77755 писал(а):А что такое 4096 цветов? как называется формат? есть ли стандартный?
Или просто по 16 оттенков в каждом RGB цвете?
Сейчас этот форум просматривают: Yandex-бот и гости: 57