├── .gitignore ├── BitmapPixels.pas ├── LICENSE ├── README.md ├── Res ├── 0.png ├── 1.png ├── 2.png └── 3.png ├── SortingPixels.exe ├── SortingPixels.ico ├── SortingPixels.lpi ├── SortingPixels.lpr ├── SortingPixelsAlgorithm.pas ├── UnitMain.lfm ├── UnitMain.pas ├── other_langs └── readme.md ├── samples ├── 0.bmp ├── 0.png ├── 1.bmp ├── 1.png ├── 10.bmp ├── 10.png ├── 11.bmp ├── 11.png ├── 12.bmp ├── 12.png ├── 13.bmp ├── 13.png ├── 14.bmp ├── 14.png ├── 2.bmp ├── 2.png ├── 3.bmp ├── 3.png ├── 4.bmp ├── 4.png ├── 5.bmp ├── 5.png ├── 6.bmp ├── 6.png ├── 7.bmp ├── 7.png ├── 8.bmp ├── 8.png ├── 9.bmp └── 9.png └── scr.png /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | 68 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss 69 | modules/ 70 | -------------------------------------------------------------------------------- /BitmapPixels.pas: -------------------------------------------------------------------------------- 1 | // ----------------------------------------------------------------------------- 2 | // *** BitmapPixels *** 3 | // version 1.1, last update 13.12.2021 4 | // ----------------------------------------------------------------------------- 5 | // Module for direct access to pixels at TBitmap 6 | // Tested on Windows(WinApi), Linux(Gtk2, Qt5), OSX(Cocoa) 7 | // ----------------------------------------------------------------------------- 8 | // 9 | // Latest verion of this unit aviable here: 10 | // https://github.com/crazzzypeter/BitmapPixels/ 11 | // 12 | // GitHub: https://github.com/crazzzypeter/ 13 | // Twitch: https://www.twitch.tv/crazzzypeter/ 14 | // YouTube: https://www.youtube.com/c/crazzzypeter/ 15 | // YouTube?: https://www.youtube.com/channel/UCPQmDZGb5mZJ27ev9-t3bGQ/ 16 | // Telegram: @crazzzypeter 17 | // 18 | // ----------------------------------------------------------------------------- 19 | // MIT LICENSE 20 | // 21 | // Copyright (c) 2021-2021 CrazzzyPeter 22 | // 23 | // Permission is hereby granted, free of charge, to any person obtaining a copy 24 | // of this software and associated documentation files (the "Software"), to deal 25 | // in the Software without restriction, including without limitation the rights 26 | // to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 27 | // copies of the Software, and to permit persons to whom the Software is 28 | // furnished to do so, subject to the following conditions: 29 | // 30 | // The above copyright notice and this permission notice shall be included in 31 | // all copies or substantial portions of the Software. 32 | // 33 | // THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 34 | // IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 35 | // FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 36 | // AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 37 | // LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 38 | // OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 39 | // SOFTWARE. 40 | // ----------------------------------------------------------------------------- 41 | 42 | {$REGION 'Examples'} 43 | { 44 | Examples of use: 45 | 46 | --- 1 --- 47 | procedure InvertColors(const Bitmap: TBitmap); 48 | var 49 | Data: TBitmapData; 50 | X, Y: Integer; 51 | Pixel: TPixelRec; 52 | begin 53 | Data.Map(Bitmap, TAccessMode.ReadWrite, False);// RGB access 54 | try 55 | for Y := 0 to Data.Height - 1 do 56 | begin 57 | for X := 0 to Data.Width - 1 do 58 | begin 59 | Pixel := Data.GetPixel(X, Y); 60 | Pixel.R := 255 - Pixel.R; 61 | Pixel.G := 255 - Pixel.G; 62 | Pixel.B := 255 - Pixel.B; 63 | Data.SetPixel(X, Y, Pixel); 64 | end; 65 | end; 66 | finally 67 | Data.Unmap(); 68 | end; 69 | end; 70 | 71 | --- 2 --- 72 | procedure HalfAlpha(const Bitmap: TBitmap); 73 | var 74 | Data: TBitmapData; 75 | X, Y: Integer; 76 | Pixel: TPixelRec; 77 | begin 78 | Data.Map(Bitmap, TAccessMode.ReadWrite, True);// ARGB access 79 | try 80 | for Y := 0 to Data.Height - 1 do 81 | begin 82 | for X := 0 to Data.Width - 1 do 83 | begin 84 | Pixel := Data.GetPixel(X, Y); 85 | Pixel.A := Pixel.A div 2; 86 | Data.SetPixel(X, Y, Pixel); 87 | end; 88 | end; 89 | finally 90 | Data.Unmap(); 91 | end; 92 | end; 93 | 94 | --- 3 --- 95 | function MakePlasm(): TBitmap; 96 | var 97 | Data: TBitmapData; 98 | X, Y: Integer; 99 | Pixel: TPixelRec; 100 | begin 101 | Result := TBitmap.Create(); 102 | Result.SetSize(300, 300); 103 | 104 | Data.Map(Result, TAccessMode.Write, False); 105 | try 106 | for Y := 0 to Data.Height - 1 do 107 | begin 108 | for X := 0 to Data.Width - 1 do 109 | begin 110 | Pixel.R := Byte(Trunc( 111 | 100 + 100 * (Sin(X * Cos(Y * 0.049) * 0.01) + Cos(X * 0.0123 - Y * 0.09)))); 112 | Pixel.G := 0; 113 | Pixel.B := Byte(Trunc( 114 | Pixel.R + 100 * (Sin(X * Cos(X * 0.039) * 0.022) + Sin(X * 0.01 - Y * 0.029)))); 115 | Data.SetPixel(X, Y, Pixel); 116 | end; 117 | end; 118 | finally 119 | Data.Unmap(); 120 | end; 121 | end; 122 | 123 | --- 4 --- 124 | function Mix(const A, B: TBitmap): TBitmap; 125 | function Min(A, B: Integer): Integer; 126 | begin 127 | if A < B then Exit(A) else Exit(B); 128 | end; 129 | var 130 | DataA, DataB, DataResult: TBitmapData; 131 | X, Y: Integer; 132 | PixelA, PixelB, PixelResult: TPixelRec; 133 | begin 134 | Result := TBitmap.Create(); 135 | Result.SetSize(Min(A.Width, B.Width), Min(A.Height, B.Height)); 136 | // this needed for correct Unmap() on exception 137 | DataA.Init(); 138 | DataB.Init(); 139 | DataResult.Init(); 140 | try 141 | DataA.Map(A, TAccessMode.Read, False); 142 | DataB.Map(B, TAccessMode.Read, False); 143 | DataResult.Map(Result, TAccessMode.Write, False); 144 | for Y := 0 to DataResult.Height - 1 do 145 | begin 146 | for X := 0 to DataResult.Width - 1 do 147 | begin 148 | PixelA := DataA.Pixels[X, Y]; 149 | PixelB := DataB.Pixels[X, Y]; 150 | PixelResult.R := (PixelA.R + PixelB.R) div 2; 151 | PixelResult.G := (PixelA.G + PixelB.G) div 2; 152 | PixelResult.B := (PixelA.B + PixelB.B) div 2; 153 | DataResult[X, Y] := PixelResult; 154 | end; 155 | end; 156 | finally 157 | DataA.Unmap(); 158 | DataB.Unmap(); 159 | DataResult.Unmap(); 160 | end; 161 | end; 162 | } 163 | {$ENDREGION} 164 | 165 | unit BitmapPixels; 166 | 167 | {$IFDEF FPC}{$MODE DELPHI}{$ENDIF} 168 | {$SCOPEDENUMS ON} 169 | {$POINTERMATH ON} 170 | interface 171 | 172 | uses 173 | {$IFNDEF FPC}Windows,{$ENDIF} Classes, SysUtils, Graphics{$IFDEF FPC}, FPImage{$ENDIF}; 174 | 175 | type 176 | // $AARRGGBB 177 | TPixel = Cardinal; 178 | PPixel = ^TPixel; 179 | 180 | TPixelArray = array [0..High(Integer) div SizeOf(TPixel) - 1] of TPixel; 181 | PPixelArray = ^TPixelArray; 182 | 183 | TAccessMode = (Read, Write, ReadWrite); 184 | 185 | { TBitmapData } 186 | 187 | TBitmapData = record 188 | private 189 | FData: PPixelArray; 190 | FBitmap: TBitmap; 191 | FWidth: Integer; 192 | FHeight: Integer; 193 | FAccessMode: TAccessMode; 194 | FHasAlpha: Boolean; 195 | FDataArray: array of TPixel;// do not use this 196 | public 197 | procedure Init(); 198 | procedure Map(const Bitmap: TBitmap; const Mode: TAccessMode; const UseAlpha: Boolean; 199 | const Background: TColor = clNone); 200 | procedure Unmap(); 201 | function GetPixel(X, Y: Integer): TPixel; inline; 202 | procedure SetPixel(X, Y: Integer; AValue: TPixel); inline; 203 | function GetPixelUnsafe(X, Y: Integer): TPixel; inline; 204 | procedure SetPixelUnsafe(X, Y: Integer; AValue: TPixel); inline; 205 | property Data: PPixelArray read FData; 206 | property HasAlpha: Boolean read FHasAlpha; 207 | property Width: Integer read FWidth; 208 | property Height: Integer read FHeight; 209 | property Pixels[X, Y: Integer]: TPixel read GetPixel write SetPixel; default; 210 | end; 211 | 212 | { TPixelRec } 213 | 214 | TPixelRec = packed record 215 | constructor Create(const R, G, B: Byte; const A: Byte = 255); 216 | class operator Implicit(Pixel: TPixel): TPixelRec; inline; 217 | class operator Implicit(Pixel: TPixelRec): TPixel; inline; 218 | case Byte of 219 | 0: (B, G, R, A: Byte); 220 | 1: (Color: TPixel); 221 | end; 222 | 223 | TPixelColors = record 224 | {$REGION 'HTML Colors'} 225 | const 226 | AliceBlue = $FFF0F8FF; 227 | AntiqueWhite = $FFFAEBD7; 228 | Aqua = $FF00FFFF; 229 | Aquamarine = $FF7FFFD4; 230 | Azure = $FFF0FFFF; 231 | Beige = $FFF5F5DC; 232 | Bisque = $FFFFE4C4; 233 | Black = $FF000000; 234 | BlanchedAlmond = $FFFFEBCD; 235 | Blue = $FF0000FF; 236 | BlueViolet = $FF8A2BE2; 237 | Brown = $FFA52A2A; 238 | BurlyWood = $FFDEB887; 239 | CadetBlue = $FF5F9EA0; 240 | Chartreuse = $FF7FFF00; 241 | Chocolate = $FFD2691E; 242 | Coral = $FFFF7F50; 243 | CornflowerBlue = $FF6495ED; 244 | Cornsilk = $FFFFF8DC; 245 | Crimson = $FFDC143C; 246 | Cyan = $FF00FFFF; 247 | DarkBlue = $FF00008B; 248 | DarkCyan = $FF008B8B; 249 | DarkGoldenrod = $FFB8860B; 250 | DarkGray = $FFA9A9A9; 251 | DarkGreen = $FF006400; 252 | DarkKhaki = $FFBDB76B; 253 | DarkMagenta = $FF8B008B; 254 | DarkOliveGreen = $FF556B2F; 255 | DarkOrange = $FFFF8C00; 256 | DarkOrchid = $FF9932CC; 257 | DarkRed = $FF8B0000; 258 | DarkSalmon = $FFE9967A; 259 | DarkSeaGreen = $FF8FBC8F; 260 | DarkSlateBlue = $FF483D8B; 261 | DarkSlateGray = $FF2F4F4F; 262 | DarkTurquoise = $FF00CED1; 263 | DarkViolet = $FF9400D3; 264 | DeepPink = $FFFF1493; 265 | DeepSkyBlue = $FF00BFFF; 266 | DimGray = $FF696969; 267 | DodgerBlue = $FF1E90FF; 268 | FireBrick = $FFB22222; 269 | FloralWhite = $FFFFFAF0; 270 | ForestGreen = $FF228B22; 271 | Fuchsia = $FFFF00FF; 272 | Gainsboro = $FFDCDCDC; 273 | GhostWhite = $FFF8F8FF; 274 | Gold = $FFFFD700; 275 | Goldenrod = $FFDAA520; 276 | Gray = $FF808080; 277 | Green = $FF008000; 278 | GreenYellow = $FFADFF2F; 279 | Honeydew = $FFF0FFF0; 280 | HotPink = $FFFF69B4; 281 | IndianRed = $FFCD5C5C; 282 | Indigo = $FF4B0082; 283 | Ivory = $FFFFFFF0; 284 | Khaki = $FFF0E68C; 285 | Lavender = $FFE6E6FA; 286 | LavenderBlush = $FFFFF0F5; 287 | LawnGreen = $FF7CFC00; 288 | LemonChiffon = $FFFFFACD; 289 | LightBlue = $FFADD8E6; 290 | LightCoral = $FFF08080; 291 | LightCyan = $FFE0FFFF; 292 | LightGoldenrodYellow = $FFFAFAD2; 293 | LightGreen = $FF90EE90; 294 | LightGrey = $FFD3D3D3; 295 | LightPink = $FFFFB6C1; 296 | LightSalmon = $FFFFA07A; 297 | LightSeaGreen = $FF20B2AA; 298 | LightSkyBlue = $FF87CEFA; 299 | LightSlateGray = $FF778899; 300 | LightSteelBlue = $FFB0C4DE; 301 | LightYellow = $FFFFFFE0; 302 | Lime = $FF00FF00; 303 | LimeGreen = $FF32CD32; 304 | Linen = $FFFAF0E6; 305 | Magenta = $FFFF00FF; 306 | Maroon = $FF800000; 307 | MediumAquamarine = $FF66CDAA; 308 | MediumBlue = $FF0000CD; 309 | MediumOrchid = $FFBA55D3; 310 | MediumPurple = $FF9370DB; 311 | MediumSeaGreen = $FF3CB371; 312 | MediumSlateBlue = $FF7B68EE; 313 | MediumSpringGreen = $FF00FA9A; 314 | MediumTurquoise = $FF48D1CC; 315 | MediumVioletRed = $FFC71585; 316 | MidnightBlue = $FF191970; 317 | MintCream = $FFF5FFFA; 318 | MistyRose = $FFFFE4E1; 319 | Moccasin = $FFFFE4B5; 320 | NavajoWhite = $FFFFDEAD; 321 | Navy = $FF000080; 322 | OldLace = $FFFDF5E6; 323 | Olive = $FF808000; 324 | OliveDrab = $FF6B8E23; 325 | Orange = $FFFFA500; 326 | OrangeRed = $FFFF4500; 327 | Orchid = $FFDA70D6; 328 | PaleGoldenrod = $FFEEE8AA; 329 | PaleGreen = $FF98FB98; 330 | PaleTurquoise = $FFAFEEEE; 331 | PaleVioletRed = $FFDB7093; 332 | PapayaWhip = $FFFFEFD5; 333 | PeachPuff = $FFFFDAB9; 334 | Peru = $FFCD853F; 335 | Pink = $FFFFC0CB; 336 | Plum = $FFDDA0DD; 337 | PowderBlue = $FFB0E0E6; 338 | Purple = $FF800080; 339 | Red = $FFFF0000; 340 | RosyBrown = $FFBC8F8F; 341 | RoyalBlue = $FF4169E1; 342 | SaddleBrown = $FF8B4513; 343 | Salmon = $FFFA8072; 344 | SandyBrown = $FFF4A460; 345 | SeaGreen = $FF2E8B57; 346 | Seashell = $FFFFF5EE; 347 | Sienna = $FFA0522D; 348 | Silver = $FFC0C0C0; 349 | SkyBlue = $FF87CEEB; 350 | SlateBlue = $FF6A5ACD; 351 | SlateGray = $FF708090; 352 | Snow = $FFFFFAFA; 353 | SpringGreen = $FF00FF7F; 354 | SteelBlue = $FF4682B4; 355 | Tan = $FFD2B48C; 356 | Teal = $FF008080; 357 | Thistle = $FFD8BFD8; 358 | Tomato = $FFFF6347; 359 | Turquoise = $FF40E0D0; 360 | Violet = $FFEE82EE; 361 | Wheat = $FFF5DEB3; 362 | White = $FFFFFFFF; 363 | WhiteSmoke = $FFF5F5F5; 364 | Yellow = $FFFFFF00; 365 | YellowGreen = $FF9ACD32; 366 | {$ENDREGION} 367 | end; 368 | 369 | function MakePixel(const R, G, B: Byte; const A: Byte = 255): TPixel; inline; 370 | function PixelGetA(const Pixel: TPixel): Byte; inline; 371 | function PixelGetR(const Pixel: TPixel): Byte; inline; 372 | function PixelGetG(const Pixel: TPixel): Byte; inline; 373 | function PixelGetB(const Pixel: TPixel): Byte; inline; 374 | {$IFDEF FPC} 375 | function FPColorToPixel(const FPColor: TFPColor): TPixel; inline; 376 | function PixelToFPColor(const Pixel: TPixel): TFPColor; inline; 377 | {$ENDIF} 378 | function ColorToPixel(const Color: TColor): TPixel; inline; 379 | function PixelToColor(const Pixel: TPixel): TColor; inline; 380 | 381 | implementation 382 | 383 | {$IFDEF FPC} 384 | uses 385 | IntfGraphics, GraphType, LCLType, LCLIntf; 386 | {$ENDIF} 387 | 388 | function MakePixel(const R, G, B: Byte; const A: Byte): TPixel; inline; 389 | begin 390 | Result := B or (G shl 8) or (R shl 16) or (A shl 24); 391 | end; 392 | 393 | function PixelGetA(const Pixel: TPixel): Byte; inline; 394 | begin 395 | Result := (Pixel shr 24) and $FF; 396 | end; 397 | 398 | function PixelGetR(const Pixel: TPixel): Byte; inline; 399 | begin 400 | Result := (Pixel shr 16) and $FF; 401 | end; 402 | 403 | function PixelGetG(const Pixel: TPixel): Byte; inline; 404 | begin 405 | Result := (Pixel shr 8) and $FF; 406 | end; 407 | 408 | function PixelGetB(const Pixel: TPixel): Byte; inline; 409 | begin 410 | Result := Pixel and $FF; 411 | end; 412 | 413 | {$IFDEF FPC} 414 | function FPColorToPixel(const FPColor: TFPColor): TPixel; inline; 415 | begin 416 | Result:= 417 | ((FPColor.Blue shr 8) and $ff) or 418 | (FPColor.Green and $ff00) or 419 | ((FPColor.Red shl 8) and $ff0000) or 420 | ((FPColor.Alpha shl 16) and $ff000000); 421 | end; 422 | 423 | function PixelToFPColor(const Pixel: TPixel): TFPColor; inline; 424 | begin 425 | Result.Red := (Pixel and $ff0000) shr 8; 426 | Result.Red := Result.Red + (Result.Red shr 8); 427 | Result.Green := (Pixel and $ff00); 428 | Result.Green := Result.Green + (Result.Green shr 8); 429 | Result.Blue := (Pixel and $ff); 430 | Result.Blue := Result.Blue + (Result.Blue shl 8); 431 | Result.Alpha := (Pixel and $ff000000) shr 16; 432 | Result.Alpha := Result.Alpha + (Result.Alpha shr 8); 433 | end; 434 | {$ENDIF} 435 | 436 | function ColorToPixel(const Color: TColor): TPixel; inline; 437 | begin 438 | Result:= 439 | (Color and $0000FF00) or 440 | ((Color shr 16) and $000000FF) or 441 | ((Color shl 16) and $00FF0000) or 442 | $FF000000; 443 | end; 444 | 445 | function PixelToColor(const Pixel: TPixel): TColor; inline; 446 | begin 447 | Result:= 448 | (Pixel and $0000FF00) or 449 | ((Pixel shr 16) and $000000FF) or 450 | ((Pixel shl 16) and $00FF0000); 451 | end; 452 | 453 | function SwapRedBlueChanel(const Pixel: TPixel): TPixel; inline; 454 | begin 455 | Result:= 456 | (Pixel and $FF00FF00) or 457 | ((Pixel shr 16) and $000000FF) or 458 | ((Pixel shl 16) and $00FF0000); 459 | end; 460 | 461 | procedure BlendData(var BitmapData: TBitmapData; const Background: TColor); 462 | var 463 | I: Integer; 464 | R, G, B, A: Byte; 465 | DestR, DestG, DestB: Byte; 466 | C: TPixel; 467 | begin 468 | DestR := Background and $FF; 469 | DestG := (Background shr 8) and $FF; 470 | DestB := (Background shr 16) and $FF; 471 | 472 | for I := 0 to BitmapData.FWidth * BitmapData.FHeight - 1 do 473 | begin 474 | C := BitmapData.FData[I]; 475 | // read 476 | B := C and $FF; 477 | G := (C shr 8) and $FF; 478 | R := (C shr 16) and $FF; 479 | A := (C shr 24) and $FF; 480 | // blend 481 | B := ((B * A) + (DestB * (255 - A))) div 255; 482 | G := ((G * A) + (DestG * (255 - A))) div 255; 483 | R := ((R * A) + (DestR * (255 - A))) div 255; 484 | // write 485 | BitmapData.FData[I] := B or ((G shl 8) and $0000FF00) or ((R shl 16) and $00FF0000); 486 | end; 487 | end; 488 | 489 | {$IFDEF FPC} 490 | // FPC ACCESS 491 | procedure ReadData(var BitmapData: TBitmapData); 492 | var 493 | IntfImage: TLazIntfImage; 494 | X, Y, Position: Integer; 495 | begin 496 | IntfImage := BitmapData.FBitmap.CreateIntfImage(); 497 | try 498 | Position := 0; 499 | for Y := 0 to BitmapData.FHeight - 1 do 500 | begin 501 | for X := 0 to BitmapData.FWidth - 1 do 502 | begin 503 | BitmapData.FData[Position] := FPColorToPixel(IntfImage.Colors[X, Y]); 504 | Inc(Position, 1); 505 | end; 506 | end; 507 | finally 508 | IntfImage.Free(); 509 | end; 510 | end; 511 | 512 | {function MakeNativeGtk2RawImageDescription(const Width, Height: Integer): TRawImageDescription; 513 | begin 514 | Result.Init; 515 | Result.Format := ricfRGBA; 516 | Result.Width := Width; 517 | Result.Height := Height; 518 | Result.Depth := 32; 519 | Result.BitOrder := riboBitsInOrder; 520 | Result.ByteOrder := riboLSBFirst; 521 | Result.LineOrder := riloTopToBottom; 522 | Result.LineEnd := rileDWordBoundary; 523 | Result.BitsPerPixel := 32; 524 | Result.RedPrec := 8; 525 | Result.RedShift := 0; 526 | Result.GreenPrec := 8; 527 | Result.GreenShift := 8; 528 | Result.BluePrec := 8; 529 | Result.BlueShift := 16; 530 | Result.AlphaPrec := 8; 531 | Result.AlphaShift := 24; 532 | Result.MaskBitsPerPixel := 0; 533 | Result.MaskShift := 0; 534 | Result.MaskLineEnd := rileByteBoundary; 535 | Result.MaskBitOrder := riboBitsInOrder; 536 | Result.PaletteColorCount := 0; 537 | Result.PaletteBitsPerIndex := 0; 538 | Result.PaletteShift := 0; 539 | Result.PaletteLineEnd := rileTight; 540 | Result.PaletteBitOrder := riboBitsInOrder; 541 | Result.PaletteByteOrder := riboLSBFirst; 542 | end;} 543 | 544 | {$IF DEFINED(LCLGTK2) OR DEFINED(WINDOWS)} 545 | procedure WriteData(var BitmapData: TBitmapData); 546 | var 547 | Position: Integer; 548 | RawImage: TRawImage; 549 | begin 550 | if BitmapData.FHasAlpha then 551 | begin 552 | RawImage.Init(); 553 | RawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(BitmapData.FWidth, BitmapData.FHeight); 554 | RawImage.Data := PByte(@(BitmapData.FData[0])); 555 | RawImage.DataSize := BitmapData.FWidth * BitmapData.FHeight * SizeOf(TPixel); 556 | BitmapData.FBitmap.LoadFromRawImage(RawImage, False); 557 | end else 558 | begin 559 | RawImage.Init(); 560 | RawImage.Description.Init_BPP32_B8G8R8_BIO_TTB(BitmapData.FWidth, BitmapData.FHeight); 561 | RawImage.DataSize := BitmapData.FWidth * BitmapData.FHeight * SizeOf(TPixel); 562 | RawImage.CreateData(False); 563 | try 564 | for Position := 0 to BitmapData.FWidth * BitmapData.FHeight - 1 do 565 | begin 566 | PPixel(RawImage.Data)[Position] := BitmapData.Data[Position] and $00FFFFFF; 567 | end; 568 | BitmapData.FBitmap.LoadFromRawImage(RawImage, False); 569 | finally 570 | RawImage.FreeData(); 571 | end; 572 | end; 573 | end; 574 | {$ELSE} 575 | procedure WriteData(var BitmapData: TBitmapData); 576 | var 577 | IntfImage: TLazIntfImage; 578 | X, Y, Position: Integer; 579 | //RawImage: TRawImage; 580 | begin 581 | if BitmapData.FHasAlpha then 582 | IntfImage := TLazIntfImage.Create(BitmapData.FWidth, BitmapData.FHeight, [riqfRGB, riqfAlpha]) 583 | else 584 | IntfImage := TLazIntfImage.Create(BitmapData.FWidth, BitmapData.FHeight, [riqfRGB]); 585 | try 586 | IntfImage.CreateData(); 587 | Position := 0; 588 | for Y := 0 to BitmapData.FHeight - 1 do 589 | begin 590 | for X := 0 to BitmapData.FWidth - 1 do 591 | begin 592 | IntfImage.Colors[X, Y] := PixelToFPColor(BitmapData.FData[Position]); 593 | Inc(Position, 1); 594 | end; 595 | end; 596 | BitmapData.FBitmap.LoadFromIntfImage(IntfImage); 597 | // IntfImage.GetRawImage(RawImage, True); 598 | // BitmapData.FBitmap.LoadFromRawImage(RawImage, True); 599 | finally 600 | IntfImage.Free(); 601 | end; 602 | end; 603 | {$ENDIF} 604 | 605 | procedure ReadDataRGB(var BitmapData: TBitmapData); 606 | var 607 | pSrc: PByte; 608 | X, Y, Position: Integer; 609 | begin 610 | BitmapData.FBitmap.BeginUpdate(False); 611 | try 612 | Position := 0; 613 | for Y := 0 to BitmapData.FHeight - 1 do 614 | begin 615 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 616 | for X := 0 to BitmapData.FWidth - 1 do 617 | begin 618 | BitmapData.FData[Position] := (pSrc[0] shl 16) or (pSrc[1] shl 8) or pSrc[2]; 619 | Inc(Position, 1); 620 | Inc(pSrc, 3); 621 | end; 622 | end; 623 | finally 624 | BitmapData.FBitmap.EndUpdate(False); 625 | end; 626 | end; 627 | 628 | procedure ReadDataRGBOpaque(var BitmapData: TBitmapData); 629 | var 630 | pSrc: PByte; 631 | X, Y, Position: Integer; 632 | begin 633 | BitmapData.FBitmap.BeginUpdate(False); 634 | try 635 | Position := 0; 636 | for Y := 0 to BitmapData.FHeight - 1 do 637 | begin 638 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 639 | for X := 0 to BitmapData.FWidth - 1 do 640 | begin 641 | BitmapData.FData[Position] := (pSrc[0] shl 16) or (pSrc[1] shl 8) or pSrc[2] or $FF000000; 642 | Inc(Position, 1); 643 | Inc(pSrc, 3); 644 | end; 645 | end; 646 | finally 647 | BitmapData.FBitmap.EndUpdate(False); 648 | end; 649 | end; 650 | 651 | procedure ReadDataBGR(var BitmapData: TBitmapData); 652 | var 653 | pSrc: PByte; 654 | X, Y, Position: Integer; 655 | begin 656 | BitmapData.FBitmap.BeginUpdate(False); 657 | try 658 | Position := 0; 659 | for Y := 0 to BitmapData.FHeight - 1 do 660 | begin 661 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 662 | for X := 0 to BitmapData.FWidth - 1 do 663 | begin 664 | BitmapData.FData[Position] := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16); 665 | Inc(Position, 1); 666 | Inc(pSrc, 3); 667 | end; 668 | end; 669 | finally 670 | BitmapData.FBitmap.EndUpdate(False); 671 | end; 672 | end; 673 | 674 | procedure ReadDataBGROpaque(var BitmapData: TBitmapData); 675 | var 676 | pSrc: PByte; 677 | X, Y, Position: Integer; 678 | begin 679 | BitmapData.FBitmap.BeginUpdate(False); 680 | try 681 | Position := 0; 682 | for Y := 0 to BitmapData.FHeight - 1 do 683 | begin 684 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 685 | for X := 0 to BitmapData.FWidth - 1 do 686 | begin 687 | BitmapData.FData[Position] := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16) or $FF000000; 688 | Inc(Position, 1); 689 | Inc(pSrc, 3); 690 | end; 691 | end; 692 | finally 693 | BitmapData.FBitmap.EndUpdate(False); 694 | end; 695 | end; 696 | 697 | procedure ReadDataBGRA(var BitmapData: TBitmapData);// fast 698 | var 699 | Y: Integer; 700 | pSrc, pDst: PPixel; 701 | begin 702 | BitmapData.FBitmap.BeginUpdate(False); 703 | try 704 | for Y := 0 to BitmapData.FHeight - 1 do 705 | begin 706 | pSrc := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 707 | pDst := @(BitmapData.FData[BitmapData.FWidth * Y]); 708 | Move(pSrc^, pDst^, BitmapData.FWidth * SizeOf(TPixel)); 709 | end; 710 | finally 711 | BitmapData.FBitmap.EndUpdate(False); 712 | end; 713 | end; 714 | 715 | procedure ReadDataBGRN(var BitmapData: TBitmapData); 716 | var 717 | Scanline: PPixel; 718 | X, Y, Position: Integer; 719 | begin 720 | BitmapData.FBitmap.BeginUpdate(False); 721 | try 722 | Position := 0; 723 | for Y := 0 to BitmapData.FHeight - 1 do 724 | begin 725 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 726 | for X := 0 to BitmapData.FWidth - 1 do 727 | begin 728 | BitmapData.FData[Position] := Scanline[X]; 729 | Inc(Position, 1); 730 | end; 731 | end; 732 | finally 733 | BitmapData.FBitmap.EndUpdate(False); 734 | end; 735 | end; 736 | 737 | procedure ReadDataBGRNOpaque(var BitmapData: TBitmapData); 738 | var 739 | Scanline: PPixel; 740 | X, Y, Position: Integer; 741 | begin 742 | BitmapData.FBitmap.BeginUpdate(False); 743 | try 744 | Position := 0; 745 | for Y := 0 to BitmapData.FHeight - 1 do 746 | begin 747 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 748 | for X := 0 to BitmapData.FWidth - 1 do 749 | begin 750 | BitmapData.FData[Position] := Scanline[X] or $FF000000; 751 | Inc(Position, 1); 752 | end; 753 | end; 754 | finally 755 | BitmapData.FBitmap.EndUpdate(False); 756 | end; 757 | end; 758 | 759 | procedure ReadDataRGBA(var BitmapData: TBitmapData); 760 | var 761 | Scanline: PPixel; 762 | X, Y, Position: Integer; 763 | begin 764 | BitmapData.FBitmap.BeginUpdate(False); 765 | try 766 | Position := 0; 767 | for Y := 0 to BitmapData.FHeight - 1 do 768 | begin 769 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 770 | for X := 0 to BitmapData.FWidth - 1 do 771 | begin 772 | BitmapData.FData[Position] := SwapRedBlueChanel(Scanline[X]); 773 | Inc(Position, 1); 774 | end; 775 | end; 776 | finally 777 | BitmapData.FBitmap.EndUpdate(False); 778 | end; 779 | end; 780 | 781 | procedure ReadDataRGBN(var BitmapData: TBitmapData); 782 | var 783 | Scanline: PPixel; 784 | Pixel: TPixel; 785 | X, Y, Position: Integer; 786 | begin 787 | BitmapData.FBitmap.BeginUpdate(False); 788 | try 789 | Position := 0; 790 | for Y := 0 to BitmapData.FHeight - 1 do 791 | begin 792 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 793 | for X := 0 to BitmapData.FWidth - 1 do 794 | begin 795 | Pixel := Scanline[X]; 796 | BitmapData.FData[Position] := 797 | ((Pixel shr 16) and $000000FF) or 798 | (Pixel and $0000FF00) or 799 | ((Pixel shl 16) and $00FF0000); 800 | Inc(Position, 1); 801 | end; 802 | end; 803 | finally 804 | BitmapData.FBitmap.EndUpdate(False); 805 | end; 806 | end; 807 | 808 | procedure ReadDataRGBNOpaque(var BitmapData: TBitmapData); 809 | var 810 | Scanline: PPixel; 811 | Pixel: TPixel; 812 | X, Y, Position: Integer; 813 | begin 814 | BitmapData.FBitmap.BeginUpdate(False); 815 | try 816 | Position := 0; 817 | for Y := 0 to BitmapData.FHeight - 1 do 818 | begin 819 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 820 | for X := 0 to BitmapData.FWidth - 1 do 821 | begin 822 | Pixel := Scanline[X]; 823 | BitmapData.FData[Position] := 824 | ((Pixel shr 16) and $000000FF) or 825 | (Pixel and $0000FF00) or 826 | ((Pixel shl 16) and $00FF0000) or 827 | $FF000000; 828 | Inc(Position, 1); 829 | end; 830 | end; 831 | finally 832 | BitmapData.FBitmap.EndUpdate(False); 833 | end; 834 | end; 835 | 836 | procedure WriteDataRGB(var BitmapData: TBitmapData); 837 | var 838 | pSrc: PByte; 839 | C: TPixel; 840 | X, Y, Position: Integer; 841 | begin 842 | BitmapData.FBitmap.BeginUpdate(False); 843 | try 844 | Position := 0; 845 | for Y := 0 to BitmapData.FHeight - 1 do 846 | begin 847 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 848 | for X := 0 to BitmapData.FWidth - 1 do 849 | begin 850 | C := BitmapData.FData[Position]; 851 | pSrc[0] := (C shr 16) and $FF; 852 | pSrc[1] := (C shr 8) and $FF; 853 | pSrc[2] := C and $FF; 854 | Inc(Position, 1); 855 | Inc(pSrc, 3); 856 | end; 857 | end; 858 | finally 859 | BitmapData.FBitmap.EndUpdate(False); 860 | end; 861 | end; 862 | 863 | procedure WriteDataBGR(var BitmapData: TBitmapData); 864 | var 865 | pSrc: PByte; 866 | C: TPixel; 867 | X, Y, Position: Integer; 868 | begin 869 | BitmapData.FBitmap.BeginUpdate(False); 870 | try 871 | Position := 0; 872 | for Y := 0 to BitmapData.FHeight - 1 do 873 | begin 874 | pSrc := PByte(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 875 | for X := 0 to BitmapData.FWidth - 1 do 876 | begin 877 | C := BitmapData.FData[Position]; 878 | pSrc[0] := C and $FF; 879 | pSrc[1] := (C shr 8) and $FF; 880 | pSrc[2] := (C shr 16) and $FF; 881 | Inc(Position, 1); 882 | Inc(pSrc, 3); 883 | end; 884 | end; 885 | finally 886 | BitmapData.FBitmap.EndUpdate(False); 887 | end; 888 | end; 889 | 890 | procedure WriteDataBGRA(var BitmapData: TBitmapData);// fast 891 | var 892 | Y: Integer; 893 | pSrc, pDst: PPixel; 894 | begin 895 | BitmapData.FBitmap.BeginUpdate(False); 896 | try 897 | for Y := 0 to BitmapData.FHeight - 1 do 898 | begin 899 | pDst := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 900 | pSrc := @(BitmapData.FData[BitmapData.FWidth * Y]); 901 | Move(pSrc^, pDst^, BitmapData.FWidth * SizeOf(TPixel)); 902 | end; 903 | finally 904 | BitmapData.FBitmap.EndUpdate(False); 905 | end; 906 | end; 907 | 908 | procedure WriteDataRGBA(var BitmapData: TBitmapData); 909 | var 910 | Scanline: PPixel; 911 | X, Y, Position: Integer; 912 | begin 913 | BitmapData.FBitmap.BeginUpdate(False); 914 | try 915 | Position := 0; 916 | for Y := 0 to BitmapData.FHeight - 1 do 917 | begin 918 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 919 | for X := 0 to BitmapData.FWidth - 1 do 920 | begin 921 | Scanline[X] := SwapRedBlueChanel(BitmapData.FData[Position]); 922 | Inc(Position, 1); 923 | end; 924 | end; 925 | finally 926 | BitmapData.FBitmap.EndUpdate(False); 927 | end; 928 | end; 929 | 930 | procedure WriteDataRGBN(var BitmapData: TBitmapData); 931 | var 932 | Scanline: PPixel; 933 | Pixel: TPixel; 934 | X, Y, Position: Integer; 935 | begin 936 | BitmapData.FBitmap.BeginUpdate(False); 937 | try 938 | Position := 0; 939 | for Y := 0 to BitmapData.FHeight - 1 do 940 | begin 941 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 942 | for X := 0 to BitmapData.FWidth - 1 do 943 | begin 944 | Pixel := BitmapData.FData[Position]; 945 | Scanline[X] := 946 | ((Pixel shr 16) and $000000FF) or 947 | (Pixel and $0000FF00) or 948 | ((Pixel shl 16) and $00FF0000); 949 | Inc(Position, 1); 950 | end; 951 | end; 952 | finally 953 | BitmapData.FBitmap.EndUpdate(False); 954 | end; 955 | end; 956 | 957 | procedure WriteDataBGRN(var BitmapData: TBitmapData); 958 | var 959 | Scanline: PPixel; 960 | X, Y, Position: Integer; 961 | begin 962 | BitmapData.FBitmap.BeginUpdate(False); 963 | try 964 | Position := 0; 965 | for Y := 0 to BitmapData.FHeight - 1 do 966 | begin 967 | Scanline := PPixel(BitmapData.FBitmap.RawImage.GetLineStart(Y)); 968 | for X := 0 to BitmapData.FWidth - 1 do 969 | begin 970 | Scanline[X] := BitmapData.FData[Position] and $00FFFFFF; 971 | Inc(Position, 1); 972 | end; 973 | end; 974 | finally 975 | BitmapData.FBitmap.EndUpdate(False); 976 | end; 977 | end; 978 | 979 | type 980 | TDescriptionType = (DeskBGR, DeskRGB, DeskBGRA, DeskRGBA, DeskBGRN, DeskRGBN, DeskOther); 981 | 982 | function CalcDescriptionType(const Description: TRawImageDescription; const IsReadOnly: Boolean = False): TDescriptionType; 983 | begin 984 | Result := TDescriptionType.DeskOther; 985 | if Description.Format <> ricfRGBA then Exit; 986 | if Description.ByteOrder <> riboLSBFirst then Exit; 987 | if Description.PaletteColorCount <> 0 then Exit; 988 | // if Description.BitOrder <> riboBitsInOrder then Exit; // it doesn't matter without a mask 989 | 990 | // ??? I think it makes no difference to us whether there is a mask or not 991 | {$IFDEF LCLGTK2} 992 | // LCLGTK2 image width workaround 993 | // ex: width = 16 - ok, width = 15 bug 994 | if (not IsReadOnly) and (Description.MaskBitsPerPixel <> 0) then 995 | if Description.MaskLineEnd = rileByteBoundary then Exit; 996 | {$ENDIF} 997 | 998 | if Description.BitsPerPixel = 32 then 999 | begin 1000 | if Description.Depth = 32 then 1001 | begin 1002 | // prec 1003 | if Description.RedPrec <> 8 then Exit; 1004 | if Description.GreenPrec <> 8 then Exit; 1005 | if Description.BluePrec <> 8 then Exit; 1006 | if Description.AlphaPrec <> 8 then Exit; 1007 | // A and G 1008 | if Description.AlphaShift <> 24 then Exit; 1009 | if Description.GreenShift <> 8 then Exit; 1010 | // DeskBGRA or DeskRGBA 1011 | if (Description.RedShift = 16) and (Description.BlueShift = 0) then 1012 | Result := TDescriptionType.DeskBGRA 1013 | else if (Description.RedShift = 0) and (Description.BlueShift = 16) then 1014 | Result := TDescriptionType.DeskRGBA 1015 | else 1016 | Result := TDescriptionType.DeskOther; 1017 | end 1018 | else if Description.Depth = 24 then 1019 | begin 1020 | // prec 1021 | if Description.RedPrec <> 8 then Exit; 1022 | if Description.GreenPrec <> 8 then Exit; 1023 | if Description.BluePrec <> 8 then Exit; 1024 | // G 1025 | if Description.GreenShift <> 8 then Exit; 1026 | // DeskBGRN or DeskRGBN 1027 | if (Description.RedShift = 16) and (Description.BlueShift = 0) then 1028 | Result := TDescriptionType.DeskBGRN 1029 | else if (Description.RedShift = 0) and (Description.BlueShift = 16) then 1030 | Result := TDescriptionType.DeskRGBN 1031 | else 1032 | Result := TDescriptionType.DeskOther; 1033 | end; 1034 | end 1035 | else if Description.BitsPerPixel = 24 then 1036 | begin 1037 | if Description.Depth <> 24 then Exit; 1038 | // prec 1039 | if Description.RedPrec <> 8 then Exit; 1040 | if Description.GreenPrec <> 8 then Exit; 1041 | if Description.BluePrec <> 8 then Exit; 1042 | // G 1043 | if Description.GreenShift <> 8 then Exit; 1044 | // DeskBGR or DeskRGB 1045 | if (Description.RedShift = 16) and (Description.BlueShift = 0) then 1046 | Result := TDescriptionType.DeskBGR 1047 | else if (Description.RedShift = 0) and (Description.BlueShift = 16) then 1048 | Result := TDescriptionType.DeskRGB 1049 | else 1050 | Result := TDescriptionType.DeskOther; 1051 | end else 1052 | Result := TDescriptionType.DeskOther; 1053 | end; 1054 | 1055 | procedure BitmapDataMap(out BitmapData: TBitmapData; const Bitmap: TBitmap; const Mode: TAccessMode; 1056 | const UseAlpha: Boolean; const Background: TColor); 1057 | begin 1058 | BitmapData.FBitmap := Bitmap; 1059 | BitmapData.FAccessMode := Mode; 1060 | BitmapData.FHasAlpha := UseAlpha; 1061 | BitmapData.FWidth := Bitmap.Width; 1062 | BitmapData.FHeight := Bitmap.Height; 1063 | 1064 | SetLength(BitmapData.FDataArray, BitmapData.FHeight * BitmapData.FWidth); 1065 | if Length(BitmapData.FDataArray) > 0 then 1066 | BitmapData.FData := @(BitmapData.FDataArray[0]) 1067 | else 1068 | BitmapData.FData := nil; 1069 | 1070 | if (BitmapData.FData <> nil) and (BitmapData.FAccessMode in [TAccessMode.ReadWrite, TAccessMode.Read]) then 1071 | begin 1072 | case CalcDescriptionType(BitmapData.FBitmap.RawImage.Description, True) of 1073 | TDescriptionType.DeskRGB: 1074 | if BitmapData.FHasAlpha then 1075 | ReadDataRGBOpaque(BitmapData) 1076 | else 1077 | ReadDataRGB(BitmapData); 1078 | 1079 | TDescriptionType.DeskBGR: 1080 | if BitmapData.FHasAlpha then 1081 | ReadDataBGROpaque(BitmapData) 1082 | else 1083 | ReadDataBGR(BitmapData); 1084 | 1085 | TDescriptionType.DeskRGBA: 1086 | if BitmapData.FHasAlpha then 1087 | ReadDataRGBA(BitmapData) 1088 | else 1089 | begin 1090 | if Background <> clNone then 1091 | begin 1092 | ReadDataRGBA(BitmapData); 1093 | BlendData(BitmapData, Background); 1094 | end else 1095 | ReadDataRGBN(BitmapData); 1096 | end; 1097 | 1098 | TDescriptionType.DeskBGRA: 1099 | if BitmapData.FHasAlpha then 1100 | ReadDataBGRA(BitmapData) 1101 | else 1102 | begin 1103 | if Background <> clNone then 1104 | begin 1105 | ReadDataBGRA(BitmapData); 1106 | BlendData(BitmapData, Background); 1107 | end else 1108 | ReadDataBGRN(BitmapData); 1109 | end; 1110 | 1111 | TDescriptionType.DeskRGBN: 1112 | if BitmapData.FHasAlpha then 1113 | ReadDataRGBNOpaque(BitmapData) 1114 | else 1115 | ReadDataRGBN(BitmapData); 1116 | 1117 | TDescriptionType.DeskBGRN: 1118 | if BitmapData.FHasAlpha then 1119 | ReadDataBGRNOpaque(BitmapData) 1120 | else 1121 | ReadDataBGRN(BitmapData); 1122 | 1123 | TDescriptionType.DeskOther: 1124 | ReadData(BitmapData); 1125 | end; 1126 | end; 1127 | end; 1128 | 1129 | procedure BitmapDataUnmap(var BitmapData: TBitmapData); 1130 | begin 1131 | try 1132 | if (BitmapData.FData <> nil) and (BitmapData.FAccessMode in [TAccessMode.ReadWrite, TAccessMode.Write]) then 1133 | begin 1134 | if BitmapData.FHasAlpha then 1135 | BitmapData.FBitmap.PixelFormat := pf32bit 1136 | else 1137 | BitmapData.FBitmap.PixelFormat := pf24bit; 1138 | 1139 | case CalcDescriptionType(BitmapData.FBitmap.RawImage.Description) of 1140 | TDescriptionType.DeskRGB: 1141 | WriteDataRGB(BitmapData); 1142 | 1143 | TDescriptionType.DeskBGR: 1144 | WriteDataBGR(BitmapData); 1145 | 1146 | TDescriptionType.DeskRGBA: 1147 | WriteDataRGBA(BitmapData); 1148 | 1149 | TDescriptionType.DeskBGRA: 1150 | WriteDataBGRA(BitmapData); 1151 | 1152 | TDescriptionType.DeskRGBN: 1153 | WriteDataRGBN(BitmapData); 1154 | 1155 | TDescriptionType.DeskBGRN: 1156 | WriteDataBGRN(BitmapData); 1157 | 1158 | TDescriptionType.DeskOther: 1159 | WriteData(BitmapData); 1160 | end; 1161 | end; 1162 | finally 1163 | Finalize(BitmapData.FDataArray); 1164 | end; 1165 | end; 1166 | 1167 | {$ELSE} 1168 | // DELPHI VCL ACCESS 1169 | 1170 | procedure ReadData(var BitmapData: TBitmapData); 1171 | var 1172 | TempBitmap: TBitmap; 1173 | X, Y: Integer; 1174 | pDst: PPixel; 1175 | pSrc: PByte; 1176 | begin 1177 | TempBitmap := TBitmap.Create(); 1178 | try 1179 | TempBitmap.Assign(BitmapData.FBitmap); 1180 | TempBitmap.PixelFormat := pf24bit; 1181 | 1182 | pDst := @(BitmapData.FData[0]); 1183 | for Y := 0 to BitmapData.FHeight - 1 do 1184 | begin 1185 | pSrc := TempBitmap.ScanLine[Y]; 1186 | for X := 0 to BitmapData.FWidth - 1 do 1187 | begin 1188 | pDst^ := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16); 1189 | Inc(pDst, 1); 1190 | Inc(pSrc, 3); 1191 | end; 1192 | end; 1193 | finally 1194 | TempBitmap.Free; 1195 | end; 1196 | end; 1197 | 1198 | procedure ReadDataOpaque(var BitmapData: TBitmapData); 1199 | var 1200 | TempBitmap: TBitmap; 1201 | X, Y: Integer; 1202 | pDst: PPixel; 1203 | pSrc: PByte; 1204 | begin 1205 | TempBitmap := TBitmap.Create(); 1206 | try 1207 | TempBitmap.Assign(BitmapData.FBitmap); 1208 | TempBitmap.PixelFormat := pf24bit; 1209 | 1210 | pDst := @(BitmapData.FData[0]); 1211 | for Y := 0 to BitmapData.FHeight - 1 do 1212 | begin 1213 | pSrc := TempBitmap.ScanLine[Y]; 1214 | for X := 0 to BitmapData.FWidth - 1 do 1215 | begin 1216 | pDst^ := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16) or $FF000000; 1217 | Inc(pDst, 1); 1218 | Inc(pSrc, 3); 1219 | end; 1220 | end; 1221 | finally 1222 | TempBitmap.Free; 1223 | end; 1224 | end; 1225 | 1226 | procedure ReadDataBGR(var BitmapData: TBitmapData); 1227 | var 1228 | X, Y: Integer; 1229 | pDst: PPixel; 1230 | pSrc: PByte; 1231 | begin 1232 | pDst := @(BitmapData.FData[0]); 1233 | for Y := 0 to BitmapData.FHeight - 1 do 1234 | begin 1235 | pSrc := BitmapData.FBitmap.ScanLine[Y]; 1236 | for X := 0 to BitmapData.FWidth - 1 do 1237 | begin 1238 | pDst^ := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16); 1239 | Inc(pDst, 1); 1240 | Inc(pSrc, 3); 1241 | end; 1242 | end; 1243 | end; 1244 | 1245 | procedure ReadDataBGROpaque(var BitmapData: TBitmapData); 1246 | var 1247 | X, Y: Integer; 1248 | pDst: PPixel; 1249 | pSrc: PByte; 1250 | begin 1251 | pDst := @(BitmapData.FData[0]); 1252 | for Y := 0 to BitmapData.FHeight - 1 do 1253 | begin 1254 | pSrc := BitmapData.FBitmap.ScanLine[Y]; 1255 | for X := 0 to BitmapData.FWidth - 1 do 1256 | begin 1257 | pDst^ := pSrc[0] or (pSrc[1] shl 8) or (pSrc[2] shl 16) or $FF000000; 1258 | Inc(pDst, 1); 1259 | Inc(pSrc, 3); 1260 | end; 1261 | end; 1262 | end; 1263 | 1264 | procedure ReadDataBGRA(var BitmapData: TBitmapData);// fast 1265 | var 1266 | Y: Integer; 1267 | pDst: PPixel; 1268 | pSrc: PPixel; 1269 | begin 1270 | for Y := 0 to BitmapData.FHeight - 1 do 1271 | begin 1272 | pSrc := BitmapData.FBitmap.ScanLine[Y]; 1273 | pDst := @(BitmapData.FData[BitmapData.FWidth * Y]); 1274 | Move(pSrc^, pDst^, BitmapData.FWidth * SizeOf(TPixel)); 1275 | end; 1276 | end; 1277 | 1278 | procedure ReadDataPremultipliedBGRA(var BitmapData: TBitmapData);// slow 1279 | var 1280 | X, Y: Integer; 1281 | pDst: PPixel; 1282 | pSrc: PPixel; 1283 | Pixel: TPixelRec; 1284 | begin 1285 | pDst := @(BitmapData.FData[0]); 1286 | for Y := 0 to BitmapData.FHeight - 1 do 1287 | begin 1288 | pSrc := BitmapData.FBitmap.ScanLine[Y]; 1289 | for X := 0 to BitmapData.FWidth - 1 do 1290 | begin 1291 | Pixel := pSrc^; 1292 | if Pixel.A = 0 then 1293 | begin 1294 | Pixel.Color := $00000000; 1295 | end else 1296 | begin 1297 | Pixel.R := MulDiv(Pixel.R, 255, Pixel.A); 1298 | Pixel.G := MulDiv(Pixel.G, 255, Pixel.A); 1299 | Pixel.B := MulDiv(Pixel.B, 255, Pixel.A); 1300 | end; 1301 | pDst^ := Pixel; 1302 | Inc(pDst, 1); 1303 | Inc(pSrc, 1); 1304 | end; 1305 | end; 1306 | end; 1307 | 1308 | procedure ReadDataBGRN(var BitmapData: TBitmapData); 1309 | var 1310 | X, Y: Integer; 1311 | pDst: PPixel; 1312 | pSrc: PPixel; 1313 | begin 1314 | pDst := @(BitmapData.FData[0]); 1315 | for Y := 0 to BitmapData.FHeight - 1 do 1316 | begin 1317 | pSrc := BitmapData.FBitmap.ScanLine[Y]; 1318 | for X := 0 to BitmapData.FWidth - 1 do 1319 | begin 1320 | pDst^ := pSrc^ and $00FFFFFF; 1321 | Inc(pDst, 1); 1322 | Inc(pSrc, 1); 1323 | end; 1324 | end; 1325 | end; 1326 | 1327 | procedure WriteDataBGRA(var BitmapData: TBitmapData);// fast 1328 | var 1329 | Y: Integer; 1330 | pDst: PPixel; 1331 | pSrc: PPixel; 1332 | begin 1333 | for Y := 0 to BitmapData.FHeight - 1 do 1334 | begin 1335 | pSrc := @(BitmapData.FData[BitmapData.FWidth * Y]); 1336 | pDst := BitmapData.FBitmap.ScanLine[Y]; 1337 | Move(pSrc^, pDst^, BitmapData.FWidth * SizeOf(TPixel)); 1338 | end; 1339 | end; 1340 | 1341 | procedure WriteDataPremultipliedBGRA(var BitmapData: TBitmapData);// slow 1342 | var 1343 | X, Y: Integer; 1344 | pDst: PPixel; 1345 | pSrc: PPixel; 1346 | Pixel: TPixelRec; 1347 | begin 1348 | pSrc := @(BitmapData.FData[0]); 1349 | for Y := 0 to BitmapData.FHeight - 1 do 1350 | begin 1351 | pDst := BitmapData.FBitmap.ScanLine[Y]; 1352 | for X := 0 to BitmapData.FWidth - 1 do 1353 | begin 1354 | Pixel := pSrc^; 1355 | Pixel.R := MulDiv(Pixel.R, Pixel.A, 255); 1356 | Pixel.G := MulDiv(Pixel.G, Pixel.A, 255); 1357 | Pixel.B := MulDiv(Pixel.B, Pixel.A, 255); 1358 | pDst^ := Pixel; 1359 | Inc(pDst, 1); 1360 | Inc(pSrc, 1); 1361 | end; 1362 | end; 1363 | end; 1364 | 1365 | procedure WriteDataBGR(var BitmapData: TBitmapData); 1366 | var 1367 | X, Y: Integer; 1368 | pDst: PByte; 1369 | pSrc: PPixel; 1370 | begin 1371 | pSrc := @(BitmapData.FData[0]); 1372 | for Y := 0 to BitmapData.FHeight - 1 do 1373 | begin 1374 | pDst := BitmapData.FBitmap.ScanLine[Y]; 1375 | for X := 0 to BitmapData.FWidth - 1 do 1376 | begin 1377 | pDst[0] := pSrc^ and $FF; 1378 | pDst[1] := (pSrc^ shr 8) and $FF; 1379 | pDst[2] := (pSrc^ shr 16) and $FF; 1380 | Inc(pDst, 3); 1381 | Inc(pSrc, 1); 1382 | end; 1383 | end; 1384 | end; 1385 | 1386 | procedure BitmapDataMap(out BitmapData: TBitmapData; const Bitmap: TBitmap; const Mode: TAccessMode; 1387 | const UseAlpha: Boolean; const Background: TColor); 1388 | begin 1389 | BitmapData.FBitmap := Bitmap; 1390 | BitmapData.FAccessMode := Mode; 1391 | BitmapData.FHasAlpha := UseAlpha; 1392 | BitmapData.FWidth := Bitmap.Width; 1393 | BitmapData.FHeight := Bitmap.Height; 1394 | 1395 | SetLength(BitmapData.FDataArray, BitmapData.FHeight * BitmapData.FWidth); 1396 | if Length(BitmapData.FDataArray) > 0 then 1397 | BitmapData.FData := @(BitmapData.FDataArray[0]) 1398 | else 1399 | BitmapData.FData := nil; 1400 | 1401 | if (BitmapData.FData <> nil) and (BitmapData.FAccessMode in [TAccessMode.ReadWrite, TAccessMode.Read]) then 1402 | begin 1403 | case BitmapData.FBitmap.PixelFormat of 1404 | pfDevice, 1405 | pf1bit, 1406 | pf4bit, 1407 | pf8bit, 1408 | pf15bit, 1409 | pf16bit, 1410 | pfCustom: 1411 | if BitmapData.FHasAlpha then 1412 | ReadDataOpaque(BitmapData) 1413 | else 1414 | ReadData(BitmapData); 1415 | 1416 | pf24bit: 1417 | if BitmapData.FHasAlpha then 1418 | ReadDataBGROpaque(BitmapData) 1419 | else 1420 | ReadDataBGR(BitmapData); 1421 | 1422 | pf32bit: 1423 | if BitmapData.FHasAlpha then 1424 | begin 1425 | if BitmapData.FBitmap.AlphaFormat = afIgnored then 1426 | ReadDataBGRA(BitmapData) 1427 | else 1428 | ReadDataPremultipliedBGRA(BitmapData); 1429 | end 1430 | else 1431 | if Background <> clNone then 1432 | begin 1433 | if BitmapData.FBitmap.AlphaFormat = afIgnored then 1434 | ReadDataBGRA(BitmapData) 1435 | else 1436 | ReadDataPremultipliedBGRA(BitmapData); 1437 | BlendData(BitmapData, Background); 1438 | end else 1439 | ReadDataBGRN(BitmapData); 1440 | end; 1441 | end; 1442 | end; 1443 | 1444 | type 1445 | TOpenBitmap = class(TBitmap); 1446 | 1447 | procedure BitmapDataUnmap(var BitmapData: TBitmapData); 1448 | begin 1449 | try 1450 | if (BitmapData.FData <> nil) and (BitmapData.FAccessMode in [TAccessMode.ReadWrite, TAccessMode.Write]) then 1451 | begin 1452 | if BitmapData.FHasAlpha then 1453 | begin 1454 | if (BitmapData.FBitmap.PixelFormat = pf32bit) and (BitmapData.FBitmap.AlphaFormat = afIgnored) then 1455 | begin 1456 | WriteDataBGRA(BitmapData);// fast way 1457 | end else 1458 | begin 1459 | BitmapData.FBitmap.PixelFormat := pf32bit; 1460 | TOpenBitmap(BitmapData.FBitmap).FAlphaFormat := afPremultiplied; 1461 | WriteDataPremultipliedBGRA(BitmapData); 1462 | end; 1463 | end else 1464 | begin 1465 | BitmapData.FBitmap.PixelFormat := pf24bit; 1466 | WriteDataBGR(BitmapData); 1467 | end; 1468 | 1469 | BitmapData.FBitmap.Modified := True; 1470 | end; 1471 | finally 1472 | Finalize(BitmapData.FDataArray); 1473 | end; 1474 | end; 1475 | {$ENDIF} 1476 | 1477 | { TPixelRec } 1478 | 1479 | constructor TPixelRec.Create(const R, G, B: Byte; const A: Byte); 1480 | begin 1481 | Self.Color := B or (G shl 8) or (R shl 16) or (A shl 24); 1482 | end; 1483 | 1484 | class operator TPixelRec.Implicit(Pixel: TPixel): TPixelRec; 1485 | begin 1486 | Result.Color := Pixel; 1487 | end; 1488 | 1489 | class operator TPixelRec.Implicit(Pixel: TPixelRec): TPixel; 1490 | begin 1491 | Result := Pixel.Color; 1492 | end; 1493 | 1494 | { TBitmapData } 1495 | 1496 | function TBitmapData.GetPixel(X, Y: Integer): TPixel; 1497 | begin 1498 | if (X < 0) or (X >= Self.Width) or (Y < 0) or (Y >= Self.Height) then Exit(0); 1499 | Result := Self.Data[Y * Self.Width + X]; 1500 | end; 1501 | 1502 | procedure TBitmapData.SetPixel(X, Y: Integer; AValue: TPixel); 1503 | begin 1504 | if (X < 0) or (X >= Self.Width) or (Y < 0) or (Y >= Self.Height) then Exit; 1505 | Self.Data[Y * Self.Width + X] := AValue; 1506 | end; 1507 | 1508 | function TBitmapData.GetPixelUnsafe(X, Y: Integer): TPixel; 1509 | begin 1510 | Result := Self.Data[Y * Self.Width + X]; 1511 | end; 1512 | 1513 | procedure TBitmapData.SetPixelUnsafe(X, Y: Integer; AValue: TPixel); 1514 | begin 1515 | Self.Data[Y * Self.Width + X] := AValue; 1516 | end; 1517 | 1518 | procedure TBitmapData.Init(); 1519 | begin 1520 | Self := Default(TBitmapData); 1521 | end; 1522 | 1523 | procedure TBitmapData.Map(const Bitmap: TBitmap; const Mode: TAccessMode; const UseAlpha: Boolean; 1524 | const Background: TColor = clNone); 1525 | begin 1526 | BitmapDataMap(Self, Bitmap, Mode, UseAlpha, Background); 1527 | end; 1528 | 1529 | procedure TBitmapData.Unmap(); 1530 | begin 1531 | BitmapDataUnmap(Self); 1532 | end; 1533 | 1534 | end. 1535 | 1536 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 turborium 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # SortingPixels 2 | 3 | [Powered By Lazarus (ObjectPascal)](https://www.lazarus-ide.org/) 4 | 5 | ![scr](scr.png) 6 | 7 | Powered By Lazarus (ObjectPascal) and [✅GDD Methodology✅](https://github.com/turborium/gdd) 8 | 9 | Compiled EXE(Windows): https://github.com/turborium/SortingPixels/raw/main/SortingPixels.exe 10 | 11 | Inspired by 12 | - https://github.com/kimasendorf/ASDFPixelSort 13 | - https://ashlynsart.wordpress.com/wp-content/uploads/2018/09/art-120-kim-asendorf.pdf 14 | - https://www.youtube.com/watch?v=HMmmBDRy-jE 15 | 16 | Прочие яп в папке "other_langs" 17 | -------------------------------------------------------------------------------- /Res/0.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/Res/0.png -------------------------------------------------------------------------------- /Res/1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/Res/1.png -------------------------------------------------------------------------------- /Res/2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/Res/2.png -------------------------------------------------------------------------------- /Res/3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/Res/3.png -------------------------------------------------------------------------------- /SortingPixels.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/SortingPixels.exe -------------------------------------------------------------------------------- /SortingPixels.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/SortingPixels.ico -------------------------------------------------------------------------------- /SortingPixels.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | <Scaled Value="True"/> 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <XPManifest> 13 | <DpiAware Value="True"/> 14 | </XPManifest> 15 | <Icon Value="0"/> 16 | <Resources Count="15"> 17 | <Resource_0 FileName="samples\0.png" Type="RCDATA" ResourceName="0"/> 18 | <Resource_1 FileName="samples\1.png" Type="RCDATA" ResourceName="1"/> 19 | <Resource_2 FileName="samples\2.png" Type="RCDATA" ResourceName="2"/> 20 | <Resource_3 FileName="samples\3.png" Type="RCDATA" ResourceName="3"/> 21 | <Resource_4 FileName="samples\4.png" Type="RCDATA" ResourceName="4"/> 22 | <Resource_5 FileName="samples\5.png" Type="RCDATA" ResourceName="5"/> 23 | <Resource_6 FileName="samples\6.png" Type="RCDATA" ResourceName="6"/> 24 | <Resource_7 FileName="samples\7.png" Type="RCDATA" ResourceName="7"/> 25 | <Resource_8 FileName="samples\8.png" Type="RCDATA" ResourceName="8"/> 26 | <Resource_9 FileName="samples\9.png" Type="RCDATA" ResourceName="9"/> 27 | <Resource_10 FileName="samples\10.png" Type="RCDATA" ResourceName="10"/> 28 | <Resource_11 FileName="samples\11.png" Type="RCDATA" ResourceName="11"/> 29 | <Resource_12 FileName="samples\12.png" Type="RCDATA" ResourceName="12"/> 30 | <Resource_13 FileName="samples\13.png" Type="RCDATA" ResourceName="13"/> 31 | <Resource_14 FileName="samples\14.png" Type="RCDATA" ResourceName="14"/> 32 | </Resources> 33 | </General> 34 | <BuildModes> 35 | <Item Name="Default" Default="True"/> 36 | <Item Name="Debug"> 37 | <CompilerOptions> 38 | <Version Value="11"/> 39 | <PathDelim Value="\"/> 40 | <Target> 41 | <Filename Value="SortingPixels"/> 42 | </Target> 43 | <SearchPaths> 44 | <IncludeFiles Value="$(ProjOutDir)"/> 45 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 46 | </SearchPaths> 47 | <Parsing> 48 | <SyntaxOptions> 49 | <IncludeAssertionCode Value="True"/> 50 | </SyntaxOptions> 51 | </Parsing> 52 | <CodeGeneration> 53 | <Checks> 54 | <IOChecks Value="True"/> 55 | <RangeChecks Value="True"/> 56 | <OverflowChecks Value="True"/> 57 | <StackChecks Value="True"/> 58 | </Checks> 59 | <VerifyObjMethodCallValidity Value="True"/> 60 | </CodeGeneration> 61 | <Linking> 62 | <Debugging> 63 | <DebugInfoType Value="dsDwarf3"/> 64 | <UseHeaptrc Value="True"/> 65 | <TrashVariables Value="True"/> 66 | <UseExternalDbgSyms Value="True"/> 67 | </Debugging> 68 | <Options> 69 | <Win32> 70 | <GraphicApplication Value="True"/> 71 | </Win32> 72 | </Options> 73 | </Linking> 74 | <Other> 75 | <CompilerMessages> 76 | <IgnoredMessages idx5091="True" idx5024="True" idx4105="True" idx4104="True"/> 77 | </CompilerMessages> 78 | </Other> 79 | </CompilerOptions> 80 | </Item> 81 | <Item Name="Release"> 82 | <CompilerOptions> 83 | <Version Value="11"/> 84 | <PathDelim Value="\"/> 85 | <Target> 86 | <Filename Value="SortingPixels"/> 87 | </Target> 88 | <SearchPaths> 89 | <IncludeFiles Value="$(ProjOutDir)"/> 90 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 91 | </SearchPaths> 92 | <CodeGeneration> 93 | <SmartLinkUnit Value="True"/> 94 | <Optimizations> 95 | <OptimizationLevel Value="3"/> 96 | </Optimizations> 97 | </CodeGeneration> 98 | <Linking> 99 | <Debugging> 100 | <GenerateDebugInfo Value="False"/> 101 | <RunWithoutDebug Value="True"/> 102 | </Debugging> 103 | <LinkSmart Value="True"/> 104 | <Options> 105 | <Win32> 106 | <GraphicApplication Value="True"/> 107 | </Win32> 108 | </Options> 109 | </Linking> 110 | <Other> 111 | <CompilerMessages> 112 | <IgnoredMessages idx5091="True" idx5024="True" idx4105="True" idx4104="True"/> 113 | </CompilerMessages> 114 | </Other> 115 | </CompilerOptions> 116 | </Item> 117 | </BuildModes> 118 | <PublishOptions> 119 | <Version Value="2"/> 120 | <DestinationDirectory Value="C:\Users\error\Documents\sp"/> 121 | <UseFileFilters Value="True"/> 122 | </PublishOptions> 123 | <RunParams> 124 | <FormatVersion Value="2"/> 125 | </RunParams> 126 | <RequiredPackages> 127 | <Item> 128 | <PackageName Value="imagesforlazarus"/> 129 | </Item> 130 | <Item> 131 | <PackageName Value="LCL"/> 132 | </Item> 133 | </RequiredPackages> 134 | <Units> 135 | <Unit> 136 | <Filename Value="SortingPixels.lpr"/> 137 | <IsPartOfProject Value="True"/> 138 | </Unit> 139 | <Unit> 140 | <Filename Value="UnitMain.pas"/> 141 | <IsPartOfProject Value="True"/> 142 | <ComponentName Value="FormMain"/> 143 | <HasResources Value="True"/> 144 | <ResourceBaseClass Value="Form"/> 145 | </Unit> 146 | <Unit> 147 | <Filename Value="BitmapPixels.pas"/> 148 | <IsPartOfProject Value="True"/> 149 | </Unit> 150 | <Unit> 151 | <Filename Value="SortingPixelsAlgorithm.pas"/> 152 | <IsPartOfProject Value="True"/> 153 | </Unit> 154 | </Units> 155 | </ProjectOptions> 156 | <CompilerOptions> 157 | <Version Value="11"/> 158 | <PathDelim Value="\"/> 159 | <Target> 160 | <Filename Value="SortingPixels"/> 161 | </Target> 162 | <SearchPaths> 163 | <IncludeFiles Value="$(ProjOutDir)"/> 164 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 165 | </SearchPaths> 166 | <Linking> 167 | <Debugging> 168 | <DebugInfoType Value="dsDwarf2Set"/> 169 | </Debugging> 170 | <Options> 171 | <Win32> 172 | <GraphicApplication Value="True"/> 173 | </Win32> 174 | </Options> 175 | </Linking> 176 | <Other> 177 | <CompilerMessages> 178 | <IgnoredMessages idx5091="True" idx5024="True" idx4105="True" idx4104="True"/> 179 | </CompilerMessages> 180 | </Other> 181 | </CompilerOptions> 182 | <Debugging> 183 | <Exceptions> 184 | <Item> 185 | <Name Value="EAbort"/> 186 | </Item> 187 | <Item> 188 | <Name Value="ECodetoolError"/> 189 | </Item> 190 | <Item> 191 | <Name Value="EFOpenError"/> 192 | </Item> 193 | </Exceptions> 194 | </Debugging> 195 | </CONFIG> 196 | -------------------------------------------------------------------------------- /SortingPixels.lpr: -------------------------------------------------------------------------------- 1 | program SortingPixels; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX} 7 | cthreads, 8 | {$ENDIF} 9 | {$IFDEF HASAMIGA} 10 | athreads, 11 | {$ENDIF} 12 | Interfaces, // this includes the LCL widgetset 13 | Forms, imagesforlazarus, UnitMain, BitmapPixels, SortingPixelsAlgorithm 14 | { you can add units after this }; 15 | 16 | {$R *.res} 17 | 18 | begin 19 | RequireDerivedFormResource := True; 20 | Application.Scaled := True; 21 | Application.Initialize; 22 | Application.CreateForm(TFormMain, FormMain); 23 | Application.Run; 24 | end. 25 | 26 | -------------------------------------------------------------------------------- /SortingPixelsAlgorithm.pas: -------------------------------------------------------------------------------- 1 | // .d8888b. 8888888b. 8888888b. 888888b. d8888 .d8888b. 8888888888 8888888b. 2 | // d88P Y88b 888 "Y88b 888 "Y88b 888 "88b d88888 d88P Y88b 888 888 "Y88b 3 | // 888 888 888 888 888 888 888 .88P d88P888 Y88b. 888 888 888 4 | // 888 888 888 888 888 8888888K. d88P 888 "Y888b. 8888888 888 888 5 | // 888 88888 888 888 888 888 888 "Y88b d88P 888 "Y88b. 888 888 888 6 | // 888 888 888 888 888 888 888 888 d88P 888 "888 888 888 888 7 | // Y88b d88P 888 .d88P 888 .d88P 888 d88P d8888888888 Y88b d88P 888 888 .d88P 8 | // "Y8888P88 8888888P" 8888888P" 8888888P" d88P 888 "Y8888P" 8888888888 8888888P" 9 | // 10 | // Turborium(c) 2024-2024 11 | 12 | unit SortingPixelsAlgorithm; 13 | 14 | {$MODE DELPHIUNICODE} 15 | {$SCOPEDENUMS ON} 16 | {$DEFINE STABLE} 17 | 18 | interface 19 | 20 | uses 21 | Classes, SysUtils, Generics.Defaults, Generics.Collections, BitmapPixels; 22 | 23 | type 24 | TSortingDirection = (Left, Up, Right, Down); 25 | 26 | procedure ImageSortingPixels(var Data: TBitmapData; Direction: TSortingDirection; ThresholdMin, ThresholdMax: Integer); 27 | 28 | function PixelBrightness(const Pixel: TPixelRec): Byte; inline; 29 | 30 | implementation 31 | 32 | function PixelBrightness(const Pixel: TPixelRec): Byte; 33 | begin 34 | Result := (299 * Pixel.R + 587 * Pixel.G + 114 * Pixel.B) div 1000; 35 | end; 36 | 37 | function CompareUp({$IFDEF STABLE}constref{$ELSE}const{$ENDIF} Left, Right: TPixelRec): Integer; 38 | begin 39 | Result := PixelBrightness(Right) - PixelBrightness(Left); 40 | end; 41 | 42 | function CompareDown({$IFDEF STABLE}constref{$ELSE}const{$ENDIF} Left, Right: TPixelRec): Integer; 43 | begin 44 | Result := PixelBrightness(Left) - PixelBrightness(Right); 45 | end; 46 | 47 | procedure ImageSortingPixels(var Data: TBitmapData; Direction: TSortingDirection; ThresholdMin, ThresholdMax: Integer); 48 | var 49 | X, Y, Brightness: Integer; 50 | Span: TArray<TPixelRec>; 51 | Len, TempX, I, TempY: Integer; 52 | Comparer: IComparer<TPixelRec>; 53 | begin 54 | // создаем компаратор для сортировки по убыванию или возрастанию 55 | if Direction in [TSortingDirection.Left, TSortingDirection.Up] then 56 | Comparer := TComparer<TPixelRec>.Construct(CompareUp) 57 | else 58 | Comparer := TComparer<TPixelRec>.Construct(CompareDown); 59 | 60 | if Direction in [TSortingDirection.Left, TSortingDirection.Right] then 61 | begin 62 | // проходимся по всем строкам изображения 63 | for Y := 0 to Data.Height - 1 do 64 | begin 65 | if TThread.CheckTerminated() then 66 | break; 67 | 68 | // обрабатываем строку в цикле 69 | X := 0; 70 | while X < Data.Width do 71 | begin 72 | // вычисляем длину непрерывного куска строки соответсвующего условиям 73 | Len := 0; 74 | TempX := X; 75 | while TempX < Data.Width do 76 | begin 77 | // даже если первый пиксел не соответсвует условиям, мы получим длину куска в единицу 78 | Len := Len + 1; 79 | 80 | // яркость пиксела 81 | Brightness := PixelBrightness(Data.Pixels[TempX, Y]); 82 | 83 | // не соответсвует усливию - выходим 84 | if Brightness < ThresholdMin then 85 | break; 86 | if Brightness > ThresholdMax then 87 | break; 88 | 89 | // следующий пиксель 90 | TempX := TempX + 1; 91 | end; 92 | 93 | // сортируем пикселы куска, если это имеет смысл 94 | if Len > 1 then 95 | begin 96 | // заполняем массив из изображения 97 | SetLength(Span, Len); 98 | for I := 0 to Len - 1 do 99 | begin 100 | Span[I] := Data.Pixels[X + I, Y]; 101 | end; 102 | 103 | // сортируем 104 | TArrayHelper<TPixelRec>.Sort(Span, Comparer); 105 | 106 | // записываем отсортированные пикселы обратно 107 | for I := 0 to Len - 1 do 108 | begin 109 | Data.Pixels[X + I, Y] := Span[I]; 110 | end; 111 | end; 112 | 113 | // пропускаем уже отсортированные пикселы 114 | X := X + Len; 115 | end; 116 | end; 117 | end else 118 | begin 119 | // проходимся по всем столбцам изображения 120 | for X := 0 to Data.Width - 1 do 121 | begin 122 | if TThread.CheckTerminated() then 123 | break; 124 | 125 | // обрабатываем столбец в цикле 126 | Y := 0; 127 | while Y < Data.Height do 128 | begin 129 | // вычисляем длину непрерывного куска столбца соответсвующего условиям 130 | Len := 0; 131 | TempY := Y; 132 | while TempY < Data.Height do 133 | begin 134 | // даже если первый пиксел не соответсвует условиям, мы получим длину куска в единицу 135 | Len := Len + 1; 136 | 137 | // яркость пиксела 138 | Brightness := PixelBrightness(Data.Pixels[X, TempY]); 139 | 140 | // не соответсвует усливию - выходим 141 | if Brightness < ThresholdMin then 142 | break; 143 | if Brightness > ThresholdMax then 144 | break; 145 | 146 | // следующий пиксель 147 | TempY := TempY + 1; 148 | end; 149 | 150 | // сортируем пикселы куска, если это имеет смысл 151 | if Len > 1 then 152 | begin 153 | // заполняем массив из изображения 154 | SetLength(Span, Len); 155 | for I := 0 to Len - 1 do 156 | begin 157 | Span[I] := Data.Pixels[X, Y + I]; 158 | end; 159 | 160 | // сортируем 161 | TArrayHelper<TPixelRec>.Sort(Span, Comparer); 162 | 163 | // записываем отсортированные пикселы обратно 164 | for I := 0 to Len - 1 do 165 | begin 166 | Data.Pixels[X, Y + I] := Span[I]; 167 | end; 168 | end; 169 | 170 | // пропускаем уже отсортированные пикселы 171 | Y := Y + Len; 172 | end; 173 | end; 174 | end; 175 | end; 176 | 177 | 178 | end. 179 | 180 | -------------------------------------------------------------------------------- /UnitMain.lfm: -------------------------------------------------------------------------------- 1 | object FormMain: TFormMain 2 | Left = 519 3 | Height = 896 4 | Top = 250 5 | Width = 1410 6 | BorderWidth = 4 7 | Caption = 'Sorting Pixels By Turborium' 8 | ClientHeight = 896 9 | ClientWidth = 1410 10 | Constraints.MinHeight = 600 11 | Constraints.MinWidth = 1410 12 | DesignTimePPI = 154 13 | OnCreate = FormCreate 14 | OnDestroy = FormDestroy 15 | Position = poScreenCenter 16 | object ScrollBoxDisp: TScrollBox 17 | Left = 12 18 | Height = 718 19 | Top = 12 20 | Width = 1386 21 | HorzScrollBar.Page = 224 22 | HorzScrollBar.Tracking = True 23 | VertScrollBar.Page = 208 24 | VertScrollBar.Tracking = True 25 | Align = alClient 26 | BorderSpacing.Left = 8 27 | BorderSpacing.Top = 8 28 | BorderSpacing.Right = 8 29 | ClientHeight = 714 30 | ClientWidth = 1382 31 | TabOrder = 0 32 | object ImageDisp: TImage 33 | AnchorSideLeft.Control = ScrollBoxDisp 34 | AnchorSideTop.Control = ScrollBoxDisp 35 | Left = 0 36 | Height = 208 37 | Top = 0 38 | Width = 224 39 | end 40 | end 41 | object PanelParams: TPanel 42 | Left = 12 43 | Height = 146 44 | Top = 738 45 | Width = 1386 46 | Align = alBottom 47 | AutoSize = True 48 | BorderSpacing.Left = 8 49 | BorderSpacing.Top = 8 50 | BorderSpacing.Right = 8 51 | BorderSpacing.Bottom = 8 52 | BevelOuter = bvNone 53 | ChildSizing.Layout = cclTopToBottomThenLeftToRight 54 | ClientHeight = 146 55 | ClientWidth = 1386 56 | TabOrder = 1 57 | OnResize = PanelParamsResize 58 | object PanelFile: TPanel 59 | Left = 0 60 | Height = 146 61 | Top = 0 62 | Width = 143 63 | AutoSize = True 64 | BevelOuter = bvNone 65 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 66 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 67 | ClientHeight = 146 68 | ClientWidth = 143 69 | TabOrder = 0 70 | object ButtonOpen: TButton 71 | Left = 0 72 | Height = 39 73 | Top = 6 74 | Width = 143 75 | AutoSize = True 76 | BorderSpacing.InnerBorder = 2 77 | Caption = 'Open' 78 | TabOrder = 0 79 | OnClick = ButtonOpenClick 80 | end 81 | object ButtonOpenSample: TButton 82 | Left = 0 83 | Height = 39 84 | Top = 51 85 | Width = 143 86 | AutoSize = True 87 | BorderSpacing.Top = 4 88 | BorderSpacing.InnerBorder = 2 89 | Caption = 'Open Sample' 90 | TabOrder = 1 91 | OnClick = ButtonOpenSampleClick 92 | end 93 | object ButtonSave: TButton 94 | Left = 0 95 | Height = 39 96 | Top = 96 97 | Width = 143 98 | AutoSize = True 99 | BorderSpacing.Top = 4 100 | BorderSpacing.InnerBorder = 2 101 | Caption = 'Save' 102 | TabOrder = 2 103 | OnClick = ButtonSaveClick 104 | end 105 | end 106 | object GroupBoxTrashhold: TGroupBox 107 | Left = 159 108 | Height = 146 109 | Top = 0 110 | Width = 402 111 | BorderSpacing.Left = 16 112 | Caption = 'Treshold' 113 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 114 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 115 | ChildSizing.ControlsPerLine = 3 116 | ClientHeight = 116 117 | ClientWidth = 398 118 | TabOrder = 1 119 | object LabelThresholdMinCaption: TLabel 120 | Left = 4 121 | Height = 40 122 | Top = 11 123 | Width = 50 124 | BorderSpacing.Left = 4 125 | Caption = 'Min:' 126 | Constraints.MinWidth = 50 127 | Layout = tlCenter 128 | end 129 | object TrackBarThresholdMin: TTrackBar 130 | AnchorSideLeft.Side = asrBottom 131 | Left = 54 132 | Height = 40 133 | Top = 11 134 | Width = 300 135 | AutoSize = True 136 | Frequency = 16 137 | Max = 255 138 | OnChange = TrackBarThresholdMinChange 139 | PageSize = 1 140 | Position = 0 141 | ShowSelRange = False 142 | BorderSpacing.Right = 4 143 | Constraints.MinWidth = 300 144 | TabOrder = 0 145 | end 146 | object LabelThresholdMin: TLabel 147 | Left = 358 148 | Height = 40 149 | Top = 11 150 | Width = 40 151 | Caption = '255' 152 | Constraints.MaxWidth = 40 153 | Constraints.MinWidth = 40 154 | Layout = tlCenter 155 | end 156 | object LabelThresholdMaxCaption: TLabel 157 | Left = 4 158 | Height = 40 159 | Top = 62 160 | Width = 50 161 | BorderSpacing.Left = 4 162 | BorderSpacing.Top = 4 163 | Caption = 'Max:' 164 | Constraints.MinWidth = 50 165 | Layout = tlCenter 166 | end 167 | object TrackBarThresholdMax: TTrackBar 168 | AnchorSideLeft.Side = asrBottom 169 | Left = 54 170 | Height = 40 171 | Top = 62 172 | Width = 300 173 | AutoSize = True 174 | Frequency = 16 175 | Max = 255 176 | OnChange = TrackBarThresholdMaxChange 177 | PageSize = 1 178 | Position = 255 179 | ShowSelRange = False 180 | BorderSpacing.Top = 4 181 | BorderSpacing.Right = 4 182 | Constraints.MinWidth = 300 183 | TabOrder = 1 184 | end 185 | object LabelThresholdMax: TLabel 186 | Left = 358 187 | Height = 40 188 | Top = 62 189 | Width = 40 190 | Caption = '255' 191 | Constraints.MaxWidth = 40 192 | Constraints.MinWidth = 40 193 | Layout = tlCenter 194 | end 195 | end 196 | object GroupBoxSortDirection: TGroupBox 197 | Left = 565 198 | Height = 146 199 | Top = 0 200 | Width = 324 201 | BorderSpacing.Left = 4 202 | Caption = 'Sort Direction' 203 | ChildSizing.EnlargeHorizontal = crsHomogenousSpaceResize 204 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 205 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 206 | ClientHeight = 116 207 | ClientWidth = 320 208 | TabOrder = 2 209 | object PanelSortDirection: TPanel 210 | Left = 4 211 | Height = 105 212 | Top = 6 213 | Width = 312 214 | AutoSize = True 215 | BorderSpacing.Left = 4 216 | BorderSpacing.Right = 4 217 | BevelOuter = bvNone 218 | ClientHeight = 105 219 | ClientWidth = 312 220 | TabOrder = 0 221 | object BitBtnUp: TBitBtn 222 | AnchorSideLeft.Control = BitBtnLeft 223 | AnchorSideLeft.Side = asrBottom 224 | AnchorSideTop.Control = PanelSortDirection 225 | Left = 104 226 | Height = 35 227 | Top = 0 228 | Width = 104 229 | AutoSize = True 230 | Caption = 'Up' 231 | Constraints.MaxWidth = 104 232 | Constraints.MinWidth = 104 233 | Margin = 4 234 | Images = ImageListSortDirection 235 | ImageIndex = 1 236 | OnClick = BitBtnUpClick 237 | TabOrder = 1 238 | end 239 | object BitBtnDown: TBitBtn 240 | AnchorSideLeft.Control = BitBtnLeft 241 | AnchorSideLeft.Side = asrBottom 242 | AnchorSideTop.Control = BitBtnLeft 243 | AnchorSideTop.Side = asrBottom 244 | Left = 104 245 | Height = 35 246 | Top = 70 247 | Width = 104 248 | AutoSize = True 249 | Caption = 'Down' 250 | Constraints.MaxWidth = 104 251 | Constraints.MinWidth = 104 252 | Margin = 4 253 | Images = ImageListSortDirection 254 | ImageIndex = 3 255 | OnClick = BitBtnDownClick 256 | TabOrder = 3 257 | end 258 | object BitBtnRight: TBitBtn 259 | AnchorSideLeft.Control = BitBtnUp 260 | AnchorSideLeft.Side = asrBottom 261 | AnchorSideTop.Control = BitBtnUp 262 | AnchorSideTop.Side = asrBottom 263 | Left = 208 264 | Height = 35 265 | Top = 35 266 | Width = 104 267 | AutoSize = True 268 | Caption = 'Right' 269 | Constraints.MaxWidth = 104 270 | Constraints.MinWidth = 104 271 | Margin = 4 272 | Images = ImageListSortDirection 273 | ImageIndex = 2 274 | OnClick = BitBtnRightClick 275 | TabOrder = 2 276 | end 277 | object BitBtnLeft: TBitBtn 278 | AnchorSideLeft.Control = PanelSortDirection 279 | AnchorSideTop.Control = BitBtnUp 280 | AnchorSideTop.Side = asrBottom 281 | Left = 0 282 | Height = 35 283 | Top = 35 284 | Width = 104 285 | AutoSize = True 286 | Caption = 'Left' 287 | Constraints.MaxWidth = 104 288 | Constraints.MinWidth = 104 289 | Margin = 4 290 | Images = ImageListSortDirection 291 | ImageIndex = 0 292 | OnClick = BitBtnLeftClick 293 | TabOrder = 0 294 | end 295 | end 296 | end 297 | object GroupBoxImageScale: TGroupBox 298 | Left = 893 299 | Height = 146 300 | Top = 0 301 | Width = 212 302 | AutoSize = True 303 | BorderSpacing.Left = 4 304 | Caption = 'Image Scale' 305 | ChildSizing.EnlargeHorizontal = crsHomogenousSpaceResize 306 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 307 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 308 | ClientHeight = 116 309 | ClientWidth = 208 310 | TabOrder = 3 311 | object TrackBarImageScale: TTrackBar 312 | Left = 4 313 | Height = 40 314 | Top = 17 315 | Width = 200 316 | Frequency = 10 317 | Max = 100 318 | Min = 1 319 | OnChange = TrackBarImageScaleChange 320 | Position = 10 321 | ShowSelRange = False 322 | BorderSpacing.Left = 4 323 | BorderSpacing.Right = 4 324 | Constraints.MinWidth = 200 325 | TabOrder = 0 326 | end 327 | object LabelScale: TLabel 328 | Left = 4 329 | Height = 25 330 | Top = 74 331 | Width = 200 332 | Alignment = taCenter 333 | Caption = 'LabelScale' 334 | end 335 | end 336 | object RadioGroupViewScale: TRadioGroup 337 | Left = 1121 338 | Height = 146 339 | Top = 0 340 | Width = 109 341 | AutoFill = True 342 | BorderSpacing.Left = 16 343 | Caption = 'View Scale' 344 | ChildSizing.LeftRightSpacing = 6 345 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize 346 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 347 | ChildSizing.ShrinkHorizontal = crsScaleChilds 348 | ChildSizing.ShrinkVertical = crsScaleChilds 349 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 350 | ChildSizing.ControlsPerLine = 1 351 | ClientHeight = 116 352 | ClientWidth = 105 353 | Items.Strings = ( 354 | '1x' 355 | '2x' 356 | '3x' 357 | '4x' 358 | ) 359 | OnClick = RadioGroupViewScaleClick 360 | TabOrder = 4 361 | end 362 | object RadioGroupSaveScale: TRadioGroup 363 | Left = 1234 364 | Height = 146 365 | Top = 0 366 | Width = 107 367 | AutoFill = True 368 | AutoSize = True 369 | BorderSpacing.Left = 4 370 | Caption = 'Save Scale' 371 | ChildSizing.LeftRightSpacing = 6 372 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize 373 | ChildSizing.EnlargeVertical = crsHomogenousChildResize 374 | ChildSizing.ShrinkHorizontal = crsScaleChilds 375 | ChildSizing.ShrinkVertical = crsScaleChilds 376 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 377 | ChildSizing.ControlsPerLine = 1 378 | ClientHeight = 116 379 | ClientWidth = 103 380 | Items.Strings = ( 381 | '1x' 382 | '2x' 383 | '3x' 384 | '4x' 385 | ) 386 | OnClick = RadioGroupSaveScaleClick 387 | TabOrder = 5 388 | end 389 | object GroupBoxAutoShow: TGroupBox 390 | Left = 1345 391 | Height = 146 392 | Top = 0 393 | Width = 258 394 | BorderSpacing.Left = 4 395 | Caption = 'Auto Show' 396 | ChildSizing.EnlargeVertical = crsHomogenousSpaceResize 397 | ChildSizing.Layout = cclLeftToRightThenTopToBottom 398 | ClientHeight = 116 399 | ClientWidth = 254 400 | TabOrder = 6 401 | object PanelAutoShow: TPanel 402 | Left = 2 403 | Height = 109 404 | Top = 4 405 | Width = 250 406 | AutoSize = True 407 | BorderSpacing.Left = 2 408 | BorderSpacing.Right = 2 409 | BevelOuter = bvNone 410 | ClientHeight = 109 411 | ClientWidth = 250 412 | TabOrder = 0 413 | object CheckBoxAutoShowEnabled: TCheckBox 414 | AnchorSideLeft.Control = PanelAutoShow 415 | AnchorSideTop.Control = PanelAutoShow 416 | Left = 0 417 | Height = 29 418 | Top = 0 419 | Width = 66 420 | Caption = 'Auto' 421 | TabOrder = 0 422 | OnChange = CheckBoxAutoShowEnabledChange 423 | end 424 | object LabelAutoShowMinRange: TLabel 425 | AnchorSideLeft.Control = PanelAutoShow 426 | AnchorSideTop.Control = TrackBarAutoShowTresholdMin 427 | AnchorSideTop.Side = asrCenter 428 | Left = 0 429 | Height = 25 430 | Top = 38 431 | Width = 50 432 | BorderSpacing.Top = 2 433 | Caption = 'Min:' 434 | Constraints.MaxWidth = 50 435 | Constraints.MinWidth = 50 436 | end 437 | object TrackBarAutoShowTresholdMin: TTrackBar 438 | AnchorSideLeft.Control = LabelAutoShowMinRange 439 | AnchorSideLeft.Side = asrBottom 440 | AnchorSideTop.Control = CheckBoxAutoShowEnabled 441 | AnchorSideTop.Side = asrBottom 442 | Left = 50 443 | Height = 38 444 | Top = 31 445 | Width = 200 446 | Frequency = 16 447 | Max = 255 448 | OnChange = TrackBarAutoShowTresholdMinChange 449 | PageSize = 1 450 | Position = 0 451 | ShowSelRange = False 452 | BorderSpacing.Top = 2 453 | Constraints.MaxHeight = 38 454 | Constraints.MinWidth = 200 455 | TabOrder = 1 456 | end 457 | object LabelAutoShowMaxRange: TLabel 458 | AnchorSideLeft.Control = PanelAutoShow 459 | AnchorSideTop.Control = TrackBarAutoShowTresholdMax 460 | AnchorSideTop.Side = asrCenter 461 | Left = 0 462 | Height = 25 463 | Top = 78 464 | Width = 50 465 | Caption = 'Max:' 466 | Constraints.MaxWidth = 50 467 | Constraints.MinWidth = 50 468 | end 469 | object TrackBarAutoShowTresholdMax: TTrackBar 470 | AnchorSideLeft.Control = LabelAutoShowMaxRange 471 | AnchorSideLeft.Side = asrBottom 472 | AnchorSideTop.Control = TrackBarAutoShowTresholdMin 473 | AnchorSideTop.Side = asrBottom 474 | Left = 50 475 | Height = 38 476 | Top = 71 477 | Width = 200 478 | Frequency = 16 479 | Max = 255 480 | OnChange = TrackBarAutoShowTresholdMaxChange 481 | PageSize = 1 482 | Position = 0 483 | ShowSelRange = False 484 | BorderSpacing.Top = 2 485 | Constraints.MaxHeight = 38 486 | Constraints.MinWidth = 200 487 | TabOrder = 2 488 | end 489 | end 490 | end 491 | end 492 | object PopupMenuSample: TPopupMenu 493 | Images = ImageListSample 494 | Left = 424 495 | Top = 368 496 | end 497 | object ImageListSortDirection: TImageList 498 | Scaled = True 499 | Left = 160 500 | Top = 368 501 | Bitmap = { 502 | 4C7A040000001000000010000000CC0000000000000078DAED96311180301004 503 | 3B242001094888042C2021169080845840021290808454C7AC86AD9849B1E543 504 | F27F97BFDE7BDEF7CDF33CB9EF3BD775A5B596F33C731C476AADD9F73DDBB6A5 505 | 9492755DB32C4BE679CE344DE9A37ED48FFA5FD71BF8B781731BB8B3817E19E8 506 | B581391998B1017D18D096015D1AD0B4013F18F092011F1AF0B085EF7016EE43 507 | 4FE82BB361BE68049DA155F48E67F01DDEC5FFA37ED48FFA7FD7DBB7C360DF4F 508 | FB7EDBFD61F797DD9F767FDBFC60F38BCD4F36BFD9FC68F3ABCDCF36BF7FB890 509 | F5C8 510 | } 511 | BitmapAdv = { 512 | 4C69020000004C7A040000001800000018000000680100000000000078DAEDD9 513 | 2D0F82601405E04EA441331369D234190D4446B2102934379A8548A049A41049 514 | D8B419CD346C44F27187FF7036C30DCF6C67EEE5BD1FE2BAAE589605DFEF179F 515 | CF07EFF71BAFD70BCFE713C330A0EB3AB46D8BBAAE71BBDD509625F23CC7E572 516 | 419AA6389FCF381E8F381C0E88A208611862B7DBC1F77DB8AE8BD5F22DDFF22D 517 | DFF22DDFF22DFF0FF395F8DD95782E4A3C73253E4F25DE1525DE4325DE7125D6 518 | 8F126B538975AFC49EA2C47EA5C45EA8C43EABC41EAEC4F9A0C4D9A3C4B9A6C4 519 | 99A9C479ACC459AFC43D42893B8A92E338DBA7E7790882603BB3FD7EBF3D9BD3 520 | E984388E912409B22C435114B85EAFA8AA0A4DD3E07EBFA3EF7B8CE388C7E3B1 521 | CD2BCEDC699A30CFF3B69F58BEE55BBEE55BBEE55BBEE5FF63BE927A7FE3B928 522 | F1CC95D4FB3FEF8A92FAF711EFB812EB4789B5A9C4BA57624F5162BF52622F54 523 | 629F55620F57E27C50E2EC51E25C5352BFDF56BFFFE7AC57E21EA1A4FEFFE807 524 | 2988691B4C7A040000002000000020000000FE0100000000000078DAEDD7B1AB 525 | 81611805F0F59649168345596E99A464609041168345268345599445D9944559 526 | 9445996452261964609092495994C560914919CFEDFC13F72C67F8CDA7EFFBDE 527 | EF799FF3F97CF0FD7EF1783CF07C3E71B95C70BD5EB1DFEF71381C703C1EB15A 528 | ADB05EAF319BCD309FCF311A8D301E8FD1EBF5D0EFF7D16AB5D06EB751ABD550 529 | AFD7512A95502E9791CD6691CBE590CFE7914824904C26118D46118BC5100C06 530 | 110A85F071BEF39DEF7CE73BDFF9CE77BEF39DEF7CE73BDFF9FF92AFC46757E2 531 | 7B57E23757E27953E25957E27FA6C47F5C89F34589B34D89735589335D89F789 532 | 12EF3225DEA34ABCC395B83F28717751E2DEA4C49D4D89FBA212775525EEC94A 533 | DCD195D80F94D84D94D88B94D8C994D80795D84595D88395D8C1950281007E7E 534 | 7E108944100E87118FC7F1FBFB8B4C2683743A8D542A8562B18842A1806AB58A 535 | 4AA58266B38946A3816EB78B4EA783E17088C16080E9748AC96482E57289C562 536 | 81DD6E87ED768BCD6683F3F98CD3E984FBFD8EDBED86F7FB8DD7EBE57CE73BDF 537 | F9CE77BEF39DEF7CE73BDFF9CE77BEF3FF295F89CFAEC4F7AEC46FAEC4F3A6C4 538 | B3AEC4FF4C89FFB812E78B12679B12E7AA1267BA12EF1325DE654ABC47957887 539 | 2B717F50E2EEA2C4BD49893B9B12F74525EEAA4ADC9395B8A32BB11F28B19B28 540 | B11729B19329B10F2AB18B2AB1072BB1832BFD01D72DD74A 541 | } 542 | end 543 | object ImageListSample: TImageList 544 | Height = 50 545 | Width = 50 546 | Left = 600 547 | Top = 368 548 | end 549 | object OpenPictureDialog: TOpenPictureDialog 550 | Title = 'Open Existing File' 551 | Options = [ofPathMustExist, ofEnableSizing, ofViewDetail] 552 | Left = 360 553 | Top = 168 554 | end 555 | object SavePictureDialog: TSavePictureDialog 556 | Title = 'Save File As' 557 | DefaultExt = '.png' 558 | FileName = 'Unnamed' 559 | FilterIndex = 2 560 | Options = [ofOverwritePrompt, ofEnableSizing, ofViewDetail] 561 | Left = 584 562 | Top = 168 563 | end 564 | object TimerAutoShow: TTimer 565 | Interval = 60 566 | OnTimer = TimerAutoShowTimer 567 | Left = 832 568 | Top = 367 569 | end 570 | end 571 | -------------------------------------------------------------------------------- /UnitMain.pas: -------------------------------------------------------------------------------- 1 | // .d8888b. 8888888b. 8888888b. 888888b. d8888 .d8888b. 8888888888 8888888b. 2 | // d88P Y88b 888 "Y88b 888 "Y88b 888 "88b d88888 d88P Y88b 888 888 "Y88b 3 | // 888 888 888 888 888 888 888 .88P d88P888 Y88b. 888 888 888 4 | // 888 888 888 888 888 8888888K. d88P 888 "Y888b. 8888888 888 888 5 | // 888 88888 888 888 888 888 888 "Y88b d88P 888 "Y88b. 888 888 888 6 | // 888 888 888 888 888 888 888 888 d88P 888 "888 888 888 888 7 | // Y88b d88P 888 .d88P 888 .d88P 888 d88P d8888888888 Y88b d88P 888 888 .d88P 8 | // "Y8888P88 8888888P" 8888888P" 8888888P" d88P 888 "Y8888P" 8888888888 8888888P" 9 | // 10 | // Turborium(c) 2024-2024 11 | 12 | unit UnitMain; 13 | 14 | {$mode delphiunicode} 15 | 16 | interface 17 | 18 | uses 19 | Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, ComCtrls, 20 | StdCtrls, Menus, Buttons, ExtDlgs, Math, LazPNG, 21 | Generics.Defaults, BitmapPixels, SortingPixelsAlgorithm; 22 | 23 | type 24 | 25 | { TSortThread } 26 | 27 | TSortThread = class(TThread) 28 | private 29 | FBitmap: TBitmap; 30 | FThresholdMax: Integer; 31 | FThresholdMin: Integer; 32 | FSortingDirection: TSortingDirection; 33 | protected 34 | procedure Execute(); override; 35 | public 36 | constructor Create(); 37 | destructor Destroy(); override; 38 | 39 | property Bitmap: TBitmap read FBitmap; 40 | property SortingDirection: TSortingDirection read FSortingDirection write FSortingDirection; 41 | property ThresholdMin: Integer read FThresholdMin write FThresholdMin; 42 | property ThresholdBright: Integer read FThresholdMax write FThresholdMax; 43 | end; 44 | 45 | { TFormMain } 46 | 47 | TFormMain = class(TForm) 48 | BitBtnDown: TBitBtn; 49 | BitBtnLeft: TBitBtn; 50 | BitBtnRight: TBitBtn; 51 | BitBtnUp: TBitBtn; 52 | ButtonOpen: TButton; 53 | ButtonOpenSample: TButton; 54 | ButtonSave: TButton; 55 | CheckBoxAutoShowEnabled: TCheckBox; 56 | GroupBoxAutoShow: TGroupBox; 57 | GroupBoxImageScale: TGroupBox; 58 | GroupBoxSortDirection: TGroupBox; 59 | GroupBoxTrashhold: TGroupBox; 60 | ImageDisp: TImage; 61 | ImageListSample: TImageList; 62 | ImageListSortDirection: TImageList; 63 | LabelAutoShowMaxRange: TLabel; 64 | LabelAutoShowMinRange: TLabel; 65 | LabelThresholdMin: TLabel; 66 | LabelThresholdMax: TLabel; 67 | LabelThresholdMaxCaption: TLabel; 68 | LabelThresholdMinCaption: TLabel; 69 | LabelScale: TLabel; 70 | OpenPictureDialog: TOpenPictureDialog; 71 | PanelAutoShow: TPanel; 72 | PanelParams: TPanel; 73 | PanelFile: TPanel; 74 | PanelSortDirection: TPanel; 75 | PopupMenuSample: TPopupMenu; 76 | RadioGroupSaveScale: TRadioGroup; 77 | RadioGroupViewScale: TRadioGroup; 78 | SavePictureDialog: TSavePictureDialog; 79 | ScrollBoxDisp: TScrollBox; 80 | TimerAutoShow: TTimer; 81 | TrackBarAutoShowTresholdMin: TTrackBar; 82 | TrackBarAutoShowTresholdMax: TTrackBar; 83 | TrackBarThresholdMin: TTrackBar; 84 | TrackBarThresholdMax: TTrackBar; 85 | TrackBarImageScale: TTrackBar; 86 | procedure BitBtnDownClick(Sender: TObject); 87 | procedure BitBtnLeftClick(Sender: TObject); 88 | procedure BitBtnRightClick(Sender: TObject); 89 | procedure BitBtnUpClick(Sender: TObject); 90 | procedure ButtonOpenClick(Sender: TObject); 91 | procedure ButtonOpenSampleClick(Sender: TObject); 92 | procedure ButtonSaveClick(Sender: TObject); 93 | procedure CheckBoxAutoShowEnabledChange(Sender: TObject); 94 | procedure FormCreate(Sender: TObject); 95 | procedure FormDestroy(Sender: TObject); 96 | procedure PanelParamsResize(Sender: TObject); 97 | procedure RadioGroupSaveScaleClick(Sender: TObject); 98 | procedure RadioGroupViewScaleClick(Sender: TObject); 99 | procedure LoadSampleToBitmap(var Bitmap: TBitmap; Index: Integer); 100 | procedure TimerAutoShowTimer(Sender: TObject); 101 | procedure TrackBarAutoShowTresholdMaxChange(Sender: TObject); 102 | procedure TrackBarAutoShowTresholdMinChange(Sender: TObject); 103 | procedure TrackBarImageScaleChange(Sender: TObject); 104 | procedure TrackBarThresholdMaxChange(Sender: TObject); 105 | procedure TrackBarThresholdMinChange(Sender: TObject); 106 | private 107 | FRawSource: TBitmap; 108 | FSource: TBitmap; 109 | FDestination: TBitmap; 110 | 111 | FViewScale: Integer; 112 | FImageScale: Integer; 113 | FSortingDirection: TSortingDirection; 114 | FTresholdMax: Integer; 115 | FTresholdMin: Integer; 116 | FSaveScale: Integer; 117 | 118 | FSortThread: TSortThread; 119 | FIsNeedUpdate: Boolean; 120 | 121 | FAutoShowEnabled: Boolean; 122 | FAutoShowRangeMin: Integer; 123 | FAutoShowRangeMax: Integer; 124 | FAutoShowDeltaMin: Double; 125 | FAutoShowDeltaMax: Double; 126 | FAutoShowTresholdMax: Double; 127 | FAutoShowTresholdMin: Double; 128 | 129 | procedure Idle(Sender: TObject; var Done: Boolean); 130 | procedure LoadSample(Index: Integer); 131 | procedure PopupSampleClick(Sender: TObject); 132 | procedure SortThreadTerminate(Sender: TObject); 133 | procedure UpdateSource(); 134 | procedure UpdateRawSource(); 135 | procedure UpdateUI(); 136 | procedure NeedUpdate(); 137 | public 138 | constructor Create(AOwner: TComponent); override; 139 | destructor Destroy(); override; 140 | end; 141 | 142 | var 143 | FormMain: TFormMain; 144 | 145 | implementation 146 | 147 | {$R *.lfm} 148 | 149 | const 150 | SampleCount = 15; 151 | MaxSourceSize = 3000; 152 | 153 | { TSortThread } 154 | 155 | constructor TSortThread.Create(); 156 | begin 157 | inherited Create(True); 158 | 159 | FBitmap := TBitmap.Create(); 160 | end; 161 | 162 | destructor TSortThread.Destroy(); 163 | begin 164 | FBitmap.Free(); 165 | 166 | inherited Destroy(); 167 | end; 168 | 169 | procedure TSortThread.Execute(); 170 | var 171 | Data: TBitmapData; 172 | begin 173 | Data.Map(FBitmap, TAccessMode.ReadWrite, False); 174 | try 175 | ImageSortingPixels(Data, FSortingDirection, FThresholdMin, FThresholdMax); 176 | finally 177 | Data.Unmap(); 178 | end; 179 | end; 180 | 181 | { TFormMain } 182 | 183 | constructor TFormMain.Create(AOwner: TComponent); 184 | begin 185 | inherited Create(AOwner); 186 | 187 | FormatSettings.DecimalSeparator := '.'; 188 | FSource := TBitmap.Create(); 189 | FRawSource := TBitmap.Create(); 190 | FDestination := TBitmap.Create(); 191 | 192 | // defaults 193 | Randomize(); 194 | FTresholdMax := 255; 195 | FTresholdMin := 0; 196 | FViewScale := 1; 197 | FImageScale := 100; 198 | FSaveScale := 3; 199 | FSortingDirection := TSortingDirection.Up; 200 | FAutoShowRangeMin := 0 + 100; 201 | FAutoShowRangeMax := 255 - 100; 202 | FAutoShowEnabled := False; 203 | end; 204 | 205 | destructor TFormMain.Destroy(); 206 | begin 207 | FSource.Free(); 208 | FRawSource.Free(); 209 | FDestination.Free(); 210 | 211 | inherited Destroy(); 212 | end; 213 | 214 | procedure TFormMain.FormCreate(Sender: TObject); 215 | begin 216 | Application.AddOnIdleHandler(Idle, True); 217 | 218 | // load random sample 219 | LoadSample(Random(SampleCount)); 220 | end; 221 | 222 | procedure TFormMain.FormDestroy(Sender: TObject); 223 | begin 224 | Application.RemoveOnIdleHandler(Idle); 225 | 226 | if FSortThread <> nil then 227 | FSortThread.WaitFor(); 228 | end; 229 | 230 | procedure TFormMain.PanelParamsResize(Sender: TObject); 231 | begin 232 | GroupBoxAutoShow.Visible := GroupBoxAutoShow.Left + GroupBoxAutoShow.Width <= PanelParams.ClientWidth; 233 | end; 234 | 235 | procedure TFormMain.RadioGroupSaveScaleClick(Sender: TObject); 236 | begin 237 | FSaveScale := RadioGroupSaveScale.ItemIndex + 1; 238 | 239 | NeedUpdate(); 240 | end; 241 | 242 | procedure TFormMain.SortThreadTerminate(Sender: TObject); 243 | begin 244 | // copy pixels 245 | FDestination.LoadFromRawImage(FSortThread.Bitmap.RawImage, False); 246 | 247 | ImageDisp.Picture.Assign(FDestination); 248 | ImageDisp.Width := ImageDisp.Picture.Width * FViewScale; 249 | ImageDisp.Height := ImageDisp.Picture.Height * FViewScale; 250 | ImageDisp.Stretch := True; 251 | ImageDisp.Repaint; 252 | 253 | FSortThread := nil; 254 | end; 255 | 256 | procedure TFormMain.Idle(Sender: TObject; var Done: Boolean); 257 | begin 258 | if FIsNeedUpdate then 259 | begin 260 | // если потока нет - создаем и сбрасываем флаг необходимости обновления 261 | if FSortThread = nil then 262 | begin 263 | FSortThread := TSortThread.Create(); 264 | FSortThread.FreeOnTerminate := True; 265 | FSortThread.OnTerminate := SortThreadTerminate; 266 | 267 | // copy pixels 268 | FSortThread.Bitmap.LoadFromRawImage(FSource.RawImage, False); 269 | 270 | FSortThread.SortingDirection := FSortingDirection; 271 | FSortThread.ThresholdMin := FTresholdMin; 272 | FSortThread.ThresholdBright := FTresholdMax; 273 | 274 | FSortThread.Start(); 275 | 276 | FIsNeedUpdate := False; 277 | end; 278 | end; 279 | end; 280 | 281 | procedure TFormMain.RadioGroupViewScaleClick(Sender: TObject); 282 | begin 283 | FViewScale := RadioGroupViewScale.ItemIndex + 1; 284 | 285 | NeedUpdate(); 286 | end; 287 | 288 | procedure TFormMain.PopupSampleClick(Sender: TObject); 289 | begin 290 | LoadSample(TMenuItem(Sender).Tag); 291 | end; 292 | 293 | procedure TFormMain.ButtonOpenSampleClick(Sender: TObject); 294 | var 295 | Item: TMenuItem; 296 | I: Integer; 297 | Bitmap: TBitmap; 298 | PopupPoint: TPoint; 299 | begin 300 | // delay loading 301 | if PopupMenuSample.Items.Count = 0 then 302 | begin 303 | Screen.BeginWaitCursor(); 304 | try 305 | // load images 306 | for I := 0 to SampleCount - 1 do 307 | begin 308 | Bitmap := TBitmap.Create(); 309 | try 310 | LoadSampleToBitmap(Bitmap, I); 311 | ImageListSample.Add(Bitmap, nil); 312 | finally 313 | Bitmap.Free(); 314 | end; 315 | end; 316 | // make items 317 | for I := 0 to SampleCount - 1 do 318 | begin 319 | Item := TMenuItem.Create(Self); 320 | Item.Caption := 'Sample ' + IntToStr(I); 321 | Item.ImageIndex := I; 322 | Item.OnClick := PopupSampleClick; 323 | Item.Tag := I; 324 | PopupMenuSample.Items.Add(Item); 325 | end; 326 | finally 327 | Screen.EndWaitCursor(); 328 | end; 329 | end; 330 | 331 | // popup 332 | PopupPoint := ButtonOpenSample.ClientToScreen(Point(ButtonOpenSample.Width, ButtonOpenSample.Height)); 333 | PopupMenuSample.PopUp(PopupPoint.X, PopupPoint.Y); 334 | end; 335 | 336 | procedure TFormMain.ButtonSaveClick(Sender: TObject); 337 | var 338 | Picture: TPicture; 339 | begin 340 | if FSortThread <> nil then 341 | FSortThread.WaitFor(); 342 | 343 | if SavePictureDialog.Execute then 344 | begin 345 | Picture := TPicture.Create(); 346 | try 347 | Picture.Bitmap.SetSize(FDestination.Width * FSaveScale, FDestination.Height * FSaveScale); 348 | Picture.Bitmap.Canvas.AntialiasingMode := amOff; 349 | Picture.Bitmap.Canvas.StretchDraw(Rect(0, 0, Picture.Bitmap.Width, Picture.Bitmap.Height), FDestination); 350 | 351 | // jpeg quality fix 352 | if TPicture.FindGraphicClassWithFileExt(ExtractFileExt(SavePictureDialog.FileName)) = TJPEGImage then 353 | Picture.Jpeg.CompressionQuality := 95; 354 | 355 | Picture.SaveToFile(SavePictureDialog.FileName); 356 | finally 357 | Picture.Free(); 358 | end; 359 | end; 360 | 361 | NeedUpdate(); 362 | end; 363 | 364 | procedure TFormMain.CheckBoxAutoShowEnabledChange(Sender: TObject); 365 | begin 366 | FAutoShowEnabled := CheckBoxAutoShowEnabled.Checked; 367 | 368 | NeedUpdate(); 369 | end; 370 | 371 | procedure TFormMain.BitBtnUpClick(Sender: TObject); 372 | begin 373 | FSortingDirection := TSortingDirection.Up; 374 | 375 | NeedUpdate(); 376 | end; 377 | 378 | procedure TFormMain.ButtonOpenClick(Sender: TObject); 379 | var 380 | Picture: TPicture; 381 | begin 382 | if OpenPictureDialog.Execute then 383 | begin 384 | Picture := TPicture.Create(); 385 | try 386 | Picture.LoadFromFile(OpenPictureDialog.FileName); 387 | FRawSource.Assign(Picture.Graphic); 388 | finally 389 | Picture.Free(); 390 | end; 391 | 392 | SavePictureDialog.FileName := ChangeFileExt(ExtractFileName(OpenPictureDialog.FileName), ''); 393 | 394 | UpdateRawSource(); 395 | end; 396 | end; 397 | 398 | procedure TFormMain.BitBtnLeftClick(Sender: TObject); 399 | begin 400 | FSortingDirection := TSortingDirection.Left; 401 | 402 | NeedUpdate(); 403 | end; 404 | 405 | procedure TFormMain.BitBtnDownClick(Sender: TObject); 406 | begin 407 | FSortingDirection := TSortingDirection.Down; 408 | 409 | NeedUpdate(); 410 | end; 411 | 412 | procedure TFormMain.BitBtnRightClick(Sender: TObject); 413 | begin 414 | FSortingDirection := TSortingDirection.Right; 415 | 416 | NeedUpdate(); 417 | end; 418 | 419 | procedure TFormMain.TrackBarImageScaleChange(Sender: TObject); 420 | begin 421 | FImageScale := TrackBarImageScale.Position; 422 | UpdateSource(); 423 | 424 | NeedUpdate(); 425 | end; 426 | 427 | procedure TFormMain.TrackBarThresholdMaxChange(Sender: TObject); 428 | begin 429 | FTresholdMax := TrackBarThresholdMax.Position; 430 | if FTresholdMin > FTresholdMax then 431 | FTresholdMin := FTresholdMax; 432 | 433 | NeedUpdate(); 434 | end; 435 | 436 | procedure TFormMain.TrackBarThresholdMinChange(Sender: TObject); 437 | begin 438 | FTresholdMin := TrackBarThresholdMin.Position; 439 | if FTresholdMin > FTresholdMax then 440 | FTresholdMax := FTresholdMin; 441 | 442 | NeedUpdate(); 443 | end; 444 | 445 | procedure TFormMain.LoadSampleToBitmap(var Bitmap: TBitmap; Index: Integer); 446 | var 447 | Png: TPNGImage; 448 | begin 449 | Png := TPNGImage.Create(); 450 | try 451 | Png.LoadFromResourceName(HInstance, IntToStr(Index)); 452 | Bitmap.Assign(Png); 453 | finally 454 | Png.Free(); 455 | end; 456 | end; 457 | 458 | procedure TFormMain.TimerAutoShowTimer(Sender: TObject); 459 | const 460 | Vals: array of Double = [-1, -0.8, -0.5, -0.3, 0.3, 0.5, 0.8, 1]; 461 | begin 462 | 463 | if Random(20) = 0 then 464 | begin 465 | FAutoShowDeltaMin := RandomFrom(Vals); 466 | end; 467 | 468 | if Random(20) = 0 then 469 | begin 470 | FAutoShowDeltaMax := RandomFrom(Vals); 471 | end; 472 | 473 | FAutoShowTresholdMin := FAutoShowTresholdMin + FAutoShowDeltaMin; 474 | FAutoShowTresholdMax := FAutoShowTresholdMax + FAutoShowDeltaMax; 475 | 476 | if (FAutoShowTresholdMax > 255) or (FAutoShowTresholdMax < FAutoShowRangeMax) then 477 | begin 478 | FAutoShowDeltaMax := -FAutoShowDeltaMax; 479 | if FAutoShowTresholdMax < FAutoShowRangeMax then 480 | FAutoShowTresholdMax := FAutoShowRangeMax 481 | else 482 | FAutoShowTresholdMax := 255; 483 | end; 484 | 485 | if (FAutoShowTresholdMin > FAutoShowRangeMin) or (FAutoShowTresholdMin < 0) then 486 | begin 487 | FAutoShowDeltaMin := -FAutoShowDeltaMin; 488 | if FAutoShowTresholdMin > FAutoShowRangeMin then 489 | FAutoShowTresholdMin := FAutoShowRangeMin 490 | else 491 | FAutoShowTresholdMin := 0; 492 | end; 493 | 494 | FTresholdMin := Trunc(FAutoShowTresholdMin); 495 | FTresholdMax := Trunc(FAutoShowTresholdMax); 496 | 497 | UpdateUI(); 498 | end; 499 | 500 | procedure TFormMain.TrackBarAutoShowTresholdMaxChange(Sender: TObject); 501 | begin 502 | FAutoShowRangeMax := TrackBarAutoShowTresholdMax.Position; 503 | if FAutoShowRangeMin > FAutoShowRangeMax then 504 | FAutoShowRangeMin := FAutoShowRangeMax; 505 | 506 | NeedUpdate(); 507 | end; 508 | 509 | procedure TFormMain.TrackBarAutoShowTresholdMinChange(Sender: TObject); 510 | begin 511 | FAutoShowRangeMin := TrackBarAutoShowTresholdMin.Position; 512 | if FAutoShowRangeMin > FAutoShowRangeMax then 513 | FAutoShowRangeMax := FAutoShowRangeMin; 514 | 515 | NeedUpdate(); 516 | end; 517 | 518 | procedure TFormMain.LoadSample(Index: Integer); 519 | begin 520 | FTresholdMax := RandomRange(130, 255); 521 | FTresholdMin := RandomRange(0, 120); 522 | FSortingDirection := TSortingDirection(Random(4)); 523 | //FRawSource.LoadFromResourceName(HInstance, IntToStr(Index)); 524 | LoadSampleToBitmap(FRawSource, Index); 525 | UpdateRawSource(); 526 | end; 527 | 528 | procedure TFormMain.UpdateSource(); 529 | var 530 | Scaled: TBitmap; 531 | W, H: Integer; 532 | begin 533 | Scaled := TBitmap.Create(); 534 | try 535 | W := Max(1, Trunc(FRawSource.Width * FImageScale / 100)); 536 | H := Max(1, Trunc(FRawSource.Height * FImageScale / 100)); 537 | 538 | if W > MaxSourceSize then 539 | begin 540 | W := MaxSourceSize; 541 | H := Trunc(W * (FRawSource.Height / FRawSource.Width)); 542 | end; 543 | if H > MaxSourceSize then 544 | begin 545 | H := MaxSourceSize; 546 | W := Trunc(H * (FRawSource.Width / FRawSource.Height)); 547 | end; 548 | 549 | Scaled.SetSize(W, H); 550 | Scaled.Canvas.AntialiasingMode := amOn; 551 | Scaled.Canvas.StretchDraw(Rect(0, 0, Scaled.Width, Scaled.Height), FRawSource); 552 | FSource.Assign(Scaled); 553 | finally 554 | Scaled.Free(); 555 | end; 556 | 557 | NeedUpdate(); 558 | end; 559 | 560 | procedure TFormMain.UpdateRawSource(); 561 | begin 562 | ScrollBoxDisp.HorzScrollBar.Position := 0; 563 | ScrollBoxDisp.VertScrollBar.Position := 0; 564 | FViewScale := 1; 565 | FImageScale := 100; 566 | UpdateSource(); 567 | end; 568 | 569 | procedure TFormMain.UpdateUI(); 570 | begin 571 | // update image scale 572 | TrackBarImageScale.Position := FImageScale; 573 | LabelScale.Caption := IntToStr(FImageScale) + '%' + ' [' + IntToStr(FSource.Width) + 'x' + IntToStr(FSource.Height) + ']'; 574 | 575 | // update direction buttons 576 | if FSortingDirection = TSortingDirection.Left then 577 | BitBtnLeft.Font.Style := [fsBold] 578 | else 579 | BitBtnLeft.Font.Style := []; 580 | if FSortingDirection = TSortingDirection.Up then 581 | BitBtnUp.Font.Style := [fsBold] 582 | else 583 | BitBtnUp.Font.Style := []; 584 | if FSortingDirection = TSortingDirection.Right then 585 | BitBtnRight.Font.Style := [fsBold] 586 | else 587 | BitBtnRight.Font.Style := []; 588 | if FSortingDirection = TSortingDirection.Down then 589 | BitBtnDown.Font.Style := [fsBold] 590 | else 591 | BitBtnDown.Font.Style := []; 592 | 593 | // update view scale 594 | RadioGroupViewScale.ItemIndex := FViewScale - 1; 595 | 596 | // update trashhold 597 | TrackBarThresholdMin.Position := FTresholdMin; 598 | TrackBarThresholdMax.Position := FTresholdMax; 599 | 600 | // update save scale 601 | RadioGroupSaveScale.ItemIndex := FSaveScale - 1; 602 | 603 | // threshold labels 604 | LabelThresholdMin.Caption := IntToStr(FTresholdMin); 605 | LabelThresholdMax.Caption := IntToStr(FTresholdMax); 606 | 607 | // auto show 608 | CheckBoxAutoShowEnabled.Checked := FAutoShowEnabled; 609 | TrackBarAutoShowTresholdMin.Position := FAutoShowRangeMin; 610 | TrackBarAutoShowTresholdMax.Position := FAutoShowRangeMax; 611 | TrackBarThresholdMax.Enabled := not FAutoShowEnabled; 612 | TrackBarThresholdMin.Enabled := not FAutoShowEnabled; 613 | RadioGroupSaveScale.Enabled := not FAutoShowEnabled; 614 | ButtonSave.Enabled := not FAutoShowEnabled; 615 | end; 616 | 617 | procedure TFormMain.NeedUpdate(); 618 | begin 619 | FIsNeedUpdate := True; 620 | 621 | TimerAutoShow.Enabled := FAutoShowEnabled; 622 | 623 | UpdateUI(); 624 | end; 625 | 626 | end. 627 | 628 | -------------------------------------------------------------------------------- /other_langs/readme.md: -------------------------------------------------------------------------------- 1 | Сюда выкладывать версии на других языках. 2 | В папку с названием яп. 3 | -------------------------------------------------------------------------------- /samples/0.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/0.bmp -------------------------------------------------------------------------------- /samples/0.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/0.png -------------------------------------------------------------------------------- /samples/1.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/1.bmp -------------------------------------------------------------------------------- /samples/1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/1.png -------------------------------------------------------------------------------- /samples/10.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/10.bmp -------------------------------------------------------------------------------- /samples/10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/10.png -------------------------------------------------------------------------------- /samples/11.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/11.bmp -------------------------------------------------------------------------------- /samples/11.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/11.png -------------------------------------------------------------------------------- /samples/12.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/12.bmp -------------------------------------------------------------------------------- /samples/12.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/12.png -------------------------------------------------------------------------------- /samples/13.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/13.bmp -------------------------------------------------------------------------------- /samples/13.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/13.png -------------------------------------------------------------------------------- /samples/14.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/14.bmp -------------------------------------------------------------------------------- /samples/14.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/14.png -------------------------------------------------------------------------------- /samples/2.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/2.bmp -------------------------------------------------------------------------------- /samples/2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/2.png -------------------------------------------------------------------------------- /samples/3.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/3.bmp -------------------------------------------------------------------------------- /samples/3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/3.png -------------------------------------------------------------------------------- /samples/4.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/4.bmp -------------------------------------------------------------------------------- /samples/4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/4.png -------------------------------------------------------------------------------- /samples/5.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/5.bmp -------------------------------------------------------------------------------- /samples/5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/5.png -------------------------------------------------------------------------------- /samples/6.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/6.bmp -------------------------------------------------------------------------------- /samples/6.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/6.png -------------------------------------------------------------------------------- /samples/7.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/7.bmp -------------------------------------------------------------------------------- /samples/7.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/7.png -------------------------------------------------------------------------------- /samples/8.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/8.bmp -------------------------------------------------------------------------------- /samples/8.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/8.png -------------------------------------------------------------------------------- /samples/9.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/9.bmp -------------------------------------------------------------------------------- /samples/9.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/samples/9.png -------------------------------------------------------------------------------- /scr.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/turborium/SortingPixels/89a741783b7e56614eada2daab86370890fa44c4/scr.png --------------------------------------------------------------------------------