NearestColor module

Share your advanced PureBasic knowledge/code with the community.
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

NearestColor module

Post by wilbert »

Inspired by the RetroEditor from zxretrosoft, I decided to post a small module to find the nearest color from a palette.
Hopefully it inspires people to create more applications like that. :)

The module is cross platform compatible and is a compromise between quality and speed.
It doesn't have the best color matching function nor the best dither algorithm but for most images and palettes it gives a reasonable output quality at a decent speed.
There's also not very much control over the output. If you need a lot of control over the output, use something else :wink:
If you don't set any palette, the CGA palette is used.

Code: Select all

; NearestColor module by Wilbert

; Latest updated : Jan 27, 2016

; Color distance formula based on:
; http://www.compuphase.com/cmetric.htm

; Dithering method:
; Sierra Lite

DeclareModule NearestColor
  
  Prototype ProtoProgressCallback(PercentProgress.i)
  
  Declare   CatchPalette(*MemoryAddress.Long, NumColors.i)
  Declare   CopyPalette(Array DestinationArray.l(1))
  Declare.i DitheredImage(Image.i, DitherLevel.a = 220, Brightness.b = 0, Contrast.b = 0, ProgressCallback.ProtoProgressCallback = 0)
  Declare.l FindNearest(Color.l)
  Declare.i PaletteColorCount()
  Declare   SetPalette(PaletteImage.i)
  
EndDeclareModule

