123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429 |
- {*****************************************************************************}
- {
- This file is part of the Free Pascal's "Free Components Library".
- Copyright (c) 2003 by Mazen NEIFER of the Free Pascal development team
- PNM writer implementation.
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- }
- {*****************************************************************************}
- {
- The PNM (Portable aNyMaps) is a generic name for :
- PBM : Portable BitMaps,
- PGM : Portable GrayMaps,
- PPM : Portable PixMaps.
- There is normally no file format associated with PNM itself.}
- {$mode objfpc}{$h+}
- unit FPReadPNM;
- interface
- uses FPImage, classes, sysutils;
- Const
- BufSize = 1024;
- type
- { TFPReaderPNM }
- TFPReaderPNM=class (TFPCustomImageReader)
- private
- FBitMapType : Integer;
- FWidth : Integer;
- FHeight : Integer;
- FBufPos : Integer;
- FBufLen : Integer;
- FBuffer : Array of char;
- function DropWhiteSpaces(Stream: TStream): Char;
- function ReadChar(Stream: TStream): Char;
- function ReadInteger(Stream: TStream): Integer;
- procedure ReadScanlineBuffer(Stream: TStream;p:Pbyte;Len:Integer);
- protected
- FMaxVal : Cardinal;
- FBitPP : Byte;
- FScanLineSize : Integer;
- FScanLine : PByte;
- procedure ReadHeader(Stream : TStream); virtual;
- function InternalCheck (Stream:TStream):boolean;override;
- procedure InternalRead(Stream:TStream;Img:TFPCustomImage);override;
- procedure ReadScanLine(Row : Integer; Stream:TStream);
- procedure WriteScanLine(Row : Integer; Img : TFPCustomImage);
- end;
- implementation
- const
- WhiteSpaces=[#9,#10,#13,#32];
- {Whitespace (TABs, CRs, LFs, blanks) are separators in the PNM Headers}
- { The magic number at the beginning of a pnm file is 'P1', 'P2', ..., 'P7'
- followed by a WhiteSpace character }
- function TFPReaderPNM.InternalCheck(Stream:TStream):boolean;
- var
- hdr: array[0..2] of char;
- oldPos: Int64;
- i,n: Integer;
- begin
- Result:=False;
- if Stream = nil then
- exit;
- oldPos := Stream.Position;
- try
- n := SizeOf(hdr);
- Result:=(Stream.Size-OldPos>=N);
- if not Result then exit;
- For I:=0 to N-1 do
- hdr[i]:=ReadChar(Stream);
- Result:=(hdr[0] = 'P')
- and (hdr[1] in ['1'..'7'])
- and (hdr[2] in WhiteSpaces);
- finally
- Stream.Position := oldPos;
- FBufLen:=0;
- end;
- end;
- function TFPReaderPNM.DropWhiteSpaces(Stream : TStream) :Char;
- begin
- with Stream do
- begin
- repeat
- Result:=ReadChar(Stream);
- {If we encounter comment then eate line}
- if DropWhiteSpaces='#' then
- repeat
- Result:=ReadChar(Stream);
- until Result=#10;
- until not (Result in WhiteSpaces);
- end;
- end;
- function TFPReaderPNM.ReadInteger(Stream : TStream) :Integer;
- var
- s:String[7];
- begin
- s:='';
- s[1]:=DropWhiteSpaces(Stream);
- repeat
- Inc(s[0]);
- s[Length(s)+1]:=ReadChar(Stream);
- until (s[0]=#7) or (s[Length(s)+1] in WhiteSpaces);
- Result:=StrToInt(s);
- end;
- procedure TFPReaderPNM.ReadScanlineBuffer(Stream: TStream;p:Pbyte;Len:Integer);
- // after the header read, there are still bytes in the buffer.
- // drain the buffer before going for direct stream reads.
- var BytesLeft : integer;
- begin
- BytesLeft:=FBufLen-FBufPos;
- if BytesLeft>0 then
- begin
- if BytesLeft>Len then
- BytesLeft:=Len;
- Move (FBuffer[FBufPos],p^,BytesLeft);
- Dec(Len,BytesLeft);
- Inc(FBufPos,BytesLeft);
- Inc(p,BytesLeft);
- if Len>0 then
- Stream.ReadBuffer(p^,len);
- end
- else
- Stream.ReadBuffer(p^,len);
- end;
- function TFPReaderPNM.ReadChar(Stream: TStream): Char;
- begin
- If (FBufPos>=FBufLen) then
- begin
- if Length(FBuffer)=0 then
- SetLength(FBuffer,BufSize);
- FBufLen:=Stream.Read(FBuffer[0],Length(FBuffer));
- if FBuflen=0 then
- Raise EReadError.Create('Failed to read from stream');
- FBufPos:=0;
- end;
- Result:=FBuffer[FBufPos];
- Inc(FBufPos);
- end;
- procedure TFPReaderPNM.ReadHeader(Stream : TStream);
- Var
- C : Char;
- begin
- C:=ReadChar(Stream);
- If (C<>'P') then
- Raise Exception.Create('Not a valid PNM image.');
- C:=ReadChar(Stream);
- FBitmapType:=Ord(C)-Ord('0');
- If Not (FBitmapType in [1..6]) then
- Raise Exception.CreateFmt('Unknown PNM subtype : %s',[C]);
- FWidth:=ReadInteger(Stream);
- FHeight:=ReadInteger(Stream);
- if FBitMapType in [1,4]
- then
- FMaxVal:=1
- else
- FMaxVal:=ReadInteger(Stream);
- If (FWidth<=0) or (FHeight<=0) or (FMaxVal<=0) then
- Raise Exception.Create('Invalid PNM header data');
- case FBitMapType of
- 1: FBitPP := 1; // 1bit PP (text)
- 2: FBitPP := 8 * SizeOf(Word); // Grayscale (text)
- 3: FBitPP := 8 * SizeOf(Word)*3; // RGB (text)
- 4: FBitPP := 1; // 1bit PP (raw)
- 5: If (FMaxval>255) then // Grayscale (raw);
- FBitPP:= 8 * 2
- else
- FBitPP:= 8;
- 6: if (FMaxVal>255) then // RGB (raw)
- FBitPP:= 8 * 6
- else
- FBitPP:= 8 * 3
- end;
- // Writeln(FWidth,'x',Fheight,' Maxval: ',FMaxVal,' BitPP: ',FBitPP);
- end;
- procedure TFPReaderPNM.InternalRead(Stream:TStream;Img:TFPCustomImage);
- var
- Row:Integer;
- begin
- ReadHeader(Stream);
- Img.SetSize(FWidth,FHeight);
- Case FBitmapType of
- 5,6 : FScanLineSize:=(FBitPP div 8) * FWidth;
- else
- FScanLineSize:=FBitPP*((FWidth+7) shr 3);
- end;
- GetMem(FScanLine,FScanLineSize);
- try
- for Row:=0 to img.Height-1 do
- begin
- ReadScanLine(Row,Stream);
- WriteScanLine(Row,Img);
- // Writeln(Stream.Position,' ',Stream.Size);
- end;
- finally
- FreeMem(FScanLine);
- end;
- end;
- procedure TFPReaderPNM.ReadScanLine(Row : Integer; Stream:TStream);
- Var
- P : PWord;
- I,j,bitsLeft : Integer;
- PB: PByte;
- begin
- Case FBitmapType of
- 1 : begin
- PB:=FScanLine;
- For I:=0 to ((FWidth+7)shr 3)-1 do
- begin
- PB^:=0;
- bitsLeft := FWidth-(I shl 3)-1;
- if bitsLeft > 7 then bitsLeft := 7;
- for j:=0 to bitsLeft do
- PB^:=PB^ or (ReadInteger(Stream) shl (7-j));
- Inc(PB);
- end;
- end;
- 2 : begin
- P:=PWord(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- P^:=ReadInteger(Stream);
- Inc(P);
- end;
- end;
- 3 : begin
- P:=PWord(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- P^:=ReadInteger(Stream); // Red
- Inc(P);
- P^:=ReadInteger(Stream); // Green
- Inc(P);
- P^:=ReadInteger(Stream); // Blue;
- Inc(P)
- end;
- end;
- 4,5,6 : if FBufPos>=FBufLen then // still bytes in buffer?
- Stream.ReadBuffer(FScanLine^,FScanLineSize)
- else
- ReadScanLineBuffer(Stream,FScanLine,FScanLineSize);
- end;
- end;
- procedure TFPReaderPNM.WriteScanLine(Row : Integer; Img : TFPCustomImage);
- Var
- C : TFPColor;
- L : Cardinal;
- Scale: Int64;
- function ScaleByte(B: Byte):Word;
- begin
- if FMaxVal = 255 then
- Result := (B shl 8) or B { As used for reading .BMP files }
- else { Mimic the above with multiplications }
- Result := (B*(FMaxVal+1) + B) * 65535 div Scale;
- end;
- function ScaleWord(W: Word):Word;
- begin
- if FMaxVal = 65535 then
- Result := BEtoN(W)
- else { Mimic the above with multiplications }
- Result := Int64(W*(FMaxVal+1) + W) * 65535 div Scale;
- end;
- Procedure ByteBnWScanLine;
- Var
- P : PByte;
- I,j,x,bitsLeft : Integer;
- begin
- P:=PByte(FScanLine);
- For I:=0 to ((FWidth+7)shr 3)-1 do
- begin
- L:=P^;
- x := I shl 3;
- bitsLeft := FWidth-x-1;
- if bitsLeft > 7 then bitsLeft := 7;
- for j:=0 to bitsLeft do
- begin
- if L and $80 <> 0 then
- Img.Colors[x,Row]:=colBlack
- else
- Img.Colors[x,Row]:=colWhite;
- L:=L shl 1;
- inc(x);
- end;
- Inc(P);
- end;
- end;
- Procedure WordGrayScanLine;
- Var
- P : PWord;
- I : Integer;
- begin
- P:=PWord(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- L:=ScaleWord(P^);
- C.Red:=L;
- C.Green:=L;
- C.Blue:=L;
- Img.Colors[I,Row]:=C;
- Inc(P);
- end;
- end;
- Procedure WordRGBScanLine;
- Var
- P : PWord;
- I : Integer;
- begin
- P:=PWord(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- C.Red:=ScaleWord(P^);
- Inc(P);
- C.Green:=ScaleWord(P^);
- Inc(P);
- C.Blue:=ScaleWord(P^);
- Img.Colors[I,Row]:=C;
- Inc(P);
- end;
- end;
- Procedure ByteGrayScanLine;
- Var
- P : PByte;
- I : Integer;
- begin
- P:=PByte(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- L:=ScaleByte(P^);
- C.Red:=L;
- C.Green:=L;
- C.Blue:=L;
- Img.Colors[I,Row]:=C;
- Inc(P);
- end;
- end;
- Procedure ByteRGBScanLine;
- Var
- P : PByte;
- I : Integer;
- begin
- P:=PByte(FScanLine);
- For I:=0 to FWidth-1 do
- begin
- C.Red:=ScaleByte(P^);
- Inc(P);
- C.Green:=ScaleByte(P^);
- Inc(P);
- C.Blue:=ScaleByte(P^);
- Img.Colors[I,Row]:=C;
- Inc(P);
- end;
- end;
- begin
- C.Alpha:=AlphaOpaque;
- Scale := FMaxVal*(FMaxVal+1) + FMaxVal;
- Case FBitmapType of
- 1 : ByteBnWScanLine;
- 2 : WordGrayScanline;
- 3 : WordRGBScanline;
- 4 : ByteBnWScanLine;
- 5 : If FBitPP=8 then
- ByteGrayScanLine
- else
- WordGrayScanLine;
- 6 : If FBitPP=24 then
- ByteRGBScanLine
- else
- WordRGBScanLine;
- end;
- end;
- initialization
- ImageHandlers.RegisterImageReader ('Netpbm format', 'PNM;PGM;PBM;PPM', TFPReaderPNM);
- end.
|