LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Graphic engine friendly loading of TGA image.
6

7
  History :  
8
         04/04/11 - Yar - Creation
9
    
10
}
11

12
unit GLFileTGA;
13

14
interface
15

16
{.$I GLScene.inc}
17

18
uses
19
  Classes,
20
  SysUtils,
21
  GLCrossPlatform,
22
  OpenGLTokens,
23
  GLContext,
24
  GLGraphics,
25
  GLTextureFormat,
26
  GLApplicationFileIO;
27

28
type
29

30

31
  TGLTGAImage = class(TGLBaseImage)
32
  public
33
     
34
    procedure LoadFromFile(const filename: string); override;
35
    procedure SaveToFile(const filename: string); override;
36
    procedure LoadFromStream(stream: TStream); override;
37
    procedure SaveToStream(stream: TStream); override;
38
    class function Capabilities: TGLDataFileCapabilities; override;
39

40
    procedure AssignFromTexture(textureContext: TGLContext;
41
      const textureHandle: TGLuint;
42
      textureTarget: TGLTextureTarget;
43
      const CurrentFormat: boolean;
44
      const intFormat: TGLInternalFormat); reintroduce;
45
  end;
46

47
implementation
48

49
type
50

51
  // TTGAHeader
52
  //
53

54
  TTGAFileHeader = packed record
55
    IDLength: Byte;
56
    ColorMapType: Byte;
57
    ImageType: Byte;
58
    ColorMapOrigin: Word;
59
    ColorMapLength: Word;
60
    ColorMapEntrySize: Byte;
61
    XOrigin: Word;
62
    YOrigin: Word;
63
    Width: Word;
64
    Height: Word;
65
    PixelSize: Byte;
66
    ImageDescriptor: Byte;
67
  end;
68

69
  // ReadAndUnPackRLETGA24
70
  //
71

72
procedure ReadAndUnPackRLETGA24(stream: TStream; destBuf: PAnsiChar; totalSize: Integer);
73
type
74
  TRGB24 = packed record
75
    r, g, b: Byte;
76
  end;
77
  PRGB24 = ^TRGB24;
78
var
79
  n: Integer;
80
  color: TRGB24;
81
  bufEnd: PAnsiChar;
82
  b: Byte;
83
begin
84
  bufEnd := @destBuf[totalSize];
85
  while destBuf < bufEnd do
86
  begin
87
    stream.Read(b, 1);
88
    if b >= 128 then
89
    begin
90
      // repetition packet
91
      stream.Read(color, 3);
92
      b := (b and 127) + 1;
93
      while b > 0 do
94
      begin
95
        PRGB24(destBuf)^ := color;
96
        Inc(destBuf, 3);
97
        Dec(b);
98
      end;
99
    end
100
    else
101
    begin
102
      n := ((b and 127) + 1) * 3;
103
      stream.Read(destBuf^, n);
104
      Inc(destBuf, n);
105
    end;
106
  end;
107
end;
108

109
// ReadAndUnPackRLETGA32
110
//
111

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

149
 
150
//
151

152
procedure TGLTGAImage.LoadFromFile(const filename: string);
153
var
154
  fs: TStream;
155
begin
156
  if FileStreamExists(fileName) then
157
  begin
158
    fs := CreateFileStream(fileName, fmOpenRead);
159
    try
160
      LoadFromStream(fs);
161
    finally
162
      fs.Free;
163
      ResourceName := filename;
164
    end;
165
  end
166
  else
167
    raise EInvalidRasterFile.CreateFmt('File %s not found', [filename]);
168
end;
169

170
// SaveToFile
171
//
172

173
procedure TGLTGAImage.SaveToFile(const filename: string);
174
var
175
  fs: TStream;
176
begin
177
  fs := CreateFileStream(fileName, fmOpenWrite or fmCreate);
178
  try
179
    SaveToStream(fs);
180
  finally
181
    fs.Free;
182
  end;
183
  ResourceName := filename;
184
end;
185

186
// LoadFromStream
187
//
188

189
procedure TGLTGAImage.LoadFromStream(stream: TStream);
190
var
191
  LHeader: TTGAFileHeader;
192
  y, rowSize, bufSize: Integer;
193
  verticalFlip: Boolean;
194
  unpackBuf: PAnsiChar;
195
  Ptr: PByte;
196
begin
197
  stream.Read(LHeader, Sizeof(TTGAFileHeader));
