VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsOctree"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' Класс clsOctree.cls - октодерево для квантования цвета и нахождения 256-цветной, оптимальной палитры
' © Кривоус Анатолий Анатольевич (The trick), 2014

Public IsLeaf As Boolean                                                ' True - "лист"
Public Depth As Long                                                    ' Глубина
Public ColorIndex As Long                                               ' Индекс в палитре
Public ChildCount As Long                                               ' Количество дочерних валидных элементов
Public ColorCount As Long                                               ' Количество обращений
Public Nxt As clsOctree                                                 ' Позиция следующего листа в связном списке
Public R As Long                                                        ' Компоненты цвета
Public G As Long
Public B As Long

Private mChild() As clsOctree                                           ' Дочерние узлы
Private Mask() As Long                                                  ' Маска глубины битности

Public Property Get Child(ByVal Index As Long) As clsOctree
    Set Child = mChild(Index)
End Property
Public Property Set Child(ByVal Index As Long, Value As clsOctree)
    Set mChild(Index) = Value
End Property
' Получить ближайший похожий цвет из палитры
Friend Property Get GetNearestPaletteIndex(Col As RGBTriple) As Long
    Dim Br As Long
    If IsLeaf Then GetNearestPaletteIndex = ColorIndex: Exit Property
    Br = CBool(Col.R And Mask(Depth)) * -4 + _
         CBool(Col.G And Mask(Depth)) * -2 + _
         CBool(Col.B And Mask(Depth)) * -1
    GetNearestPaletteIndex = mChild(Br).GetNearestPaletteIndex(Col)
End Property
' Получить палитру
Public Sub GetPalette(Pal() As Long, Optional StartIndex As Long)
    Dim rr As Long, rg As Long, rb As Long, i As Long
    If IsLeaf Or Depth = TreeLeafLevel Then
        rr = R \ ColorCount
        rg = G \ ColorCount
        rb = B \ ColorCount
        Pal(StartIndex) = rr * &H10000 Or rg * &H100 Or rb
        ColorIndex = StartIndex
        IsLeaf = True
        StartIndex = StartIndex + 1
    Else
        For i = 0 To 7
            If Not mChild(i) Is Nothing Then
                mChild(i).GetPalette Pal(), StartIndex
            End If
        Next
    End If
End Sub
' Добавить цвет в дерево
Friend Sub AddTree(Col As RGBTriple, ByVal Depth As Long)
    Dim Br As Long
    ColorCount = ColorCount + 1
    Me.R = Me.R + Col.R
    Me.G = Me.G + Col.G
    Me.B = Me.B + Col.B
    If IsLeaf = False And Depth < TreeLeafLevel Then
        Br = CBool(Col.R And Mask(Depth)) * -4 + _
             CBool(Col.G And Mask(Depth)) * -2 + _
             CBool(Col.B And Mask(Depth)) * -1
        If mChild(Br) Is Nothing Then
            ChildCount = ChildCount + 1
            If ChildCount = 2 Then
                Set Nxt = TreeReduceList(Depth)
                Set TreeReduceList(Depth) = Me
            End If
        End If
        Depth = Depth + 1
        If mChild(Br) Is Nothing Then
            Set mChild(Br) = New clsOctree
            mChild(Br).Depth = Depth
            mChild(Br).IsLeaf = Depth >= TreeLeafLevel
            If mChild(Br).IsLeaf Then TreeSize = TreeSize + 1
        End If
        mChild(Br).AddTree Col, Depth
    End If
End Sub
' Удалить все дочерние узлы
Public Sub KillChild()
    Dim i As Long
    If ChildCount = 0 Then Exit Sub
    For i = 0 To 7
        If Not mChild(i) Is Nothing Then mChild(i).KillChild
        Set mChild(i) = Nothing
    Next
End Sub
' "Обрезать" дерево
Public Sub ReduceTree()
    Dim Node As clsOctree, i As Long, d As Long
    i = TreeReduceLevel
    Do While TreeReduceList(i) Is Nothing: i = i - 1: Loop
    Set Node = TreeReduceList(i)
    Set TreeReduceList(i) = TreeReduceList(i).Nxt
    Node.IsLeaf = True: d = Node.Depth
    TreeSize = TreeSize - Node.ChildCount + 1
    Node.KillChild
    Set Node = Nothing
    If d < TreeReduceLevel Then
        TreeReduceLevel = d
        TreeLeafLevel = d + 1
    End If
End Sub
Private Sub Class_Initialize()
    Dim i As Long
    ReDim mChild(7)
    ReDim Mask(7)
    Mask(0) = 128
    For i = 1 To 7
        Mask(i) = Mask(i - 1) \ 2
    Next
End Sub
