Changeset 163 for trunk/Components
- Timestamp:
- May 26, 2019, 12:14:41 PM (6 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Components/ScreenTools.pas
r155 r163 52 52 procedure PreparePlay(Item: string; Index: integer = -1); 53 53 procedure EmptyMenu(MenuItems: TMenuItem; Keep: Integer = 0); 54 function turntoyear(Turn: integer): integer;54 function TurnToYear(Turn: integer): integer; 55 55 function TurnToString(Turn: integer): string; 56 56 function MovementToString(Movement: integer): string; 57 57 procedure BtnFrame(ca: TCanvas; p: TRect; const T: TTexture); 58 58 procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture); 59 function HexStringToColor( s: string): integer;59 function HexStringToColor(S: string): integer; 60 60 function LoadGraphicFile(bmp: TBitmap; Path: string; Options: integer = 0): boolean; 61 61 function LoadGraphicSet(const Name: string): integer; … … 226 226 {$ENDIF} 227 227 228 Gamma: integer; // global gamma correction (cent)229 GammaL UT: array [0 .. 255] of byte;228 Gamma: Integer; // global gamma correction (cent) 229 GammaLookupTable: array [0 .. 255] of Byte; 230 230 231 231 {$IFDEF WINDOWS} … … 260 260 {$IFNDEF DEBUG} 261 261 var 262 W AVFileName: string;262 WavFileName: string; 263 263 {$ENDIF} 264 264 begin … … 268 268 begin 269 269 Result := True; 270 exit;271 end; 272 W AVFileName := Sounds.Lookup(Item, Index);273 assert(WAVFileName[1] <> '[');274 Result := (W AVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*');270 Exit; 271 end; 272 WavFileName := Sounds.Lookup(Item, Index); 273 Assert(WavFileName[1] <> '['); 274 Result := (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*'); 275 275 if Result then 276 // SndPlaySound(pchar(HomeDir+'Sounds' +DirectorySeparator+W AVFileName+'.wav'),SND_ASYNC)277 PlaySound(HomeDir + 'Sounds' + DirectorySeparator + W AVFileName);276 // SndPlaySound(pchar(HomeDir+'Sounds' +DirectorySeparator+WavFileName+'.wav'),SND_ASYNC) 277 PlaySound(HomeDir + 'Sounds' + DirectorySeparator + WavFileName); 278 278 {$ENDIF} 279 279 end; 280 280 281 procedure PreparePlay(Item: string; Index: integer = -1);281 procedure PreparePlay(Item: string; Index: Integer = -1); 282 282 {$IFNDEF DEBUG} 283 283 var 284 W AVFileName: string;284 WavFileName: string; 285 285 {$ENDIF} 286 286 begin 287 287 {$IFNDEF DEBUG} 288 288 if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then 289 exit;290 W AVFileName := Sounds.Lookup(Item, Index);291 assert(WAVFileName[1] <> '[');292 if (W AVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*') then293 PrepareSound(HomeDir + 'Sounds' + DirectorySeparator + W AVFileName);289 Exit; 290 WavFileName := Sounds.Lookup(Item, Index); 291 Assert(WavFileName[1] <> '['); 292 if (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*') then 293 PrepareSound(HomeDir + 'Sounds' + DirectorySeparator + WavFileName); 294 294 {$ENDIF} 295 295 end; … … 306 306 end; 307 307 308 function turntoyear(Turn: integer): integer;309 var 310 i: integer;308 function TurnToYear(Turn: Integer): Integer; 309 var 310 I: Integer; 311 311 begin 312 312 Result := -4000; 313 for i := 1 to Turn do 314 if Result < -1000 then 315 Inc(Result, 50) // 0..60 316 else if Result < 0 then 317 Inc(Result, 25) // 60..100 318 else if Result < 1500 then 319 Inc(Result, 20) // 100..175 320 else if Result < 1750 then 321 Inc(Result, 10) // 175..200 322 else if Result < 1850 then 323 Inc(Result, 2) // 200..250 324 else 325 Inc(Result); 326 end; 327 328 function TurnToString(Turn: integer): string; 329 var 330 year: integer; 313 for I := 1 to Turn do 314 if Result < -1000 then Inc(Result, 50) // 0..60 315 else if Result < 0 then Inc(Result, 25) // 60..100 316 else if Result < 1500 then Inc(Result, 20) // 100..175 317 else if Result < 1750 then Inc(Result, 10) // 175..200 318 else if Result < 1850 then Inc(Result, 2) // 200..250 319 else Inc(Result); 320 end; 321 322 function TurnToString(Turn: Integer): string; 323 var 324 Year: Integer; 331 325 begin 332 326 if GenerateNames then 333 327 begin 334 year := turntoyear(Turn);335 if year < 0 then336 Result := Format(Phrases.Lookup('BC'), [- year])328 Year := TurnToYear(Turn); 329 if Year < 0 then 330 Result := Format(Phrases.Lookup('BC'), [-Year]) 337 331 else 338 Result := Format(Phrases.Lookup('AD'), [ year]);332 Result := Format(Phrases.Lookup('AD'), [Year]); 339 333 end 340 334 else … … 342 336 end; 343 337 344 function MovementToString(Movement: integer): string;338 function MovementToString(Movement: Integer): string; 345 339 begin 346 340 if Movement >= 1000 then 347 341 begin 348 Result := char(48 + Movement div 1000);342 Result := Char(48 + Movement div 1000); 349 343 Movement := Movement mod 1000; 350 344 end 351 345 else 352 346 Result := ''; 353 Result := Result + char(48 + Movement div 100);347 Result := Result + Char(48 + Movement div 100); 354 348 Movement := Movement mod 100; 355 349 if Movement > 0 then 356 350 begin 357 Result := Result + '.' + char(48 + Movement div 10);351 Result := Result + '.' + Char(48 + Movement div 10); 358 352 Movement := Movement mod 10; 359 353 if Movement > 0 then 360 Result := Result + char(48 + Movement);354 Result := Result + Char(48 + Movement); 361 355 end; 362 356 end; … … 377 371 end; 378 372 379 function HexStringToColor(s: string): integer; 380 381 function HexCharToInt(x: char): integer; 382 begin 383 case x of 384 '0' .. '9': 385 Result := Ord(x) - 48; 386 'A' .. 'F': 387 Result := Ord(x) - 65 + 10; 388 'a' .. 'f': 389 Result := Ord(x) - 97 + 10; 390 else 391 Result := 0 392 end; 393 end; 394 395 begin 396 while (Length(s) > 0) and (s[1] = ' ') do 397 Delete(s, 1, 1); 398 s := s + '000000'; 373 function HexCharToInt(X: Char): Integer; 374 begin 375 case x of 376 '0' .. '9': Result := Ord(X) - Ord('0'); 377 'A' .. 'F': Result := Ord(X) - Ord('A') + 10; 378 'a' .. 'f': Result := Ord(X) - Ord('a') + 10; 379 else Result := 0 380 end; 381 end; 382 383 function HexStringToColor(S: string): Integer; 384 begin 385 while (Length(S) > 0) and (S[1] = ' ') do 386 Delete(S, 1, 1); 387 S := S + '000000'; 399 388 if Gamma = 100 then 400 Result := $10 * HexCharToInt( s[1]) + $1 * HexCharToInt(s[2]) +401 $1000 * HexCharToInt( s[3]) + $100 * HexCharToInt(s[4]) + $100000 *402 HexCharToInt(s[5]) + $10000 * HexCharToInt(s[6])389 Result := $10 * HexCharToInt(S[1]) + $1 * HexCharToInt(S[2]) + 390 $1000 * HexCharToInt(S[3]) + $100 * HexCharToInt(S[4]) + 391 $100000 * HexCharToInt(S[5]) + $10000 * HexCharToInt(S[6]) 403 392 else 404 Result := GammaLUT[$10 * HexCharToInt(s[1]) + HexCharToInt(s[2])] + 405 $100 * GammaLUT[$10 * HexCharToInt(s[3]) + HexCharToInt(s[4])] + 406 $10000 * GammaLUT[$10 * HexCharToInt(s[5]) + HexCharToInt(s[6])]; 393 Result := GammaLookupTable[$10 * HexCharToInt(S[1]) + HexCharToInt(S[2])] + 394 $100 * GammaLookupTable[$10 * HexCharToInt(S[3]) + HexCharToInt(S[4])] + 395 $10000 * GammaLookupTable[$10 * HexCharToInt(S[5]) + HexCharToInt(S[6])]; 396 end; 397 398 function ApplyGammaToPixel(Pixel: TPixel32): TPixel32; 399 begin 400 Result.R := GammaLookupTable[Pixel.R]; 401 Result.G := GammaLookupTable[Pixel.G]; 402 Result.B := GammaLookupTable[Pixel.B]; 407 403 end; 408 404 … … 410 406 var 411 407 PixelPtr: TPixelPointer; 412 X, Y: integer;408 X, Y: Integer; 413 409 begin 414 410 Bitmap.BeginUpdate; 415 411 PixelPtr.Init(Bitmap); 416 for Y := 0 to Bitmap.Height - 1 do 417 begin 418 for X := 0 to Bitmap.Width - 1 do 419 begin 420 PixelPtr.Pixel^.B := GammaLUT[PixelPtr.Pixel^.B]; 421 PixelPtr.Pixel^.G := GammaLUT[PixelPtr.Pixel^.G]; 422 PixelPtr.Pixel^.R := GammaLUT[PixelPtr.Pixel^.R]; 412 for Y := 0 to Bitmap.Height - 1 do begin 413 for X := 0 to Bitmap.Width - 1 do begin 414 PixelPtr.Pixel^ := ApplyGammaToPixel(PixelPtr.Pixel^); 423 415 PixelPtr.NextPixel; 424 416 end; … … 431 423 var 432 424 SrcPtr, DstPtr: TPixelPointer; 433 X, Y: integer;425 X, Y: Integer; 434 426 begin 435 427 //Dst.SetSize(Src.Width, Src.Height); 436 428 SrcPtr.Init(Src); 437 429 DstPtr.Init(Dst); 438 for Y := 0 to Src.Height - 1 do 439 begin 440 for X := 0 to Src.Width - 1 do 441 begin 430 for Y := 0 to Src.Height - 1 do begin 431 for X := 0 to Src.Width - 1 do begin 442 432 DstPtr.Pixel^.B := SrcPtr.Pixel^.B; 443 433 DstPtr.Pixel^.G := SrcPtr.Pixel^.B; … … 451 441 end; 452 442 453 function LoadGraphicFile(bmp: TBitmap; Path: string; Options: integer): boolean;454 var 455 jtex: tjpegimage;443 function LoadGraphicFile(bmp: TBitmap; Path: string; Options: Integer): Boolean; 444 var 445 jtex: TJpegImage; 456 446 Png: TPortableNetworkGraphic; 457 447 begin … … 459 449 if ExtractFileExt(Path) = '' then 460 450 Path := Path + '.png'; 461 if ExtractFileExt(Path) = '.jpg' then 462 begin 451 if ExtractFileExt(Path) = '.jpg' then begin 463 452 jtex := tjpegimage.Create; 464 453 try … … 477 466 end 478 467 else 479 if ExtractFileExt(Path) = '.png' then 480 begin 468 if ExtractFileExt(Path) = '.png' then begin 481 469 Png := TPortableNetworkGraphic.Create; 482 470 Png.PixelFormat := Bmp.PixelFormat; … … 503 491 end 504 492 else 505 if ExtractFileExt(Path) = '.bmp' then 506 begin 493 if ExtractFileExt(Path) = '.bmp' then begin 507 494 try 508 495 bmp.LoadFromFile(Path); … … 510 497 Result := False; 511 498 end; 512 if Result then 513 begin 499 if Result then begin 514 500 if Options and gfNoGamma = 0 then 515 501 bmp.PixelFormat := pf24bit; … … 519 505 raise Exception.Create('Unsupported image file type ' + ExtractFileExt(Path)); 520 506 521 if not Result then 522 begin 507 if not Result then begin 523 508 if Options and gfNoError = 0 then 524 509 raise Exception.Create(Format(Phrases.Lookup('FILENOTFOUND'), [Path])); … … 529 514 end; 530 515 531 function LoadGraphicSet(const Name: string): integer;532 var 533 I, x, y, xmax, OriginalColor: integer;516 function LoadGraphicSet(const Name: string): Integer; 517 var 518 I, x, y, xmax, OriginalColor: Integer; 534 519 FileName: string; 535 520 Source: TBitmap; … … 540 525 Inc(I); 541 526 Result := I; 542 if I = nGrExt then 543 begin 527 if I = nGrExt then begin 544 528 Source := TBitmap.Create; 545 529 Source.PixelFormat := pf24bit; 546 530 FileName := HomeDir + 'Graphics' + DirectorySeparator + Name; 547 if not LoadGraphicFile(Source, FileName) then 548 begin 531 if not LoadGraphicFile(Source, FileName) then begin 549 532 Result := -1; 550 533 Exit; … … 568 551 DataPixel.Init(GrExt[nGrExt].Data); 569 552 MaskPixel.Init(GrExt[nGrExt].Mask); 570 for y := 0 to Source.Height - 1 do 571 begin 572 for x := 0 to xmax - 1 do 573 begin 553 for y := 0 to Source.Height - 1 do begin 554 for x := 0 to xmax - 1 do begin 574 555 OriginalColor := DataPixel.Pixel^.ARGB and $FFFFFF; 575 556 if (OriginalColor = $FF00FF) or (OriginalColor = $7F007F) then … … 578 559 DataPixel.Pixel^.ARGB := DataPixel.Pixel^.ARGB and $FF000000; 579 560 end 580 else 581 begin 561 else begin 582 562 MaskPixel.Pixel^.ARGB := $000000; // non-transparent 583 563 if Gamma <> 100 then 584 begin 585 DataPixel.Pixel^.B := GammaLUT[DataPixel.Pixel^.B]; 586 DataPixel.Pixel^.G := GammaLUT[DataPixel.Pixel^.G]; 587 DataPixel.Pixel^.R := GammaLUT[DataPixel.Pixel^.R]; 588 end; 564 DataPixel.Pixel^ := ApplyGammaToPixel(DataPixel.Pixel^); 589 565 end; 590 566 DataPixel.NextPixel; … … 615 591 Dst.BeginUpdate; 616 592 PixelPtr.Init(Dst, X, Y); 617 for yy := 0 to h - 1 do 618 begin 619 for xx := 0 to w - 1 do 620 begin 593 for yy := 0 to h - 1 do begin 594 for xx := 0 to w - 1 do begin 621 595 PixelPtr.Pixel^.B := PixelPtr.Pixel^.B div 2; 622 596 PixelPtr.Pixel^.G := PixelPtr.Pixel^.G div 2; … … 629 603 end; 630 604 631 procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h: integer);605 procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h: Integer); 632 606 // Src is template 633 607 // X channel = background amp (old Dst content), 128=original brightness 634 608 var 635 X, Y: integer;636 Brightness, Test: integer;609 X, Y: Integer; 610 Brightness, Test: Integer; 637 611 PixelSrc: TPixelPointer; 638 612 PixelDst: TPixelPointer; … … 640 614 //Assert(Src.PixelFormat = pf8bit); 641 615 Assert(dst.PixelFormat = pf24bit); 642 if xDst < 0 then 643 begin 616 if xDst < 0 then begin 644 617 w := w + xDst; 645 618 xSrc := xSrc - xDst; 646 619 xDst := 0; 647 620 end; 648 if yDst < 0 then 649 begin 621 if yDst < 0 then begin 650 622 h := h + yDst; 651 623 ySrc := ySrc - yDst; … … 663 635 PixelDst.Init(Dst, xDst, yDst); 664 636 PixelSrc.Init(Src, xSrc, ySrc); 665 for Y := 0 to h - 1 do 666 begin 667 for X := 0 to w - 1 do 668 begin 637 for Y := 0 to h - 1 do begin 638 for X := 0 to w - 1 do begin 669 639 Brightness := PixelSrc.Pixel^.B; // One byte for 8-bit color 670 640 test := (PixelDst.Pixel^.R * Brightness) shr 7; … … 703 673 SrcPixel, DstPixel: TPixelPointer; 704 674 begin 705 if xDst < 0 then 706 begin 675 if xDst < 0 then begin 707 676 w := w + xDst; 708 677 xSrc := xSrc - xDst; 709 678 xDst := 0; 710 679 end; 711 if yDst < 0 then 712 begin 680 if yDst < 0 then begin 713 681 h := h + yDst; 714 682 ySrc := ySrc - yDst; … … 726 694 SrcPixel.Init(Src, xSrc, ySrc); 727 695 DstPixel.Init(Dst, xDst, yDst); 728 for iy := 0 to h - 1 do 729 begin 730 for ix := 0 to w - 1 do 731 begin 696 for iy := 0 to h - 1 do begin 697 for ix := 0 to w - 1 do begin 732 698 trans := SrcPixel.Pixel^.B * 2; // green channel = transparency 733 699 amp1 := SrcPixel.Pixel^.G * 2; 734 700 amp2 := SrcPixel.Pixel^.R * 2; 735 if trans <> $FF then 736 begin 701 if trans <> $FF then begin 737 702 Value := (DstPixel.Pixel^.B * trans + ((Color2 shr 16) and $FF) * 738 703 amp2 + ((Color1 shr 16) and $FF) * amp1) div $FF; … … 764 729 end; 765 730 766 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, Color2: integer);731 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, Color2: Integer); 767 732 // Bmp is template 768 733 // B channel = Color0 amp, 128=original brightness … … 770 735 // R channel = Color2 amp, 128=original brightness 771 736 var 772 i, Red, Green: integer;737 i, Red, Green: Integer; 773 738 PixelPtr: TPixelPointer; 774 739 begin … … 777 742 h := y + h; 778 743 PixelPtr.Init(Bmp, x, y); 779 while y < h do 780 begin 781 for i := 0 to w - 1 do 782 begin 744 while y < h do begin 745 for i := 0 to w - 1 do begin 783 746 Red := ((PixelPtr.Pixel^.B * (Color0 and $0000FF) + PixelPtr.Pixel^.G * 784 747 (Color1 and $0000FF) + PixelPtr.Pixel^.R * (Color2 and $0000FF)) shr 8) and $ff; … … 826 789 procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor); 827 790 begin 828 with ca do 829 begin 791 with ca do begin 830 792 Pen.Color := cl; 831 793 MoveTo(x0, y); … … 836 798 procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor); 837 799 begin 838 with ca do 839 begin 800 with ca do begin 840 801 Pen.Color := cl0; 841 802 MoveTo(x0, y); … … 851 812 procedure Frame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor); 852 813 begin 853 with ca do 854 begin 814 with ca do begin 855 815 MoveTo(x0, y1); 856 816 Pen.Color := cl0; … … 865 825 procedure RFrame(ca: TCanvas; x0, y0, x1, y1: integer; cl0, cl1: TColor); 866 826 begin 867 with ca do 868 begin 827 with ca do begin 869 828 Pen.Color := cl0; 870 829 MoveTo(x0, y0 + 1); … … 882 841 procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor); 883 842 begin 884 with ca do 885 begin 843 with ca do begin 886 844 Pen.Color := cl; 887 845 MoveTo(x0, y0 + Corner - 1); … … 903 861 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False); 904 862 begin 905 if IsControl then 906 begin 863 if IsControl then begin 907 864 Frame(ca, x - 1, y - 1, x + Width, y + Height, $B0B0B0, $FFFFFF); 908 865 RFrame(ca, x - 2, y - 2, x + Width + 1, y + Height + 1, $FFFFFF, $B0B0B0); 909 end 910 else 866 end else 911 867 Frame(ca, x - 1, y - 1, x + Width, y + Height, $000000, $000000); 912 868 BitBlt(ca.Handle, x, y, Width, Height, Src.Canvas.Handle, xSrc, ySrc, … … 914 870 end; 915 871 916 procedure GlowFrame(dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor);917 var 918 x, y, ch, r: integer;872 procedure GlowFrame(dst: TBitmap; x0, y0, Width, Height: Integer; cl: TColor); 873 var 874 x, y, ch, r: Integer; 919 875 DstPtr: TPixelPointer; 920 876 begin 921 877 dst.BeginUpdate; 922 878 DstPtr.Init(dst, x0, y0); 923 for y := -GlowRange + 1 to Height - 1 + GlowRange - 1 do 924 begin 925 for x := -GlowRange + 1 to Width - 1 + GlowRange - 1 do 926 begin 879 for y := -GlowRange + 1 to Height - 1 + GlowRange - 1 do begin 880 for x := -GlowRange + 1 to Width - 1 + GlowRange - 1 do begin 927 881 DstPtr.SetXY(x, y); 928 882 if x < 0 then … … 960 914 procedure InitOrnament; 961 915 var 962 x, y, p, light, shade: integer; 963 begin 964 if InitOrnamentDone then 965 exit; 966 light := MainTexture.clBevelLight; 916 x, y, p, Light, Shade: Integer; 917 begin 918 if InitOrnamentDone then Exit; 919 Light := MainTexture.clBevelLight; 967 920 // and $FCFCFC shr 2*3+MainTexture.clBevelShade and $FCFCFC shr 2; 968 shade := MainTexture.clBevelShade and $FCFCFC shr 2 * 3 +921 Shade := MainTexture.clBevelShade and $FCFCFC shr 2 * 3 + 969 922 MainTexture.clBevelLight and $FCFCFC shr 2; 970 923 for x := 0 to wOrna - 1 do 971 for y := 0 to hOrna - 1 do 972 begin 924 for y := 0 to hOrna - 1 do begin 973 925 p := GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y]; 974 926 if p = $0000FF then 975 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := light927 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := Light 976 928 else if p = $FF0000 then 977 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := shade;929 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := Shade; 978 930 end; 979 931 InitOrnamentDone := True; … … 982 934 procedure InitCityMark(const T: TTexture); 983 935 var 984 x, y, intensity: integer;936 x, y, intensity: Integer; 985 937 begin 986 938 for x := 0 to 9 do … … 999 951 end; 1000 952 1001 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer);953 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); 1002 954 begin 1003 955 Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= wMainTexture) and … … 1007 959 end; 1008 960 1009 procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: integer);1010 1011 function band(i: integer): integer;961 procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: Integer); 962 963 function Band(I: Integer): Integer; 1012 964 var 1013 965 n: integer; 1014 966 begin 1015 967 n := ((hMainTexture div 2) div (y1 - y0)) * 2; 1016 while hMainTexture div 2 + ( i+ 1) * (y1 - y0) > hMainTexture do1017 Dec( i, n);1018 while hMainTexture div 2 + i* (y1 - y0) < 0 do1019 Inc( i, n);1020 Result := i;1021 end; 1022 1023 var 1024 i: integer;1025 begin 1026 for i:= 0 to (x1 - xm) div wMainTexture - 1 do1027 BitBlt(ca.Handle, xm + i* wMainTexture, y0, wMainTexture, y1 - y0,1028 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band(i) *968 while hMainTexture div 2 + (I + 1) * (y1 - y0) > hMainTexture do 969 Dec(I, n); 970 while hMainTexture div 2 + I * (y1 - y0) < 0 do 971 Inc(I, n); 972 Result := I; 973 end; 974 975 var 976 I: Integer; 977 begin 978 for I := 0 to (x1 - xm) div wMainTexture - 1 do 979 BitBlt(ca.Handle, xm + I * wMainTexture, y0, wMainTexture, y1 - y0, 980 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + Band(I) * 1029 981 (y1 - y0), SRCCOPY); 1030 982 BitBlt(ca.Handle, xm + ((x1 - xm) div wMainTexture) * wMainTexture, y0, 1031 983 x1 - (xm + ((x1 - xm) div wMainTexture) * wMainTexture), y1 - y0, 1032 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band(984 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + Band( 1033 985 (x1 - xm) div wMainTexture) * (y1 - y0), SRCCOPY); 1034 for i:= 0 to (xm - x0) div wMainTexture - 1 do1035 BitBlt(ca.Handle, xm - ( i+ 1) * wMainTexture, y0, wMainTexture, y1 - y0,986 for I := 0 to (xm - x0) div wMainTexture - 1 do 987 BitBlt(ca.Handle, xm - (I + 1) * wMainTexture, y0, wMainTexture, y1 - y0, 1036 988 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + 1037 band(-i- 1) * (y1 - y0), SRCCOPY);989 Band(-I - 1) * (y1 - y0), SRCCOPY); 1038 990 BitBlt(ca.Handle, x0, y0, xm - ((xm - x0) div wMainTexture) * 1039 991 wMainTexture - x0, y1 - y0, MainTexture.Image.Canvas.Handle, 1040 992 ((xm - x0) div wMainTexture + 1) * wMainTexture - (xm - x0), 1041 hMainTexture div 2 + band(-(xm - x0) div wMainTexture - 1) * (y1 - y0), SRCCOPY);1042 end; 1043 1044 procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer;993 hMainTexture div 2 + Band(-(xm - x0) div wMainTexture - 1) * (y1 - y0), SRCCOPY); 994 end; 995 996 procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer; 1045 997 const Texture: TBitmap); 1046 998 var 1047 x, y, x0cut, y0cut, x1cut, y1cut: integer;999 x, y, x0cut, y0cut, x1cut, y1cut: Integer; 1048 1000 begin 1049 1001 while xOffset < 0 do … … 1077 1029 end; 1078 1030 1079 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: integer;1031 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer; 1080 1032 const Texture: TBitmap); 1081 1033 begin … … 1083 1035 end; 1084 1036 1085 procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer);1037 procedure PaintBackground(Form: TForm; Left, Top, Width, Height: Integer); 1086 1038 begin 1087 1039 Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth) div … … 1089 1041 end; 1090 1042 1091 procedure Corner(ca: TCanvas; x, y, Kind: integer; const T: TTexture);1043 procedure Corner(ca: TCanvas; x, y, Kind: Integer; const T: TTexture); 1092 1044 begin 1093 1045 { BitBlt(ca.Handle,x,y,8,8,GrExt[T.HGr].Mask.Canvas.Handle, … … 1097 1049 end; 1098 1050 1099 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; s: string);1100 1101 procedure PaintIcon(x, y, Kind: integer);1051 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: Integer; s: string); 1052 1053 procedure PaintIcon(x, y, Kind: Integer); 1102 1054 begin 1103 1055 BitBlt(ca.Handle, x, y + 6, 10, 10, GrExt[HGrSystem].Mask.Canvas.Handle, … … 1108 1060 1109 1061 var 1110 p, xp: integer;1062 p, xp: Integer; 1111 1063 sp: string; 1112 shadow: boolean;1064 shadow: Boolean; 1113 1065 begin 1114 1066 Inc(x); … … 1130 1082 begin 1131 1083 ca.Textout(xp, y, sp); 1132 break;1084 Break; 1133 1085 end 1134 1086 else … … 1138 1090 if not shadow then 1139 1091 case sp[p + 1] of 1140 'c': 1141 PaintIcon(xp + 1, y, 6); 1142 'f': 1143 PaintIcon(xp + 1, y, 0); 1144 'l': 1145 PaintIcon(xp + 1, y, 8); 1146 'm': 1147 PaintIcon(xp + 1, y, 17); 1148 'n': 1149 PaintIcon(xp + 1, y, 7); 1150 'o': 1151 PaintIcon(xp + 1, y, 16); 1152 'p': 1153 PaintIcon(xp + 1, y, 2); 1154 'r': 1155 PaintIcon(xp + 1, y, 12); 1156 't': 1157 PaintIcon(xp + 1, y, 4); 1158 'w': 1159 PaintIcon(xp + 1, y, 13); 1092 'c': PaintIcon(xp + 1, y, 6); 1093 'f': PaintIcon(xp + 1, y, 0); 1094 'l': PaintIcon(xp + 1, y, 8); 1095 'm': PaintIcon(xp + 1, y, 17); 1096 'n': PaintIcon(xp + 1, y, 7); 1097 'o': PaintIcon(xp + 1, y, 16); 1098 'p': PaintIcon(xp + 1, y, 2); 1099 'r': PaintIcon(xp + 1, y, 12); 1100 't': PaintIcon(xp + 1, y, 4); 1101 'w': PaintIcon(xp + 1, y, 13); 1160 1102 end; 1161 1103 Inc(xp, 10); 1162 1104 Delete(sp, 1, p + 1); 1163 end 1105 end; 1164 1106 until False; 1165 1107 Dec(x); … … 1168 1110 end; 1169 1111 1170 function BiColorTextWidth(ca: TCanvas; s: string): integer;1171 var 1172 p: integer;1112 function BiColorTextWidth(ca: TCanvas; s: string): Integer; 1113 var 1114 P: Integer; 1173 1115 begin 1174 1116 Result := 1; 1175 1117 repeat 1176 p := pos('%', s);1177 if ( p = 0) or (p= Length(s)) then1118 P := Pos('%', s); 1119 if (P = 0) or (P = Length(s)) then 1178 1120 begin 1179 1121 Inc(Result, ca.TextWidth(s)); 1180 break;1122 Break; 1181 1123 end 1182 1124 else 1183 1125 begin 1184 if not (s[ p+ 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w'])1126 if not (s[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1185 1127 then 1186 Inc(Result, ca.TextWidth(copy(s, 1, p+ 1)))1128 Inc(Result, ca.TextWidth(copy(s, 1, P + 1))) 1187 1129 else 1188 Inc(Result, ca.TextWidth(copy(s, 1, p- 1)) + 10);1189 Delete(s, 1, p+ 1);1190 end 1130 Inc(Result, ca.TextWidth(copy(s, 1, P - 1)) + 10); 1131 Delete(s, 1, P + 1); 1132 end; 1191 1133 until False; 1192 1134 end; 1193 1135 1194 1136 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture; 1195 x, y: integer; s: string);1137 x, y: Integer; s: string); 1196 1138 begin 1197 1139 if cl = -2 then … … 1209 1151 end; 1210 1152 1211 procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: integer;1153 procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: Integer; 1212 1154 Brightness: array of integer); 1213 1155 var 1214 i, r, g, b: integer;1156 i, r, g, b: Integer; 1215 1157 begin 1216 1158 begin … … 1243 1185 end; 1244 1186 1245 procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer);1187 procedure LightGradient(ca: TCanvas; x, y, Width, Color: Integer); 1246 1188 const 1247 1189 Brightness: array [0 .. 15] of integer = … … 1251 1193 end; 1252 1194 1253 procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer);1195 procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: Integer); 1254 1196 const 1255 1197 Brightness: array [0 .. 15] of integer = … … 1260 1202 end; 1261 1203 1262 procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer);1204 procedure VLightGradient(ca: TCanvas; x, y, Height, Color: Integer); 1263 1205 const 1264 1206 Brightness: array [0 .. 15] of integer = … … 1268 1210 end; 1269 1211 1270 procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer);1212 procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: Integer); 1271 1213 const 1272 1214 Brightness: array [0 .. 15] of integer = … … 1278 1220 1279 1221 procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; 1280 val: integer; const T: TTexture);1222 val: Integer; const T: TTexture); 1281 1223 var 1282 1224 s: string; … … 1293 1235 end; 1294 1236 1295 procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer;1296 Cap: string; val: integer; const T: TTexture);1297 var 1298 i, sd, ld, cl, xIcon, yIcon: integer;1237 procedure CountBar(dst: TBitmap; x, y, w: Integer; Kind: Integer; 1238 Cap: string; val: Integer; const T: TTexture); 1239 var 1240 i, sd, ld, cl, xIcon, yIcon: Integer; 1299 1241 s: string; 1300 1242 begin 1301 1243 // val:=random(40); //!!! 1302 1244 if val = 0 then 1303 exit;1304 assert(Kind >= 0);1245 Exit; 1246 Assert(Kind >= 0); 1305 1247 with dst.Canvas do 1306 1248 begin … … 1387 1329 end; 1388 1330 end; 1389 end; // CountBar1390 1391 procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer;1331 end; 1332 1333 procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: Integer; 1392 1334 const T: TTexture); 1393 1335 var 1394 i: integer;1336 i: Integer; 1395 1337 begin 1396 1338 if pos > max then … … 1443 1385 // pos and growth are relative to max, set size independent 1444 1386 procedure PaintRelativeProgressBar(ca: TCanvas; 1445 Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;1387 Kind, x, y, size, pos, Growth, max: Integer; IndicateComplete: Boolean; 1446 1388 const T: TTexture); 1447 1389 begin … … 1456 1398 end; 1457 1399 1458 procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer);1400 procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: Integer); 1459 1401 begin 1460 1402 BitBltCanvas(LogoBuffer.Canvas, 0, 0, wLogo, hLogo, ca, x, … … 1466 1408 end; 1467 1409 1468 function SetMainTextureByAge(Age: integer): boolean;1410 function SetMainTextureByAge(Age: Integer): Boolean; 1469 1411 begin 1470 1412 if Age <> MainTextureAge then 1471 with MainTexture do 1472 begin 1413 with MainTexture do begin 1473 1414 MainTextureAge := Age; 1474 1415 LoadGraphicFile(Image, HomeDir + 'Graphics' + DirectorySeparator + … … 1501 1442 end; 1502 1443 1503 procedure TPixelPointer.SetXY(X, Y: integer); inline;1444 procedure TPixelPointer.SetXY(X, Y: Integer); inline; 1504 1445 begin 1505 1446 Line := Pointer(Base) + Y * BytesPerLine; … … 1507 1448 end; 1508 1449 1509 procedure TPixelPointer.SetX(X: integer); inline;1450 procedure TPixelPointer.SetX(X: Integer); inline; 1510 1451 begin 1511 1452 Pixel := Pointer(Line) + X * BytesPerPixel; 1512 1453 end; 1513 1454 1514 procedure TPixelPointer.Init(Bitmap: TRasterImage; BaseX: integer = 0;1455 procedure TPixelPointer.Init(Bitmap: TRasterImage; BaseX: Integer = 0; 1515 1456 BaseY: integer = 0); inline; 1516 1457 begin … … 1569 1510 try 1570 1511 Reset(fontscript); 1571 while not EOF(FontScript) do 1572 begin 1512 while not EOF(FontScript) do begin 1573 1513 ReadLn(FontScript, s); 1574 1514 if s <> '' then 1575 if s[1] = '#' then 1576 begin 1515 if s[1] = '#' then begin 1577 1516 s := TrimRight(s); 1578 1517 if s = '#SMALL' then … … 1586 1525 else 1587 1526 Section := ftNormal; 1588 end 1589 else 1590 begin 1527 end else begin 1591 1528 p := Pos(',', s); 1592 if p > 0 then 1593 begin 1529 if p > 0 then begin 1594 1530 UniFont[section].Name := Trim(Copy(s, 1, p - 1)); 1595 1531 Size := 0; … … 1622 1558 end; 1623 1559 1560 procedure InitGammaLookupTable; 1561 var 1562 I: Integer; 1563 P: Integer; 1564 begin 1565 GammaLookupTable[0] := 0; 1566 for I := 1 to 255 do begin 1567 P := Round(255.0 * Exp(Ln(I / 255.0) * 100.0 / Gamma)); 1568 Assert((P >= 0) and (P < 256)); 1569 GammaLookupTable[I] := P; 1570 end; 1571 end; 1572 1624 1573 procedure UnitInit; 1625 1574 var 1626 I: integer;1627 P: integer;1628 1575 Reg: TRegistry; 1629 1576 begin … … 1647 1594 end; 1648 1595 1649 if Gamma <> 100 then 1650 begin 1651 GammaLUT[0] := 0; 1652 for i := 1 to 255 do 1653 begin 1654 p := Round(255.0 * exp(ln(i / 255.0) * 100.0 / Gamma)); 1655 Assert((p >= 0) and (p < 256)); 1656 GammaLUT[i] := p; 1657 end; 1658 end; 1596 if Gamma <> 100 then InitGammaLookupTable; 1659 1597 1660 1598 {$IFDEF WINDOWS} … … 1710 1648 1711 1649 RestoreResolution; 1712 for I := 0 to nGrExt - 1 do 1713 begin 1650 for I := 0 to nGrExt - 1 do begin 1714 1651 GrExt[I].Data.Free; 1715 1652 GrExt[I].Mask.Free; … … 1731 1668 end; 1732 1669 1733 1734 initialization1735 1736 //UnitInit;1737 1738 finalization1739 1740 //UnitDone;1741 1742 1670 end.
Note:
See TracChangeset
for help on using the changeset viewer.