http://www.fileformat.info/format/pictor/egff.htm
Credit goes to Netmaestro for the Imageto8Bit procedure and Adaptive Color Palette.
Why is this important? It's not really, rather it is a final triumph of mine to figure out a nasty, nasty image encoding routine. Anyway, it's one more format to encode to just for the heck of it.
NOTE: If anyone has WORKING dithering routines to better adapt a 24/32 bit PBimage I'd love to have them. Then we can all benefit from natively PB coded procedures to accurately reduce image depth.
EDIT: 4/20/09 - Fixed a bug when the read byte = TheRunMarker - was causing very detailed images to be skewed in parts of the image. Subtracting 1 from the read byte to ensure it does NOT = TheRunMarker and skew the image. Overall it does not affect image quality, as the byte is just subtracted to the next nearest palette entry.
Code: Select all
Structure PICHEADER
id.w ;Magic number (always $1234)
width.w ;Width of image in pixels
height.w ;Height of image in pixels
XOffset.w ;X of lower left corner of image
YOffset.w ;Y of lower left corner of image
PlaneInfo.b ;BPP and number color planes
PaletteFlag.b ;Color palette/video flag
VideoMode.b ;Video mode of image
PaletteType.w ;Type of color palette
PaletteSize.w ;Size of color palette
EndStructure
Structure MyRGB
Red.b
Green.b
Blue.b
EndStructure
Structure _LTI_BITMAPINFO
bmiHeader.BITMAPINFOHEADER
bmiColors.RGBQUAD[1]
EndStructure
Structure _LTI_LONG
l.l
EndStructure
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(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(0)
ProcedureReturn *palette
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
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 GetRunMarker(*SCline, SCLength) ;Translated from code by Bill Buckels - http://en.wikipedia.org/wiki/Example_Pictor_Encoder
Dim buf.b(SCLength-1)
Dim markerbuf.b(255)
bfound =#False
CopyMemory(*SCline,buf(),SCLength)
For idx = 0 To 255
markerbuf(idx) = 0; initial count
Next
For idx = 0 To SCLength-1
markertest = buf(idx)&255
markerbuf(markertest)+1
Next
;count backwards, i prefer the highest Value possible For a marker.
markertest = 255;
Repeat
If markerbuf(markertest) = 0
bfound = #True
RunMarker = markertest &255
Break
EndIf
markertest-1
Until markertest = 0
; If we found no available markers in This block
; all 256 byte values are in use
; ROT - To avoid complicated algorithms that consider patterning etc.
; take John Bridges' early advice...
; no unique Bytes in scanline, so use the LEAST used byte As a marker
; again counting backwards
If bfound =#False
leastused = 255
jdx = markerbuf(255)&255
markertest = 254
While markertest > 0
idx = markerbuf(markertest)
If idx < jdx
;only switch For less
jdx = idx;
leastused = markertest&255
EndIf
markertest -1
Wend
RunMarker = leastused &255
Dim buf.b(0)
ProcedureReturn RunMarker
Else
Dim buf.b(0)
ProcedureReturn RunMarker
EndIf
EndProcedure
Procedure.l SavePic(PBImage.l,filename.s)
new8bimage=ImageTo8bit(PBImage,2,0)
If Not IsImage(new8bimage) Or ImageDepth(new8bimage) <> 8
ProcedureReturn 0
EndIf
If GetObject_(ImageID(new8bimage), SizeOf(BITMAP), Bmp.BITMAP)
With BmiInfo.BITMAPINFOHEADER
\biSize = SizeOf(BITMAPINFOHEADER)
\biWidth = Bmp\bmWidth
\biHeight = -Bmp\bmHeight ;bitmap is TOP down
\biPlanes = 1
\biBitCount = 8
\biCompression = #BI_RGB
EndWith
Else
ProcedureReturn 0
EndIf
width = Bmp\bmWidth
height = Bmp\bmHeight
bitcount = Bmp\bmBitsPixel
pitch=(((width*bitcount)+31)/32)*4
sz_colorbits = Bmp\bmWidthBytes*Bmp\bmHeight
*bitmapdata=AllocateMemory(sz_colorbits)
*colortable = AllocateMemory(256*SizeOf(RGBQUAD))
hdc = StartDrawing(ImageOutput(new8bimage))
NumColors = GetDIBColorTable_(hdc, 0, 256, *colortable) ;get the color table
StopDrawing()
Dim CT1024.RGBQUAD(NumColors-1)
CopyMemory(*colortable,@CT1024(),NumColors*SizeOf(RGBQUAD)) ;copy our BGRI palette to a RGBQUAD array
CopyMemory(Bmp\bmBits, *bitmapdata, sz_colorbits) ;output all out pixel data
FreeMemory(*colortable)
Dim CT768.MyRGB(NumColors-1)
For a =0 To NumColors-1 ; Here we take the BGRI and switch it to a RGB VGA palette by bitshitfing >>2
CT768(a)\Red=CT1024(a)\rgbRed>>2
CT768(a)\Green=CT1024(a)\rgbGreen>>2
CT768(a)\Blue=CT1024(a)\rgbBlue>>2
Next
*pic.PICHEADER=AllocateMemory(SizeOf(PICHEADER))
*pic\id =$1234;Magic number (always $1234)
*pic\width=width;Width of image in pixels
*pic\height =height;Height of image in pixels
*pic\XOffset =0;X of lower left corner of image
*pic\YOffset =0;Y of lower left corner of image
*pic\PlaneInfo= bitcount|(1 >>4)
*pic\PaletteFlag=0 ;Color palette/video flag
*pic\VideoMode.b ;Video mode of image
*pic\PaletteType=4 ;Type of color palette
*pic\PaletteSize=NumColors*3 ;Size of color palette
file=CreateFile(#PB_Any,filename)
If file=0 ;File can't be created
MessageRequester("SAVE ERROR","File could not be opened")
ProcedureReturn #False
EndIf
WriteData(file,*pic,SizeOf(PICHEADER))
WriteData(file,@CT768(0) ,NumColors*3)
WriteWord(file,height)
;// Notes From http://www.fileformat.info/format/pictor/egff.htm
; WORD BlockSize Size of encoded block including Header
; WORD RunLength Size of decoded pixel Data
; byte RunMarker Start-of-run indicator
; byte RunMarker Start-of-run indicator
; byte RunLength length of the pixel run (8-bit run length)
; WORD RunCount length of the pixel run (16-bit run length)
; byte RunValue the Value of the pixel run
;
; If the RunMarker is missing from a Data block, the byte Read is assumed To be a literal pixel Value And is written directly To the output:
;
; WORD BlockSize Size of encoded block including Header
; WORD RunLength Size of decoded pixel Data
; byte RunMarker Start-of-run indicator
; byte PixelValue No RunMarker, literal pixel Value
bytesPerLine=((Bmp\bmWidth*bitcount)+15)/16*2 ;DWORD aligned scan width
bytesPerLN=((width*bitcount)+15)/16*2 ; WORD aligned scanline width
extrabytesperrow = (4 - (width * bitcount / 8) % 4) % 4
sizetoscan=pitch-extrabytesperrow-1
;Run through our image data and process
For iy=0 To height-1
offset=*bitmapdata+(iy*pitch) ;Start of next scanline
*SCline=AllocateMemory(pitch);allocate some memory for the scanline
*OutSCline=AllocateMemory(pitch*3) ;allocate memory for the encoded scanline
CopyMemory(offset,*SCline,pitch) ;copy the scanline to find a run marker
TheRunMarker.b= GetRunMarker(*SCline,pitch) ;use above procedure to find run marker
PokeW(*OutSCline+2,width);set the size of the decoded scanline --Second word of header
PokeB(*OutSCline+4,TheRunMarker); Our chosen Runmarker
SCPosition=5
Size.w=5 ;Our size now is 5 bytes - 2 Words (Blocksize, Runlength) and 1 Byte (Runmarker)
count=1 ;Reset, runs in pix don't go onto next line
lastbyte=PeekB(*SCline);&255
For ix=1 To width;+b ;x loop is for pitch
;lastrgb is the working rgb
byte=PeekB(*SCline+(ix)) ;& 255
If byte =TheRunMarker ;if there is a duplication - just subtract 1 from byte
byte-1
EndIf
If ix<= width
If byte=lastbyte ;And outputbyte=#True ;End of a run or count is maximum or last pixel on line
count+1
Else ; nope, our run or scanline has ended and now we need to construct a run block
If count >2 And count <=255
PokeB(*OutSCline+SCPosition, TheRunMarker) ;+1 byte - Indicate that a run starts here
SCPosition+1
PokeB(*OutSCline+SCPosition, count); our runlength
SCPosition+1
PokeB(*OutSCline+SCPosition, lastbyte) ;our byte to be repeated
SCPosition+1
Size+ 3
count=1 ;Reset
lastbyte=byte
;byte=
ElseIf count >255 ;Count now needs to be a WORD
PokeB(*OutSCline+SCPosition, TheRunMarker) ;+1 byte - Indicate that a run starts here
SCPosition+1
PokeB(*OutSCline+SCPosition, 0)
SCPosition+1
wordcount.w=count
PokeW(*OutSCline+SCPosition,wordcount)
SCPosition+2
PokeB(*OutSCline+SCPosition, lastbyte)
SCPosition+1
wordcount=0
count=1 ;Reset
Size+5 ; Adjust our OutScanline size accordingly
lastbyte=byte
ElseIf count =1 Or count =2 ; no count was taken, we have a literal pixel value - output the byte
;a runcount of less than 3 is NOT efficient And will only INCREASE file Size - just poke out 1 Or 2 literal pixels
While count>0
PokeB(*OutSCline+SCPosition, lastbyte);+1 byte
SCPosition+1 ;advance 1 byte
Size+1
count-1
Wend
count=1 ;Reset just to be sure
lastbyte=byte
EndIf
EndIf
Else
byte=0
count=1
EndIf
Next
PokeW(*OutSCline,Size)
WriteData(file,*OutSCline,Size);Write the Scanline to the File
FreeMemory(*OutSCline);Free up our memory
FreeMemory(*SCline);Free up our memory
Next
CloseFile(file)
FreeMemory(*bitmapdata)
FreeMemory(*pic)
If IsImage(new8bimage)
FreeImage(new8bimage)
EndIf
ProcedureReturn #True ;success code
EndProcedure
UseJPEGImageDecoder()
UsePNGImageDecoder()
If OpenWindow(0,0,0,670,620,"Save Pic",#PB_Window_SystemMenu|#PB_Window_ScreenCentered) And CreateGadgetList(WindowID(0))
ButtonGadget(0, 10, 10,80,20,"Open File")
ImageGadget(1, 10, 50, 300,300,0,#PB_Image_Border)
EndIf
Repeat
Select WaitWindowEvent()
Case #PB_Event_Gadget
Select EventGadget()
Case 0
Pattern$="All Supported Formats|*.jpg;*.bmp;*.png"
filename.s=OpenFileRequester("Choose An Image File To Open","",Pattern$,0)
If filename
hBitmap=LoadImage(#PB_Any,filename.s)
SendMessage_(GadgetID(1), #STM_SETIMAGE,#IMAGE_BITMAP,ImageID(hBitmap))
SavePic(hBitmap,filename.s+"_out.pic")
EndIf
EndSelect
Case #PB_Event_CloseWindow
End
EndSelect
ForEver