Color Quantizing Image Editor

[SeregaZ]

any alternative url for download? mediafire is not open. and what it is? exe file, or sourse, or dll?

i have table with 512 constant colors. but output image can use only 15 from this 512. this project can do something like this?

[BasicallyPure]

SeregaZ, are you still having trouble with the download?
It seems to work for me.
The downloads for the latest version are all exe files.

From your description it sounds like what you need is wilbert's nearest color module.

edit: I see you have already found wilbert's module.

[SeregaZ]

it is bloody goverment's KGB do this. it block mediafire. but tru friGate CDN i am download right now fine. will see what it is.

nearest color fine, i am use that. but task a little dificult.

whole image into 512 from table, get 15 different colors from result, whole image into this 15. i am get first 15 - it is a little wrong. what if more intensive colors lay after first 15 unic colors? so i need some color sort procedure. any simple explanation how to do this sorting?

for example image have 23 unique colors after 512 repainting. i need make some sort and mix for make 15 from this 23. but mix can happen only into any of 512 colors, that is allow. not any color.

so for me it is a little dificult.

[BasicallyPure]

SeregaZ,
I have modified my 'Popularity_Palette()' example shown elsewhere in this topic so it may work for you.
This is a complete working example, just provide the path and file name of the image with 23 unique colors (your example).
It should work with any image that has 512 colors or less.
You can choose how many colors you want in the result, I have set the variable 'limit' to 15 but you can change it to anything <= 512.
The resulting palette will only consist of colors from the original image.
You will need a copy of wilbert's 'nearest color module' as an include file.

Code: Select all

EnableExplicit

XIncludeFile "NearestColorModule.pbi" ; http://www.purebasic.fr/english/viewtopic.php?f=12&t=61475

UsePNGImageDecoder()
UseJPEGImageDecoder()

Declare POPULARITY_PALETTE(ImgRef.i,limit.i)
Declare SCAN_FOR_PALETTE(image.i)
Declare SHOW_PALETTE(Array palette.l(1))
Declare COUNT_COLORS(image.i)
Declare ASSEMBLE_TO_PALETTE(Array palette.l(1), ImgRef.i, dither.i)

#WinMain    = 0
#WinPalette = 1

Structure PopType ; used in POPULARITY_PALETTE() procedure
   clr.l ; color
   pop.i ; popularity
EndStructure