Module NearestColor
  
  EnableASM
  EnableExplicit
  DisableDebugger
  
  Structure ColorScan
    l.l[524288]
  EndStructure
  
  Global ColorScan.ColorScan
  Global Dim IndexG.l(255)
  Global Dim Palette.l(1)
  
  CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
    Macro rdx : edx : EndMacro
  CompilerEndIf
  
  Procedure.i PaletteColorCount()
    ; Return amount of colors the palette contains
    ProcedureReturn ArraySize(Palette()) - 1
  EndProcedure
  
  Procedure CopyPalette(Array DestinationArray.l(1))
    ; Copy the current palette into a supplied array
    Protected.i cnt = ArraySize(Palette()) - 1
    ReDim DestinationArray(cnt - 1)
    CopyMemory(@Palette(1), @DestinationArray(0), cnt << 2)
  EndProcedure
  
  Procedure CatchPalette(*MemoryAddress.Long, NumColors.i)
    ; Catch a palette from memory
    Protected.i i, j = 1
    ReDim Palette(NumColors + 1)
    Palette(0) = 0 : Palette(NumColors + 1) = 0
    For i = 1 To NumColors
      Palette(i) = $ff000000 | *MemoryAddress\l
      *MemoryAddress + 4
    Next
    SortStructuredArray(Palette(), 0, 0, #PB_Unicode, 1, NumColors)
    For i = 0 To 255
      IndexG(i) = j
      While ((Palette(j) >> 8) & $ff) = i And j < NumColors
        j + 1
      Wend
      IndexG(i) = (IndexG(i) + j) >> 1
    Next
  EndProcedure
  
  Procedure SetPalette(PaletteImage.i)
    ; Set a palette from an image
    Protected.i i, j, b, x, y, cnt
    Protected.l c, c_
    If StartDrawing(ImageOutput(PaletteImage))
      FillMemory(@ColorScan, SizeOf(ColorScan))
      j = OutputHeight() - 1
      i = OutputWidth() - 1
      ; count all used colors
      For y = 0 To j
        For x = 0 To i
          c = Point(x, y)
          !mov eax, [p.v_c]
          !rol ax, 8
          !bswap eax
          !shr eax, 8
          lea rdx, [nearestcolor.v_ColorScan]
          bts [rdx], eax
          !jc nearestcolor.setpalette_cont0
          inc cnt
          !nearestcolor.setpalette_cont0:
        Next
      Next
      StopDrawing()
      ; redim palette with room at top and bottom for zero entry
      ReDim Palette(cnt + 1)
      Palette(0) = 0 : Palette(cnt + 1) = 0
      ; set palette sorted on G, R, B and index on G
      i = 0 : j = 1
      For y = 0 To 255
        IndexG(y) = j
        For x = 0 To 2047
          b = 0 : c_ = ColorScan\l[i]
          While c_
            shr c_, 1
            !jnc nearestcolor.setpalette_cont1          
            !mov eax, [p.v_i]
            !shl eax, 5
            !or eax, [p.v_b]
            !shl eax, 8
            !or eax, 0xff
            !bswap eax
            !rol ax, 8
            !mov [p.v_c], eax
            Palette(j) = c : j + 1
            !nearestcolor.setpalette_cont1:          
            b + 1
          Wend
          i + 1  
        Next
        IndexG(y) = (IndexG(y) + j) >> 1   
      Next
    EndIf  
  EndProcedure
  
  Macro M_FindNearest(i, st)
    !nearestcolor.findnearest#i#_loop: 
    !mov ecx, [p.v_c#i#]
    !test ecx, ecx
    !jz nearestcolor.findnearest#i#_cont2
    !movzx eax, byte [p.v_Color + 1]
    !movzx ecx, ch
    !sub eax, ecx
    !imul eax, eax
    !shl eax, 11
    !cmp eax, [p.v_bestd]
    !jnc nearestcolor.findnearest#i#_cont1
    !mov [p.v_d], eax
    !movzx eax, byte [p.v_Color]
    !movzx ecx, byte [p.v_c#i#]
    !lea edx, [eax + ecx]   ; edx = rsum
    !sub eax, ecx
    !imul eax, eax          ; eax = r*r
    !lea ecx, [edx + 0x400] ; ecx = $400 + rsum
    !imul eax, ecx          ; eax = ($400+rsum)*r*r
    !add [p.v_d], eax
    !movzx eax, byte [p.v_Color + 2]
    !movzx ecx, byte [p.v_c#i# + 2]
    !sub eax, ecx
    !imul eax, eax          ; eax = b*b
    !neg edx
    !add edx, 0x5fe         ; edx = $5fe - rsum
    !imul eax, edx          ; eax = ($5fe-rsum)*b*b
    !add eax, [p.v_d]
    !cmp eax, [p.v_bestd]
    !jnc nearestcolor.findnearest#i#_cont0
    !mov [p.v_bestd], eax
    !mov eax, [p.v_c#i#]
    !mov [p.v_c], eax
    !nearestcolor.findnearest#i#_cont0:
    mov rdx, *p#i
    add rdx, st
    mov *p#i, rdx
    mov eax, [rdx]
    !mov [p.v_c#i#], eax
    CompilerIf i = 1
      !jmp nearestcolor.findnearest0_loop
    CompilerElse
      !jmp nearestcolor.findnearest1_loop
    CompilerEndIf
    !nearestcolor.findnearest#i#_cont1:
    !mov dword [p.v_c#i#], 0
    !nearestcolor.findnearest#i#_cont2:
    CompilerIf i = 1
      !cmp dword [p.v_c0], 0
      !jnz nearestcolor.findnearest0_loop
    CompilerEndIf
  EndMacro
  
  Procedure.l FindNearest(Color.l)
    ; Find the nearest color
    Protected.l c, c0, c1, d, bestd = $12000000
    Protected.Long *p0, *p1
    !movzx eax, byte [p.v_Color + 1]
    !mov [p.v_d], eax
    *p1 = @Palette(IndexG(d)) : *p0 = *p1 - 4
    c0 = *p0\l : c1 = *p1\l
    M_FindNearest(0, -4)
    M_FindNearest(1, 4)
    ProcedureReturn c
  EndProcedure
  
  Macro M_DitherImage(offset, n = 1)
    !movsx ecx, byte [p.v_err + offset]
    !movsx eax, byte [p.v_err50 + offset]
    !add ecx, eax
    !imul ecx, edx
    !sar ecx, 8
    !movzx eax, byte [p.v_c0 + offset]
    !add eax, [p.v_badd]
    !imul eax, [p.v_cmul]
    !sar eax, 8
    !lea eax, [eax + ecx + 128]
    !neg ah
    !setz cl
    !neg cl
    !and al, cl
    !sar ah, 7
    !or al, ah
    !mov [p.v_c0 + offset], al
  EndMacro
  
  Procedure.i DitheredImage(Image.i, DitherLevel.a = 220, Brightness.b = 0, Contrast.b = 0, ProgressCallback.ProtoProgressCallback = 0)
    ; Return a dithered image
    ; DitherLevel : 0 - 255
    ; Brightness : -128 - 127
    ; Contrast : -128 - 127
    Protected.i result, x, y, w, h
    Protected.l c0, c1, badd, cmul, err50, err
    If ProgressCallback : ProgressCallback(0) : EndIf
    result = CopyImage(Image, #PB_Any)
    If result And StartDrawing(ImageOutput(result))
      h = OutputHeight()
      w = OutputWidth()
      If DitherLevel = 0 And Brightness = 0 And Contrast = 0
        While y < h
          x = 0
          While x < w
            Plot(x, y, FindNearest(Point(x, y)))
            x + 1
          Wend
          y + 1
          If ProgressCallback
            ProgressCallback(100 * y / h)
          EndIf
        Wend
      Else
        badd = Brightness - 128
        cmul = (33280 * Contrast + 4259840) / (16640 - Contrast << 7)
        Dim d_error.l(w)
        While y < h
          x = 0 : err50 = 0
          While x < w
            c0 = Point(x, y)
            ; add previous error
            err = d_error(x)
            !movzx edx, byte [p.v_DitherLevel]
            M_DitherImage(0)
            M_DitherImage(1)
            M_DitherImage(2)
            c1 = FindNearest(c0)
            Plot(x, y, c1)
            ; calculate 50% error
            !mov eax, [p.v_c0]
            !mov ecx, [p.v_c1]
            !mov edx, eax
            !not edx
            !and edx, ecx
            !and edx, 0x01010101
            !or eax, 0x01010101
            !and ecx, 0xfefefefe
            !sub eax, ecx
            !xor eax, 0x01010101
            !shr eax, 1
            !sub eax, edx
            !mov ecx, [p.v_err50]
            !mov [p.v_err50], eax
            ; mix with previous error
            !xor eax, 0x80808080
            !xor ecx, 0x80808080
            !mov edx, eax
            !and edx, ecx
            !and edx, 0x01010101
            !and eax, 0xfefefefe
            !and ecx, 0xfefefefe
            !add eax, ecx
            !shr eax, 1
            !add eax, edx
            !xor eax, 0x80808080
            !mov [p.v_err], eax
            d_error(x) = err
            x + 1
          Wend
          d_error(0) << 1
          y + 1
          If ProgressCallback
            ProgressCallback(100 * y / h)
          EndIf
        Wend
      EndIf
      StopDrawing()
    EndIf
    ProcedureReturn result
  EndProcedure
  
  DataSection
    CGAPalette:
    Data.l $000000, $AA0000, $00AA00, $AAAA00, $0000AA, $AA00AA, $0055AA, $AAAAAA
    Data.l $555555, $FF5555, $55FF55, $FFFF55, $5555FF, $FF55FF, $55FFFF, $FFFFFF
  EndDataSection
  
  ; Set default palette
  CatchPalette(?CGAPalette, 16)
  
EndModule
Update Jan 26, 2015 :
- Speed improvement
- DitheredImage procedure call changed to include contrast adjustment

Update Jan 27, 2016 :
- Fixed a bug in the CatchPalette procedure
Last edited by wilbert on Wed Jan 27, 2016 4:54 pm, edited 8 times in total.
Windows (x64)
Raspberry Pi OS (Arm64)
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

Example:

Code: Select all

IncludeFile "NearestColorModule.pbi"

DataSection
  nes57_png_start:
  ; size : 1035 bytes
  Data.q $0A1A0A0D474E5089,$524448490D000000,$4000000000010000,$5983C20000000308,$544C50000300008C
  Data.q $7F96C396FFFFFF45,$0000000000007F7F,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$00FC00007C7C7C00,$840094BC2844BC00,$14880010A82000A8
  Data.q $0000780000305000,$5840000058000068,$0000000000000000,$00F87800BCBCBC00,$CC00D8FC4468F858
  Data.q $5CE40038F85800E4,$0000B800007CAC10,$88880044A80000A8,$0000000000080808,$68FCBC3CF8F8F800
  Data.q $F878F8F87898FC88,$A0FC5878F89858F8,$5818F8B800B8F844,$D8E80098F85854D8,$0000000000787878
  Data.q $B8FCE4A4FCFCFC00,$F8B8F8F8B8D8F8B8,$E0FCB0D0F0C0A4F8,$B878F8D878D8F8A8,$FCFC00D8F8B8B8F8
  Data.q $0000000000D8D8D8,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000,$0000000000000000
  Data.q $0000000000000000,$000000148FCAFC00,$ED9C7854414449C6,$C1000001020DC5D0,$7024EE07F704684B
  Data.q $F7FC1B7FD3B825B8,$A1C413094EDE7847,$85301A1A43D82302,$1943B84B03A1E433,$601806043785B006
  Data.q $0601806018060180,$C110180601806018,$40C8070C61540480,$0561740281706613,$0301F07610C1880F
  Data.q $C0300C0300C0300C,$0C0300C0300C0300,$11C2106A12406288,$3D08A15C3982D0B2,$8060197F8213C358
  Data.q $1806018060180601,$0440601806018060,$07209C0987505203,$0D87D04A0DC0586D,$00C0300C0300C0BC
  Data.q $300C0300C0300C03,$0817D9F80C0300C0,$002F5D5F26C482DE,$AE444E4549000000
  Data.b $42,$60,$82
  nes57_png_end:
EndDataSection

UseJPEGImageDecoder()
UsePNGImageDecoder()

Procedure HandleEvents(Event)
  If Event = #PB_Event_CloseWindow
    End
  EndIf
EndProcedure

Procedure ProgressCallback(progress)
  Static p = -1
  If progress <> p And IsStatusBar(0)
    StatusBarText(0, 0, Str(progress) + "% done (" + Str(NearestColor::PaletteColorCount()) +" color palette)")
    p = progress
  EndIf
  HandleEvents(WindowEvent())
EndProcedure

; Set NES palette (57 colors)
CatchImage(0, ?nes57_png_start)
NearestColor::SetPalette(0)

; Load image
LoadImage(0, "test.jpg")

; Open window and dither image

w = ImageWidth(0)
h = ImageHeight(0)

OpenWindow(0, 0, 0, w, h, "NearestColor Module", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)

If CreateStatusBar(0, WindowID(0))
  AddStatusBarField(#PB_Ignore)
  ResizeWindow(0, #PB_Ignore, #PB_Ignore, w, h + StatusBarHeight(0))
EndIf

dithered_image = NearestColor::DitheredImage(0, 220, 0, 0, @ProgressCallback())
ImageGadget(0, 0, 0, w, h, ImageID(dithered_image))

Repeat
  HandleEvents(WaitWindowEvent())
ForEver
Alternative example with custom drawn palette:

Code: Select all

IncludeFile "NearestColorModule.pbi"

UseJPEGImageDecoder()
UsePNGImageDecoder()

Procedure HandleEvents(Event)
  If Event = #PB_Event_CloseWindow
    End
  EndIf
EndProcedure

Procedure ProgressCallback(progress)
  Static p = -1
  If progress <> p And IsStatusBar(0)
    StatusBarText(0, 0, Str(progress) + "% done (" + Str(NearestColor::PaletteColorCount()) +" color palette)")
    p = progress
  EndIf
  HandleEvents(WindowEvent())
EndProcedure

; Set a custom drawn gradient palette
If CreateImage(1, 128, 16) And StartDrawing(ImageOutput(1))
  DrawingMode(#PB_2DDrawing_Gradient)
  BackColor($c0ffff)
  FrontColor($60a060)
  LinearGradient(0, 0, 64, 0)
  Box(0, 0, 64, 16)
  BackColor($60a060)
  FrontColor($001050)
  LinearGradient(64, 0, 128, 0)
  Box(64, 0, 64, 16)
  StopDrawing()
  NearestColor::SetPalette(1)
EndIf

; Load image
LoadImage(0, "test.jpg")

; Open window and dither image

w = ImageWidth(0)
h = ImageHeight(0)

OpenWindow(0, 0, 0, w, h, "NearestColor Module", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)

If CreateStatusBar(0, WindowID(0))
  AddStatusBarField(#PB_Ignore)
  ResizeWindow(0, #PB_Ignore, #PB_Ignore, w, h + StatusBarHeight(0))
EndIf

dithered_image = NearestColor::DitheredImage(0, 128, 0, 0, @ProgressCallback())
ImageGadget(0, 0, 0, w, h, ImageID(dithered_image))

Repeat
  HandleEvents(WaitWindowEvent())
ForEver
Last edited by wilbert on Mon Jan 26, 2015 7:50 am, edited 1 time in total.
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
idle
Always Here
Always Here
Posts: 5049
Joined: Fri Sep 21, 2007 5:52 am
Location: New Zealand

Re: NearestColor module

Post by idle »

works fine on Linux, thanks
Windows 11, Manjaro, Raspberry Pi OS
Image
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

idle wrote:works fine on Linux
Thanks for checking :)
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: NearestColor module

Post by BasicallyPure »

Hi Wilbert,
I am very interested in your NearestColor module.
Thanks for posting it.

I may want to use this with my color quantizing image editor.

I have some questions:

How can I use the module if I have a predefined palette in an array?
Does the array have to be defined as a 'long'?
Does the array have to be sorted in a certain way? It looks like it does.

If I don't want the result to be dithered do I set dither level to 1 or 0?

How does this compare with the similar function that is part of your neuquant module?
Is it faster or slower?
Does it do a better job at selecting the nearest color? I'm betting it does.

Thanks again for this great module.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

BasicallyPure wrote:How can I use the module if I have a predefined palette in an array?
If you have an array with colors with the RGB channels in the same order as PureBasic uses them, you can set the palette just like setting from memory the module itself does for the CGA palette.
For example just black and white.

Code: Select all

Dim PaletteBW.l(1)
PaletteBW(0) = $000000
PaletteBW(1) = $ffffff

NearestColor::CatchPalette(@PaletteBW(), 2)
BasicallyPure wrote:Does the array have to be defined as a 'long'?
Does the array have to be sorted in a certain way? It looks like it does.
It does have to be an array defined as 'long' and it doesn't have to be sorted; the procedure to set a palette does the sorting (it sorts on the green channel).
BasicallyPure wrote:If I don't want the result to be dithered do I set dither level to 1 or 0?
You can set it to 0.
BasicallyPure wrote:How does this compare with the similar function that is part of your neuquant module?
Is it faster or slower?
Does it do a better job at selecting the nearest color? I'm betting it does.
Interesting question. I guess in some situations one will perform better and in other situations the other when it comes to selecting the nearest color.
The NearestColor module isn't limited to 256 colors. You can also supply a palette of for example 512, 768 or 2048 colors.
As for speed, this NearestColor module uses only plain assembler code; no MMX or SSE so it can run on even the oldest hardware PureBasic supports. I have no clue what the impact is on the speed.
It would be nice if you can give me some feedback on your own findings about speed and quality compared with the other module.
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: NearestColor module

Post by BasicallyPure »

Thanks for the quick reply Wilbert.

It looks like you have given me enough information to proceed with my testing.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: NearestColor module

Post by BasicallyPure »

Here are the results of the speed comparison between NearestColor module and Neuquant module.
The test image size was 1920 x 1080.
Palette size ranged from 2 to 256.

Notice the Neuquqnt is slow with a palette size of 2.

raw data; time in milliseconds:
Image

graph of data:
Image

The tests were performed with the modules running in my 'Color quantizing image editor'.
The palettes were created with my custom popularity algorithm.
The waviness in the lines is likely an artifact of the palettes chosen by my algorithm.
Both of your modules would have been using the same palettes for each data point so the data
should be valid.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: NearestColor module

Post by BasicallyPure »

It is difficult to decide how to perform a quality comparison test but I gave it a try anyway.
Results were surprising in the similarity of three different methods that I tried.

I chose a 64 count palette for no particular reason.

You can click on the link below to download the full sized image.
The reference image is shown along the top with three different algorithms of choosing the
closest color shown below.

With the exception of transitions occurring one pixel left or right they look very much identical.
There is one anomaly however with the Neuquant algorithm. If you look at the far right you will
see a green bar that looks out of place. I checked it twice and it really does that. That could be
the indication of a flaw with the Neuquant nearest color algorithm.

Perhaps there is a better way to do this test such as a different test image or a different
palette count. The operation was rather tedious so I am not inclined to perform another one.

Image

click here to download larger image
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

BasicallyPure wrote:Perhaps there is a better way to do this test such as a different test image or a different
palette count. The operation was rather tedious so I am not inclined to perform another one.
Thanks for all your hard work. :)

I'll try if I can improve the speed of the NearestColor module a tiny bit more.
When it comes to quality, it mainly would depend on what palette you chose I guess.
In theory the formula of the NearestColor module should produce better results but that would be mainly visible when you use fixed palettes.
When a palette is carefully chosen based on the colors visible in an image both seem to work pretty good.

For your information, the NeuQuant module simply adds the red, green and blue differences together for comparison while the NearestColor module approach is more similar to the euclidean you were using.
When it comes to speed, both modules use a sorted and indexed palette. This means that the palette is sorted on the green component. When you want to find a color, a starting point in the sorted palette array is chosen with the help of the created index. Moving further away from that starting point always increases the difference of the green component. When the point is reached that the contribution of the green component alone is bigger as the best color found so far, the search stops since it's impossible from that point on to find a better color. This way only a part of the palette has to be searched instead of all colors.

This Wikipedia page http://en.wikipedia.org/wiki/List_of_8- ... e_palettes uses this image for testing which is also kind of nice.
Image

If you test some more, you can simply use some real world images and tell what you noticed; no need to create a complete chart or screenshots. :wink:
Last edited by wilbert on Mon Jan 26, 2015 6:02 pm, edited 3 times in total.
Windows (x64)
Raspberry Pi OS (Arm64)
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

I updated the NearestColor module code.
It's a bit faster now and I added the ability for contrast adjustment to the DitheredImage procedure.
This means the DitheredImage procedure has changed. If you were already using the module and used a progress callback, you have to insert an extra procedure argument.
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
Michael Vogel
Addict
Addict
Posts: 2666
Joined: Thu Feb 09, 2006 11:27 pm
Contact:

Re: NearestColor module

Post by Michael Vogel »

Nice idea, thanks :wink:

I merged the examples into a single demo file...

Code: Select all

; ~~~~~~~~~~~~~~~~~~~~~~ Demo ~~~~~~~~~~~~~~~~~~~~~~

Procedure HandleEvents(Event)
	If Event = #PB_Event_CloseWindow
		End
	EndIf
EndProcedure
Procedure ProgressCallback(progress)
	Static p = -1
	If progress <> p And IsStatusBar(0)
		StatusBarText(0, 0, Str(progress) + "% done (" + Str(NearestColor::PaletteColorCount()) +" color palette)")
		p = progress
	EndIf
	HandleEvents(WindowEvent())
EndProcedure

UseJPEGImageDecoder()
UsePNGImageDecoder()

LoadImage(0, "TEST.jpg"); Load image

#MaxWidth=600
#PalHeight=24

If ImageWidth(0)>#MaxWidth
	ResizeImage(0,#MaxWidth,ImageHeight(0)*#MaxWidth/ImageWidth(0))
EndIf

; --------------------------------- Palette ------------------------------------
Select 2

Case 1
	; Set a custom drawn gradient palette
	If CreateImage(1,128,16) And StartDrawing(ImageOutput(1))
		DrawingMode(#PB_2DDrawing_Gradient)
		BackColor($c0ffff)
		FrontColor($60a060)
		LinearGradient(0, 0, 64, 0)
		Box(0, 0, 64, 16)
		BackColor($60a060)
		FrontColor($1050)
		LinearGradient(64, 0, 128, 0)
		Box(64, 0, 64, 16)
		StopDrawing()
		NearestColor::SetPalette(1)
	EndIf

Case 2
	DataSection
		nes57_png_start:
		; size : 1035 bytes
		Data.q $A1A0A0D474E5089,$524448490D000000,$4000000000010000,$5983C20000000308,$544C50000300008C
		Data.q $7F96C396FFFFFF45,$07F7F,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$FC00007C7C7C00,$840094BC2844BC00
		Data.q $14880010A82000A8,$0780000305000,$5840000058000068,$0,$F87800BCBCBC00,$CC00D8FC4468F858
		Data.q $5CE40038F85800E4,$0B800007CAC10,$88880044A80000A8,$080808,$68FCBC3CF8F8F800
		Data.q $F878F8F87898FC88,$A0FC5878F89858F8,$5818F8B800B8F844,$D8E80098F85854D8,$0787878
		Data.q $B8FCE4A4FCFCFC00,$F8B8F8F8B8D8F8B8,$E0FCB0D0F0C0A4F8,$B878F8D878D8F8A8,$FCFC00D8F8B8B8F8
		Data.q $0D8D8D8,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0
		Data.q $0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0,$0
		Data.q $0,$0148FCAFC00,$ED9C7854414449C6,$C1000001020DC5D0,$7024EE07F704684B
		Data.q $F7FC1B7FD3B825B8,$A1C413094EDE7847,$85301A1A43D82302,$1943B84B03A1E433,$601806043785B006
		Data.q $601806018060180,$C110180601806018,$40C8070C61540480,$561740281706613,$301F07610C1880F
		Data.q $C0300C0300C0300C,$C0300C0300C0300,$11C2106A12406288,$3D08A15C3982D0B2,$8060197F8213C358
		Data.q $1806018060180601,$440601806018060,$7209C0987505203,$D87D04A0DC0586D,$C0300C0300C0BC
		Data.q $300C0300C0300C03,$817D9F80C0300C0,$2F5D5F26C482DE,$AE444E4549000000
		Data.b $42,$60,$82
		nes57_png_end:
	EndDataSection

	; Set NES palette (57 colors)
	CatchImage(1, ?nes57_png_start)
	NearestColor::SetPalette(1)

Case 3

	CreateImage(1,16,1)
	StartDrawing(ImageOutput(1))
	Plot(0,0,#Black)
	Plot(1,0,$080)
	Plot(2,0,$8000)
	Plot(3,0,$8080)
	Plot(4,0,$800000)
	Plot(5,0,$800080)
	Plot(6,0,$808000)
	Plot(7,0,$C0C0C0)
	Plot(8,0,#Gray)
	Plot(9,0,#Red)
	Plot(10,0,#Green)
	Plot(11,0,#Yellow)
	Plot(12,0,#Blue)
	Plot(13,0,#Magenta)
	Plot(14,0,#Cyan)
	Plot(15,0,#White)
	StopDrawing()
	NearestColor::SetPalette(1)

EndSelect

; --------------------------------- Palette ------------------------------------

; Open window and dither image
w = ImageWidth(0)
h = ImageHeight(0)

OpenWindow(0, 0, 0, w, h, "NearestColor Module", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
If CreateStatusBar(0, WindowID(0))
	AddStatusBarField(#PB_Ignore)
	ResizeWindow(0, #PB_Ignore, #PB_Ignore, w, h + StatusBarHeight(0)+#PalHeight+2)
EndIf

dithered_image = NearestColor::DitheredImage(0, 128, 0, 0, @ProgressCallback())
ImageGadget(0, 0, 0, w, h, ImageID(dithered_image))
ResizeImage(1,w,#PalHeight)
ImageGadget(1, 0, h+1, w, #PalHeight, ImageID(1))

Repeat
	HandleEvents(WaitWindowEvent())
ForEver
wilbert
PureBasic Expert
PureBasic Expert
Posts: 3870
Joined: Sun Aug 08, 2004 5:21 am
Location: Netherlands

Re: NearestColor module

Post by wilbert »

Michael Vogel wrote:I merged the examples into a single demo file...
Unfortunately color constants like #Yellow, #Blue etc. are not cross platform compatible.
On OS X they aren't available.
Windows (x64)
Raspberry Pi OS (Arm64)
User avatar
Vera
Addict
Addict
Posts: 858
Joined: Tue Aug 11, 2009 1:56 pm
Location: Essen (Germany)

Re: NearestColor module

Post by Vera »

wilbert wrote:Unfortunately color constants like #Yellow, #Blue etc. are not cross platform compatible.
As Linux/Mac - user it's always helpful to have this snippet right at hand ;-)

Code: Select all

; =============24-Bit==============
#Black = $000000  ; RGB(0, 0, 0)
#White = $FFFFFF  ; RGB(255, 255, 255)
#Red = $0000FF    ; RGB(255, 0, 0)
#Green = $00FF00  ; RGB(0, 255, 0)
#Blue = $FF0000   ; RGB(0, 0, 255)
#Gray = $808080   ; RGB(128, 128, 128)
#Magenta = $FF00FF  ; RGB(255, 0, 255)
#Yellow = $00FFFF   ; RGB(255, 255, 0)
#Cyan = $FFFF00     ; RGB(0, 255, 255)

; =============32-Bit==============
#aBlack = $FF000000  ; RGBA(0, 0, 0, 255)
#aWhite = $FFFFFFFF  ; RGBA(255, 255, 255, 255)
#aRed = $FF0000FF    ; RGBA(255, 0, 0, 255)
#aGreen = $FF00FF00  ; RGBA(0, 255, 0, 255)
#aBlue = $FFFF0000   ; RGBA(0, 0, 255, 255)
#aGray = $FF808080   ; RGBA(128, 128, 128, 255)
#aMagenta = $FFFF00FF  ; RGBA(255, 0, 255, 255)
#aYellow = $FF00FFFF   ; RGBA(255, 255, 0, 255)
#aCyan = $FFFFFF00     ; RGBA(0, 255, 255, 255)
Thanks @all for sharing your achievements ~ greets Vera
User avatar
BasicallyPure
Enthusiast
Enthusiast
Posts: 536
Joined: Thu Mar 24, 2011 12:40 am
Location: Iowa, USA

Re: NearestColor module

Post by BasicallyPure »

Wilbert,

I have encountered a bug in your 'NearestColor module'.
The problem is when any given palette has all of the green values set to zero.
Change any green value to something other than zero and it works fine.
This problem does not occur when all red or blue palette members have zero values.

Here is an example where I changed your default CGA palette to one of my own.
Notice all of the greens are zero.
This should only produce an image with various shades of magenta but it gives other colors
that are not part of the palette.

Code: Select all

  DataSection
    CGAPalette:
    ;Data.l $000000, $AA0000, $00AA00, $AAAA00, $0000AA, $AA00AA, $0055AA, $AAAAAA
    ;Data.l $555555, $FF5555, $55FF55, $FFFF55, $5555FF, $FF55FF, $55FFFF, $FFFFFF
    Data.l $FF00EA, $F200DE, $E500D2, $D800C6, $CB00BA, $BE00AE, $B100A2, $A30096
    Data.l $96008A, $89007E, $7C0072, $6F0066, $62005A, $55004E, $480042, $3B0036
  EndDataSection
 
  ; Set default palette
  CatchPalette(?CGAPalette, 16)
I'm hoping you can come up with a fix for this problem.
I've tried looking at the code but it's just too deep for me to follow.
BasicallyPure
Until you know everything you know nothing, all you have is what you believe.
Post Reply