Attribute VB_Name = "ModColors"
' ModColors.bas

Option Explicit

' 3 vertical picboxes height = 256  (picSlide)
' 3 imageboxes (imSlide)

' Returns RGBSlideVal(Index)

Public imDown As Boolean
Public Yim As Single
Public RGBSlideVal() As Long

Public LeftColor As Long
Public RightColor As Long

Public pLeftColor As Long
Public pRightColor As Long
Public aFillpicRGB As Boolean


Public PalARR() As Byte
Public PalSpec$

Private palRed() As Byte, palGreen() As Byte, palBlue() As Byte
Private pR() As Byte, pG() As Byte, pB() As Byte

Private Pow2(7) As Byte

' For Quicksort
Private sortl() As Long, sortr() As Long

Dim CommonDialog1 As cOSDialog

Public Sub InitSlider(Ndex As Long, PIC As PictureBox)
Dim k As Long
   PIC.Height = 256
   For k = 0 To 255
      Select Case Ndex
      Case 0: PIC.Line (0, k)-(PIC.Width, k), RGB(255 - k, 0, 0)
      Case 1: PIC.Line (0, k)-(PIC.Width, k), RGB(0, 255 - k, 0)
      Case 2: PIC.Line (0, k)-(PIC.Width, k), RGB(0, 0, 255 - k)
      End Select
   Next k
End Sub

Public Sub Slider(Ndex As Long, Index As Integer, IM As Image, PIC As PictureBox, Button As Integer, y As Single)
Dim SVal As Long
Dim SValScaled As Long
   Select Case Ndex
   Case 0   ' Image Mouse_Down
      Yim = y
      imDown = True
   Case 1   ' Image Mouse_Move
      If Button = vbLeftButton And imDown Then
         SVal = IM.TOp + (y - Yim) \ STY
         SValScaled = SVal - PIC.TOp + IM.Height \ 2
         If SValScaled >= 0 And SValScaled <= 255 Then
            IM.TOp = SVal
            RGBSlideVal(Index) = 255 - SValScaled
         End If
      End If
   Case 2   ' Image Mouse_Up
      imDown = False
   Case 3   ' pic Mouse_Down
      IM.TOp = y + PIC.TOp - IM.Height / 3
      RGBSlideVal(Index) = 255 - y
   End Select
End Sub

Public Sub CenteredPAL(PIC As PictureBox)
' Method from Stefan Casier Paint256
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim zR As Single, zG As Single, zB As Single
Dim k As Long, k2 As Long, k3 As Long
Dim j As Long
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   ReDim palRed(0 To 16), palGreen(0 To 16), palBlue(0 To 16)
   
   palRed(0) = 0:    palGreen(0) = 0:    palBlue(0) = 254
   palRed(1) = 86:   palGreen(1) = 254:  palBlue(1) = 86
   palRed(2) = 254:  palGreen(2) = 168:  palBlue(2) = 86
   palRed(3) = 92:   palGreen(3) = 0:    palBlue(3) = 0
   palRed(4) = 254:  palGreen(4) = 254:  palBlue(4) = 0
   palRed(5) = 0:    palGreen(5) = 112:  palBlue(5) = 142
   palRed(6) = 254:  palGreen(6) = 254:  palBlue(6) = 254
   palRed(7) = 174:  palGreen(7) = 174:  palBlue(7) = 174
   palRed(8) = 138:  palGreen(8) = 110:  palBlue(8) = 233
   palRed(9) = 0:    palGreen(9) = 101:  palBlue(9) = 0
   palRed(10) = 0:   palGreen(10) = 254: palBlue(10) = 254
   palRed(11) = 254: palGreen(11) = 0:   palBlue(11) = 0
   palRed(12) = 254: palGreen(12) = 254: palBlue(12) = 0
   palRed(13) = 178: palGreen(13) = 0:   palBlue(13) = 178
   palRed(14) = 254: palGreen(14) = 254: palBlue(14) = 254
   palRed(15) = 90:  palGreen(15) = 90:  palBlue(15) = 90
   

   k3 = 0
   For k = 0 To 15
      k2 = k + 1
      If k = 15 Then k2 = 0
      zR = (1& * palRed(k) - palRed(k2)) / 16
      zG = (1& * palGreen(k) - palGreen(k2)) / 16
      zB = (1& * palBlue(k) - palBlue(k2)) / 16
      r2 = palRed(k)
      g2 = palGreen(k)
      b2 = palBlue(k)
      For j = 0 To 14
         r1 = r2 - zR
         g1 = g2 - zG
         b1 = b2 - zB
         If r1 < 0 Then r1 = 255
         If r1 > 255 Then r1 = 0
         r2 = r1
         If g1 < 0 Then g1 = 255
         If g1 > 255 Then g1 = 0
         g2 = g1
         If b1 < 0 Then b1 = 255
         If b1 > 255 Then b1 = 0
         b2 = b1
         PalARR(2, k3) = r1
         PalARR(1, k3) = g1
         PalARR(0, k3) = b1
         k3 = k3 + 1
         If k3 > 255 Then Exit For
      Next j
      If k3 > 255 Then Exit For
   Next k
