I only found an old version here:
https://www.purebasic.fr/english/viewtopic.php?t=27462
And on my disk I found something from me, but it looked incomplete.
So I decided to give it a new try.
P1 to P6 should always work.
P7 should now also work. (IrfanView can not load a *.pam file at all
)One limitation: only one image per file
Maybe I add this feature later.
Code: Select all
;
; PNM.pbi
;
; An include file for PNM picture files
; https://www.purebasic.fr/english/viewtopic.php?p=615861
;
; https://en.wikipedia.org/wiki/Netpbm
;
; V1.2.0 Added SaveImagePNM
; V1.1.0 Added transparency for P7 / pam files
; V1.0.2 Fixed a bug with pam files (officially pam is only binary, but I found examples with ASCII)
; V1.0.1 Fixed a bug with pam files (no value after ENDHDR)
; V1.0.0 LoadImagePNM() implemented
;
CompilerIf #PB_Compiler_IsMainFile
EnableExplicit
CompilerEndIf
Enumeration PNM_Coding
#PNM_Coding_None
#PNM_Coding_Ascii
#PNM_Coding_Binary
#PNM_Coding_Arbitrary
EndEnumeration
Enumeration PNM_FileType
#PNM_Filetype_None
#PNM_Filetype_Bitmap
#PNM_Filetype_Graymap
#PNM_Filetype_Pixmap
EndEnumeration
Enumeration PNM_HeaderState
#PNM_HeaderState_Coding
#PNM_HeaderState_Width
#PNM_HeaderState_Height
#PNM_HeaderState_Max
EndEnumeration
Macro IsWhiteSpacePNM(Char)
Bool(Char = ' ' Or Char = #TAB Or Char = #CR Or Char = #LF)
EndMacro
Procedure.i LoadImagePNM(Img.i, Filename$)
Protected File.i, FileExtension$, *Buffer, *BufferEnd, *BufferPtr.Ascii, State.i
Protected Coding.i, FileType.i, HeaderComplete.i, Width.i, Height.i, Max.i, Depth.i, Alpha.i, Transparency.i
Protected x.i, y.i, Color.i, ColorFactor.f, Red.i, Green.i, Blue.i, BitMask.i
Protected Width$, Height$, Max$, Color$, Line$, Value$, Depth$, Tupltype$, NewLine$
File = ReadFile(#PB_Any, Filename$)
If File
*Buffer = AllocateMemory(Lof(File), #PB_Memory_NoClear)
If *Buffer
If ReadData(File, *Buffer, MemorySize(*Buffer)) = MemorySize(*Buffer)
*BufferPtr = *Buffer
*BufferEnd = *Buffer + MemorySize(*Buffer)
FileExtension$ = GetExtensionPart(Filename$)
If *BufferPtr\a = 'P'
*BufferPtr + 1
Select *BufferPtr\a
Case '1' : FileType = #PNM_Filetype_Bitmap : Coding = #PNM_Coding_Ascii
Case '2' : FileType = #PNM_Filetype_Graymap : Coding = #PNM_Coding_Ascii
Case '3' : FileType = #PNM_Filetype_Pixmap : Coding = #PNM_Coding_Ascii
Case '4' : FileType = #PNM_Filetype_Bitmap : Coding = #PNM_Coding_Binary
Case '5' : FileType = #PNM_Filetype_Graymap : Coding = #PNM_Coding_Binary
Case '6' : FileType = #PNM_Filetype_Pixmap : Coding = #PNM_Coding_Binary
Case '7' : Coding = #PNM_Coding_Arbitrary
EndSelect
If Coding <> #PNM_Coding_None
Debug "Coding Ok"
*BufferPtr + 1
If Coding = #PNM_Coding_Arbitrary
NewLine$ = Chr(*BufferPtr\a)
*BufferPtr + 1
If *BufferPtr\a = #LF Or *BufferPtr\a = #CR
NewLine$ + Chr(*BufferPtr\a)
EndIf
*BufferPtr - 1
While Not HeaderComplete And *BufferPtr <= *BufferEnd
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Line$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Line$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Debug Line$
If Line$ <> "ENDHDR" And Left(Line$, 1) <> "#"
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Value$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Value$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Debug Value$
EndIf
*BufferPtr + Len(NewLine$)
Select Left(Line$, 4)
Case "WIDT"
Width$ = Value$
Case "HEIG"
Height$ = Value$
Case "DEPT"
Depth$ = Value$
Depth = Val(Depth$)
If Depth = 4
Transparency = #True
EndIf
Case "MAXV"
Max$ = Value$
Max = Val(Max$)
ColorFactor = 255 / Max
Case "TUPL"
Tupltype$ = Value$
Select LCase(Tupltype$)
Case "blackandwhite"
FileType = #PNM_Filetype_Bitmap
Case "blackandwhite_alpha"
FileType = #PNM_Filetype_Bitmap
Transparency = #True
Case "grayscale"
FileType = #PNM_Filetype_Graymap
Case "grayscale_alpha"
FileType = #PNM_Filetype_Graymap
Transparency = #True
Case "color"
FileType = #PNM_Filetype_Pixmap
Case "rgb"
FileType = #PNM_Filetype_Pixmap
Case "rgb_alpha"
FileType = #PNM_Filetype_Pixmap
Transparency = #True
Case "transparent"
Transparency = #True
EndSelect
Case "ENDH"
If Tupltype$ = ""
Select Depth
Case 1
If Max = 1
FileType = #PNM_Filetype_Bitmap
Else
FileType = #PNM_Filetype_Graymap
EndIf
Case 2
FileType = #PNM_Filetype_Graymap
Case 3, 4
FileType = #PNM_Filetype_Pixmap
EndSelect
EndIf
If *BufferPtr\a = ' ' Or (*BufferPtr\a >= '0' And *BufferPtr\a <= '9')
Coding = #PNM_Coding_Ascii
Else
Coding = #PNM_Coding_Binary
EndIf
HeaderComplete = #True
EndSelect
Wend
Else
State = #PNM_HeaderState_Width
While Not HeaderComplete And *BufferPtr <= *BufferEnd
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
If *BufferPtr\a = '#'
While (*BufferPtr\a <> #CR And *BufferPtr\a <> #LF) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Else
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Select State
Case #PNM_HeaderState_Width
Width$ + Chr(*BufferPtr\a)
Case #PNM_HeaderState_Height
Height$ + Chr(*BufferPtr\a)
Case #PNM_HeaderState_Max
Max$ + Chr(*BufferPtr\a)
EndSelect
*BufferPtr + 1
Wend
State + 1
If State = #PNM_HeaderState_Max And FileType = #PNM_Filetype_Bitmap
HeaderComplete = #True
EndIf
If State > #PNM_HeaderState_Max
Max = Val(Max$)
ColorFactor = 255 / Max
Debug ColorFactor
HeaderComplete = #True
EndIf
EndIf
Wend
EndIf
Debug Width$ + "x" + Height$ + " Max: " + Max$
If *BufferPtr < *BufferEnd
Width = Val(Width$)
Height = Val(Height$)
If Img = #PB_Any
If Transparency
Img = CreateImage(#PB_Any, Width, Height, 32, #PB_Image_Transparent)
Else
Img = CreateImage(#PB_Any, Width, Height)
EndIf
Else
If Transparency
CreateImage(Img, Width, Height, 32, #PB_Image_Transparent)
Else
CreateImage(Img, Width, Height)
EndIf
EndIf
EndIf
If IsImage(Img)
If StartDrawing(ImageOutput(Img))
If Transparency
DrawingMode(#PB_2DDrawing_AllChannels)
EndIf
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
While *BufferPtr <= *BufferEnd
Select Coding
Case #PNM_Coding_Ascii
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Select FileType
Case #PNM_Filetype_Bitmap
If *BufferPtr\a = '0'
Plot(x, y, $FFFFFF)
Else
Plot(x, y, $000000)
EndIf
*BufferPtr + 1
Case #PNM_Filetype_Graymap
Color$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Color$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Color = Val(Color$) * ColorFactor
Plot(x, y, RGB(Color, Color, Color))
Case #PNM_Filetype_Pixmap
Color$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Color$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Red = Val(Color$) * ColorFactor
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Color$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Color$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Green = Val(Color$) * ColorFactor
While IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
*BufferPtr + 1
Wend
Color$ = ""
While Not IsWhiteSpacePNM(*BufferPtr\a) And *BufferPtr <= *BufferEnd
Color$ + Chr(*BufferPtr\a)
*BufferPtr + 1
Wend
Blue = Val(Color$) * ColorFactor
Plot(x, y, RGB(Red, Green, Blue))
EndSelect
x + 1
If x = Width
x = 0
y + 1
If y = Height
*BufferPtr = *BufferEnd + 1
EndIf
EndIf
Case #PNM_Coding_Binary
Select FileType
Case #PNM_Filetype_Bitmap
If Depth = 0
BitMask = $80
While BitMask
If *BufferPtr\a & BitMask
Plot(x, y, $000000)
Else
Plot(x, y, $FFFFFF)
EndIf
BitMask >> 1
x + 1
If x = Width
x = 0
y + 1
If y = Height
*BufferPtr = *BufferEnd + 1
BitMask = 0
EndIf
EndIf
Wend
Else
If *BufferPtr\a = 0
If Transparency
*BufferPtr + 1
Alpha = *BufferPtr\a
Plot(x, y, RGBA(0, 0, 0, Alpha))
Else
Plot(x, y, 0)
EndIf
Else
If Transparency
*BufferPtr + 1
Alpha = *BufferPtr\a
Plot(x, y, RGBA(255, 255, 255, Alpha))
Else
Plot(x, y, $FFFFFF)
EndIf
EndIf
x + 1
If x = Width
x = 0
y + 1
If y = Height
*BufferPtr = *BufferEnd + 1
BitMask = 0
EndIf
EndIf
EndIf
*BufferPtr + 1
Case #PNM_Filetype_Graymap
Color = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Color << 8
Color | *BufferPtr\a
EndIf
Color = Color * ColorFactor
If Transparency
Alpha = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Alpha << 8
Alpha | *BufferPtr\a
EndIf
Alpha = Alpha * ColorFactor
Plot(x, y, RGBA(Color, Color, Color, Alpha))
Else
Plot(x, y, RGB(Color, Color, Color))
EndIf
x + 1
If x = Width
x = 0
y + 1
If y = Height
*BufferPtr = *BufferEnd
BitMask = 0
EndIf
EndIf
*BufferPtr + 1
Case #PNM_Filetype_Pixmap
Red = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Red << 8
Red | *BufferPtr\a
EndIf
Red = Red * ColorFactor
*BufferPtr + 1
Green = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Green << 8
Green | *BufferPtr\a
EndIf
Green = Green * ColorFactor
*BufferPtr + 1
Blue = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Blue << 8
Blue | *BufferPtr\a
EndIf
Blue = Blue * ColorFactor
If Transparency
*BufferPtr + 1
Alpha = *BufferPtr\a
If Max > 255
*BufferPtr + 1
Alpha << 8
Alpha | *BufferPtr\a
EndIf
Alpha = Alpha * ColorFactor
Debug Hex(Alpha)
Plot(x, y, RGBA(Red, Green, Blue, Alpha))
Else
Plot(x, y, RGB(Red, Green, Blue))
EndIf
x + 1
If x = Width
x = 0
y + 1
If y = Height
*BufferPtr = *BufferEnd
BitMask = 0
EndIf
EndIf
*BufferPtr + 1
EndSelect
EndSelect
Wend
StopDrawing()
EndIf
Else
Img = 0
EndIf
EndIf
EndIf
EndIf
FreeMemory(*Buffer)
EndIf
CloseFile(File)
EndIf
ProcedureReturn Img
EndProcedure
;(#Image, Filename$ [, ImagePlugin [, Flags [, Depth]]])
Procedure.i SaveImagePNM(Img.i, Filename$, Filetype.i=#PNM_Filetype_Pixmap, Coding.i=#PNM_Coding_Binary, Transparency.i=#False)
Protected.a Byte
Protected.i File, x, y, xMax, yMax, Color, BitMask
Protected.f Gray
If IsImage(Img)
If StartDrawing(ImageOutput(Img))
If Transparency
DrawingMode(#PB_2DDrawing_AllChannels)
EndIf
File = CreateFile(#PB_Any, Filename$, #PB_Ascii)
If File
xmax = ImageWidth(Img)
ymax = ImageHeight(Img)
If Coding = #PNM_Coding_Arbitrary
WriteStringN(File, "P7")
WriteStringN(File, "WIDTH " + Str(xmax))
WriteStringN(File, "HEIGHT " + Str(ymax))
Select Filetype
Case #PNM_Filetype_Bitmap
If Transparency
WriteStringN(File, "DEPTH 2")
WriteStringN(File, "TUPLTYPE blackandwhite_alpha")
Else
WriteStringN(File, "DEPTH 1")
WriteStringN(File, "TUPLTYPE blackandwhite")
EndIf
WriteStringN(File, "MAXVAL 1")
Case #PNM_Filetype_Graymap
If Transparency
WriteStringN(File, "DEPTH 2")
WriteStringN(File, "TUPLTYPE grayscale_alpha")
Else
WriteStringN(File, "DEPTH 1")
WriteStringN(File, "TUPLTYPE grayscale")
EndIf
WriteStringN(File, "MAXVAL 255")
Case #PNM_Filetype_Pixmap
If Transparency
WriteStringN(File, "DEPTH 4")
WriteStringN(File, "TUPLTYPE rgb_alpha")
Else
WriteStringN(File, "DEPTH 3")
WriteStringN(File, "TUPLTYPE rgb")
EndIf
WriteStringN(File, "MAXVAL 255")
EndSelect
WriteStringN(File, "ENDHDR")
Else
Select Filetype
Case #PNM_Filetype_Bitmap
If Coding = #PNM_Coding_Ascii
WriteString(File, "P1" + #LF$)
Else
WriteString(File, "P4" + #LF$)
EndIf
WriteString(File, Str(xmax) + #LF$)
WriteString(File, Str(ymax) + #LF$)
Case #PNM_Filetype_Graymap
If Coding = #PNM_Coding_Ascii
WriteString(File, "P2" + #LF$)
Else
WriteString(File, "P5" + #LF$)
EndIf
WriteString(File, Str(xmax) + #LF$)
WriteString(File, Str(ymax) + #LF$)
WriteString(File, "255" + #LF$)
Case #PNM_Filetype_Pixmap
If Coding = #PNM_Coding_Ascii
WriteString(File, "P3" + #LF$)
Else
WriteString(File, "P6" + #LF$)
EndIf
WriteString(File, Str(xmax) + #LF$)
WriteString(File, Str(ymax) + #LF$)
WriteString(File, "255" + #LF$)
EndSelect
EndIf
xmax - 1
ymax - 1
BitMask = $80
For y = 0 To ymax
For x = 0 To xmax
If Coding = #PNM_Coding_Ascii
Select Filetype
Case #PNM_Filetype_Bitmap
Color = Point(x, y)
Gray = 0.3 * Red(color) + 0.59 * Green(Color) + 0.11 * Blue(color)
If Gray > 128
WriteString(File, "0")
Else
WriteString(File, "1")
EndIf
If Transparency
WriteString(File, " " + Str(Alpha(color)))
EndIf
WriteStringN(File, "")
Case #PNM_Filetype_Graymap
Color = Point(x, y)
Gray = 0.3 * Red(color) + 0.59 * Green(Color) + 0.11 * Blue(color)
WriteString(File, StrF(Gray, 0))
If Transparency
WriteString(File, " " + Str(Alpha(color)))
EndIf
WriteStringN(File, "")
Case #PNM_Filetype_Pixmap
Color = Point(x, y)
WriteString(File, Str(Red(Color)) + " ")
WriteString(File, Str(Green(Color)) + " ")
WriteString(File, Str(Blue(Color)))
If Transparency
WriteString(File, " " + Str(Alpha(Color)))
EndIf
WriteStringN(File, "")
EndSelect
Else
Select Filetype
Case #PNM_Filetype_Bitmap
Color = Point(x, y)
Gray = 0.3 * Red(color) + 0.59 * Green(Color) + 0.11 * Blue(color)
If Coding = #PNM_Coding_Arbitrary
If Gray > 128
WriteByte(File, 1)
Else
WriteByte(File, 0)
EndIf
Else
If Gray < 128
Byte | BitMask
EndIf
BitMask >> 1
If BitMask = $00
WriteByte(File, Byte)
Byte = 0
BitMask = $80
EndIf
EndIf
Case #PNM_Filetype_Graymap
Color = Point(x, y)
Gray = 0.3 * Red(color) + 0.59 * Green(Color) + 0.11 * Blue(color)
WriteByte(File, Int(Gray))
If Transparency
WriteByte(File, Alpha(Color))
EndIf
Case #PNM_Filetype_Pixmap
Color = Point(x, y)
WriteByte(File, Red(color))
WriteByte(File, Green(color))
WriteByte(File, Blue(color))
If Transparency
WriteByte(File, Alpha(Color))
EndIf
EndSelect
EndIf
Next x
Next y
If BitMask <> $00
WriteByte(File, Byte)
EndIf
CloseFile(File)
EndIf
StopDrawing()
EndIf
EndIf
ProcedureReturn File
EndProcedure
;-Demo
CompilerIf #PB_Compiler_IsMainFile
Define.i Img
Define Filename$
Filename$ = OpenFileRequester("Choose a PNM file", "", "PNM|*.pnm;*.pbm;*.pgm;*.ppm;*.pam", 0)
If Filename$
Img = LoadImagePNM(#PB_Any, Filename$)
If Img
SaveImagePNM(Img, GetPathPart(ProgramFilename()) + GetFilePart(ProgramFilename(), #PB_FileSystem_NoExtension) + "_save.pnm", #PNM_Filetype_Bitmap, #PNM_Coding_Binary)
OpenWindow(0, 0, 0, ImageWidth(Img), ImageHeight(Img), "PNM Demo", #PB_Window_MinimizeGadget|#PB_Window_ScreenCentered)
ImageGadget(0, 0, 0, 0, 0, ImageID(Img))
Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
FreeImage(Img)
EndIf
EndIf
CompilerEndIf
