← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fcl/image/fpimage.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fcl/image/fpimage.pp
1
 
{
2
 
    $Id: fpimage.pp,v 1.16 2004/02/15 20:59:06 michael Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 2003 by the Free Pascal development team
5
 
 
6
 
    fpImage base definitions.
7
 
    
8
 
    See the file COPYING.FPC, included in this distribution,
9
 
    for details about the copyright.
10
 
 
11
 
    This program is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
 
 
15
 
 **********************************************************************}
16
 
{$mode objfpc}{$h+}
17
 
unit FPimage;
18
 
 
19
 
interface
20
 
 
21
 
uses sysutils, classes;
22
 
 
23
 
type
24
 
 
25
 
  TFPCustomImageReader = class;
26
 
  TFPCustomImageWriter = class;
27
 
  TFPCustomImage = class;
28
 
 
29
 
  FPImageException = class (exception);
30
 
 
31
 
  TFPColor = record
32
 
    red,green,blue,alpha : word;
33
 
  end;
34
 
  PFPColor = ^TFPColor;
35
 
 
36
 
  TColorFormat = (cfMono,cfGray2,cfGray4,cfGray8,cfGray16,cfGray24,
37
 
                  cfGrayA8,cfGrayA16,cfGrayA32,
38
 
                  cfRGB15,cfRGB16,cfRGB24,cfRGB32,cfRGB48,
39
 
                  cfRGBA8,cfRGBA16,cfRGBA32,cfRGBA64,
40
 
                  cfBGR15,cfBGR16,cfBGR24,cfBGR32,cfBGR48,
41
 
                  cfABGR8,cfABGR16,cfABGR32,cfABGR64);
42
 
  TColorData = qword;
43
 
  PColorData = ^TColorData;
44
 
 
45
 
  TDeviceColor = record
46
 
    Fmt : TColorFormat;
47
 
    Data : TColorData;
48
 
  end;
49
 
 
50
 
{$ifdef CPU68K}
51
 
  { 1.0 m68k cpu compiler does not allow
52
 
    types larger than 32k....
53
 
    if we remove range checking all should be fine PM }
54
 
  TFPColorArray = array [0..0] of TFPColor;
55
 
{$R-}
56
 
{$else not CPU68K}
57
 
  TFPColorArray = array [0..(maxint-1) div sizeof(TFPColor)] of TFPColor;
58
 
{$endif CPU68K}
59
 
  PFPColorArray = ^TFPColorArray;
60
 
 
61
 
  TFPImgProgressStage = (psStarting, psRunning, psEnding);
62
 
  TFPImgProgressEvent = procedure (Sender: TObject; Stage: TFPImgProgressStage;
63
 
                                   PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
64
 
                                   const Msg: AnsiString; var Continue : Boolean) of object;
65
 
  // Delphi compatibility
66
 
  TProgressStage = TFPImgProgressStage;
67
 
  TProgressEvent = TFPImgProgressEvent;
68
 
 
69
 
  TFPPalette = class
70
 
    protected
71
 
      FData : PFPColorArray;
72
 
      FCount, FCapacity : integer;
73
 
      procedure SetCount (Value:integer); virtual;
74
 
      function GetCount : integer;
75
 
      procedure SetColor (index:integer; const Value:TFPColor); virtual;
76
 
      function GetColor (index:integer) : TFPColor;
77
 
      procedure CheckIndex (index:integer); virtual;
78
 
      procedure EnlargeData; virtual;
79
 
    public
80
 
      constructor Create (ACount : integer);
81
 
      destructor Destroy; override;
82
 
      procedure Build (Img : TFPCustomImage); virtual;
83
 
      procedure Merge (pal : TFPPalette); virtual;
84
 
      function IndexOf (const AColor: TFPColor) : integer; virtual;
85
 
      function Add (const Value: TFPColor) : integer; virtual;
86
 
      procedure Clear; virtual;
87
 
      property Color [Index : integer] : TFPColor read GetColor write SetColor; default;
88
 
      property Count : integer read GetCount write SetCount;
89
 
  end;
90
 
 
91
 
  TFPCustomImage = class(TPersistent)
92
 
    private
93
 
      FOnProgress : TFPImgProgressEvent;
94
 
      FExtra : TStringlist;
95
 
      FPalette : TFPPalette;