'   ' Make end blues
   For k = 240 To 255
      Cul = 240 + (k - 240)
      PalARR(2, k) = 0
      PalARR(1, k) = 0
      PalARR(0, k) = Cul
   Next k
   pRGB2PalARR PIC

   Erase palRed()
   Erase palGreen()
   Erase palBlue()

End Sub

Public Sub ShortBandedPAL(PIC As PictureBox)
' pic = picScreenPAL on frmColors
Dim k As Long
Dim RR As Byte
Dim GG As Byte
Dim BB As Byte
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   ' Banded palette
   RR = 248: GG = 0: BB = 0
   For k = 0 To 31
      PalARR(2, k) = RR
      If RR > 7 Then RR = RR - 8
   Next k
   RR = 0: GG = 244: BB = 0
   For k = 32 To 63
      PalARR(1, k) = GG
      If GG > 7 Then GG = GG - 8
   Next k
   RR = 0: GG = 0: BB = 248
   For k = 64 To 95
      PalARR(0, k) = BB
      If BB > 7 Then BB = BB - 8
   Next k
   RR = 255: GG = 255: BB = 0
   For k = 96 To 127
      PalARR(2, k) = RR
      PalARR(1, k) = GG
      If RR > 7 Then RR = RR - 8
      If GG > 7 Then GG = GG - 8
   Next k
   RR = 248: GG = 0: BB = 248
   For k = 128 To 159
      PalARR(2, k) = RR
      PalARR(0, k) = BB
      If RR > 7 Then RR = RR - 8
      If BB > 7 Then BB = BB - 8
   Next k
   RR = 0: GG = 240: BB = 240
   For k = 160 To 191
      PalARR(1, k) = GG
      PalARR(0, k) = BB
      If GG > 7 Then GG = GG - 8
      If BB > 7 Then BB = BB - 8
   Next k
   RR = 240: GG = 244: BB = 240
   For k = 192 To 223
      PalARR(2, k) = GG
      PalARR(1, k) = GG
      PalARR(0, k) = BB
      If RR > 7 Then RR = RR - 8
      If GG > 7 Then GG = GG - 8
      If BB > 7 Then BB = BB - 8
   Next k
   RR = 248: GG = 248: BB = 248
   For k = 224 To 255
      PalARR(2, k) = RR
      PalARR(1, k) = GG
      PalARR(0, k) = BB
      If GG > 7 Then GG = GG - 8
      If BB > 7 Then BB = BB - 8
   Next k
   pRGB2PalARR PIC
End Sub

Public Sub LongBandedPAL(PIC As PictureBox)
Dim k As Long
Dim Cul As Long
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   'ReDim palRed(0 To 255), palGreen(0 To 255), palBlue(0 To 255)
   ' Banded palette
   For k = 0 To 39
      PalARR(2, k) = 60 + 5 * k
   Next k
   For k = 40 To 79
      PalARR(1, k) = 60 + 5 * (k - 40)
   Next k
   For k = 80 To 119
      PalARR(0, k) = 60 + 5 * (k - 80)
   Next k
   For k = 120 To 159
      PalARR(1, k) = 60 + 5 * (k - 120)
      PalARR(0, k) = 60 + 5 * (k - 120)
   Next k
   
   For k = 160 To 199
      PalARR(2, k) = 60 + 5 * (k - 160)
      PalARR(0, k) = 60 + 5 * (k - 160)
   Next k
   
   For k = 200 To 255 '239
      Cul = 60 + 5 * (k - 200)
      If Cul > 255 Then Cul = 255
      PalARR(2, k) = Cul '60 + 5 * (k - 200)
      PalARR(1, k) = Cul '60 + 5 * (k - 200)
      Cul = 5 * (k - 200)
      If Cul > 255 Then Cul = 255
      PalARR(0, k) = Cul '5 * (k - 200)
   Next k
   pRGB2PalARR PIC
