Floyd Steinberg dithering mit Purebasic

funkheld · **Registriert:** 31.12.2009 11:58

Hallo, gibt es ein Floyd Steinberg dithering in Purebasic ?

Danke.

Gruss

NicTheQuick · **Verfasst:** 13.02.2012 13:53

Nicht, dass ich wüsste, aber der ist doch sehr leicht zu implementieren. Siehe Floyd-Steinberg-Algorithmus [Wiki].

DarkDragon · **Registriert:** 29.08.2004 08:37

Zum abspeichern gibt es das sogar schon:

SaveImage Dokumentation hat geschrieben:

#PB_Image_FloydSteinberg: wendet ein Floyd-Steinberg Dithering an

funkheld · **Registriert:** 31.12.2009 11:58

Danke für die Tipps.
Hmm..., leicht ?
Für dich , aber ich kann das nicht umsetzen.
Der Code sieht zwar wunderbar kurz aus,aber...
Wie wird der für Purebasic umgesetzt ?

Gruss

Code:

for each y
   for each x
      oldpixel        := pixel[x][y]
      newpixel        := find_closest_palette_color (oldpixel)
      pixel[x][y]     := newpixel
      quant_error     := oldpixel - newpixel
      pixel[x+1][y  ] := pixel[x+1][y  ] + 7 * quant_error / 16
      pixel[x-1][y+1] := pixel[x-1][y+1] + 3 * quant_error / 16
      pixel[x  ][y+1] := pixel[x  ][y+1] + 5 * quant_error / 16
      pixel[x+1][y+1] := pixel[x+1][y+1] + 1 * quant_error / 16

NicTheQuick · **Verfasst:** 13.02.2012 14:43

Zunächst einmal musst du wissen welche Farben du am Ende noch haben möchtest. Soll es am Ende gänzlich Schwarz/Weiß sein, oder hast du eine 256-Farben-Palette, auf die du dein Eingangsbild reduzieren willst. Darauf muss man dann die Funktion 'find_closest_palette_color' aus dem Pseudocode anpassen und der Rest ist ja nichts anderes als das Arbeiten mit einem simplen 2D-Array und Plus, Minus, Mal und Geteilt. :wink:

funkheld · **Registriert:** 31.12.2009 11:58

Die Punkte sind doch S/W oder ?
Das Ausgangsbild ist 8BIT Graustufe.

Gruss

NicTheQuick · **Verfasst:** 13.02.2012 17:08

Das muss nicht sein. Mit dem Algorithmus kannst du die Farbanzahl eines Bildes auf eine beliebige Zahl verringern. Allerdings müssen vorher die zu verwendeten Farben definiert werden.

funkheld · **Registriert:** 31.12.2009 11:58

Ich habe hier Code gefunden, den bring ich nicht zum Laufen.
Es sind da einige Proceduredll drin, das verstehe ich nicht.
Es kommen einige Meldungen von Purebasic, das einige Befehle nicht stimmen.

Kann den mal einer durchtesten ?
Danke.

Gruss

Code:

;===========================================================================
;=   Make8bitImage.pbi
;===========================================================================

;=====================================================================================
; Library commands:       ImageTo8bit() and Save8bitImage()
; Author:                 Lloyd Gallant (netmaestro)
; Date:                   December 12, 2008
; Target OS:              Microsoft Windows All
; Target Compiler:        PureBasic 4.3 and later
; License:                Free, unrestricted, no warranty
;           
; Usage: ImageTo8bit(hImageIn, palette, free)
;
;        hImageIn: is the 16,24 or 32bit image to reduce to 8bit depth
;        palette:  is either 0,1 or 2:  0 = grayscale
;                                       1 = MSX2 Screen8 color palette
;                                       2 = Adaptive color palette
;        free:     is a boolean which if true will free the original image
;
; Usage: Save8bitImage(image, filename$ [,memory])
;
;        image:     is an 8bit image to save to disk or memory
;        filename$: is the name to save it to.
;        memory:    is a boolean which if true, will cause the procedure to return
;                   a memory block containing the complete bitmap file. You may
;                   compress this and send it over a network or catch the image
;                   from the returned pointer as desired. You must free the pointer
;                   when you're finished to avoid a memory leak.
;=====================================================================================

;Procedure ArraySize(*Array)
  ;ProcedureReturn PeekL(*Array-8)
;EndProcedure

