LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Simple TGA formats supports for Delphi. 
6
   Currently supports only 24 and 32 bits RGB formats (uncompressed
7
   and RLE compressed).
8

9
   Based on David McDuffee's document from www.wotsit.org
10

11
	 History :  
12
            07/03/11 - Yar - Removed LazTGA, added workaround of ScanLine for Lazarus
13
            20/04/10 - Yar - Removed registration for FPC (thanks to Rustam Asmandiarov aka Predator) 
14
	    07/01/10 - DaStr - TTGAImage is now replaced by LazTGA.TTGAImage
15
                              in Lazarus (thanks Predator)   
16
	    08/07/04 - LR - Uses of Graphics replaced by GLCrossPlatform for Linux
17
	    21/11/02 - Egg - Creation
18
	 
19
}
20
unit TGA;
21

22
interface
23

24
{$I GLScene.inc}
25

26
uses 
27
  Classes, 
28
  SysUtils, 
29
  GLCrossPlatform;
30

31
type
32

33
   { TGA image load/save capable class for Delphi.
34
      TGA formats supported : 24 and 32 bits uncompressed or RLE compressed,
35
      saves only to uncompressed TGA. }
36
        TTGAImage = class (TGLBitmap)
37
	       
38

39
	   public
40
	       
41
	      constructor Create; override;
42
         destructor Destroy; override;
43

44
         procedure LoadFromStream(stream : TStream); override;
45
         procedure SaveToStream(stream : TStream); override;
46
	end;
47

48
   ETGAException = class (Exception)
49
   end;
50

51

52
// ------------------------------------------------------------------
53
// ------------------------------------------------------------------
54
// ------------------------------------------------------------------
55
implementation
56
// ------------------------------------------------------------------
57
// ------------------------------------------------------------------
58
// ------------------------------------------------------------------
59

60
uses
61
  GLGraphics,GraphType, LCLType ;
62

63
type
64

65
   // TTGAHeader
66
   //
67
   TTGAHeader = packed record
68
      IDLength          : Byte;
69
      ColorMapType      : Byte;
70
      ImageType         : Byte;
71
      ColorMapOrigin    : Word;
72
      ColorMapLength    : Word;
73
      ColorMapEntrySize : Byte;
74
      XOrigin           : Word;
75
      YOrigin           : Word;
76
      Width             : Word;
77
      Height            : Word;
78
      PixelSize         : Byte;
79
      ImageDescriptor   : Byte;
80
  end;
81

82
// ReadAndUnPackRLETGA24
83
//
84
procedure ReadAndUnPackRLETGA24(stream : TStream; destBuf : PAnsiChar; totalSize : Integer);
85
type
86
   TRGB24 = packed record
87
      r, g, b : Byte;
88
   end;
89
   PRGB24 = ^TRGB24;
90
var
91
   n : Integer;
92
   color : TRGB24;
93
   bufEnd : PAnsiChar;
94
   b : Byte;
95
begin
96
   bufEnd:=@destBuf[totalSize];
97
   while destBuf<bufEnd do 
98
   begin
99
      stream.Read(b, 1);
100
      if b>=128 then 
101
	  begin
102
         // repetition packet
103
         stream.Read(color, 3);
104
         b:=(b and 127)+1;
105
         while b>0 do 
106
		 begin
107
            PRGB24(destBuf)^:=color;
108
            Inc(destBuf, 3);
109
            Dec(b);
110
         end;
111
      end 
112
	  else 
113
	  begin
114
         n:=((b and 127)+1)*3;
115
         stream.Read(destBuf^, n);
116
         Inc(destBuf, n);
117
      end;
118
   end;
119
end;
120

121
// ReadAndUnPackRLETGA32
122
//
123
procedure ReadAndUnPackRLETGA32(stream : TStream; destBuf : PAnsiChar; totalSize : Integer);
124
type
125
   TRGB32 = packed record
126
      r, g, b, a : Byte;
127
   end;
128
   PRGB32 = ^TRGB32;
129
var
130
   n : Integer;
131
   color : TRGB32;
132
   bufEnd : PAnsiChar;
133
   b : Byte;
134
begin
135
   bufEnd:=@destBuf[totalSize];
136
   while destBuf<bufEnd do 
137
   begin
138
      stream.Read(b, 1);
139
      if b>=128 then 
140
	  begin
141
         // repetition packet
142
         stream.Read(color, 4);
143
         b:=(b and 127)+1;
144
         while b>0 do 
145
		 begin
146
            PRGB32(destBuf)^:=color;
147
            Inc(destBuf, 4);
148
            Dec(b);
149
         end;
150
      end 
151
	  else 
152
	  begin
153
         n:=((b and 127)+1)*4;
154
         stream.Read(destBuf^, n);
155
         Inc(destBuf, n);
156
      end;
157
   end;
158
end;
159

160
// ------------------
161
// ------------------ TTGAImage ------------------
162
// ------------------
163

