source: tools/Image resize/UFormMain.pas

Last change on this file was 333, checked in by chronos, 3 years ago
  • Modified: Image resize tool scale up using xbrzscale tool.
  • Modified: Various improvements of generation of scaled up tiles.
File size: 14.0 KB
Line 
1unit UFormMain;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
9 Math, LazFileUtils, UPixelPointer, Process;
10
11type
12
13 { TFormMain }
14
15 TFormMain = class(TForm)
16 ButtonTile: TButton;
17 ButtonAlpha: TButton;
18 ButtonResize: TButton;
19 procedure ButtonAlphaClick(Sender: TObject);
20 procedure ButtonResizeClick(Sender: TObject);
21 procedure ButtonTileClick(Sender: TObject);
22 procedure FormShow(Sender: TObject);
23 private
24 function SwapColors(Color: Cardinal): Cardinal;
25 procedure UseAlphaFile(SourceName: string; BBC: Boolean);
26 procedure UseAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean = False);
27 procedure RestoreAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean = False);
28 procedure ResizeRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect);
29 procedure ResizeRectXbrz(SrcBitmap, DstBitmap: TBitmap);
30 procedure ProcessBitmapRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect);
31 procedure ResizeAuxPos(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect);
32 public
33 procedure ResizeImage(SourceName: string; SourceSize: TPoint; Count: TPoint;
34 DestName: string; DestSize: TPoint);
35 end;
36
37var
38 FormMain: TFormMain;
39
40implementation
41
42{$R *.lfm}
43
44uses
45 UBitmapSet;
46
47{ TFormMain }
48
49procedure TFormMain.FormShow(Sender: TObject);
50begin
51end;
52
53function TFormMain.SwapColors(Color: Cardinal): Cardinal;
54begin
55 Result := ((Color and $ff0000) shr 16) or (Color and $00ff00) or
56 ((Color and $ff) shl 16) or (Color and $ff000000);
57end;
58
59procedure TFormMain.ButtonResizeClick(Sender: TObject);
60var
61 NewSize: TPoint;
62 OldSize: TPoint;
63 OldFileName: string;
64 NewFileName: string;
65 I: Integer;
66const
67 //Files: array[0..0] of string = ('Cities66x32.png');
68 Files: array[0..0] of string = ('Cities96x48.png');
69 //Files: array[0..0] of string = ('Terrain96x48.png');
70 //Files: array[0..1] of string = ('Cities66x32.png', 'Terrain66x32.png');
71 //Files: array[0..1] of string = ('Cities96x48.png', 'Terrain96x48.png');
72 TileCount: array[0..1] of TPoint = ((X: 8; Y: 2), (X: 9; Y: 21));
73 //TileCount: array[0..0] of TPoint = ((X: 9; Y: 21));
74begin
75 //OldSize := Point(66, 48);
76 OldSize := Point(96, 72);
77 //NewSize := Point(96, 72);
78 //NewSize := Point(66, 48);
79 NewSize := Point(144, 108);
80 //NewSize := Point(192, 144);
81
82 for I := 0 to Length(Files) - 1 do begin
83 OldFileName := Files[I];
84 NewFileName := '_' + OldFileName;
85 ResizeImage(OldFileName, OldSize, TileCount[I], NewFileName, NewSize);
86 end;
87end;
88
89procedure TFormMain.ButtonTileClick(Sender: TObject);
90var
91 Ptr: TPixelPointer;
92 X, Y: Integer;
93 Bitmap: TBitmap;
94begin
95 Bitmap := TBitmap.Create;
96 Bitmap.LoadFromFile('tile.bmp');
97
98 Bitmap.BeginUpdate;
99 Ptr := PixelPointer(Bitmap);
100 for Y := 0 to Bitmap.Height - 1 do begin
101 for X := 0 to Bitmap.Width - 1 do begin
102 if Ptr.Pixel^.ARGB <> 0 then begin
103 if ((X + Y) mod 2) = 0 then
104 Ptr.Pixel^.ARGB := $ff7f007f
105 else Ptr.Pixel^.ARGB := $ff000000;
106 end else Ptr.Pixel^.ARGB := $ff7f007f;
107 Ptr.NextPixel;
108 end;
109 Ptr.NextLine;
110 end;
111 Bitmap.EndUpdate;
112
113 Bitmap.SaveToFile('tile_.bmp');
114 Bitmap.Free;
115end;
116
117procedure TFormMain.ButtonAlphaClick(Sender: TObject);
118const
119 Files: array[0..11] of string = (
120 'Cities66x32.png', 'Cities96x48.png', 'Cities144x72.png',
121 'Terrain66x32.png', 'Terrain96x48.png', 'Terrain144x72.png',
122 'Nation1.png', 'Nation2.png', 'StdCities.png', 'StdUnits.png', 'System.png',
123 'System2.png');
124var
125 I: Integer;
126begin
127 I := 0;
128 for I := 0 to Length(Files) - 1 do
129 UseAlphaFile('../../trunk/Graphics/' + Files[I], False);
130 UseAlphaFile('../../trunk/Help/AdvTree.png', False);
131 //UseAlphaFile('../../trunk/Graphics/Templates.png', True);
132end;
133
134procedure FillRectBitmap(Bitmap: TBitmap; Color: TColor32);
135var
136 Ptr: TPixelPointer;
137 X, Y: Integer;
138begin
139 Bitmap.BeginUpdate;
140 Ptr := PixelPointer(Bitmap);
141 for Y := 0 to Bitmap.Height - 1 do begin
142 for X := 0 to Bitmap.Width - 1 do begin
143 Ptr.Pixel^.ARGB := Color;
144 Ptr.NextPixel;
145 end;
146 Ptr.NextLine;
147 end;
148 Bitmap.EndUpdate;
149end;
150
151procedure TFormMain.UseAlphaFile(SourceName: string; BBC: Boolean);
152var
153 ImageSrc: TImage;
154 ImageDest: TImage;
155 X, Y: Integer;
156 PtrSrc: PPixel32;
157 PtrDest: PPixel32;
158 C: TPixel32;
159 Size: TPoint;
160 Trans, Amp1, Amp2, Value: Integer;
161 Color1, Color2: TPixel32;
162 BitmapSet: TBitmapSet;
163 BitmapDesc: TBitmapDesc;
164 I: Integer;
165begin
166 BitmapSet := TBitmapSet.Create;
167 if FileExists(ExtractFileNameOnly(SourceName) + '.txt') then
168 BitmapSet.LoadFromFile(ExtractFileNameOnly(SourceName) + '.txt');
169
170 ImageSrc := TImage.Create(nil);
171 ImageSrc.Picture.LoadFromFile(SourceName);
172 ImageDest := TImage.Create(nil);
173 ImageDest.Picture.Bitmap.PixelFormat := pf32bit;
174
175 UseAlphaBitmap(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap, BBC);
176
177 ImageDest.Picture.SaveToFile(ExtractFileName(SourceName));
178 ImageSrc.Free;
179 ImageDest.Free;
180 BitmapSet.Free;
181end;
182
183procedure TFormMain.UseAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean);
184var
185 X, Y: Integer;
186 PtrSrc: PPixel32;
187 PtrDest: PPixel32;
188 C: TPixel32;
189 Size: TPoint;
190 Trans, Amp1, Amp2, Value: Integer;
191 Color1, Color2: TPixel32;
192 BitmapSet: TBitmapSet;
193 BitmapDesc: TBitmapDesc;
194 I: Integer;
195begin
196 Size := Point(SrcBitmap.Width, SrcBitmap.Height);
197 SrcBitmap.BeginUpdate(True);
198 DstBitmap.SetSize(Size.X, Size.Y);
199 DstBitmap.BeginUpdate(True);
200 for Y := 0 to Size.Y - 1 do
201 for X := 0 to Size.X - 1 do begin
202 PtrSrc := SrcBitmap.ScanLine[Y] + X * 4;
203 PtrDest := DstBitmap.ScanLine[Y] + X * 4;
204 C.ARGB := PtrSrc^.ARGB and $ffffff;
205 //C.ARGB := SwapColors(C.ARGB);
206 if BBC then begin
207 PtrDest^.R := C.R;
208 PtrDest^.G := C.G;
209 PtrDest^.B := 0; //C.B;
210 PtrDest^.A := 255 - C.B; // blue channel = transparency
211 end else begin
212 if (C.ARGB = $7f007f) or (C.ARGB = $ff00ff) then
213 PtrDest^.ARGB := $00000000
214 else PtrDest^.ARGB := SwapColors($ff000000 or C.ARGB);
215 end;
216 end;
217
218{ if BBC then begin
219 for I := 0 to BitmapSet.Items.Count - 1 do begin
220 BitmapDesc := BitmapSet.Items[I];
221 for Y := BitmapDesc.Rect.Top to BitmapDesc.Rect.Top + BitmapDesc.Rect.Height - 1 do
222 for X := BitmapDesc.Rect.Left to BitmapDesc.Rect.Left + BitmapDesc.Rect.Width - 1 do begin
223 Color1.ARGB := BitmapDesc.Color1;
224 Color2.ARGB := BitmapDesc.Color2;
225 PtrDest := ImageDest.Picture.Bitmap.ScanLine[Y] + X * 4;
226 C.ARGB := PtrDest^.ARGB;
227 trans := C.A * 2;
228 amp1 := C.G * 2;
229 amp2 := C.R * 2;
230 if trans <> $FF then begin
231 Value := (0 * trans + Color2.R * amp2 + Color1.R * amp1) div $FF;
232 PtrDest^.B := Min(Value, 255);
233
234 Value := (0 * trans + Color2.G * amp2 + Color1.G * amp1) div $FF;
235 PtrDest^.G := Min(Value, 255);
236
237 Value := (0 * trans + Color2.B * amp2 + Color1.B * amp1) div $FF;
238 PtrDest^.R := Min(Value, 255);
239
240 PtrDest^.A := 255 - Min(Trans, 255)
241 end;
242 end;
243 end;
244 end;
245 }
246 SrcBitmap.EndUpdate;
247 DstBitmap.EndUpdate;
248end;
249
250procedure TFormMain.RestoreAlphaBitmap(SrcBitmap, DstBitmap: TBitmap;
251 BBC: Boolean);
252var
253 X, Y: Integer;
254 Size: TPoint;
255 PtrSrc: PPixel32;
256 PtrDest: PPixel32;
257 C: TPixel32;
258 A: Cardinal;
259 Alpha: Byte;
260const
261 AlphaThreshold = $80;
262begin
263 Size := Point(SrcBitmap.Width, SrcBitmap.Height);
264 SrcBitmap.BeginUpdate(True);
265 SrcBitmap.PixelFormat := pf32bit;
266 DstBitmap.SetSize(Size.X, Size.Y);
267 DstBitmap.BeginUpdate(True);
268 for Y := 0 to Size.Y - 1 do
269 for X := 0 to Size.X - 1 do begin
270 PtrSrc := SrcBitmap.ScanLine[Y] + X * 4;
271 PtrDest := DstBitmap.ScanLine[Y] + X * 4;
272 C.ARGB := PtrSrc^.ARGB;
273 //C.ARGB := SwapColors(C.ARGB);
274 if BBC then begin
275 PtrDest^.R := C.R;
276 PtrDest^.G := C.G;
277 PtrDest^.B := 0; //C.B;
278 PtrDest^.A := 255 - C.B; // blue channel = transparency
279 end else begin
280 Alpha := C.A;
281 if Alpha < AlphaThreshold then begin
282 PtrDest^.RGB := $7f007f
283 end
284 else begin
285 A := C.ARGB and $ffffff;
286 PtrDest^.RGB := SwapRedBlue(A);
287 end;
288 end;
289 end;
290 SrcBitmap.EndUpdate;
291 DstBitmap.EndUpdate;
292end;
293
294procedure TFormMain.ResizeRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect);
295var
296 X, Y: Integer;
297 SrcPtr: PCardinal;
298 DestPtr: PCardinal;
299begin
300 SrcBitmap.BeginUpdate(True);
301 DstBitmap.BeginUpdate(True);
302 for Y := 0 to DstRect.Height - 1 do begin
303 for X := 0 to DstRect.Width - 1 do begin
304 SrcPtr := SrcBitmap.ScanLine[SrcRect.Top + Trunc(Y / DstRect.Height * SrcRect.Height)];
305 DestPtr := DstBitmap.ScanLine[DstRect.Top + Y];
306 SrcPtr := SrcPtr + SrcRect.Left + Trunc(X / DstRect.Width * SrcRect.Width);
307 DestPtr := DestPtr + DstRect.Left + X;
308 DestPtr^ := SrcPtr^;
309 //ImageDest.Picture.Bitmap.Canvas.Pixels[XX * (DestSize.X + 1) + 1 + X,
310 // YY * (DestSize.Y + 1) + 1 + Y] :=
311 //ImageSrc.Picture.Bitmap.Canvas.Pixels[XX * (SourceSize.X + 1) + 1 + Trunc(X / DestSize.X * SourceSize.X),
312 // YY * (SourceSize.Y + 1) + 1 + Trunc(Y / DestSize.Y * SourceSize.Y)];
313 end;
314 end;
315 SrcBitmap.EndUpdate;
316 DstBitmap.EndUpdate;
317end;
318
319procedure ExecuteProgram(Executable: string; Parameters: array of string);
320var
321 Process: TProcess;
322 I: Integer;
323begin
324 try
325 Process := TProcess.Create(nil);
326 Process.Executable := Executable;
327 for I := 0 to Length(Parameters) - 1 do
328 Process.Parameters.Add(Parameters[I]);
329 Process.Options := [poNoConsole, poWaitOnExit];
330 Process.Execute;
331 finally
332 Process.Free;
333 end;
334end;
335
336procedure TFormMain.ResizeRectXbrz(SrcBitmap, DstBitmap: TBitmap);
337var
338 Png: TPortableNetworkGraphic;
339const
340 XbrzScaleExe = 'xbrzscale'; // https://github.com/atheros/xbrzscale
341begin
342 SrcBitmap.SaveToFile('Input.bmp');
343 ExecuteProgram(XbrzScaleExe, ['3', 'Input.bmp', 'Output.png']);
344 Png := TPortableNetworkGraphic.Create;
345 Png.PixelFormat := pf32bit;
346 Png.LoadFromFile('Output.png');
347 Png.PixelFormat := pf32bit;
348 Png.SaveToFile('Output2.png');
349 DstBitmap.SaveToFile('xxx1.bmp');
350 BitmapStretchRect(DstBitmap, Bounds(0, 0, DstBitmap.Width, DstBitmap.Height),
351 Png, Rect(0, 0, Png.Width, Png.Height));
352 BitmapSwapRedBlue(DstBitmap);
353 DstBitmap.SaveToFile('xxx.bmp');
354 Png.Free;
355end;
356
357procedure TFormMain.ProcessBitmapRect(SrcBitmap, DstBitmap: TBitmap; SrcRect,
358 DstRect: TRect);
359var
360 Src, Dst: TBitmap;
361 Alpha: TBitmap;
362 Alpha2: TBitmap;
363begin
364 Src := TBitmap.Create;
365 Src.SetSize(SrcRect.Width, SrcRect.Height);
366 Src.Canvas.CopyRect(Bounds(0, 0, SrcRect.Width, SrcRect.Height), SrcBitmap.Canvas,
367 SrcRect);
368 Dst := TBitmap.Create;
369 Dst.SetSize(DstRect.Width, DstRect.Height);
370 Dst.PixelFormat := Src.PixelFormat;
371 //Dst.Canvas.Brush.Style := bsSolid;
372 //Dst.Canvas.Brush.Color := $757575;
373 //Dst.Canvas.FillRect(0, 0, Dst.Width, Dst.Height);
374 FillRectBitmap(Dst, $ff000000);
375
376 Alpha := TBitmap.Create;
377 Alpha.PixelFormat := pf32bit;
378 Alpha.SetSize(Src.Width, Src.Height);
379 UseAlphaBitmap(Src, Alpha);
380
381 Alpha2 := TBitmap.Create;
382 Alpha2.PixelFormat := pf32bit;
383 Alpha2.SetSize(Dst.Width, Dst.Height);
384 FillRectBitmap(Alpha2, $00000000);
385 //Alpha2.Canvas.Brush.Style := bsSolid;
386 //Alpha2.Canvas.Brush.Color := $000000;
387 //Alpha2.Canvas.FillRect(0, 0, 0, 0);
388
389 ResizeRectXbrz(Alpha, Alpha2);
390
391 RestoreAlphaBitmap(Alpha2, Dst);
392
393 Dst.SaveToFile('Dst.bmp');
394 DstBitmap.Canvas.CopyRect(DstRect, Dst.Canvas, Bounds(0, 0, DstRect.Width, DstRect.Height));
395 DstBitmap.SaveToFile('DstBitmap.bmp');
396 Src.Free;
397 Dst.Free;
398 Alpha.Free;
399 Alpha2.Free;
400end;
401
402function FindPosition(Bitmap: TBitmap; x, y, xmax, ymax: Integer; Mark: TColor): TPoint;
403var
404 xp, yp: Integer;
405begin
406 xp := 0;
407 while (xp < xmax) and (Bitmap.Canvas.Pixels[x + 1 + xp, y] <> Mark) do
408 Inc(xp);
409 yp := 0;
410 while (yp < ymax) and (Bitmap.Canvas.Pixels[x, y + 1 + yp] <> Mark) do
411 Inc(yp);
412 Result := Point(xp, yp);
413end;
414
415procedure TFormMain.ResizeAuxPos(SrcBitmap, DstBitmap: TBitmap; SrcRect,
416 DstRect: TRect);
417var
418 P: TPoint;
419const
420 MarkColor: TColor = $00ffff;
421begin
422 P := FindPosition(SrcBitmap, SrcRect.Left, SrcRect.Top, SrcRect.Width, SrcRect.Height, MarkColor);
423 P := Point(Round(P.X * DstRect.Width / SrcRect.Width),
424 Round(P.Y * DstRect.Height / SrcRect.Height));
425 DstBitmap.Canvas.Pixels[DstRect.Left + P.X, DstRect.Top] := MarkColor;
426 DstBitmap.Canvas.Pixels[DstRect.Left, DstRect.Top + P.Y] := MarkColor;
427end;
428
429procedure TFormMain.ResizeImage(SourceName: string; SourceSize: TPoint; Count: TPoint;
430 DestName: string; DestSize: TPoint);
431var
432 ImageSrc: TImage;
433 ImageDest: TImage;
434 X, Y: Integer;
435begin
436 ImageSrc := TImage.Create(nil);
437 ImageSrc.Picture.LoadFromFile(SourceName);
438 ImageDest := TImage.Create(nil);
439 ImageDest.Picture.Bitmap.Assign(ImageSrc.Picture.Bitmap);
440 ImageDest.Picture.Bitmap.SetSize((DestSize.X + 1) * Count.X + 1,
441 (DestSize.Y + 1) * Count.Y + 1);
442 //ShowMessage(IntToStr(ImageDest.Picture.Bitmap.Width) + ' ' + IntToStr(ImageDest.Width));
443 FillRectBitmap(ImageDest.Picture.Bitmap, $ff757575);
444
445 ImageSrc.Picture.Bitmap.BeginUpdate(True);
446 //ImageDest.Picture.Bitmap.BeginUpdate(True);
447 //ImageDest.Picture.Bitmap.Canvas.Brush.Style := bsSolid;
448 //ImageDest.Picture.Bitmap.Canvas.Brush.Color := $757575;
449 //ImageDest.Picture.Bitmap.Canvas.FillRect(0, 0, ImageDest.Picture.Bitmap.Width, ImageDest.Picture.Bitmap.Height);
450 for Y := 0 to Count.Y - 1 do
451 for X := 0 to Count.X - 1 do begin
452 ProcessBitmapRect(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap,
453 Bounds(X * (SourceSize.X + 1) + 1, Y * (SourceSize.Y + 1) + 1, SourceSize.X, SourceSize.Y),
454 Bounds(X * (DestSize.X + 1) + 1, Y * (DestSize.Y + 1) + 1, DestSize.X, DestSize.Y));
455 ResizeAuxPos(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap,
456 Bounds(X * (SourceSize.X + 1), Y * (SourceSize.Y + 1), SourceSize.X, SourceSize.Y),
457 Bounds(X * (DestSize.X + 1), Y * (DestSize.Y + 1), DestSize.X, DestSize.Y));
458 end;
459 ImageSrc.Picture.Bitmap.EndUpdate;
460 //ImageDest.Picture.Bitmap.EndUpdate;
461 ImageDest.Picture.SaveToFile(DestName);
462 ImageSrc.Free;
463 ImageDest.Free;
464end;
465
466end.
467
Note: See TracBrowser for help on using the repository browser.