96
 
      FHeight, FWidth : integer;
97
 
      procedure SetHeight (Value : integer);
98
 
      procedure SetWidth (Value : integer);
99
 
      procedure SetExtra (const key:String; const AValue:string);
100
 
      function GetExtra (const key:String) : string;
101
 
      procedure SetExtraValue (index:integer; const AValue:string);
102
 
      function GetExtraValue (index:integer) : string;
103
 
      procedure SetExtraKey (index:integer; const AValue:string);
104
 
      function GetExtraKey (index:integer) : string;
105
 
      procedure CheckIndex (x,y:integer);
106
 
      procedure CheckPaletteIndex (PalIndex:integer);
107
 
      procedure SetColor (x,y:integer; const Value:TFPColor);
108
 
      function GetColor (x,y:integer) : TFPColor;
109
 
      procedure SetPixel (x,y:integer; Value:integer);
110
 
      function GetPixel (x,y:integer) : integer;
111
 
      function GetUsePalette : boolean;
112
 
    protected
113
 
      // Procedures to store the data. Implemented in descendants
114
 
      procedure SetInternalColor (x,y:integer; const Value:TFPColor); virtual;
115
 
      function GetInternalColor (x,y:integer) : TFPColor; virtual;
116
 
      procedure SetInternalPixel (x,y:integer; Value:integer); virtual; abstract;
117
 
      function GetInternalPixel (x,y:integer) : integer; virtual; abstract;
118
 
      procedure SetUsePalette (Value:boolean);virtual;
119
 
      procedure Progress(Sender: TObject; Stage: TProgressStage;
120
 
                         PercentDone: Byte;  RedrawNow: Boolean; const R: TRect;
121
 
                         const Msg: AnsiString; var Continue: Boolean); Virtual;
122
 
    public
123
 
      constructor create (AWidth,AHeight:integer); virtual;
124
 
      destructor destroy; override;
125
 
      procedure Assign(Source: TPersistent); override;
126
 
      // Saving and loading
127
 
      procedure LoadFromStream (Str:TStream; Handler:TFPCustomImageReader);
128
 
      procedure LoadFromStream (Str:TStream);
129
 
      procedure LoadFromFile (const filename:String; Handler:TFPCustomImageReader);
130
 
      procedure LoadFromFile (const filename:String);
131
 
      procedure SaveToStream (Str:TStream; Handler:TFPCustomImageWriter);
132
 
      procedure SaveToFile (const filename:String; Handler:TFPCustomImageWriter);
133
 
      // Size and data
134
 
      procedure SetSize (AWidth, AHeight : integer); virtual;
135
 
      property  Height : integer read FHeight write SetHeight;
136
 
      property  Width : integer read FWidth write SetWidth;
137
 
      property  Colors [x,y:integer] : TFPColor read GetColor write SetColor; default;
138
 
      // Use of palette for colors
139
 
      property  UsePalette : boolean read GetUsePalette write SetUsePalette;
140
 
      property  Palette : TFPPalette read FPalette;
141
 
      property  Pixels [x,y:integer] : integer read GetPixel write SetPixel;
142
 
      // Info unrelated with the image representation
143
 
      property  Extra [const key:string] : string read GetExtra write SetExtra;
144
 
      property  ExtraValue [index:integer] : string read GetExtraValue write SetExtraValue;
145
 
      property  ExtraKey [index:integer] : string read GetExtraKey write SetExtraKey;
146
 
      procedure RemoveExtra (const key:string);
147
 
      function  ExtraCount : integer;
148
 
      property OnProgress: TFPImgProgressEvent read FOnProgress write FOnProgress;
149
 
  end;
150
 
  TFPCustomImageClass = class of TFPCustomImage;
151
 
 
152
 
{$ifdef CPU68K}
153
 
  { 1.0 m68k cpu compiler does not allow
154
 
    types larger than 32k....
155
 
    if we remove range checking all should be fine PM }
156
 
  TFPIntegerArray = array [0..0] of integer;
157
 
{$R-}
158
 
{$else not CPU68K}
159
 
  TFPIntegerArray = array [0..(maxint-1) div sizeof(integer)] of integer;
160
 
{$endif CPU68K}
161
 
  PFPIntegerArray = ^TFPIntegerArray;
162
 
 
163
 
  TFPMemoryImage = class (TFPCustomImage)