164
// Create
165
//
166
constructor TTGAImage.Create;
167
begin
168
	inherited Create;
169
end;
170

171
// Destroy
172
//
173
destructor TTGAImage.Destroy;
174
begin
175
	inherited Destroy;
176
end;
177

178
// LoadFromStream
179
//
180
procedure TTGAImage.LoadFromStream(stream : TStream);
181
var
182
   header : TTGAHeader;
183
   y, rowSize, bufSize : Integer;
184
   verticalFlip : Boolean;
185
   unpackBuf : PAnsiChar;
186

187
   rimg: TRawImage;
188

189

190
   function GetLineAddress(ALine: Integer): PByte;
191
   begin
192
     Result := PByte(@PGLPixel32Array(rimg.Data)[ALine*Width]);
193
   end;
194

195
begin
196
   stream.Read(header, Sizeof(TTGAHeader));
197

198
   if header.ColorMapType<>0 then
199
      raise ETGAException.Create('ColorMapped TGA unsupported');
200

201
   case header.PixelSize of
202
      24 : PixelFormat:=glpf24bit;
203
      32 : PixelFormat:=glpf32bit;
204
   else
205
      raise ETGAException.Create('Unsupported TGA ImageType');
206
   end;
207

208
   Width:=header.Width;
209
   Height:=header.Height;
210
   rowSize:=(Width*header.PixelSize) div 8;
211
   verticalFlip:=((header.ImageDescriptor and $20)=0);
212
   if header.IDLength>0 then
213
      stream.Seek(header.IDLength, soFromCurrent);
214

215

216
    try
217
     rimg.Init;
218
     rimg.Description.Init_BPP32_B8G8R8A8_BIO_TTB(Width, Height);
219
     rimg.Description.RedShift := 16;
220
     rimg.Description.BlueShift := 0;
221
     if verticalFlip then
222
       rimg.Description.LineOrder := riloTopToBottom
223
     else
224
       rimg.Description.LineOrder := riloBottomToTop;
225
     RIMG.DataSize := Width * Height * 4;
226
     GetMem(rimg.Data, RIMG.DataSize);
227

228

229

230
     case header.ImageType of
231
        0 : begin // empty image, support is useless but easy ;)
232
           Width:=0;
233
           Height:=0;
234
           Abort;
235
        end;
236
        2 : begin // uncompressed RGB/RGBA
237
           if verticalFlip then begin
238
              for y:=0 to Height-1 do
239
                 stream.Read(GetLineAddress(Height-y-1)^, rowSize);
240
           end else begin
241
              for y:=0 to Height-1 do
242
                 stream.Read(GetLineAddress(y)^, rowSize);
243
           end;
244
        end;
245
        10 : begin // RLE encoded RGB/RGBA
246
           bufSize:=Height*rowSize;
247
           unpackBuf:=GetMemory(bufSize);
248
           try
249
              // read & unpack everything
250
              if header.PixelSize=24 then
251
                 ReadAndUnPackRLETGA24(stream, unpackBuf, bufSize)
252
              else ReadAndUnPackRLETGA32(stream, unpackBuf, bufSize);
253
              // fillup bitmap
254
              if verticalFlip then begin
255
                 for y:=0 to Height-1 do begin
256
                    Move(unPackBuf[y*rowSize], GetLineAddress(Height-y-1)^, rowSize);
257
                 end;
258
              end else begin
259
                 for y:=0 to Height-1 do
260
                    Move(unPackBuf[y*rowSize], GetLineAddress(y)^, rowSize);
261
              end;
262
           finally
263
              FreeMemory(unpackBuf);
264
           end;
265
        end;
266
     else
267
        raise ETGAException.Create('Unsupported TGA ImageType '+IntToStr(header.ImageType));
268
     end;
269

270

271
     LoadFromRawImage(rimg, False);
272

273
   finally
274

275
     FreeMem(rimg.Data);
276

277
   end;
278
end;
279

280
// TTGAImage
281
//
282
procedure TTGAImage.SaveToStream(stream : TStream);
283
var
284
   header : TTGAHeader;
285
begin
286
   // prepare the header, essentially made up from zeroes
287
   FillChar(header, SizeOf(TTGAHeader), 0);
288
   header.ImageType:=2;
289
   header.Width:=Width;
290
   header.Height:=Height;
291

292
   header.PixelSize:=32;
293
   stream.Write(header, SizeOf(TTGAHeader));
294
   stream.Write(RawImage.Data^, Width*Height*4);
295

296
end;
297

298
// ------------------------------------------------------------------
299
// ------------------------------------------------------------------
300
// ------------------------------------------------------------------
301

302
initialization
303
// ------------------------------------------------------------------
304
// ------------------------------------------------------------------
305
// ------------------------------------------------------------------
306
   TGLPicture.RegisterFileFormat('tga', 'Targa', TTGAImage);
307

308
finalization
309

310
   TGLPicture.UnregisterGraphicClass(TTGAImage);
311
end.
312