End Sub

Public Sub GreyPAL(PIC As PictureBox)
Dim k As Long
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   ' Greyed palette
   For k = 0 To 255
      PalARR(2, k) = k
      PalARR(1, k) = k
      PalARR(0, k) = k
   Next k
   pRGB2PalARR PIC
End Sub

Public Sub QBColors(PIC As PictureBox)
Dim k As Long, j As Long
Dim n As Long
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   ' QB palette
   n = 0
   For k = 0 To 255 - 15 Step 16
   For j = k To k + 15
      LngToRGB QBColor(n), PalARR(2, j), PalARR(1, j), PalARR(0, j)
   Next j
   n = n + 1
   Next k
   pRGB2PalARR PIC
End Sub

Public Sub FirePalette(PIC As PictureBox)
Dim k As Long, n As Long
' 0 B, 1 G, 2 R
   ReDim PalARR(0 To 2, 0 To 255) As Byte
   For k = 0 To 255
      Select Case k
      Case 0 To 31
         PalARR(2, k) = 255
      Case 32 To 63
         PalARR(2, k) = 255
         PalARR(1, k) = 255
      Case 64 To 95
         PalARR(2, k) = 255
         PalARR(1, k) = 255
         PalARR(0, k) = 255
      Case 96 To 127
         PalARR(2, k) = 255
      Case 128 To 159
         PalARR(2, k) = 255
         PalARR(1, k) = 255
      Case 160 To 191
         PalARR(2, k) = 255
         PalARR(1, k) = 255
         PalARR(0, k) = 255
      Case Else
         PalARR(2, k) = 255
      End Select
   Next k
   ' Smooth
   For n = 1 To 24
   For k = 1 To 254
      PalARR(0, k) = (1& * PalARR(0, k - 1) + PalARR(0, k) + PalARR(0, k + 1)) \ 3
      PalARR(1, k) = (1& * PalARR(1, k - 1) + PalARR(1, k) + PalARR(1, k + 1)) \ 3
      PalARR(2, k) = (1& * PalARR(2, k - 1) + PalARR(2, k) + PalARR(2, k + 1)) \ 3
   Next k
   
   PalARR(0, 0) = 255
   PalARR(1, 0) = 255
   PalARR(2, 0) = 255
   
   PalARR(0, 255) = 255
   PalARR(1, 255) = 255
   PalARR(2, 255) = 255
   Next n
   
   pRGB2PalARR PIC
   
   
End Sub

Public Sub LoadPALFile(PSpec$)
Dim r As RECT
Dim Title$, Filt$, InDir$
   Set CommonDialog1 = New cOSDialog
   Title$ = "Load JASC PAL File"
   Filt$ = "Load pal (*.pal)|*.pal"
   InDir$ = PSpec$
   CommonDialog1.ShowOpen PSpec$, Title$, Filt$, InDir$, "", Form1.hwnd
   If Len(PSpec$) <> 0 Then
      READ_PAL_FILE PSpec$
   End If
   Set CommonDialog1 = Nothing
      ' Avoid click through
   GetWindowRect Form1.cmdDrawZoom.hwnd, r
   SetCursorPos r.Left + 10, r.TOp + 10

End Sub

Public Sub SavePALFile(PSpec$)
Dim r As RECT
Dim Title$, Filt$, InDir$
   Set CommonDialog1 = New cOSDialog
   Title$ = "Save JASC PAL File"
   Filt$ = "JASC pal (*.pal)|*.pal"
   InDir$ = CurrPath$
   CommonDialog1.ShowSave PSpec$, Title$, Filt$, InDir$, "", Form1.hwnd
   If Len(PSpec$) <> 0 Then
      CurrPath$ = PSpec$
      SAVE_PAL_FILE PSpec$
   End If
   Set CommonDialog1 = Nothing
      ' Avoid click through
   GetWindowRect Form1.cmdDrawZoom.hwnd, r
   SetCursorPos r.Left + 10, r.TOp + 10
End Sub


