 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
 Verfasst am: 14.07.2012, 11:39 Titel: [fertig] Median-Cut Farbreduzierung |
 |
|
Moin zusammen,
Ich habe gerade einen Versuch gestartet die Farben eines hicolor Bild's auf eine beliebige anzahl Farben zu reduzieren und einen median-cut ansatz/versuch genommen, zwar wird reduziert und auch die farben selbst sind soweit ganz ok (alles im rahmen) leider hab ich noch probleme mit dem 'teilen' der Farbwerte, bei meinem jetztigen Versuch habe ich ein Bild mit 155k+ Farben und möchte es nach möglichkeit recht genau auf 256 farben zum testen reduzieren...
aber ich bekomme je nach angabe von 'maxcolors' im Type RGBCube entweder weit darüber hinaus (hier mit etwas über 300 Farben) oder viel zu wenige (150+) im vergleich mit Photofiltre sieht das ergebnis dann nicht mehr so schön aus (Photo Filtre schafft die reduzierung des gleichen bildes auf genau 254 Farben bei meinem testbild mit schönem ergebnis)
Vielleicht hat noch jemand einen Ansatz/Idee wie ich die teilung und prüfung hier verbessern kann um ein möglichst optimales Ergebnis zu erzielen?
Edit: (Edit Editiert  )
Edit: Aller guten Dinge sind 13 (jedenfalls waren 13 Versuche notwendig bis endlich ein 'brauchbares' stück Code dabei heraus sprang)
Der Code arbeitet im RGB Farbraum und nutzt Floyd-Steinberg-Dithering
evtl. etwas geschwindigkeitsoptimierung notwendig... aber ansonsten befriedigend.
Edit: nochmals bisschen optimiert
| Code: |
#Define delta(RXL1,GYa1,BZb1,RXL2,GYa2,BZb2) (sqr ( (abs(RXL1-RXL2)*abs(RXL1-RXL2)) + (abs(GYa1-GYa2)*abs(GYa1-GYa2)) + (abs(BZb1-BZb2)*abs(BZb1-BZb2)) ))
Type RGBCluster
as Integer R
as Integer G
as Integer B
Count as Integer
End Type
Type RGBClusterList
List as RGBCluster ptr
Count as Integer
End Type
Type RGBCube
as UByte minR, maxR, medR
as UByte minG, maxG, medG
as UByte minB, maxB, medB
ClusterList as RGBClusterList ptr
ClusterSize as Integer
End Type
Sub MinMaxCubeUpdate(byref Cube as RGBCube ptr)
'Dim as Uinteger LabColor
If (Cube = 0) Then Exit Sub
Dim as Integer minR = 255, maxR = 0, cenR, R
Dim as Integer minG = 255, maxG = 0, cenG, G
Dim as Integer minB = 255, maxB = 0, cenB, B
Dim as Integer wgtR, wgtG, wgtB, wgtL, wgtP
For CCL as Integer = 0 to Cube -> ClusterList -> Count-1
R = Cube -> ClusterList -> List[CCL].R \ Cube -> ClusterList -> List[CCL].Count
G = Cube -> ClusterList -> List[CCL].G \ Cube -> ClusterList -> List[CCL].Count
B = Cube -> ClusterList -> List[CCL].B \ Cube -> ClusterList -> List[CCL].Count
If (R < minR) Then minR = R
If (R > maxR) Then maxR = R
If (G < minG) Then minG = G
If (G > maxG) Then maxG = G
If (B < minB) Then minB = B
If (B > maxB) Then maxB = B
wgtR += Cube -> ClusterList -> List[CCL].R \ Cube -> ClusterList -> List[CCL].Count
wgtG += Cube -> ClusterList -> List[CCL].G \ Cube -> ClusterList -> List[CCL].Count
wgtB += Cube -> ClusterList -> List[CCL].B \ Cube -> ClusterList -> List[CCL].Count
wgtP += 1'Cube -> ClusterList -> List[CCL].Count
Next CCL
wgtR \= wgtP : cenR = (minR+maxR)\2
wgtG \= wgtP : cenG = (minG+maxG)\2
wgtB \= wgtP : cenB = (minB+maxB)\2
Cube -> medR = IIF((cenR+wgtR)\2 < minR, minR, IIF((cenR+wgtR)\2 > maxR, maxR, (cenR+wgtR)\2))
Cube -> medG = IIF((cenG+wgtG)\2 < minG, minG, IIF((cenG+wgtG)\2 > maxG, maxG, (cenG+wgtG)\2))
Cube -> medB = IIF((cenB+wgtB)\2 < minB, minB, IIF((cenB+wgtB)\2 > maxB, maxB, (cenB+wgtB)\2))
Cube -> minR = minR : Cube -> maxR = maxR
Cube -> minG = minG : Cube -> maxG = maxG
Cube -> minB = minB : Cube -> maxB = maxB
End Sub
Sub QSortRGBCluster (byref ClusterList as RGBCluster ptr, byval lo as Integer, byval hi as Integer, SortType as byte)
Dim i as Integer = lo
Dim j as Integer = hi
Dim X as Single
X = IIF(SortType = 1, ClusterList[(lo+hi)\2].R\ClusterList[(lo+hi)\2].Count, IIF(SortType = 0, ClusterList[(lo+hi)\2].G\ClusterList[(lo+hi)\2].Count, ClusterList[(lo+hi)\2].B\ClusterList[(lo+hi)\2].Count) )
Do
While IIF(SortType = 1, ClusterList[i].R\ClusterList[i].Count, IIF(SortType = 0, ClusterList[i].G\ClusterList[i].Count, ClusterList[i].B\ClusterList[i].Count) ) < X
i += 1
Wend
While X < IIF(SortType = 1, ClusterList[j].R\ClusterList[j].Count, IIF(SortType = 0, ClusterList[j].G\ClusterList[j].Count, ClusterList[j].B\ClusterList[j].Count) )
j -= 1
Wend
If (i <= j) Then
swap ClusterList[i].R , ClusterList[j].R
swap ClusterList[i].G , ClusterList[j].G
swap ClusterList[i].B , ClusterList[j].B
swap ClusterList[i].Count, ClusterList[j].Count
i += 1
j -= 1
End If
Loop Until (i > j)
If (lo < j ) Then QSortRGBCluster(ClusterList, lo, j , SortType)
If (i < hi) Then QSortRGBCluster(ClusterList, i , hi, SortType)
End Sub
Function SplitRGBClusterList(byref ClusterList as RGBClusterList ptr) as RGBClusterList ptr
Dim ClusterListCenter as Integer
Dim ClusterListEntrys as Integer
Dim EntryCenter as Integer
If (ClusterList = 0) Then return 0
'Step(1)
'gezählte Einträge in Liste ermitteln
For CL as Integer = 0 to ClusterList -> Count-1
ClusterListEntrys += ClusterList -> List[CL].Count
Next CL
If (ClusterListEntrys < 2) Then return 0
EntryCenter = ClusterListEntrys\2
'Step(2)
'finde eintrag der ermittelte Eintragsmitte 'kreuzt'
For CL as Integer = 0 to ClusterList -> Count-1
EntryCenter -= ClusterList -> List[CL].Count
If (EntryCenter <= 0) Then
ClusterListCenter = CL
Exit For
End If
Next CL
'Step(3)
'Zwei (halbe) Listen erstellen
Dim loClusterS as Integer = 0
Dim loClusterE as Integer = ClusterListCenter
Dim loClusterSize as Integer = (loClusterE-loClusterS)+1
Dim loClusterList as RGBClusterList ptr = NEW RGBClusterList
loClusterList -> List = NEW RGBCluster[loClusterSize]
Dim hiClusterS as Integer = IIF(EntryCenter = 0, ClusterListCenter+1, ClusterListCenter)
Dim hiClusterE as Integer = ClusterList -> Count-1
Dim hiClusterSize as Integer = (hiClusterE-hiClusterS)+1
Dim hiClusterList as RGBClusterList ptr = NEW RGBClusterList
hiClusterList -> List = NEW RGBCluster[hiClusterSize]
For lo as Integer = loClusterS to loClusterE
'loClusterList -> List[loClusterList -> Count].R = ClusterList -> List[lo].R
'loClusterList -> List[loClusterList -> Count].G = ClusterList -> List[lo].G
'loClusterList -> List[loClusterList -> Count].B = ClusterList -> List[lo].B
If (lo <> ClusterListCenter) Then
loClusterList -> List[loClusterList -> Count].Count = ClusterList -> List[lo].Count
loClusterList -> List[loClusterList -> Count].R = ClusterList -> List[lo].R
loClusterList -> List[loClusterList -> Count].G = ClusterList -> List[lo].G
loClusterList -> List[loClusterList -> Count].B = ClusterList -> List[lo].B
Else
ClusterList -> List[lo].R \= ClusterList -> List[lo].Count
ClusterList -> List[lo].G \= ClusterList -> List[lo].Count
ClusterList -> List[lo].B \= ClusterList -> List[lo].Count
loClusterList -> List[loClusterList -> Count].Count = ClusterList -> List[lo].Count+EntryCenter
ClusterList -> List[lo].Count -= loClusterList -> List[loClusterList -> Count].Count
loClusterList -> List[loClusterList -> Count].R = ClusterList -> List[lo].R * loClusterList -> List[loClusterList -> Count].Count
loClusterList -> List[loClusterList -> Count].G = ClusterList -> List[lo].G * loClusterList -> List[loClusterList -> Count].Count
loClusterList -> List[loClusterList -> Count].B = ClusterList -> List[lo].B * loClusterList -> List[loClusterList -> Count].Count
ClusterList -> List[lo].R *= ClusterList -> List[lo].Count
ClusterList -> List[lo].G *= ClusterList -> List[lo].Count
ClusterList -> List[lo].B *= ClusterList -> List[lo].Count
End If
loClusterList -> Count += 1
Next lo
For hi as Integer = hiClusterS to hiClusterE
hiClusterList -> List[hiClusterList -> Count].R = ClusterList -> List[hi].R
hiClusterList -> List[hiClusterList -> Count].G = ClusterList -> List[hi].G
hiClusterList -> List[hiClusterList -> Count].B = ClusterList -> List[hi].B
hiClusterList -> List[hiClusterList -> Count].Count = ClusterList -> List[hi].Count
hiClusterList -> Count += 1
Next hi
'Step(4)
'neue liste(lo) zuweisen und liste(hi) ausgeben
Delete[] ClusterList -> List
ClusterList = loClusterList
return hiClusterList
End Function
Function ColorReduce (byref FBImage as any ptr, byval maxcolors as Integer=256, byval Dithering as Integer=1) as Integer
'Imagecheck
Dim as Integer IsImage , ImagePitch
Dim as Integer ImageWidth, ImageHeight
Dim as UInteger ptr Image , ImageRow
If (FBImage = 0) Then
return 0
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then return 0
ImagePitch \= 4
End If
'Step(1)
Dim BaseClusterList as RGBClusterList ptr = NEW RGBClusterList
BaseClusterList -> List = NEW RGBCluster[&h10000]
BaseClusterList -> Count = &h10000 'using a 16bit Index
Dim BaseClusterCount as Integer
Dim rColor as UInteger
Dim Index as Integer
Dim Red as Integer
Dim Green as Integer
Dim Blue as Integer
'Dim as byte LR, aG, bB 'Lab test
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
Red = lobyte(hiword(rColor))
Green = hibyte(loword(rColor))
Blue = lobyte(loword(rColor))
'Index = ((Red shr 3) shl 10) + ((Green shr 4) shl 6) + (Blue shr 2) '546 15bit
'Index = ((Red shr 3) shl 11) + ((Green shr 2) shl 5) + (Blue shr 3) '565 16bit
Index = ((Red shr 3) shl 10) + ((Green shr 3) shl 5) + (Blue shr 3) '555 15bit
'Index = ((Red shr 2) shl 9) + ((Green shr 2) shl 3) + (Blue shr 4) '664 16bit
'Index = ((Red shr 2) shl 10) + ((Green shr 4) shl 6) + (Blue shr 2) '646 16bit
'Index = ((Red shr 3) shl 11) + ((Green shr 3) shl 6) + (Blue shr 2) '556 16bit
'Index = ((Red shr 2) shl 10) + ((Green shr 3) shl 5) + (Blue shr 3) '655 16bit
'rColor = RGBtoLab(RGB(Red,Green,Blue)) 'Lab test
'LR = lobyte(hiword(rColor)) : Red = LR 'Lab test
'aG = hibyte(loword(rColor)) : Green = aG 'Lab test
'bB = lobyte(loword(rColor)) : Blue = bB 'Lab test
If (BaseClusterList -> List[Index].Count = 0) Then
BaseClusterCount += 1
BaseClusterList -> List[Index].R = Red
BaseClusterList -> List[Index].G = Green
BaseClusterList -> List[Index].B = Blue
Else
BaseClusterList -> List[Index].R += Red
BaseClusterList -> List[Index].G += Green
BaseClusterList -> List[Index].B += Blue
End If
BaseClusterList -> List[Index].Count += 1
Next X
ImageRow += ImagePitch
Next Y
'Step(2)
Dim CubeList as RGBCube ptr ptr = allocate(maxcolors * SizeOf(any ptr))
Dim CubeCount as Integer
Dim CubeClusterCount as Integer
CubeList[0] = NEW RGBCube
CubeList[0] -> ClusterList = NEW RGBClusterList
CubeList[0] -> ClusterList -> List = NEW RGBCluster[BaseClusterCount]
For BCL as Integer = 0 to BaseClusterList -> Count -1
If (BaseClusterList -> List[BCL].Count) Then
CubeList[0] -> ClusterList -> List[CubeClusterCount].R = BaseClusterList -> List[BCL].R
CubeList[0] -> ClusterList -> List[CubeClusterCount].G = BaseClusterList -> List[BCL].G
CubeList[0] -> ClusterList -> List[CubeClusterCount].B = BaseClusterList -> List[BCL].B
CubeList[0] -> ClusterList -> List[CubeClusterCount].Count = BaseClusterList -> List[BCL].Count
CubeClusterCount += 1
If (CubeClusterCount = BaseClusterCount) Then Exit For
End If
Next BCL
CubeList[0] -> ClusterList -> Count = CubeClusterCount
MinMaxCubeUpdate(CubeList[0])
CubeCount = 1
'Step(3)
Dim DDist as Integer
Dim RDist as Integer
Dim GDist as Integer
Dim BDist as Integer
Dim CDist as Integer
Dim CubeP as Integer
Dim CubeID as Integer
Dim NewCubeList as RGBClusterList ptr
Do
CDist = 0 : NewCubeList = 0
For CC as Integer = 0 to CubeCount-1
RDist = CubeList[CC] -> maxR - CubeList[CC] -> minR
GDist = CubeList[CC] -> maxG - CubeList[CC] -> minG
BDist = CubeList[CC] -> maxB - CubeList[CC] -> minB
DDist = IIF(RDist > GDist, IIF(RDist > BDist, RDist, IIF(BDist > GDist, BDist, GDist)), IIF(GDist < BDist, BDist, GDist))
If (DDist > CDist) Then
CubeP = 0
For LC as Integer = 0 to CubeList[CC] -> ClusterList -> Count-1
CubeP += CubeList[CC] -> ClusterList -> List[LC].Count
Next LC
If (CubeP > 2) Then
CDist = DDist
CubeID = CC
End If
End If
Next CC
'---------'
RDist = CubeList[CubeID] -> maxR - CubeList[CubeID] -> minR
GDist = CubeList[CubeID] -> maxG - CubeList[CubeID] -> minG
BDist = CubeList[CubeID] -> maxB - CubeList[CubeID] -> minB
DDist = IIF(RDist > GDist, IIF(RDist > BDist, 1, IIF(BDist > GDist, 2, 0)), IIF(GDist < BDist, 2, 0))
QSortRGBCluster (CubeList[CubeID] -> ClusterList -> List, 0, CubeList[CubeID] -> ClusterList -> Count-1, DDist)
NewCubeList = SplitRGBClusterList (CubeList[CubeID] -> ClusterList)
If (NewCubeList) Then
CubeList[CubeCount] = NEW RGBCube
CubeList[CubeCount] -> ClusterList = NewCubeList
MinMaxCubeUpdate(CubeList[CubeID] )
MinMaxCubeUpdate(CubeList[CubeCount])
CubeCount += 1
Else
Exit Do
End If
Loop while (CubeCount < maxcolors)
'Step(4)
Dim as Ubyte BaseR, BaseG, BaseB
Dim as UByte CubeR, CubeG, CubeB
Dim as Double dRGBC, dRGB
For BCL as Integer = 0 to BaseClusterList -> Count-1'&h7FFF
If (BaseClusterList -> List[BCL].Count) Then
BaseR = BaseClusterList -> List[BCL].R\BaseClusterList -> List[BCL].Count
BaseG = BaseClusterList -> List[BCL].G\BaseClusterList -> List[BCL].Count
BaseB = BaseClusterList -> List[BCL].B\BaseClusterList -> List[BCL].Count
dRGBC = 500
For CL as Integer = 0 to CubeCount-1
CubeR = CubeList[CL] -> medR
CubeG = CubeList[CL] -> medG
CubeB = CubeList[CL] -> medB
dRGB = delta(BaseR, BaseG, BaseB, CubeR, CubeG, CubeB)
If (dRGB < dRGBC) Then
CubeID = CL
dRGBC = dRGB
End If
Next CL
BaseClusterList -> List[BCL].R = CubeList[CubeID] -> medR
BaseClusterList -> List[BCL].G = CubeList[CubeID] -> medG
BaseClusterList -> List[BCL].B = CubeList[CubeID] -> medB
End If
Next BCL
Dim RError as Integer
Dim GError as Integer
Dim BError as Integer
Dim DLevel as Integer
Dim WRed as Integer
Dim WGreen as Integer
Dim WBlue as Integer
'Dim as byte WLR, WaG, WbB 'Lab test
ImageRow = Image
DLevel = IIF(Dithering<8,8,Dithering)
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
WRed = lobyte(hiword(rColor))
WGreen = hibyte(loword(rColor))
WBlue = lobyte(loword(rColor))
'Index = ((WRed shr 3) shl 10) + ((WGreen shr 4) shl 6) + (WBlue shr 2) '546 15bit
'Index = ((WRed shr 3) shl 11) + ((WGreen shr 2) shl 5) + (WBlue shr 3) '565 16bit
Index = ((WRed shr 3) shl 10) + ((WGreen shr 3) shl 5) + (WBlue shr 3) '555 15bit
'Index = ((WRed shr 2) shl 9) + ((WGreen shr 2) shl 3) + (WBlue shr 4) '664 16bit
'Index = ((WRed shr 2) shl 10) + ((WGreen shr 4) shl 6) + (WBlue shr 2) '646 16bit
'Index = ((WRed shr 3) shl 11) + ((WGreen shr 3) shl 6) + (WBlue shr 2) '556 16bit
'Index = ((WRed shr 2) shl 10) + ((WGreen shr 3) shl 5) + (WBlue shr 3) '655 16bit
'WLR = BaseClusterList -> List[Index].R : WaG = BaseClusterList -> List[Index].G : WbB = BaseClusterList -> List[Index].B
'rColor = LabtoRGB(Lab(WLR,WaG,WbB))
If (BaseClusterList -> List[Index].Count) Then
ImageRow[X] = RGB(BaseClusterList -> List[Index].R,BaseClusterList -> List[Index].G,BaseClusterList -> List[Index].B)
Else
dRGBC = 500
For CL as Integer = 0 to CubeCount-1
CubeR = CubeList[CL] -> medR
CubeG = CubeList[CL] -> medG
CubeB = CubeList[CL] -> medB
dRGB = delta(WRed, WGreen, WBlue, CubeR, CubeG, CubeB)
If (dRGB < dRGBC) Then
CubeID = CL
dRGBC = dRGB
End If
Next CL
BaseClusterList -> List[Index].R = CubeList[CubeID] -> medR
BaseClusterList -> List[Index].G = CubeList[CubeID] -> medG
BaseClusterList -> List[Index].B = CubeList[CubeID] -> medB
BaseClusterList -> List[Index].Count = 1
'WLR = BaseClusterList -> List[Index].R : WaG = BaseClusterList -> List[Index].G : WbB = BaseClusterList -> List[Index].B
'rColor = LabtoRGB(Lab(WLR,WaG,WbB))
ImageRow[X] = RGB(BaseClusterList -> List[Index].R,BaseClusterList -> List[Index].G,BaseClusterList -> List[Index].B)
End If
If (Dithering) Then
RError = (WRed - BaseClusterList -> List[Index].R) \ 2'(DLevel\2)
GError = (WGreen - BaseClusterList -> List[Index].G) \ 2'(DLevel\2)
BError = (WBlue - BaseClusterList -> List[Index].B) \ 2'(DLevel\2)
Else
RError = IIF(abs(RError) < 128, 0, maxcolors-1)'255)
GError = IIF(abs(GError) < 128, 0, maxcolors-1)'255)
BError = IIF(abs(BError) < 128, 0, maxcolors-1)'255)
End If
If (X < (ImageWidth-1)) Then 'X+1 7/16
rColor = ImageRow[X+1]
WRed = lobyte(hiWord(rColor)) + (7 * RError / DLevel)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (7 * GError / DLevel)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (7 * BError / DLevel)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X+1] = RGB(WRed,WGreen,WBlue)
End If
If (X < (ImageWidth-1)) and (Y < (ImageHeight-1)) Then 'X+1,Y+1 1/16
rColor = ImageRow[X+1 + ImagePitch]
WRed = lobyte(hiWord(rColor)) + (1 * RError / DLevel)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (1 * GError / DLevel)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (1 * BError / DLevel)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X+1 + ImagePitch] = RGB(WRed,WGreen,WBlue)
End If
If (Y < (ImageHeight-1)) Then 'Y+1 5/16
rColor = ImageRow[X + ImagePitch]
WRed = lobyte(hiWord(rColor)) + (5 * RError / DLevel)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (5 * GError / DLevel)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (5 * BError / DLevel)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X + ImagePitch] = RGB(WRed,WGreen,WBlue)
End If
If (X > 0) and (Y < (ImageHeight-1)) Then 'X-1,Y+1 3/16
rColor = ImageRow[X + ImagePitch -1]
WRed = lobyte(hiWord(rColor)) + (3 * RError / DLevel)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (3 * GError / DLevel)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (3 * BError / DLevel)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X + ImagePitch -1] = RGB(WRed,WGreen,WBlue)
End If
'End If
Next X
ImageRow += ImagePitch
Next Y
'FreeMem:
Delete[] BaseClusterList -> List
Delete BaseClusterList
For DC as Integer=0 to CubeCount-1
Delete[] CubeList[DC] -> ClusterList -> List
Delete CubeList[DC] -> ClusterList
Delete CubeList[DC]
Next DC
deallocate CubeList
return 1
End Function
Screen 19,32
Dim testimage as any ptr = imagecreate(800,600)
bload "test.bmp",testimage
ColorReduce(testimage,256,0)
Put (0,0),testimage,pset
bsave "testimage.bmp",testimage
sleep
|
_________________
Zuletzt bearbeitet von Eternal_pain am 26.07.2012, 11:29, insgesamt 2-mal bearbeitet |
|
| Nach oben |
|
 |
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1838
Wohnort: [JN58JR]
|
| Verfasst am: 15.07.2012, 12:37 Titel: |
|
|
Wie wäre denn ein
| Code: | | OutPixel = Fix(MaxColor / CurMaxColor * InPixel) |
Das reduziert ganz schlichte jede art von Pixelfarbe auf deine neue max anzahl
Wenn du das ganze dann noch in "Falschfarben" haben willst, könntest du das ganze dann noch mit
| Code: | | OutPixel = CurMaxColor / MaxColor * Fix(MaxColor / CurMaxColor * InPixel) |
verrechnen.
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 15.07.2012, 21:01 Titel: |
|
|
Eine einfache reduzierung wäre auch per grauton schnell und einfach möglich, allerdings wollte ich dass das farbreduzierte Bild farblich so nah wie nur möglich am original Bild anlehnt.
Daher der Versuch des (als beste möglichkeit beschriebenen) median-cut ansatz
Mein neuster Versuch (der 8. inzwischen) laeuft schon recht gut, gegenüber der Indexfunktion von Photofiltre weichen die ergebnisse zwar immernoch leicht voneinander ab aber insgesamt kann sich das Ergebnis schon sehen lassen, dazu läuft er ohne bisherige codeoptimierung schneller als erwartet (und ein paar meiner vorversuche)
Ist allerdings auch etwas komplexer geworden als ich dachte daher den source mal als zip (mit beispiel)
Download: ColorReduce.zip
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1838
Wohnort: [JN58JR]
|
| Verfasst am: 15.07.2012, 23:05 Titel: |
|
|
naja... irgend wie kann ich nicht glauben, das ein solches verfahren so enormen code-aufwand benötigt. ... auch die farbannäherung.
MfG
TPM
PS: ich bastel auch ma n bissi dran rum
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 15.07.2012, 23:23 Titel: |
|
|
Wundere mich eigentlich selbst über die Codemenge;
Leider gibt es nicht wirklich viel (brauchbares) zum median-cut algo (von Paul Heckbert) weder bei Wiki noch sonstwie per Googlesuche, das wenige das sich findet ist grösstenteils der gleiche Inhalt, der grob lautet;
* erstelle ein Farbhistogramm/Farbliste,
* erstelle einen Farbwürfel anhand der Liste/ des Histogramms,
* teile Würfel der längsten achse entlang in zwei teile,
* wiederhole teilen des Würfels so oft bis gewünschte anzahl 'Wüffel/Farben' erreicht ist.
* Wähle representanten von Farbliste/Farbhistogram aus Würfel
* ersetze alte farbe mit neuer farbe
Die neue Farbe kann auf verschiedenste weise 'gewählt' werden, hier habe ich einfach den Mittelwert zwischen min/max genommen, welches bisher das 'schönere' Ergebnis aus meinen Versuchen geliefert hat
Der Code ist leider nicht besonders 'schön' und (noch) nicht optimiert, aber funktioniert bisher schonmal recht gut
ein paar Functionen kann man allerdings auch rauswerfen, wie GetHistogram24b und GetHistogram16b.
Diese hab ich eigentlich nur zu testzwecken erstellt gehabt ob ein
besseres/genaueres Ergebnis anhand eines grösseren Histogramms erzielt werden kann, aber ausser auf speicher und geschwindigkeit hat es wenn nur sehr geringe auswirkung auf das Endergebnis
_________________
|
|
| Nach oben |
|
|
28398
Anmeldungsdatum: 25.04.2008
Beiträge: 1917
|
| Verfasst am: 16.07.2012, 10:57 Titel: |
|
|
Schau dir doch einfach an wie GIMP oder PDN das machen...?  |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 16.07.2012, 17:33 Titel: |
|
|
Habe gerade mal einen Blick in den GIMP Source geworfen, der part der für die Farbreduzierung zuständig ist, hat ohne die zugehörigen Includes, mal eben 4k+ Zeilen 
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1838
Wohnort: [JN58JR]
|
|
| Nach oben |
|
|
Flo
aka kleiner_hacker
Anmeldungsdatum: 23.06.2006
Beiträge: 1210
|
| Verfasst am: 16.07.2012, 18:04 Titel: |
|
|
| ThePuppetMaster hat Folgendes geschrieben: | das is ja auch C(++)  |
und deshalb ist fb-code um sooo viel schlanker  ? das wage ich ja mal anzuzweifeln
(btw, hab ich dich letztens in #archlinux gesehen, tpm?)
_________________
MFG
Flo
Satoru Iwata: Wer Spaß am Spielen hat, fragt nicht nach Grafik.
zum korrekten Verstaendnis meiner Beitraege ist die regelmaessige Wartung des Ironiedetektors unerlaesslich. |
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1838
Wohnort: [JN58JR]
|
| Verfasst am: 16.07.2012, 18:05 Titel: |
|
|
Och .. der source kommt mir schon deutlich schlanker vor. ob das die bin is, is ja ne andere frage 
arch: nop
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
Jojo
alter Rang
Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte
|
| Verfasst am: 16.07.2012, 20:11 Titel: |
|
|
Pro-Tipp: Man kann in jeder Sprache Sourcecode over-engineeren. Und Man kann viele Dinge in C++ wesentlich kürzer schreiben als in FB oder auch C.
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
 |
|
| Nach oben |
|
|
28398
Anmeldungsdatum: 25.04.2008
Beiträge: 1917
|
| Verfasst am: 19.07.2012, 20:16 Titel: |
|
|
| Pro-Tipp™ von Opa Rats: In Python™ kann man Sachen oft am kürzesten abhandeln. Und mit PyPy™ rennt die Sau auch. |
|
| Nach oben |
|
|
dreael
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 2529
Wohnort: Hofen SH (Schweiz)
|
| Verfasst am: 21.07.2012, 15:55 Titel: |
|
|
Zum im Titel genannten Problem: Aufgabenstellung müsste klar als Herunterrechnung eines Echtfarbbildes (=jeder Pixel hat eigene RGB-Werte) in ein Palettenbild (Indexed Color) definiert werden.
Um diese Aufgabe zu lösen, sind zwei Teilprobleme zu lösen:
1.) Farbpalette bestimmen
2.) Bild selber durch geeignetes Dithering herunterrechnen
Selber habe ich in diesem Bereich noch nichts selber programmiert, aber von meinen alten QB-Beispielen (siehe Knoblifax) weiss ich nur noch, dass automatisch berechnete Farbpaletten häufig sich sehr nahe auf der Grauachse bewegen, so dass ein grünes Gebüsch mehr braungrau wird, ein roter Ziegelstein ebenfalls mehr ins Beige tendiert (beim Herunterrechnen auf 16 Farben ganz extrem) -> mit handoptimierten Farbpaletten (z.B. ich picke die Farben an markanten Stellen vom Bild selber heraus) kann das Ergebnis erheblich verbessert werden, so dass das Foto im SCREEN 12 (=nur 16 Farben bzw. 4 bpp) auch noch etwas hergibt.
Palettenbilder dürften aber vermutlich inzwischen nur noch historische Bedeutung haben, da Echtfarb-Bildschirmauflösungen jetzt doch schon vor weit über 10 Jahre zum Standard geworden sind (mit Windows 95 sind Grafikkarten mit 2 MB und mehr Video-RAM üblich geworden), womit auch Dinge wie die berühmte Netscape-Farbpalette beim Webdesign schon längst überholt und veraltet sind.
In jüngerer Zeit habe ich mit einem 256-Farben-Desktop eigentlich nur noch bei Windows Vista einmal Vorliebe nehmen müssen, wenn der PC nur die minimalen 512 MB RAM besitzt und das Onboard-VGA mit Shared Memory arbeitet, d.h. der DAC-Chip das Video-RAM dem regulären Arbeitsspeicher "abzwackt". -> In diesem Fall bekommen dargestellte Webseiten zum Teil erhebliche Farbfehler im Internet Explorer und der gesamte Desktop präsentiert sich ebenfalls mehr als "Streuselkuchen".
_________________
Teste die PC-Sicherheit mit www.sec-check.net |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 21.07.2012, 17:18 Titel: |
|
|
| Zitat: | | dass automatisch berechnete Farbpaletten häufig sich sehr nahe auf der Grauachse bewegen |
Ich hab mir viele Beispiele angesehen die eine Farbreduzierung durchführen und bin da 'erstaunlicherweise oft' auf
Codes gestossen die das Bild per Grauton bzw Helligkeit 'vorreduzieren/verrechnen' die Ergebnise sind zwar
Optisch schon ganz ok (man kann jedenfalls das Bild was es ist/war deutlich erkennen) jedoch Farblich zu weit
vom Original entfernt.
| Zitat: | | Palettenbilder dürften aber vermutlich inzwischen nur noch historische Bedeutung haben, da Echtfarb-Bildschirmauflösungen jetzt doch schon vor weit über 10 Jahre zum Standard geworden sind (mit Windows 95 sind Grafikkarten mit 2 MB und mehr Video-RAM üblich geworden), womit auch Dinge wie die berühmte Netscape-Farbpalette beim Webdesign schon längst überholt und veraltet sind. |
Leider kenne ich bisher noch kein 'standard' für Web bzw allgemeine Bildanimationen ausser dem GIF format welches
leider nur max. 256 Farben unterstützt.
Ich meinen momentenen Projekt BMP to OBJ spielt Farbgenauigkeit eigentlich keine Rolle, ich brauchte nur ein herunterrechnen der Farben zum erstellen einer maximalen Objektanzahl (werde da wohl auch wieder auf graustufenreduzierung gehen, ist schnell und liefert gute ergebnisse)
Bei einem sehr viel älteren Projekt das schon seit Jahren auf meiner Platte liegt und ich damals nicht weiter kam
geht es wie eben angesprochen um das berechnen von Animationen welche später fertig als GIF gespeichert werden sollen.
An dieser stelle würde ich einen Optimalenen median-cut algo benötigen um ein optimales Ergebnis zu erzielen.
Ich grabe da an dieser Stelle gern mal ein altes GIF aus, die animation wurde mit dem erwähnten alten Projekt erstellt
Die reduzierung hab ich dann per Hand gemacht, bzw machen lassen mit Photofiltre
Photofiltre's Indexcolor funktion liefert absolut perfekte Ergebnisse (256 Farben ohne dithering)
Bei meinem Versuch musste ich letztenendes leider feststellen das die Ergebnisse noch weit weg vom 'optimalen' entfernt sind...
Edit/Note: eine überlegung wäre es noch zwei Farbreduzierungs-algos zu kombinieren, den Populary algo zusammen mit den Median-cut.....
_________________
|
|
| Nach oben |
|
|
Jojo
alter Rang
Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte
|
| Verfasst am: 21.07.2012, 20:35 Titel: |
|
|
| Eternal_pain hat Folgendes geschrieben: | | Photofiltre's Indexcolor funktion liefert absolut perfekte Ergebnisse (256 Farben ohne dithering) |
Stimmt so auch nur bedingt, oft "verrechnet" sich das Programm bei Bildern, die bereits mit einem anderen Programm auf 256 Farben runtergerechnet wurden und reduziert diese dann auf noch weniger Farben, selbst wenn man 256 Farben auswählt. Hab auch schon einen Bugreport geschrieben aber seitdem hat sich nichts mehr daran getan...
Die wohl am besten unterstützte Truecolor-Alternative zu GIF ist momentan APNG, auch wenn da der Support noch zu wünschen übrig lässt. Ist aber immerhin weiter verbreitet als MNG...
_________________
» Die Mathematik wurde geschaffen, um Probleme zu lösen, die es nicht gäbe, wenn die Mathematik nicht erschaffen worden wäre.
|
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 22.07.2012, 11:07 Titel: |
|
|
9. Versuch
Es wird besser... aber leider immernoch nicht gut genug...
Edit: bei einer reduzierung von minimal64 Farben sind die Ergebnisse eigentlich recht gut zu gebrauchen....
| Code: | Function Distance3f (byval X1 as Single, byval Y1 as Single, byval Z1 as Single, _
byval X2 as Single, Byval Y2 as Single, Byval Z2 as Single) as Single
Dim PX as Single = abs(X1-X2)*abs(X1-X2)
Dim PY as Single = abs(Y1-Y2)*abs(Y1-Y2)
Dim PZ as Single = abs(Z1-Z2)*abs(Z1-Z2)
Function = SQR(PX+PY+PZ)
End Function
'RGB - L*a*b --> http://de.wikipedia.org/wiki/Lab-Farbraum
'http://www.cs.rit.edu/~ncs/color/t_convert.html#RGB%20to%20XYZ%20&%20XYZ%20to%20RGB
SUB RGB_to_XYZ(byval RGB_Red as Ubyte , Byval RGB_Green as UByte , Byval RGB_Blue as Ubyte, _
Byref X_POS as Single, Byref Y_POS as Single, Byref Z_POS as Single)
X_POS = (RGB_Red * 0.4124564) + (RGB_Green * 0.3575761) + (RGB_Blue * 0.1804375)
Y_POS = (RGB_Red * 0.2126729) + (RGB_Green * 0.7151522) + (RGB_Blue * 0.0721750)
Z_POS = (RGB_Red * 0.0193339) + (RGB_Green * 0.1191920) + (RGB_Blue * 0.9503041)
End Sub
Function ColorCount24b (byval FBImage as any ptr) as UInteger
'Imagecheck
Dim IsImage as Integer
Dim ImageWidth as Integer
Dim ImageHeight as Integer
Dim ImagePitch as Integer
Dim ImageRow as UInteger ptr
Dim Image as UInteger ptr
If (FBImage = 0) Then
return 0
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then return 0
ImageRow = Image
ImagePitch \= 4
End If
Dim ColorBitList as UByte ptr = NEW UByte[&h200000]
Dim CBLBit as UByte
Dim CBLByte as UInteger
Dim IndexColor as UInteger
Dim CountColor as UInteger
For Y as Integer=0 to ImageHeight-1
For X as Integer=0 to ImageWidth-1
IndexColor = (ImageRow[X] and &hFFFFFF)
ASM
mov eax, [IndexColor]
mov ebx, &h08
mov edx, &h0
div ebx
mov [CBLByte],eax
mov [CBLBit],edx
End ASM
If (Bit(ColorBitList[CBLByte],CBLBit) = 0) Then
CountColor += 1
ColorBitList[CBLByte] += (1 SHL CBLBit)
End If
Next X
ImageRow += ImagePitch
Next Y
Delete[] ColorBitList
Return CountColor
End Function
Type RGBHist
Red as Ubyte
Green as UByte
Blue as UByte
Count as Integer
End Type
Type XYZCube
as Single minX, maxX
as Single minY, maxY
as Single minZ, maxZ
Hist as RGBHist ptr
HistCount as Integer
CubeColor as UInteger
End Type
' **
' *
Sub HQSort (byref Histogram as RGBHist ptr, byval lo as Integer, byval hi as Integer, SortType as byte)
Dim i as Integer = lo
Dim j as Integer = hi
Dim as Single cX,cY,cZ,xC
Dim as Single iX,iY,iZ,iC
Dim as Single jX,jY,jZ,jC
RGB_to_XYZ(Histogram[(lo+hi)\2].Red, Histogram[(lo+hi)\2].Green, Histogram[(lo+hi)\2].Blue, cX,cY,cZ)
xC = IIF(SortType = 0, cX, IIF(SortType = 1, cY, cZ))
Do
Do
RGB_to_XYZ(Histogram[i].Red, Histogram[i].Green, Histogram[i].Blue, iX,iY,iZ)
iC = IIF(SortType = 0, iX, IIF(SortType = 1, iY, iZ))
If (iC < xC) Then
i += 1
Else
Exit Do
End If
Loop
Do
RGB_to_XYZ(Histogram[j].Red, Histogram[j].Green, Histogram[j].Blue, jX,jY,jZ)
jC = IIF(SortType = 0, jX, IIF(SortType = 1, jY, jZ))
If xC < jC Then
j -= 1
Else
Exit Do
End If
Loop
If (i <= j) Then
swap Histogram[i].Red , Histogram[j].Red
swap Histogram[i].Green, Histogram[j].Green
swap Histogram[i].Blue , Histogram[j].Blue
swap Histogram[i].Count, Histogram[j].Count
i += 1
j -= 1
End If
Loop Until (i > j)
If (lo < j ) Then HQSort(Histogram, lo, j , SortType)
If (i < hi) Then HQSort(Histogram, i , hi, SortType)
End Sub
Sub XYZCube_minmax_Update(byref InCube as XYZCube ptr)
If (InCube = 0) Then Exit Sub
Dim as Single minX = 255
Dim as Single maxX = 0
Dim as Single minY = 255
Dim as Single maxY = 0
Dim as Single minZ = 255
Dim as Single maxZ = 0
Dim as Single CubeX, CubeY, CubeZ
For l as Integer = 0 to InCube -> HistCount-1
With InCube -> Hist[l]
RGB_to_XYZ(.Red, .Green, .Blue, CubeX, CubeY, CubeZ)
If (CubeX < minX) Then minX = CubeX
If (CubeX > maxX) Then maxX = CubeX
If (CubeY < minY) Then minY = CubeY
If (CubeY > maxY) Then maxY = CubeY
If (CubeZ < minZ) Then minZ = CubeZ
If (CubeZ > maxZ) Then maxZ = CubeZ
End With
Next l
InCube -> minX = minX
InCube -> maxX = maxX
InCube -> minY = minY
InCube -> maxY = maxY
InCube -> minZ = minZ
InCube -> maxZ = maxZ
End Sub
Function Split_XYZCube(byref InCube as XYZCube ptr) as XYZCube ptr
Dim SortType as Integer
Dim as Single Dx,Dy,Dz
Dx = InCube -> maxX - InCube -> minX
Dy = InCube -> maxY - InCube -> minY
Dz = InCube -> maxZ - InCube -> minZ
SortType = IIF (Dx >= Dy, IIF(Dx >= Dz, 0, IIF(Dz >= Dy, 2, 1)), IIF(Dy >= Dz, 1, 2))
HQSort (InCube -> Hist, 0, InCube -> HistCount-1, SortType)
Dim hc as UInteger = InCube -> HistCount\2
Dim loLength as UInteger = hc
Dim hiLength as UInteger = InCube -> HistCount-hc
Dim loCount as Integer = 0
Dim hiCount as Integer = 0
Dim loHist as RGBHist ptr = NEW RGBHist[loLength]
Dim hiHist as RGBHist ptr = NEW RGBHist[hiLength]
For l as Integer = 0 to hc-1
loHist[loCount].Red = InCube -> Hist[l].Red
loHist[loCount].Green = InCube -> Hist[l].Green
loHist[loCount].Blue = InCube -> Hist[l].Blue
loHist[loCount].Count = InCube -> Hist[l].Count
loCount += 1
Next l
For h as Integer = hc to InCube -> HistCount-1
hiHist[hiCount].Red = InCube -> Hist[h].Red
hiHist[hiCount].Green = InCube -> Hist[h].Green
hiHist[hiCount].Blue = InCube -> Hist[h].Blue
hiHist[hiCount].Count = InCube -> Hist[h].Count
hiCount += 1
Next h
Delete[] InCube -> Hist
Dim OutCube as XYZCube ptr = NEW XYZCube
InCube -> Hist = loHist
InCube -> HistCount = loLength
OutCube -> Hist = hiHist
OutCube -> HistCount = hiLength
XYZCube_minmax_Update(InCube)
XYZCube_minmax_Update(OutCube)
return OutCube
End Function
Sub ColorReduce15b(byref FBImage as any ptr)
'Imagecheck
Dim IsImage as Integer
Dim ImageWidth as Integer
Dim ImageHeight as Integer
Dim ImagePitch as Integer
Dim ImageRow as UInteger ptr
Dim Image as UInteger ptr
If (FBImage = 0) Then
Exit Sub
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then Exit Sub
ImagePitch \= 4
End If
Dim BaseHist as RGBHist ptr = NEW RGBHist[&h10000]
Dim Red as UByte
Dim Green as Ubyte
Dim Blue as Ubyte
Dim Index as UShort
Dim IndexCount as UShort
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
Red = lobyte(hiword(ImageRow[X]))
Green = hibyte(loword(ImageRow[X]))
Blue = lobyte(loword(ImageRow[X]))
Index = ((Red SHR 3) SHL 10) + ((Green SHR 3) SHL 5) + (Blue SHR 3)
With BaseHist[Index]
If (.Count = 0) Then
.Red = Red
.Green = Green
.Blue = Blue
.Count = 1
Else
.Red = (.Red + Red ) /2 '* 0.5
.Green = (.Green + Green) /2 '* 0.5
.Blue = (.Blue + Blue ) /2 '* 0.5
End If
End With
Next X
ImageRow += ImagePitch
Next Y
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
Red = lobyte(hiword(ImageRow[X]))
Green = hibyte(loword(ImageRow[X]))
Blue = lobyte(loword(ImageRow[X]))
Index = ((Red SHR 3) SHL 10) + ((Green SHR 3) SHL 5) + (Blue SHR 3)
ImageRow[X] = RGB(BaseHist[Index].Red, BaseHist[Index].Green, BaseHist[Index].Blue)
Next X
ImageRow += ImagePitch
Next Y
Delete[] BaseHist
End Sub
Sub ColorReduce (byref FBImage as any ptr, byval maxcolors as Integer=256)
'Imagecheck
Dim IsImage as Integer
Dim ImageWidth as Integer
Dim ImageHeight as Integer
Dim ImagePitch as Integer
Dim ImageRow as UInteger ptr
Dim Image as UInteger ptr
If (FBImage = 0) Then
exit sub
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then exit sub
ImageRow = Image
ImagePitch \= 4
End If
If (ColorCount24b(FBImage) < maxcolors) Then Exit Sub
ColorReduce15b(FBImage)
If (ColorCount24b(FBImage) < maxcolors) Then Exit Sub
Dim BaseHist as RGBHist ptr = NEW RGBHist[&h10000]
Dim rColor as UInteger
Dim Red as UByte
Dim Green as Ubyte
Dim Blue as Ubyte
Dim Index as Integer
Dim IndexCount as UShort
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
Red = lobyte(hiword(rColor))
Green = hibyte(loword(rColor))
Blue = lobyte(loword(rColor))
Index = ((Red SHR 3) SHL 10) + ((Green SHR 3) SHL 5) + (Blue SHR 3)
With BaseHist[Index]
If (.Count = 0) Then IndexCount += 1
.Red = Red
.Green = Green
.Blue = Blue
.Count += 1'IIF(.Count <= 10000, .Count + 1, .Count)
End With
Next X
ImageRow += ImagePitch
Next Y
Dim BaseCube as XYZCube ptr = NEW XYZCube
Dim CubeX as Single
Dim CubeY as Single
Dim CubeZ as Single
With BaseCube[0]
.Hist = NEW RGBHist[IndexCount]
Index = 0
Do
If (BaseHist[Index].Count) Then
.Hist[.HistCount].Red = BaseHist[Index].Red
.Hist[.HistCount].Green = BaseHist[Index].Green
.Hist[.HistCount].Blue = BaseHist[Index].Blue
.Hist[.HistCount].Count = BaseHist[Index].Count
.HistCount += 1
End If
Index += 1
Loop while .HistCount < IndexCount
End With
XYZCube_minmax_Update(BaseCube)
'-----------------------------------------------------------------------------------'
'Farbliste erstellen
Dim CubeList as XYZCube ptr ptr = callocate(maxcolors * SizeOf(Any ptr))
Dim CubeCount as Integer
CubeList[0] = BaseCube
CubeCount = 1
'----'
Dim CL as Integer 'CubeLength
Dim CF as Integer 'CubeFlag
Dim CC as Integer 'CubeCount
Dim CI as Integer 'CubeIndex
Do
'Finde Cube mit grösster RGBHist
CC = 0 : CI = 0 : CF = 0
For I as Integer = 0 To CubeCount-1
CL = CubeList[I] -> HistCount
If (CL > 2) and (CL > CC) Then
CC = CL
CI = I
CF = 1
End If
Next I
If (CF) Then
CubeList[CubeCount] = Split_XYZCube(CubeList[CI])
CubeCount += 1
End If
Loop until (CubeCount = maxcolors) or (CF = 0)
'
'-----------------------------------------------------------------------------------'
'-----------------------------------------------------------------------------------'
'Farben zuweisen
Index = 0
Dim as Single HX, HY, HZ
Dim as Single CX, CY, CZ
Dim as Single D , DC
Dim as Integer CR, CG, CB
Dim as Double RGBC
Do
If (BaseHist[Index].Count) Then
RGB_to_XYZ(BaseHist[Index].Red, BaseHist[Index].Green, BaseHist[Index].Blue, HX, HY, HZ)
D = 442
For C as Integer = 0 to CubeCount-1
CX = (CubeList[C] -> minX + CubeList[C] -> maxX) / 2
CY = (CubeList[C] -> minY + CubeList[C] -> maxY) / 2
CZ = (CubeList[C] -> minZ + CubeList[C] -> maxZ) / 2
DC = Distance3f(HX, HY, HZ, CX, CY, CZ)
If (DC < D) Then
D = DC
CI = C
End If
Next C
'Farbe bestimmen:
CX = (CubeList[CI] -> minX + CubeList[CI] -> maxX) / 2
CY = (CubeList[CI] -> minY + CubeList[CI] -> maxY) / 2
CZ = (CubeList[CI] -> minZ + CubeList[CI] -> maxZ) / 2
'L * = 116 * (Y / Yn) 1/3 - 16 für Y / Yn> 0,008856
'L * = 903,3 * Y / Yn sonst
'a * = 500 * (f (X / Xn) - f (Y / Yn))
'b * = 200 * (f (Y / Yn) - f (Z / Zn))
'wobei f (t) = t 1/3 für t> 0,008856
'f (t) = 7,787 * t + 16/116 anders
'If (CY/255 > 0.008856) Then
' L = 116 * (CY / 255)
'Else
' L = 903.3 * (CY / 255)
'End If
'a = 500 * ((CX/255)-(CY/255))
'b = 200 * ((CY/255)-(CZ/255)
CR = (CX * +3.240470) + (CY * -1.537150) + (CZ * -0.498535)
CG = (CX * -0.969256) + (CY * +1.875992) + (CZ * +0.041556)
CB = (CX * +0.055648) + (CY * -0.204043) + (CZ * +1.057311)
BaseHist[Index].Count = RGB(CR,CG,CB)
CR = 0 : CG = 0 : CB = 0 : CC = 0
For L as Integer = 0 to CubeList[CI] -> HistCount -1
If (CubeList[CI] -> Hist[L].Count > CC) Then
CR = CubeList[CI] -> Hist[L].Red
CG = CubeList[CI] -> Hist[L].Green
CB = CubeList[CI] -> Hist[L].Blue
CC = CubeList[CI] -> Hist[L].Count
End If
Next L
CR = (CR + lobyte(hiword(BaseHist[Index].Count)) + BaseHist[Index].Red ) / 3
CG = (CG + hibyte(loword(BaseHist[Index].Count)) + BaseHist[Index].Green) / 3
CB = (CB + lobyte(loword(BaseHist[Index].Count)) + BaseHist[Index].Blue ) / 3
CubeList[CI] -> CubeColor = RGB(CR,CG,CB)
BaseHist[Index].Count = CI
End If
Index += 1
Loop while (Index < &h10000)
'-----------------------------------------------------------------------------------'
'Neue Farben 'setzen'
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
Index = ((lobyte(hiword(ImageRow[X])) SHR 3) SHL 10) + ((hibyte(loword(ImageRow[X])) SHR 3) SHL 5) + (lobyte(loword(ImageRow[X])) SHR 3)
ImageRow[X] = CubeList[BaseHist[Index].Count] -> CubeColor
Next X
ImageRow += ImagePitch
Next Y
'-----------------------------------------------------------------------------------'
'Speicher freigeben
For C as Integer = 0 to CubeCount-1
Delete[] CubeList[C] -> Hist
Delete CubeList[C]
Next C
Deallocate CubeList
Delete[] BaseHist
End Sub
screen 19,32
Dim testimage as any ptr = imagecreate(800,600)
bload "test.bmp",testimage
ColorReduce(testimage,256)
Put (0,0),testimage,pset
bsave "testimage.bmp",testimage
sleep
Imagedestroy(testimage) |
| Zitat: |
Stimmt so auch nur bedingt, oft "verrechnet" sich das Programm bei Bildern, die bereits mit einem anderen Programm auf 256 Farben runtergerechnet wurden und reduziert diese dann auf noch weniger Farben, selbst wenn man 256 Farben auswählt. Hab auch schon einen Bugreport geschrieben aber seitdem hat sich nichts mehr daran getan... |
Ist mir ehrlich gesagt bisher noch gar nicht aufgefallen, allerdings habe ich so etwas in meinem neuen Versuch direkt mal eleminiert
| Zitat: |
Die wohl am besten unterstützte Truecolor-Alternative zu GIF ist momentan APNG, auch wenn da der Support noch zu wünschen übrig lässt. Ist aber immerhin weiter verbreitet als MNG... |
Ich glaube mit dem MNG hab ich mich mal oberflächlich auseinandergesetzt, das APNG werd ich mir aber auch mal richtig ansehen... jedoch wird ja auch das leider nicht voll unterstützt...
Beide sind enorm komplex in ihren Aufbau und internen Optionen, dagegen war das laden/speichern eines GIFs Echt mal entspannend
_________________
|
|
| Nach oben |
|
|
28398
Anmeldungsdatum: 25.04.2008
Beiträge: 1917
|
| Verfasst am: 22.07.2012, 15:44 Titel: |
|
|
Mit libpng müsste sich das doch recht einfach machen lassen...
/e: Schau dir einfach mal die zurechtgepatchte libpng vom Firefox an... |
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 24.07.2012, 14:52 Titel: |
|
|
11. Versuch (den 10. hab ich komplett versaut )
Besser krieg ichs ums verrecken nicht hin, vermute auch das
es ohne weitere Algos nicht viel besser geht...
Beispiel:
Links: Original | Mitte: Photofiltre (256 ohne Dithering) | Rechts: Mein Versuchsode (256)
| Code: |
#Define dE76(L1,a1,b1,L2,a2,b2) (sqr ( (abs(L1-L2)*abs(L1-L2)) + (abs(a1-a2)*abs(a1-a2)) + (abs(b1-b2)*abs(b1-b2)) ))
Sub RGB2Lab (byval Red as UByte, byval Green as UByte, byval Blue as Ubyte, byref LL as Double, byref aa as Double, byref bb as Double)
Dim as Double fx, fy, fz
Dim as Double xr, yr, zr
Dim as Double L_, a_, b_
Dim as Double R , G , B
Dim as Double X , Y , Z
Dim as Double T
T = 0.04045 'threshold
'RGB [1,0]
R = Red / 255
G = Green / 255
B = Blue / 255
'RGB to XYZ
R = IIF(R > T, ( (R + 0.055) / 1.055) ^ 2.4, R / 12.95)
G = IIF(G > T, ( (G + 0.055) / 1.055) ^ 2.4, G / 12.95)
B = IIF(B > T, ( (B + 0.055) / 1.055) ^ 2.4, B / 12.95)
X = (0.412453*R) + (0.357580*G) + (0.180423*B)
Y = (0.212671*R) + (0.715160*G) + (0.072169*B)
Z = (0.019334*R) + (0.119193*G) + (0.950227*B)
T = 0.008856 ' threshold
xr = X / 0.950456
yr = Y / 1.000000
zr = Z / 1.088754
'XYZ ro L*a*b*
fx = IIF( xr>T, ( xr^(1/3) ), ( (7.787 * xr) + (16 / 116) ) )
fy = IIF( yr>T, ( yr^(1/3) ), ( (7.787 * yr) + (16 / 116) ) )
fz = IIF( zr>T, ( zr^(1/3) ), ( (7.787 * zr) + (16 / 116) ) )
L_ = (116 * fy) - 16
a_ = 500 * (fx - fy)
b_ = 200 * (fy - fz)
LL = L_ : aa = a_ : bb = b_
End Sub
Type RGBIndex
DI as Integer
dE as Double
IU as Integer
End Type
Type RGBIndexHist
as Ubyte minR, maxR
as Ubyte minG, maxG
as Ubyte minB, maxB
Count as UInteger
End Type
Type RGBHistogram'Cube
as Ubyte minR, maxR
as Ubyte minG, maxG
as Ubyte minB, maxB
RGBList as RGBIndexHist ptr
HistLength as UInteger
RGBCount as UInteger
HistColor as UInteger
HistFlag as Integer
End Type
Function GetRGBHistogram(byval FBImage as any ptr) as RGBHistogram ptr
'Imagecheck
Dim as Integer IsImage , ImagePitch
Dim as Integer ImageWidth, ImageHeight
Dim as UInteger ptr Image , ImageRow
If (FBImage = 0) Then
return 0
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then return 0
ImagePitch \= 4
End If
Dim BaseHist as RGBHistogram ptr = NEW RGBHistogram
BaseHist -> RGBList = NEW RGBIndexHist[&h8000]
BaseHist -> HistLength = &h8000
Dim rColor as UInteger
Dim Index as Integer
Dim Red as UByte
Dim Green as Ubyte
Dim Blue as Ubyte
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
Red = lobyte(hiword(rColor))
Green = hibyte(loword(rColor))
Blue = lobyte(loword(rColor))
Index = ((Red SHR 3) SHL 10) + ((Green SHR 3) SHL 5) + (Blue SHR 3)
If (BaseHist -> RGBList[Index].Count) Then
If (Red < BaseHist -> RGBList[Index].minR) Then BaseHist -> RGBList[Index].minR = Red
If (Red > BaseHist -> RGBList[Index].maxR) Then BaseHist -> RGBList[Index].maxR = Red
If (Green < BaseHist -> RGBList[Index].minG) Then BaseHist -> RGBList[Index].minG = Green
If (Green > BaseHist -> RGBList[Index].maxG) Then BaseHist -> RGBList[Index].maxG = Green
If (Blue < BaseHist -> RGBList[Index].minB) Then BaseHist -> RGBList[Index].minB = Blue
If (Blue > BaseHist -> RGBList[Index].maxB) Then BaseHist -> RGBList[Index].maxB = Blue
Else
BaseHist -> RGBList[Index].minR = Red : BaseHist -> RGBList[Index].maxR = Red
BaseHist -> RGBList[Index].minG = Green : BaseHist -> RGBList[Index].maxG = Green
BaseHist -> RGBList[Index].minB = Blue : BaseHist -> RGBList[Index].maxB = Blue
End If
If (BaseHist -> RGBCount) Then
If (Red < BaseHist -> minR) Then BaseHist -> minR = Red
If (Red > BaseHist -> maxR) Then BaseHist -> maxR = Red
If (Green < BaseHist -> minG) Then BaseHist -> minG = Green
If (Green > BaseHist -> maxG) Then BaseHist -> maxG = Green
If (Blue < BaseHist -> minB) Then BaseHist -> minB = Blue
If (Blue > BaseHist -> maxB) Then BaseHist -> maxB = Blue
Else
BaseHist -> minR = Red : BaseHist -> maxR = Red
BaseHist -> minG = Green : BaseHist -> maxG = Green
BaseHist -> minB = Blue : BaseHist -> maxB = Blue
End If
BaseHist -> RGBList[Index].Count += 1
BaseHist -> RGBCount += 1
Next X
ImageRow += ImagePitch
Next Y
return BaseHist
End Function
Function SplitRGBHistogram (byref Hist as RGBHistogram ptr) as RGBHistogram ptr
Dim as Integer HistCenter
Dim as Integer ListCenter
Dim as Integer CenterRGB
Dim as Integer RGBCount
HistCenter = (Hist -> RGBCount \2)
For HL as Integer = 0 to Hist -> HistLength-1
RGBCount += Hist -> RGBList[HL].Count
If (RGBCount >= HistCenter) Then
ListCenter = HL
CenterRGB = RGBCount - HistCenter
Exit For
End If
Next HL
'ListCenter = Hist -> HistLength\2
Dim loHist as RGBHistogram ptr = NEW RGBHistogram
Dim as Integer loHistS = 0
Dim as Integer loHistE = IIF(Hist -> RGBList[ListCenter].Count - CenterRGB > 0, ListCenter, ListCenter-1)
If loHistE < 0 Then loHistE = 0
Dim as Integer loHistLength = (loHistE-loHistS)+1
Dim as Integer loHistCount = 0
loHist -> minR = 255 : loHist -> maxR = 0
loHist -> minG = 255 : loHist -> maxG = 0
loHist -> minB = 255 : loHist -> maxB = 0
loHist -> RGBList = NEW RGBIndexHist[loHistLength]
Dim hiHist as RGBHistogram ptr = NEW RGBHistogram
Dim as Integer hiHistS = IIF(Hist -> RGBList[ListCenter].Count - CenterRGB > 0, ListCenter, ListCenter+1)
Dim as Integer hiHistE = Hist -> HistLength-1
Dim as Integer hiHistLength = (hiHistE-hiHistS)+1
Dim as Integer hiHistCount = 0
hiHist -> minR = 255 : hiHist -> maxR = 0
hiHist -> minG = 255 : hiHist -> maxG = 0
hiHist -> minB = 255 : hiHist -> maxB = 0
hiHist -> RGBList = NEW RGBIndexHist[hiHistLength]
For lo as Integer = loHistS to loHistE
loHist -> RGBList[loHistCount].minR = Hist -> RGBList[lo].minR
loHist -> RGBList[loHistCount].maxR = Hist -> RGBList[lo].maxR
loHist -> RGBList[loHistCount].minG = Hist -> RGBList[lo].minG
loHist -> RGBList[loHistCount].maxG = Hist -> RGBList[lo].maxG
loHist -> RGBList[loHistCount].minB = Hist -> RGBList[lo].minB
loHist -> RGBList[loHistCount].maxB = Hist -> RGBList[lo].maxB
If (loHist -> RGBList[loHistCount].minR < loHist -> minR) Then loHist -> minR = loHist -> RGBList[loHistCount].minR
If (loHist -> RGBList[loHistCount].maxR > loHist -> maxR) Then loHist -> maxR = loHist -> RGBList[loHistCount].maxR
If (loHist -> RGBList[loHistCount].minG < loHist -> minG) Then loHist -> minG = loHist -> RGBList[loHistCount].minG
If (loHist -> RGBList[loHistCount].maxG > loHist -> maxG) Then loHist -> maxG = loHist -> RGBList[loHistCount].maxG
If (loHist -> RGBList[loHistCount].minB < loHist -> minB) Then loHist -> minB = loHist -> RGBList[loHistCount].minB
If (loHist -> RGBList[loHistCount].maxB > loHist -> maxB) Then loHist -> maxB = loHist -> RGBList[loHistCount].maxB
''
If (lo <> ListCenter) Then
loHist -> RGBList[loHistCount].Count = Hist -> RGBList[lo].Count
loHist -> RGBCount += Hist -> RGBList[lo].Count
Else
loHist -> RGBList[loHistCount].Count = Hist -> RGBList[lo].Count - CenterRGB
loHist -> RGBCount += Hist -> RGBList[lo].Count - CenterRGB
Hist -> RGBList[ListCenter].Count = CenterRGB
End If
loHistCount += 1
Next lo
loHist -> HistLength = loHistCount
For hi as Integer = hiHistS to hiHistE
hiHist -> RGBList[hiHistCount].minR = Hist -> RGBList[hi].minR
hiHist -> RGBList[hiHistCount].maxR = Hist -> RGBList[hi].maxR
hiHist -> RGBList[hiHistCount].minG = Hist -> RGBList[hi].minG
hiHist -> RGBList[hiHistCount].maxG = Hist -> RGBList[hi].maxG
hiHist -> RGBList[hiHistCount].minB = Hist -> RGBList[hi].minB
hiHist -> RGBList[hiHistCount].maxB = Hist -> RGBList[hi].maxB
If (hiHist -> RGBList[hiHistCount].minR < hiHist -> minR) Then hiHist -> minR = hiHist -> RGBList[hiHistCount].minR
If (hiHist -> RGBList[hiHistCount].maxR > hiHist -> maxR) Then hiHist -> maxR = hiHist -> RGBList[hiHistCount].maxR
If (hiHist -> RGBList[hiHistCount].minG < hiHist -> minG) Then hiHist -> minG = hiHist -> RGBList[hiHistCount].minG
If (hiHist -> RGBList[hiHistCount].maxG > hiHist -> maxG) Then hiHist -> maxG = hiHist -> RGBList[hiHistCount].maxG
If (hiHist -> RGBList[hiHistCount].minB < hiHist -> minB) Then hiHist -> minB = hiHist -> RGBList[hiHistCount].minB
If (hiHist -> RGBList[hiHistCount].maxB > hiHist -> maxB) Then hiHist -> maxB = hiHist -> RGBList[hiHistCount].maxB
''
hiHist -> RGBList[hiHistCount].Count = Hist -> RGBList[hi].Count
hiHist -> RGBCount += Hist -> RGBList[hi].Count
hiHistCount += 1
Next hi
hiHist -> HistLength = hiHistCount
Delete[] Hist -> RGBList
Delete Hist
Hist = hiHist
return loHist
End Function
Sub QSortRGBHist (byref RGBList as RGBIndexHist ptr, byval lo as Integer, byval hi as Integer, SortType as byte)
Dim i as Integer = lo
Dim j as Integer = hi
Dim X as UByte
X = IIF(SortType = 0, (RGBList[(lo+hi)\2].minR+RGBList[(lo+hi)\2].maxR)\2, IIF(SortType = 1, (RGBList[(lo+hi)\2].minG+RGBList[(lo+hi)\2].maxG)\2, (RGBList[(lo+hi)\2].minB+RGBList[(lo+hi)\2].maxB)\2) )
Do
While IIF(SortType = 0, (RGBList[i].minR+RGBList[i].maxR)\2, IIF(SortType = 1, (RGBList[i].minG+RGBList[i].maxG)\2, (RGBList[i].minB+RGBList[i].maxB)\2)) < X
i += 1
Wend
While X < IIF(SortType = 0, (RGBList[j].minR+RGBList[j].maxR)\2, IIF(SortType = 1, (RGBList[j].minG+RGBList[j].maxG)\2, (RGBList[j].minB+RGBList[j].maxB)\2))
j -= 1
Wend
If (i <= j) Then
swap RGBList[i].minR , RGBList[j].minR
swap RGBList[i].maxR , RGBList[j].maxR
swap RGBList[i].minG , RGBList[j].minG
swap RGBList[i].maxG , RGBList[j].maxG
swap RGBList[i].minB , RGBList[j].minB
swap RGBList[i].maxB , RGBList[j].maxB
swap RGBList[i].Count, RGBList[j].Count
i += 1
j -= 1
End If
Loop Until (i > j)
If (lo < j ) Then QSortRGBHist(RGBList, lo, j , SortType)
If (i < hi) Then QSortRGBHist(RGBList, i , hi, SortType)
End Sub
Sub SortRGBHistogram (byref Hist as RGBHistogram ptr)
Dim SortType as Integer
Dim as UByte DR, DG, DB
DR = Hist -> maxR - Hist -> minR
DG = Hist -> maxG - Hist -> minG
DB = Hist -> maxB - Hist -> minB
'SortType = IIF(DG > DR, IIF(DG > DB, 1, IIF(DB > DR, 2, 0)), IIF(DR > DB, 0, 2))
SortType = IIF(DR > DG, IIF(DR > DB, 0, IIF(DB > DG, 2, 1)), IIF(DG > DB, 1, 2))
QSortRGBHist(Hist -> RGBList, 0, Hist -> HistLength-1, SortType)
End Sub
Sub ColorReduce(byref FBImage as any ptr, byval maxcolors as Integer=256)
Dim BaseHist as RGBHistogram ptr
BaseHist = GetRGBHistogram(FBImage)
If (BaseHist = 0) Then Exit Sub
Dim HistList as RGBHistogram ptr ptr = allocate(maxcolors * SizeOf(any ptr))
Dim HistCount as Integer
Dim CountSize as Integer
For RC as Integer = 0 to BaseHist -> HistLength-1
If (BaseHist -> RGBList[RC].Count) Then CountSize += 1
Next RC
HistList[0] = NEW RGBHistogram
HistList[0] -> RGBList = NEW RGBIndexHist[CountSize]
HistList[0] -> HistLength = CountSize
HistList[0] -> RGBCount = BaseHist -> RGBCount
HistList[0] -> minR = BaseHist -> minR
HistList[0] -> maxR = BaseHist -> maxR
HistList[0] -> minG = BaseHist -> minG
HistList[0] -> maxG = BaseHist -> maxG
HistList[0] -> minB = BaseHist -> minB
HistList[0] -> maxB = BaseHist -> maxB
CountSize = 0
For RC as Integer = 0 to BaseHist -> HistLength-1
If (BaseHist -> RGBList[RC].Count) Then
HistList[0] -> RGBList[CountSize].Count = BaseHist -> RGBList[RC].Count
HistList[0] -> RGBList[CountSize].minR = BaseHist -> RGBList[RC].minR
HistList[0] -> RGBList[CountSize].maxR = BaseHist -> RGBList[RC].maxR
HistList[0] -> RGBList[CountSize].minG = BaseHist -> RGBList[RC].minG
HistList[0] -> RGBList[CountSize].maxG = BaseHist -> RGBList[RC].maxG
HistList[0] -> RGBList[CountSize].minB = BaseHist -> RGBList[RC].minB
HistList[0] -> RGBList[CountSize].maxB = BaseHist -> RGBList[RC].maxB
CountSize += 1
End If
Next RC
HistCount = 1
Dim STH as Integer
Dim THC as Integer
Dim SHF as Integer
Do
STH = 0 : THC = 0 : SHF = 1
Dim as UByte rDif, gDif, bDif, cDif
For SGH as Integer = 0 to HistCount-1
rDif = HistList[SGH] -> maxR - HistList[SGH] -> minR
gDif = HistList[SGH] -> maxG - HistList[SGH] -> minG
bDif = HistList[SGH] -> maxB - HistList[SGH] -> minB
cDif = IIF(gDif > rDif, IIF(gDif > bDif, gDif, IIF(bDif > rDif, bDif, rDif)), IIF(rDif > bDif, rDif, bDif))
'cDif = IIF(rDif >= gDif, IIF(gDif >= bDif, rDif, bDif), IIF(gDif >= bDif, gDif, bDif))
If (cDif > THC) and (HistList[SGH] -> HistLength > 2) and (HistList[SGH] -> RGBCount > 2) Then '(HistList[SGH] -> RGBCount > 2) Then' and (THC < HistList[SGH] -> RGBCount) Then
THC = cDif'HistList[SGH] -> RGBCount
STH = SGH
SHF = 1
End If
Next SGH
If SHF=0 Then Exit Do
SortRGBHistogram(HistList[STH])
HistList[HistCount] = SplitRGBHistogram(HistList[STH])
HistCount += 1
Loop while (HistCount < maxcolors)
Dim as Integer Red, Green, Blue
For HL as Integer = 0 to HistCount-1
Red = 0 : Green = 0 : Blue = 0
For HLL as Integer = 0 to HistList[HL] -> HistLength-1
Red += ((HistList[HL] -> RGBList[HLL].minR + HistList[HL] -> RGBList[HLL].maxR) / 2) * HistList[HL] -> RGBList[HLL].Count
Green += ((HistList[HL] -> RGBList[HLL].minG + HistList[HL] -> RGBList[HLL].maxG) / 2) * HistList[HL] -> RGBList[HLL].Count
Blue += ((HistList[HL] -> RGBList[HLL].minB + HistList[HL] -> RGBList[HLL].maxB) / 2) * HistList[HL] -> RGBList[HLL].Count
Next HLL
Red = Red \ HistList[HL] -> RGBCount
Green = Green \ HistList[HL] -> RGBCount
Blue = Blue \ HistList[HL] -> RGBCount
HistList[HL] -> HistColor = RGB(Red,Green,Blue)
Next HL
' Exit Sub
Dim as Double L1, a1, b1_
Dim as Double L2, a2, b2_
Dim as Double R1, G1, B1
Dim as Double R2, G2, B2
Dim as Double DLabC, DLab
Dim as Double DRGBC, DRGB
Dim as Integer DI
Dim IndexColor as RGBIndex ptr = NEW RGBIndex[&h8000]
For BHC as Integer = 0 to BaseHist -> HistLength-1
If (BaseHist -> RGBList[BHC].Count) Then
RGB2Lab ( (BaseHist -> RGBList[BHC].minR+BaseHist -> RGBList[BHC].maxR)\2, _
(BaseHist -> RGBList[BHC].minG+BaseHist -> RGBList[BHC].maxG)\2, _
(BaseHist -> RGBList[BHC].minB+BaseHist -> RGBList[BHC].maxB)\2, _
L1, a1, b1_ )
R1 = (BaseHist -> RGBList[BHC].minR+BaseHist -> RGBList[BHC].maxR)\2
G1 = (BaseHist -> RGBList[BHC].minG+BaseHist -> RGBList[BHC].maxG)\2
B1 = (BaseHist -> RGBList[BHC].minB+BaseHist -> RGBList[BHC].maxB)\2
DLabC = 99.99 : DRGBC = 99.99
For LHC as Integer = 0 to HistCount-1
RGB2Lab( lobyte(hiword(HistList[LHC] -> HistColor)), _
hibyte(loword(HistList[LHC] -> HistColor)), _
lobyte(loword(HistList[LHC] -> HistColor)), _
L2, a2, b2_ )
R2 = lobyte(hiword(HistList[LHC] -> HistColor))
G2 = hibyte(loword(HistList[LHC] -> HistColor))
B2 = lobyte(loword(HistList[LHC] -> HistColor))
DLab = dE76(L1,a1,b1_,L2,a2,b2_)
DRGB = dE76(R1,G1,B1,R2,G2,B2)
If (DLab < DLabC+3.15) and (DRGB < DRGBC+11.5) Then
If DLab < DLabC Then DLabC = DLab
If DRGB < DRGBC Then DRGBC = DRGB
DI = LHC
End If
Next LHC
IndexColor[BHC].DI = DI
IndexColor[BHC].dE = DRGBC
IndexColor[BHC].IU = 1
HistList[DI] -> HistFlag += 1
End If
Next BHC
/'
Dim MU as Integer
Dim MC as Integer
Dim BigDE as Integer
Dim CDE as Double
Do
CDE = 0 : BigDE = 0
For CC as Integer = 0 to &h7FFF
If (IndexColor[CC].dE > CDE) Then
CDE = IndexColor[CC].dE
BigDE = CC
End If
Next CC
'?CDE
'If (BigDE > 8.5) Then
MU = -1 : MC = &HFFFFFF
For HL as Integer = 0 to HistCount-1
If (HistList[HL] -> HistFlag = 0) Then' MC) and (HistList[HL] -> HistFlag < 10) Then
MC = HistList[HL] -> HistFlag
MU = HL
Exit For
End If
Next HL
If MU = -1 Then Exit Do
'If (MC>0) Then
'Red = (lobyte(hiword(HistList[MU] -> HistColor)) + BaseHist -> RGBList[CC].minR + BaseHist -> RGBList[CC].maxR)/3 '*BaseHist -> RGBList[CC].Count)\(MC+BaseHist -> RGBList[CC].Count)
'Green = (hibyte(loword(HistList[MU] -> HistColor)) + BaseHist -> RGBList[CC].minG + BaseHist -> RGBList[CC].maxG)/3 '*BaseHist -> RGBList[CC].Count)\(MC+BaseHist -> RGBList[CC].Count)
'Blue = (lobyte(loword(HistList[MU] -> HistColor)) + BaseHist -> RGBList[CC].minB + BaseHist -> RGBList[CC].maxB)/3 '*BaseHist -> RGBList[CC].Count)\(MC+BaseHist -> RGBList[CC].Count)
'Red = lobyte(hiword(HistList[MU] -> HistColor)) '* HistList[MU] -> HistFlag
'Red += ((BaseHist -> RGBList[CC].minR + BaseHist -> RGBList[CC].maxR)\2)' \ BaseHist -> RGBList[CC].Count
'Red \= 2'(HistList[MU] -> HistFlag + BaseHist -> RGBList[CC].Count)
'Red = IIF(Red < 0, 0, IIF(Red > 255, 255, Red))
'Green = hibyte(loword(HistList[MU] -> HistColor)) '* HistList[MU] -> HistFlag
'Green += ((BaseHist -> RGBList[CC].minG + BaseHist -> RGBList[CC].maxG)\2)' \ BaseHist -> RGBList[CC].Count
'Green \= 2'(HistList[MU] -> HistFlag + BaseHist -> RGBList[CC].Count)
'Green = IIF(Green < 0, 0, IIF(Green > 255, 255, Green))
'Blue = lobyte(loword(HistList[MU] -> HistColor)) '* HistList[MU] -> HistFlag
'Blue += ((BaseHist -> RGBList[CC].minB + BaseHist -> RGBList[CC].maxB)\2)' \ BaseHist -> RGBList[CC].Count
'Blue \= 2'(HistList[MU] -> HistFlag + BaseHist -> RGBList[CC].Count)
'Blue = IIF(Blue < 0, 0, IIF(Blue > 255, 255, Blue))
'Else
Red = ((BaseHist -> RGBList[BigDE].minR + BaseHist -> RGBList[BigDE].maxR)\2)'\BaseHist -> RGBList[CC].Count
Green = ((BaseHist -> RGBList[BigDE].minG + BaseHist -> RGBList[BigDE].maxG)\2)'\BaseHist -> RGBList[CC].Count
Blue = ((BaseHist -> RGBList[BigDE].minB + BaseHist -> RGBList[BigDE].maxB)\2)'\BaseHist -> RGBList[CC].Count
HistList[MU] -> HistColor = RGB(Red,Green,Blue)
HistList[MU] -> HistFlag += 1
IndexColor[BigDE].DI = MU
IndexColor[BigDE].dE = 0
'End If
Loop
'/
'Imagecheck
Dim as Integer ImagePitch, ImageWidth, ImageHeight
Dim as UInteger ptr Image , ImageRow
Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
ImagePitch \= 4
Dim rColor as UInteger
Dim Index as Integer
Dim IRed as UByte
Dim IGreen as Ubyte
Dim IBlue as Ubyte
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
IRed = lobyte(hiword(rColor))
IGreen = hibyte(loword(rColor))
IBlue = lobyte(loword(rColor))
Index = ((IRed SHR 3) SHL 10) + ((IGreen SHR 3) SHL 5) + (IBlue SHR 3)
ImageRow[X] = HistList[IndexColor[Index].DI] -> HistColor' -> RGBList[Index].Count] -> HistColor
Next X
ImageRow += ImagePitch
Next Y
'freemen ToDo
End Sub
Screen 19,32
Dim testimage as any ptr = imagecreate(800,600)
bload "test.bmp",testimage
ColorReduce(testimage,256)
Put (0,0),testimage,pset
bsave "testimage.bmp",testimage
sleep
imagedestroy(testimage)
|
_________________
|
|
| Nach oben |
|
|
Eternal_pain
Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA
|
| Verfasst am: 25.07.2012, 12:43 Titel: |
|
|
Habe Dithering nie in betracht gezogen, jedoch gingen mir die Ideen aus das ganze noch zu Optimieren, hab nun ein Floyd-Steinberg-Dithering mit drin, das ergebnis ist gut, werd evtl noch einen anderen Farbraum versuchen, aber nun klappt alles ganz gut....
Edit: Etwas Optimiert...
Im Vergleich mit Photofiltre sind die Ergebnisse immernoch minimal voneinander abweichend, jedoch sehr gering (mir tun schon die Augen vom vielen Bilder vergleichen weh )
Fröhliches Farben reduzieren
Versuch13.bas
| Code: |
#Define delta(RXL1,GYa1,BZb1,RXL2,GYa2,BZb2) (sqr ( (abs(RXL1-RXL2)*abs(RXL1-RXL2)) + (abs(GYa1-GYa2)*abs(GYa1-GYa2)) + (abs(BZb1-BZb2)*abs(BZb1-BZb2)) ))
Type RGBCluster
as UByte R
as UByte G
as UByte B
Count as Integer
End Type
Type RGBClusterList
List as RGBCluster ptr
Count as Integer
End Type
Type RGBCube
as UByte minR, maxR, medR
as UByte minG, maxG, medG
as UByte minB, maxB, medB
ClusterList as RGBClusterList ptr
ClusterSize as Integer
End Type
Sub MinMaxCubeUpdate(byref Cube as RGBCube ptr)
If (Cube = 0) Then Exit Sub
Dim as UByte minR = 255, maxR = 0
Dim as UByte minG = 255, maxG = 0
Dim as UByte minB = 255, maxB = 0
Dim as Integer wgtR, wgtG, wgtB
Dim as Integer wgtP
For CCL as Integer = 0 to Cube -> ClusterList -> Count-1
If (Cube -> ClusterList -> List[CCL].R < minR) Then minR = Cube -> ClusterList -> List[CCL].R
If (Cube -> ClusterList -> List[CCL].R > maxR) Then maxR = Cube -> ClusterList -> List[CCL].R
If (Cube -> ClusterList -> List[CCL].G < minG) Then minG = Cube -> ClusterList -> List[CCL].G
If (Cube -> ClusterList -> List[CCL].G > maxG) Then maxG = Cube -> ClusterList -> List[CCL].G
If (Cube -> ClusterList -> List[CCL].B < minB) Then minB = Cube -> ClusterList -> List[CCL].B
If (Cube -> ClusterList -> List[CCL].B > maxB) Then maxB = Cube -> ClusterList -> List[CCL].B
wgtR += Cube -> ClusterList -> List[CCL].R * Cube -> ClusterList -> List[CCL].Count
wgtG += Cube -> ClusterList -> List[CCL].G * Cube -> ClusterList -> List[CCL].Count
wgtB += Cube -> ClusterList -> List[CCL].B * Cube -> ClusterList -> List[CCL].Count
wgtP += Cube -> ClusterList -> List[CCL].Count
Next CCL
wgtR = wgtR / wgtP
wgtG = wgtG / wgtP
wgtB = wgtB / wgtP
Cube -> minR = minR : Cube -> maxR = maxR : Cube -> medR = wgtR
Cube -> minG = minG : Cube -> maxG = maxG : Cube -> medG = wgtG
Cube -> minB = minB : Cube -> maxB = maxB : Cube -> medB = wgtB
End Sub
Sub QSortRGBCluster (byref ClusterList as RGBCluster ptr, byval lo as Integer, byval hi as Integer, SortType as byte)
Dim i as Integer = lo
Dim j as Integer = hi
Dim X as Single
X = IIF(SortType = 0, ClusterList[(lo+hi)\2].R, IIF(SortType = 1, ClusterList[(lo+hi)\2].G, ClusterList[(lo+hi)\2].B) )
Do
While IIF(SortType = 0, ClusterList[i].R, IIF(SortType = 1, ClusterList[i].G, ClusterList[i].B) ) < X
i += 1
Wend
While X < IIF(SortType = 0, ClusterList[j].R, IIF(SortType = 1, ClusterList[j].G, ClusterList[j].B) )
j -= 1
Wend
If (i <= j) Then
swap ClusterList[i].R , ClusterList[j].R
swap ClusterList[i].G , ClusterList[j].G
swap ClusterList[i].B , ClusterList[j].B
swap ClusterList[i].Count, ClusterList[j].Count
i += 1
j -= 1
End If
Loop Until (i > j)
If (lo < j ) Then QSortRGBCluster(ClusterList, lo, j , SortType)
If (i < hi) Then QSortRGBCluster(ClusterList, i , hi, SortType)
End Sub
Function SplitRGBClusterList(byref ClusterList as RGBClusterList ptr) as RGBClusterList ptr
Dim ClusterListCenter as Integer
Dim ClusterListEntrys as Integer
Dim EntryCenter as Integer
If (ClusterList = 0) Then return 0
'Step(1)
'gezählte Einträge in Liste ermitteln
For CL as Integer = 0 to ClusterList -> Count-1
ClusterListEntrys += ClusterList -> List[CL].Count
Next CL
If (ClusterListEntrys < 2) Then return 0
EntryCenter = ClusterListEntrys\2
'Step(2)
'finde eintrag der ermittelte Eintragsmitte 'kreuzt'
For CL as Integer = 0 to ClusterList -> Count-1
EntryCenter -= ClusterList -> List[CL].Count
If (EntryCenter <= 0) Then
ClusterListCenter = CL
Exit For
End If
Next CL
'Step(3)
'Zwei (halbe) Listen erstellen
Dim loClusterS as Integer = 0
Dim loClusterE as Integer = ClusterListCenter
Dim loClusterSize as Integer = (loClusterE-loClusterS)+1
Dim loClusterList as RGBClusterList ptr = NEW RGBClusterList
loClusterList -> List = NEW RGBCluster[loClusterSize]
Dim hiClusterS as Integer = IIF(EntryCenter = 0, ClusterListCenter+1, ClusterListCenter)
Dim hiClusterE as Integer = ClusterList -> Count-1
Dim hiClusterSize as Integer = (hiClusterE-hiClusterS)+1
Dim hiClusterList as RGBClusterList ptr = NEW RGBClusterList
hiClusterList -> List = NEW RGBCluster[hiClusterSize]
For lo as Integer = loClusterS to loClusterE
loClusterList -> List[loClusterList -> Count].R = ClusterList -> List[lo].R
loClusterList -> List[loClusterList -> Count].G = ClusterList -> List[lo].G
loClusterList -> List[loClusterList -> Count].B = ClusterList -> List[lo].B
If (lo <> ClusterListCenter) Then
loClusterList -> List[loClusterList -> Count].Count = ClusterList -> List[lo].Count
Else
loClusterList -> List[loClusterList -> Count].Count = ClusterList -> List[lo].Count+EntryCenter
ClusterList -> List[lo].Count -= loClusterList -> List[loClusterList -> Count].Count
End If
loClusterList -> Count += 1
Next lo
For hi as Integer = hiClusterS to hiClusterE
hiClusterList -> List[hiClusterList -> Count].R = ClusterList -> List[hi].R
hiClusterList -> List[hiClusterList -> Count].G = ClusterList -> List[hi].G
hiClusterList -> List[hiClusterList -> Count].B = ClusterList -> List[hi].B
hiClusterList -> List[hiClusterList -> Count].Count = ClusterList -> List[hi].Count
hiClusterList -> Count += 1
Next hi
'Step(4)
'neue liste(lo) zuweisen und liste(hi) ausgeben
Delete[] ClusterList -> List
ClusterList = loClusterList
return hiClusterList
End Function
Function ColorReduce (byref FBImage as any ptr, byval maxcolors as Integer=256, byval Dithering as Integer=1) as Integer
'Imagecheck
Dim as Integer IsImage , ImagePitch
Dim as Integer ImageWidth, ImageHeight
Dim as UInteger ptr Image , ImageRow
If (FBImage = 0) Then
return 0
Else
IsImage = Imageinfo (FBImage, ImageWidth, ImageHeight, ,ImagePitch, Image)
If (IsImage <> 0) Then return 0
ImagePitch \= 4
End If
'Step(1)
Dim BaseClusterList as RGBClusterList ptr = NEW RGBClusterList
BaseClusterList -> List = NEW RGBCluster[&h8000]
BaseClusterList -> Count = &h8000 'using a 15bit Index
Dim BaseClusterCount as Integer
Dim rColor as UInteger
Dim Index as Integer
Dim Red as UByte
Dim Green as Ubyte
Dim Blue as Ubyte
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
Red = lobyte(hiword(rColor))' shr 3
Green = hibyte(loword(rColor))' shr 3
Blue = lobyte(loword(rColor))' shr 3
'Index = ((Red shr 3) shl 10) + ((Green shr 3) shl 5) + (Blue shr 3)
Index = ((Red shr 3) shl 10) + ((Green shr 4) shl 6) + (Blue shr 2)
If (BaseClusterList -> List[Index].Count = 0) Then
BaseClusterCount += 1
BaseClusterList -> List[Index].R = Red
BaseClusterList -> List[Index].G = Green
BaseClusterList -> List[Index].B = Blue
Else
BaseClusterList -> List[Index].R = (Red + BaseClusterList -> List[Index].R)/2
BaseClusterList -> List[Index].G = (Green + BaseClusterList -> List[Index].G)/2
BaseClusterList -> List[Index].B = (Blue + BaseClusterList -> List[Index].B)/2
End If
BaseClusterList -> List[Index].Count += 1
Next X
ImageRow += ImagePitch
Next Y
'Step(2)
Dim CubeList as RGBCube ptr ptr = allocate(maxcolors * SizeOf(any ptr))
Dim CubeCount as Integer
Dim CubeClusterCount as Integer
CubeList[0] = NEW RGBCube
CubeList[0] -> ClusterList = NEW RGBClusterList
CubeList[0] -> ClusterList -> List = NEW RGBCluster[BaseClusterCount]
For BCL as Integer = 0 to BaseClusterList -> Count -1
If (BaseClusterList -> List[BCL].Count) Then
CubeList[0] -> ClusterList -> List[CubeClusterCount].R = BaseClusterList -> List[BCL].R
CubeList[0] -> ClusterList -> List[CubeClusterCount].G = BaseClusterList -> List[BCL].G
CubeList[0] -> ClusterList -> List[CubeClusterCount].B = BaseClusterList -> List[BCL].B
CubeList[0] -> ClusterList -> List[CubeClusterCount].Count = BaseClusterList -> List[BCL].Count
CubeClusterCount += 1
If (CubeClusterCount = BaseClusterCount) Then Exit For
End If
Next BCL
CubeList[0] -> ClusterList -> Count = CubeClusterCount
MinMaxCubeUpdate(CubeList[0])
CubeCount = 1
'Step(3)
Dim DDist as Integer
Dim RDist as Integer
Dim GDist as Integer
Dim BDist as Integer
Dim CDist as Integer
Dim CubeP as Integer
Dim CubeID as Integer
Dim NewCubeList as RGBClusterList ptr
Do
CDist = 0 : NewCubeList = 0
For CC as Integer = 0 to CubeCount-1
RDist = CubeList[CC] -> maxR - CubeList[CC] -> minR
GDist = CubeList[CC] -> maxG - CubeList[CC] -> minG
BDist = CubeList[CC] -> maxB - CubeList[CC] -> minB
DDist = IIF(RDist > GDist, IIF(RDist > BDist, RDist, IIF(BDist >= GDist, BDist, GDist)), IIF(GDist < BDist, BDist, GDist))
If (DDist > CDist) Then
CubeP = 0
For LC as Integer = 0 to CubeList[CC] -> ClusterList -> Count-1
CubeP += CubeList[CC] -> ClusterList -> List[LC].Count
Next LC
If (CubeP > 2) Then
CDist = DDist
CubeID = CC
End If
End If
Next CC
'---------'
RDist = CubeList[CubeID] -> maxR - CubeList[CubeID] -> minR
GDist = CubeList[CubeID] -> maxG - CubeList[CubeID] -> minG
BDist = CubeList[CubeID] -> maxB - CubeList[CubeID] -> minB
DDist = IIF(RDist > GDist, IIF(RDist > BDist, 0, IIF(BDist >= GDist, 2, 1)), IIF(GDist < BDist, 2, 1))
QSortRGBCluster (CubeList[CubeID] -> ClusterList -> List, 0, CubeList[CubeID] -> ClusterList -> Count-1, DDist)
NewCubeList = SplitRGBClusterList (CubeList[CubeID] -> ClusterList)
If (NewCubeList) Then
CubeList[CubeCount] = NEW RGBCube
CubeList[CubeCount] -> ClusterList = NewCubeList
MinMaxCubeUpdate(CubeList[CubeID] )
MinMaxCubeUpdate(CubeList[CubeCount])
CubeCount += 1
Else
Exit Do
End If
Loop while (CubeCount < maxcolors)
'Step(4)
Dim as Ubyte BaseR, BaseG, BaseB
Dim as UByte CubeR, CubeG, CubeB
Dim as Double dRGBC, dRGB
For BCL as Integer = 0 to &h7FFF
If (BaseClusterList -> List[BCL].Count) Then
BaseR = BaseClusterList -> List[BCL].R
BaseG = BaseClusterList -> List[BCL].G
BaseB = BaseClusterList -> List[BCL].B
dRGBC = 500
For CL as Integer = 0 to CubeCount-1
CubeR = CubeList[CL] -> medR
CubeG = CubeList[CL] -> medG
CubeB = CubeList[CL] -> medB
dRGB = delta(BaseR, BaseG, BaseB, CubeR, CubeG, CubeB)
If (dRGB < dRGBC) Then
CubeID = CL
dRGBC = dRGB
End If
Next CL
BaseClusterList -> List[BCL].R = CubeList[CubeID] -> medR
BaseClusterList -> List[BCL].G = CubeList[CubeID] -> medG
BaseClusterList -> List[BCL].B = CubeList[CubeID] -> medB
End If
Next BCL
Dim RError as Single
Dim GError as Single
Dim BError as Single
Dim WRed as Integer
Dim WGreen as Integer
Dim WBlue as Integer
ImageRow = Image
For Y as Integer = 0 to ImageHeight-1
For X as Integer = 0 to ImageWidth-1
rColor = ImageRow[X]
WRed = lobyte(hiword(rColor))
WGreen = hibyte(loword(rColor))
WBlue = lobyte(loword(rColor))
'Index = ((WRed shr 3) shl 10) + ((WGreen shr 3) shl 5) + (WBlue shr 3)
Index = ((WRed shr 3) shl 10) + ((WGreen shr 4) shl 6) + (WBlue shr 2)
If (BaseClusterList -> List[Index].Count) Then
ImageRow[X] = RGB(BaseClusterList -> List[Index].R,BaseClusterList -> List[Index].G,BaseClusterList -> List[Index].B)
Else
dRGBC = 500
For CL as Integer = 0 to CubeCount-1
CubeR = CubeList[CL] -> medR
CubeG = CubeList[CL] -> medG
CubeB = CubeList[CL] -> medB
dRGB = delta(WRed, WGreen, WBlue, CubeR, CubeG, CubeB)
If (dRGB < dRGBC) Then
CubeID = CL
dRGBC = dRGB
End If
Next CL
BaseClusterList -> List[Index].R = CubeList[CubeID] -> medR
BaseClusterList -> List[Index].G = CubeList[CubeID] -> medG
BaseClusterList -> List[Index].B = CubeList[CubeID] -> medB
BaseClusterList -> List[Index].Count = 1
ImageRow[X] = RGB(BaseClusterList -> List[Index].R,BaseClusterList -> List[Index].G,BaseClusterList -> List[Index].B)
End If
If (Dithering) Then
RError = abs(WRed - BaseClusterList -> List[Index].R)
GError = abs(WGreen - BaseClusterList -> List[Index].G)
BError = abs(WBlue - BaseClusterList -> List[Index].B)
RError = IIF(RError < 128, 0, maxcolors-1)
GError = IIF(GError < 128, 0, maxcolors-1)
BError = IIF(BError < 128, 0, maxcolors-1)
If (X < (ImageWidth-1)) Then 'X+1 7/16
rColor = ImageRow[X+1]
WRed = lobyte(hiWord(rColor)) + (7 * RError / 16)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (7 * GError / 16)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (7 * BError / 16)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X+1] = RGB(WRed,WGreen,WBlue)
End If
If (X < (ImageWidth-1)) and (Y < (ImageHeight-1)) Then 'X+1,Y+1 1/16
rColor = ImageRow[X+1 + ImagePitch]
WRed = lobyte(hiWord(rColor)) + (1 * RError / 16)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (1 * GError / 16)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (1 * BError / 16)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X+1 + ImagePitch] = RGB(WRed,WGreen,WBlue)
End If
If (Y < (ImageHeight-1)) Then 'Y+1 5/16
rColor = ImageRow[X + ImagePitch]
WRed = lobyte(hiWord(rColor)) + (5 * RError / 16)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (5 * GError / 16)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (5 * BError / 16)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X + ImagePitch] = RGB(WRed,WGreen,WBlue)
End If
If (X > 0) and (Y < (ImageHeight-1)) Then 'X-1,Y+1 3/16
rColor = ImageRow[X + ImagePitch -1]
WRed = lobyte(hiWord(rColor)) + (3 * RError / 16)
WRed = IIF(WRed < 0, 0, IIF(WRed > 255, 255, WRed ))
WGreen = hibyte(loWord(rColor)) + (3 * GError / 16)
WGreen = IIF(WGreen < 0, 0, IIF(WGreen > 255, 255, WGreen))
WBlue = lobyte(loWord(rColor)) + (3 * BError / 16)
WBlue = IIF(WBlue < 0, 0, IIF(WBlue > 255, 255, WBlue ))
ImageRow[X + ImagePitch -1] = RGB(WRed,WGreen,WBlue)
End If
End If
Next X
ImageRow += ImagePitch
Next Y
'FreeMem:
Delete[] BaseClusterList -> List
Delete BaseClusterList
For DC as Integer=0 to CubeCount-1
Delete[] CubeList[DC] -> ClusterList -> List
Delete CubeList[DC] -> ClusterList
Delete CubeList[DC]
Next DC
deallocate CubeList
return 1
End Function
Screen 19,32
Dim testimage as any ptr = imagecreate(800,600)
bload "test.bmp",testimage
Dim colors as integer
colors = ColorReduce(testimage,256,1)
Put (0,0),testimage,pset
bsave "testimage.bmp",testimage
sleep
|
_________________
|
|
| Nach oben |
|
|
ThePuppetMaster
Anmeldungsdatum: 18.02.2007
Beiträge: 1838
Wohnort: [JN58JR]
|
| Verfasst am: 26.07.2012, 06:02 Titel: |
|
|
Du könntest versuchen eine "intelligente funktion" zu schreiben die selbstständig nach deinen kriterien 2 bilder miteinander vergleicht, und daraus den Reducer-Code mit Parameter versorgt, bis das Ergebniss optimal erscheint.
Die Parameter könnten dann fest in den code fliesen.
MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ] |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