164
 
    private
165
 
      FData : PFPIntegerArray;
166
 
      function GetInternalColor(x,y:integer):TFPColor;override;
167
 
      procedure SetInternalColor (x,y:integer; const Value:TFPColor);override;
168
 
      procedure SetUsePalette (Value:boolean);override;
169
 
    protected
170
 
      procedure SetInternalPixel (x,y:integer; Value:integer); override;
171
 
      function GetInternalPixel (x,y:integer) : integer; override;
172
 
    public
173
 
      constructor create (AWidth,AHeight:integer); override;
174
 
      destructor destroy; override;
175
 
      procedure SetSize (AWidth, AHeight : integer); override;
176
 
  end;
177
 
 
178
 
  TFPCustomImageHandler = class
179
 
    private
180
 
      FOnProgress : TFPImgProgressEvent;
181
 
      FStream : TStream;
182
 
      FImage : TFPCustomImage;
183
 
    protected
184
 
      procedure Progress(Stage: TProgressStage; PercentDone: Byte;  RedrawNow: Boolean; const R: TRect;
185
 
                         const Msg: AnsiString; var Continue: Boolean); Virtual;
186
 
      property TheStream : TStream read FStream;
187
 
      property TheImage : TFPCustomImage read FImage;
188
 
    public
189
 
      constructor Create; virtual;
190
 
      Property OnProgress : TFPImgProgressEvent Read FOnProgress Write FOnProgress;
191
 
  end;
192
 
 
193
 
  TFPCustomImageReader = class (TFPCustomImageHandler)
194
 
    private
195
 
      FDefImageClass:TFPCustomImageClass;
196
 
    protected
197
 
      procedure InternalRead  (Str:TStream; Img:TFPCustomImage); virtual; abstract;
198
 
      function  InternalCheck (Str:TStream) : boolean; virtual; abstract;
199
 
    public
200
 
      constructor Create; override;
201
 
      function ImageRead (Str:TStream; Img:TFPCustomImage) : TFPCustomImage;
202
 
      // reads image
203
 
      function CheckContents (Str:TStream) : boolean;
204
 
      // Gives True if contents is readable
205
 
      property DefaultImageClass : TFPCustomImageClass read FDefImageClass write FDefImageClass;
206
 
      // Image Class to create when no img is given for reading
207
 
  end;
208
 
  TFPCustomImageReaderClass = class of TFPCustomImageReader;
209
 
 
210
 
  TFPCustomImageWriter = class (TFPCustomImageHandler)
211
 
    protected
212
 
      procedure InternalWrite (Str:TStream; Img:TFPCustomImage); virtual; abstract;
213
 
    public
214
 
      procedure ImageWrite (Str:TStream; Img:TFPCustomImage);
215
 
      // writes given image to stream
216
 
  end;
217
 
  TFPCustomImageWriterClass = class of TFPCustomImageWriter;
218
 
 
219
 
  TIHData = class
220
 
    private
221
 
      FExtention, FTypeName, FDefaultExt : string;
222
 
      FReader : TFPCustomImageReaderClass;
223
 
      FWriter : TFPCustomImageWriterClass;
224
 
  end;
225
 
 
226
 
  TImageHandlersManager = class
227
 
    private
228
 
      FData : TList;
229
 
      function GetReader (const TypeName:string) : TFPCustomImageReaderClass;
230
 
      function GetWriter (const TypeName:string) : TFPCustomImageWriterClass;
231
 
      function GetExt (const TypeName:string) : string;
232
 
      function GetDefExt (const TypeName:string) : string;
233
 
      function GetTypeName (index:integer) : string;
234
 
      function GetData (const ATypeName:string) : TIHData;
235
 
      function GetData (index : integer) : TIHData;
236
 
      function GetCount : integer;
237
 
    public
238
 
      constructor Create;
239
 
      destructor Destroy; override;
240
 
      procedure RegisterImageHandlers (const ATypeName,TheExtentions:string;
241
 
                   AReader:TFPCustomImageReaderClass; AWriter:TFPCustomImageWriterClass);
242
 
      procedure RegisterImageReader (const ATypeName,TheExtentions:string;
243
 
                   AReader:TFPCustomImageReaderClass);
244
 
      procedure RegisterImageWriter (const ATypeName,TheExtentions:string;
245
 
                   AWriter:TFPCustomImageWriterClass);