Procedure GrayscaleTable()

  Global Dim GrayTable.RGBQUAD(256)
  For i = 0 To 255
    With GrayTable(i)
      \rgbBlue  = i
      \rgbGreen = i
      \rgbRed   = i
      \rgbReserved = 0
    EndWith       
  Next

  *palette = AllocateMemory(256*SizeOf(RGBQUAD))
  CopyMemory(@GrayTable(),*palette, MemorySize(*palette))
  ReDim GrayTable.RGBQUAD(0)
  ProcedureReturn *palette

EndProcedure

Procedure ColorTable()

  *unpacked = AllocateMemory(824)
  UnpackMemory(?ColorTable, *unpacked)
  img0 = CatchImage(#PB_Any, *unpacked, 824)
  FreeMemory(*unpacked)

  DataSection
    ColorTable:
    Data.b $4A,$43,$38,$03,$00,$00,$4E,$C7,$B6,$7E,$B3,$A9,$D0,$20,$69,$14,$19,$88,$12,$CA
    Data.b $08,$B0,$4A,$08,$25,$90,$0C,$30,$46,$02,$89,$81,$20,$70,$60,$10,$D8,$42,$AA,$91
    Data.b $FF,$16,$02,$A9,$66,$80,$90,$84,$00,$68,$51,$20,$0A,$0C,$50,$52,$88,$02,$0A,$44
    Data.b $81,$28,$A2,$40,$6D,$21,$86,$28,$10,$05,$14,$88,$02,$49,$64,$1B,$A2,$40,$02,$51
    Data.b $20,$0A,$28,$D0,$76,$88,$20,$0A,$44,$81,$00,$48,$02,$49,$3A,$38,$10,$31,$14,$74
    Data.b $28,$52,$24,$0C,$30,$40,$A2,$40,$14,$88,$A0,$A4,$10,$05,$14,$88,$02,$51,$44,$81
    Data.b $DA,$42,$0C,$51,$20,$0A,$28,$10,$05,$92,$C8,$36,$44,$81,$05,$A2,$40,$14,$24,$81
    Data.b $24,$10,$02,$49,$20,$09,$35,$3A,$14,$C8,$40,$B6,$01,$C3,$6D,$A0,$0E,$03,$20,$92
    Data.b $30,$00,$14,$88,$02,$51,$44,$81,$92,$42,$0B,$51,$20,$0A,$28,$10,$05,$6A,$48,$32
    Data.b $44,$81,$05,$A2,$40,$14,$24,$81,$24,$10,$0E,$49,$20,$09,$28,$10,$05,$DA,$20,$0B
    Data.b $44,$81,$0C,$88,$02,$51,$88,$02,$49,$06,$05,$A2,$40,$14,$44,$81,$28,$10,$02,$51
    Data.b $20,$0A,$A2,$40,$14,$88,$81,$28,$10,$05,$51,$20,$0A,$44,$40,$13,$68,$02,$28,$D0
    Data.b $04,$9A,$20,$0A,$44,$81,$14,$88,$02,$51,$10,$05,$A2,$40,$68,$88,$82,$28,$0A,$D4
    Data.b $16,$30,$88,$02,$51,$20,$05,$A2,$40,$14,$44,$81,$28,$10,$02,$51,$20,$0A,$9A,$40
    Data.b $14,$88,$81,$26,$D0,$04,$51,$20,$0A,$34,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A
    Data.b $44,$81,$14,$88,$02,$51,$57,$0A,$A2,$40,$50,$52,$C0,$A0,$0A,$44,$81,$28,$88,$02
    Data.b $51,$20,$05,$A2,$40,$14,$34,$81,$26,$10,$02,$4D,$A0,$09,$A2,$40,$14,$88,$81,$28
    Data.b $10,$05,$51,$20,$0A,$44,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A,$44,$81,$2C,$88
    Data.b $02,$51,$24,$01,$83,$36,$10,$05,$A2,$40,$09,$44,$81,$28,$68,$02,$4D,$A0,$05,$A2
    Data.b $40,$13,$44,$81,$28,$10,$02,$51,$20,$0A,$A2,$40,$14,$88,$81,$28,$10,$05,$51,$20
    Data.b $0A,$44,$40,$14,$88,$02,$28,$10,$05,$A2,$20,$0A,$44,$81,$A8,$B4,$3C,$B4,$5A,$50
    Data.b $04,$30,$80,$51,$00,$A2,$8E,$3E,$80,$22,$22,$80,$11,$C9,$A0,$08,$14,$81,$11,$28
    Data.b $02,$45,$50,$04,$8A,$40,$08,$14,$81,$22,$28,$02,$45,$A0,$04,$8A,$40,$11,$14,$81
    Data.b $22,$50,$02,$45,$A0,$08,$89,$40,$11,$28,$00,$40,$24,$32
    ColorTableend:
  EndDataSection

  Global Dim ctable.RGBQUAD(256)

  cc=0
  StartDrawing(ImageOutput(img0))
  For j=0 To 7
    For i=0 To 31
      col = Point(i,j)
      With ctable(cc)
        \rgbBlue  = Blue(col)
        \rgbGreen = Green(col)
        \rgbRed   = Red(col)
        \rgbReserved = 0
      EndWith
      cc+1
    Next
  Next
  StopDrawing()
  FreeImage(img0)

  *palette = AllocateMemory(256*SizeOf(RGBQUAD))
  CopyMemory(@ctable(),*palette, MemorySize(*palette))
  ReDim ctable.RGBQUAD(0)
  ProcedureReturn *palette


EndProcedure

ProcedureDLL Save8bitImage(image, filename$, memory=0)

  If Not IsImage(image) Or ImageDepth(image) <> 8
    ProcedureReturn 0
  EndIf

  If GetObject_(ImageID(image), SizeOf(BITMAP), Bmp.BITMAP)
    With BmiInfo.BITMAPINFOHEADER
      \biSize         = SizeOf(BITMAPINFOHEADER)
      \biWidth        = Bmp\bmWidth
      \biHeight       = Bmp\bmHeight
      \biPlanes       = 1
      \biBitCount     = 8
      \biCompression  = #BI_RGB
    EndWith
  Else
    ProcedureReturn 0
  EndIf

  sz_colorbits = Bmp\bmWidthBytes*Bmp\bmHeight
  *colortable = AllocateMemory(256*SizeOf(RGBQUAD))
  hdc = StartDrawing(ImageOutput(image))
    NumColors = GetDIBColorTable_(hdc, 0, 256, *colortable)
  StopDrawing()
  sz_image = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD) + sz_colorbits
  *rawimage = AllocateMemory(sz_image)
  *fileheader.BITMAPFILEHEADER = *rawimage
  *header = *rawimage + SizeOf(BITMAPFILEHEADER)
  With *fileheader
    \bfType = PeekW(@"BM")
    \bfSize = sz_image
    \bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD)
  EndWith
  CopyMemory(BmiInfo, *header, SizeOf(BITMAPINFOHEADER))
  CopyMemory(*colortable, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER), NumColors*SizeOf(RGBQUAD))
  CopyMemory(Bmp\bmBits, *rawimage + SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + NumColors*SizeOf(RGBQUAD), sz_colorbits)

  FreeMemory(*colortable)

  If Not memory
    file = CreateFile(#PB_Any, filename$)
    If file
      WriteData(file,*rawimage,MemorySize(*rawimage))
      CloseFile(file)
    EndIf
    FreeMemory(*rawimage)
    ProcedureReturn 1
  Else
    ProcedureReturn *rawimage
  EndIf

EndProcedure

Procedure Get32BitColors(pBitmap)

  GetObject_(ImageID(pBitmap), SizeOf(BITMAP), @Bmp.BITMAP)

  With BmiInfo.BITMAPINFOHEADER
    \biSize         = SizeOf(BITMAPINFOHEADER)
    \biWidth        = Bmp\bmWidth
    \biHeight       = -Bmp\bmHeight
    \biPlanes       = 1
    \biBitCount     = 32
    \biCompression  = #BI_RGB
  EndWith

  *pPixels = AllocateMemory(4*Bmp\bmWidth*Bmp\bmHeight)
  hDC = GetWindowDC_(#Null)
  iRes = GetDIBits_(hDC, ImageID(pBitmap), 0, Bmp\bmHeight , *pPixels, @bmiInfo, #DIB_RGB_COLORS)
  ReleaseDC_(#Null, hDC)
  ProcedureReturn *pPixels

EndProcedure

Procedure AdaptiveColorTable(pBitmap)

  *pPixels = Get32BitColors(pBitmap)
  Global Dim ColorBits.l(MemorySize(*pPixels)/4)
  CopyMemory(*pPixels,ColorBits(),MemorySize(*pPixels))
  FreeMemory(*pPixels)
  SortArray(ColorBits(),#PB_Sort_Ascending)
  Global Dim Apalette(256)
  x = ArraySize(colorbits())/256
  cc=0
  lastcolor = colorbits(0)-1
  For i = 0 To 255
    If colorbits(cc)<>lastcolor
      Apalette(i) = colorbits(cc)
      lastcolor = colorbits(cc)
      cc+x
    Else
      While colorbits(cc) = lastcolor And cc < ArraySize(colorbits())
        cc+1
      Wend
      x = (ArraySize(colorbits())-cc)/(256-i)
      cc+x-1
      Apalette(i) = colorbits(cc)
      lastcolor = colorbits(cc)
    EndIf
  Next

  ReDim Colorbits.l(0)

  *palette = AllocateMemory(256*SizeOf(RGBQUAD))
  CopyMemory(@Apalette(),*palette, MemorySize(*palette))
  ReDim Apalette(0)
  ProcedureReturn *palette

EndProcedure

ProcedureDLL ImageTo8bit(hImageIn, palette, free)

  Select palette
    Case 0
      *palette = GrayscaleTable()
    Case 1
      *palette = ColorTable()
    Case 2
      *palette = AdaptiveColorTable(hImageIn)
    Default
      *palette = ColorTable()
  EndSelect

  GetObject_(ImageID(hImageIn),SizeOf(BITMAP),bmp.BITMAP)
  w = bmp\bmWidth
  h = bmp\bmHeight
  d = bmp\bmBitsPixel

  hImageOut = CreateImage(#PB_Any,w,h,8)

  hdc = StartDrawing(ImageOutput(hImageOut))
    SetDIBColorTable_(hdc,0,256,*palette)
    With bmi.BITMAPINFO
      \bmiHeader\biSize     = SizeOf(BITMAPINFOHEADER)
      \bmiHeader\biWidth    = w
      \bmiHeader\biHeight   = -h
      \bmiHeader\biPlanes   = 1
      \bmiHeader\biBitCount = d
      \bmiHeader\biCompression = #BI_RGB
    EndWith
    GetDIBits_(hdc,ImageID(hImageIn),0,0, #Null, bmi.BITMAPINFO, #DIB_RGB_COLORS)
    *bits = AllocateMemory(bmi\bmiHeader\biSizeImage)
    GetDIBits_(hdc,ImageID(hImageIn),0,h, *bits, bmi.BITMAPINFO, #DIB_RGB_COLORS)
    SetDIBits_(hdc,ImageID(hImageOut),0,h,*bits,bmi,#DIB_PAL_COLORS)
  StopDrawing()
  FreeMemory(*bits)

  FreeMemory(*palette)

  If free
    FreeImage(hImageIn)
  EndIf

  ProcedureReturn hImageOut

EndProcedure

;IncludeFile "Make8bitImage.pbi"

UseJPEGImageDecoder()
;If FileSize("girl.jpg")= -1 : InitNetwork() : ReceiveHTTPFile("http://www.lloydsplace.com/girl.jpg", "girl.jpg") : EndIf

hImage = LoadImage(#PB_Any, "girl.jpg")
i = ImageTo8bit(hImage, 2, 0)

; save to a bitmap file
Save8bitImage(i, "girl_8bit.bmp")

; save to memory
*image = Save8bitImage(i, "", 1)

; test memory image
j = CatchImage(#PB_Any, *image)

OpenWindow(0,100,100,ImageWidth(j),ImageHeight(j),"")
CreateGadgetList(WindowID(0))
ImageGadget(0,0,0,0,0,ImageID(j))
Repeat:Until WaitWindowEvent()=#WM_CLOSE

NicTheQuick · **Verfasst:** 13.02.2012 20:35

funkheld hat geschrieben:

Es kommen einige Meldungen von Purebasic, das einige Befehle nicht stimmen.

Kann den mal einer durchtesten ?

Kannst du mal lernen hinreichende Informationen zu geben? Welche Meldungen? Welche Befehle?
Im Header steht ja, dass der Code nur unter Windows funktionert, von daher kann ich dir ab hier nicht mehr weiterhelfen.

Nino · **Registriert:** 13.05.2010 09:26 **Wohnort:** Berlin

funkheld hat geschrieben:

Ich habe hier Code gefunden, den bring ich nicht zum Laufen.
Es sind da einige Proceduredll drin, das verstehe ich nicht.

Ich bin mir nicht sicher ob es der Sinn des Programmierens ist, irgendwelchen Code zusammenzukopieren den man nicht versteht.
Außerdem hatte NicTheQuick Dir doch einen sehr einfachen Beispielcode gezeigt, plus mehrere Winke mit 'm Zaunpfahl. Wenn Du das nicht umsetzt, und stattdessen irgendwelchen Code zusammenkopierst und danach rumjammerst, weil er nicht funktioniert (noch dazu ohne konkret zu sagen wo es hakt), dann ist Programmieren wohl kaum das richtige Hobby für Dich. Oder vielleicht belegst Du wenigstens erstmal einen Kurs und/oder liest ein gutes Buch darüber. Aber so wird's jedenfalls nix.

PureBoard

Floyd Steinberg dithering mit Purebasic

Wer ist online?