Attribute VB_Name = "Mod256Colors"
' Mod256Colors.bas

'   From cPalette.Cls
'   Copyright © 1999 Steve McMahon
'
'   The Octree Colour Quantisation Code (CreateOptimal) was written by
'   Brian Schimpf Copyright © 1999 Brian Schimpf

' RR
' Also Octree code extracted & adapted from 'Ordered dither test"
' by Carles P V (PSC CodeId=49875).

' This is a simplified version

Option Explicit

Private Type PALETTEENTRY
    peR     As Byte
    peG     As Byte
    peB     As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE256
    palVersion       As Integer
    palNumEntries    As Integer
    palPalEntry(0 To 255) As PALETTEENTRY
End Type
Private logpal256 As LOGPALETTE256

Private Type tNode    'OCT-TREE node struct.
   bIsLeaf            As Boolean ' Leaf flag
   bAddedReduce       As Boolean ' Linked list flag
   vR                 As Long    ' Red Value
   vG                 As Long    ' Green Value
   vB                 As Long    ' Blue Value
   cClrs              As Long    ' Pixel count
   iChildren(0 To 1, 0 To 1, 0 To 1) As Long   ' Child pointers
   iNext              As Long    ' Next reducable node
End Type

' Octree variables
Private aNodes()   As tNode
Private cNodes     As Long
Private nDepth     As Byte
Private TopGarbage As Long
Private cClr       As Long
Private aReduce()  As Long

Private gRED() As Byte
Private gGREEN() As Byte
Private gBLUE() As Byte