198

199
  if LHeader.ColorMapType <> 0 then
200
    raise EInvalidRasterFile.Create('ColorMapped TGA unsupported');
201

202
  UnMipmap;
203
  FLOD[0].Width := LHeader.Width;
204
  FLOD[0].Height := LHeader.Height;
205
  FLOD[0].Depth := 0;
206

207
  case LHeader.PixelSize of
208
    24:
209
      begin
210
        FColorFormat := GL_BGR;
211
        FInternalFormat := tfRGB8;
212
        FElementSize := 3;
213
      end;
214
    32:
215
      begin
216
        FColorFormat := GL_RGBA;
217
        FInternalFormat := tfRGBA8;
218
        FElementSize := 4;
219
      end;
220
  else
221
    raise EInvalidRasterFile.Create('Unsupported TGA ImageType');
222
  end;
223

224
  FDataType := GL_UNSIGNED_BYTE;
225
  FCubeMap := False;
226
  FTextureArray := False;
227
  ReallocMem(FData, DataSize);
228

229
  rowSize := GetWidth * FElementSize;
230
  verticalFlip := ((LHeader.ImageDescriptor and $20) <> 1);
231

232
  if LHeader.IDLength > 0 then
233
    stream.Seek(LHeader.IDLength, soFromCurrent);
234

235
  case LHeader.ImageType of
236
    2:
237
      begin // uncompressed RGB/RGBA
238
        if verticalFlip then
239
        begin
240
          Ptr := PByte(FData);
241
          Inc(Ptr, rowSize * (GetHeight - 1));
242
          for y := 0 to GetHeight - 1 do
243
          begin
244
            stream.Read(Ptr^, rowSize);
245
            Dec(Ptr, rowSize);
246
          end;
247
        end
248
        else
249
          stream.Read(FData^, rowSize * GetHeight);
250
      end;
251
    10:
252
      begin // RLE encoded RGB/RGBA
253
        bufSize := GetHeight * rowSize;
254
        GetMem(unpackBuf, bufSize);
255
        try
256
          // read & unpack everything
257
          if LHeader.PixelSize = 24 then
258
            ReadAndUnPackRLETGA24(stream, unpackBuf, bufSize)
259
          else
260
            ReadAndUnPackRLETGA32(stream, unpackBuf, bufSize);
261
          // fillup bitmap
262
          if verticalFlip then
263
          begin
264
            Ptr := PByte(FData);
265
            Inc(Ptr, rowSize * (GetHeight - 1));
266
            for y := 0 to GetHeight - 1 do
267
            begin
268
              Move(unPackBuf[y * rowSize], Ptr^, rowSize);
269
              Dec(Ptr, rowSize);
270
            end;
271
          end
272
          else
273
            Move(unPackBuf[rowSize * GetHeight], FData^, rowSize * GetHeight);
274
        finally
275
          FreeMem(unpackBuf);
276
        end;
277
      end;
278
  else
279
    raise EInvalidRasterFile.CreateFmt('Unsupported TGA ImageType %d',
280
      [LHeader.ImageType]);
281
  end;
282
end;
283

284
// SaveToStream
285
//
286

287
procedure TGLTGAImage.SaveToStream(stream: TStream);
288
begin
289
{$MESSAGE Hint 'TGLTGAImage.SaveToStream not yet implemented' }
290
end;
291

292
// AssignFromTexture
293
//
294

295
procedure TGLTGAImage.AssignFromTexture(textureContext: TGLContext;
296
  const textureHandle: TGLuint; textureTarget: TGLTextureTarget;
297
  const CurrentFormat: boolean; const intFormat: TGLInternalFormat);
298
begin
299
{$MESSAGE Hint 'TGLTGAImage.AssignFromTexture not yet implemented' }
300
end;
301

302
class function TGLTGAImage.Capabilities: TGLDataFileCapabilities;
303
begin
304
  Result := [dfcRead {, dfcWrite}];
305
end;
306

307
initialization
308

309
  { Register this Fileformat-Handler with GLScene }
310
  RegisterRasterFormat('tga', 'TARGA Image File', TGLTGAImage);
311
//  TGLPicture.RegisterFileFormat('tga', 'TARGA Image File', TGLTGAImage);
312

313
finalization
314

315
 //  TGLPicture.UnregisterGraphicClass(TGLTGAImage);
316

317
end.
318

319