Public Sub READ_PAL_FILE(PSpec$) ', pic As PictureBox)
Dim k As Long
Dim fnum As Long
Dim A$
   fnum = FreeFile
   On Error GoTo PalFileError
   Open PSpec$ For Input As #fnum
   Line Input #fnum, A$
   Close #fnum
   Open PSpec$ For Input As #fnum
   If InStr(1, A$, "JASC") <> 0 Then  'JASC-PAL MAP file
                   'JASC-PAL
                   '0100
                   'Skip 3 lines  '256
      Line Input #fnum, A$
      Line Input #fnum, A$
      Line Input #fnum, A$
      ReDim PalARR(0 To 2, 0 To 255)
      For k = 0 To 255
         If EOF(1) Then Exit For
         Input #fnum, PalARR(2, k), PalARR(1, k), PalARR(0, k)
      Next k
      Close #fnum
   Else
      MsgBox "Not a JASC PAL file", vbInformation, "Reading PAL file"
      PSpec$ = ""
      Exit Sub
   End If
   Exit Sub
'===========
PalFileError:
Close
MsgBox "Pal file error", vbCritical, "Reading pal file"
PSpec$ = ""
End Sub

Public Sub pRGB2PalARR(PIC As PictureBox)
' PIC=picSceenPAL Vertical
Dim k As Long
   For k = 0 To 255
      PIC.Line (0, k)-(PIC.Width - 1, k), RGB(PalARR(2, k), PalARR(1, k), PalARR(0, k))
   Next k
   PIC.Refresh
End Sub

Public Sub pRGB2PalARR_Form1(PIC As PictureBox)
' PIC=Form1.picPAL Horizontal
Dim k As Long
   For k = 0 To 255
      PIC.Line (k, 0)-(k, PIC.Height - 1), RGB(PalARR(2, k), PalARR(1, k), PalARR(0, k))
   Next k
   PIC.Refresh
End Sub

Public Sub LngToRGB(LCul As Long, r As Byte, g As Byte, B As Byte)
   r = LCul And &HFF&
   g = (LCul And &HFF00&) \ &H100&
   B = (LCul And &HFF0000) \ &H10000
End Sub

Public Sub SAVE_PAL_FILE(PSpec$)
Dim fnum As Long
Dim k As Long
   FixExtension SaveSpec$, ".pal"
   ' Palette on frmColor
   fnum = FreeFile
   Open PSpec$ For Output As #fnum
   Print #fnum, "JASC-PAL"
   Print #fnum, "0100"
   Print #fnum, "256"
   For k = 0 To 255
      Print #fnum, Trim$(Str$(PalARR(2, k))); " "; Trim$(Str$(PalARR(1, k))); " "; Trim$(Str$(PalARR(0, k)))
   Next k
   Close fnum

End Sub

Public Function ColorCounts(bARR() As Byte) As Long
' eg bARR() = picDATA(0 to 3, 0 to W - 1, 0 to H - 1)
Dim iy As Long, ix As Long
Dim LCul As Long
Dim BytePos As Long
Dim BitPos As Long
Dim BW As Long ' Width
Dim BH As Long ' Height

   BW = UBound(bARR(), 2)   ' = W - 1
   BH = UBound(bARR(), 3)   ' = H - 1
   
   ReDim bColorTable(0 To 16777216 \ 8) As Byte ' 16/8 = 2 MB
   Pow2Tab
   ColorCounts = 0
   For iy = 0 To BH
   For ix = 0 To BW
      LCul = RGB(bARR(2, ix, iy), bARR(1, ix, iy), bARR(0, ix, iy))
      BytePos = LCul \ 8
      BitPos = LCul And 7
      If (bColorTable(BytePos) And Pow2(BitPos)) = 0 Then
         bColorTable(BytePos) = bColorTable(BytePos) Or Pow2(BitPos)
         ColorCounts = ColorCounts + 1
      End If
   Next ix
   Next iy
   Erase bColorTable()
End Function

Public Sub Pow2Tab()
Dim k As Long
   For k = 0 To 7
      Pow2(k) = 2 ^ k
   Next k
End Sub

' Color sorting