' For logical palette
Private NumEntries As Integer
Private hpal As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
 (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GetNearestPaletteIndex Lib "gdi32" (ByVal hPalette As Long, ByVal crColor As Long) As Long

Public gifPAL() As Long
Public bA8() As Byte


'<<<< Progress bar >>>>>>>>>>
Private xd As Single, xp As Single

Public Sub Get256PAL(bA32() As Byte, NColors As Long, Optional Extract As Boolean = True)
' Only called from frmColors cmdLoadPal to extract a 256 palette

' bA32() = picDATA()   TO  Public gifPAL(0 To 255) As Long
Dim NumLevels As Long
  
Dim gWidth As Long
Dim gHeight As Long
Dim ix As Long
Dim iy As Long
Dim k As Long

   Screen.MousePointer = vbHourglass
   ReDim gRED(0 To 255)
   ReDim gGREEN(0 To 255)
   ReDim gBLUE(0 To 255)
   ReDim gifPAL(0 To 255)
   
   gWidth = UBound(bA32, 2)      ' FullW-1
   gHeight = UBound(bA32, 3)     ' FullH-1

   NumLevels = 8

   '-- Allocates initial storage
   ReDim aNodes(1 To 50) As tNode
   ReDim aReduce(1 To 8) As Long
   nDepth = NumLevels
   cNodes = 1
   TopGarbage = 0
   cClr = 0

   StartProgress gHeight
   For iy = 0 To gHeight
      For ix = 0 To gWidth
         '-- Adds the current pixel to the color octree
         If Extract Then
            Call pvAddClr(1, 1, 0, 255, 0, 255, 0, 255, _
                 bA32(0, ix, iy), bA32(1, ix, iy), bA32(2, ix, iy))  ' B,G,R nec ?
         Else
            Call pvAddClr(1, 1, 0, 255, 0, 255, 0, 255, _
                 bA32(2, ix, iy), bA32(1, ix, iy), bA32(0, ix, iy))  ' B,G,R nec ?
         End If
         '-- Combine the levels to get down to desired palette size
         'Do While (cClr > NumColors)
         Do While (cClr > NColors)
             If (pvCombineNodes = 0) Then Exit Do
         Loop
      Next ix
      DrawProgress
   Next iy
   frm256Colors.picPB.Cls
   '-- Go through octree and extract colors
   k = 0
   For iy = 1 To UBound(aNodes)
      If (aNodes(iy).bIsLeaf) Then
         With aNodes(iy)
            gRED(k) = .vR / .cClrs
            gGREEN(k) = .vG / .cClrs
            gBLUE(k) = .vB / .cClrs
            k = k + 1
         End With
      End If
   Next iy
   NumEntries = k
   ' Transfer colors to gifPAL(0-255) As Long
   'Public gifPAL(0 To 255) As Long
   For k = 0 To 255
      gifPAL(k) = RGB(gRED(k), gGREEN(k), gBLUE(k))
   Next k
   
   Screen.MousePointer = vbDefault
End Sub

Public Sub ReduceTo256(bA32() As Byte, NumColors As Long, Optional aTransfer As Boolean = False)
' EG
' ReduceTo256 picDATA()
' bA32() = picDATA()
' aTransfer = False convert bA32()
'           = True  indexes to bA8()

' Output Public gifPAL(0 to 255) Longs                            ' 1024 palette
'        Public bA8(0 To UBound(bA32, 2), 0 To UBound(bA32, 3))   ' Indexes(bytes) to palette
Dim ix As Long
Dim iy As Long

Dim XX As Long, YY As Long
Dim mIndex As Byte
Dim mCurr As Long, mPrev As Long
Dim errR As Long, errG As Long, errB As Long
Dim newR As Long, newG As Long, newB As Long
'
' Can be inputted NOT USED
'Dim NColors As Long
'Dim NumLevels As Long
  
Dim gWidth As Long
Dim gHeight As Long

   Screen.MousePointer = vbHourglass
   
   Get256PAL bA32(), NumColors - 1, False
   
   gWidth = UBound(bA32, 2)      ' FullW-1
   gHeight = UBound(bA32, 3)     ' FullH-1
   
   ' Make logical palette
   If hpal <> 0 Then
      DeleteObject hpal
      hpal = 0
   End If
   ' Force 256
   NumEntries = 256
   With logpal256
      .palNumEntries = NumEntries
      .palVersion = &H300
      CopyMemory .palPalEntry(0), gifPAL(0), 1024
   End With
   hpal = CreatePalette(logpal256)
   '------------------------------------------------------------
   StartProgress gHeight
   mPrev = -1
   ' If Not aTransfer Then   ' Reducing to 16,32,64,128 or 256 colors
      
   If aTransfer Then  ' Transfer indexes to bA8() for saving as GIF87A
      ReDim bA8(0 To gWidth, 0 To gHeight)
   End If
      
   For iy = 0 To gHeight
      For ix = 0 To gWidth
         mCurr = RGB(bA32(2, ix, iy), bA32(1, ix, iy), bA32(0, ix, iy))
         If mCurr <> mPrev Then
              mIndex = GetNearestPaletteIndex(hpal, mCurr)
              mPrev = mCurr
         End If

         ' Diffuse error Floyd-SteinbergB
         '0 (ix,iy) 7             ' iy
         '3    5    1    / 16     ' iy+1
         'ix-1      ix+1

         errB = CLng(bA32(0, ix, iy)) - gBLUE(mIndex)
         errG = CLng(bA32(1, ix, iy)) - gGREEN(mIndex)
         errR = CLng(bA32(2, ix, iy)) - gRED(mIndex)

         bA32(0, ix, iy) = gBLUE(mIndex)
         bA32(1, ix, iy) = gGREEN(mIndex)
         bA32(2, ix, iy) = gRED(mIndex)

         If aTransfer Then
            bA8(ix, iy) = GetNearestPaletteIndex(hpal, RGB(bA32(2, ix, iy), bA32(1, ix, iy), bA32(0, ix, iy)))
         End If

         If (Abs(errB) + Abs(errG) + Abs(errR) > 3) Then
            If (ix < gWidth) Then
               XX = ix + 1
               newB = bA32(0, XX, iy) + (7 * errB) \ 16
               newG = bA32(1, XX, iy) + (7 * errG) \ 16
               newR = bA32(2, XX, iy) + (7 * errR) \ 16
               If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
               If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
               If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
               bA32(0, XX, iy) = newB
               bA32(1, XX, iy) = newG
               bA32(2, XX, iy) = newR
               If aTransfer Then
                  bA8(XX, iy) = GetNearestPaletteIndex(hpal, RGB(newR, newG, newB))
               End If
            End If
            If (iy < gHeight) Then
               YY = iy + 1
               newB = bA32(0, ix, YY) + (5 * errB) \ 16
               newG = bA32(1, ix, YY) + (5 * errG) \ 16
               newR = bA32(2, ix, YY) + (5 * errR) \ 16
               If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
               If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
               If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
               bA32(0, ix, YY) = newB
               bA32(1, ix, YY) = newG
               bA32(2, ix, YY) = newR
               If aTransfer Then
                  bA8(ix, YY) = GetNearestPaletteIndex(hpal, RGB(newR, newG, newB))
               End If
               If (ix < gWidth) Then
                  XX = ix + 1
                  newB = bA32(0, XX, YY) + errB \ 16
                  newG = bA32(1, XX, YY) + errG \ 16
                  newR = bA32(2, XX, YY) + errR \ 16
                  If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
                  If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
                  If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
                  bA32(0, XX, YY) = newB
                  bA32(1, XX, YY) = newG
                  bA32(2, XX, YY) = newR
                  If aTransfer Then
                     bA8(XX, YY) = GetNearestPaletteIndex(hpal, RGB(newR, newG, newB))
                  End If
               End If
               If (ix > 0) Then
                  XX = ix - 1
                  newB = bA32(0, XX, YY) + (3 * errB) \ 16
                  newG = bA32(1, XX, YY) + (3 * errG) \ 16
                  newR = bA32(2, XX, YY) + (3 * errR) \ 16
                  If (newB < 0) Then newB = 0 Else If (newB > 255) Then newB = 255
                  If (newG < 0) Then newG = 0 Else If (newG > 255) Then newG = 255
                  If (newR < 0) Then newR = 0 Else If (newR > 255) Then newR = 255
                  bA32(0, XX, YY) = newB
                  bA32(1, XX, YY) = newG
                  bA32(2, XX, YY) = newR
                  If aTransfer Then
                     bA8(XX, YY) = GetNearestPaletteIndex(hpal, RGB(newR, newG, newB))
                  End If
               End If
            End If   'If (iy < gHeight) Then
         End If   'If (Abs(errB) + Abs(errG) + Abs(errR) > 3) Then
      Next ix
      DrawProgress
   Next iy
   frm256Colors.picPB.Cls

   ' Delete logical palette
   If hpal <> 0 Then
      DeleteObject hpal
      hpal = 0
   End If
   Screen.MousePointer = vbDefault
End Sub


'========================================================================================
' Private   From Carles P V
'========================================================================================

Private Sub pvAddClr(ByVal iBranch As Long, ByVal nLevel As Long, _
                     ByVal vMinR As Byte, ByVal vMaxR As Byte, _
                     ByVal vMinG As Byte, ByVal vMaxG As Byte, _
                     ByVal vMinB As Byte, ByVal vMaxB As Byte, _
                     ByVal r As Byte, ByVal g As Byte, ByVal B As Byte)

' <Recursive>
' Adds a color to the OctTree palette.
' Will call itself if not in correct level.
'
' Inputs:
'  - iBranch (Branch to look down)
'  - nLevel (Current level (depth) in tree)
'  - vMin(R, G, B) (The minimum branch value)
'  - vMax(R, G, B) (The maximum branch value)
'  - R, G, B (The Red, Green, and Blue color components)
  
  Dim iR As Byte, ig As Byte, iB As Byte
  Dim vMid As Byte, iIndex As Long
    
    '-- Find mid values for colors and decide which path to take.
    '   Also update max and min values for later call to self.
    
    vMid = vMinR / 2 + vMaxR / 2
    If (r > vMid) Then iR = 1: vMinR = vMid Else iR = 0: vMaxR = vMid

    vMid = vMinG / 2 + vMaxG / 2
    If (g > vMid) Then ig = 1: vMinG = vMid Else ig = 0: vMaxG = vMid

    vMid = vMinB / 2 + vMaxB / 2
    If (B > vMid) Then iB = 1: vMinB = vMid Else iB = 0: vMaxB = vMid
    
    '-- If no child here then...
    If (aNodes(iBranch).iChildren(iR, ig, iB) = 0) Then
        '-- Get a new node index
        iIndex = pvGetFreeNode
        aNodes(iBranch).iChildren(iR, ig, iB) = iIndex
        aNodes(iBranch).cClrs = aNodes(iBranch).cClrs + 1
        '-- Clear/set data
        With aNodes(iIndex)
            .bIsLeaf = (nLevel = nDepth)
            .iNext = 0
            .cClrs = 0
            .vR = 0
            .vG = 0
            .vB = 0
        End With
      Else
        '-- Has a child here
        iIndex = aNodes(iBranch).iChildren(iR, ig, iB)
    End If
 
    '-- If it is a leaf
    If (aNodes(iIndex).bIsLeaf) Then
        With aNodes(iIndex)
            If (.cClrs = 0) Then cClr = cClr + 1
            .cClrs = .cClrs + 1
            .vR = .vR + r
            .vG = .vG + g
            .vB = .vB + B
        End With
    Else
        With aNodes(iIndex)
            '-- If 2 or more colors, add to reducable aNodes list
            If (.bAddedReduce = 0) Then
                .iNext = aReduce(nLevel)
                 aReduce(nLevel) = iIndex
                .bAddedReduce = -1
            End If
        End With
        '-- Search a level deeper
        Call pvAddClr(iIndex, nLevel + 1, vMinR, vMaxR, vMinG, vMaxG, vMinB, vMaxB, r, g, B)
    End If
End Sub

Private Function pvCombineNodes() As Boolean

' Combines octree aNodes to reduce the count of colors.
' Combines all children of a leaf into itself.
  
  Dim i As Long, iIndex As Long
  Dim iR As Byte, ig As Byte, iB As Byte
  Dim nR As Long, nG As Long, nb As Long, nPixel As Long

    '-- Find deepest reducable level
    For i = nDepth To 1 Step -1
        If (aReduce(i) <> 0) Then Exit For
    Next i

    If (i = 0) Then Exit Function
    iIndex = aReduce(i)
    aReduce(i) = aNodes(iIndex).iNext

    For i = 0 To 7
        If (i And 1) = 1 Then iR = 1 Else iR = 0
        If (i And 2) = 2 Then ig = 1 Else ig = 0
        If (i And 4) = 4 Then iB = 1 Else iB = 0
        
        '-- If there is a child
        If (aNodes(iIndex).iChildren(iR, ig, iB) <> 0) Then
            With aNodes(aNodes(iIndex).iChildren(iR, ig, iB))
                '-- Add red, green, blue, and pixel count to running total
                nR = nR + .vR
                nG = nG + .vG
                nb = nb + .vB
                nPixel = nPixel + .cClrs
                '-- Free the node
                Call pvFreeNode(aNodes(iIndex).iChildren(iR, ig, iB))
                cClr = cClr - 1
            End With
            '-- Clear the link
            aNodes(iIndex).iChildren(iR, ig, iB) = 0
        End If
    Next i
    cClr = cClr + 1

    '-- Set the new node data
    With aNodes(iIndex)
        .cClrs = nPixel
        .bIsLeaf = -1
        .vR = nR
        .vG = nG
        .vB = nb
    End With
    pvCombineNodes = -1
End Function

Private Sub pvFreeNode(ByVal iNode As Long)

' Puts a node on the top of the garbage list.
' Inputs:
'  - iNode
'  - Index of node to free
    
    aNodes(iNode).iNext = TopGarbage
    TopGarbage = iNode
    aNodes(iNode).bIsLeaf = 0 ' Necessary for final loop through
    aNodes(iNode).bAddedReduce = 0
    cNodes = cNodes - 1
End Sub

Private Function pvGetFreeNode() As Long

' pvGetFreeNode: Gets a new node index from the CAST list or the
' end of the list. Clears child pointers.
' Outputs:
'  - Node index
  
  Dim i  As Long
  Dim iR As Byte
  Dim ig As Byte
  Dim iB As Byte
  
    cNodes = cNodes + 1
    If (TopGarbage = 0) Then
        If (cNodes > UBound(aNodes)) Then
            i = cNodes * 1.1
            ReDim Preserve aNodes(1 To i)
        End If
        pvGetFreeNode = cNodes
      Else
        pvGetFreeNode = TopGarbage
        TopGarbage = aNodes(TopGarbage).iNext
        For i = 0 To 7
            If (i And 1) = 1 Then iR = 1 Else iR = 0
            If (i And 2) = 2 Then ig = 1 Else ig = 0
            If (i And 4) = 4 Then iB = 1 Else iB = 0
            aNodes(pvGetFreeNode).iChildren(iR, ig, iB) = 0
        Next i
    End If
End Function
'========================================================================================

Private Sub StartProgress(ByVal zPAR As Single)
' Private xd As Single, xp As Single
' EG: Par = PRELIEF * FullH
   frm256Colors.picPB.DrawWidth = 3
   frm256Colors.picPB.Cls
   xp = 0
   xd = frm256Colors.picPB.Width / zPAR
   frm256Colors.picPB.PSet (xp, 2)
End Sub
Private Sub DrawProgress()
' Private xd As Single, xp As Single
   frm256Colors.picPB.Line -(xp, 2)
   frm256Colors.picPB.Refresh
   xp = xp + xd
End Sub


