ReduceImageColors()

[Froggerprogger]

Ahoi.
Folgender Code reduziert die Anzahl Farben eines Bildes auf 2-16 Farben.
Ihm liegt allerdings kein bekannter+bewährter Algorithmus zugrunde, sondern ist lediglich auf meinen eigenen Mist gewachsen, aber immerhin tut er einigermaßen das, was er soll.

Ahoi,
Froggerprogger

Code: Alles auswählen

;- ReduceImageColors() v1.0
;- Reduces the number of colors of an image to 2-16 colors
;- and finds adequate colors for that.
;- Returns a new created copy containing the reduced image.
;- The algorithm will not be the best out there (was just
;- based on some simple thoughts), but it works!
;- 
;- 12.08.05 by Froggerprogger

Structure RGBCountElement
  red.l
  green.l
  blue.l
  count.l
EndStructure 

Dim InputImage.l(0,0)
Dim ImageColors4096.RGBCountElement(4095)
Dim OutputColors.RGBCountElement(0)

Procedure ReduceImageColors(imageNumber.l, numColors.l) ; Reduces the number of colors to 1 - 16 colors. Returns the new image.
  If numColors < 2 Or numColors > 16 Or IsImage(imageNumber) = 0
    ProcedureReturn 0
  EndIf
  
  Protected width.l, height.l, color.l, red.l, green.l, blue.l, index.l
  Protected currentMaximumPos.l
  Protected i.l, j.l, k.l, l.l, m.l
  
  UseImage(imageNumber)
  width = ImageWidth()
  height = ImageHeight()
  
  Dim InputImage.l(width-1, height-1)
  StartDrawing(ImageOutput())
    For i=0 To width-1
      For j=0 To height-1
        color = Point(i,j)
        ; 'copy' the image to an array
        InputImage(i,j) = color
        ;count the color-hits
        red   = Int(Red(color) / 16)
        green = Int(Green(color) / 16)
        blue  = Int(Blue(color) / 16)
        index = red + green << 4 + blue << 8
        ImageColors4096(index)\count + 1
      Next
    Next
  StopDrawing()
 
  
  Dim OutputColors.RGBCountElement(numColors-1)
  For i=0 To numColors-1
    currentMaximumPos = 0
    ; get the most often value
    For j=1 To 4095
      If ImageColors4096(j)\count > ImageColors4096(currentMaximumPos)\count
        currentMaximumPos = j
      EndIf
    Next
 
    OutputColors(i)\red   = currentMaximumPos & $F
    OutputColors(i)\green = (currentMaximumPos >> 4) & $F
    OutputColors(i)\blue  = (currentMaximumPos >> 8) & $F
    
    ; remove entries that are closest to the current outputcolor
    removeNum = 1 + width * height / numColors
    removed = 0
    ignoreTheseWays = 0
    For j=0 To 15
      For k=0 To 15
        For l=0 To 15
          For m=0 To 7
            ; bitfield used for speeding up
            If ignoreTheseWays & (1 << m)
              Continue
            EndIf

            If m & %1
              red = OutputColors(i)\red + j
              If red > 15
                Continue
              EndIf
            Else
              red = OutputColors(i)\red - j
              If red < 0
                Continue
              EndIf              
            EndIf
            If m & %10
              green = OutputColors(i)\green + k
              If green > 15
                Continue
              EndIf
            Else
              green = OutputColors(i)\green - k
              If green < 0
                Continue
              EndIf              
            EndIf
            If m & %100
              blue = OutputColors(i)\blue + l
              If blue > 15
                Continue
              EndIf
            Else
              blue = OutputColors(i)\blue - l
              If blue < 0
                Continue
              EndIf              
            EndIf            

            index = red + green << 4 + blue << 8
            
            If ImageColors4096(index)\count = -1
              ignoreTheseWays = ignoreTheseWays | (1 << m)
              If ignoreTheseWays = %11111111
                Break 4
              EndIf
            EndIf
            
            removed = removed + ImageColors4096(index)\count
            ImageColors4096(index)\count = -1
            ImageColors4096(index)\red   = red
            ImageColors4096(index)\green = green
            ImageColors4096(index)\blue  = blue

            If totalremoved + removed >= width * height
              Break 5
            EndIf 
            If removed >= removeNum
              Break 4
            EndIf
          Next
        Next
      Next
    Next 
    totalremoved + removed
  Next
  
  outputimage = CreateImage(#PB_Any, width, height)
  StartDrawing(ImageOutput())
    For i=0 To width-1
      For j=0 To height-1
        color = InputImage(i,j)
        red   = Int(Red(color) / 16)
        green = Int(Green(color) / 16)
        blue  = Int(Blue(color) / 16)

        minindex = 0
        minval = Abs(red - OutputColors(0)\red) + Abs(green - OutputColors(0)\green) + Abs(blue - OutputColors(0)\blue)
        For k=1 To numColors-1
          tmp = Abs(red - OutputColors(k)\red) + Abs(green - OutputColors(k)\green) + Abs(blue - OutputColors(k)\blue)
          If tmp < minval
            minval = tmp
            minindex = k
          EndIf
        Next
        OutputColors(minindex)\count + 1
        FrontColor(OutputColors(minindex)\red * 16, OutputColors(minindex)\green * 16, OutputColors(minindex)\blue * 16)
        Plot(i, j)
      Next
    Next
    StopDrawing()
    
    ProcedureReturn outputimage
EndProcedure

;- example
inputimg = LoadImage(#PB_Any, "test.bmp")
outputimg = ReduceImageColors(inputimg, 16)
SaveImage(outputimg, "output16.bmp")
outputimg = ReduceImageColors(inputimg, 4)
SaveImage(outputimg, "output4.bmp")
MessageRequester("", "done")