fpimage.inc 7.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 2003 by the Free Pascal development team
  5. TFPCustomImage implementation.
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { TFPCustomImage }
  13. constructor TFPCustomImage.create (AWidth,AHeight:integer);
  14. begin
  15. inherited create;
  16. FExtra := TStringList.Create;
  17. FWidth := 0;
  18. FHeight := 0;
  19. FPalette := nil;
  20. SetSize (AWidth,AHeight);
  21. end;
  22. destructor TFPCustomImage.destroy;
  23. begin
  24. FExtra.Free;
  25. if assigned (FPalette) then
  26. FPalette.Free;
  27. inherited;
  28. end;
  29. procedure TFPCustomImage.LoadFromStream (Str:TStream; Handler:TFPCustomImagereader);
  30. begin
  31. Handler.ImageRead (Str, self);
  32. end;
  33. procedure TFPCustomImage.LoadFromFile (const filename:String; Handler:TFPCustomImageReader);
  34. var
  35. fs : TStream;
  36. begin
  37. if FileExists (filename) then
  38. begin
  39. fs := TFileStream.Create (filename, fmOpenRead);
  40. try
  41. LoadFromStream (fs, handler);
  42. finally
  43. fs.Free;
  44. end;
  45. end
  46. else
  47. FPImgError (StrNoFile, [filename]);
  48. end;
  49. procedure TFPCustomImage.SaveToStream (Str:TStream; Handler:TFPCustomImageWriter);
  50. begin
  51. Handler.ImageWrite (Str, Self);
  52. end;
  53. procedure TFPCustomImage.SaveToFile (const filename:String; Handler:TFPCustomImageWriter);
  54. var
  55. fs : TStream;
  56. begin
  57. fs := TFileStream.Create (filename, fmCreate);
  58. try
  59. SaveToStream (fs, handler);
  60. finally
  61. fs.Free;
  62. end
  63. end;
  64. procedure TFPCustomImage.SetHeight (Value : integer);
  65. begin
  66. if Value <> FHeight then
  67. SetSize (FWidth, Value);
  68. end;
  69. procedure TFPCustomImage.SetWidth (Value : integer);
  70. begin
  71. if Value <> FWidth then
  72. SetSize (Value, FHeight);
  73. end;
  74. procedure TFPCustomImage.SetSize (AWidth, AHeight : integer);
  75. begin
  76. FWidth := AWidth;
  77. FHeight := AHeight;
  78. end;
  79. procedure TFPCustomImage.SetExtraValue (index:integer; const AValue:string);
  80. var s : string;
  81. p : integer;
  82. begin
  83. s := FExtra[index];
  84. p := pos ('=', s);
  85. if p > 0 then
  86. FExtra[index] := copy(s, 1, p) + AValue
  87. else
  88. FPImgError (StrInvalidIndex,[ErrorText[StrImageExtra],index]);
  89. end;
  90. function TFPCustomImage.GetExtraValue (index:integer) : string;
  91. var s : string;
  92. p : integer;
  93. begin
  94. s := FExtra[index];
  95. p := pos ('=', s);
  96. if p > 0 then
  97. result := copy(s, p+1, maxint)
  98. else
  99. result := '';
  100. end;
  101. procedure TFPCustomImage.SetExtraKey (index:integer; const AValue:string);
  102. var s : string;
  103. p : integer;
  104. begin
  105. s := FExtra[index];
  106. p := pos('=',s);
  107. if p > 0 then
  108. s := AValue + copy(s,p,maxint)
  109. else
  110. s := AValue;
  111. FExtra[index] := s;
  112. end;
  113. function TFPCustomImage.GetExtraKey (index:integer) : string;
  114. begin
  115. result := FExtra.Names[index];
  116. end;
  117. procedure TFPCustomImage.SetExtra (const key:String; const AValue:string);
  118. begin
  119. FExtra.values[key] := AValue;
  120. end;
  121. function TFPCustomImage.GetExtra (const key:String) : string;
  122. begin
  123. result := FExtra.values[key];
  124. end;
  125. function TFPCustomImage.ExtraCount : integer;
  126. begin
  127. result := FExtra.count;
  128. end;
  129. procedure TFPCustomImage.RemoveExtra (const key:string);
  130. var p : integer;
  131. begin
  132. p := FExtra.IndexOfName(key);
  133. if p >= 0 then
  134. FExtra.Delete (p);
  135. end;
  136. procedure TFPCustomImage.SetPixel (x,y:integer; Value:integer);
  137. begin
  138. CheckPaletteIndex (Value);
  139. CheckIndex (x,y);
  140. SetInternalPixel (x,y,Value);
  141. end;
  142. function TFPCustomImage.GetPixel (x,y:integer) : integer;
  143. begin
  144. CheckIndex (x,y);
  145. result := GetInternalPixel(x,y);
  146. end;
  147. procedure TFPCustomImage.SetColor (x,y:integer; const Value:TFPColor);
  148. begin
  149. CheckIndex (x,y);
  150. SetInternalColor (x,y,Value);
  151. end;
  152. function TFPCustomImage.GetColor (x,y:integer) : TFPColor;
  153. begin
  154. CheckIndex (x,y);
  155. result := GetInternalColor(x,y);
  156. end;
  157. procedure TFPCustomImage.SetInternalColor (x,y:integer; const Value:TFPColor);
  158. var i : integer;
  159. begin
  160. i := FPalette.IndexOf (Value);
  161. SetInternalPixel (x,y,i);
  162. end;
  163. function TFPCustomImage.GetInternalColor (x,y:integer) : TFPColor;
  164. begin
  165. result := FPalette.Color[GetInternalPixel(x,y)];
  166. end;
  167. function TFPCustomImage.GetUsePalette : boolean;
  168. begin
  169. result := assigned(FPalette);
  170. end;
  171. procedure TFPCustomImage.SetUsePalette (Value : boolean);
  172. begin
  173. if Value <> assigned(FPalette) then
  174. if Value then
  175. FPalette := TFPPalette.Create (0)
  176. else
  177. begin
  178. FPalette.Free;
  179. FPalette := nil;
  180. end;
  181. end;
  182. procedure TFPCustomImage.CheckPaletteIndex (PalIndex:integer);
  183. begin
  184. if UsePalette then
  185. begin
  186. if (PalIndex < -1) or (PalIndex >= FPalette.Count) then
  187. FPImgError (StrInvalidIndex,[ErrorText[StrPalette],PalIndex]);
  188. end
  189. else
  190. FPImgError (StrNoPaletteAvailable);
  191. end;
  192. procedure TFPCustomImage.CheckIndex (x,y:integer);
  193. begin
  194. if (x < 0) or (x >= FWidth) then
  195. FPImgError (StrInvalidIndex,[ErrorText[StrImageX],x]);
  196. if (y < 0) or (y >= FHeight) then
  197. FPImgError (StrInvalidIndex,[ErrorText[StrImageY],y]);
  198. end;
  199. Procedure TFPCustomImage.Progress(Sender: TObject; Stage: TProgressStage;
  200. PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
  201. const Msg: AnsiString; var Continue: Boolean);
  202. begin
  203. If Assigned(FOnProgress) then
  204. FonProgress(Sender,Stage,PercentDone,RedrawNow,R,Msg,Continue);
  205. end;
  206. { TFPMemoryImage }
  207. constructor TFPMemoryImage.Create (AWidth,AHeight:integer);
  208. begin
  209. inherited create (AWidth,AHeight);
  210. UsePalette := True;
  211. Palette.Add (colTransparent);
  212. end;
  213. destructor TFPMemoryImage.Destroy;
  214. begin
  215. // MG: missing if
  216. if FData<>nil then
  217. FreeMem (FData);
  218. inherited Destroy;
  219. end;
  220. function TFPMemoryImage.GetInternalPixel (x,y:integer) : integer;
  221. begin
  222. result := FData^[y*FWidth+x];
  223. end;
  224. procedure TFPMemoryImage.SetInternalPixel (x,y:integer; Value:integer);
  225. begin
  226. FData^[y*FWidth+x] := Value;
  227. end;
  228. function Lowest (a,b : integer) : integer;
  229. begin
  230. if a <= b then
  231. result := a
  232. else
  233. result := b;
  234. end;
  235. procedure TFPMemoryImage.SetSize (AWidth, AHeight : integer);
  236. var w, h, r, old : integer;
  237. NewData : PFPIntegerArray;
  238. begin
  239. if (AWidth <> Width) or (AHeight <> Height) then
  240. begin
  241. old := Height * Width;
  242. r := SizeOf(integer)*AWidth*AHeight;
  243. if r = 0 then
  244. NewData := nil
  245. else
  246. begin
  247. GetMem (NewData, r);
  248. Fillchar (Newdata^[0], r, 0);
  249. end;
  250. // MG: missing "and (NewData<>nil)"
  251. if (old <> 0) and assigned(FData) and (NewData<>nil) then
  252. begin
  253. if r <> 0 then
  254. begin
  255. w := Lowest(Width, AWidth);
  256. h := Lowest(Height, AHeight);
  257. for r := 0 to h-1 do
  258. move (FData^[r*Width], NewData^[r*AWidth], w);
  259. end;
  260. FreeMem (FData);
  261. end;
  262. FData := NewData;
  263. inherited;
  264. end;
  265. end;
  266. Procedure TFPCustomImage.Assign(Source: TPersistent);
  267. Var
  268. Src : TFPCustomImage;
  269. X,Y : Integer;
  270. begin
  271. If Source is TFPCustomImage then
  272. begin
  273. Src:=TFPCustomImage(Source);
  274. // Copy extra info
  275. FExtra.Assign(Src.Fextra);
  276. // Copy palette if needed.
  277. UsePalette:=Src.UsePalette;
  278. If UsePalette then
  279. begin
  280. Palette.Count:=0;
  281. Palette.Build(Src);
  282. end;
  283. // Copy image.
  284. SetSize(Src.Width,Src.height);
  285. If UsePalette then
  286. For x:=0 to Src.Width-1 do
  287. For y:=0 to src.Height-1 do
  288. pixels[X,Y]:=src.pixels[X,Y]
  289. else
  290. For x:=0 to Src.Width-1 do
  291. For y:=0 to src.Height-1 do
  292. self[X,Y]:=src[X,Y];
  293. end
  294. else
  295. Inherited Assign(Source);
  296. end;