LZScene

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

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

12
unit GLFileBMP;
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
  TGLBMPImage = class(TGLBaseImage)
31
  private
32
     
33
    FTopDown: Boolean;
34
    RedMask, GreenMask, BlueMask: LongWord;
35
    RedShift, GreenShift, BlueShift: ShortInt;
36
    FLineBuffer: PByteArray;
37
    FReadSize: Integer;
38
    FDeltaX: Integer;
39
    FDeltaY: Integer;
40
    function CountBits(Value: byte): shortint;
41
    function ShiftCount(Mask: longword): shortint;
42
    function ExpandColor(Value: longword): TGLPixel32;
43
    procedure ExpandRLE4ScanLine(Row: Integer; Stream: TStream);
44
    procedure ExpandRLE8ScanLine(Row: Integer; Stream: TStream);
45
    function Monochrome(N: Integer): Integer;
46
    function Quadrochrome(N: Integer): Integer;
47
    function Octochrome(N: Integer): Integer;
48
  public
49
     
50
    procedure LoadFromFile(const filename: string); override;
51
    procedure SaveToFile(const filename: string); override;
52
    procedure LoadFromStream(stream: TStream); override;
53
    procedure SaveToStream(stream: TStream); override;
54
    class function Capabilities: TGLDataFileCapabilities; override;
55

56
    procedure AssignFromTexture(textureContext: TGLContext;
57
      const textureHandle: TGLuint;
58
      textureTarget: TGLTextureTarget;
59
      const CurrentFormat: boolean;
60
      const intFormat: TGLInternalFormat); reintroduce;
61
  end;
62

63
implementation
64

65
const
66

67
  BMmagic = 19778; // BMP magic word is always 19778 : 'BM'
68
  // Values for Compression field
69
  BI_RGB = 0;
70
  BI_RLE8 = 1;
71
  BI_RLE4 = 2;
72
  BI_BITFIELDS = 3;
73

74
type
75

76
  TBitMapFileHeader = packed record
77
    {00+02 :File type}
78
    bfType: word;
79
    {02+04 :File size in bytes}
80
    bfSize: longint;
81
    {06+04 : Reserved}
82
    bfReserved: longint;
83
    {10+04 : Offset of image data : size if the file hieder + the info header + palette}
84
    bfOffset: longint;
85
  end;
86
  PBitMapFileHeader = ^TBitMapFileHeader;
87

88
  TBitMapInfoHeader = packed record
89
    {14+04 : Size of the bitmap info header : sould be 40=$28}
90
    Size: longint;
91
    {18+04 : Image width in pixels}
92
    Width: longint;
93
    {22+04 : Image height in pixels}
94
    Height: longint;
95
    {26+02 : Number of image planes : should be 1 always}
96
    Planes: word;
97
    {28+02 : Color resolution : Number of bits per pixel (1,4,8,16,24,32)}
98
    BitCount: word;
99
    {30+04 : Compression Type}
100
    Compression: longint;
101
    {34+04 : Size of image data (not headers nor palette): can be 0 if no compression}
102
    SizeImage: longint;
103
    {38+04 : Horizontal resolution in pixel/meter}
104
    XPelsPerMeter: Longint;
105
    {42+04 : Vertical resolution in pixel/meter}
106
    YPelsPerMeter: Longint;
107
    {46+04 : Number of colors used}
108
    ClrUsed: longint;
109
    {50+04 : Number of imprtant colors used : usefull for displaying on VGA256}
110
    ClrImportant: longint;
111
  end;
112
  PBitMapInfoHeader = ^TBitMapInfoHeader;
113

114
 
115
//
116

117
procedure TGLBMPImage.LoadFromFile(const filename: string);
118
var
119
  fs: TStream;
120
begin
121
  if FileStreamExists(fileName) then
122
  begin
123
    fs := CreateFileStream(fileName, fmOpenRead);
124
    try
125
      LoadFromStream(fs);
126
    finally
127
      fs.Free;
128
      ResourceName := filename;
129
    end;
130
  end
131
  else
132
    raise EInvalidRasterFile.CreateFmt('File %s not found', [filename]);
133
end;
134

