source: trunk/Packages/bgrabitmap/bgraphoxo.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 16.4 KB
Line 
1unit BGRAPhoxo;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 BGRABitmapTypes, FPImage, BGRALayers, BGRABitmap, Classes, SysUtils, BMPcomn;
9
10const
11 PhoxoHeaderMagic : packed array[1..4] of char = 'oXo ';
12 PhoxoBlock_CanvasSize = 1;
13 PhoxoBlock_Layer = 2;
14 PhoxoBlock_TextLayer = 3;
15 PhoxoBlock_DPI = 4;
16 PhoxoBlock_LayerCaption = 5;
17 PhoxoBlock_LazPaintBlendMode = 128;
18 PhoxoBlock_EndOfFile = 255;
19
20type
21 TPhoxoHeader = packed record
22 magic: packed array[1..4] of char;
23 version: longword;
24 end;
25
26 TPhoxoBlockHeader = packed record
27 blockType : longword;
28 blockSize : longword;
29 end;
30
31 TPhoxoLayerHeader = packed record
32 layerVisible: longword;
33 layerLimited: longword;
34 opacityPercent: longword;
35 bmpHeader: TBitMapInfoHeader;
36 redMask,greenMask,blueMask: longword;
37 end;
38
39 { TBGRAPhoxoDocument }
40
41 TBGRAPhoxoDocument = class(TBGRALayeredBitmap)
42 private
43 FDPIX,FDPIY: integer;
44 protected
45 function GetMimeType: string; override;
46 procedure AddLayerFromPhoxoData(const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte);
47 public
48 constructor Create; overload; override;
49 constructor Create(AWidth, AHeight: integer); overload; override;
50 procedure LoadFromStream(AStream: TStream); override;
51 procedure LoadFromFile(const filenameUTF8: string); override;
52 procedure SaveToFile(const filenameUTF8: string); override;
53 procedure SaveToStream(AStream: TStream); override;
54 class function CheckFormat(Stream: TStream; ARestorePosition: boolean): boolean;
55 class function ReadBlock(Stream: TStream; out AHeader: TPhoxoBlockHeader; out ABlockData: PByte): boolean;
56 property DPIX: integer read FDPIX;
57 property DPIY: integer read FDPIY;
58 end;
59
60 { TBGRAReaderOXO }
61
62 TBGRAReaderOXO = class(TFPCustomImageReader)
63 private
64 FWidth,FHeight,FNbLayers: integer;
65 FDPIX,FDPIY: integer;
66 protected
67 function InternalCheck(Stream: TStream): boolean; override;
68 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
69 public
70 property Width: integer read FWidth;
71 property Height: integer read FHeight;
72 property NbLayers: integer read FNbLayers;
73 property DPIX: integer read FDPIX;
74 property DPIY: integer read FDPIY;
75 end;
76
77 { TBGRAWriterOXO }
78
79 TBGRAWriterOXO = class(TFPCustomImageWriter)
80 protected
81 procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
82 end;
83
84procedure RegisterPhoxoFormat;
85
86implementation
87
88uses BGRAUTF8, LazUTF8;
89
90var AlreadyRegistered: boolean;
91
92function ComputeRowStride(AWidth,ABitsPerPixel: Longword): Longword;
93begin
94 result := ((AWidth * ABitsPerPixel + 31) div 32)*4;
95end;
96
97procedure SwapLayerHeaderIfNeeded(var ALayerHeader: TPhoxoLayerHeader);
98begin
99 with ALayerHeader do
100 begin
101 layerVisible := LEtoN(layerVisible);
102 layerLimited := LEtoN(layerLimited);
103 opacityPercent := LEtoN(opacityPercent);
104 {$IFNDEF ENDIAN_LITTLE}SwapBMPInfoHeader(bmpHeader);{$ENDIF}
105 end;
106end;
107
108procedure RegisterPhoxoFormat;
109begin
110 if AlreadyRegistered then exit;
111 ImageHandlers.RegisterImageReader ('PhoXo', 'oXo', TBGRAReaderOXO);
112 RegisterLayeredBitmapReader('oXo', TBGRAPhoxoDocument);
113 RegisterLayeredBitmapWriter('oXo', TBGRAPhoxoDocument);
114 DefaultBGRAImageReader[ifPhoxo] := TBGRAReaderOXO;
115 DefaultBGRAImageWriter[ifPhoxo] := TBGRAWriterOXO;
116 AlreadyRegistered:= True;
117end;
118
119{ TBGRAWriterOXO }
120
121procedure TBGRAWriterOXO.InternalWrite(Str: TStream; Img: TFPCustomImage);
122var doc: TBGRAPhoxoDocument;
123 tempBmp: TBGRABitmap;
124 x,y: integer;
125begin
126 doc := TBGRAPhoxoDocument.Create;
127 if Img is TBGRABitmap then doc.AddLayer(Img as TBGRABitmap) else
128 begin
129 tempBmp := TBGRABitmap.Create(img.Width,img.Height);
130 for y := 0 to Img.Height-1 do
131 for x := 0 to img.Width-1 do
132 tempBmp.SetPixel(x,y, FPColorToBGRA(img.Colors[x,y]));
133 doc.AddOwnedLayer(tempBmp);
134 end;
135 doc.SaveToStream(Str);
136 doc.Free;
137end;
138
139{ TBGRAReaderOXO }
140
141function TBGRAReaderOXO.InternalCheck(Stream: TStream): boolean;
142begin
143 result := TBGRAPhoxoDocument.CheckFormat(Stream,True);
144end;
145
146procedure TBGRAReaderOXO.InternalRead(Stream: TStream; Img: TFPCustomImage);
147var layeredImage: TBGRAPhoxoDocument;
148 flat: TBGRABitmap;
149 x,y: integer;
150begin
151 FWidth := 0;
152 FHeight:= 0;
153 FNbLayers:= 0;
154 FDPIX := 0;
155 FDPIY := 0;
156 layeredImage := TBGRAPhoxoDocument.Create;
157 try
158 layeredImage.LoadFromStream(Stream);
159 flat := layeredImage.ComputeFlatImage;
160 try
161 FWidth:= layeredImage.Width;
162 FHeight:= layeredImage.Height;
163 FNbLayers:= layeredImage.NbLayers;
164 FDPIX := layeredImage.DPIX;
165 FDPIY := layeredImage.DPIY;
166 if Img is TBGRACustomBitmap then
167 TBGRACustomBitmap(img).Assign(flat)
168 else
169 begin
170 Img.SetSize(flat.Width,flat.Height);
171 for y := 0 to flat.Height-1 do
172 for x := 0 to flat.Width-1 do
173 Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
174 end;
175 finally
176 flat.free;
177 end;
178 finally
179 layeredImage.Free;
180 end;
181end;
182
183{ TBGRAPhoxoDocument }
184
185function TBGRAPhoxoDocument.GetMimeType: string;
186begin
187 Result:= 'image/phoxo';
188end;
189
190procedure TBGRAPhoxoDocument.AddLayerFromPhoxoData(
191 const ABlockHeader: TPhoxoBlockHeader; ABlockData: PByte);
192var
193 layerHeader: TPhoxoLayerHeader;
194 rawImageSize: longword;
195 rowStride: longword;
196 remaining: longword;
197 bmp: TBGRABitmap;
198 layerIndex,y,x: integer;
199 pSrc: PByte;
200 pDest: PBGRAPixel;
201begin
202 remaining := ABlockHeader.blockSize;
203 if remaining < sizeof(TPhoxoLayerHeader) then raise EFormatError.Create('Block too small');
204 move(ABlockData^, {%H-}layerHeader, sizeof(layerHeader));
205 inc(ABlockData, sizeof(layerHeader));
206 dec(remaining, sizeof(layerHeader));
207 SwapLayerHeaderIfNeeded(layerHeader);
208
209 if layerHeader.bmpHeader.Compression <> BI_RGB then raise EFormatError.Create('Compression not supported');
210 if (layerHeader.bmpHeader.Width < 0) or (layerHeader.bmpHeader.Height < 0) then
211 raise EFormatError.Create('Invalid image size');
212 if int64(layerHeader.bmpHeader.Width)*layerHeader.bmpHeader.Height > maxLongint div 4 then
213 raise EOutOfMemory.Create('Image too big');
214 rowStride := ComputeRowStride(layerHeader.bmpHeader.Width,layerHeader.bmpHeader.BitCount);
215 rawImageSize := rowStride * layerHeader.bmpHeader.Height;
216
217 if rawImageSize > remaining then
218 raise EFormatError.Create('Invalid image size');
219
220 bmp := TBGRABitmap.Create(layerHeader.bmpHeader.Width, layerHeader.bmpHeader.Height);
221 layerIndex := AddOwnedLayer(bmp, (layerHeader.opacityPercent*255 + 50) div 100);
222 LayerVisible[layerIndex] := (layerHeader.layerVisible = 1);
223
224 case layerHeader.bmpHeader.BitCount of
225 8: begin
226 for y := bmp.Height-1 downto 0 do
227 begin
228 pSrc := ABlockData + (bmp.Height-1 - y)*rowStride;
229 pDest := bmp.ScanLine[y];
230 for x := bmp.Width-1 downto 0 do
231 begin
232 pDest^ := BGRA(pSrc^,pSrc^,pSrc^);
233 inc(pDest);
234 inc(pSrc,3);
235 end;
236 end;
237 end;
238 24: begin
239 for y := bmp.Height-1 downto 0 do
240 begin
241 pSrc := ABlockData + (bmp.Height-1 - y)*rowStride;
242 pDest := bmp.ScanLine[y];
243 for x := bmp.Width-1 downto 0 do
244 begin
245 pDest^ := BGRA((pSrc+2)^,(pSrc+1)^,pSrc^);
246 inc(pDest);
247 inc(pSrc,3);
248 end;
249 end;
250 end;
251 32: begin
252 move(ABlockData^, bmp.Data^, sizeof(TBGRAPixel)*bmp.NbPixels);
253 if bmp.LineOrder = riloTopToBottom then bmp.VerticalFlip;
254 if TBGRAPixel_RGBAOrder then bmp.SwapRedBlue;
255 end;
256 else
257 raise EFormatError.Create('Unsupported bit depth');
258 end;
259
260 inc(ABlockData, rawImageSize);
261 dec(remaining, rawImageSize);
262 if remaining >= 8 then
263 begin
264 LayerOffset[layerIndex] := Point(LEtoN(PLongInt(ABlockData)^),LEtoN((PLongInt(ABlockData)+1)^));
265 inc(ABlockData, 8);
266 dec(remaining, 8);
267 end;
268end;
269
270constructor TBGRAPhoxoDocument.Create;
271begin
272 inherited Create;
273 RegisterPhoxoFormat;
274end;
275
276constructor TBGRAPhoxoDocument.Create(AWidth, AHeight: integer);
277begin
278 inherited Create(AWidth, AHeight);
279 RegisterPhoxoFormat;
280end;
281
282procedure TBGRAPhoxoDocument.LoadFromStream(AStream: TStream);
283var blockHeader: TPhoxoBlockHeader;
284 blockData: PByte;
285 wCaption: widestring;
286 i: Integer;
287begin
288 if not CheckFormat(AStream,False) then
289 raise EFormatError.Create('File header is invalid');
290 Clear;
291 FDPIX := 0;
292 FDPIY := 0;
293 blockData := nil;
294 repeat
295 if not ReadBlock(AStream, blockHeader,blockData) then
296 begin
297 if NbLayers = 0 then
298 raise EFormatError.Create('Error reading block from file')
299 else
300 break;
301 end;
302 try
303 case blockHeader.blockType of
304 PhoxoBlock_CanvasSize:
305 begin
306 if blockHeader.blockSize < 8 then raise EFormatError.Create('Block too small');
307 SetSize(LEtoN(PLongWord(blockData)^),LEtoN((PLongWord(blockData)+1)^));
308 end;
309 PhoxoBlock_DPI:
310 begin
311 if blockHeader.blockSize >= 8 then
312 begin
313 FDPIX := LEtoN(PLongWord(blockData)^);
314 FDPIY := LEtoN((PLongWord(blockData)+1)^);
315 end;
316 end;
317 PhoxoBlock_Layer, PhoxoBlock_TextLayer:
318 AddLayerFromPhoxoData(blockHeader,blockData);
319 PhoxoBlock_LayerCaption:
320 begin
321 if (blockHeader.blockSize >= 2) and (NbLayers > 0) then
322 begin
323 setlength(wCaption, blockHeader.blockSize div 2);
324 for i := 1 to length(wCaption) do
325 Word(wCaption[i]) := LEtoN((PWord(blockData)+i-1)^);
326 if wCaption[1] = #1 then Delete(wCaption,1,1);
327 LayerName[NbLayers-1] := UTF8Encode(wCaption);
328
329 end;
330 end;
331 PhoxoBlock_LazPaintBlendMode:
332 begin
333 if (blockHeader.blockSize >= 2) and (NbLayers > 0) then
334 begin
335 setlength(wCaption, blockHeader.blockSize div 2);
336 for i := 1 to length(wCaption) do
337 Word(wCaption[i]) := LEtoN((PWord(blockData)+i-1)^);
338 BlendOperation[NbLayers-1] := StrToBlendOperation(UTF8Encode(wCaption));
339 end;
340 end;
341 end;
342 finally
343 FreeMem(blockData);
344 end;
345 until blockHeader.blockType = PhoxoBlock_EndOfFile;
346end;
347
348procedure TBGRAPhoxoDocument.LoadFromFile(const filenameUTF8: string);
349var AStream: TFileStreamUTF8;
350begin
351 AStream := TFileStreamUTF8.Create(filenameUTF8,fmOpenRead or fmShareDenyWrite);
352 try
353 LoadFromStream(AStream);
354 finally
355 AStream.Free;
356 end;
357end;
358
359procedure TBGRAPhoxoDocument.SaveToFile(const filenameUTF8: string);
360var AStream: TFileStreamUTF8;
361begin
362 AStream := TFileStreamUTF8.Create(filenameUTF8,fmCreate or fmShareDenyWrite);
363 try
364 SaveToStream(AStream);
365 finally
366 AStream.Free;
367 end;
368end;
369
370procedure TBGRAPhoxoDocument.SaveToStream(AStream: TStream);
371
372 procedure WriteFileHeader;
373 var fileHeader: TPhoxoHeader;
374 begin
375 fileHeader.magic := PhoxoHeaderMagic;
376 fileHeader.version := 1;
377 fileHeader.version := NtoLE(fileHeader.version);
378 AStream.WriteBuffer(fileHeader, sizeof(fileHeader));
379 end;
380
381 procedure WriteBlockHeader(blockType: longword; blockSize: longword);
382 var blockHeader: TPhoxoBlockHeader;
383 begin
384 blockHeader.blockType := NtoLE(blockType);
385 blockHeader.blockSize := NtoLE(blockSize);
386 AStream.WriteBuffer(blockHeader, sizeof(blockHeader));
387 end;
388
389 procedure WriteLongInt(value: longint);
390 begin
391 value := NtoLE(value);
392 AStream.WriteBuffer(value, sizeof(value));
393 end;
394
395 procedure WriteLayer(index: integer);
396 var wCaption: widestring;
397 pCaption: PWord;
398
399 layerHeader: TPhoxoLayerHeader;
400 rowStride: longword;
401
402 temp,pdest: PByte;
403 i,x,y: integer;
404 psrc: PBGRAPixel;
405 begin
406 if LayerVisible[index] then
407 layerHeader.layerVisible := 1
408 else
409 layerHeader.layerVisible := 0;
410 layerHeader.layerLimited:= 0;
411 layerHeader.opacityPercent := (LayerOpacity[index]*100 + 127) div 255;
412 with layerHeader.bmpHeader do
413 begin
414 Size := $28;
415 Width := self.LayerBitmap[index].Width;
416 Height := self.LayerBitmap[index].Height;
417 Planes := 1;
418 BitCount := 32; //24-bit does not seem to be supported
419 Compression := BI_RGB;
420 SizeImage := 0;
421 XPelsPerMeter := 0;
422 YPelsPerMeter := 0;
423 ClrUsed := 0;
424 ClrImportant := 0;
425 end;
426 layerHeader.redMask := 0;
427 layerHeader.greenMask := 0;
428 layerHeader.blueMask := 0;
429
430 rowStride := ComputeRowStride(layerHeader.bmpHeader.Width, layerHeader.bmpHeader.BitCount);
431
432 WriteBlockHeader(PhoxoBlock_Layer, sizeof(layerHeader) + rowStride*layerHeader.bmpHeader.Height + sizeof(TPoint));
433 SwapLayerHeaderIfNeeded(layerHeader);
434 AStream.WriteBuffer(layerHeader,sizeof(layerHeader));
435 SwapLayerHeaderIfNeeded(layerHeader);
436
437 case layerHeader.bmpHeader.BitCount of
438 32: begin
439 if TBGRAPixel_RGBAOrder then self.LayerBitmap[index].SwapRedBlue;
440 for y := self.LayerBitmap[index].Height-1 downto 0 do
441 AStream.WriteBuffer(self.LayerBitmap[index].ScanLine[y]^, rowStride);
442 if TBGRAPixel_RGBAOrder then self.LayerBitmap[index].SwapRedBlue;
443 end;
444 24: begin
445 GetMem(temp, rowStride);
446 fillchar(temp^, rowStride, 0);
447 try
448 for y := self.LayerBitmap[index].Height-1 downto 0 do
449 begin
450 psrc := self.LayerBitmap[index].ScanLine[y];
451 pdest := temp;
452 for x := self.LayerBitmap[index].Width-1 downto 0 do
453 begin
454 pdest^ := psrc^.blue; inc(pdest);
455 pdest^ := psrc^.green; inc(pdest);
456 pdest^ := psrc^.red; inc(pdest);
457 inc(psrc);
458 end;
459 AStream.WriteBuffer(temp^, rowstride);
460 end;
461 finally
462 FreeMem(temp);
463 end;
464 end
465 else
466 raise exception.Create('Internal error');
467 end;
468
469 WriteLongInt(LayerOffset[index].X);
470 WriteLongInt(LayerOffset[index].Y);
471
472 if LayerName[index]<>'' then
473 begin
474 wCaption := UTF8ToUTF16(LayerName[index]);
475 WriteBlockHeader(PhoxoBlock_LayerCaption, length(wCaption)*2);
476 getmem(pCaption, length(wCaption)*2);
477 try
478 for i := 1 to length(wCaption) do
479 (pCaption+i-1)^ := NtoLE(Word(wCaption[i]));
480 AStream.WriteBuffer(pCaption^, length(wCaption)*2);
481 finally
482 freemem(pCaption);
483 end;
484 end;
485
486 if BlendOperation[index] <> boTransparent then
487 begin
488 wCaption := UTF8ToUTF16(BlendOperationStr[BlendOperation[index]]);
489 WriteBlockHeader(PhoxoBlock_LazPaintBlendMode, length(wCaption)*2);
490 getmem(pCaption, length(wCaption)*2);
491 try
492 for i := 1 to length(wCaption) do
493 (pCaption+i-1)^ := NtoLE(Word(wCaption[i]));
494 AStream.WriteBuffer(pCaption^, length(wCaption)*2);
495 finally
496 freemem(pCaption);
497 end;
498 end;
499 end;
500
501var
502 i: Integer;
503begin
504 WriteFileHeader;
505
506 WriteBlockHeader(PhoxoBlock_CanvasSize, 8);
507 WriteLongInt(Width);
508 WriteLongInt(Height);
509
510 if (DPIX <> 0) and (DPIY <> 0) then
511 begin
512 WriteBlockHeader(PhoxoBlock_DPI, 8);
513 WriteLongInt(DPIX);
514 WriteLongInt(DPIY);
515 end;
516
517 for i := 0 to NbLayers-1 do
518 WriteLayer(i);
519
520 WriteBlockHeader(PhoxoBlock_EndOfFile,0);
521end;
522
523class function TBGRAPhoxoDocument.CheckFormat(Stream: TStream; ARestorePosition: boolean): boolean;
524var header: TPhoxoHeader;
525 oldPos: int64;
526begin
527 oldPos := Stream.Position;
528 if Stream.Read({%H-}header,sizeof(header))<>sizeof(header) then
529 result := false else
530 begin
531 header.version:= LEtoN(header.version);
532 if (header.magic <> PhoxoHeaderMagic) or (header.version <> 1) then
533 result := false
534 else
535 result := true;
536 end;
537 if ARestorePosition then Stream.Position:= oldPos;
538end;
539
540class function TBGRAPhoxoDocument.ReadBlock(Stream: TStream; out
541 AHeader: TPhoxoBlockHeader; out ABlockData: PByte): boolean;
542begin
543 ABlockData := nil;
544 if Stream.Read({%H-}AHeader,sizeof(AHeader)) <> sizeof(AHeader) then
545 begin
546 AHeader.blockType := 0;
547 AHeader.blockSize := 0;
548 result := false;
549 exit;
550 end;
551 AHeader.blockType := LEtoN(AHeader.blockType);
552 AHeader.blockSize := LEtoN(AHeader.blockSize);
553 if Stream.Position + AHeader.blockSize > Stream.Size then
554 begin
555 AHeader.blockSize := 0;
556 result := false;
557 exit;
558 end;
559 GetMem(ABlockData, AHeader.blockSize);
560 if Stream.Read(ABlockData^, AHeader.blockSize) <> AHeader.blockSize then
561 begin
562 FreeMem(ABlockData);
563 AHeader.blockSize := 0;
564 result := false;
565 exit;
566 end;
567 result := true;
568end;
569
570end.
571
Note: See TracBrowser for help on using the repository browser.