; ><><><><><><><><><><><><><>><><><> ATTENTION! <><><><><>><><><><><><><><><><><><><><>><><><><><>
Global Dim WK_Pal.l(0)  ; <--- this array will contain the final palette                        <>
Define.i limit = 15     ; <--- maximum number of colors in the result                           <>
Define.i dither = #True ; <--- dither yes or no                                                 <>
Define.i ImgRef = LoadImage(#PB_Any,"chicken_35.png") ;<--- edit path and filename as required  <>
; ><><><><><><><><><><><><><>><><><><><><><><><><><><><><>><><><><><><><><><><><><><><>><><><><><>

Define.i w,h,Qimage
If ImgRef : w = ImageWidth(ImgRef) : h = ImageHeight(ImgRef)
   If OpenWindow(#WinMain,0,0,w,h,"Example",#PB_Window_ScreenCentered|#PB_Window_SystemMenu)
     
      If POPULARITY_PALETTE(ImgRef, limit) ;generate the palette
         Qimage = ASSEMBLE_TO_PALETTE(WK_Pal(), ImgRef, dither) ;build the final image
         If IsImage(Qimage)
            ImageGadget(#PB_Any,0,0,w,h,ImageID(Qimage)) ;display the result
            SCAN_FOR_PALETTE(Qimage) ; show the palette in a separate window
         EndIf
      EndIf
     
      Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
   EndIf
EndIf

End
; ****************************************************************************************

Procedure POPULARITY_PALETTE(ImgRef.i,limit.i)
   ; Create a color palette with a modified popularity approach.
   ; ImgRef = the source image.
   ; Limit = the maximum number of colors in result.
   ; Limit count can be specified from 2 to 512. (512 is arbitrary limit)
   ; Required support procedures are:
   ;   'COUNT_COLORS', and 'ASSEMBLE_TO_PALETTE'.
   ; Finished palette is placed in the global array WK_Pal().
   ; This algorithm was created by BasicallyPure.
   
   Static.i kb = $FF0000, kg = $00FF00, kr = $0000FF
   Protected.i ImgWork, count, Xmin,Ymin,Xmax, Ymax, i, x, y, lum, d, br, da, mb, md
      
   If IsImage(ImgRef)
      ImgWork = CopyImage(ImgRef,#PB_Any)
     
      If ImgWork
         count = COUNT_COLORS(ImgWork)
         If count <= limit : limit = count : EndIf
      Else
         ProcedureReturn 0
      EndIf
   Else
      ProcedureReturn 0
   EndIf
   
   Xmax = ImageWidth(ImgWork) - 1
   Ymax = ImageHeight(ImgWork) - 1
   
   ; 1) if color count is > 512 color count will be reduced.
   ;    and palette colors may be altered.
   If count > 512
      ; simple bitmask color reduction method
      StartDrawing(ImageOutput(ImgWork))
         For y = Ymin To yMax
            For x = Xmin To xMax
               Plot(x, y, Point(x,y) & $E0E0E0 | $0F0F0F)
            Next x
         Next y
      StopDrawing()
   EndIf
         
   ; 2) gather popularity data
      NewMap Pmap.i()
      StartDrawing(ImageOutput(ImgWork))
         For y = Ymin To Ymax
            For x = Xmin To Xmax
               Pmap(Str(Point(x,y))) + 1
            Next
         Next
      StopDrawing()
     
      If MapSize(Pmap()) < limit : limit = MapSize(Pmap()) : EndIf
     
   ; 3) subdivide colors into 4 brightness lists
      NewList bright.PopType()
      NewList MedBri.PopType()
      NewList MedDrk.PopType()
      NewList dark.PopType()
     
      ForEach Pmap()
         d = Val(MapKey(Pmap()))
         lum = (d & kr)<<1 + (d & kg) >> 6 + (d & kb) >> 16
         If lum > 1338
            AddElement(bright()) : bright()\clr = d : bright()\pop = Pmap()
         ElseIf lum > 892
            AddElement(MedBri()) : MedBri()\clr = d : MedBri()\pop = Pmap()
         ElseIf lum > 446
            AddElement(MedDrk()) : MedDrk()\clr = d : MedDrk()\pop = Pmap()
         Else
            AddElement(dark())   : dark()\clr   = d : dark()\pop   = Pmap()
         EndIf
      Next
     
   ; 4) sort each brightness lists by popularity
      SortStructuredList(bright(),#PB_Sort_Descending,OffsetOf(PopType\pop),#PB_Integer)
      SortStructuredList(MedBri(),#PB_Sort_Descending,OffsetOf(PopType\pop),#PB_Integer)
      SortStructuredList(MedDrk(),#PB_Sort_Descending,OffsetOf(PopType\pop),#PB_Integer)
      SortStructuredList(dark()  ,#PB_Sort_Descending,OffsetOf(PopType\pop),#PB_Integer)
     
   ; 5) create the final palette
      FirstElement(bright()) : br = ListSize(bright())
      FirstElement(MedBri()) : mb = ListSize(MedBri())
      FirstElement(MedDrk()) : md = ListSize(MedDrk())
      FirstElement(dark())   : da = ListSize(dark())
     
      limit - 1
      ReDim WK_Pal(limit)
     
      i = 0 : d = %00
      Repeat ; pick from each list in turn the most popular color
         If d = %00 And br > 0
            WK_Pal(i) = bright()\clr
            NextElement(bright())
            i + 1 : br - 1
         ElseIf d = %01 And da > 0
            WK_Pal(i) = dark()\clr
            NextElement(dark())
            i + 1 : da - 1
         ElseIf d = %10 And mb > 0
            WK_Pal(i) = MedBri()\clr
            NextElement(MedBri())
            i + 1 : mb - 1
         ElseIf d = %11 And md > 0
            WK_Pal(i) = MedDrk()\clr
            NextElement(MedDrk())
            i + 1 : md - 1
         EndIf
           
         d = (d + %01) & %11
      Until i > limit
     
      If IsImage(ImgWork) : FreeImage(ImgWork) : EndIf
     
      ProcedureReturn 1
EndProcedure

Procedure COUNT_COLORS(image.i)
   ; returns the number of unique colors in an image (24 bit)
   Protected.i x, y, max_x, max_y, c, count, m
   Dim m.a($1FFFFF)
   StartDrawing(ImageOutput(image))
      max_x = ImageWidth(image) - 1
      max_y = ImageHeight(image) - 1
      For y = 0 To max_y
         For x = 0 To max_x
            c = Point(x, y) & $FFFFFF
            If m(c >> 3) & 1 << (c & 7) = 0
               m(c >> 3) | 1 << (c & 7)
               count + 1
            EndIf
         Next
      Next
   StopDrawing()
   ProcedureReturn count
EndProcedure

Procedure ASSEMBLE_TO_PALETTE(Array palette.l(1), ImgRef.i, dither.i)
   ; assign each pixel of an image to the defined palette using NearestColor module
   ; ImgRef  = the source image
   ; dither: 0 = no dither, 1 = dither
   ; A new image is created, the return value is the new image number.
   
   NearestColor::CatchPalette(@palette(), ArraySize(palette())+1)
   
   ProcedureReturn NearestColor::DitheredImage(ImgRef, dither*128)
   
EndProcedure

Procedure SCAN_FOR_PALETTE(image.i)
   ; obtain the palette of all colors used in an image
   ; stops if number of colors exceeds 512
   Static NewMap Pmap.i(1024)
   Static Dim Palette.l(0)
   Protected c,i,x,y,Xmax,Ymax
   
   Xmax = ImageWidth(image)-1
   Ymax = ImageHeight(image)-1
   
   StartDrawing(ImageOutput(image))
      For y = 0 To Ymax
         For x = 0 To Xmax
            c = Point(x,y)
               If MapSize(Pmap()) > 512
                  Break 2
               EndIf
            Pmap(Str(c)) = c
         Next
      Next
   StopDrawing()

   ReDim palette(MapSize(Pmap())-1)
   
   i = 0
   ForEach Pmap()
      palette(i) = Pmap()
      i + 1
   Next
   
   ClearMap(Pmap())
   
   SHOW_PALETTE(Palette())
EndProcedure

Procedure SHOW_PALETTE(Array palette.l(1))
   ; draw the palette window
   
   Static flags = #PB_Window_SystemMenu | #PB_Window_Tool | #PB_Window_ScreenCentered
   Static imgGad, imgPalette
   Protected c, i, x, y, columns, Xmax, Ymax, blockSize
   Protected Imax = ArraySize(palette())
   
   If IsWindow(#WinPalette) = 0
      OpenWindow(#WinPalette,0,0,129,255,"",flags,WindowID(#WinMain))
      imgGad = ImageGadget(#PB_Any,0,0,1,1,0)
   EndIf
   
   If Imax > 511 ; (16_columns * 32_rows) - 1
      Imax = 511
      SetWindowTitle(#WinPalette,"over!")
   Else
      SetWindowTitle(#WinPalette,Str(Imax+1)+" Palette")
   EndIf
   
   columns = Round(Sqr((Imax+1)/2),#PB_Round_Up)
   blockSize = 126 / columns
   Xmax = columns * blockSize
   Ymax = Xmax * 2
   
   If IsImage(imgPalette) = 0
      imgPalette = CreateImage(#PB_Any,Xmax,Ymax,24,0)
   Else
      ResizeImage(imgPalette,Xmax,Ymax)
   EndIf
   
   StartDrawing(ImageOutput(imgPalette))
      Xmax - 1 : Ymax - 1
      For y = 0 To Ymax
         For x = 0 To Xmax
            c = (x ! y)
            c = (c << 16) | (c << 8) | c
            Plot(x, y, c | $C0C0C0)
         Next
      Next
      X = 0 : Y = 0
      For I = 0 To Imax
         Box(X, Y, blockSize, blockSize, palette(I))
         X + blockSize
         If X > Xmax : X = 0 : Y + blockSize : EndIf
      Next
   StopDrawing()

   SetGadgetState(imgGad,ImageID(imgPalette))
   
EndProcedure

[SeregaZ]

as i can understand this algo work with heavy colors. i mean save that colors, pixels of which is bigger count, than other. but i found something another, that works, by my opinion, better:
https://rilden.github.io/tiledpalettequant/

i hope you can see some ideas, that can apply to your code.

[Caronte3D]

Seven years later...

[SeregaZ]

all of that years old code serve with image paste for Sega Genesis console games.

[SeregaZ]

will be nice to port that code from javascript to PB. i make video manager for Sega Mega Drive/Genesis, but it eat red colors sometimes i can reload image from tiledpalettequant by manualy, but when i split video for a few scenes - upload and download each one is not fine.

[SeregaZ]

ok, time is cure. internet now have that code as dll: https://github.com/Aikku93/qualetize

BUT! it dont want to properly work with 32 version (( that code on C and have some problems when set Dithering with FLOYDSTEINBERG or ATKINSON method. i try to make as CHECKER method and it looks like work...

i build dll with mingw32.exe and load it by this code:

Code: Select all

Enumeration
  #Window
  #QualDLL
  #File
  #Image
  #PalCanvasGadget
  #MainImageCanvasGadget
EndEnumeration

; https://github.com/Aikku93/qualetize/blob/main/include/Qualetize.h
Structure Vec4f_t
  ;x.f
  ;y.f  
  ;z.f
  ;w.f
  x.l ; for more usefriendly write data into it
  y.l
  z.l
  w.l
EndStructure
Structure BGRA8_t
  b.a
  g.a
  r.a  
  a.a
EndStructure
Structure QualetizePlan_t Align #PB_Structure_AlignC
  TileWidth.w                 ; uint16_t
  TileHeight.w                ; uint16_t  
  nPaletteColours.w           ; uint16_t
  nTilePalettes.w             ; uint16_t
  Colourspace.b               ; uint8_t
  FirstColourIsTransparent.b  ; uint8_t
  PremultipliedAlpha.b        ; uint8_t
  DitherType.b                ; uint8_t
  DitherLevel.f               ; float
  nTileClusterPasses.l        ; uint32_t
  nColourClusterPasses.l      ; uint32_t
  Padding1.b[8]
  ColourDepth.Vec4f_t         ; Vec4f_t (4x float)
  TransparentColour.BGRA8_t   ; BGRA8_t (4x uint8_t)
  Padding2.b[12]
EndStructure


; dump from original exe file for plan structure
; 08 00 TileWidth 8
; 08 00 TileHeight 8
; 10 00 nPaletteColours 16
; 04 00 nTilePalettes 4
; 08 Colourspace.b
; 01 FirstColourIsTransparent.b
; 00 PremultipliedAlpha.b
; FF DitherType 
; 00 00 80 3F = 1.0   DitherLevel.f   00 00 00 3F = 0.5
; 00 00 00 00 nTileClusterPasses.l
; 00 00 00 00 nColourClusterPasses.l

; 38 FE DF 00 some padding
; 20 FF DF 00

; 00 00 E0 40 = 3  ColourDepth.Vec4f_t 3331
; 00 00 E0 40 = 3
; 00 00 E0 40 = 3
; 00 00 80 3F = 1

; 00 00 00 00 TransparentColour.BGRA8_t

; 80 84 0E 00 some padding
; B8 FE DF 00 
; F8 84 0E 00 


PrototypeC.i ProtoQualetize(OutputPxData.l, OutputPalette.l, InputBitmap.l, 
                           InputPalette.l, InputWidth.l, InputHeight.l, 
                           Plan.l, RMSE.l)

Debug "Size of QualetizePlan_t: " + Str(SizeOf(QualetizePlan_t))

dllPath$ = "libqualetize.dll"
If OpenLibrary(#QualDLL, dllPath$) = 0
  MessageRequester("Error", "Cant load DLL")
  End
EndIf

Qualetize.ProtoQualetize = GetFunction(#QualDLL, "Qualetize")
Debug "Qualetize = " + Str(Qualetize)

; is we realy found address of function, that we need?
Debug "Function address: " + Str(GetFunction(#QualDLL, "Qualetize"))

tileSize = 8
numPalettes = 4
colorsPerPalette = 16
Dim outputPalettes.b(numPalettes * colorsPerPalette * 4) 

If LoadImage(#Image, "ironman.bmp")
  
  width  = ImageWidth(#Image)
  height = ImageHeight(#Image)
  
  ; arrays
  Dim inputRGBA.a(width * height * 4)        ; input image rgba
  Dim outputIndexed.a(width * height)      ; numbers of colors
  
  If StartDrawing(ImageOutput(#Image))
    For y = 0 To height - 1
      For x = 0 To width - 1
        color = Point(x, y) ; get color
        offset = (y * width + x) * 4 ; count memory addres, where to write data
        inputRGBA(offset + 0) = Blue(color)   ; B
        inputRGBA(offset + 1) = Green(color)  ; G
        inputRGBA(offset + 2) = Red(color)    ; R
        inputRGBA(offset + 3) = $FF           ; A
        
        ;inputRGBA(offset + 0) = Red(color)    ; R
        ;inputRGBA(offset + 1) = Green(color)  ; G
        ;inputRGBA(offset + 2) = Blue(color)   ; B        
        ;inputRGBA(offset + 3) = $FF           ; A
      Next
    Next
    StopDrawing()
  EndIf
  
Else
  MessageRequester("Error", "Loading image is fail.")
  End
EndIf

; check data with debug
Debug "arr = " + Str(@inputRGBA()) + " ; size = " + Str(ArraySize(inputRGBA()))
Debug "width = " + Str(width)
Debug "height = " + Str(height)
Debug "tileSize = " + Str(tileSize)
Debug "numPalettes = " + Str(numPalettes)
Debug "colorsPerPalette = " + Str(colorsPerPalette)
Debug "outputIndexed = " + Str(@outputIndexed()) + " ; size = " + Str(ArraySize(outputIndexed()))
Debug "outputPalettes = " + Str(@outputPalettes()) + " ; size = " + Str(ArraySize(outputPalettes()))

Debug "First pixel B,G,R,A: " + Str(inputRGBA(0)) + "," + Str(inputRGBA(1)) + "," + Str(inputRGBA(2)) + "," + Str(inputRGBA(3))
Debug "Last pixel B,G,R,A: " + Str(inputRGBA(ArraySize(inputRGBA())-4)) + "," + Str(inputRGBA(ArraySize(inputRGBA())-3)) + "," + Str(inputRGBA(ArraySize(inputRGBA())-2)) + "," + Str(inputRGBA(ArraySize(inputRGBA())-1))

; ---------------------------
; fill plan
; ---------------------------
plan.QualetizePlan_t
plan\TileWidth = 8
plan\TileHeight = 8
plan\nPaletteColours = 16
plan\nTilePalettes = 4
plan\Colourspace = 8 ; exe file have 8. no have idea what is that. it was in original exe file
plan\FirstColourIsTransparent = 1  ; 0 or 1. 1 is for making shared color for all 4 paletes. for first num in a each pal.
plan\PremultipliedAlpha = 0
plan\DitherType = $FF ; Checkerboard. ATKINSON and FLOYDSTEINBERG have bugs and dll is hung.
;//! Dithering modes available
;//! NOTE: Ordered dithering gives consistent tiled results, but Floyd-Steinberg can look nicer.
;#define DITHER_NONE           (   0) //! No dithering
;#define DITHER_ORDERED(n)     (   n) //! Ordered dithering (Kernel size: (2^n) x (2^n))
;#define DITHER_CHECKER        (0xFF) //! Checkerboard pattern
;#define DITHER_FLOYDSTEINBERG (0xFE) //! Floyd-Steinberg (diffusion)
;#define DITHER_ATKINSON       (0xFD) //! Atkinson (diffusion)
plan\DitherLevel = 1.0
plan\nTileClusterPasses = 0
plan\nColourClusterPasses = 0
plan\ColourDepth\x = $41700000 ;3.0  ; R bits ; 00 00 70 41 ColourDepth -rgba:4441
plan\ColourDepth\y = $41700000 ;3.0  ; G bits ; 00 00 70 41
plan\ColourDepth\z = $41700000 ;3.0  ; B bits ; 00 00 70 41
plan\ColourDepth\w = $3F800000 ;1.0  ; A bits ; 00 00 80 3F
plan\TransparentColour\b = 0
plan\TransparentColour\g = 0
plan\TransparentColour\r = 0
plan\TransparentColour\a = 0
; ---------------------------

;If CreateFile(#File, "plan_dumpPB.bin")  ; SAME, check
;  WriteData(#File, plan, SizeOf(QualetizePlan_t))
;  CloseFile(#File)
;EndIf
;End

;If CreateFile(#File, "bitmap_dumpPB.bin")  ; SAME, check
;  WriteData(#File, @inputRGBA(), width * height * 4)
;  CloseFile(#File)
;EndIf
;End

result = CallCFunction(#QualDLL, "Qualetize", 
                      @outputIndexed(0), @outputPalettes(0), @inputRGBA(0),
                      #Null, width, height, @plan, #Null)

;uint8_t Qualetize(
;	      uint8_t  *OutputPxData,
;	      BGRA8_t  *OutputPalette,
;	const void     *InputBitmap,
;	const BGRA8_t  *InputPalette,
;	      uint32_t  InputWidth,
;	      uint32_t  InputHeight,
;	const struct QualetizePlan_t *Plan,
;	Vec4f_t *RMSE
;)



If result = 0
  MessageRequester("Error", "Not Working")
Else
  ;MessageRequester("OK", "All Done Fine")
  Debug ""
  Debug "Function returned: " + Str(result)
  
  
  ;If CreateFile(#File, "outputindexPB.bin")  ; SAME, check
  ;  WriteData(#File, @outputIndexed(0), ArraySize(outputIndexed()))
  ;  CloseFile(#File)
  ;EndIf
  
  ;If CreateFile(#File, "outputcolorsPB.bin")  ; SAME, check
  ;  WriteData(#File, @outputPalettes(0), ArraySize(outputPalettes()))
  ;  CloseFile(#File)
  ;EndIf
  
  
  If OpenWindow(#Window, 100, 100, 400, 400, "", #PB_Window_MinimizeGadget | #PB_Window_ScreenCentered)
    
    CanvasGadget(#PalCanvasGadget, 10, 10, 95, 23)
    
    CanvasGadget(#MainImageCanvasGadget, 10, 50, 320, 224)
    
    sz = ArraySize(outputPalettes())
    If sz > 0
      sz - 1
      
      If StartDrawing(CanvasOutput(#PalCanvasGadget))
        
        x = 0 : y = 0 : column = 0
        For c = 0 To sz Step 4
          ; this is bgra
          ;color = outputPalettes(c + 3)
          ;color = color << 8 + outputPalettes(c + 2)
          ;color = color << 8 + outputPalettes(c + 1)
          ;color = color << 8 + outputPalettes(c)
          ; need to remake into rgba
          color = outputPalettes(c + 3)
          color = color << 8 + outputPalettes(c)
          color = color << 8 + outputPalettes(c + 1)
          color = color << 8 + outputPalettes(c + 2)
          Box(x, y, 5, 5, color)
          x + 6
          column + 1
          If column = 16
            x = 0
            y + 6
            column = 0
          EndIf        
        Next
        
        StopDrawing()
      EndIf
      
    EndIf
    
    sz = ArraySize(outputIndexed())
    If sz > 0
      sz - 1
      
      If StartDrawing(CanvasOutput(#MainImageCanvasGadget))
        
        x = 0 : y = 0
        For p = 0 To sz
          c = outputIndexed(p) 
          ; c is 0-63 colors num from whole pal
          ; need to recount c into array's number
          c * 4
          color = outputPalettes(c + 3)
          color = color << 8 + outputPalettes(c)
          color = color << 8 + outputPalettes(c + 1)
          color = color << 8 + outputPalettes(c + 2)
          Plot(x, y, color)
          x + 1
          If x = 320
            x = 0
            y + 1
          EndIf 
        Next        
        
        StopDrawing()
      EndIf
      
    Else
      MessageRequester("error", "no data")
    EndIf
    
    Repeat
       Select WaitWindowEvent()
  
         Case #PB_Event_Gadget
  
           Select EventGadget()
             
             Case 0
               If EventType() = #PB_EventType_LeftClick
               EndIf
  
           EndSelect
  
         Case #PB_Event_CloseWindow
           qiut = 1
     
       EndSelect
     Until qiut = 1
  
  EndIf
  
EndIf

CloseLibrary(#QualDLL)

End

i try to recreate all input and output data and final result is:




if some one know C and can fix problem with FLOYDSTEINBERG or ATKINSON for 32bit dll - will be great (hope that is not mingw32.exe bug it self).
for test change plan\DitherType = $FF to $FE or $FD