135
// SaveToFile
136
//
137

138
procedure TGLBMPImage.SaveToFile(const filename: string);
139
var
140
  fs: TStream;
141
begin
142
  fs := CreateFileStream(fileName, fmOpenWrite or fmCreate);
143
  try
144
    SaveToStream(fs);
145
  finally
146
    fs.Free;
147
  end;
148
  ResourceName := filename;
149
end;
150

151
function TGLBMPImage.CountBits(Value: byte): shortint;
152
var
153
  i, bits: shortint;
154
begin
155
  bits := 0;
156
  for i := 0 to 7 do
157
  begin
158
    if (value mod 2) <> 0 then
159
      inc(bits);
160
    value := value shr 1;
161
  end;
162
  Result := bits;
163
end;
164

165
function TGLBMPImage.ShiftCount(Mask: longword): shortint;
166
var
167
  tmp: shortint;
168
begin
169
  tmp := 0;
170
  if Mask = 0 then
171
  begin
172
    Result := 0;
173
    exit;
174
  end;
175

176
  while (Mask mod 2) = 0 do // rightmost bit is 0
177
  begin
178
    inc(tmp);
179
    Mask := Mask shr 1;
180
  end;
181
  tmp := tmp - (8 - CountBits(Mask and $FF));
182
  Result := tmp;
183
end;
184

185
function TGLBMPImage.ExpandColor(Value: longword): TGLPixel32;
186
var
187
  tmpr, tmpg, tmpb: longword;
188
begin
189
  tmpr := value and RedMask;
190
  tmpg := value and GreenMask;
191
  tmpb := value and BlueMask;
192
  if RedShift < 0 then
193
    Result.R := byte(tmpr shl (-RedShift))
194
  else
195
    Result.R := byte(tmpr shr RedShift);
196
  if GreenShift < 0 then
197
    Result.G := byte(tmpg shl (-GreenShift))
198
  else
199
    Result.G := byte(tmpg shr GreenShift);
200
  if BlueShift < 0 then
201
    Result.B := byte(tmpb shl (-BlueShift))
202
  else
203
    Result.B := byte(tmpb shr BlueShift);
204
end;
205

206
function TGLBMPImage.Monochrome(N: Integer): Integer;
207
begin
208
  Result := (FLineBuffer[N div 8] shr (7 - (N and 7))) and 1;
209
end;
210

211
function TGLBMPImage.Quadrochrome(N: Integer): Integer;
212
begin
213
  Result := (FLineBuffer[N div 2] shr (((N + 1) and 1) * 4)) and $0F;
214
end;
215

216
function TGLBMPImage.Octochrome(N: Integer): Integer;
217
begin
218
  Result := FLineBuffer[N];
219
end;
220

221
// LoadFromStream
222
//
223

224
procedure TGLBMPImage.LoadFromStream(stream: TStream);
225
type
226
  TBitShiftFunc = function(N: Integer): Integer of object;
227
var
228
  LHeader: TBitMapFileHeader;
229
  LInfo: TBitMapInfoHeader;
230
  BadCompression: Boolean;
231
  Ptr: PByte;
232
  BitCount, LineSize: Integer;
233
  Row: Integer;
234
  nPalette: Integer;
235
  LPalette: array of TGLPixel32;
236
  BitShiftFunc: TBitShiftFunc;
237

238
  procedure ReadScanLine;
239
  var
240
    I: Integer;
241
  begin
242
    if nPalette > 0 then
243
    begin
244
      Stream.Read(FLineBuffer[0], FReadSize);
245
      for I := LInfo.Width - 1 downto 0 do
246
        PGLPixel32Array(Ptr)[I] := LPalette[BitShiftFunc(I)];
247
    end
248
    else if LInfo.Compression = BI_RLE8 then
249
    begin
250
      ExpandRLE8ScanLine(Row, Stream);
251
      Move(FLineBuffer[0], Ptr^, LineSize);
252
    end
253
    else if LInfo.Compression = BI_RLE4 then
254
    begin
255
      ExpandRLE4ScanLine(Row, Stream);
256
      Move(FLineBuffer[0], Ptr^, LineSize);
257
    end
