02-20-2025, 09:45 PM
4 bite BMP
So it's time for two more posts. I had problems with the second program, I finally solved it/didn't solve it - but now it works correctly even if it's not completely according to the specification.
The first program is a simple thing, saving and loading an uncompressed image into BMP in 4 bits, the number of colors for the image is a maximum of 16. The number of colors in the input image is not monitored. However, there is a function directly in the program for that, which does not monitor this, it just prints the number of colors after loading the created image.
So the first program: Uncompressed BMP 4 Bit, 16 colors:
Well, here's the second program. It creates an RLE - compressed 4-bit BMP file with a maximum of 16 colors. Since this format is not supported by the _LoadImage function, the program also includes a loader that loads and displays this format. The output file remains on disk, so you can check its compatibility, for example, in a photo viewer. Note the significant difference in the size of the output file compared to the previous program.
Above, I mentioned that there was a problem with the program that I solved/did not solve. If RLE encounters a point that has a different color than the points around it, it should switch to the so-called absolute encoding. The problem is that this implementation caused me to lose a part of image. Simply, after switching from RLE to absolute encoding, the rest of the image remained black. For this reason, I would like to point out that the program runs only in RLE mode, so an image that has poor content, unsuitable for RLE (that is, the image has few single-color areas and contains many small dots), the resulting size can paradoxically be much larger than in the uncompressed format. But then again, there is an option, if we know that the uncompressed version has a size of approximately (width * height)/2, then compare this number with the LOF of the resulting BMP and choose the saving method accordingly. When the problem is solved, I will update the program here and write a warning.
So it's time for two more posts. I had problems with the second program, I finally solved it/didn't solve it - but now it works correctly even if it's not completely according to the specification.
The first program is a simple thing, saving and loading an uncompressed image into BMP in 4 bits, the number of colors for the image is a maximum of 16. The number of colors in the input image is not monitored. However, there is a function directly in the program for that, which does not monitor this, it just prints the number of colors after loading the created image.
So the first program: Uncompressed BMP 4 Bit, 16 colors:
Code: (Select All)
'--------------------------------------------------- --------------------------------------------------
'Uloží obrázek s 16 barvami jako nekomprimovaný BMP Save image in max 16 colors as uncompressed bitmap
'--------------------------------------------------- --------------------------------------------------
Screen _NewImage(1024, 768, 32)
Dim img16 As Long
img16 = _NewImage(800, 600, 256)
_Dest img16 ' create some image
For f = 0 To 15
Line (0 + 20 * f, 0 + 20 * f)-(800 - 20 * f, 600 - 20 * f), f, BF
Next
_Dest 0
outFile$ = "16-4-not_compressed.bmp"
Print "Creating uncompressed 4 bit bitmap with 16 colors..."
SaveAs4BitBMP img16, outFile$
_FreeImage img16
i = _LoadImage(outFile$, 256)
_PutImage , i
Print "File "; outFile$; " saved. _LoadImage support this format."
Print "Image use: "; ClrsCnt(i); "colors." ' Výpis informací o obrázku Print image details
Print "Image width: "; _Width(i); "Image height: "; _Height(i); "Image size: "; GetSze("outfile$"); "B Image PixelSize:"; _PixelSize(i)
Sleep
_FreeImage i
End
Function GetSze (file As String) ' Vrací velikost souboru v bajtech Returns file size in bytes
ff = FreeFile
Open file For Binary As ff
GetSze = LOF(ff)
Close ff
End Function
Sub SaveAs4BitBMP (sourceImg As Long, outputFile$) ' Uložit nekomprimovaný BMP formát (4 bit) save uncompressed BMP format (4 bit)
' Vstup: 8bitový obrázek, maximálně 16 unikátních barev. Input: 8 bit image with max 16 colors
' Výstup: BMP soubor ve 4bitovém režimu (16 barev). Output: 4 bit image with max 16 colors
Type BMP4BitHeader
signature As String * 2
fileSize As Long
reserved1 As Integer
reserved2 As Integer
dataOffset As Long
infoHeaderSize As Long
width As Long
height As Long
planes As Integer
bitsPerPixel As Integer
compression As Long
imageSize As Long
xPelsPerMeter As Long
yPelsPerMeter As Long
colorsUsed As Long
importantColors As Long
'colorTable(15) AS _UNSIGNED LONG 16 barev (4 bajty na jednu barvu) Color palette contains 4 byte to 1 color
End Type
'===== Krok 1: Zjistíme rozměry obrázku ===== Determine image dimensions
Dim W As Long, H As Long
W = _Width(sourceImg)
H = _Height(sourceImg)
'===== Krok 2: Zjistíme, které paletové indexy se v obrázku používají ===== Determine which palette indices are used in the image
Dim memSrc As _MEM
memSrc = _MemImage(sourceImg)
Dim totalPixels As Long
totalPixels = memSrc.SIZE
' Pomocné pole – pro každý index 0..255 (0 = nepoužito, 1 = použit) Helper array – for each index 0..255 (0 = unused, 1 = used)
Dim used(0 To 255) As _Byte
Dim i As Long
Dim pixVal As _Unsigned _Byte
For i = 0 To totalPixels - 1
pixVal = _MemGet(memSrc, memSrc.OFFSET + i, _Unsigned _Byte)
used(pixVal) = 1
Next i
' Sestavíme finální paletu: pole finPal obsahuje všechny (použité) indexy Build final palette: the finPal array contains all (used) indices
Dim finPal(0 To 15) As _Unsigned _Byte
Dim usedCount As Long: usedCount = 0
Dim k As Long
For k = 0 To 255
If used(k) <> 0 Then
finPal(usedCount) = k
usedCount = usedCount + 1
If usedCount > 16 Then
Print "Input image contains more than 16 colors."
End
End If
End If
Next k
'===== Krok 3: Načteme barvy palety pomocí _PaletteColor Load palette colors using _PaletteColor
' Vytvoříme pole ColorTable, kde pro každý ze 16 indexů bude uložena 32bitová barva. Create ColorTable array, where for each of the 16 indices, a 32-bit color is stored.
Dim ColorTable(0 To 15) As _Unsigned Long
For i = 0 To 15
If i < usedCount Then
ColorTable(i) = _PaletteColor(finPal(i), sourceImg)
Else
ColorTable(i) = 0
End If
Next i
'===== Krok 4: Připravíme hlavičku BMP pro 4bitový obrázek Prepare BMP header for 4-bit image
' Definice typu BMP4BitHeader musí být již deklarována (viz váš původní kód). The BMP4BitHeader type definition must already be declared (see your original code).
Dim bmp As BMP4BitHeader
bmp.signature = "BM"
bmp.reserved1 = 0
bmp.reserved2 = 0
bmp.infoHeaderSize = 40
bmp.width = W
bmp.height = H
bmp.planes = 1
bmp.bitsPerPixel = 4
bmp.compression = 0
bmp.xPelsPerMeter = 0
bmp.yPelsPerMeter = 0
bmp.colorsUsed = 16
bmp.importantColors = 0
' V BMP se data ukládají jako řádky, kde každý pixel = 4 bity. In BMP, data is stored in rows, with each pixel equal to 4 bits.
' Počet bajtů na řádek = CEILING(W/2). Každý řádek se zarovnává na 4 bajty. Number of bytes per row = CEILING(W/2). Each row is aligned to 4 bytes.
Dim bytesPerRow As Long
bytesPerRow = (W + 1) \ 2 ' (W+1)\2 dává počet bajtů (správně funguje pro lichou i sudou šířku)
If (bytesPerRow Mod 4) <> 0 Then
bytesPerRow = bytesPerRow + (4 - (bytesPerRow Mod 4))
End If
bmp.imageSize = bytesPerRow * H
bmp.dataOffset = 14 + 40 + (16 * 4) '14 = FileHeader, 40 = InfoHeader, 64 = palette
bmp.fileSize = bmp.dataOffset + bmp.imageSize
'===== Krok 5: Převod pixelových dat z 8bitového formátu do 4bitového Convert pixel data from 8-bit format to 4-bit format.
' Vstupní obrázek obsahuje pro každý pixel jeden bajt – index do palety. Input image contains one byte per pixel – palette index.
' V BMP 4bit formátu je každý bajt složen ze dvou 4bitových hodnot (nibble). In 4-bit BMP format, each byte consists of two 4-bit values (nibbles).
' Proto potřebujeme vytvořit buffer pro pixel data. Therefore we need to create a buffer for pixel data.
Dim pixelData As String
pixelData = String$(bmp.imageSize, Chr$(0))
' Připravíme remapování – vstupní index › nový index (0 až usedCount-1) Prepare remapping – input index to new index (0 to usedCount-1)
Dim remap(0 To 255) As _Unsigned _Byte
For i = 0 To 255
remap(i) = 255 'inicializace (neplatná hodnota)
Next i
For i = 0 To usedCount - 1
remap(finPal(i)) = i
Next i
' Budeme číst obrázek po řádcích. We will read the image row by row.
'BMP ukládá řádky zdola nahoru, zatímco paměť obrázku je obvykle odshora. BMP stores rows from bottom to top, while image memory is usually top-down.
Dim outPos As Long: outPos = 0
Dim rowStr As String
Dim nibbleByte As _Unsigned _Byte
Dim x As Long, y As Long
For y = 0 To H - 1
rowStr = String$(bytesPerRow, Chr$(0))
Dim lineY As Long
lineY = H - 1 - y ' řádek v paměti obrázku Image row in memory
Dim rowOffset As Long
rowOffset = lineY * W ' protože 1 bajt na pixel
nibbleByte = 0
For x = 0 To W - 1
Dim srcIndex As Long
srcIndex = rowOffset + x
Dim pix8 As _Unsigned _Byte
pix8 = _MemGet(memSrc, memSrc.OFFSET + srcIndex, _Unsigned _Byte)
' Přemapování: získáme nový 4bitový index Remapping: obtain new 4-bit index
Dim newIndex As _Unsigned _Byte
newIndex = remap(pix8)
If (x Mod 2) = 0 Then
'Horní nibble Upper nibble
nibbleByte = _ShL(newIndex, 4)
Else
'Dolní nibble Lower nibble
nibbleByte = nibbleByte Or (newIndex And &HF)
' Uložíme bajt do řádku (pozice: (x\2)+1) Save byte into row (position: (x\2)+1)
Mid$(rowStr, (x \ 2) + 1, 1) = Chr$(nibbleByte)
nibbleByte = 0
End If
Next x
' Pokud je šířka lichá, uložíme poslední nibble: If the width is odd, store the last nibble:
If (W Mod 2) = 1 Then
Mid$(rowStr, (W \ 2) + 1, 1) = Chr$(nibbleByte)
End If
' Zkopírujeme řádek do pixelData Copy the row into pixelData.
Mid$(pixelData, outPos + 1, Len(rowStr)) = rowStr
outPos = outPos + bytesPerRow
Next y
'===== Krok 6: Zápis BMP souboru Write BMP file.
If _FileExists(outputFile$) Then Kill outputFile$
Open outputFile$ For Binary As #1
'FileHeader (14 bajtů) FileHeader (14 bytes)
Put #1, , bmp.signature
Put #1, , bmp.fileSize
Put #1, , bmp.reserved1
Put #1, , bmp.reserved2
Put #1, , bmp.dataOffset
'InfoHeader (40 bajtů) InfoHeader (40 bytes)
Put #1, , bmp.infoHeaderSize
Put #1, , bmp.width
Put #1, , bmp.height
Put #1, , bmp.planes
Put #1, , bmp.bitsPerPixel
Put #1, , bmp.compression
Put #1, , bmp.imageSize
Put #1, , bmp.xPelsPerMeter
Put #1, , bmp.yPelsPerMeter
Put #1, , bmp.colorsUsed
Put #1, , bmp.importantColors
'Paleta: 16 barev, každý 4 bajty Palette: 16 colors, each 4 bytes
For i = 0 To 15
Put #1, , ColorTable(i)
Next i
'Pixelová data Pixel data
Put #1, , pixelData
Close #1
'Uvolnění paměťového bloku zdrojového obrázku (nebo jej ponechte, pokud se dále používá) Release the memory block of the source image (or keep it if used further)
_MemFree memSrc
End Sub
Function ClrsCnt (handle As Long)
'Vrátí počet unikátních barev v obrázku Returns the count of unique colors in the image
Dim As _Unsigned _Byte r, g, b
Dim As _MEM m
Dim As Long a, Clrscn
m = _MemImage(handle)
If _PixelSize(handle) > 1 Then
Dim c(255, 255, 255) As _Unsigned _Byte
Do Until a = m.SIZE
_MemGet m, m.OFFSET + a, b
_MemGet m, m.OFFSET + a + 1, g
_MemGet m, m.OFFSET + a + 2, r
a = a + 4
If c(r, g, b) = 0 Then
Clrscn = Clrscn + 1
c(r, g, b) = 1
End If
Loop
ClrsCnt = Clrscn
Else
Dim d(255) As _Byte
Do Until a = m.SIZE
index = _MemGet(m, m.OFFSET + a, _Unsigned _Byte)
If d(index) = 0 Then
d(index) = 1
Clrscn = Clrscn + 1
End If
a = a + 1
Loop
ClrsCnt = Clrscn
End If
End Function
Well, here's the second program. It creates an RLE - compressed 4-bit BMP file with a maximum of 16 colors. Since this format is not supported by the _LoadImage function, the program also includes a loader that loads and displays this format. The output file remains on disk, so you can check its compatibility, for example, in a photo viewer. Note the significant difference in the size of the output file compared to the previous program.
Above, I mentioned that there was a problem with the program that I solved/did not solve. If RLE encounters a point that has a different color than the points around it, it should switch to the so-called absolute encoding. The problem is that this implementation caused me to lose a part of image. Simply, after switching from RLE to absolute encoding, the rest of the image remained black. For this reason, I would like to point out that the program runs only in RLE mode, so an image that has poor content, unsuitable for RLE (that is, the image has few single-color areas and contains many small dots), the resulting size can paradoxically be much larger than in the uncompressed format. But then again, there is an option, if we know that the uncompressed version has a size of approximately (width * height)/2, then compare this number with the LOF of the resulting BMP and choose the saving method accordingly. When the problem is solved, I will update the program here and write a warning.
Code: (Select All)
'BMP - RLE4 (16 colors) for qb64pe in cooperation. Create image. Save as RLE format. Load it. Show it.
Const SCR_WIDTH = 800 ' Nastavení šířky obrazovky Set screen width
Const SCR_HEIGHT = 600 ' Nastavení výšky obrazovky Set screen height
Const DEBUG_MODE = 0 'allow = 1 Povolení ladicího režimu Enable debug mode (now is disabled)
Dim Shared debugFileNum As Integer ' Sdílená proměnná pro číslo logovacího souboru Shared variable for debug file number
If DEBUG_MODE Then ' Pokud je ladicí režim zapnutý If debug mode is enabled
debugFileNum = FreeFile ' Získání volného čísla souboru Get free file number
Open "debug.log" For Output As #debugFileNum ' Otevření logovacího souboru pro výstup Open debug.log for output
Print #debugFileNum, "=== Debug Log - Start ===" ' Zápis začátku logu Print debug log header
End If ' Konec ladicí podmínky End debug mode block
Dim img16 As Long ' Deklarace proměnné pro obrázek Declare variable for image
img16 = _NewImage(SCR_WIDTH, SCR_HEIGHT, 256) ' Vytvoření nového obrázku s 256 barvami Create a new image with 256 colors
_Dest img16 ' Nastavení cílového obrázku ' Set destination image
Cls , 4 ' Vyčištění obrazovky s barvou 4 Clear screen with color 4
Locate 10, 1 ' Nastavení pozice kurzoru Set cursor position
For f = 0 To 15 ' Smyčka přes 16 barev Loop over 16 colors
Line (0 + 20 * f, 0 + 20 * f)-(800 - 20 * f, 600 - 20 * f), f, BF
Next ' Konec smyčky End loop
_PrintMode _KeepBackground ' Nastavení režimu tisku tak, aby se zachovalo pozadí Set print mode to keep background
Color 0 ' Nastavení barvy textu na 0 Set text color to 0
Print ' Vytisknutí prázdného řádku Print blank line
Print " Hi QB64PE Team. I am your first RLE - compressed 16 colors bitmap!"
Print " Because _LoadImage can't load my format, is used own loader!"
_Dest 0
Print "Saving image to file 'testRLE4.bmp'"
Sleep 2
SaveAs4BitRLEBMP img16, "testRLE4.bmp"
Dim loadedImg As Long
loadedImg = _LoadImage("testRLE4.bmp", 256) ' Load image using built-in _LoadImage (always failure, but you can test bmp file with windows photo viewer)
Screen _NewImage(800, 600, 32)
Print "Hm... Returned by _LoadImage: "; loadedImg
Sleep 2
image& = Load4BitRLEBMP("testRLE4.bmp") ' Načtení obrázku pomocí vlastního loaderu Load image using custom loader
_PutImage , image& ' Zobrazení načteného obrázku Display the loaded image
Print "So use own loader..." '
Print "Image width: "; _Width(image&); "Image height: "; _Height(image&); "Image size: "; GetSze("testRLE4.bmp"); "B Image PixelSize:"; _PixelSize(image&) ' Výpis informací o obrázku ' Print image details
Sleep
If DEBUG_MODE Then
Print #debugFileNum, "=== Debug Log - Konec ===" ' Výpis konce logu Print debug log end
Close #debugFileNum ' Zavření logovacího souboru Close debug file
End If ' Konec ladicí podmínky End debug mode block
' ============================================================
' Typ BMP4BitHeader ' BMP header type definition
' ============================================================
Type BMP4BitHeader ' Definice struktury BMP hlavičky Define BMP header structure
signature As String * 2 ' Podpis BMP souboru ("BM") BMP file signature ("BM")
fileSize As Long ' Celková velikost souboru Total file size
reserved1 As Integer ' Rezervované pole Reserved field 1
reserved2 As Integer ' Rezervované pole Reserved field 2
dataOffset As Long ' Offset, kde začínají obrazová data Data offset from file start
infoHeaderSize As Long ' Velikost informační hlavičky Info header size
width As Long ' Šířka obrázku Image width
height As Long ' Výška obrázku Image height
planes As Integer ' Počet rovin (vždy 1) Number of planes (always 1)
bitsPerPixel As Integer ' Bity na pixel Bits per pixel
compression As Long ' Typ komprese (pro RLE4: 2) Compression type (RLE4: 2)
imageSize As Long ' Velikost obrazových dat Image data size
xPelsPerMeter As Long ' Horizontální rozlišení Horizontal resolution
yPelsPerMeter As Long ' Vertikální rozlišení Vertical resolution
colorsUsed As Long ' Počet použitých barev Colors used
importantColors As Long ' Počet důležitých barev Important colors
End Type ' Konec definice BMP4BitHeader End BMP4BitHeader definition
' ============================================================
' Funkce: GetSze
' ============================================================
Function GetSze (file As String) ' Vrací velikost souboru v bajtech Returns file size in bytes
ff = FreeFile
Open file For Binary As ff
GetSze = LOF(ff)
Close ff '
End Function '
' ============================================================
' SUB: SaveAs4BitRLEBMP ' Sub: SaveAs4BitRLEBMP
' ============================================================
Sub SaveAs4BitRLEBMP (sourceImg As Long, outputFile$) ' Uloží obrázek ve formátu 4-bit BMP s RLE4 kompresí Save image in 4-bit BMP with RLE4 compression
Dim w As Long, h As Long ' Deklarace proměnných pro rozměry obrázku Declare image dimension variables
w = _Width(sourceImg) ' Získání šířky obrázku Get image width
h = _Height(sourceImg) ' Získání výšky obrázku Get image height
Dim totalPixels As Long ' Celkový počet pixelů Total number of pixels
totalPixels = w * h ' Výpočet celkového počtu pixelů Calculate total pixels
Dim memSrc As _MEM ' Paměťová oblast zdrojového obrázku Source image memory block
memSrc = _MemImage(sourceImg) ' Získání paměťové oblasti Get image memory block
Dim used(0 To 255) As _Unsigned _Byte ' Pole pro použití barev Array to track used colors
Dim i As Long
For i = 0 To 255 ' Inicializace pole pro 256 barev Initialize used array for 256 colors
used(i) = 0 ' Nastavení hodnoty na 0 Set to 0
Next i
Dim tVal As _Unsigned _Byte
For i = 0 To totalPixels - 1 ' Pro každý pixel v obrázku For each pixel in image
tVal = _MemGet(memSrc, memSrc.OFFSET + i, _Unsigned _Byte) ' Načtení hodnoty pixelu Get pixel value
used(tVal) = 1 ' Označení, že barva byla použita Mark color as used
Next i
Dim finPal(0 To 15) As _Unsigned _Byte ' Finální paleta (max 16 barev) Final palette (max 16 colors)
Dim usedCount As Long: usedCount = 0 ' Počet použitých barev Count of used colors
Dim c As Long
For c = 0 To 255 ' Pro každou barvu For each color
If used(c) <> 0 Then ' Pokud je barva použita If color is used
finPal(usedCount) = c ' Uložení barvy do finální palety Save color to final palette
usedCount = usedCount + 1 ' Zvýšení počtu použitých barev Increment used color count
If usedCount > 16 Then ' Pokud je více než 16 barev If more than 16 colors
Print "Input image has more than 16 colors!" ' Chybová hláška Error message
End ' Ukončení programu ' End program
End If
End If
Next c
Dim remap(0 To 255) As _Unsigned _Byte ' Remapovací pole pro změnu indexů barev Remapping array for color indices
For i = 0 To 255
remap(i) = 255 ' Inicializace remapovacího pole Initialize remap array
Next i
For i = 0 To usedCount - 1 ' Pro každou použitou barvu For each used color
remap(finPal(i)) = i ' Přiřazení nového indexu Assign new index
Next i
Dim ColorTable(0 To 15) As _Unsigned Long ' Tabulka barev pro BMP Color table for BMP
For i = 0 To 15
If i < usedCount Then
ColorTable(i) = _PaletteColor(finPal(i), sourceImg) ' Načtení barvy z palety zdroje Get color from source palette
Else
ColorTable(i) = 0 ' Nepoužité barvy nastavit na 0 Set unused colors to 0
End If
Next i
Dim bmp As BMP4BitHeader ' Deklarace struktury BMP hlavičky Declare BMP header structure
bmp.signature = "BM" ' Nastavení podpisu BMP Set BMP signature
bmp.reserved1 = 0 ' Rezervované pole Reserved field 1
bmp.reserved2 = 0 ' Rezervované pole Reserved field 2
bmp.infoHeaderSize = 40 ' Velikost informační hlavičky Info header size
bmp.width = w ' Šířka obrázku Image width
bmp.height = h ' Výška obrázku Image height
bmp.planes = 1 ' Počet rovin Number of planes
bmp.bitsPerPixel = 4 ' Bity na pixel Bits per pixel
bmp.compression = 2 ' RLE4 komprese RLE4 compression
bmp.xPelsPerMeter = 0 ' Horizontální rozlišení Horizontal resolution
bmp.yPelsPerMeter = 0 ' Vertikální rozlišení Vertical resolution
bmp.colorsUsed = 16 ' Počet barev v paletě Number of colors used
bmp.importantColors = 0 ' Všechny barvy jsou důležité All colors are important
Dim rowPitch As Long ' Výpočet délky řádku v bajtech Calculate row pitch in bytes
rowPitch = ((w + 3) \ 4) * 4 ' Zarovnání řádku na 4 bajty Align row to 4 bytes
Dim indexArray(0 To totalPixels - 1) As _Unsigned _Byte ' Pole indexů pixelů Array for pixel indices
Dim pixPos As Long: pixPos = 0 ' Počáteční pozice v indexArray Starting index position
Dim y As Long, x As Long
For y = 0 To h - 1 ' Smyčka přes všechny řádky Loop through all rows
Dim srcY As Long
srcY = (h - 1) - y ' BMP řádky jsou uloženy odspodu nahoru BMP rows are stored bottom-up
Dim rowOff As Long
rowOff = srcY * rowPitch ' Výpočet offsetu řádku v paměti Calculate row offset in memory
For x = 0 To w - 1 ' Smyčka přes všechny sloupce Loop through all columns
Dim p8 As _Unsigned _Byte
p8 = _MemGet(memSrc, memSrc.OFFSET + rowOff + x, _Unsigned _Byte) ' Načtení pixelu ze zdrojového obrázku Get pixel from source image
indexArray(pixPos) = remap(p8) ' Remapování původního indexu na nový Remap original pixel index
pixPos = pixPos + 1 ' Posun v indexArray Increment index position
Next x
Next y
Dim rleData As String: rleData = "" ' Inicializace řetězce pro RLE data Initialize string for RLE data
Dim rowOfs As Long: rowOfs = 0 ' Offset pro každý řádek v indexArray Row offset in indexArray
For y = 1 To h ' Smyčka přes každý řádek Loop for each row
Dim rowStr As String
rowStr = CompressRowRLE4(indexArray(), rowOfs, w) ' Komprimace řádku do RLE4 Compress row using RLE4
rleData = rleData + rowStr ' Přidání komprimovaného řádku do výsledného řetězce Append compressed row data
rleData = rleData + Chr$(0) + Chr$(0) ' Zápis konec řádku (0,0) Write end-of-line marker (0,0)
rowOfs = rowOfs + w ' Posun na další řádek v indexArray Move to next row in index array
Next y
rleData = rleData + Chr$(0) + Chr$(1) ' Zápis ukončovacího příkazu (0,1) Write end-of-bitmap marker (0,1)
bmp.imageSize = Len(rleData) ' Nastavení velikosti obrazových dat Set image data size
bmp.dataOffset = 14 + 40 + (16 * 4) ' Výpočet offsetu dat (hlavička + paleta) Calculate data offset (header + palette)
bmp.fileSize = bmp.dataOffset + bmp.imageSize ' Výpočet celkové velikosti souboru Calculate total file size
_MemFree memSrc ' Uvolnění paměti zdrojového obrázku Free memory of source image
If _FileExists(outputFile$) Then Kill outputFile$ ' Smazání existujícího souboru, pokud existuje Delete existing file if any
Dim fileNum As Integer: fileNum = FreeFile ' Získání volného čísla souboru pro zápis Get free file number for output
Open outputFile$ For Binary As #fileNum ' Otevření souboru pro binární zápis Open output file for binary writing
Put #fileNum, , bmp.signature ' Zápis podpisu BMP do souboru Write BMP signature to file
Put #fileNum, , bmp.fileSize ' Zápis celkové velikosti souboru Write total file size
Put #fileNum, , bmp.reserved1 ' Zápis rezervovaných bajtů Write reserved field 1
Put #fileNum, , bmp.reserved2 ' Zápis rezervovaných bajtů Write reserved field 2
Put #fileNum, , bmp.dataOffset ' Zápis offsetu dat Write data offset
Put #fileNum, , bmp.infoHeaderSize ' Zápis velikosti informační hlavičky Write info header size
Put #fileNum, , bmp.width ' Zápis šířky obrázku Write image width
Put #fileNum, , bmp.height ' Zápis výšky obrázku Write image height
Put #fileNum, , bmp.planes ' Zápis počtu rovin Write number of planes
Put #fileNum, , bmp.bitsPerPixel ' Zápis bitů na pixel Write bits per pixel
Put #fileNum, , bmp.compression ' Zápis typu komprese Write compression type
Put #fileNum, , bmp.imageSize ' Zápis velikosti obrazových dat Write image data size
Put #fileNum, , bmp.xPelsPerMeter ' Zápis horizontálního rozlišení Write horizontal resolution
Put #fileNum, , bmp.yPelsPerMeter ' Zápis vertikálního rozlišení Write vertical resolution
Put #fileNum, , bmp.colorsUsed ' Zápis počtu použitých barev Write number of colors used
Put #fileNum, , bmp.importantColors ' Zápis počtu důležitých barev Write number of important colors
For i = 0 To 15 ' Smyčka pro zápis palety Loop to write palette
Put #fileNum, , ColorTable(i) ' Zápis barvy z palety Write palette color
Next i
Put #fileNum, , rleData ' Zápis RLE4 dat Write RLE4 compressed data
Close #fileNum ' Zavření souboru Close file
End Sub
' ============================================================ ' ============================================================
' Funkce: CompressRowRLE4 – s okamžitým flushováním, když runLen=1 ' Function: CompressRowRLE4 – immediate flush when runLen=1
' ============================================================ ' ============================================================
Function CompressRowRLE4$ (rowNibbles() As _Unsigned _Byte, start As Long, rowWidth As Long)
Dim result As String: result = "" ' Inicializace výsledného řetězce Initialize result string
Dim maxIndex As Long: maxIndex = UBound(rowNibbles) ' Zjištění maximálního indexu v poli Get maximum index of array
Dim i As Long: i = 0 ' Počáteční index ' Initialize index to 0
If DEBUG_MODE Then Print #debugFileNum, "=== Zpracování řádku, start=", start, " rowWidth=", rowWidth ' Debug: start row processing Debug: row processing start
Do While i < rowWidth ' Smyčka přes pixely v řádku Loop through pixels in row
If (start + i) > maxIndex Then Exit Do ' Pokud jsme mimo pole, ukončíme Exit if index exceeds array bounds
Dim currentVal As _Unsigned _Byte: currentVal = rowNibbles(start + i) ' Načtení aktuální hodnoty nibble Get current nibble value
If DEBUG_MODE Then Print #debugFileNum, "i=", i, " currentVal=", currentVal ' Debug: tisk aktuální hodnoty Debug: print current value
Dim runLen As Long: runLen = 1 ' Inicializace délky opakování Initialize run length
Dim j As Long: j = i + 1 ' Nastavení dalšího indexu pro porovnání Set index for comparison
Do While (j < rowWidth) And ((start + j) <= maxIndex)
If rowNibbles(start + j) <> currentVal Then Exit Do ' Pokud se hodnota liší, ukončíme smyčku Exit if nibble differs
runLen = runLen + 1 ' Zvýšení délky opakování Increment run length
If runLen >= 255 Then Exit Do ' Limit délky opakování na 255 Limit run length to 255
j = j + 1 ' Posun indexu ' Increment index
Loop
If DEBUG_MODE Then Print #debugFileNum, "i=", i, " Detekován run s currentVal=", currentVal, " runLen=", runLen ' Debug: tisk zjištěného runu Debug: print run detected
' Zpracování kódovaného (run) bloku
If runLen >= 1 Then
Dim remain As Long: remain = runLen ' N astavení zbývající délky Set remaining run length
Do While remain > 255
result = result + Chr$(255) + Chr$(_ShL(currentVal, 4) Or currentVal) ' Zápis bloku s 255 opakováními Write block of 255 repeats
If DEBUG_MODE Then Print #debugFileNum, "Zapsán run blok: délka=255, currentVal=", currentVal ' Debug: tisk zapsaného bloku Debug: print block written
remain = remain - 255 ' Odečtení 255 opakování ' Subtract 255 from run length
Loop
result = result + Chr$(remain) + Chr$(_ShL(currentVal, 4) Or currentVal) ' Zápis zbývajícího run bloku Write remaining run block
If DEBUG_MODE Then Print #debugFileNum, "Zapsán run blok: délka=", remain, " currentVal=", currentVal ' Debug: tisk posledního bloku Debug: print last block
i = i + runLen ' Posun indexu o délku runu Increment index by run length
End If
Loop
If DEBUG_MODE Then Print #debugFileNum, "=== Konec zpracování řádku ===" ' Debug: konec zpracování řádku Debug: end of row processing
CompressRowRLE4 = result ' Vrácení komprimovaného řádku Return compressed row string
End Function
' ============================================================
' Funkce: FlushAbsoluteBlock
' ============================================================
Function FlushAbsoluteBlock$ (absData As String, absCount As Long)
Dim ut As String: ut = "" ' Inicializace výstupního řetězce Initialize output string
ut = ut + Chr$(0) + Chr$(absCount) ' Zápis značky absolutního bloku a délky Write absolute block marker and length
Dim tmp As String: tmp = "" ' Dočasný řetězec pro kombinaci nibblů Temporary string for combined nibbles
Dim n As Long: n = 1 ' Počáteční index Initialize index to 1
Do While n <= Len(absData) ' Smyčka přes absolutní data Loop through absolute data
Dim nib1 As _Unsigned _Byte: nib1 = Asc(Mid$(absData, n, 1)) ' Načtení prvního nibble Get first nibble
Dim nib2 As _Unsigned _Byte: nib2 = 0 ' Inicializace druhého nibble Initialize second nibble
If (n + 1) <= Len(absData) Then nib2 = Asc(Mid$(absData, n + 1, 1)) ' Načtení druhého nibble, pokud existuje Get second nibble if available
Dim combined As _Unsigned _Byte: combined = _ShL((nib1 And &HF), 4) Or (nib2 And &HF) ' Kombinace dvou nibblů do jednoho bajtu Combine two nibbles into one byte
tmp = tmp + Chr$(combined) ' Přidání kombinovaného bajtu do dočasného řetězce Append combined byte to temporary string
n = n + 2 ' Posun indexu o 2 Increment index by 2
Loop
ut = ut + tmp ' Připojení kombinovaných bajtů k výstupnímu řetězci Append combined bytes to output
Dim byteCount As Long: byteCount = (absCount + 1) \ 2 ' Výpočet počtu bajtů v absolutním bloku Calculate number of bytes in absolute block
If (byteCount Mod 2) = 1 Then ut = ut + Chr$(0) ' Přidání padovacího bajtu, pokud je počet bajtů lichý Add padding byte if odd number of bytes
FlushAbsoluteBlock = ut ' Vrácení výsledného absolutního bloku Return absolute block string
End Function
' ============================================================
' Funkce: Load4BitRLEBMP
' ============================================================
' Načte BMP soubor s RLE4 kompresí, který byl vytvořen pomocí našeho SaveAs4BitRLEBMP.
' POZN.: Tento loader používá stejnou “podmínku”, jakou má náš save routine – tedy vždy, když je bajt count nenulový,
' je to kódovaný blok (run block), i kdyby count=1, což není úplně podle standardní specifikace - ale funguje správnš.
' Loads a BMP file with RLE4 compression produced by our save routine.
' NOTE: This loader uses the same condition as our save routine – if the count byte is nonzero,
' it treats the block as a run block (even if count=1), which is non-standard - but works correctly.
Function Load4BitRLEBMP& (fileName$)
' Otevře BMP soubor, načte hlavičku, paletu a RLE4 data a dekóduje je do nového obrázku.
' Opens the BMP file, reads header, palette, and RLE4 data, and decodes them into a new image.
Dim fileNum As Integer: fileNum = FreeFile ' Získání volného čísla souboru Get free file number
Open fileName$ For Binary As #fileNum ' Otevření BMP souboru pro binární čtení Open BMP file for binary reading
' Načtení hlavičky (14 bajtů)
Dim signature As String * 2 ' BMP podpis BMP signature
Dim fileSize As Long, reserved1 As Integer, reserved2 As Integer, dataOffset As Long ' Hlavičková data Header data
Get #fileNum, , signature ' Čtení podpisu Read signature
If signature <> "BM" Then ' Kontrola podpisu Verify signature
Print "Není to BMP soubor!" ' Chybová zpráva Error: Not a BMP file
Close #fileNum ' Zavření souboru Close file
Load4BitRLEBMP = 0 ' Vrácení 0 jako chyba Return 0 as error
Exit Function
End If
Get #fileNum, , fileSize ' Čtení celkové velikosti souboru Read total file size
Get #fileNum, , reserved1 ' Čtení rezervovaných bajtů Read reserved field 1
Get #fileNum, , reserved2 ' Čtení rezervovaných bajtů Read reserved field 2
Get #fileNum, , dataOffset ' Čtení offsetu dat Read data offset
' Načtení BITMAPINFOHEADER (40 bajtů)
Dim infoHeaderSize As Long, width As Long, height As Long ' Data hlavičky obrázku Image header data
Dim planes As Integer, bitsPerPixel As Integer, compression As Long ' Další hlavičková data Additional header info
Dim imageSize As Long, xPelsPerMeter As Long, yPelsPerMeter As Long ' Velikost dat a rozlišení Image size and resolution
Dim colorsUsed As Long, importantColors As Long ' Počet použitých a důležitých barev Colors used and important colors
Get #fileNum, , infoHeaderSize ' Čtení velikosti informační hlavičky Read info header size
Get #fileNum, , width ' Čtení šířky obrázku Read image width
Get #fileNum, , height ' Čtení výšky obrázku Read image height
Get #fileNum, , planes ' Čtení počtu rovin Read number of planes
Get #fileNum, , bitsPerPixel ' Čtení bitů na pixel Read bits per pixel
Get #fileNum, , compression ' Čtení typu komprese Read compression type
Get #fileNum, , imageSize ' Čtení velikosti obrazových dat Read image data size
Get #fileNum, , xPelsPerMeter ' Čtení horizontálního rozlišení Read horizontal resolution
Get #fileNum, , yPelsPerMeter ' Čtení vertikálního rozlišení Read vertical resolution
Get #fileNum, , colorsUsed ' Čtení počtu použitých barev Read number of colors used
Get #fileNum, , importantColors ' Čtení počtu důležitých barev Read number of important colors
If bitsPerPixel <> 4 Then ' Kontrola, zda se jedná o 4-bit BMP Verify image is 4-bit
Print "Nejedná se o 4-bit BMP!" ' Chybová zpráva Error: Not a 4-bit BMP
Close #fileNum ' Zavření souboru Close file
Load4BitRLEBMP = 0 ' Vrácení 0 jako chybu Return 0 as error
Exit Function
End If
' Načtení palety – 16 barev, každý 4 bajty (B, G, R, 0)
Dim pal(0 To 15) As _Unsigned Long ' Deklarace palety pro 16 barev Declare palette for 16 colors
Dim i As Long
For i = 0 To 15 ' Smyčka pro 16 barev Loop for 16 colors
Dim blue As _Unsigned _Byte, green As _Unsigned _Byte, red As _Unsigned _Byte, reserved As _Unsigned _Byte
Get #fileNum, , blue ' Načtení modré složky Read blue component
Get #fileNum, , green ' Načtení zelené složky Read green component
Get #fileNum, , red ' Načtení červené složky Read red component
Get #fileNum, , reserved ' Načtení rezervovaného bajtu Read reserved byte
pal(i) = red * 65536 + green * 256 + blue ' Sestavení barvy ve formátu &H00RRGGBB Construct color as &H00RRGGBB
Next i
' Přesunutí čtecí pozice na začátek obrazových dat Seek to start of image data
Seek #fileNum, dataOffset + 1 ' Použití dataOffset + 1 (kvůli 1-indexování) Use dataOffset + 1 for 1-indexing
' Načtení RLE dat Read RLE data
Dim rleData As String
rleData = Space$(imageSize) ' Inicializace řetězce pro RLE data Initialize RLE data string
Get #fileNum, , rleData ' Načtení RLE dat do řetězce Read RLE data
Close #fileNum ' Zavření souboru Close file
' Vytvoření nového obrázku s rozměry width x height Create new image with dimensions from header
Dim img As Long
img = _NewImage(width, height, 256) ' Vytvoření 256barevného obrázku Create a 256-color image
For i = 0 To 15 ' Smyčka pro nastavení palety Loop to set palette
_PaletteColor i, pal(i), img ' Nastavení palety obrázku Set image palette color
Next i
' Získání paměťové oblasti nového obrázku Get memory block for image
Dim memImg As _MEM
memImg = _MemImage(img)
' Výpočet řádkové délky v bajtech Calculate row pitch in bytes
Dim rowPitch As Long
rowPitch = ((width + 3) \ 4) * 4 ' Zarovnání řádků na 4 bajty Align rows to 4 bytes
' Dekódování RLE dat – BMP ukládá řádky odspodu nahoru Decode RLE data – BMP rows stored bottom-up
Dim curRow As Long: curRow = 0 ' Počáteční řádek Initialize current row to 0
Dim curCol As Long: curCol = 0 ' Počáteční sloupec Initialize current column to 0
Dim poss As Long: poss = 1 ' Počáteční pozice v RLE datech Start position in RLE data
Dim dataLen As Long: dataLen = Len(rleData) ' Celková délka RLE dat Total length of RLE data
Do While poss <= dataLen ' Smyčka přes RLE data Loop through RLE data
Dim countByte As _Unsigned _Byte, dataByte As _Unsigned _Byte
countByte = Asc(Mid$(rleData, poss, 1)) ' Načtení count bajtu Read count byte
poss = poss + 1 ' Posun o 1 bajt Increment position by 1
If poss > dataLen Then Exit Do
dataByte = Asc(Mid$(rleData, poss, 1)) ' Načtení datového bajtu Read data byte
poss = poss + 1 ' Posun o 1 bajt Increment position by 1
If countByte = 0 Then ' Speciální příkazy Special commands
If dataByte = 0 Then ' Konec řádku End of line
curRow = curRow + 1 ' Zvýšení řádku Increment row
curCol = 0 ' Reset sloupce Reset column
ElseIf dataByte = 1 Then ' Konec bitmapy End of bitmap
Exit Do ' Ukončení dekódování Exit decoding loop
ElseIf dataByte = 2 Then ' Delta příkaz (posun) Delta command (shift)
If poss + 1 > dataLen Then Exit Do
Dim dx As _Unsigned _Byte, dy As _Unsigned _Byte
dx = Asc(Mid$(rleData, poss, 1)) ' Delta – posun v x Delta shift in x
dy = Asc(Mid$(rleData, poss + 1, 1)) ' Delta – posun v y Delta shift in y
poss = poss + 2 ' Posun o 2 bajty Increment position by 2
curCol = curCol + dx ' Aktualizace sloupce Update column
curRow = curRow + dy ' Aktualizace řádku Update row
Else ' Absolutní blok Absolute block
Dim absCount As Long: absCount = dataByte ' Počet nibble v absolutním bloku Number of nibbles in absolute block
Dim byteCount As Long: byteCount = (absCount + 1) \ 2 ' Počet bajtů v absolutním bloku Number of bytes in absolute block
Dim absData As String
absData = Mid$(rleData, poss, byteCount) ' Načtení absolutních dat Read absolute block data
poss = poss + byteCount ' Posun za absolutní data Move position past absolute data
Dim k As Long
For k = 1 To absCount ' Smyčka přes nibble v absolutním bloku Loop through each nibble in absolute block
Dim currentNibble As _Unsigned _Byte
Dim currentByte As _Unsigned _Byte: currentByte = Asc(Mid$(absData, ((k + 1) \ 2), 1))
If (k Mod 2) = 1 Then
currentNibble = currentByte \ 16 ' Horní nibble Upper nibble
Else
currentNibble = currentByte And &HF ' Dolní nibble Lower nibble
End If
_MemPut memImg, memImg.OFFSET + (((height - curRow - 1) * rowPitch) + curCol), currentNibble As _UNSIGNED _BYTE ' Zápis pixelu Write pixel to image memory
curCol = curCol + 1 ' Posun sloupce Increment column
If curCol >= width Then Exit For ' Pokud konec řádku, ukončit smyčku Exit loop if end of row
Next k
End If
Else ' Kódovaný režim (run mode) Encoded (run) mode
Dim j As Long
For j = 1 To countByte ' Smyčka přes počet opakování Loop for count repetitions
Dim pixel As _Unsigned _Byte
If (j Mod 2) = 1 Then
pixel = dataByte \ 16 ' Horní nibble Upper nibble
Else
pixel = dataByte And &HF ' Dolní nibble Lower nibble
End If
_MemPut memImg, memImg.OFFSET + (((height - curRow - 1) * rowPitch) + curCol), pixel As _UNSIGNED _BYTE ' Zápis pixelu do obrázku Write pixel to image memory
curCol = curCol + 1 ' Posun sloupce Increment column
If curCol >= width Then Exit For ' Ukončení smyčky při dosažení konce řádku Exit loop if end of row reached
Next j
End If
' Automatický posun řádku se zde neprovádí, protože konec řádku je explicitně signalizován (0,0 nebo delta)
If curRow >= height Then Exit Do ' Pokud jsou všechny řádky načteny, ukončíme dekódování Exit loop if all rows processed
Loop
Load4BitRLEBMP = img ' Vrácení načteného obrázku Return the loaded image
End Function