Edit: updated
I've managed to write an image compression routing in DBPro that actually works. I've saved a 197 x 211 BMP which was 124kb down to a 85kb file.
The code works by finding repeatedly used colours nad replacing each colours with a "token", pointing to a colour in the image palette. That way if you only used two colours then the data stored would be two colours and lots of smaller token values.
The top picture is loaded from my format (85k), the bottom from BMP (124k).
The size of file also depends on the number of colours used in the image - the image above used only 290 colours so was a smaller file.
-- Structure --
Header:
1 byte width
1 byte height
1 word number of colours in palette
Palette:
for each colour, rgb colour info
Image:
for each x/y, 1 word of palette index
eg:
In palette:
1:red
2:blue
In main image:
1,1,1,1,1,2,2,2,1,2,1,2,1,2
I'm now working to get it to work quicker and with more compression
Here's my current code. This will load "testimg2.bmp" (has to be 198x212) and save it is "finalimg.dif".
The compression is slighly lossy (it wasn't at the time of writing the post, hence the title "lossless image ocmpression"), though only once (ie. after saving once there will be no more loss of detail for further saves until the image is modified).
My next step is to catch repeated entries in the image data (ie. 0000000001000000) and replace it with something like 0(9) 1(1) 0(6).
`198 212
center text 320,240,"Compressing....."
sync
`end
load image "testimg2.bmp",1
paste image 1,0,0
dim imgarray(197,211)
` Get image data into array
for x = 0 to 197
for y = 0 to 211
imgarray(x,y) = point(x,y)
next x
next y
`Clear screen
cls
`Output
center text 320,260,"Creating palette"
sync
open to write 2,"log.txt"
` Create palette and add entries
dim palette(100000)
dim finalimg(197,211)
NumCols = 0
for x = 0 to 197
for y = 0 to 211
col = imgarray(x,y)
colr = rgbr(col)
colg = rgbg(col)
colb = rgbb(col)
colr = int((colr / 10) * 10)
colg = int((colg / 10) * 10)
colb = int((colb / 10) * 10)
col = rgb(colr,colg,colb)
i = InPalette(col)
` If colour exists in palette add token to main file
if i<>-1
finalimg(x,y)=i
else
` If not then add colour to palette and add token
palette(NumCols) = col
finalimg(x,y)=NumCols
inc NumCols
endif
cls
text 320,240,"Cell "+str$(x)+" / "+str$(y)+" "+str$(i)
sync
if spacekey()=1 then end
next x
next y
`Write file
center text 320,280,"Writing file..."
sync
`First header
open to write 1,"finalimg.dif"
write byte 1,198 : `width
write byte 1,212 : `height
write word 1,NumCols : `Number of colours
write string 2,"// Header"
write string 2,"198"
write string 2,"212"
write string 2,str$(numcols)
write string 2,"// Palette"
`Now write palette
for p = 0 to NumCols
write file 1,palette(p)
write string 2,str$(rgbr(palette(p)))+"."+str$(rgbg(palette(p)))+"."+str$(rgbb(palette(p)))
next p
write string 2,"// Image"
`Now write image data
for x = 0 to 197
for y = 0 to 211
write word 1,finalimg(x,y)
write string 2,str$(finalimg(x,y))
next x
next y
close file 1
close file 2
` Done
center text 320,300,"Done with "+str$(NumCols)+" colours in image"
center text 320,320,str$(inpalette(rgb(254,254,253)))
` Display picture
do
sync
if returnkey()=1 then exit
loop
`Load image
file$ = "finalimg.dif"
open to read 1,file$
`Read header
read byte 1,width
read byte 1,height
read word 1,NumCols
`Read palette
dim palette(NumCols)
for p = 0 to NumCols
read file 1,palette(p)
next p
cls
`Now read image data and substitute tokens for palette data
dim image(width-1,height-1)
for x = 0 to width-1
for y = 0 to height-1
read word 1,paltoken
image(x,y) = palette(paltoken)
ink image(x,y),0
dot x,y
sync
next y
next x
paste image 1,0,213
sync
wait key
end
` Checks if colour in palette. If so returns palette indes for colour, else 0
Function InPalette(col)
for i = 0 to 100000
if palette(i) = col then exitfunction i
next i
endfunction -1
There's no place like 127.0.0.1
There are 10 people in this world, those who understand binary and those who don't.