258
    else if LInfo.BitCount = 16 then
259
    begin
260
      Stream.Read(FLineBuffer[0], FReadSize);
261
      for I := LInfo.Width - 1 downto 0 do
262
        PGLPixel32Array(Ptr)[I] := ExpandColor(PWordArray(FLineBuffer)[I]);
263
    end
264
    else
265
      Stream.Read(Ptr^, FReadSize);
266

267
    Inc(Ptr, LineSize);
268
  end;
269

270
begin
271
  stream.Read(LHeader, SizeOf(TBitMapFileHeader));
272
  if LHeader.bfType <> BMmagic then
273
    raise EInvalidRasterFile.Create('Invalid BMP header');
274

275
  stream.Read(LInfo, SizeOf(TBitMapInfoHeader));
276
  stream.Position := stream.Position - SizeOf(TBitMapInfoHeader) + LInfo.Size;
277

278
  BadCompression := false;
279
  if ((LInfo.Compression = BI_RLE4) and (LInfo.BitCount <> 4)) then
280
    BadCompression := true;
281
  if ((LInfo.Compression = BI_RLE8) and (LInfo.BitCount <> 8)) then
282
    BadCompression := true;
283
  if ((LInfo.Compression = BI_BITFIELDS) and (not (LInfo.BitCount in [16, 32]))) then
284
    BadCompression := true;
285
  if not (LInfo.Compression in [BI_RGB..BI_BITFIELDS]) then
286
    BadCompression := true;
287
  if BadCompression then
288
    raise EInvalidRasterFile.Create('Bad BMP compression mode');
289
  FTopDown := (LInfo.Height < 0);
290
  LInfo.Height := abs(LInfo.Height);
291
  if (FTopDown and (not (LInfo.Compression in [BI_RGB, BI_BITFIELDS]))) then
292
    raise EInvalidRasterFile.Create('Top-down bitmaps cannot be compressed');
293

294
  nPalette := 0;
295
  if ((LInfo.Compression = BI_RGB)
296
    and (LInfo.BitCount = 16)) then // 5 bits per channel, fixed mask
297
  begin
298
    RedMask := $7C00;
299
    RedShift := 7;
300
    GreenMask := $03E0;
301
    GreenShift := 2;
302
    BlueMask := $001F;
303
    BlueShift := -3;
304
  end
305
  else if ((LInfo.Compression = BI_BITFIELDS)
306
    and (LInfo.BitCount in [16, 32])) then // arbitrary mask
307
  begin
308
    Stream.Read(RedMask, 4);
309
    Stream.Read(GreenMask, 4);
310
    Stream.Read(BlueMask, 4);
311
    RedShift := ShiftCount(RedMask);
312
    GreenShift := ShiftCount(GreenMask);
313
    BlueShift := ShiftCount(BlueMask);
314
  end
315
  else if LInfo.BitCount in [1, 4, 8] then
316
  begin
317
    nPalette := 1 shl LInfo.BitCount;
318
    SetLength(LPalette, nPalette);
319
    if LInfo.ClrUsed > 0 then
320
      Stream.Read(LPalette[0], LInfo.ClrUsed * SizeOf(TGLPixel32))
321
    else // Seems to me that this is dangerous.
322
      Stream.Read(LPalette[0], nPalette * SizeOf(TGLPixel32));
323
  end
324
  else if LInfo.ClrUsed > 0 then { Skip palette }
325
    Stream.Position := Stream.Position + LInfo.ClrUsed * 3;
326

327
  UnMipmap;
328
  FLOD[0].Width := LInfo.Width;
329
  FLOD[0].Height := LInfo.Height;
330
  FLOD[0].Depth := 0;
331
  BitCount := 0;
332
  FColorFormat := GL_BGRA;
333
  FInternalFormat := tfRGBA8;
334
  FElementSize := 4;
335

336
  case LInfo.BitCount of
337
    1:
338
      begin
339
        BitCount := 1;
340
        BitShiftFunc := Monochrome;
341
      end;
342
    4:
343
      begin
344
        BitCount := 4;
345
        BitShiftFunc := Quadrochrome;
346
      end;
347
    8:
348
      begin
349
        BitCount := 8;
350
        BitShiftFunc := Octochrome;
351
      end;
352
    16:
353
      BitCount := 16;
354
    24:
355
      begin
356
        BitCount := 24;
357
        FColorFormat := GL_BGR;
358
        FInternalFormat := tfRGB8;
359
        FElementSize := 3;
360
      end;
361
    32:
362
      BitCount := 32;
363
  end;
364

365
  FDataType := GL_UNSIGNED_BYTE;
366
  FCubeMap := False;
367
  FTextureArray := False;
368
  ReallocMem(FData, DataSize);
369

370
  FDeltaX := -1;
371
  FDeltaY := -1;
372
  Ptr := PByte(FData);
373
  LineSize := GetWidth * FElementSize;
374

375
  FReadSize := ((LInfo.Width * BitCount + 31) div 32) shl 2;
376
  GetMem(FLineBuffer, FReadSize);
377

378
  try
379
    if FTopDown then
380
      for Row := 0 to GetHeight - 1 do // A rare case of top-down bitmap!
381
        ReadScanLine
382
    else
383
      for Row := GetHeight - 1 downto 0 do
384
        ReadScanLine;
385
  finally
386
    FreeMem(FLineBuffer);
387
  end;
388

389
end;
390

391
procedure TGLBMPImage.ExpandRLE4ScanLine(Row: Integer; Stream: TStream);
392
var
393
  i, j, tmpsize: integer;
394
  b0, b1: byte;
395
  nibline: PByteArray;
396
  even: boolean;
