04-27-2025, 01:16 PM
This program deals with dithering. The program loads the file ara.png and then displays it using internal dithering (LoadImage with parameter 256), then better (LoadImage with parameter 257), then displays the original 32 bit version and finally performs Floyd Stenberg's own (slow) dithering method with the MedianCut method, but the own version is really very slow. I don't intend to speed it up - I think LoadImage with parameter 257 returns super fast output with acceptable color rendition.
Code: (Select All)
' ====================================================================================================
' QB64PE Dithering with Median Cut palette (Floyd-Steinberg); extremly SLOW, but best graphical output
' ====================================================================================================
DefInt A-Z
Type BoxRange
startIndex As Long
endIndex As Long
minR As Long
maxR As Long
minG As Long
maxG As Long
minB As Long
maxB As Long
End Type
' Globální proměnné pro QuickSort a Median Cut
Dim Shared compareComponent As Long
Dim Shared srcR, srcG, srcB As Long
Dim Shared Boxes As BoxRange
' =============================================================================
' Hlavní program
' =============================================================================
Screen 0
Cls
_FullScreen
Dim sourceImg As Long, targetImg As Long
Dim w As Long, h As Long
' Load 32bit image
Dim As String SourceImage32
SourceImage32 = "ara.png"
sourceImg = _LoadImage(SourceImage32, 32)
If sourceImg = 0 Then
Print "Error loading 32bit image!"
Sleep 2
End
End If
image8QB64PE = _LoadImage(SourceImage32, 256)
Screen image8QB64PE
Print "QB64PE: LoadImage 256 dithering. Press any key to continue..."
Sleep
Screen 0
_Delay .5
_FreeImage image8QB64PE
image8QB64PE = _LoadImage(SourceImage32, 257)
Screen image8QB64PE
Print "QB64PE: LoadImage 257 dithering. Press any key to continue..."
Sleep
w = _Width(sourceImg)
h = _Height(sourceImg)
' Vytvoř 8bitový cílový obrázek (paleta 256 barev)
' Create 8bit target image (palette 256 colors)
targetImg = _NewImage(w, h, 256)
' Přepni se na zdrojový 32bitový screen, abys mohl(a) číst pixelová data
' Show 32bit image
Screen sourceImg
Print "Original 32bit image..."
' --- 1) Uložit zdrojové barvy do polí (pro dithering) pouzijeme SINGLE ---
' --- 2) save source colors to arrays for dithering (Single type)
ReDim Shared dataR!(0 To w - 1, 0 To h - 1)
ReDim Shared dataG!(0 To w - 1, 0 To h - 1)
ReDim Shared dataB!(0 To w - 1, 0 To h - 1)
' --- 2) Uložit barvy do polí pro Median Cut (0..255, typ LONG) ---
' --- 2) save colors to arrays for Median Cut (0 to 255, LONG type)
ReDim Shared srcR(0 To w * h - 1) As Long
ReDim Shared srcG(0 To w * h - 1) As Long
ReDim Shared srcB(0 To w * h - 1) As Long
ReDim Shared Boxes(0 To 0) As BoxRange
'Print "Načítám barvy do paměti..."
'Print "Loading 32bit colors to RAM..."
Dim p As Long: p = 0
Dim x As Long, y As Long
Dim c As _Unsigned Long
Dim rByte As _Unsigned _Byte, gByte As _Unsigned _Byte, bByte As _Unsigned _Byte
Dim m As _MEM
m = _MemImage(sourceImg)
c = 0
x = 0: y = 0
Do While c < m.SIZE
bByte = _MemGet(m, m.OFFSET + c, _Unsigned _Byte)
gByte = _MemGet(m, m.OFFSET + c + 1, _Unsigned _Byte)
rByte = _MemGet(m, m.OFFSET + c + 2, _Unsigned _Byte)
' Uložíme do Single polí pro dithering:
' Save image colors to arrays for dithering
dataR!(x, y) = rByte
dataG!(x, y) = gByte
dataB!(x, y) = bByte
' Uložíme do polí pro Median Cut:
' Save image colors for Median Cut
srcR(p) = rByte
srcG(p) = gByte
srcB(p) = bByte
p = p + 1
x = x + 1
If x = w Then
x = 0
y = y + 1
End If
c = c + 4
Loop
' --- 3) Vytvořit 256barevnou paletu metodou Median Cut ---
' --- 3) Build 256 colors palette with Median Cut method
Dim PalR(255) As Long, PalG(255) As Long, PalB(255) As Long
BuildPaletteMedianCut srcR(), srcG(), srcB(), w * h, 256, PalR(), PalG(), PalB()
' Nastavit vytvořenou paletu do cílového 8bitového obrazu
' Set 8 bit created palette to target 8bit image
Dim i As Long
For i = 0 To 255
_PaletteColor i, _RGB32(PalR(i), PalG(i), PalB(i)), targetImg
Next i
' --- 4) Floyd-Steinberg dithering ---
'Print "Provádím Floyd-Steinberg dithering..."
'Print "Processing Floyd-Steinberg dithering..."
FloydSteinbergDither dataR!(), dataG!(), dataB!(), w, h, PalR(), PalG(), PalB(), targetImg
' --- Zobrazit výsledek ---
Screen targetImg
Print "Hotovo!"
Print "Done! - own dithering"
Sleep
' =============================================================================
' SUBs and FUNCTIONs
' =============================================================================
' ========================================================================
' SUB BuildPaletteMedianCut
' Vytvoří paletu 256 barev metodou Median Cut ze zdrojových polí (srcR, srcG, srcB)
' Create palette in 256 colors unsing Median Cut method from arrays srcR, srcG, srcB
' ========================================================================
Sub BuildPaletteMedianCut (sourceR() As Long, sourceG() As Long, sourceB() As Long, totalPixels As Long, desiredColors As Long, paletteR() As Long, paletteG() As Long, paletteB() As Long)
' 1) Připrav pole indexů všech pixelů
' 2) Create indexes array all pixels
ReDim pixelIndices(totalPixels - 1) As Long
Dim i As Long
For i = 0 To totalPixels - 1
pixelIndices(i) = i
Next i
' 2) Najdi celkové min/max R, G, B
' find total min/maX R,G,B
Dim minValR As Long, maxValR As Long
Dim minValG As Long, maxValG As Long
Dim minValB As Long, maxValB As Long
minValR = 255: maxValR = 0
minValG = 255: maxValG = 0
minValB = 255: maxValB = 0
Dim ir As Long, ig As Long, ib As Long
For i = 0 To totalPixels - 1
ir = sourceR(i)
ig = sourceG(i)
ib = sourceB(i)
If ir < minValR Then minValR = ir
If ir > maxValR Then maxValR = ir
If ig < minValG Then minValG = ig
If ig > maxValG Then maxValG = ig
If ib < minValB Then minValB = ib
If ib > maxValB Then maxValB = ib
Next i
' 3) První box - celý rozsah
' first box - complete range
ReDim Boxes(0) As BoxRange
Boxes(0).startIndex = 0
Boxes(0).endIndex = totalPixels - 1
Boxes(0).minR = minValR
Boxes(0).maxR = maxValR
Boxes(0).minG = minValG
Boxes(0).maxG = maxValG
Boxes(0).minB = minValB
Boxes(0).maxB = maxValB
Dim boxCount As Long: boxCount = 1
Dim largestBoxIndex As Long, largestDimension As Long
' 4) Rozdělení boxů
' boxes distribution
Do While boxCount < desiredColors
largestBoxIndex = -1
largestDimension = -1
Dim idxBox As Long
For idxBox = 0 To boxCount - 1
Dim rSize As Long, gSize As Long, bSize As Long
rSize = Boxes(idxBox).maxR - Boxes(idxBox).minR
gSize = Boxes(idxBox).maxG - Boxes(idxBox).minG
bSize = Boxes(idxBox).maxB - Boxes(idxBox).minB
Dim maxDim As Long: maxDim = rSize
If gSize > maxDim Then maxDim = gSize
If bSize > maxDim Then maxDim = bSize
If maxDim > largestDimension Then
largestDimension = maxDim
largestBoxIndex = idxBox
End If
Next idxBox
If largestBoxIndex < 0 Then Exit Do
Dim b As BoxRange
b = Boxes(largestBoxIndex)
' Určení, podle které složky třídit
' Determine which folder to sort by
Dim dimR As Long, dimG As Long, dimB As Long
dimR = b.maxR - b.minR
dimG = b.maxG - b.minG
dimB = b.maxB - b.minB
If dimR >= dimG And dimR >= dimB Then
compareComponent = 0
ElseIf dimG >= dimR And dimG >= dimB Then
compareComponent = 1
Else
compareComponent = 2
End If
' Setřiď pixelIndices v rozsahu boxu
' Sort pixelIndices in box range
QuickSortIndices pixelIndices(), b.startIndex, b.endIndex
' Rozdělení boxu na dvě části
' Dividing the box into two parts
Dim middle As Long: middle = (b.startIndex + b.endIndex) \ 2
Dim box1 As BoxRange, box2 As BoxRange
box1.startIndex = b.startIndex
box1.endIndex = middle
box2.startIndex = middle + 1
box2.endIndex = b.endIndex
' Výpočet min/max pro box1
' Calculate min/max for box1
Dim j As Long
Dim rr As Long, gg As Long, bb As Long
Dim minr As Long, maxr As Long, ming As Long, maxg As Long, minb As Long, maxb As Long
minr = 255: maxr = 0: ming = 255: maxg = 0: minb = 255: maxb = 0
For j = box1.startIndex To box1.endIndex
idxBox = pixelIndices(j)
rr = sourceR(idxBox)
gg = sourceG(idxBox)
bb = sourceB(idxBox)
If rr < minr Then minr = rr
If rr > maxr Then maxr = rr
If gg < ming Then ming = gg
If gg > maxg Then maxg = gg
If bb < minb Then minb = bb
If bb > maxb Then maxb = bb
Next j
box1.minR = minr: box1.maxR = maxr
box1.minG = ming: box1.maxG = maxg
box1.minB = minb: box1.maxB = maxb
' Výpočet min/max pro box2
' Calculate min/max for box2
minr = 255: maxr = 0: ming = 255: maxg = 0: minb = 255: maxb = 0
For j = box2.startIndex To box2.endIndex
idxBox = pixelIndices(j)
rr = sourceR(idxBox)
gg = sourceG(idxBox)
bb = sourceB(idxBox)
If rr < minr Then minr = rr
If rr > maxr Then maxr = rr
If gg < ming Then ming = gg
If gg > maxg Then maxg = gg
If bb < minb Then minb = bb
If bb > maxb Then maxb = bb
Next j
box2.minR = minr: box2.maxR = maxr
box2.minG = ming: box2.maxG = maxg
box2.minB = minb: box2.maxB = maxb
' Nahrazení původního boxu a přidání druhého
' Replacing the original box and adding a second one
Boxes(largestBoxIndex) = box1
ReDim _Preserve Boxes(boxCount) As BoxRange
Boxes(boxCount) = box2
boxCount = boxCount + 1
If boxCount >= desiredColors Then Exit Do
Loop
' 5) Pro každý box vypočítat průměrnou barvu a uložit do palety
' 5) Calculate the average color for each box and save it to the palette
Dim cIndex As Long: cIndex = 0
Dim sumR As Long, sumG As Long, sumB As Long, count As Long
For i = 0 To boxCount - 1
sumR = 0: sumG = 0: sumB = 0
count = Boxes(i).endIndex - Boxes(i).startIndex + 1
If count < 1 Then
paletteR(cIndex) = 0: paletteG(cIndex) = 0: paletteB(cIndex) = 0
cIndex = cIndex + 1
If cIndex > 255 Then Exit For
Else
For j = Boxes(i).startIndex To Boxes(i).endIndex
idxBox = pixelIndices(j)
sumR = sumR + sourceR(idxBox)
sumG = sumG + sourceG(idxBox)
sumB = sumB + sourceB(idxBox)
Next j
paletteR(cIndex) = sumR \ count
paletteG(cIndex) = sumG \ count
paletteB(cIndex) = sumB \ count
cIndex = cIndex + 1
If cIndex > 255 Then Exit For
End If
Next i
' Doplnění zbylých barev nulou
' Fill remaining colors with zero
Dim fillColor As Long
For fillColor = cIndex To 255
paletteR(fillColor) = 0
paletteG(fillColor) = 0
paletteB(fillColor) = 0
Next fillColor
End Sub
' ========================================================================
' SUB FloydSteinbergDither
' Provádí Floyd-Steinberg dithering – používá dataR!(), dataG!(), dataB!() jako SINGLE
' ========================================================================
Sub FloydSteinbergDither (dataR() As Single, dataG() As Single, dataB() As Single, w As Long, h As Long, paletteR() As Long, paletteG() As Long, paletteB() As Long, targetHandle As Long)
Screen targetHandle
Dim x As Long, y As Long
' Deklarace proměnných jako SINGLE
Dim oldR!, oldG!, oldB!
Dim newR!, newG!, newB!
Dim errR!, errG!, errB!
Dim idx As Long
For y = 0 To h - 1
For x = 0 To w - 1
oldR! = dataR!(x, y)
oldG! = dataG!(x, y)
oldB! = dataB!(x, y)
idx = FindNearestColorIndex%(oldR!, oldG!, oldB!, paletteR(), paletteG(), paletteB())
' Vykreslíme paletový index
' Draw palette index
PSet (x, y), idx
newR! = paletteR(idx)
newG! = paletteG(idx)
newB! = paletteB(idx)
errR! = oldR! - newR!
errG! = oldG! - newG!
errB! = oldB! - newB!
' Rozdistribuování chyby
' distribute colors error
If (x + 1) < w Then
dataR!(x + 1, y) = dataR!(x + 1, y) + errR! * (7.0! / 16.0!)
dataG!(x + 1, y) = dataG!(x + 1, y) + errG! * (7.0! / 16.0!)
dataB!(x + 1, y) = dataB!(x + 1, y) + errB! * (7.0! / 16.0!)
End If
If (x - 1) >= 0 And (y + 1) < h Then
dataR!(x - 1, y + 1) = dataR!(x - 1, y + 1) + errR! * (3.0! / 16.0!)
dataG!(x - 1, y + 1) = dataG!(x - 1, y + 1) + errG! * (3.0! / 16.0!)
dataB!(x - 1, y + 1) = dataB!(x - 1, y + 1) + errB! * (3.0! / 16.0!)
End If
If (y + 1) < h Then
dataR!(x, y + 1) = dataR!(x, y + 1) + errR! * (5.0! / 16.0!)
dataG!(x, y + 1) = dataG!(x, y + 1) + errG! * (5.0! / 16.0!)
dataB!(x, y + 1) = dataB!(x, y + 1) + errB! * (5.0! / 16.0!)
End If
If (x + 1) < w And (y + 1) < h Then
dataR!(x + 1, y + 1) = dataR!(x + 1, y + 1) + errR! * (1.0! / 16.0!)
dataG!(x + 1, y + 1) = dataG!(x + 1, y + 1) + errG! * (1.0! / 16.0!)
dataB!(x + 1, y + 1) = dataB!(x + 1, y + 1) + errB! * (1.0! / 16.0!)
End If
Next x
Next y
End Sub
' ========================================================================
' FUNCTION FindNearestColorIndex%
' Vrací index paletové barvy, která je nejblíže zadaným hodnotám (r, g, b)
' Returns the index of the palette color that is closest to the specified values ??(r, g, b)
' ========================================================================
Function FindNearestColorIndex% (r!, g!, b!, paletteR() As Long, paletteG() As Long, paletteB() As Long)
Dim bestIndex As Long, i As Long
Dim bestDist As Single
bestDist! = 1E+20
For i = 0 To 255
Dim dr!, dg!, db!, dist!
dr! = r! - paletteR(i)
dg! = g! - paletteG(i)
db! = b! - paletteB(i)
dist! = dr! * dr! + dg! * dg! + db! * db!
If dist! < bestDist! Then
bestDist! = dist!
bestIndex = i
End If
Next i
FindNearestColorIndex% = bestIndex
End Function
' ========================================================================
' SUB QuickSortIndices
' Rychlé řazení pole indexů podle hodnoty pixelu (podle compareComponent)
' Quickly sort an array of indices by pixel value (by compareComponent)
' ========================================================================
Sub QuickSortIndices (arr() As Long, left As Long, right As Long)
If left >= right Then Exit Sub
Dim pivot As Long
pivot = arr((left + right) \ 2)
Dim i As Long, j As Long
i = left: j = right
Do
Do While ComparePixels(arr(i), pivot) < 0
i = i + 1
Loop
Do While ComparePixels(arr(j), pivot) > 0
j = j - 1
Loop
If i <= j Then
Dim t As Long
t = arr(i)
arr(i) = arr(j)
arr(j) = t
i = i + 1
j = j - 1
End If
Loop While i <= j
If left < j Then QuickSortIndices arr(), left, j
If i < right Then QuickSortIndices arr(), i, right
End Sub
' ========================================================================
' FUNCTION ComparePixels&
' Porovná dva pixely (indexy v srcR(), srcG(), srcB()) podle nastavené složky (R/G/B)
' Compares two pixels (indexes in srcR(), srcG(), srcB()) according to the set component (R/G/B)
' ========================================================================
Function ComparePixels& (idxA As Long, idxB As Long)
Select Case compareComponent
Case 0: ComparePixels& = srcR(idxA) - srcR(idxB)
Case 1: ComparePixels& = srcG(idxA) - srcG(idxB)
Case 2: ComparePixels& = srcB(idxA) - srcB(idxB)
End Select
End Function