123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346 |
- {
- $Id$
- This file is part of the Free Pascal run time library.
- Copyright (c) 2003 by the Free Pascal development team
- TFPCustomImage implementation.
-
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- { TFPCustomImage }
- constructor TFPCustomImage.create (AWidth,AHeight:integer);
- begin
- inherited create;
- FExtra := TStringList.Create;
- FWidth := 0;
- FHeight := 0;
- FPalette := nil;
- SetSize (AWidth,AHeight);
- end;
- destructor TFPCustomImage.destroy;
- begin
- FExtra.Free;
- if assigned (FPalette) then
- FPalette.Free;
- inherited;
- end;
- procedure TFPCustomImage.LoadFromStream (Str:TStream; Handler:TFPCustomImagereader);
- begin
- Handler.ImageRead (Str, self);
- end;
- procedure TFPCustomImage.LoadFromFile (const filename:String; Handler:TFPCustomImageReader);
- var
- fs : TStream;
- begin
- if FileExists (filename) then
- begin
- fs := TFileStream.Create (filename, fmOpenRead);
- try
- LoadFromStream (fs, handler);
- finally
- fs.Free;
- end;
- end
- else
- FPImgError (StrNoFile, [filename]);
- end;
- procedure TFPCustomImage.SaveToStream (Str:TStream; Handler:TFPCustomImageWriter);
- begin
- Handler.ImageWrite (Str, Self);
- end;
- procedure TFPCustomImage.SaveToFile (const filename:String; Handler:TFPCustomImageWriter);
- var
- fs : TStream;
- begin
- fs := TFileStream.Create (filename, fmCreate);
- try
- SaveToStream (fs, handler);
- finally
- fs.Free;
- end
- end;
- procedure TFPCustomImage.SetHeight (Value : integer);
- begin
- if Value <> FHeight then
- SetSize (FWidth, Value);
- end;
- procedure TFPCustomImage.SetWidth (Value : integer);
- begin
- if Value <> FWidth then
- SetSize (Value, FHeight);
- end;
- procedure TFPCustomImage.SetSize (AWidth, AHeight : integer);
- begin
- FWidth := AWidth;
- FHeight := AHeight;
- end;
- procedure TFPCustomImage.SetExtraValue (index:integer; const AValue:string);
- var s : string;
- p : integer;
- begin
- s := FExtra[index];
- p := pos ('=', s);
- if p > 0 then
- FExtra[index] := copy(s, 1, p) + AValue
- else
- FPImgError (StrInvalidIndex,[ErrorText[StrImageExtra],index]);
- end;
- function TFPCustomImage.GetExtraValue (index:integer) : string;
- var s : string;
- p : integer;
- begin
- s := FExtra[index];
- p := pos ('=', s);
- if p > 0 then
- result := copy(s, p+1, maxint)
- else
- result := '';
- end;
- procedure TFPCustomImage.SetExtraKey (index:integer; const AValue:string);
- var s : string;
- p : integer;
- begin
- s := FExtra[index];
- p := pos('=',s);
- if p > 0 then
- s := AValue + copy(s,p,maxint)
- else
- s := AValue;
- FExtra[index] := s;
- end;
- function TFPCustomImage.GetExtraKey (index:integer) : string;
- begin
- result := FExtra.Names[index];
- end;
- procedure TFPCustomImage.SetExtra (const key:String; const AValue:string);
- begin
- FExtra.values[key] := AValue;
- end;
- function TFPCustomImage.GetExtra (const key:String) : string;
- begin
- result := FExtra.values[key];
- end;
- function TFPCustomImage.ExtraCount : integer;
- begin
- result := FExtra.count;
- end;
- procedure TFPCustomImage.RemoveExtra (const key:string);
- var p : integer;
- begin
- p := FExtra.IndexOfName(key);
- if p >= 0 then
- FExtra.Delete (p);
- end;
- procedure TFPCustomImage.SetPixel (x,y:integer; Value:integer);
- begin
- CheckPaletteIndex (Value);
- CheckIndex (x,y);
- SetInternalPixel (x,y,Value);
- end;
- function TFPCustomImage.GetPixel (x,y:integer) : integer;
- begin
- CheckIndex (x,y);
- result := GetInternalPixel(x,y);
- end;
- procedure TFPCustomImage.SetColor (x,y:integer; const Value:TFPColor);
- begin
- CheckIndex (x,y);
- SetInternalColor (x,y,Value);
- end;
- function TFPCustomImage.GetColor (x,y:integer) : TFPColor;
- begin
- CheckIndex (x,y);
- result := GetInternalColor(x,y);
- end;
- procedure TFPCustomImage.SetInternalColor (x,y:integer; const Value:TFPColor);
- var i : integer;
- begin
- i := FPalette.IndexOf (Value);
- SetInternalPixel (x,y,i);
- end;
- function TFPCustomImage.GetInternalColor (x,y:integer) : TFPColor;
- begin
- result := FPalette.Color[GetInternalPixel(x,y)];
- end;
- function TFPCustomImage.GetUsePalette : boolean;
- begin
- result := assigned(FPalette);
- end;
- procedure TFPCustomImage.SetUsePalette (Value : boolean);
- begin
- if Value <> assigned(FPalette) then
- if Value then
- FPalette := TFPPalette.Create (0)
- else
- begin
- FPalette.Free;
- FPalette := nil;
- end;
- end;
- procedure TFPCustomImage.CheckPaletteIndex (PalIndex:integer);
- begin
- if UsePalette then
- begin
- if (PalIndex < -1) or (PalIndex >= FPalette.Count) then
- FPImgError (StrInvalidIndex,[ErrorText[StrPalette],PalIndex]);
- end
- else
- FPImgError (StrNoPaletteAvailable);
- end;
- procedure TFPCustomImage.CheckIndex (x,y:integer);
- begin
- if (x < 0) or (x >= FWidth) then
- FPImgError (StrInvalidIndex,[ErrorText[StrImageX],x]);
- if (y < 0) or (y >= FHeight) then
- FPImgError (StrInvalidIndex,[ErrorText[StrImageY],y]);
- end;
- Procedure TFPCustomImage.Progress(Sender: TObject; Stage: TProgressStage;
- PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
- const Msg: AnsiString; var Continue: Boolean);
- begin
- If Assigned(FOnProgress) then
- FonProgress(Sender,Stage,PercentDone,RedrawNow,R,Msg,Continue);
- end;
-
- { TFPMemoryImage }
- constructor TFPMemoryImage.Create (AWidth,AHeight:integer);
- begin
- inherited create (AWidth,AHeight);
- UsePalette := True;
- Palette.Add (colTransparent);
- end;
- destructor TFPMemoryImage.Destroy;
- begin
- // MG: missing if
- if FData<>nil then
- FreeMem (FData);
- inherited Destroy;
- end;
- function TFPMemoryImage.GetInternalPixel (x,y:integer) : integer;
- begin
- result := FData^[y*FWidth+x];
- end;
- procedure TFPMemoryImage.SetInternalPixel (x,y:integer; Value:integer);
- begin
- FData^[y*FWidth+x] := Value;
- end;
- function Lowest (a,b : integer) : integer;
- begin
- if a <= b then
- result := a
- else
- result := b;
- end;
- procedure TFPMemoryImage.SetSize (AWidth, AHeight : integer);
- var w, h, r, old : integer;
- NewData : PFPIntegerArray;
- begin
- if (AWidth <> Width) or (AHeight <> Height) then
- begin
- old := Height * Width;
- r := SizeOf(integer)*AWidth*AHeight;
- if r = 0 then
- NewData := nil
- else
- begin
- GetMem (NewData, r);
- Fillchar (Newdata^[0], r, 0);
- end;
- // MG: missing "and (NewData<>nil)"
- if (old <> 0) and assigned(FData) and (NewData<>nil) then
- begin
- if r <> 0 then
- begin
- w := Lowest(Width, AWidth);
- h := Lowest(Height, AHeight);
- for r := 0 to h-1 do
- move (FData^[r*Width], NewData^[r*AWidth], w);
- end;
- FreeMem (FData);
- end;
- FData := NewData;
- inherited;
- end;
- end;
- Procedure TFPCustomImage.Assign(Source: TPersistent);
- Var
- Src : TFPCustomImage;
- X,Y : Integer;
- begin
- If Source is TFPCustomImage then
- begin
- Src:=TFPCustomImage(Source);
- // Copy extra info
- FExtra.Assign(Src.Fextra);
- // Copy palette if needed.
- UsePalette:=Src.UsePalette;
- If UsePalette then
- begin
- Palette.Count:=0;
- Palette.Build(Src);
- end;
- // Copy image.
- SetSize(Src.Width,Src.height);
- If UsePalette then
- For x:=0 to Src.Width-1 do
- For y:=0 to src.Height-1 do
- pixels[X,Y]:=src.pixels[X,Y]
- else
- For x:=0 to Src.Width-1 do
- For y:=0 to src.Height-1 do
- self[X,Y]:=src[X,Y];
- end
- else
- Inherited Assign(Source);
- end;
-
|