Public Sub ColorSort(ARR() As Long)
'Private pR() As Byte, pG() As Byte, pB() As Byte
' ColorSort gifPAL() from frmColors & frmBigPAL temp ARR()
' so ARR() = gifPAL(0 To 255) or just ARR(0 To 255)
Dim RGBMix(0 To 255) As Long
Dim Lum(0 To 255) As Long
Dim zH As Single, zS As Single, zL As Single  ' zS not used
Dim k As Long

   ReDim pR(0 To 255), pG(0 To 255), pB(0 To 255)
   ' Get RGBs into pR(), pG() & pB()
   For k = 0 To 255
      LngToRGB ARR(k), pR(k), pG(k), pB(k)
   Next k
   
   ' HSL SORT
   For k = 0 To 255
      RGB2HSL pR(k), pG(k), pB(k), zH, zS, zL
      RGBMix(k) = zL + 256 * zH
   Next k
   Quicksort RGBMix(), LBound(RGBMix()), UBound(RGBMix())
   ' Get new Lum()s
   For k = 0 To 255
      RGB2HSL pR(k), pG(k), pB(k), zH, zS, zL
      Lum(k) = zL
   Next k
   ' 8 banded sort of pR(),pG() & pB() based on Lum()
   For k = 0 To 7
      Quicksort Lum(), k * 32, (k * 32 + 31)
   Next k
   ' Put back in ARR() ie in gifPAL() or just ARR()
   For k = 0 To 255
      ARR(k) = RGB(pR(k), pG(k), pB(k))
   Next k
   Erase RGBMix(), Lum()
End Sub

Public Sub Quicksort(LArr() As Long, Min As Long, Max As Long)
'Private pR() As Byte, pG() As Byte, pB() As Byte
'1 dimensional long array sorted in ascending order from Min to max
Dim m As Long
Dim sortl() As Long, sortr() As Long
Dim S As Long, LL As Long, mm As Long
Dim p As Long, x As Long, y As Long
Dim i As Long, j As Long, IT As Long

   If Max = 1 Then Exit Sub
   If Min = Max Then Exit Sub
   
   m = (Max - Min) \ 2
   ReDim sortl(m), sortr(m)
   S = 1: sortl(1) = Min: sortr(1) = Max
   Do While S <> 0
      LL = sortl(S): mm = sortr(S): S = S - 1
      
      Do While LL < mm
         i = LL: j = mm
         p = (LL + mm) \ 2
         x = LArr(p)
         
         Do While i <= j
            Do While LArr(i) < x: i = i + 1: Loop
            Do While x < LArr(j): j = j - 1: Loop
            If i <= j Then
               'SWAP LArr(i), LArr(j)
               y = LArr(i): LArr(i) = LArr(j): LArr(j) = y
               ' SWAP RGB components
               IT = pR(i): pR(i) = pR(j): pR(j) = IT
               IT = pG(i): pG(i) = pG(j): pG(j) = IT
               IT = pB(i): pB(i) = pB(j): pB(j) = IT
             
               i = i + 1: j = j - 1
            End If
         Loop
         
         If i < mm Then
            S = S + 1: sortl(S) = i: sortr(S) = mm
         End If
         mm = j
      Loop
   
   Loop
   
   Erase sortl, sortr
End Sub


Public Sub RGB2HSL(ByVal AR As Long, ByVal AG As Long, ByVal ab As Long, _
                   zH As Single, zS As Single, zL As Single)

' In: RGB  Out: HSL
Dim Colmax As Long, ColMin As Long
Dim MmM As Long, MpM As Long
Dim zMul As Single
   Colmax = AR
   If AG > AR Then Colmax = AG
   If ab > Colmax Then Colmax = ab
   
   ColMin = AR
   If AG < AR Then ColMin = AG
   If ab < ColMin Then ColMin = ab
   
   MmM = Colmax - ColMin
   MpM = Colmax + ColMin
   
   zL = MpM / 2

   If Colmax = ColMin Then
      zS = 0
      zH = 170
   Else
      If zL <= 127.5 Then
         zS = MmM * 255 / MpM
      Else
         zS = MmM * 255 / (510 - MpM)
      End If
      ' VBSpeed
      zMul = 60 / MmM
      Select Case Colmax
      Case AR
         If ab > AG Then
            zH = zMul * (AG - ab) + 360
         Else
            zH = zMul * (AG - ab)
         End If
      Case AG
         zH = zMul * (ab - AR) + 120
      Case ab
         zH = zMul * (AR - AG) + 240
      End Select
      If zH < 0 Then zH = zH + 255
   End If
End Sub