397
begin
398
  tmpsize := FReadSize * 2; { ReadSize is in bytes, while nibline is made of nibbles, so it's 2*readsize long }
399
  getmem(nibline, tmpsize);
400
  try
401
    i := 0;
402
    while true do
403
    begin
404
      { let's see if we must skip pixels because of delta... }
405
      if FDeltaY <> -1 then
406
      begin
407
        if Row = FDeltaY then
408
          j := FDeltaX { If we are on the same line, skip till DeltaX }
409
        else
410
          j := tmpsize; { else skip up to the end of this line }
411
        while (i < j) do
412
        begin
413
          NibLine[i] := 0;
414
          inc(i);
415
        end;
416

417
        if Row = FDeltaY then { we don't need delta anymore }
418
          FDeltaY := -1
419
        else
420
          break; { skipping must continue on the next line, we are finished here }
421
      end;
422

423
      Stream.Read(b0, 1);
424
      Stream.Read(b1, 1);
425
      if b0 <> 0 then { number of repetitions }
426
      begin
427
        if b0 + i > tmpsize then
428
          raise EInvalidRasterFile.Create('Bad BMP RLE chunk at row ' + inttostr(row) + ', col ' + inttostr(i) + ', file offset $' + inttohex(Stream.Position, 16));
429
        even := true;
430
        j := i + b0;
431
        while (i < j) do
432
        begin
433
          if even then
434
            NibLine[i] := (b1 and $F0) shr 4
435
          else
436
            NibLine[i] := b1 and $0F;
437
          inc(i);
438
          even := not even;
439
        end;
440
      end
441
      else
442
        case b1 of
443
          0: break; { end of line }
444
          1: break; { end of file }
445
          2:
446
            begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
447
              Stream.Read(b0, 1);
448
              Stream.Read(b1, 1);
449
              FDeltaX := i + b0;
450
              FDeltaY := Row + b1;
451
            end
452
        else
453
          begin { absolute mode }
454
            if b1 + i > tmpsize then
455
              raise EInvalidRasterFile.Create('Bad BMP RLE chunk at row ' + inttostr(row) + ', col ' + inttostr(i) + ', file offset $' + inttohex(Stream.Position, 16));
456
            j := i + b1;
457
            even := true;
458
            while (i < j) do
459
            begin
460
              if even then
461
              begin
462
                Stream.Read(b0, 1);
463
                NibLine[i] := (b0 and $F0) shr 4;
464
              end
465
              else
466
                NibLine[i] := b0 and $0F;
467
              inc(i);
468
              even := not even;
469
            end;
470
            { aligned on 2 bytes boundary: see rle8 for details  }
471
            b1 := b1 + (b1 mod 2);
472
            if (b1 mod 4) <> 0 then
473
              Stream.Seek(1, soFromCurrent);
474
          end;
475
        end;
476
    end;
477
    { pack the nibline into the linebuf }
478
    for i := 0 to FReadSize - 1 do
479
      FLineBuffer[i] := (NibLine[i * 2] shl 4) or NibLine[i * 2 + 1];
480
  finally
481
    FreeMem(nibline)
482
  end;
483
end;
484

485
procedure TGLBMPImage.ExpandRLE8ScanLine(Row: Integer; Stream: TStream);
486
var
487
  i, j: integer;
488
  b0, b1: byte;
489
begin
490
  i := 0;
491
  while true do
492
  begin
493
    { let's see if we must skip pixels because of delta... }
494
    if FDeltaY <> -1 then
495
    begin
496
      if Row = FDeltaY then
497
        j := FDeltaX { If we are on the same line, skip till DeltaX }
498
      else
499
        j := FReadSize; { else skip up to the end of this line }
500
      while (i < j) do
501
      begin
502
        FLineBuffer[i] := 0;
503
        inc(i);
504
      end;
505

506
      if Row = FDeltaY then { we don't need delta anymore }
507
        FDeltaY := -1
508
      else
509
        break; { skipping must continue on the next line, we are finished here }
510
    end;
511

512
    Stream.Read(b0, 1);
513
    Stream.Read(b1, 1);
514
    if b0 <> 0 then { number of repetitions }
515
    begin
516
      if b0 + i > FReadSize then
517
        raise EInvalidRasterFile.Create('Bad BMP RLE chunk at row ' + inttostr(row) + ', col ' + inttostr(i) + ', file offset $' + inttohex(Stream.Position, 16));
518
      j := i + b0;
519
      while (i < j) do
520
      begin
521
        FLineBuffer[i] := b1;
522
        inc(i);
523
      end;
524
    end
525
    else
526
      case b1 of
527
        0: break; { end of line }
528
        1: break; { end of file }
529
        2:
530
          begin { Next pixel position. Skipped pixels should be left untouched, but we set them to zero }
531
            Stream.Read(b0, 1);
532
            Stream.Read(b1, 1);
533
            FDeltaX := i + b0;
534
            FDeltaY := Row + b1;
535
          end
536
      else
537
        begin { absolute mode }
538
          if b1 + i > FReadSize then
539
            raise EInvalidRasterFile.Create('Bad BMP RLE chunk at row ' + inttostr(row) + ', col ' + inttostr(i) + ', file offset $' + inttohex(Stream.Position, 16));
540
          Stream.Read(FLineBuffer[i], b1);
541
          inc(i, b1);
542
          { aligned on 2 bytes boundary: every group starts on a 2 bytes boundary, but absolute group
543
            could end on odd address if there is a odd number of elements, so we pad it  }
544
          if (b1 mod 2) <> 0 then
545
            Stream.Seek(1, soFromCurrent);
546
        end;
547
      end;
548
  end;
549
end;
550

551
// SaveToStream
552
//
553

554
procedure TGLBMPImage.SaveToStream(stream: TStream);
555
begin
556
  {$Message Hint 'TGLBMPImage.SaveToStream not yet implemented' }
557
end;
558

559
// AssignFromTexture
560
//
561

562
procedure TGLBMPImage.AssignFromTexture(textureContext: TGLContext;
563
  const textureHandle: TGLuint; textureTarget: TGLTextureTarget;
564
  const CurrentFormat: boolean; const intFormat: TGLInternalFormat);
565
begin
566
  {$Message Hint 'TGLBMPImage.AssignFromTexture not yet implemented' }
567
end;
568

569
class function TGLBMPImage.Capabilities: TGLDataFileCapabilities;
570
begin
571
  Result := [dfcRead {, dfcWrite}];
572
end;
573

574
initialization
575

576
  { Register this Fileformat-Handler with GLScene }
577
  RegisterRasterFormat('bmp', 'Bitmap Image File', TGLBMPImage);
578

579
end.
580

581