246
 
      property Count : integer read GetCount;
247
 
      property ImageReader [const TypeName:string] : TFPCustomImageReaderClass read GetReader;
248
 
      property ImageWriter [const TypeName:string] : TFPCustomImageWriterClass read GetWriter;
249
 
      property Extentions [const TypeName:string] : string read GetExt;
250
 
      property DefaultExtention [const TypeName:string] : string read GetDefExt;
251
 
      property TypeNames [index:integer] : string read GetTypeName;
252
 
    end;
253
 
 
254
 
{function ShiftAndFill (initial:word; CorrectBits:byte):word;
255
 
function FillOtherBits (initial:word;CorrectBits:byte):word;
256
 
}
257
 
function CalculateGray (const From : TFPColor) : word;
258
 
(*
259
 
function ConvertColor (const From : TDeviceColor) : TFPColor;
260
 
function ConvertColor (const From : TColorData; FromFmt:TColorFormat) : TFPColor;
261
 
function ConvertColorToData (const From : TFPColor; Fmt : TColorFormat) : TColorData;
262
 
function ConvertColorToData (const From : TDeviceColor; Fmt : TColorFormat) : TColorData;
263
 
function ConvertColor (const From : TFPColor; Fmt : TColorFormat) : TDeviceColor;
264
 
function ConvertColor (const From : TDeviceColor; Fmt : TColorFormat) : TDeviceColor;
265
 
*)
266
 
function FPColor (r,g,b,a:word) : TFPColor;
267
 
function FPColor (r,g,b:word) : TFPColor;
268
 
{$ifdef debug}function MakeHex (n:TColordata;nr:byte): string;{$endif}
269
 
 
270
 
operator = (const c,d:TFPColor) : boolean;
271
 
operator or (const c,d:TFPColor) : TFPColor;
272
 
operator and (const c,d:TFPColor) : TFPColor; 
273
 
operator xor (const c,d:TFPColor) : TFPColor; 
274
 
function CompareColors(const Color1, Color2: TFPColor): integer;
275
 
 
276
 
var ImageHandlers : TImageHandlersManager;
277
 
 
278
 
type
279
 
  TErrorTextIndices = (
280
 
    StrInvalidIndex,
281
 
    StrNoImageToWrite,
282
 
    StrNoFile,
283
 
    StrNoStream,
284
 
    StrPalette,
285
 
    StrImageX,
286
 
    StrImageY,
287
 
    StrImageExtra,
288
 
    StrTypeAlreadyExist,
289
 
    StrTypeReaderAlreadyExist,
290
 
    StrTypeWriterAlreadyExist,
291
 
    StrCantDetermineType,
292
 
    StrNoCorrectReaderFound,
293
 
    StrReadWithError,
294
 
    StrNoPaletteAvailable
295
 
    );
296
 
 
297
 
const
298
 
  // MG: ToDo: move to implementation and add a function to map to resourcestrings
299
 
  ErrorText : array[TErrorTextIndices] of string =
300
 
    ('Invalid %s index %d',
301
 
     'No image to write',
302
 
     'File "%s" does not exist',
303
 
     'No stream to write to',
304
 
     'palette',
305
 
     'horizontal pixel',
306
 
     'vertical pixel',
307
 
     'extra',
308
 
     'Image type "%s" already exists',
309
 
     'Image type "%s" already has a reader class',
310
 
     'Image type "%s" already has a writer class',
311
 
     'Error while determining image type of stream: %s',
312
 
     'Can''t determine image type of stream',
313
 
     'Error while reading stream: %s',
314
 
     'No palette available'
315
 
     );
316
 
 
317
 
{$i FPColors.inc}
318
 
 
319
 
type
320
 
  TGrayConvMatrix = record
321
 
    red, green, blue : single;
322
 
  end;
323
 
 
324
 
var
325
 
  GrayConvMatrix : TGrayConvMatrix;
326
 
 
327
 
const
328
 
  GCM_NTSC : TGrayConvMatrix = (red:0.299; green:0.587; blue:0.114);
329
 
  GCM_JPEG : TGrayConvMatrix = (red:0.299; green:0.587; blue:0.114);
330
 
  GCM_Mathematical : TGrayConvMatrix = (red:0.334; green:0.333; blue:0.333);
