Changeset 128 for trunk/Components
- Timestamp:
- May 1, 2018, 3:15:03 PM (7 years ago)
- Location:
- trunk/Components
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Components/ScreenTools.pas
r115 r128 14 14 Image: TBitmap; 15 15 clBevelLight, clBevelShade, clTextLight, clTextShade, clLitText, clMark, 16 17 end; 18 19 TColor32 = type Cardinal;16 clPage, clCover: TColor; 17 end; 18 19 TColor32 = type cardinal; 20 20 TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha); 21 21 TPixel32 = packed record 22 case Integer of23 0: (B, G, R, A: Byte);24 1: (ARGB: TColor32);25 2: (Planes: array[0..3] of Byte);26 3: (Components: array[TColor32Component] of Byte);22 case integer of 23 0: (B, G, R, A: byte); 24 1: (ARGB: TColor32); 25 2: (Planes: array[0..3] of byte); 26 3: (Components: array[TColor32Component] of byte); 27 27 end; 28 28 PPixel32 = ^TPixel32; … … 35 35 Line: PPixel32; 36 36 RelLine: PPixel32; 37 BytesPerPixel: Integer;38 BytesPerLine: Integer;37 BytesPerPixel: integer; 38 BytesPerLine: integer; 39 39 procedure NextLine; inline; // Move pointer to start of new base line 40 40 procedure NextPixel; inline; // Move pointer to next pixel 41 procedure SetXY(X, Y: Integer); inline; // Set pixel position relative to base42 procedure SetX(X: Integer); inline; // Set horizontal pixel position relative to base43 procedure Init(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0); inline;41 procedure SetXY(X, Y: integer); inline; // Set pixel position relative to base 42 procedure SetX(X: integer); inline; // Set horizontal pixel position relative to base 43 procedure Init(Bitmap: TRasterImage; BaseX: integer = 0; BaseY: integer = 0); inline; 44 44 end; 45 45 PPixelPointer = ^TPixelPointer; … … 58 58 procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture); 59 59 function HexStringToColor(s: string): integer; 60 function LoadGraphicFile(bmp: TBitmap; Path: string; 61 Options: integer = 0): boolean; 60 function LoadGraphicFile(bmp: TBitmap; Path: string; Options: integer = 0): boolean; 62 61 function LoadGraphicSet(const Name: string): integer; 63 62 procedure Dump(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, yGr: integer); 64 procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr, 65 yGr: integer);overload;66 procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, 67 yGr: integer);overload;63 procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr, yGr: integer); 64 overload; 65 procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, yGr: integer); 66 overload; 68 67 procedure MakeBlue(dst: TBitmap; x, y, w, h: integer); 69 68 procedure ImageOp_B(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h: integer); 70 procedure ImageOp_BCC(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h, Color1, 71 Color2: integer); 72 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, 73 Color2: integer); 74 function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer; SrcCanvas: TCanvas; 75 XSrc, YSrc: Integer; Rop: DWORD): Boolean; 69 procedure ImageOp_BCC(dst, Src: TBitmap; 70 xDst, yDst, xSrc, ySrc, w, h, Color1, Color2: integer); 71 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, Color2: integer); 72 function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: integer; 73 SrcCanvas: TCanvas; XSrc, YSrc: integer; Rop: DWORD): boolean; 76 74 procedure SLine(ca: TCanvas; x0, x1, y: integer; cl: TColor); 77 75 procedure DLine(ca: TCanvas; x0, x1, y: integer; cl0, cl1: TColor); … … 80 78 procedure CFrame(ca: TCanvas; x0, y0, x1, y1, Corner: integer; cl: TColor); 81 79 procedure FrameImage(ca: TCanvas; Src: TBitmap; 82 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = false);80 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False); 83 81 procedure GlowFrame(dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor); 84 82 procedure InitOrnament; 85 83 procedure InitCityMark(const T: TTexture); 86 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, 87 yOffset: integer); 84 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); 88 85 procedure FillLarge(ca: TCanvas; x0, y0, x1, y1, xm: integer); 89 procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, 90 yOffset: integer;const Texture: TBitmap);91 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, 92 yOffset: integer;const Texture: TBitmap);86 procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer; 87 const Texture: TBitmap); 88 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: integer; 89 const Texture: TBitmap); 93 90 procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer); 94 91 procedure Corner(ca: TCanvas; x, y, Kind: integer; const T: TTexture); 95 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; 96 s: string); 92 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; s: string); 97 93 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture; 98 94 x, y: integer; s: string); … … 105 101 procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer; 106 102 const T: TTexture); 107 procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer; Cap: string;108 val: integer; const T: TTexture);103 procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer; 104 Cap: string; val: integer; const T: TTexture); 109 105 procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer; 110 106 const T: TTexture); 111 procedure PaintRelativeProgressBar(ca: TCanvas; Kind, x, y, size, pos, Growth, 112 max: integer; IndicateComplete: boolean; const T: TTexture); 107 procedure PaintRelativeProgressBar(ca: TCanvas; 108 Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean; 109 const T: TTexture); 113 110 procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer); 114 111 function SetMainTextureByAge(Age: integer): boolean; … … 192 189 Name: string[31]; 193 190 Data, Mask: TBitmap; 194 pixUsed: array [ Byte] of Byte;191 pixUsed: array [byte] of byte; 195 192 end; 196 193 … … 210 207 MainTexture: TTexture; 211 208 Templates, Colors, Paper, BigImp, LogoBuffer: TBitmap; 212 FullScreen, GenerateNames, InitOrnamentDone, 213 Phrases2FallenBackToEnglish: boolean; 209 FullScreen, GenerateNames, InitOrnamentDone, Phrases2FallenBackToEnglish: boolean; 214 210 215 211 UniFont: array [TFontType] of TFont; … … 227 223 {$IFDEF WINDOWS} 228 224 StartResolution: TDeviceMode; 225 ResolutionChanged: boolean; 229 226 {$ENDIF} 230 ResolutionChanged: boolean;231 227 232 228 Gamma: integer; // global gamma correction (cent) 233 GammaLUT: array [0 .. 255] of Byte;229 GammaLUT: array [0 .. 255] of byte; 234 230 235 231 {$IFDEF WINDOWS} … … 245 241 DevMode.dmBitsPerPel := bpp; 246 242 DevMode.dmDisplayFrequency := freq; 247 result := ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL; 248 if result then 249 ResolutionChanged := true; 250 end; 243 Result := ChangeDisplaySettings(DevMode, 0) = DISP_CHANGE_SUCCESSFUL; 244 if Result then 245 ResolutionChanged := True; 246 end; 247 251 248 {$ENDIF} 252 249 … … 256 253 if ResolutionChanged then 257 254 ChangeDisplaySettings(StartResolution, 0); 255 ResolutionChanged := False; 258 256 {$ENDIF} 259 ResolutionChanged := false;260 257 end; 261 258 … … 270 267 if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then 271 268 begin 272 result := true;269 Result := True; 273 270 exit; 274 271 end; 275 272 WAVFileName := Sounds.Lookup(Item, Index); 276 273 assert(WAVFileName[1] <> '['); 277 result := (WAVFileName <> '') and (WAVFileName[1] <> '[') and 278 (WAVFileName <> '*'); 279 if result then 274 Result := (WAVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*'); 275 if Result then 280 276 // SndPlaySound(pchar(HomeDir+'Sounds' +DirectorySeparator+WAVFileName+'.wav'),SND_ASYNC) 281 PlaySound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName) 277 PlaySound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName); 282 278 {$ENDIF} 283 279 end; … … 294 290 WAVFileName := Sounds.Lookup(Item, Index); 295 291 assert(WAVFileName[1] <> '['); 296 if (WAVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*') 297 then 298 PrepareSound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName) 292 if (WAVFileName <> '') and (WAVFileName[1] <> '[') and (WAVFileName <> '*') then 293 PrepareSound(HomeDir + 'Sounds' + DirectorySeparator + WAVFileName); 299 294 {$ENDIF} 300 295 end; … … 316 311 i: integer; 317 312 begin 318 result := -4000;313 Result := -4000; 319 314 for i := 1 to Turn do 320 if result < -1000 then321 inc(result, 50) // 0..60322 else if result < 0 then323 inc(result, 25) // 60..100324 else if result < 1500 then325 inc(result, 20) // 100..175326 else if result < 1750 then327 inc(result, 10) // 175..200328 else if result < 1850 then329 inc(result, 2) // 200..250315 if Result < -1000 then 316 Inc(Result, 50) // 0..60 317 else if Result < 0 then 318 Inc(Result, 25) // 60..100 319 else if Result < 1500 then 320 Inc(Result, 20) // 100..175 321 else if Result < 1750 then 322 Inc(Result, 10) // 175..200 323 else if Result < 1850 then 324 Inc(Result, 2) // 200..250 330 325 else 331 inc(result);326 Inc(Result); 332 327 end; 333 328 … … 340 335 year := turntoyear(Turn); 341 336 if year < 0 then 342 result := Format(Phrases.Lookup('BC'), [-year])337 Result := Format(Phrases.Lookup('BC'), [-year]) 343 338 else 344 result := Format(Phrases.Lookup('AD'), [year]);339 Result := Format(Phrases.Lookup('AD'), [year]); 345 340 end 346 341 else 347 result := IntToStr(Turn)342 Result := IntToStr(Turn); 348 343 end; 349 344 … … 352 347 if Movement >= 1000 then 353 348 begin 354 result := char(48 + Movement div 1000);349 Result := char(48 + Movement div 1000); 355 350 Movement := Movement mod 1000; 356 351 end 357 352 else 358 result := '';359 result := result + char(48 + Movement div 100);353 Result := ''; 354 Result := Result + char(48 + Movement div 100); 360 355 Movement := Movement mod 100; 361 356 if Movement > 0 then 362 357 begin 363 result := result + '.' + char(48 + Movement div 10);358 Result := Result + '.' + char(48 + Movement div 10); 364 359 Movement := Movement mod 10; 365 360 if Movement > 0 then 366 result := result + char(48 + Movement);367 end 361 Result := Result + char(48 + Movement); 362 end; 368 363 end; 369 364 … … 371 366 begin 372 367 RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.clBevelShade, 373 T.clBevelLight) 368 T.clBevelLight); 374 369 end; 375 370 … … 380 375 Frame(ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000); 381 376 RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.clBevelShade, 382 T.clBevelLight) 377 T.clBevelLight); 383 378 end; 384 379 … … 389 384 case x of 390 385 '0' .. '9': 391 result := ord(x) - 48;386 Result := Ord(x) - 48; 392 387 'A' .. 'F': 393 result := ord(x) - 65 + 10;388 Result := Ord(x) - 65 + 10; 394 389 'a' .. 'f': 395 result := ord(x) - 97 + 10;396 else397 result := 0398 end 390 Result := Ord(x) - 97 + 10; 391 else 392 Result := 0 393 end; 399 394 end; 400 395 … … 404 399 s := s + '000000'; 405 400 if Gamma = 100 then 406 result := $10 * HexCharToInt(s[1]) + $1 * HexCharToInt(s[2]) + $1000 *407 HexCharToInt(s[3]) + $100 * HexCharToInt(s[4]) + $100000 *401 Result := $10 * HexCharToInt(s[1]) + $1 * HexCharToInt(s[2]) + 402 $1000 * HexCharToInt(s[3]) + $100 * HexCharToInt(s[4]) + $100000 * 408 403 HexCharToInt(s[5]) + $10000 * HexCharToInt(s[6]) 409 404 else 410 result := GammaLUT[$10 * HexCharToInt(s[1]) + HexCharToInt(s[2])] + $100 *411 GammaLUT[$10 * HexCharToInt(s[3]) + HexCharToInt(s[4])] + $10000 *412 GammaLUT[$10 * HexCharToInt(s[5]) + HexCharToInt(s[6])];405 Result := GammaLUT[$10 * HexCharToInt(s[1]) + HexCharToInt(s[2])] + 406 $100 * GammaLUT[$10 * HexCharToInt(s[3]) + HexCharToInt(s[4])] + 407 $10000 * GammaLUT[$10 * HexCharToInt(s[5]) + HexCharToInt(s[6])]; 413 408 end; 414 409 … … 416 411 var 417 412 PixelPtr: TPixelPointer; 418 X, Y: Integer;413 X, Y: integer; 419 414 begin 420 415 Bitmap.BeginUpdate; 421 416 PixelPtr.Init(Bitmap); 422 for Y := 0 to Bitmap.Height - 1 do begin 423 for X := 0 to Bitmap.Width - 1 do begin 417 for Y := 0 to Bitmap.Height - 1 do 418 begin 419 for X := 0 to Bitmap.Width - 1 do 420 begin 424 421 PixelPtr.Pixel^.B := GammaLUT[PixelPtr.Pixel^.B]; 425 422 PixelPtr.Pixel^.G := GammaLUT[PixelPtr.Pixel^.G]; … … 435 432 var 436 433 SrcPtr, DstPtr: TPixelPointer; 437 X, Y: Integer;434 X, Y: integer; 438 435 begin 439 436 //Dst.SetSize(Src.Width, Src.Height); 440 437 SrcPtr.Init(Src); 441 438 DstPtr.Init(Dst); 442 for Y := 0 to Src.Height - 1 do begin 443 for X := 0 to Src.Width - 1 do begin 439 for Y := 0 to Src.Height - 1 do 440 begin 441 for X := 0 to Src.Width - 1 do 442 begin 444 443 DstPtr.Pixel^.B := SrcPtr.Pixel^.B; 445 444 DstPtr.Pixel^.G := SrcPtr.Pixel^.B; … … 459 458 begin 460 459 Result := True; 461 if ExtractFileExt(Path) = '' then Path := Path + '.png'; 462 if ExtractFileExt(Path) = '.jpg' then begin 463 jtex := tjpegimage.create; 460 if ExtractFileExt(Path) = '' then 461 Path := Path + '.png'; 462 if ExtractFileExt(Path) = '.jpg' then 463 begin 464 jtex := tjpegimage.Create; 464 465 try 465 466 jtex.LoadFromFile(Path); … … 467 468 Result := False; 468 469 end; 469 if result then begin 470 if Options and gfNoGamma = 0 then bmp.PixelFormat := pf24bit; 470 if Result then 471 begin 472 if Options and gfNoGamma = 0 then 473 bmp.PixelFormat := pf24bit; 471 474 Bmp.SetSize(jtex.Width, jtex.Height); 472 475 Bmp.Canvas.Draw(0, 0, jtex); 473 476 end; 474 477 jtex.Free; 475 end else 476 if ExtractFileExt(Path) = '.png' then begin 478 end 479 else 480 if ExtractFileExt(Path) = '.png' then 481 begin 477 482 Png := TPortableNetworkGraphic.Create; 478 483 Png.PixelFormat := Bmp.PixelFormat; … … 482 487 Result := False; 483 488 end; 484 if Result then begin 485 if Options and gfNoGamma = 0 then bmp.PixelFormat := pf24bit; 489 if Result then 490 begin 491 if Options and gfNoGamma = 0 then 492 bmp.PixelFormat := pf24bit; 486 493 bmp.SetSize(Png.Width, Png.Height); 487 if (Png.RawImage.Description.Format = ricfGray) then begin 494 if (Png.RawImage.Description.Format = ricfGray) then 495 begin 488 496 // LCL doesn't support 8-bit colors properly. Use 24-bit instead. 489 497 Bmp.PixelFormat := pf24bit; 490 CopyGray8BitTo24bitBitmap(Bmp, Png) 491 end else Bmp.Canvas.draw(0, 0, Png); 498 CopyGray8BitTo24bitBitmap(Bmp, Png); 499 end 500 else 501 Bmp.Canvas.draw(0, 0, Png); 492 502 end; 493 503 Png.Free; 494 end else 495 if ExtractFileExt(Path) = '.bmp' then begin 504 end 505 else 506 if ExtractFileExt(Path) = '.bmp' then 507 begin 496 508 try 497 509 bmp.LoadFromFile(Path); … … 499 511 Result := False; 500 512 end; 501 if Result then begin 513 if Result then 514 begin 502 515 if Options and gfNoGamma = 0 then 503 516 bmp.PixelFormat := pf24bit; 504 end 505 end else 517 end; 518 end 519 else 506 520 raise Exception.Create('Unsupported image file type ' + ExtractFileExt(Path)); 507 521 508 if not Result then begin 522 if not Result then 523 begin 509 524 if Options and gfNoError = 0 then 510 raise Exception.Create(Format(Phrases.Lookup('FILENOTFOUND'), 511 [Path])); 525 raise Exception.Create(Format(Phrases.Lookup('FILENOTFOUND'), [Path])); 512 526 end; 513 527 … … 527 541 Inc(I); 528 542 Result := I; 529 if I = nGrExt then begin 543 if I = nGrExt then 544 begin 530 545 Source := TBitmap.Create; 531 546 Source.PixelFormat := pf24bit; 532 547 FileName := HomeDir + 'Graphics' + DirectorySeparator + Name; 533 if not LoadGraphicFile(Source, FileName) then begin 548 if not LoadGraphicFile(Source, FileName) then 549 begin 534 550 Result := -1; 535 551 Exit; … … 540 556 541 557 xmax := Source.Width - 1; // allows 4-byte access even for last pixel 542 if xmax > 970 then xmax := 970; 558 if xmax > 970 then 559 xmax := 970; 543 560 544 561 GrExt[nGrExt].Data := Source; 545 562 GrExt[nGrExt].Data.PixelFormat := pf24bit; 546 GrExt[nGrExt].Mask := TBitmap. create;563 GrExt[nGrExt].Mask := TBitmap.Create; 547 564 GrExt[nGrExt].Mask.PixelFormat := pf24bit; 548 565 GrExt[nGrExt].Mask.SetSize(Source.Width, Source.Height); … … 552 569 DataPixel.Init(GrExt[nGrExt].Data); 553 570 MaskPixel.Init(GrExt[nGrExt].Mask); 554 for y := 0 to Source.Height - 1 do begin 555 for x := 0 to xmax - 1 do begin 571 for y := 0 to Source.Height - 1 do 572 begin 573 for x := 0 to xmax - 1 do 574 begin 556 575 OriginalColor := DataPixel.Pixel^.ARGB and $FFFFFF; 557 if (OriginalColor = $FF00FF) or (OriginalColor = $7F007F) then begin // transparent 576 if (OriginalColor = $FF00FF) or (OriginalColor = $7F007F) then 577 begin // transparent 558 578 MaskPixel.Pixel^.ARGB := $FFFFFF; 559 DataPixel.Pixel^.ARGB := DataPixel.Pixel^.ARGB and $FF000000 560 end else begin 579 DataPixel.Pixel^.ARGB := DataPixel.Pixel^.ARGB and $FF000000; 580 end 581 else 582 begin 561 583 MaskPixel.Pixel^.ARGB := $000000; // non-transparent 562 if Gamma <> 100 then begin 584 if Gamma <> 100 then 585 begin 563 586 DataPixel.Pixel^.B := GammaLUT[DataPixel.Pixel^.B]; 564 587 DataPixel.Pixel^.G := GammaLUT[DataPixel.Pixel^.G]; … … 576 599 577 600 FillChar(GrExt[nGrExt].pixUsed, GrExt[nGrExt].Data.Height div 49 * 10, 0); 578 inc(nGrExt);601 Inc(nGrExt); 579 602 end; 580 603 end; … … 588 611 procedure MakeBlue(dst: TBitmap; x, y, w, h: integer); 589 612 var 590 XX, YY: Integer;613 XX, YY: integer; 591 614 PixelPtr: TPixelPointer; 592 615 begin 593 616 Dst.BeginUpdate; 594 617 PixelPtr.Init(Dst); 595 for yy := 0 to h - 1 do begin 596 for xx := 0 to w - 1 do begin 618 for yy := 0 to h - 1 do 619 begin 620 for xx := 0 to w - 1 do 621 begin 597 622 PixelPtr.Pixel^.B := PixelPtr.Pixel^.B div 2; 598 623 PixelPtr.Pixel^.G := PixelPtr.Pixel^.G div 2; … … 609 634 // X channel = background amp (old Dst content), 128=original brightness 610 635 var 611 X, Y: Integer;612 Brightness, Test: Integer;636 X, Y: integer; 637 Brightness, Test: integer; 613 638 PixelSrc: TPixelPointer; 614 639 PixelDst: TPixelPointer; 615 pf: TPixelFormat; 616 begin 617 pf := src.PixelFormat; 640 begin 618 641 //Assert(Src.PixelFormat = pf8bit); 619 642 Assert(dst.PixelFormat = pf24bit); … … 641 664 PixelDst.Init(Dst, xDst, yDst); 642 665 PixelSrc.Init(Src, xSrc, ySrc); 643 for Y := 0 to h - 1 do begin 644 for X := 0 to w - 1 do begin 666 for Y := 0 to h - 1 do 667 begin 668 for X := 0 to w - 1 do 669 begin 645 670 Brightness := PixelSrc.Pixel^.B; // One byte for 8-bit color 646 671 test := (PixelDst.Pixel^.R * Brightness) shr 7; 647 if test >= 256 then PixelDst.Pixel^.R := 255 648 else PixelDst.Pixel^.R := test; // Red 672 if test >= 256 then 673 PixelDst.Pixel^.R := 255 674 else 675 PixelDst.Pixel^.R := test; // Red 649 676 test := (PixelDst.Pixel^.G * Brightness) shr 7; 650 if test >= 256 then PixelDst.Pixel^.G := 255 651 else PixelDst.Pixel^.G := test; // Green 677 if test >= 256 then 678 PixelDst.Pixel^.G := 255 679 else 680 PixelDst.Pixel^.G := test; // Green 652 681 test := (PixelDst.Pixel^.B * Brightness) shr 7; 653 if test >= 256 then PixelDst.Pixel^.R := 255 654 else PixelDst.Pixel^.B := Test; // Blue 682 if test >= 256 then 683 PixelDst.Pixel^.R := 255 684 else 685 PixelDst.Pixel^.B := Test; // Blue 655 686 PixelDst.NextPixel; 656 687 PixelSrc.NextPixel; … … 663 694 end; 664 695 665 procedure ImageOp_BCC(dst, Src: TBitmap; xDst, yDst, xSrc, ySrc, w, h, Color1,666 Color2: integer);696 procedure ImageOp_BCC(dst, Src: TBitmap; 697 xDst, yDst, xSrc, ySrc, w, h, Color1, Color2: integer); 667 698 // Src is template 668 699 // B channel = background amp (old Dst content), 128=original brightness … … 673 704 SrcPixel, DstPixel: TPixelPointer; 674 705 begin 675 if xDst < 0 then begin 706 if xDst < 0 then 707 begin 676 708 w := w + xDst; 677 709 xSrc := xSrc - xDst; 678 710 xDst := 0; 679 711 end; 680 if yDst < 0 then begin 712 if yDst < 0 then 713 begin 681 714 h := h + yDst; 682 715 ySrc := ySrc - yDst; … … 694 727 SrcPixel.Init(Src, xSrc, ySrc); 695 728 DstPixel.Init(Dst, xDst, yDst); 696 for iy := 0 to h - 1 do begin 697 for ix := 0 to w - 1 do begin 729 for iy := 0 to h - 1 do 730 begin 731 for ix := 0 to w - 1 do 732 begin 698 733 trans := SrcPixel.Pixel^.B * 2; // green channel = transparency 699 734 amp1 := SrcPixel.Pixel^.G * 2; 700 735 amp2 := SrcPixel.Pixel^.R * 2; 701 if trans <> $FF then begin 702 Value := (DstPixel.Pixel^.B * trans + ((Color2 shr 16) and $FF) * amp2 703 + ((Color1 shr 16) and $FF) * amp1) div $FF; 704 if Value < 256 then DstPixel.Pixel^.B := Value 705 else DstPixel.Pixel^.B := 255; 706 Value := (DstPixel.Pixel^.G * trans + ((Color2 shr 8) and $FF) * amp2 707 + ((Color1 shr 8) and $FF) * amp1) div $FF; 708 if Value < 256 then DstPixel.Pixel^.G := Value 709 else DstPixel.Pixel^.G := 255; 710 Value := (DstPixel.Pixel^.R * trans + (Color2 and $FF) * amp2 + 711 (Color1 and $FF) * amp1) div $FF; 712 if Value < 256 then DstPixel.Pixel^.R := Value 713 else DstPixel.Pixel^.R := 255; 736 if trans <> $FF then 737 begin 738 Value := (DstPixel.Pixel^.B * trans + ((Color2 shr 16) and $FF) * 739 amp2 + ((Color1 shr 16) and $FF) * amp1) div $FF; 740 if Value < 256 then 741 DstPixel.Pixel^.B := Value 742 else 743 DstPixel.Pixel^.B := 255; 744 Value := (DstPixel.Pixel^.G * trans + ((Color2 shr 8) and $FF) * 745 amp2 + ((Color1 shr 8) and $FF) * amp1) div $FF; 746 if Value < 256 then 747 DstPixel.Pixel^.G := Value 748 else 749 DstPixel.Pixel^.G := 255; 750 Value := (DstPixel.Pixel^.R * trans + (Color2 and $FF) * 751 amp2 + (Color1 and $FF) * amp1) div $FF; 752 if Value < 256 then 753 DstPixel.Pixel^.R := Value 754 else 755 DstPixel.Pixel^.R := 255; 714 756 end; 715 757 SrcPixel.NextPixel; … … 723 765 end; 724 766 725 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, 726 Color2: integer); 767 procedure ImageOp_CCC(bmp: TBitmap; x, y, w, h, Color0, Color1, Color2: integer); 727 768 // Bmp is template 728 769 // B channel = Color0 amp, 128=original brightness … … 737 778 h := y + h; 738 779 PixelPtr.Init(Bmp, x, y); 739 while y < h do begin 740 for i := 0 to w - 1 do begin 741 Red := ((PixelPtr.Pixel^.B * (Color0 and $0000FF) + PixelPtr.Pixel^.G * (Color1 and $0000FF) 742 + PixelPtr.Pixel^.R * (Color2 and $0000FF)) shr 8) and $ff; 743 Green := ((PixelPtr.Pixel^.B * ((Color0 shr 8) and $0000FF) + PixelPtr.Pixel^.G * 744 ((Color1 shr 8) and $0000FF) + PixelPtr.Pixel^.R * ((Color2 shr 8) and 745 $0000FF)) shr 8) and $ff; 746 PixelPtr.Pixel^.B := ((PixelPtr.Pixel^.B * ((Color0 shr 16) and $0000FF) + PixelPtr.Pixel^.G * 747 ((Color1 shr 16) and $0000FF) + PixelPtr.Pixel^.R * ((Color2 shr 16) and $0000FF)) 748 shr 8) and $ff; // Blue 780 while y < h do 781 begin 782 for i := 0 to w - 1 do 783 begin 784 Red := ((PixelPtr.Pixel^.B * (Color0 and $0000FF) + PixelPtr.Pixel^.G * 785 (Color1 and $0000FF) + PixelPtr.Pixel^.R * (Color2 and $0000FF)) shr 8) and $ff; 786 Green := ((PixelPtr.Pixel^.B * ((Color0 shr 8) and $0000FF) + 787 PixelPtr.Pixel^.G * ((Color1 shr 8) and $0000FF) + PixelPtr.Pixel^.R * 788 ((Color2 shr 8) and $0000FF)) shr 8) and $ff; 789 PixelPtr.Pixel^.B := ((PixelPtr.Pixel^.B * ((Color0 shr 16) and $0000FF) + 790 PixelPtr.Pixel^.G * ((Color1 shr 16) and $0000FF) + PixelPtr.Pixel^.R * 791 ((Color2 shr 16) and $0000FF)) shr 8) and $ff; // Blue 749 792 PixelPtr.Pixel^.G := Green; 750 793 PixelPtr.Pixel^.R := Red; 751 794 PixelPtr.NextPixel; 752 795 end; 753 inc(y);796 Inc(y); 754 797 PixelPtr.NextLine; 755 798 end; … … 757 800 end; 758 801 759 procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr, 760 yGr: integer); 802 procedure Sprite(Canvas: TCanvas; HGr, xDst, yDst, Width, Height, xGr, yGr: integer); 761 803 begin 762 804 BitBlt(Canvas.Handle, xDst, yDst, Width, Height, … … 766 808 end; 767 809 768 procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, 769 yGr: integer); 810 procedure Sprite(dst: TBitmap; HGr, xDst, yDst, Width, Height, xGr, yGr: integer); 770 811 begin 771 812 BitBlt(dst.Canvas.Handle, xDst, yDst, Width, Height, … … 775 816 end; 776 817 777 function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: Integer; SrcCanvas: TCanvas; XSrc,778 YSrc: Integer; Rop: DWORD): Boolean;818 function BitBltCanvas(DestCanvas: TCanvas; X, Y, Width, Height: integer; 819 SrcCanvas: TCanvas; XSrc, YSrc: integer; Rop: DWORD): boolean; 779 820 begin 780 821 Assert(Rop = SRCCOPY); … … 791 832 MoveTo(x0, y); 792 833 LineTo(x1 + 1, y); 793 end 834 end; 794 835 end; 795 836 … … 806 847 Pixels[x0, y + 1] := cl0; 807 848 Pixels[x1, y] := cl1; 808 end 849 end; 809 850 end; 810 851 … … 820 861 LineTo(x1, y1); 821 862 LineTo(x0, y1); 822 end 863 end; 823 864 end; 824 865 … … 837 878 MoveTo(x0 + 1, y1); 838 879 LineTo(x1, y1); 839 end 880 end; 840 881 end; 841 882 … … 857 898 LineTo(x0, y1); 858 899 LineTo(x0 + Corner, y1); 859 end 900 end; 860 901 end; 861 902 862 903 procedure FrameImage(ca: TCanvas; Src: TBitmap; 863 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = false);904 x, y, Width, Height, xSrc, ySrc: integer; IsControl: boolean = False); 864 905 begin 865 906 if IsControl then … … 934 975 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := light 935 976 else if p = $FF0000 then 936 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := shade 937 end; 938 InitOrnamentDone := true977 GrExt[HGrSystem2].Data.Canvas.Pixels[xOrna + x, yOrna + y] := shade; 978 end; 979 InitOrnamentDone := True; 939 980 end; 940 981 … … 947 988 if GrExt[HGrSystem].Mask.Canvas.Pixels[66 + x, 47 + y] = 0 then 948 989 begin 949 intensity := GrExt[HGrSystem].Data.Canvas.Pixels 950 [66 +x, 47 + y] and $FF;951 GrExt[HGrSystem].Data.Canvas.Pixels[77 + x, 47 + y] := T.clMark and952 $FF * intensity div $FF + T.clMark shr 8 and990 intensity := GrExt[HGrSystem].Data.Canvas.Pixels[66 + 991 x, 47 + y] and $FF; 992 GrExt[HGrSystem].Data.Canvas.Pixels[77 + x, 47 + y] := 993 T.clMark and $FF * intensity div $FF + T.clMark shr 8 and 953 994 $FF * intensity div $FF shl 8 + T.clMark shr 16 and 954 $FF * intensity div $FF shl 16 995 $FF * intensity div $FF shl 16; 955 996 end; 956 997 BitBlt(GrExt[HGrSystem].Mask.Canvas.Handle, 77, 47, 10, 10, … … 958 999 end; 959 1000 960 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, 961 yOffset: integer); 1001 procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); 962 1002 begin 963 1003 Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= wMainTexture) and … … 975 1015 n := ((hMainTexture div 2) div (y1 - y0)) * 2; 976 1016 while hMainTexture div 2 + (i + 1) * (y1 - y0) > hMainTexture do 977 dec(i, n);1017 Dec(i, n); 978 1018 while hMainTexture div 2 + i * (y1 - y0) < 0 do 979 inc(i, n);980 result := i;1019 Inc(i, n); 1020 Result := i; 981 1021 end; 982 1022 … … 990 1030 BitBlt(ca.Handle, xm + ((x1 - xm) div wMainTexture) * wMainTexture, y0, 991 1031 x1 - (xm + ((x1 - xm) div wMainTexture) * wMainTexture), y1 - y0, 992 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + 993 band((x1 - xm) div wMainTexture) * (y1 - y0), SRCCOPY);1032 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band( 1033 (x1 - xm) div wMainTexture) * (y1 - y0), SRCCOPY); 994 1034 for i := 0 to (xm - x0) div wMainTexture - 1 do 995 1035 BitBlt(ca.Handle, xm - (i + 1) * wMainTexture, y0, wMainTexture, y1 - y0, 996 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + band(-i - 1) *997 (y1 - y0), SRCCOPY);998 BitBlt(ca.Handle, x0, y0, xm - ((xm - x0) div wMainTexture) * wMainTexture -999 x0, y1 - y0, MainTexture.Image.Canvas.Handle,1036 MainTexture.Image.Canvas.Handle, 0, hMainTexture div 2 + 1037 band(-i - 1) * (y1 - y0), SRCCOPY); 1038 BitBlt(ca.Handle, x0, y0, xm - ((xm - x0) div wMainTexture) * 1039 wMainTexture - x0, y1 - y0, MainTexture.Image.Canvas.Handle, 1000 1040 ((xm - x0) div wMainTexture + 1) * wMainTexture - (xm - x0), 1001 hMainTexture div 2 + band(-(xm - x0) div wMainTexture - 1) * 1002 (y1 - y0), SRCCOPY); 1003 end; 1004 1005 procedure FillSeamless(ca: TCanvas; Left, Top, Width, Height, xOffset, 1006 yOffset: integer; const Texture: TBitmap); 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; 1045 const Texture: TBitmap); 1007 1046 var 1008 1047 x, y, x0cut, y0cut, x1cut, y1cut: integer; 1009 1048 begin 1010 1049 while xOffset < 0 do 1011 inc(xOffset, Texture.Width);1050 Inc(xOffset, Texture.Width); 1012 1051 while yOffset < 0 do 1013 inc(yOffset, Texture.Height);1014 for y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) 1015 divTexture.Height do1052 Inc(yOffset, Texture.Height); 1053 for y := (Top + yOffset) div Texture.Height to (Top + yOffset + Height - 1) div 1054 Texture.Height do 1016 1055 begin 1017 1056 y0cut := Top + yOffset - y * Texture.Height; … … 1021 1060 if y1cut < 0 then 1022 1061 y1cut := 0; 1023 for x := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) 1024 divTexture.Width do1062 for x := (Left + xOffset) div Texture.Width to (Left + xOffset + Width - 1) div 1063 Texture.Width do 1025 1064 begin 1026 1065 x0cut := Left + xOffset - x * Texture.Width; … … 1038 1077 end; 1039 1078 1040 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, 1041 yOffset: integer;const Texture: TBitmap);1079 procedure FillRectSeamless(ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: integer; 1080 const Texture: TBitmap); 1042 1081 begin 1043 1082 FillSeamless(ca, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture); … … 1046 1085 procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer); 1047 1086 begin 1048 Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth) 1049 div2, (hMainTexture - Form.ClientHeight) div 2);1087 Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth) div 1088 2, (hMainTexture - Form.ClientHeight) div 2); 1050 1089 end; 1051 1090 … … 1058 1097 end; 1059 1098 1060 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; 1061 s: string); 1099 procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; s: string); 1062 1100 1063 1101 procedure PaintIcon(x, y, Kind: integer); … … 1074 1112 shadow: boolean; 1075 1113 begin 1076 inc(x);1077 inc(y);1078 for shadow := true downto false do1114 Inc(x); 1115 Inc(y); 1116 for shadow := True downto False do 1079 1117 with ca do 1080 1118 if not shadow or (clBack <> $7F007F) then … … 1088 1126 repeat 1089 1127 p := pos('%', sp); 1090 if (p = 0) or (p + 1 > Length(sp)) or 1091 not(sp[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1092 then 1128 if (p = 0) or (p + 1 > Length(sp)) or not 1129 (sp[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then 1093 1130 begin 1094 1131 ca.Textout(xp, y, sp); 1095 break 1132 break; 1096 1133 end 1097 1134 else 1098 1135 begin 1099 1136 Textout(xp, y, copy(sp, 1, p - 1)); 1100 inc(xp, ca.TextWidth(copy(sp, 1, p - 1)));1137 Inc(xp, ca.TextWidth(copy(sp, 1, p - 1))); 1101 1138 if not shadow then 1102 1139 case sp[p + 1] of … … 1122 1159 PaintIcon(xp + 1, y, 13); 1123 1160 end; 1124 inc(xp, 10);1161 Inc(xp, 10); 1125 1162 Delete(sp, 1, p + 1); 1126 1163 end 1127 until false; 1128 dec(x); 1129 dec(y); 1130 end 1164 until False; 1165 Dec(x); 1166 Dec(y); 1131 1167 end; 1132 1133 function BiColorTextWidth(ca: TCanvas; s: string): integer; 1134 var 1135 p: integer; 1136 begin 1137 result := 1; 1138 repeat 1139 p := pos('%', s); 1140 if (p = 0) or (p = Length(s)) then 1168 end; 1169 1170 function BiColorTextWidth(ca: TCanvas; s: string): integer; 1171 var 1172 p: integer; 1173 begin 1174 Result := 1; 1175 repeat 1176 p := pos('%', s); 1177 if (p = 0) or (p = Length(s)) then 1178 begin 1179 Inc(Result, ca.TextWidth(s)); 1180 break; 1181 end 1182 else 1183 begin 1184 if not (s[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1185 then 1186 Inc(Result, ca.TextWidth(copy(s, 1, p + 1))) 1187 else 1188 Inc(Result, ca.TextWidth(copy(s, 1, p - 1)) + 10); 1189 Delete(s, 1, p + 1); 1190 end 1191 until False; 1192 end; 1193 1194 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture; 1195 x, y: integer; s: string); 1196 begin 1197 if cl = -2 then 1198 BiColorTextOut(ca, (T.clBevelShade and $FEFEFE) shr 1, 1199 T.clBevelLight, x, y, s) 1200 else if cl < 0 then 1201 BiColorTextOut(ca, T.clTextShade, T.clTextLight, x, y, s) 1202 else 1203 BiColorTextOut(ca, cl, T.clTextLight, x, y, s); 1204 end; 1205 1206 procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string); 1207 begin 1208 BiColorTextOut(ca, $FFFFFF, $000000, x, y, s); 1209 end; 1210 1211 procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: integer; 1212 Brightness: array of integer); 1213 var 1214 i, r, g, b: integer; 1215 begin 1216 begin 1217 for i := 0 to 15 do 1218 begin // gradient 1219 r := Color and $FF + Brightness[i]; 1220 if r < 0 then 1221 r := 0 1222 else if r >= 256 then 1223 r := 255; 1224 g := Color shr 8 and $FF + Brightness[i]; 1225 if g < 0 then 1226 g := 0 1227 else if g >= 256 then 1228 g := 255; 1229 b := Color shr 16 and $FF + Brightness[i]; 1230 if b < 0 then 1231 b := 0 1232 else if b >= 256 then 1233 b := 255; 1234 ca.Pen.Color := r + g shl 8 + b shl 16; 1235 ca.MoveTo(x + dx * i, y + dy * i); 1236 ca.LineTo(x + dx * i + Width, y + dy * i + Height); 1237 end; 1238 ca.Pen.Color := $000000; 1239 ca.MoveTo(x + 1, y + 16 * dy + Height); 1240 ca.LineTo(x + 16 * dx + Width, y + 16 * dy + Height); 1241 ca.LineTo(x + 16 * dx + Width, y); 1242 end; 1243 end; 1244 1245 procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer); 1246 const 1247 Brightness: array [0 .. 15] of integer = 1248 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1249 begin 1250 Gradient(ca, x, y, 0, 1, Width, 0, Color, Brightness); 1251 end; 1252 1253 procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer); 1254 const 1255 Brightness: array [0 .. 15] of integer = 1256 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1257 begin 1258 Gradient(ca, x, y, 0, 1, Width, 0, GrExt[HGrSystem].Data.Canvas.Pixels 1259 [187, 137 + Kind], Brightness); 1260 end; 1261 1262 procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer); 1263 const 1264 Brightness: array [0 .. 15] of integer = 1265 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1266 begin 1267 Gradient(ca, x, y, 1, 0, 0, Height, Color, Brightness); 1268 end; 1269 1270 procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer); 1271 const 1272 Brightness: array [0 .. 15] of integer = 1273 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1274 begin 1275 Gradient(ca, x, y, 1, 0, 0, Height, 1276 GrExt[HGrSystem].Data.Canvas.Pixels[187, 137 + Kind], Brightness); 1277 end; 1278 1279 procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; 1280 val: integer; const T: TTexture); 1281 var 1282 s: string; 1283 begin 1284 if val > 0 then 1285 begin 1286 DLine(dst.Canvas, x - 2, x + 170, y + 16, T.clBevelShade, 1287 T.clBevelLight); 1288 LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap); 1289 s := IntToStr(val); 1290 RisedTextOut(dst.Canvas, x + 170 - BiColorTextWidth(dst.Canvas, 1291 s), y, s); 1292 end; 1293 end; 1294 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; 1299 s: string; 1300 begin 1301 // val:=random(40); //!!! 1302 if val = 0 then 1303 exit; 1304 assert(Kind >= 0); 1305 with dst.Canvas do 1306 begin 1307 // xIcon:=x+100; 1308 // yIcon:=y; 1309 // DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight); 1310 1311 xIcon := x - 5; 1312 yIcon := y + 15; 1313 DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.clBevelShade, 1314 T.clBevelLight); 1315 1316 s := IntToStr(val); 1317 if val < 0 then 1318 cl := $0000FF 1319 else 1320 cl := -1; 1321 LoweredTextOut(dst.Canvas, cl, T, x - 2, y, Cap); 1322 LoweredTextOut(dst.Canvas, cl, T, 1323 xIcon + w + 2 - BiColorTextWidth(dst.Canvas, s), yIcon, s); 1324 1325 if (Kind = 12) and (val >= 100) then 1326 begin // science with symbol for 100 1327 val := val div 10; 1328 sd := 14 * (val div 10 + val mod 10 - 1); 1329 if sd = 0 then 1330 sd := 1; 1331 if sd < w - 44 then 1332 ld := sd 1333 else 1334 ld := w - 44; 1335 for i := 0 to val mod 10 - 1 do 1141 1336 begin 1142 inc(result, ca.TextWidth(s)); 1143 break 1144 end 1337 BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 2 + 1, 14, 1338 14, GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15, 1339 70 + Kind div 8 * 15, SRCAND); 1340 Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2, 1341 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1342 end; 1343 for i := 0 to val div 10 - 1 do 1344 begin 1345 BitBlt(dst.Canvas.Handle, xIcon + 4 + (val mod 10) * 1346 (14 * ld div sd) + i * (14 * ld div sd), yIcon + 3, 14, 14, 1347 GrExt[HGrSystem].Mask.Canvas.Handle, 67 + 7 mod 8 * 15, 1348 70 + 7 div 8 * 15, SRCAND); 1349 Sprite(dst, HGrSystem, xIcon + 3 + (val mod 10) * 1350 (14 * ld div sd) + i * (14 * ld div sd), yIcon + 2, 14, 1351 14, 67 + 7 mod 8 * 15, 1352 70 + 7 div 8 * 15); 1353 end; 1354 end 1355 else 1356 begin 1357 val := abs(val); 1358 if val mod 10 = 0 then 1359 sd := 14 * (val div 10 - 1) 1145 1360 else 1361 sd := 10 * (val mod 10 - 1) + 14 * (val div 10); 1362 if sd = 0 then 1363 sd := 1; 1364 if sd < w - 44 then 1365 ld := sd 1366 else 1367 ld := w - 44; 1368 for i := 0 to val div 10 - 1 do 1146 1369 begin 1147 if not(s[p + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1148 then 1149 inc(result, ca.TextWidth(copy(s, 1, p + 1))) 1150 else 1151 inc(result, ca.TextWidth(copy(s, 1, p - 1)) + 10); 1152 Delete(s, 1, p + 1); 1153 end 1154 until false; 1155 end; 1156 1157 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture; 1158 x, y: integer; s: string); 1159 begin 1160 if cl = -2 then 1161 BiColorTextOut(ca, (T.clBevelShade and $FEFEFE) shr 1, 1162 T.clBevelLight, x, y, s) 1163 else if cl < 0 then 1164 BiColorTextOut(ca, T.clTextShade, T.clTextLight, x, y, s) 1165 else 1166 BiColorTextOut(ca, cl, T.clTextLight, x, y, s) 1167 end; 1168 1169 procedure RisedTextOut(ca: TCanvas; x, y: integer; s: string); 1170 begin 1171 BiColorTextOut(ca, $FFFFFF, $000000, x, y, s) 1172 end; 1173 1174 procedure Gradient(ca: TCanvas; x, y, dx, dy, Width, Height, Color: integer; 1175 Brightness: array of integer); 1176 var 1177 i, r, g, b: integer; 1178 begin 1370 BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 3, 14, 14, 1371 GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15, 1372 70 + Kind div 8 * 15, SRCAND); 1373 Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2, 1374 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1375 end; 1376 for i := 0 to val mod 10 - 1 do 1179 1377 begin 1180 for i := 0 to 15 do 1181 begin // gradient 1182 r := Color and $FF + Brightness[i]; 1183 if r < 0 then 1184 r := 0 1185 else if r >= 256 then 1186 r := 255; 1187 g := Color shr 8 and $FF + Brightness[i]; 1188 if g < 0 then 1189 g := 0 1190 else if g >= 256 then 1191 g := 255; 1192 b := Color shr 16 and $FF + Brightness[i]; 1193 if b < 0 then 1194 b := 0 1195 else if b >= 256 then 1196 b := 255; 1197 ca.Pen.Color := r + g shl 8 + b shl 16; 1198 ca.MoveTo(x + dx * i, y + dy * i); 1199 ca.LineTo(x + dx * i + Width, y + dy * i + Height); 1200 end; 1201 ca.Pen.Color := $000000; 1202 ca.MoveTo(x + 1, y + 16 * dy + Height); 1203 ca.LineTo(x + 16 * dx + Width, y + 16 * dy + Height); 1204 ca.LineTo(x + 16 * dx + Width, y); 1205 end 1206 end; 1207 1208 procedure LightGradient(ca: TCanvas; x, y, Width, Color: integer); 1209 const 1210 Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, -12, 1211 -16, -20, -24, -28, -32, -36, -40, -44); 1212 begin 1213 Gradient(ca, x, y, 0, 1, Width, 0, Color, Brightness) 1214 end; 1215 1216 procedure DarkGradient(ca: TCanvas; x, y, Width, Kind: integer); 1217 const 1218 Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, 1219 -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1220 begin 1221 Gradient(ca, x, y, 0, 1, Width, 0, GrExt[HGrSystem].Data.Canvas.Pixels 1222 [187, 137 + Kind], Brightness) 1223 end; 1224 1225 procedure VLightGradient(ca: TCanvas; x, y, Height, Color: integer); 1226 const 1227 Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, -12, 1228 -16, -20, -24, -28, -32, -36, -40, -44); 1229 begin 1230 Gradient(ca, x, y, 1, 0, 0, Height, Color, Brightness) 1231 end; 1232 1233 procedure VDarkGradient(ca: TCanvas; x, y, Height, Kind: integer); 1234 const 1235 Brightness: array [0 .. 15] of integer = (16, 12, 8, 4, 0, -4, -8, 1236 -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1237 begin 1238 Gradient(ca, x, y, 1, 0, 0, Height, GrExt[HGrSystem].Data.Canvas.Pixels 1239 [187, 137 + Kind], Brightness) 1240 end; 1241 1242 procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer; 1243 const T: TTexture); 1244 var 1245 s: string; 1246 begin 1247 if val > 0 then 1248 begin 1249 DLine(dst.Canvas, x - 2, x + 170, y + 16, T.clBevelShade, 1250 T.clBevelLight); 1251 LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap); 1252 s := IntToStr(val); 1253 RisedTextOut(dst.Canvas, x + 170 - BiColorTextWidth(dst.Canvas, 1254 s), y, s); 1255 end 1256 end; 1257 1258 procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer; 1259 Cap: string; val: integer; const T: TTexture); 1260 var 1261 i, sd, ld, cl, xIcon, yIcon: integer; 1262 s: string; 1263 begin 1264 // val:=random(40); //!!! 1265 if val = 0 then 1266 exit; 1267 assert(Kind >= 0); 1268 with dst.Canvas do 1269 begin 1270 // xIcon:=x+100; 1271 // yIcon:=y; 1272 // DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight); 1273 1274 xIcon := x - 5; 1275 yIcon := y + 15; 1276 DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.clBevelShade, 1277 T.clBevelLight); 1278 1279 s := IntToStr(val); 1280 if val < 0 then 1281 cl := $0000FF 1282 else 1283 cl := -1; 1284 LoweredTextOut(dst.Canvas, cl, T, x - 2, y, Cap); 1285 LoweredTextOut(dst.Canvas, cl, T, 1286 xIcon + w + 2 - BiColorTextWidth(dst.Canvas, s), yIcon, s); 1287 1288 if (Kind = 12) and (val >= 100) then 1289 begin // science with symbol for 100 1290 val := val div 10; 1291 sd := 14 * (val div 10 + val mod 10 - 1); 1292 if sd = 0 then 1293 sd := 1; 1294 if sd < w - 44 then 1295 ld := sd 1296 else 1297 ld := w - 44; 1298 for i := 0 to val mod 10 - 1 do 1299 begin 1300 BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 2 + 1, 14, 1301 14, GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15, 1302 70 + Kind div 8 * 15, SRCAND); 1303 Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2, 1304 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1305 end; 1306 for i := 0 to val div 10 - 1 do 1307 begin 1308 BitBlt(dst.Canvas.Handle, xIcon + 4 + (val mod 10) * 1309 (14 * ld div sd) + i * (14 * ld div sd), yIcon + 3, 14, 14, 1310 GrExt[HGrSystem].Mask.Canvas.Handle, 67 + 7 mod 8 * 15, 1311 70 + 7 div 8 * 15, SRCAND); 1312 Sprite(dst, HGrSystem, xIcon + 3 + (val mod 10) * (14 * ld div sd) + 1313 i * (14 * ld div sd), yIcon + 2, 14, 14, 67 + 7 mod 8 * 15, 1314 70 + 7 div 8 * 15); 1315 end; 1316 end 1317 else 1318 begin 1319 val := abs(val); 1320 if val mod 10 = 0 then 1321 sd := 14 * (val div 10 - 1) 1322 else 1323 sd := 10 * (val mod 10 - 1) + 14 * (val div 10); 1324 if sd = 0 then 1325 sd := 1; 1326 if sd < w - 44 then 1327 ld := sd 1328 else 1329 ld := w - 44; 1330 for i := 0 to val div 10 - 1 do 1331 begin 1332 BitBlt(Handle, xIcon + 4 + i * (14 * ld div sd), yIcon + 3, 14, 14, 1333 GrExt[HGrSystem].Mask.Canvas.Handle, 67 + Kind mod 8 * 15, 1334 70 + Kind div 8 * 15, SRCAND); 1335 Sprite(dst, HGrSystem, xIcon + 3 + i * (14 * ld div sd), yIcon + 2, 1336 14, 14, 67 + Kind mod 8 * 15, 70 + Kind div 8 * 15); 1337 end; 1338 for i := 0 to val mod 10 - 1 do 1339 begin 1340 BitBlt(dst.Canvas.Handle, xIcon + 4 + (val div 10) * 1341 (14 * ld div sd) + i * (10 * ld div sd), yIcon + 7, 10, 10, 1342 GrExt[HGrSystem].Mask.Canvas.Handle, 66 + Kind mod 11 * 11, 1343 115 + Kind div 11 * 11, SRCAND); 1344 Sprite(dst, HGrSystem, xIcon + 3 + (val div 10) * (14 * ld div sd) + 1345 i * (10 * ld div sd), yIcon + 6, 10, 10, 66 + Kind mod 11 * 11, 1346 115 + Kind div 11 * 11) 1347 end; 1348 end 1349 end 1350 end; // CountBar 1351 1352 procedure PaintProgressBar(ca: TCanvas; 1353 Kind, x, y, pos, Growth, max: integer; const T: TTexture); 1354 var 1355 i: integer; 1356 begin 1357 if pos > max then 1358 pos := max; 1359 if Growth < 0 then 1360 begin 1361 pos := pos + Growth; 1362 if pos < 0 then 1363 begin 1364 Growth := Growth - pos; 1365 pos := 0 1366 end 1367 end 1368 else if pos + Growth > max then 1369 Growth := max - pos; 1370 Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000); 1371 RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.clBevelShade, 1372 T.clBevelLight); 1373 with ca do 1374 begin 1375 for i := 0 to pos div 8 - 1 do 1376 BitBlt(Handle, x + i * 8, y, 8, 7, 1377 GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY); 1378 BitBlt(Handle, x + 8 * (pos div 8), y, pos - 8 * (pos div 8), 7, 1379 GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY); 1380 if Growth > 0 then 1381 begin 1382 for i := 0 to Growth div 8 - 1 do 1383 BitBlt(Handle, x + pos + i * 8, y, 8, 7, 1384 GrExt[HGrSystem].Data.Canvas.Handle, 112, 9 + 8 * Kind, SRCCOPY); 1385 BitBlt(Handle, x + pos + 8 * (Growth div 8), y, 1386 Growth - 8 * (Growth div 8), 7, GrExt[HGrSystem].Data.Canvas.Handle, 1387 112, 9 + 8 * Kind, SRCCOPY); 1388 end 1389 else if Growth < 0 then 1390 begin 1391 for i := 0 to -Growth div 8 - 1 do 1392 BitBlt(Handle, x + pos + i * 8, y, 8, 7, 1393 GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY); 1394 BitBlt(Handle, x + pos + 8 * (-Growth div 8), y, 1395 -Growth - 8 * (-Growth div 8), 7, 1396 GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY); 1397 end; 1398 Brush.Color := $000000; 1399 FillRect(Rect(x + pos + abs(Growth), y, x + max, y + 7)); 1400 Brush.Style := bsClear; 1401 end 1402 end; 1403 1404 // pos and growth are relative to max, set size independent 1405 procedure PaintRelativeProgressBar(ca: TCanvas; 1406 Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean; 1407 const T: TTexture); 1408 begin 1409 if Growth > 0 then 1410 PaintProgressBar(ca, Kind, x, y, pos * size div max, 1411 (Growth * size + max div 2) div max, size, T) 1412 else 1413 PaintProgressBar(ca, Kind, x, y, pos * size div max, 1414 (Growth * size - max div 2) div max, size, T); 1415 if IndicateComplete and (pos + Growth >= max) then 1416 Sprite(ca, HGrSystem, x + size - 10, y - 7, 23, 16, 1, 129); 1417 end; 1418 1419 procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer); 1420 begin 1421 BitBltCanvas(LogoBuffer.Canvas, 0, 0, wLogo, hLogo, ca, x, 1422 y, SRCCOPY); 1423 ImageOp_BCC(LogoBuffer, Templates, 0, 0, 1, 1, wLogo, hLogo, 1424 clLight, clShade); 1425 BitBlt(ca.Handle, x, y, wLogo, hLogo, LogoBuffer.Canvas.Handle, 0, 1426 0, SRCCOPY); 1427 end; 1428 1429 function SetMainTextureByAge(Age: integer): boolean; 1430 begin 1431 if Age <> MainTextureAge then 1432 with MainTexture do 1433 begin 1434 MainTextureAge := Age; 1435 LoadGraphicFile(Image, HomeDir + 'Graphics' + DirectorySeparator + 'Texture' + 1436 IntToStr(Age + 1) + '.jpg'); 1437 clBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight]; 1438 clBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade]; 1439 clTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight]; 1440 clTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade]; 1441 clLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText]; 1442 clMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark]; 1443 clPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage]; 1444 clCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover]; 1445 result := true 1446 end 1447 else 1448 result := false 1449 end; 1450 1451 var 1452 i, p, size: integer; 1453 s: string; 1454 fontscript: TextFile; 1455 section: TFontType; 1456 Reg: TRegistry; 1378 BitBlt(dst.Canvas.Handle, xIcon + 4 + (val div 10) * 1379 (14 * ld div sd) + i * (10 * ld div sd), yIcon + 7, 10, 10, 1380 GrExt[HGrSystem].Mask.Canvas.Handle, 66 + Kind mod 11 * 11, 1381 115 + Kind div 11 * 11, SRCAND); 1382 Sprite(dst, HGrSystem, xIcon + 3 + (val div 10) * 1383 (14 * ld div sd) + i * (10 * ld div sd), yIcon + 6, 10, 1384 10, 66 + Kind mod 11 * 11, 1385 115 + Kind div 11 * 11); 1386 end; 1387 end; 1388 end; 1389 end; // CountBar 1390 1391 procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer; 1392 const T: TTexture); 1393 var 1394 i: integer; 1395 begin 1396 if pos > max then 1397 pos := max; 1398 if Growth < 0 then 1399 begin 1400 pos := pos + Growth; 1401 if pos < 0 then 1402 begin 1403 Growth := Growth - pos; 1404 pos := 0; 1405 end; 1406 end 1407 else if pos + Growth > max then 1408 Growth := max - pos; 1409 Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000); 1410 RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.clBevelShade, 1411 T.clBevelLight); 1412 with ca do 1413 begin 1414 for i := 0 to pos div 8 - 1 do 1415 BitBlt(Handle, x + i * 8, y, 8, 7, 1416 GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY); 1417 BitBlt(Handle, x + 8 * (pos div 8), y, pos - 8 * (pos div 8), 7, 1418 GrExt[HGrSystem].Data.Canvas.Handle, 104, 9 + 8 * Kind, SRCCOPY); 1419 if Growth > 0 then 1420 begin 1421 for i := 0 to Growth div 8 - 1 do 1422 BitBlt(Handle, x + pos + i * 8, y, 8, 7, 1423 GrExt[HGrSystem].Data.Canvas.Handle, 112, 9 + 8 * Kind, SRCCOPY); 1424 BitBlt(Handle, x + pos + 8 * (Growth div 8), y, 1425 Growth - 8 * (Growth div 8), 7, GrExt[HGrSystem].Data.Canvas.Handle, 1426 112, 9 + 8 * Kind, SRCCOPY); 1427 end 1428 else if Growth < 0 then 1429 begin 1430 for i := 0 to -Growth div 8 - 1 do 1431 BitBlt(Handle, x + pos + i * 8, y, 8, 7, 1432 GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY); 1433 BitBlt(Handle, x + pos + 8 * (-Growth div 8), y, -Growth - 1434 8 * (-Growth div 8), 7, 1435 GrExt[HGrSystem].Data.Canvas.Handle, 104, 1, SRCCOPY); 1436 end; 1437 Brush.Color := $000000; 1438 FillRect(Rect(x + pos + abs(Growth), y, x + max, y + 7)); 1439 Brush.Style := bsClear; 1440 end; 1441 end; 1442 1443 // pos and growth are relative to max, set size independent 1444 procedure PaintRelativeProgressBar(ca: TCanvas; 1445 Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean; 1446 const T: TTexture); 1447 begin 1448 if Growth > 0 then 1449 PaintProgressBar(ca, Kind, x, y, pos * size div max, 1450 (Growth * size + max div 2) div max, size, T) 1451 else 1452 PaintProgressBar(ca, Kind, x, y, pos * size div max, 1453 (Growth * size - max div 2) div max, size, T); 1454 if IndicateComplete and (pos + Growth >= max) then 1455 Sprite(ca, HGrSystem, x + size - 10, y - 7, 23, 16, 1, 129); 1456 end; 1457 1458 procedure PaintLogo(ca: TCanvas; x, y, clLight, clShade: integer); 1459 begin 1460 BitBltCanvas(LogoBuffer.Canvas, 0, 0, wLogo, hLogo, ca, x, 1461 y, SRCCOPY); 1462 ImageOp_BCC(LogoBuffer, Templates, 0, 0, 1, 1, wLogo, hLogo, 1463 clLight, clShade); 1464 BitBlt(ca.Handle, x, y, wLogo, hLogo, LogoBuffer.Canvas.Handle, 0, 1465 0, SRCCOPY); 1466 end; 1467 1468 function SetMainTextureByAge(Age: integer): boolean; 1469 begin 1470 if Age <> MainTextureAge then 1471 with MainTexture do 1472 begin 1473 MainTextureAge := Age; 1474 LoadGraphicFile(Image, HomeDir + 'Graphics' + DirectorySeparator + 1475 'Texture' + IntToStr(Age + 1) + '.jpg'); 1476 clBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight]; 1477 clBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade]; 1478 clTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight]; 1479 clTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade]; 1480 clLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText]; 1481 clMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark]; 1482 clPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage]; 1483 clCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover]; 1484 Result := True; 1485 end 1486 else 1487 Result := False; 1488 end; 1457 1489 1458 1490 { TPixelPointer } … … 1469 1501 end; 1470 1502 1471 procedure TPixelPointer.SetXY(X, Y: Integer); inline;1503 procedure TPixelPointer.SetXY(X, Y: integer); inline; 1472 1504 begin 1473 1505 Line := Pointer(Base) + Y * BytesPerLine; … … 1475 1507 end; 1476 1508 1477 procedure TPixelPointer.SetX(X: Integer); inline;1509 procedure TPixelPointer.SetX(X: integer); inline; 1478 1510 begin 1479 1511 Pixel := Pointer(Line) + X * BytesPerPixel; 1480 1512 end; 1481 1513 1482 procedure TPixelPointer.Init(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0); inline; 1514 procedure TPixelPointer.Init(Bitmap: TRasterImage; BaseX: integer = 0; 1515 BaseY: integer = 0); inline; 1483 1516 begin 1484 1517 BytesPerLine := Bitmap.RawImage.Description.BytesPerLine; … … 1490 1523 procedure LoadPhrases; 1491 1524 begin 1492 if Phrases = nil then Phrases := TStringTable.create; 1493 if Phrases2 = nil then Phrases2 := TStringTable.create; 1494 Phrases2FallenBackToEnglish := false; 1525 if Phrases = nil then 1526 Phrases := TStringTable.Create; 1527 if Phrases2 = nil then 1528 Phrases2 := TStringTable.Create; 1529 Phrases2FallenBackToEnglish := False; 1495 1530 if FileExists(LocalizedFilePath('Language.txt')) then 1496 1531 begin … … 1501 1536 begin 1502 1537 Phrases2.loadfromfile(HomeDir + 'Language2.txt'); 1503 Phrases2FallenBackToEnglish := true;1504 end 1538 Phrases2FallenBackToEnglish := True; 1539 end; 1505 1540 end 1506 1541 else … … 1510 1545 end; 1511 1546 1512 if Sounds = nil then Sounds := TStringTable.create; 1547 if Sounds = nil then 1548 Sounds := TStringTable.Create; 1513 1549 if not Sounds.loadfromfile(HomeDir + 'Sounds' + DirectorySeparator + 'sound.txt') then 1514 1550 begin … … 1517 1553 end; 1518 1554 1519 procedure UnitInit; 1520 begin 1521 Reg := TRegistry.Create; 1522 with Reg do 1523 try 1524 OpenKey(AppRegistryKey, True); 1525 if ValueExists('Gamma') then 1526 Gamma := ReadInteger('Gamma') 1527 else begin 1528 Gamma := 100; 1529 WriteInteger('Gamma', Gamma); 1530 end; 1531 if ValueExists('Locale') then LocaleCode := ReadString('Locale') 1532 else LocaleCode := ''; 1533 finally 1534 Free; 1535 end; 1536 1537 if Gamma <> 100 then 1538 begin 1539 GammaLUT[0] := 0; 1540 for i := 1 to 255 do 1541 begin 1542 p := round(255.0 * exp(ln(i / 255.0) * 100.0 / Gamma)); 1543 assert((p >= 0) and (p < 256)); 1544 GammaLUT[i] := p; 1545 end; 1546 end; 1547 1548 {$IFDEF WINDOWS} 1549 EnumDisplaySettings(nil, $FFFFFFFF, StartResolution); 1550 {$ENDIF} 1551 ResolutionChanged := false; 1552 1553 LoadPhrases; 1554 1555 for section := Low(TFontType) to High(TFontType) do 1556 UniFont[section] := TFont.create; 1557 1558 LogoBuffer := TBitmap.create; 1559 LogoBuffer.PixelFormat := pf24bit; 1560 LogoBuffer.SetSize(wBBook, hBBook); 1561 1562 section := ftNormal; 1563 AssignFile(fontscript, LocalizedFilePath('Fonts.txt')); 1555 procedure LoadFonts; 1556 var 1557 Section: TFontType; 1558 FontScript: TextFile; 1559 Size: integer; 1560 S: string; 1561 I: integer; 1562 P: integer; 1563 begin 1564 for Section := Low(TFontType) to High(TFontType) do 1565 UniFont[Section] := TFont.Create; 1566 1567 Section := ftNormal; 1568 AssignFile(FontScript, LocalizedFilePath('Fonts.txt')); 1564 1569 try 1565 1570 Reset(fontscript); 1566 while not eof(fontscript) do1567 begin 1568 ReadLn( fontscript, s);1571 while not EOF(FontScript) do 1572 begin 1573 ReadLn(FontScript, s); 1569 1574 if s <> '' then 1570 1575 if s[1] = '#' then … … 1572 1577 s := TrimRight(s); 1573 1578 if s = '#SMALL' then 1574 section := ftSmall1579 Section := ftSmall 1575 1580 else if s = '#TINY' then 1576 section := ftTiny1581 Section := ftTiny 1577 1582 else if s = '#CAPTION' then 1578 section := ftCaption1583 Section := ftCaption 1579 1584 else if s = '#BUTTON' then 1580 section := ftButton1585 Section := ftButton 1581 1586 else 1582 section := ftNormal;1587 Section := ftNormal; 1583 1588 end 1584 1589 else 1585 1590 begin 1586 p := pos(',', s);1591 p := Pos(',', s); 1587 1592 if p > 0 then 1588 1593 begin 1589 UniFont[section].Name := Trim( copy(s, 1, p - 1));1590 size := 0;1594 UniFont[section].Name := Trim(Copy(s, 1, p - 1)); 1595 Size := 0; 1591 1596 for i := p + 1 to Length(s) do 1592 1597 case s[i] of 1593 1598 '0' .. '9': 1594 size := size * 10 + Byte(s[i]) - 48;1599 Size := Size * 10 + Byte(s[i]) - 48; 1595 1600 'B', 'b': 1596 1601 UniFont[section].Style := UniFont[section].Style + [fsBold]; … … 1599 1604 end; 1600 1605 // 0.8 constant is compensation for Lazarus as size of fonts against Delphi differs 1601 UniFont[section]. size :=1602 round(size * Screen.PixelsPerInch / UniFont[section].PixelsPerInch * 0.8);1606 UniFont[section].Size := 1607 Round(size * Screen.PixelsPerInch / UniFont[section].PixelsPerInch * 0.8); 1603 1608 end; 1604 1609 end; 1605 1610 end; 1606 CloseFile( fontscript);1611 CloseFile(FontScript); 1607 1612 except 1608 1613 end; 1614 end; 1615 1616 procedure ReleaseFonts; 1617 var 1618 Section: TFontType; 1619 begin 1620 for Section := Low(TFontType) to High(TFontType) do 1621 FreeAndNil(UniFont[section]); 1622 end; 1623 1624 procedure UnitInit; 1625 var 1626 I: integer; 1627 P: integer; 1628 Reg: TRegistry; 1629 begin 1630 Reg := TRegistry.Create; 1631 with Reg do 1632 try 1633 OpenKey(AppRegistryKey, True); 1634 if ValueExists('Gamma') then 1635 Gamma := ReadInteger('Gamma') 1636 else 1637 begin 1638 Gamma := 100; 1639 WriteInteger('Gamma', Gamma); 1640 end; 1641 if ValueExists('Locale') then 1642 LocaleCode := ReadString('Locale') 1643 else 1644 LocaleCode := ''; 1645 finally 1646 Free; 1647 end; 1648 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; 1659 1660 {$IFDEF WINDOWS} 1661 EnumDisplaySettings(nil, $FFFFFFFF, StartResolution); 1662 ResolutionChanged := False; 1663 {$ENDIF} 1664 1665 LoadPhrases; 1666 1667 LogoBuffer := TBitmap.Create; 1668 LogoBuffer.PixelFormat := pf24bit; 1669 LogoBuffer.SetSize(wBBook, hBBook); 1670 1671 LoadFonts; 1609 1672 1610 1673 nGrExt := 0; … … 1613 1676 Templates := TBitmap.Create; 1614 1677 Templates.PixelFormat := pf24bit; 1615 LoadGraphicFile(Templates, HomeDir + 'Graphics' + DirectorySeparator + 'Templates.png', gfNoGamma); 1678 LoadGraphicFile(Templates, HomeDir + 'Graphics' + DirectorySeparator + 1679 'Templates.png', gfNoGamma); 1616 1680 Colors := TBitmap.Create; 1617 1681 Colors.PixelFormat := pf24bit; … … 1633 1697 var 1634 1698 Reg: TRegistry; 1635 begin 1636 Reg := TRegistry.create; 1699 I: integer; 1700 begin 1701 Reg := TRegistry.Create; 1637 1702 with Reg do 1638 try1639 OpenKey(AppRegistryKey, True);1640 WriteString('Locale', LocaleCode);1641 WriteInteger('Gamma', Gamma);1642 finally1643 Free;1644 end;1703 try 1704 OpenKey(AppRegistryKey, True); 1705 WriteString('Locale', LocaleCode); 1706 WriteInteger('Gamma', Gamma); 1707 finally 1708 Free; 1709 end; 1645 1710 1646 1711 RestoreResolution; 1647 for i := 0 to nGrExt - 1 do 1648 begin 1649 GrExt[i].Data.Free; 1650 GrExt[i].Mask.Free; 1651 FreeMem(GrExt[i]); 1652 end; 1653 for section := Low(TFontType) to High(TFontType) do 1654 FreeAndNil(UniFont[section]); 1712 for I := 0 to nGrExt - 1 do 1713 begin 1714 GrExt[I].Data.Free; 1715 GrExt[I].Mask.Free; 1716 FreeMem(GrExt[I]); 1717 end; 1718 1719 ReleaseFonts; 1720 1655 1721 FreeAndNil(Phrases); 1656 1722 FreeAndNil(Phrases2); … … 1665 1731 end; 1666 1732 1733 1667 1734 initialization 1668 1735 1669 //UnitInit;1736 //UnitInit; 1670 1737 1671 1738 finalization 1672 1739 1673 //UnitDone;1740 //UnitDone; 1674 1741 1675 1742 end. -
trunk/Components/StringTables.pas
r111 r128 46 46 function TStringTable.LoadFromFile(const FileName: String): boolean; 47 47 begin 48 Lines.LoadFromFile(FileName); 48 Result := True; 49 Lines.Clear; 50 try 51 Lines.LoadFromFile(FileName); 52 except 53 Result := False; 54 end; 49 55 end; 50 56
Note:
See TracChangeset
for help on using the changeset viewer.