я беру готовый код, как бы модуль, запиленный юзерами с буржуйского форума для своего горе-языка. и с помощью него импортирую изображение в свой редактор.
и пока спал - думал. там среди функций есть некая POPULARITY_PALETTE, то есть согласно моему диванно-икспердному мнению там происходит подсчет количества пикселов одного цвета, и тем самым выставляется некий рейтинг цветов чтоль. какого цвета больше - того и тапки. тогда, опять таки согласно моей диванно-икспердной теории, если я заранее, каким-то образом, втолкаю в итоговый результат работы этой функции фиолетовый и черный с очень большим значением этого самого рейтинга, то эти цвета всегда будут на выходе, а сама функция будет подтягивать ближайшие цвета к этим двум, без их изменения.
CompilerIf #PB_Compiler_IsMainFile
Enumeration
#Pal512
EndEnumeration
UsePNGImageDecoder()
UseOGGSoundDecoder()
;{ глобальная палитра
Global Dim FullPalette.l(513)
Dim col.a(8)
col(1) = 0
col(2) = 36
col(3) = 72
col(4) = 109
col(5) = 145
col(6) = 181
col(7) = 219
col(8) = 255
x = 0
y = 0
If CreateImage(#Pal512, 256, 32)
If StartDrawing(ImageOutput(#Pal512))
For i = 1 To 8
For l = 1 To 8
For k = 1 To 8
Box(x,y,4,4, RGB(col(k),col(l),col(i)))
num + 1
FullPalette(num) = RGB(col(k),col(l),col(i))
x + 4
Next
x - 32
y + 4
Next
x + 32
y - 32
Next
StopDrawing()
EndIf
EndIf ;}
; 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
DisableASM
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
CompilerEndIf
Structure PopType ; used in POPULARITY_PALETTE() procedure
clr.l ; color
pop.i ; popularity
EndStructure
Global Dim WK_Pal.l(0) ; <--- this array will contain the final palette
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())
;Debug ArraySize(WK_Pal())
;For i = 0 To ArraySize(palette());ArraySize(WK_Pal())
; Debug Str(palette(i)); + " " + Str(WK_Pal(i))
;Next
;SHOW_PALETTE(Palette())
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 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 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)
;CopyImage(ImgWork, ImgRef)
FreeImage(ImgWork)
EndIf
ProcedureReturn 1
EndProcedure
Procedure.a ImportImageWithPallete(ImgRef.l, limit, dither.i)
ret.a = 0
; repaint into 512 allow colors
NearestColor::CatchPalette(@FullPalette(), 513)
CBWidth = ImageWidth(ImgRef)
CBHeight = ImageHeight(ImgRef)
x = 0
y = 0
If StartDrawing(ImageOutput(ImgRef))
While y < CBHeight
x = 0
While x < CBWidth
Plot(x, y, NearestColor::FindNearest(Point(x, y)))
x + 1
Wend
y + 1
Wend
StopDrawing()
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
If IsImage(ImgRef)
FreeImage(ImgRef)
EndIf
CopyImage(Qimage, ImgRef)
FreeImage(Qimage)
ret = 1
EndIf
EndIf
EndIf
ProcedureReturn ret
EndProcedure
CompilerIf #PB_Compiler_IsMainFile
GetClipboardImage(ImgRef, 32)
ImportImageWithPallete(ImgRef, 14, #True)
SaveImage(ImgRef, "D:\test.png")
;For i = 0 To ArraySize(WK_Pal())
; Debug WK_Pal(i)
;Next
CompilerEndIf
