PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

Reducing bitmap depth

https://www.purebasic.fr/english/viewtopic.php?t=8843

Page 1 of 1

Reducing bitmap depth

Posted: Tue Dec 23, 2003 3:20 pm
by dontmailme
I want to reduce the colors in a bitmap from 32-24-16-8 or combinations of the above....

I have not tried this before and wonderd if anyone could provide some ideas how to do it ?

Posted: Tue Dec 23, 2003 4:47 pm
by El_Choni
This used to work, can't test it now:

Code: Select all

Procedure Error(message.s, fatal.b)
  ErrorBuffer$ = Space(1024)
  Errorcito = GetLastError_()
  Debug Hex(Errorcito)
  FormatMessage_(#FORMAT_MESSAGE_FROM_SYSTEM, 0, Errorcito, 0, ErrorBuffer$, Len(ErrorBuffer$), 0)
  MessageRequester("Error", message+Chr(10)+Chr(10)+ErrorBuffer$, 0)
  If fatal
    End
  EndIf
EndProcedure

Structure BoundingBox
  Error.f
  Low.w
  Up.w
  Direction.b
EndStructure

#UsedDepth = 31

Procedure SetDepth(ImageID, PixelDepth)
  result = 0
  GetObject_(ImageID, SizeOf(BITMAP), bm.BITMAP)
  bmih.BITMAPINFOHEADER
  bmih\biSize = SizeOf(BITMAPINFOHEADER)
  bmih\biWidth = bm\bmWidth
  bmih\biHeight = bm\bmHeight
  bmih\biPlanes = 1
  bmih\biBitCount = 32
  bmih\biCompression = #BI_RGB
  ImageBits = AllocateMemory(0, bmih\biWidth*bmih\biHeight*4)
  WindowID = WindowID()
  hDC = GetDC_(WindowID)
  GetDIBits_(hDC, ImageID, 0, bmih\biHeight, ImageBits, bmih, 0)
  ReleaseDC_(WindowID, hDC)
  BMPSeeker = ImageBits
  MaxColours = Pow(2, PixelDepth)
  Dim Histogram($8000-1) ; 5/6/4? Otra combinacion? Basada en diferencias en la imagen?
  For i=0 To bmih\biHeight-1                        ; Tener en cuenta al partir
    For t=0 To bmih\biWidth-1
      RGBColour = PeekL(BMPSeeker)
      r = (RGBColour&$F8)<<7
      g = (RGBColour&$F800)>>6
      b = (RGBColour&$F80000)>>19
      Histogram(r|g|b)+1
      BMPSeeker+4
    Next t
  Next i
  HColours = $8000-1
  Dim Colours.w(HColours-1, 2)
  i = 0
  For r=0 To #UsedDepth
    For g=0 To #UsedDepth
      For b=0 To #UsedDepth
        Colour = ((r<<10)|(g<<5)|b)&$7FFF
        If Histogram(Colour)
          Colours(i, 0) = Colour
          i+1
        EndIf
      Next b
    Next g
  Next r
  ImageColours = i-1
  If ImageColours>MaxColours-1
    i = 0
    For g=0 To #UsedDepth
      For b=0 To #UsedDepth
        For r=0 To #UsedDepth
          Colour = ((r<<10)|(g<<5)|b)&$7FFF
          If Histogram(Colour)
            Colours(i, 1) = Colour
            i+1
          EndIf
        Next r
      Next b
    Next g
    i = 0
    For b=0 To #UsedDepth
      For r=0 To #UsedDepth
        For g=0 To #UsedDepth
          Colour = ((r<<10)|(g<<5)|b)&$7FFF
          If Histogram(Colour)
            Colours(i, 2) = Colour
            i+1
          EndIf
        Next g
      Next r
    Next b
    Dim Region.BoundingBox(MaxColours-1)
    CurrentRegion = 0
    Region(CurrentRegion)\Low = 0
    Region(CurrentRegion)\Up = ImageColours
    LastHigh = 0
    LastLow = 0
    CurrentList = 0
    Lastdiff.f = 0
    For i=0 To 2
      Low = (Colours(Region(CurrentRegion)\Low, i)>>((2-i)*5))&$1F
      High = (Colours(Region(CurrentRegion)\Up, i)>>((2-i)*5))&$1F
      Select i
        Case 0
          diff.f = (High-Low)*0.59
        Case 1
          diff.f = (High-Low)*0.30
        Case 2
          diff.f = (High-Low)*0.11
      EndSelect
      If diff>Lastdiff
        CurrentList = i
        Lastdiff = diff
      EndIf
    Next i
    NewRegion = 1
    Region(CurrentRegion)\Direction = %11
    Dim leftvec.f(ImageColours)
    Dim rightvec.f(ImageColours)
    While NewRegion<MaxColours
      L = Region(CurrentRegion)\Low
      U = Region(CurrentRegion)\Up
      If Region(CurrentRegion)\Direction&%1
        LowR = #UsedDepth
        LowG = #UsedDepth
        LowB = #UsedDepth
        HighR = 0
        HighG = 0
        HighB = 0
        Popularity = 0
        For i=L To U-1
          Colour = Colours(i, CurrentList)
          r = (Colour&$7C00)>>10
          g = (Colour&$3E0)>>5
          b = Colour&$1F
          If r<LowR
            LowR = r
          EndIf
          If r>HighR
            HighR = r
          EndIf
          If g<LowG
            LowG = g
          EndIf
          If g>HighG
            HighG = g
          EndIf
          If b<LowB
            LowB = b
          EndIf
          If b>HighB
            HighB = b
          EndIf
          Popularity+Histogram(Colour)
          SoR.f = (HighR-LowR)*0.59
          SoG.f = (HighG-LowG)*0.30
          SoB.f = (HighB-LowB)*0.11
          leftvec(i) = Popularity*(Sqr(Pow(SoR, 2)+Pow(SoG, 2))+Pow(SoB, 2))
        Next i
      EndIf
      If Region(CurrentRegion)\Direction&%10
        LowR = #UsedDepth
        LowG = #UsedDepth
        LowB = #UsedDepth
        HighR = 0
        HighG = 0
        HighB = 0
        Popularity = 0
        For i=U To L+1 Step -1
          Colour = Colours(i, CurrentList)
          r = (Colour&$7C00)>>10
          g = (Colour&$3E0)>>5
          b = Colour&$1F
          If r<LowR
            LowR = r
          EndIf
          If r>HighR
            HighR = r
          EndIf
          If g<LowG
            LowG = g
          EndIf
          If g>HighG
            HighG = g
          EndIf
          If b<LowB
            LowB = b
          EndIf
          If b>HighB
            HighB = b
          EndIf
          Popularity+Histogram(Colour)
          SoR.f = (HighR-LowR)*0.59
          SoG.f = (HighG-LowG)*0.30
          SoB.f = (HighB-LowB)*0.11
          rightvec(i) = Popularity*(Sqr(Pow(SoR, 2)+Pow(SoG, 2))+Pow(SoB, 2))
        Next i
      EndIf
      PreviousError = leftvec(L)+rightvec(L+1)
      SplitPlace = L
      For i=L To U-1
        If leftvec(i)+rightvec(i+1)<PreviousError
          PreviousError = leftvec(i)+rightvec(i+1)
          SplitPlace = i
        EndIf
      Next i
      If SplitPlace>L
        Region(CurrentRegion)\Error = leftvec(SplitPlace)
      Else
        Region(CurrentRegion)\Error = 0
      EndIf
      Region(CurrentRegion)\Up = SplitPlace
      Region(CurrentRegion)\Direction = %10
      If SplitPlace<U-1
        Region(NewRegion)\Error = rightvec(SplitPlace+1)
      EndIf
      Region(NewRegion)\Low = SplitPlace+1
      Region(NewRegion)\Up = U
      Region(NewRegion)\Direction = %1
      LowC = 0
      HighC = 0
      For i=0 To 2
        ThisL = CurrentList+i
        If ThisL>2:ThisL-3:EndIf
        LowC = (LowC<<5)|((Colours(L, CurrentList)>>((2-ThisL)*5))&$1F)
        HighC = (HighC<<5)|((Colours(SplitPlace, CurrentList)>>((2-ThisL)*5))&$1F)
      Next i
      Dim belowList.w(U-L)
      Dim aboveList.w(U-L)
      List2 = CurrentList+1
      If List2>2:List2-3:EndIf
      List3 = List2+1
      If List3>2:List3-3:EndIf
      For d=1 To 2
        aListIndex = 0
        bListIndex = 0
        RCLI = CurrentList+d
        If RCLI>2:RCLI-3:EndIf
        For i=L To U
          OutBounds = 1
          Colour = Colours(i, RCLI)
          PColour = 0
          For z=0 To 2
            ThisL = CurrentList+z
            If ThisL>2:ThisL-3:EndIf
            PColour = (PColour<<5)|((Colour>>((2-ThisL)*5))&$1F)
          Next z
          If PColour>=LowC And PColour<=HighC
            OutBounds = 0
          EndIf
          If OutBounds
            aboveList(aListIndex) = Colour
            aListIndex+1
          Else
            belowList(bListIndex) = Colour
            bListIndex+1
          EndIf
        Next i
        For i=0 To bListIndex-1
          Colours(i+L, RCLI) = belowList(i)
        Next i
        For i=0 To aListIndex-1
          Colours(i+L+bListIndex, RCLI) = aboveList(i)
        Next i
      Next d
      For i=0 To NewRegion
        If Region(i)\Error>Region(CurrentRegion)\Error
          CurrentRegion = i
        EndIf
      Next i
      Lastdiff.f = 0
      For i=0 To 2
        Low = (Colours(Region(CurrentRegion)\Low, i)>>((2-i)*5))&$1F
        High = (Colours(Region(CurrentRegion)\Up, i)>>((2-i)*5))&$1F
        Select i
          Case 0
            diff.f = (High-Low)*0.59
          Case 1
            diff.f = (High-Low)*0.30
          Case 2
            diff.f = (High-Low)*0.11
        EndSelect
        If diff>Lastdiff
          CurrentList = i
          Lastdiff = diff
        EndIf
      Next i
      NewRegion+1
    Wend
    Dim leftvec.f(0)
    Dim rightvec.f(0)
    Dim belowList.w(0)
    Dim aboveList.w(0)
    Dim Palette(MaxColours-1)
    PaletteIndex = 0
    While PaletteIndex<MaxColours
      AverageR.f = 0
      AverageG.f = 0
      AverageB.f = 0
      ColoursNumber = 0
      For i=Region(PaletteIndex)\Low To Region(PaletteIndex)\Up
        Colour = Colours(i, 0)&$7FFF
        r = (Colour&$7C00)>>10
        g = (Colour&$3E0)>>5
        b = Colour&$1F
        AverageR+(r*Histogram(Colour))
        AverageG+(g*Histogram(Colour))
        AverageB+(b*Histogram(Colour))
        ColoursNumber+Histogram(Colour)
        Histogram(Colour) = PaletteIndex
      Next i
      If ColoursNumber
        AvR = Int(AverageR*8/ColoursNumber)
        AvG = Int(AverageG*8/ColoursNumber)
        AvB = Int(AverageB*8/ColoursNumber)
        Palette(PaletteIndex) = ((AvB&$FF)<<16)|((AvG&$FF)<<8)|(AvR&$FF)
      EndIf
      PaletteIndex+1
    Wend
    Dim Colours.w(0, 0)
    Dim Region.BoundingBox(0)
    BMPSeeker = ImageBits
    For i=0 To bmih\biHeight-1
      For t=0 To bmih\biWidth-1
        RGBColour = PeekL(BMPSeeker)
        r = (RGBColour&$F8)<<7
        g = (RGBColour&$F800)>>6
        b = (RGBColour&$F80000)>>19
        ; Dither aquí
        PokeL(BMPSeeker, Palette(Histogram(r|g|b)))
        BMPSeeker+4
      Next t
    Next i
    Dim Histogram(0)
    hDC = GetDC_(WindowID)
    SetDIBits_(hDC, ImageID, 0, bmih\biHeight, ImageBits, bmih, 0)
    ReleaseDC_(WindowID, hDC)
    RedrawWindow_(WindowID, 0, 0, 7)
    result = 1
  ElseIf ImageColours=MaxColours
    BMPSeeker = ImageBits
    For i=0 To bmih\biHeight-1
      For t=0 To bmih\biWidth-1
        RGBColour = PeekL(BMPSeeker)
        RGBColour!%1110000011100000111
        ; Dither aquí
        PokeL(BMPSeeker, RGBColour)
        BMPSeeker+4
      Next t
    Next i
    hDC = GetDC_(WindowID)
    SetDIBits_(hDC, ImageID, 0, bmih\biHeight, ImageBits, bmih, 0)
    ReleaseDC_(WindowID, hDC)
    RedrawWindow_(WindowID, 0, 0, 7)
    result = 1
  EndIf
  FreeMemory(0)
  ProcedureReturn result
EndProcedure

hWindow = OpenWindow(0, 0, 0, 320, 256, #PB_Window_SystemMenu|#PB_Window_MinimizeGadget|#PB_Window_ScreenCentered|#PB_Window_Invisible, "Load picture example")
If hWindow
  FileName$ = OpenFileRequester("Open image", "", "All supported formats|*.bmp;*.ico;*.cur|BMP image (*.bmp)|*.bmp|Icon file (*.ico)|*.ico|Cursor file (*.cur)|*.cur", 0)
  If FileName$
    CurrentDir$ = GetPathPart(FileName$)
    ImageID = LoadImage(0, FileName$)
    If CreateGadgetList(hWindow)
      If ImageID
        width = ImageWidth()
        height = ImageHeight()
        ButtonImageGadget(0, 0, 0, width, height, ImageID)
        ResizeWindow(width, height)
        HideWindow(0, 0)
        AddKeyboardShortcut(0, #PB_Shortcut_Space, 0)
        SetForegroundWindow_(hWindow)
        Repeat
          EventID = WaitWindowEvent()
          If EventID=#PB_EventGadget
            FileName$ = OpenFileRequester("Open image", "", "All supported formats|*.bmp;*.ico;*.cur|BMP image (*.bmp)|*.bmp|Icon file (*.ico)|*.ico|Cursor file (*.cur)|*.cur", 0)
            If FileName$
              CurrentDir$ = GetPathPart(FileName$)
              FreeImage(0)
              ImageID = LoadImage(0, FileName$)
              If ImageID
                width = ImageWidth()
                height = ImageHeight()
                ResizeWindow(width, height)
                ResizeGadget(0, 0, 0, width, height)
                SetGadgetState(0, ImageID)
              Else
                Error("qué?", 0)
              EndIf
            EndIf
          ElseIf EventID=#PB_EventMenu
            SetDepth(ImageID(), 8)
          EndIf
        Until EventID=#PB_EventCloseWindow
      Else
        Error("cosa?", 0)
      EndIf
    EndIf
  EndIf
EndIf
End
Just use your settings in SetDepth(ImageID(), 8<--bitdepth) to call the colour reduction proc. Regards,

Posted: Tue Dec 23, 2003 4:57 pm
by dontmailme
I saw this before, and have just tested this new version too.....

It changes the on-screen colors OK, but if I then save the bitmap you still have a bitmap with same color depth as before, but less are displayed.

So the filesize is same as original.

Do you know how to reduce the colordepth in the header and reduce filesize, or is this much more complex !? Or best done differently ?

Posted: Tue Dec 23, 2003 5:18 pm
by El_Choni
I see... You'd need to modify the SetDepth proc so it generates a bmp file (in memory if you want). Create the palette with the entries in the histogram llist, the bmp header (for, let's say, 8 bit depth), and the bmp data with the palette indexes instead of the rgb value. Not that difficult, check the BITMAPINFO and BITMAPINFOHEADER structs.
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited