Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
 
FAQFAQ   SuchenSuchen   MitgliederlisteMitgliederliste   BenutzergruppenBenutzergruppen  RegistrierenRegistrieren
ProfilProfil   Einloggen, um private Nachrichten zu lesenEinloggen, um private Nachrichten zu lesen   LoginLogin
Zur Begleitseite des Forums / Chat / Impressum
Aktueller Forenpartner:

[fertig] Median-Cut Farbreduzierung
Gehe zu Seite 1, 2  Weiter
 
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC.
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 14.07.2012, 11:39    Titel: [fertig] Median-Cut Farbreduzierung Antworten mit Zitat

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 grinsen)

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]

BeitragVerfasst am: 15.07.2012, 12:37    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 15.07.2012, 21:01    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]

BeitragVerfasst am: 15.07.2012, 23:05    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 15.07.2012, 23:23    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
28398



Anmeldungsdatum: 25.04.2008
Beiträge: 1917

BeitragVerfasst am: 16.07.2012, 10:57    Titel: Antworten mit Zitat

Schau dir doch einfach an wie GIMP oder PDN das machen...? zwinkern
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 16.07.2012, 17:33    Titel: Antworten mit Zitat

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 happy
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]

BeitragVerfasst am: 16.07.2012, 17:34    Titel: Antworten mit Zitat

das is ja auch C(++) Hammer


MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Flo
aka kleiner_hacker


Anmeldungsdatum: 23.06.2006
Beiträge: 1210

BeitragVerfasst am: 16.07.2012, 18:04    Titel: Antworten mit Zitat

ThePuppetMaster hat Folgendes geschrieben:
das is ja auch C(++) Hammer


und deshalb ist fb-code um sooo viel schlanker durchgeknallt? das wage ich ja mal anzuzweifeln zwinkern

(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
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]

BeitragVerfasst am: 16.07.2012, 18:05    Titel: Antworten mit Zitat

Och .. der source kommt mir schon deutlich schlanker vor. ob das die bin is, is ja ne andere frage Zunge rausstrecken

arch: nop zwinkern


MfG
TPM
_________________
[ WebFBC ][ OPS ][ ToOFlo ][ Wiemann.TV ]
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Jojo
alter Rang


Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte

BeitragVerfasst am: 16.07.2012, 20:11    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
28398



Anmeldungsdatum: 25.04.2008
Beiträge: 1917

BeitragVerfasst am: 19.07.2012, 20:16    Titel: Antworten mit Zitat

Pro-Tipp™ von Opa Rats: In Python™ kann man Sachen oft am kürzesten abhandeln. Und mit PyPy™ rennt die Sau auch.
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
dreael
Administrator


Anmeldungsdatum: 10.09.2004
Beiträge: 2507
Wohnort: Hofen SH (Schweiz)

BeitragVerfasst am: 21.07.2012, 15:55    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 21.07.2012, 17:18    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Jojo
alter Rang


Anmeldungsdatum: 12.02.2005
Beiträge: 9736
Wohnort: Neben der Festplatte

BeitragVerfasst am: 21.07.2012, 20:35    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden Website dieses Benutzers besuchen
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 22.07.2012, 11:07    Titel: Antworten mit Zitat

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 zwinkern

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 grinsen
_________________
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
28398



Anmeldungsdatum: 25.04.2008
Beiträge: 1917

BeitragVerfasst am: 22.07.2012, 15:44    Titel: Antworten mit Zitat

Mit libpng müsste sich das doch recht einfach machen lassen...

/e: Schau dir einfach mal die zurechtgepatchte libpng vom Firefox an...
Nach oben
Benutzer-Profile anzeigen Private Nachricht senden
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 24.07.2012, 14:52    Titel: Antworten mit Zitat

11. Versuch (den 10. hab ich komplett versaut happy)
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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
Eternal_pain



Anmeldungsdatum: 08.08.2006
Beiträge: 1783
Wohnort: BW/KA

BeitragVerfasst am: 25.07.2012, 12:43    Titel: Antworten mit Zitat

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 happy)

Fröhliches Farben reduzieren grinsen

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
Benutzer-Profile anzeigen Private Nachricht senden E-Mail senden Website dieses Benutzers besuchen MSN Messenger
ThePuppetMaster



Anmeldungsdatum: 18.02.2007
Beiträge: 1837
Wohnort: [JN58JR]

BeitragVerfasst am: 26.07.2012, 06:02    Titel: Antworten mit Zitat

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
Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Das deutsche QBasic- und FreeBASIC-Forum Foren-Übersicht -> Allgemeine Fragen zu FreeBASIC. Alle Zeiten sind GMT + 1 Stunde
Gehe zu Seite 1, 2  Weiter
Seite 1 von 2

 
Gehe zu:  
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.

 Impressum :: Datenschutz