From 769f0d8008eefa6f51c06ef4d8b238feaa4863d0 Mon Sep 17 00:00:00 2001 From: michael Date: Mon, 13 Jun 2011 19:07:29 +0000 Subject: [PATCH] * Applied patches by "circular", bug #18863 git-svn-id: trunk@17747 - --- packages/fcl-image/src/fpreadpnm.pp | 47 ++++---- packages/fcl-image/src/fpwritepnm.pp | 174 ++++++++++++++++++++++++--- 2 files changed, 182 insertions(+), 39 deletions(-) diff --git a/packages/fcl-image/src/fpreadpnm.pp b/packages/fcl-image/src/fpreadpnm.pp index 3b9d6a56c0..178c52668d 100644 --- a/packages/fcl-image/src/fpreadpnm.pp +++ b/packages/fcl-image/src/fpreadpnm.pp @@ -19,7 +19,7 @@ The PNM (Portable aNyMaps) is a generic name for : PBM : Portable BitMaps, PGM : Portable GrayMaps, PPM : Portable PixMaps. -There is no file format associated with PNM itself.} +There is normally no file format associated with PNM itself.} {$mode objfpc}{$h+} unit FPReadPNM; @@ -85,7 +85,7 @@ begin repeat Inc(s[0]); ReadBuffer(s[Length(s)+1],1) - until s[Length(s)+1] in WhiteSpaces; + until (s[0]=#7) or (s[Length(s)+1] in WhiteSpaces); Result:=StrToInt(s); end; @@ -112,10 +112,10 @@ begin If (FWidth<=0) or (FHeight<=0) or (FMaxVal<=0) then Raise Exception.Create('Invalid PNM header data'); case FBitMapType of - 1: FBitPP := SizeOf(Word); + 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 (row) + 4: FBitPP := 1; // 1bit PP (raw) 5: If (FMaxval>255) then // Grayscale (raw); FBitPP:= 8 * 2 else @@ -136,7 +136,7 @@ var begin ReadHeader(Stream); Img.SetSize(FWidth,FHeight); - FScanLineSize:=(FBitPP*FWidth+7) shr 3; // (bits/line +7) + FScanLineSize:=FBitPP*((FWidth+7)shr 3); GetMem(FScanLine,FScanLineSize); try for Row:=0 to img.Height-1 do @@ -153,18 +153,21 @@ procedure TFPReaderPNM.ReadScanLine(Row : Integer; Stream:TStream); Var P : PWord; - I,j : Integer; + I,j,bitsLeft : Integer; + PB: PByte; begin Case FBitmapType of 1 : begin - P:=PWord(FScanLine); + PB:=FScanLine; For I:=0 to ((FWidth+7)shr 3)-1 do begin - P^:=0; - for j:=0 to 7 do - P^:=(P^ shr 1)or ReadInteger(Stream); - Inc(P); + 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 @@ -219,26 +222,26 @@ Var Var P : PByte; - I,j,x : Integer; + I,j,x,bitsLeft : Integer; begin P:=PByte(FScanLine); - x:=7; For I:=0 to ((FWidth+7)shr 3)-1 do begin L:=P^; - for j:=0 to 7 do + x := I shl 3; + bitsLeft := FWidth-x-1; + if bitsLeft > 7 then bitsLeft := 7; + for j:=0 to bitsLeft do begin - if x < FWidth then - if odd(L) then + if L and $80 <> 0 then Img.Colors[x,Row]:=colBlack else Img.Colors[x,Row]:=colWhite; - L:=L shr 1; - dec(x); + L:=L shl 1; + inc(x); end; Inc(P); - Inc(x,16); end; end; @@ -324,7 +327,7 @@ begin C.Alpha:=AlphaOpaque; Scale := FMaxVal*(FMaxVal+1) + FMaxVal; Case FBitmapType of - 1 : ; + 1 : ByteBnWScanLine; 2 : WordGrayScanline; 3 : WordRGBScanline; 4 : ByteBnWScanLine; @@ -340,5 +343,7 @@ begin end; initialization - ImageHandlers.RegisterImageReader ('PNM Format', 'PNM;PGM;PBM', TFPReaderPNM); + + ImageHandlers.RegisterImageReader ('Netpbm format', 'PNM;PGM;PBM;PPM', TFPReaderPNM); + end. diff --git a/packages/fcl-image/src/fpwritepnm.pp b/packages/fcl-image/src/fpwritepnm.pp index 6630336633..35137f4411 100644 --- a/packages/fcl-image/src/fpwritepnm.pp +++ b/packages/fcl-image/src/fpwritepnm.pp @@ -19,29 +19,103 @@ * PPM (P5,P6) : Portable PixelMap foramt : 24 bits per pixel} {$mode objfpc}{$h+} unit FPWritePNM; + interface uses FPImage, classes, sysutils; type + TPNMColorDepth = (pcdAuto,pcdBlackWhite, pcdGrayscale, pcdRGB); + + { TFPWriterPNM } TFPWriterPNM = class(TFPCustomImageWriter) - private - BitMapType:Integer; protected procedure InternalWrite(Stream:TStream;Img:TFPCustomImage);override; public - constructor Create(aBitMapType:Integer); + ColorDepth: TPNMColorDepth; + BinaryFormat: boolean; + function GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth; + function GetColorDepthOfExtension(AExtension: string): TPNMColorDepth; + function GetFileExtension(AColorDepth: TPNMColorDepth): string; + constructor Create; override; end; + { TFPWriterPBM } + + TFPWriterPBM = class(TFPWriterPNM) + constructor Create; override; + end; + + { TFPWriterPGM } + + TFPWriterPGM = class(TFPWriterPNM) + constructor Create; override; + end; + + { TFPWriterPPM } + + TFPWriterPPM = class(TFPWriterPNM) + constructor Create; override; + end; + +procedure SaveImageToPNMFile(Img: TFPCustomImage; filename: string; UseBinaryFormat: boolean = true); + implementation -constructor TFPWriterPNM.Create(aBitMapType:Integer); +procedure SaveImageToPNMFile(Img: TFPCustomImage; filename: string; UseBinaryFormat: boolean = true); +var writer: TFPWriterPNM; + curExt: string; +begin + writer := TFPWriterPNM.Create; + writer.BinaryFormat := UseBinaryFormat; + curExt := Lowercase(ExtractFileExt(filename)); + if (curExt='.pnm') or (curExt='') then begin - inherited Create; - BitMapType:=aBitMapType; - end; + writer.ColorDepth := writer.GuessColorDepthOfImage(Img); + filename := ChangeFileExt(filename,'.'+writer.GetFileExtension(writer.ColorDepth)); + end else + writer.ColorDepth := writer.GetColorDepthOfExtension(curExt); + Img.SaveToFile(filename,writer); + writer.Free; +end; + +{ TFPWriterPPM } + +constructor TFPWriterPPM.Create; +begin + inherited Create; + ColorDepth := pcdRGB; +end; + +{ TFPWriterPGM } + +constructor TFPWriterPGM.Create; +begin + inherited Create; + ColorDepth := pcdGrayscale; +end; + +{ TFPWriterPBM } + +constructor TFPWriterPBM.Create; +begin + inherited Create; + ColorDepth:= pcdBlackWhite; +end; + +{ TFPWriterPNM } + +constructor TFPWriterPNM.Create; +begin + inherited Create; + ColorDepth := pcdAuto; + BinaryFormat := True; +end; + procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); +var useBitMapType: integer; + function SaveHeader(stream:TStream):boolean; const MagicWords:Array[1..6]OF String[2]=('P1','P2','P3','P4','P5','P6'); @@ -55,8 +129,8 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); Str(Img.Width,StrWidth); Str(Img.Height,StrHeight); end; - PNMInfo:=Concat(MagicWords[BitMapType],#10,StrWidth,#32,StrHeight,#10); - if BitMapType in [2,3,5,6] + PNMInfo:=Concat(MagicWords[useBitMapType],#10,StrWidth,#32,StrHeight,#10); + if useBitMapType in [2,3,5,6] then PNMInfo:=Concat(PNMInfo,'255'#10); stream.seek(0,soFromBeginning); @@ -68,18 +142,31 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); aColor:TFPColor; aLine:PByte; strCol:String[3]; + LinuxEndOfLine: char; + UseColorDepth: TPNMColorDepth; + begin + LinuxEndOfLine := #10; + + //determine color depth + if ColorDepth = pcdAuto then + UseColorDepth := GuessColorDepthOfImage(Img) else + UseColorDepth := ColorDepth; + + //determine file format number (1-6) + case UseColorDepth of + pcdBlackWhite: useBitMapType := 1; + pcdGrayscale: useBitMapType := 2; + pcdRGB: useBitMapType := 3; + end; + if BinaryFormat then inc(useBitMapType,3); + SaveHeader(Stream); - case BitMapType of + case useBitMapType of 1:nBpLine:=Img.Width*2;{p p p} 2:nBpLine:=Img.Width*4;{lll lll lll} 3:nBpLine:=Img.Width*3*4;{rrr ggg bbb rrr ggg bbb} - 4:begin - nBpLine:=Img.Width SHR 3; - if(Img.Width AND $0F)<>0 - then - Inc(nBpLine); - end; + 4:nBpLine:=(Img.Width+7) SHR 3; 5:nBpLine:=Img.Width; 6:nBpLine:=Img.Width*3; end; @@ -91,7 +178,7 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); begin aColor:=img.Colors[Coulumn,Row]; with aColor do - case BitMapType of + case useBitMapType of 1:begin if(Red<=$2F00)or(Green<=$2F00)or(Blue<=$2F00) then @@ -136,10 +223,61 @@ procedure TFPWriterPNM.InternalWrite(Stream:TStream;Img:TFPCustomImage); end; end; Stream.Write(aLine^,nBpLine); + if useBitMapType in[1..3] then Stream.Write(LinuxEndOfLine,1); end; FreeMem(aLine,nBpLine); end; +function TFPWriterPNM.GetColorDepthOfExtension(AExtension: string + ): TPNMColorDepth; +begin + if (length(AExtension) > 0) and (AExtension[1]='.') then + delete(AExtension,1,1); + AExtension := LowerCase(AExtension); + if AExtension='pbm' then result := pcdBlackWhite else + if AExtension='pgm' then result := pcdGrayscale else + if AExtension='ppm' then result := pcdRGB else + result := pcdAuto; +end; + +function TFPWriterPNM.GuessColorDepthOfImage(Img: TFPCustomImage): TPNMColorDepth; +var Row, Col: integer; + aColor: TFPColor; +begin + result := pcdBlackWhite; + for Row:=0 to img.Height-1 do + for Col:=0 to img.Width-1 do + begin + aColor:=img.Colors[Col,Row]; + if (AColor.red >= 256) and (AColor.green >= 256) and (AColor.blue >= 256) and + (AColor.red < $FF00) and (AColor.green < $FF00) and (AColor.blue < $FF00) then + begin + if (AColor.red shr 8 <> AColor.Green shr 8) or + (AColor.blue shr 8 <> AColor.Green shr 8) or + (AColor.red shr 8 <> AColor.blue shr 8) then + begin + result := pcdRGB; + exit; + end else + result := pcdGrayscale; + end; + end; +end; + +function TFPWriterPNM.GetFileExtension(AColorDepth: TPNMColorDepth): string; +begin + case AColorDepth of + pcdBlackWhite: result := 'pbm'; + pcdGrayscale: result := 'pgm'; + pcdRGB: result := 'ppm'; + else + result := 'pnm'; + end; +end; + initialization - ImageHandlers.RegisterImageWriter ('PBM Format', 'pbm', TFPWriterPNM); + ImageHandlers.RegisterImageWriter ('Netpbm Portable aNyMap', 'pnm', TFPWriterPNM); + ImageHandlers.RegisterImageWriter ('Netpbm Portable BitMap', 'pbm', TFPWriterPBM); + ImageHandlers.RegisterImageWriter ('Netpbm Portable GrayMap', 'pgm', TFPWriterPGM); + ImageHandlers.RegisterImageWriter ('Netpbm Portable PixelMap', 'ppm', TFPWriterPPM); end.