331
 
  GCM_Photoshop : TGrayConvMatrix = (red:0.213; green:0.715; blue:0.072);
332
 
 
333
 
implementation
334
 
 
335
 
procedure FPImgError (Fmt:TErrorTextIndices; data : array of const);
336
 
begin
337
 
  raise FPImageException.CreateFmt (ErrorText[Fmt],data);
338
 
end;
339
 
 
340
 
procedure FPImgError (Fmt:TErrorTextIndices);
341
 
begin
342
 
  raise FPImageException.Create (ErrorText[Fmt]);
343
 
end;
344
 
 
345
 
{$i FPImage.inc}
346
 
{$i FPHandler.inc}
347
 
{$i FPPalette.inc}
348
 
{$i FPColCnv.inc}
349
 
 
350
 
function FPColor (r,g,b:word) : TFPColor;
351
 
begin
352
 
  with result do
353
 
    begin
354
 
    red := r;
355
 
    green := g;
356
 
    blue := b;
357
 
    alpha := alphaOpaque;
358
 
    end;
359
 
end;
360
 
 
361
 
function FPColor (r,g,b,a:word) : TFPColor;
362
 
begin
363
 
  with result do
364
 
    begin
365
 
    red := r;
366
 
    green := g;
367
 
    blue := b;
368
 
    alpha := a;
369
 
    end;
370
 
end;
371
 
 
372
 
operator = (const c,d:TFPColor) : boolean;
373
 
begin
374
 
  result := (c.Red = d.Red) and
375
 
            (c.Green = d.Green) and
376
 
            (c.Blue = d.Blue) and
377
 
            (c.Alpha = d.Alpha);
378
 
end;
379
 
 
380
 
function GetFullColorData (color:TFPColor) : TColorData;
381
 
begin
382
 
  result := PColorData(@color)^;
383
 
end;
384
 
 
385
 
function SetFullColorData (color:TColorData) : TFPColor;
386
 
begin
387
 
  result := PFPColor (@color)^;
388
 
end;
389
 
 
390
 
operator or (const c,d:TFPColor) : TFPColor; 
391
 
begin
392
 
  result := SetFullColorData(GetFullColorData(c) OR GetFullColorData(d));
393
 
end;
394
 
 
395
 
operator and (const c,d:TFPColor) : TFPColor; 
396
 
begin
397
 
  result := SetFullColorData(GetFullColorData(c) AND GetFullColorData(d));
398
 
end;
399
 
 
400
 
operator xor (const c,d:TFPColor) : TFPColor; 
401
 
begin
402
 
  result := SetFullColorData(GetFullColorData(c) XOR GetFullColorData(d));
403
 
end;
404
 
 
405
 
{$ifdef debug}
406
 
function MakeHex (n:TColordata;nr:byte): string;
407
 
const hexnums : array[0..15] of char =
408
 
              ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
409
 
var r : integer;
410
 
begin
411
 
  result := '';
412
 
  for r := 0 to nr-1 do
413
 
    begin
414
 
    result := hexnums[n and $F] + result;
415
 
    n := n shr 4;
416
 
    if ((r+1) mod 4) = 0 then
417
 
      result := ' ' + result;
418
 
    end;
419
 
end;
420
 
{$endif}
421
 
 
422
 
initialization
423
 
  ImageHandlers := TImageHandlersManager.Create;
424
 
  GrayConvMatrix := GCM_JPEG;
425
 
  // Following lines are here because the compiler 1.0 can't work with int64 constants
426
 
(*  ColorBits [cfRGB48,1] := ColorBits [cfRGB48,1] shl 16;
427
 
  ColorBits [cfRGBA64,1] := ColorBits [cfRGBA64,1] shl 32;
428
 
  ColorBits [cfRGBA64,2] := ColorBits [cfRGBA64,2] shl 16;
429
 
  ColorBits [cfABGR64,0] := ColorBits [cfABGR64,0] shl 32;
430
 
  ColorBits [cfABGR64,3] := ColorBits [cfABGR64,3] shl 16;
431
 
  ColorBits [cfBGR48,3] := ColorBits [cfBGR48,3] shl 16;
432
 
  PrepareBitMasks;*)
433
 
 
434
 
finalization
435
 
  ImageHandlers.Free;
436
 
 
437
 
end.