1{ ------------------------------------------ 2 carbongdiobjects.pp - Carbon GDI objects 3 ------------------------------------------ 4 5 ***************************************************************************** 6 This file is part of the Lazarus Component Library (LCL) 7 8 See the file COPYING.modifiedLGPL.txt, included in this distribution, 9 for details about the license. 10 ***************************************************************************** 11} 12unit CarbonGDIObjects; 13 14{$mode objfpc}{$H+} 15{.$define DumpRegion} 16interface 17 18// defines 19{$I carbondefines.inc} 20 21uses 22 // rtl+fcl 23 Types, Classes, SysUtils, Math, 24 // carbon bindings 25 MacOSAll, 26 // LCL 27 LCLProc, LCLType, GraphType, Graphics, Controls, Forms, ExtCtrls, 28 // LCL Carbon 29 {$ifdef DebugBitmaps} 30 CarbonDebug, 31 {$endif} 32 CarbonDef; 33 34type 35 TCarbonBitmap = class; 36 37 { TCarbonGDIObject } 38 39 TCarbonGDIObject = class 40 private 41 FSelCount: Integer; 42 FGlobal: Boolean; 43 public 44 constructor Create(AGlobal: Boolean); 45 46 procedure Select; 47 procedure Unselect; 48 49 property Global: Boolean read FGlobal; 50 property SelCount: Integer read FSelCount; 51 end; 52 53 { TCarbonRegion } 54 55 TCarbonRegion = class(TCarbonGDIObject) 56 private 57 FShape: HIShapeRef; 58 public 59 constructor Create; 60 constructor Create(const X1, Y1, X2, Y2: Integer); 61 constructor Create(Points: PPoint; NumPts: Integer; FillMode: Integer); 62 constructor CreateEllipse(X1, Y1, X2, Y2: Integer); 63 destructor Destroy; override; 64 65 procedure Apply(ADC: TCarbonContext); 66 function GetBounds: TRect; 67 function GetType: Integer; 68 function ContainsPoint(const P: TPoint): Boolean; 69 procedure SetShape(AShape: HIShapeRef); 70 function CombineWith(ARegion: TCarbonRegion; CombineMode: Integer): Integer; 71 procedure Offset(dx, dy: Integer); 72 function GetShapeCopy: HIShapeRef; 73 procedure MakeMutable; 74 public 75 property Shape: HIShapeRef read FShape write SetShape; 76 end; 77 78 TCarbonFont = class; 79 80 { TCarbonTextLayout } 81 82 TCarbonTextLayout = class 83 private 84 FTextBefore: ATSUTextMeasurement; 85 FTextAfter: ATSUTextMeasurement; 86 FAscent: ATSUTextMeasurement; 87 FDescent: ATSUTextMeasurement; 88 FLineRotation: Fixed; 89 public 90 procedure Apply(ADC: TCarbonContext); virtual; abstract; 91 function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; virtual; abstract; 92 procedure Release; virtual; 93 94 function GetHeight: Integer; 95 function GetWidth: Integer; 96 function GetDrawBounds(X, Y: Integer): CGRect; 97 98 property TextBefore: ATSUTextMeasurement read FTextBefore; 99 property TextAfter: ATSUTextMeasurement read FTextAfter; 100 property Ascent: ATSUTextMeasurement read FAscent; 101 property Descent: ATSUTextMeasurement read FDescent; 102 end; 103 104 { TCarbonTextLayoutBuffer } 105 106 TCarbonTextLayoutBuffer = class(TCarbonTextLayout) 107 private 108 FLayout: ATSUTextLayout; 109 FWidget: HIViewRef; 110 FTextBuffer: WideString; 111 FDC: TCarbonContext; 112 FDXCount: Integer; 113 FDX: PInteger; 114 Idx: Integer; 115 protected 116 procedure DoJustify(iLineRef: ATSULineRef; var Handled: Boolean); 117 public 118 constructor Create(const Text: String; Font: TCarbonFont; TextFractional: Boolean); 119 procedure Apply(ADC: TCarbonContext); override; 120 function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; override; 121 procedure Release; override; 122 123 property Layout: ATSUTextLayout read FLayout; 124 property TextBuffer: WideString read FTextBuffer; 125 end; 126 127 { TCarbonTextLayoutArray } 128 129 TCarbonTextLayoutArray = class(TCarbonTextLayout) 130 private 131 FText: String; 132 FFont: TCarbonFont; 133 public 134 constructor Create(const Text: String; Font: TCarbonFont); 135 procedure Apply(ADC: TCarbonContext); override; 136 function Draw(X, Y: Integer; DX: PInteger; DXCount: Integer): Boolean; override; 137 end; 138 139 { TCarbonFont } 140 141 TCarbonFont = class(TCarbonGDIObject) 142 private 143 FStyle: ATSUStyle; 144 FLineRotation: Fixed; 145 FCachedLayouts: Array of TCarbonTextLayoutBuffer; 146 public 147 constructor Create(AGlobal: Boolean); // default system font 148 constructor Create(ALogFont: TLogFont; const AFaceName: String); 149 function CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle; 150 procedure QueryStyle(ALogFont: PLogFont); 151 destructor Destroy; override; 152 procedure SetColor(AColor: TColor); 153 154 function CreateTextLayout(const Text: String; TextFractional: Boolean): TCarbonTextLayout; 155 public 156 property LineRotation: Fixed read FLineRotation; 157 property Style: ATSUStyle read FStyle; 158 end; 159 160 { TCarbonColorObject } 161 162 TCarbonColorObject = class(TCarbonGDIObject) 163 private 164 FR, FG, FB: Byte; 165 FA: Boolean; // alpha: True - solid, False - clear 166 function GetColorRef: TColorRef; 167 public 168 constructor Create(const AColor: TColor; ASolid, AGlobal: Boolean); 169 procedure SetColor(const AColor: TColor; ASolid: Boolean); 170 procedure GetRGBA(AROP2: Integer; out AR, AG, AB, AA: Single); 171 function CreateCGColor: CGColorRef; 172 173 property Red: Byte read FR write FR; 174 property Green: Byte read FG write FG; 175 property Blue: Byte read FB write FB; 176 property Solid: Boolean read FA write FA; 177 property ColorRef: TColorRef read GetColorRef; 178 end; 179 180 { TCarbonBrush } 181 182 TCarbonBrush = class(TCarbonColorObject) 183 private 184 FCGPattern: CGPatternRef; 185 FColored: Boolean; 186 FBitmap: TCarbonBitmap; 187 protected 188 procedure SetHatchStyle(AHatch: PtrInt); 189 procedure SetBitmap(ABitmap: TCarbonBitmap); 190 public 191 constructor Create(AGlobal: Boolean); // create default brush 192 constructor Create(ALogBrush: TLogBrush); 193 destructor Destroy; override; 194 procedure Apply(ADC: TCarbonContext; UseROP2: Boolean = True); 195 end; 196 197const 198 // Paul Ishenin: 199 // pen shapes are compared with windows shapes and now a bit to bit equal 200 CarbonDashStyle: Array [0..1] of Single = (3, 1); 201 CarbonDotStyle: Array [0..1] of Single = (1, 1); 202 CarbonDashDotStyle: Array [0..3] of Single = (3, 1, 1, 1); 203 CarbonDashDotDotStyle: Array [0..5] of Single = (3, 1, 1, 1, 1, 1); 204 205type 206 TCarbonDashes = array of Float32; 207 208 { TCarbonPen } 209 210 TCarbonPen = class(TCarbonColorObject) 211 private 212 FWidth: Integer; 213 FStyle: LongWord; 214 FIsExtPen: Boolean; 215 FIsGeometric: Boolean; 216 FEndCap: CGLineCap; 217 FJoinStyle: CGLineJoin; 218 public 219 Dashes: TCarbonDashes; 220 constructor Create(AGlobal: Boolean); // create default pen 221 constructor Create(ALogPen: TLogPen); 222 constructor Create(dwPenStyle, dwWidth: DWord; const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord); 223 procedure Apply(ADC: TCarbonContext; UseROP2: Boolean = True); 224 225 property Width: Integer read FWidth; 226 property Style: LongWord read FStyle; 227 property IsExtPen: Boolean read FIsExtPen; 228 property IsGeometric: Boolean read FIsGeometric; 229 property JoinStyle: CGLineJoin read FJoinStyle; 230 property CapStyle: CGLineCap read FEndCap; 231 end; 232 233 { TCarbonBitmap } 234 235 TCarbonBitmapAlignment = ( 236 cbaByte, // each line starts at byte boundary. 237 cbaWord, // each line starts at word (16bit) boundary 238 cbaDWord, // each line starts at double word (32bit) boundary 239 cbaQWord, // each line starts at quad word (64bit) boundary 240 cbaDQWord // each line starts at double quad word (128bit) boundary 241 ); 242 243 TCarbonBitmapType = ( 244 cbtMono, // mask or mono bitmap 245 cbtGray, // grayscale bitmap 246 cbtRGB, // color bitmap 8-8-8 R-G-B 247 cbtARGB, // color bitmap with alpha channel first 8-8-8-8 A-R-G-B 248 cbtRGBA, // color bitmap with alpha channel last 8-8-8-8 R-G-B-A 249 cbtBGR, // color bitmap 8-8-8 B-G-R (windows compatible) 250 cbtBGRA // color bitmap with alpha channel 8-8-8-8 B-G-R-A (windows compatible) 251 ); 252const 253 cbtMask = cbtMono; 254 255 256type 257 TCarbonBitmap = class(TCarbonGDIObject) 258 private 259 FData: Pointer; 260 FAlignment: TCarbonBitmapAlignment; 261 FFreeData: Boolean; 262 FDataSize: Integer; 263 FBytesPerRow: Integer; 264 FDepth: Byte; 265 FBitsPerPixel: Byte; 266 FWidth: Integer; 267 FHeight: Integer; 268 FType: TCarbonBitmapType; 269 FCGImage: CGImageRef; 270 function GetBitsPerComponent: Integer; 271 function GetColorSpace: CGColorSpaceRef; 272 function GetInfo: CGBitmapInfo; 273 procedure SetCGImage(const AValue: CGImageRef); 274 public 275 constructor Create(AWidth, AHeight, ADepth, ABitsPerPixel: Integer; 276 AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType; 277 AData: Pointer; ACopyData: Boolean = True); 278 constructor Create(ABitmap: TCarbonBitmap); 279 destructor Destroy; override; 280 procedure SetInfo(AWidth, AHeight, ADepth, ABitsPerPixel: Integer; 281 AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType); 282 procedure UpdateImage; 283 procedure UpdateInfo; 284 function CreateSubImage(const ARect: TRect): CGImageRef; 285 function CreateMaskImage(const ARect: TRect): CGImageRef; 286 function CreateMaskedImage(AMask: TCarbonBitmap): CGImageRef; 287 function CreateMaskedImage(AMask: TCarbonBitmap; const ARect: TRect): CGImageRef; 288 procedure AddMask(AMask: TCarbonBitmap); 289 public 290 property BitsPerComponent: Integer read GetBitsPerComponent; 291 property BitmapType: TCarbonBitmapType read FType; 292 property BytesPerRow: Integer read FBytesPerRow; 293 property CGImage: CGImageRef read FCGImage write SetCGImage; 294 property ColorSpace: CGColorSpaceRef read GetColorSpace; 295 property Data: Pointer read FData; 296 property DataSize: Integer read FDataSize; 297 property Depth: Byte read FDepth; 298 property Info: CGBitmapInfo read GetInfo; 299 property Width: Integer read FWidth; 300 property Height: Integer read FHeight; 301 end; 302 303const 304 kThemeUndefCursor = ThemeCursor(-1); // undefined mac theme cursor 305 306 CursorToThemeCursor: array[crLow..crHigh] of ThemeCursor = 307 ({crSizeSE } kThemeResizeRightCursor, {!!} 308 {crSizeS } kThemeResizeDownCursor, 309 {crSizeSW } kThemeResizeLeftCursor, {!!} 310 {crSizeE } kThemeResizeRightCursor, 311 {crSizeW } kThemeResizeLeftCursor, 312 {crSizeNE } kThemeResizeRightCursor, {!!} 313 {crSizeN } kThemeResizeUpCursor, 314 {crSizeNW } kThemeResizeLeftCursor, {!!} 315 {crSizeAll } kThemeUndefCursor, // will be loaded from resource 316 {crHandPoint } kThemePointingHandCursor, 317 {crHelp } kThemeUndefCursor, // will be loaded from resource 318 {crAppStart } kThemeSpinningCursor, 319 {crNo } kThemeUndefCursor, 320 {crSQLWait } kThemeUndefCursor, // will be loaded from resource 321 {crMultiDrag } kThemeUndefCursor, // will be loaded from resource 322 {crVSplit } kThemeResizeUpDownCursor, 323 {crHSplit } kThemeResizeLeftRightCursor, 324 {crNoDrop } kThemeNotAllowedCursor, 325 {crDrag } kThemeCopyArrowCursor, 326 {crHourGlass } kThemeSpinningCursor, 327 {crUpArrow } kThemeUndefCursor, // will be loaded from resource 328 {crSizeWE } kThemeResizeLeftRightCursor, 329 {crSizeNWSE } kThemeResizeLeftRightCursor, {!!} 330 {crSizeNS } kThemeResizeUpDownCursor, {!!} 331 {crSizeNESW } kThemeResizeLeftRightCursor, {!!} 332 {undefined } kThemeArrowCursor, {!!} 333 {crIBeam } kThemeIBeamCursor, 334 {crCross } kThemeCrossCursor, 335 {crArrow } kThemeArrowCursor, 336 {crNone } kThemeUndefCursor, 337 {crDefault } kThemeArrowCursor); 338 339type 340 TCarbonCursorType = 341 ( 342 cctUnknown, // undefined 343 cctQDHardware, // QuickDraw hardware cursor 344 cctQDColor, // QuickDraw Color cursor 345 cctTheme, // theme cursor 346 cctAnimated, // animated theme cursor 347 cctWait // special wait cursor 348 ); 349 { TCarbonCursor } 350 351 TCarbonCursor = class(TCarbonGDIObject) 352 private 353 FCursorType: TCarbonCursorType; 354 FDefault: Boolean; 355 FThemeCursor: ThemeCursor; 356 // animation 357 FAnimationStep: Integer; 358 FTaskID: MPTaskID; 359 // color cursors 360 FQDColorCursorHandle: CCrsrHandle; 361 FQDHardwareCursorName: String; 362 FPixmapHandle: PixmapHandle; 363 // animated color cursors 364 FAnimationFrames: array of record 365 QDColorCursorHandle: CCrsrHandle; 366 QDHardwareCursorName: String; 367 PixmapHandle: PixmapHandle; 368 end; 369 FAnimationTimer: TTimer; 370 procedure CreateThread; 371 procedure DestroyThread; 372 procedure StepQDAnimation(Sender: TObject); 373 protected 374 procedure CreateHardwareCursor(ABitmap: TCarbonBitmap; AHotSpot: Point); 375 procedure CreateColorCursor(ABitmap: TCarbonBitmap; AHotSpot: Point); 376 procedure DestroyCursor; 377 public 378 constructor Create; 379 constructor CreateAnimatedFromInfo(AInfo: PIconInfo; ACount: Integer); 380 constructor CreateFromInfo(AInfo: PIconInfo); 381 constructor CreateThemed(AThemeCursor: ThemeCursor; ADefault: Boolean = False); 382 destructor Destroy; override; 383 384 procedure Install; 385 procedure UnInstall; 386 function StepAnimation: Boolean; 387 class function HardwareCursorsSupported: Boolean; 388 public 389 property CursorType: TCarbonCursorType read FCursorType; 390 property Default: Boolean read FDefault; 391 end; 392 393function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String; AParamName: String = ''): Boolean; 394function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String; AParamName: String = ''): Boolean; 395function CheckCursor(const Cursor: HCURSOR; const AMethodName: String; AParamName: String = ''): Boolean; 396 397function FloodFillBitmap(const Bitmap: TCarbonBitmap; X,Y: Integer; {%H-}ABorderColor, FillColor: TColor; {%H-}isBorderColor: Boolean): Boolean; 398 399var 400 StockSystemFont: TCarbonFont; 401 StockNullBrush: TCarbonBrush; 402 WhiteBrush: TCarbonBrush; 403 BlackPen: TCarbonPen; 404 405 DefaultFont: TCarbonFont; 406 DefaultBrush: TCarbonBrush; 407 DefaultPen: TCarbonPen; 408 409 DefaultBitmap: TCarbonBitmap; // 1 x 1 bitmap for default context 410 411implementation 412 413uses 414 LazUTF8, CarbonInt, CarbonProc, CarbonCanvas, CarbonDbgConsts; 415 416const 417 BITMAPINFOMAP: array[TCarbonBitmapType] of CGBitmapInfo = ( 418 {cbtMask} kCGImageAlphaNone, 419 {cbtGray} kCGImageAlphaNone, 420 {cbtRGB} kCGImageAlphaNoneSkipFirst, 421 {cbtARGB} kCGImageAlphaFirst, 422 {cbtRGBA} kCGImageAlphaLast, 423 {cbtBGR} kCGImageAlphaNoneSkipFirst or kCGBitmapByteOrder32Little, 424 {cbtBGRA} kCGImageAlphaFirst or kCGBitmapByteOrder32Little 425 ); 426 427type 428 429 { TScanObject } 430 431 TScanObject = class 432 Shape: HIShapeRef; 433 fX, fY, fW, fH: Integer; 434 Data: Pointer; 435 Context: CGContextRef; 436 constructor create(aShape: HIShapeRef; aX, aY, aW, aH: Integer); 437 destructor destroy; override; 438 procedure AddPart(X1, X2, Y: Integer); 439 function Setup: boolean; 440 procedure Scan; 441 procedure ScanConvex; 442 end; 443 444 445constructor TScanObject.create(aShape: HIShapeRef; aX, aY, aW, aH: Integer); 446begin 447 inherited Create; 448 Shape := aShape; 449 fX := aX; 450 fY := aY; 451 fW := aW; 452 fH := aH; 453end; 454 455 456destructor TScanObject.destroy; 457begin 458 if Context<>nil then 459 CGContextRelease(Context); 460 if Data<>nil then 461 System.Freemem(Data); 462 inherited Destroy; 463end; 464 465function TScanObject.Setup: boolean; 466begin 467 System.GetMem(Data, fW * fH); 468 System.FillChar(Data^, fW * fH, 0); 469 try 470 Context := CGBitmapContextCreate(Data, fW, fH, 8, fW, GrayColorSpace, kCGImageAlphaNone); 471 CGContextSetShouldAntialias(Context, 0); // disable anti-aliasing 472 CGContextSetGrayFillColor(Context, 1.0, 1.0); // draw white polygon 473 CGContextTranslateCTM(Context, -fx, -fy); // Translate origin so we draw at 0,0 474 result := true; 475 except 476 result := false; 477 end; 478end; 479 480procedure TScanObject.AddPart(X1, X2, Y: Integer); 481var 482 R: HIShapeRef; 483begin 484 //DebugLn('AddPart:' + DbgS(X1) + ' - ' + DbgS(X2) + ', ' + DbgS(Y)); 485 R := HIShapeCreateWithRect(GetCGRect(X1, Y, X2, Y + 1)); 486 OSError(HIShapeUnion(Shape, R, Shape), Self, 'AddPart', 'HIShapeUnion'); 487 CFRelease(R); 488end; 489 490procedure TScanObject.Scan; 491var 492 PData: PByte; 493 X, Y, SX: Integer; 494 LC, C: Byte; 495 {$ifdef DumpRegion} 496 Line: string; 497 {$endif} 498begin 499 // scan shape 500 {$ifdef DumpRegion} 501 DebugLn; 502 DebugLn('SCAN: X=%d Y=%d W=%d H=%d',[fX,fY,fW,fH]); 503 SetLength(Line, fW); 504 {$endif} 505 506 PData := Data; 507 for Y := 0 to Pred(fH) do 508 begin 509 LC := 0; // edge is black 510 Sx := -1; 511 for X := 0 to Pred(fW) do 512 begin 513 C := PData^; 514 {$ifdef DumpRegion} 515 Line[X + 1] := Chr(Ord('0') + C div 255); 516 {$endif} 517 518 if (C = $FF) and (LC = 0) then 519 SX := X; // start of painted row part 520 if (SX>=0) and (LC = $FF) and ((C = 0) or (x=Pred(fw))) then 521 // end of painted row part (SX, X) 522 AddPart(fx + SX, fx + X, fy + Pred(fH) - Y); 523 524 LC := C; 525 Inc(PData); 526 end; 527 {$ifdef DumpRegion} 528 DebugLn('%.3d: %s',[Pred(fH) - Y,Line]); 529 {$endif} 530 end; 531end; 532 533procedure TScanObject.ScanConvex; 534var 535 PData, P: PByte; 536 X, Xe, Y, SX,EX: Integer; 537 {$ifdef DumpRegion} 538 Line: string; 539 {$endif} 540 found, noted: boolean; 541begin 542 // scan shape 543 {$ifdef DumpRegion} 544 DebugLn; 545 DebugLn('SCANCONVEX: X=%d Y=%d W=%d H=%d',[fX,fY,fW,fH]); 546 SetLength(Line, fW); 547 {$endif} 548 549 noted := false; 550 PData := Data; 551 for Y := 0 to Pred(fH) do 552 begin 553 P := PData; 554 {$ifdef DumpRegion} 555 for X:=0 to Pred(fW) do Line[X+1] := Chr(Ord('0') + P[X] div 255); 556 {$endif} 557 SX := -1; EX := -1; 558 for X := 0 to Pred(fW) do 559 begin 560 Xe := Pred(fW)-X; 561 if (SX=-1) and (P[X]=$FF) then SX := X; 562 if (EX=-1) and (P[Xe]=$FF) then EX := Xe; 563 found := (EX>=0) and (SX>=0); 564 if found or (Xe<=X) then 565 break; 566 end; 567 // just in case .... 568 if not found then 569 begin 570 if (Sx>=0) then begin Ex := Pred(fW); found := true; end; 571 if (Ex>=0) then begin Sx := 0; found := true; end; 572 if not noted and found then begin 573 noted := true; 574 DebugLn('NOTE: ScanObj: broken convex!'); 575 end; 576 end; 577 578 inc(PData, fW); 579 if found then 580 AddPart(fX + SX, fX + Ex + 1, fY + Pred(fH) - Y); 581 {$ifdef DumpRegion} 582 DebugLn('%.3d: %s did=%s',[Pred(fH) - Y,Line,dbgs(found)]); 583 {$endif} 584 end; 585end; 586 587 588{------------------------------------------------------------------------------ 589 Name: CheckGDIObject 590 Params: GDIObject - Handle to a GDI Object (TCarbonFont, ...) 591 AMethodName - Method name 592 AParamName - Param name 593 Returns: If the GDIObject is valid 594 595 Remark: All handles for GDI objects must be pascal objects so we can 596 distinguish between them 597 ------------------------------------------------------------------------------} 598function CheckGDIObject(const GDIObject: HGDIOBJ; const AMethodName: String; 599 AParamName: String): Boolean; 600begin 601 if TObject(GDIObject) is TCarbonGDIObject then Result := True 602 else 603 begin 604 Result := False; 605 606 if Pos('.', AMethodName) = 0 then 607 DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid GDIObject ' + 608 AParamName + ' = ' + DbgS(GDIObject) + '!') 609 else 610 DebugLn(AMethodName + ' Error - invalid GDIObject ' + AParamName + ' = ' + 611 DbgS(GDIObject) + '!'); 612 end; 613end; 614 615{------------------------------------------------------------------------------ 616 Name: CheckBitmap 617 Params: Bitmap - Handle to a bitmap (TCarbonBitmap) 618 AMethodName - Method name 619 AParamName - Param name 620 Returns: If the bitmap is valid 621 ------------------------------------------------------------------------------} 622function CheckBitmap(const Bitmap: HBITMAP; const AMethodName: String; 623 AParamName: String): Boolean; 624begin 625 if TObject(Bitmap) is TCarbonBitmap then Result := True 626 else 627 begin 628 Result := False; 629 630 if Pos('.', AMethodName) = 0 then 631 DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid bitmap ' + 632 AParamName + ' = ' + DbgS(Bitmap) + '!') 633 else 634 DebugLn(AMethodName + ' Error - invalid bitmap ' + AParamName + ' = ' + 635 DbgS(Bitmap) + '!'); 636 end; 637end; 638 639{------------------------------------------------------------------------------ 640 Name: CheckCursor 641 Params: Cursor - Handle to a cursor (TCarbonCursor) 642 AMethodName - Method name 643 AParamName - Param name 644 Returns: If the cursor is valid 645 ------------------------------------------------------------------------------} 646function CheckCursor(const Cursor: HCURSOR; const AMethodName: String; 647 AParamName: String): Boolean; 648begin 649 if TObject(Cursor) is TCarbonCursor then Result := True 650 else 651 begin 652 Result := False; 653 654 if Pos('.', AMethodName) = 0 then 655 DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid cursor ' + 656 AParamName + ' = ' + DbgS(Cursor) + '!') 657 else 658 DebugLn(AMethodName + ' Error - invalid cursor ' + AParamName + ' = ' + 659 DbgS(Cursor) + '!'); 660 end; 661end; 662 663type 664 THardwareCursorsAvailability = 665 ( 666 hcaUndef, 667 hcaAvailable, 668 hcaUnavailable 669 ); 670 671const 672// missed error codes 673 kQDNoColorHWCursorSupport = -3951; 674 {%H-}kQDCursorAlreadyRegistered = -3952; 675 {%H-}kQDCursorNotRegistered = -3953; 676 {%H-}kQDCorruptPICTDataErr = -3954; 677 678 kThemeCursorAnimationDelay = 70; 679 LazarusCursorInfix = '_lazarus_'; 680 681var 682 MHardwareCursorsSupported: THardwareCursorsAvailability = hcaUndef; 683 684{------------------------------------------------------------------------------ 685 Name: AnimationCursorHandler 686 Handles cursor animation steps 687 ------------------------------------------------------------------------------} 688function AnimationCursorHandler(parameter: UnivPtr): OSStatus; 689 {$IFDEF darwin}mwpascal;{$ENDIF} 690begin 691 Result := noErr; 692 while True do 693 begin 694 if TCarbonCursor(parameter).StepAnimation then 695 Sleep(kThemeCursorAnimationDelay) else 696 break; 697 end; 698end; 699 700{ TCarbonGDIObject } 701 702{------------------------------------------------------------------------------ 703 Method: TCarbonGDIObject.Create 704 Params: AGlobal - Global 705 706 Creates custom GDI object 707 ------------------------------------------------------------------------------} 708constructor TCarbonGDIObject.Create(AGlobal: Boolean); 709begin 710 FSelCount := 0; 711 FGlobal := AGlobal; 712end; 713 714{------------------------------------------------------------------------------ 715 Method: TCarbonGDIObject.Select 716 717 Selects custom GDI object 718 ------------------------------------------------------------------------------} 719procedure TCarbonGDIObject.Select; 720begin 721 if FGlobal then Exit; 722 Inc(FSelCount); 723end; 724 725{------------------------------------------------------------------------------ 726 Method: TCarbonGDIObject.Unselect 727 728 Unselects custom GDI object 729 ------------------------------------------------------------------------------} 730procedure TCarbonGDIObject.Unselect; 731begin 732 if FGlobal then Exit; 733 if FSelCount > 0 then 734 Dec(FSelCount) 735 else 736 begin 737 DebugLn('TCarbonGDIObject.Unselect Error - ', DbgSName(Self), ' SelCount = ', 738 DbgS(FSelCount), '!'); 739 end; 740end; 741 742{ TCarbonRegion } 743 744{------------------------------------------------------------------------------ 745 Method: TCarbonRegion.Create 746 747 Creates a new empty Carbon region 748 ------------------------------------------------------------------------------} 749constructor TCarbonRegion.Create; 750begin 751 inherited Create(False); 752 753 FShape := HIShapeCreateEmpty; 754end; 755 756{------------------------------------------------------------------------------ 757 Method: TCarbonRegion.Create 758 Params: X1, Y1, X2, Y2 - Region bounding rectangle 759 760 Creates a new rectangular Carbon region 761 ------------------------------------------------------------------------------} 762constructor TCarbonRegion.Create(const X1, Y1, X2, Y2: Integer); 763begin 764 inherited Create(False); 765 766 FShape := HIShapeCreateWithRect(GetCGRectSorted(X1, Y1, X2, Y2)); 767end; 768 769{------------------------------------------------------------------------------ 770 Method: TCarbonRegion.Create 771 Params: Points - Pointer to array of polygon points 772 NumPts - Number of points passed 773 FillMode - Filling mode 774 775 Creates a new polygonal Carbon region from the specified points 776 ------------------------------------------------------------------------------} 777constructor TCarbonRegion.Create(Points: PPoint; NumPts: Integer; 778 FillMode: Integer); 779var 780 Bounds: TRect; 781 ScanObj: TScanObject; 782 P: PPoint; 783 I, W, H: Integer; 784 785 function GetPolygonBounds: TRect; 786 var 787 I: Integer; 788 begin 789 P := Points; 790 Result := Classes.Rect(P^.X, P^.Y, P^.X, P^.Y); 791 for I := 1 to NumPts - 1 do 792 begin 793 Inc(P); 794 if P^.X < Result.Left then Result.Left := P^.X; 795 if P^.X > Result.Right then Result.Right := P^.X; 796 if P^.Y < Result.Top then Result.Top := P^.Y; 797 if P^.Y > Result.Bottom then Result.Bottom := P^.Y; 798 end; 799 end; 800 801begin 802 inherited Create(False); 803 804(* 805 The passed polygon is drawed into grayscale context, the region is constructed 806 per rows from rectangles of drawed polygon parts. 807 *) 808 809 FShape := HIShapeCreateMutable; 810 811 if (NumPts <= 2) or (Points = nil) then Exit; 812 Bounds := GetPolygonBounds; 813 // DebugLn('TCarbonRegion.Create Bounds:' + DbgS(Bounds)); 814 W := Bounds.Right - Bounds.Left + 2; 815 H := Bounds.Bottom - Bounds.Top + 2; 816 817 if (W <= 0) or (H <= 0) then Exit; 818 819 ScanObj := TScanObject.create(FShape, Bounds.Left, Bounds.Top, W, H); 820 try 821 if ScanObj.Setup then begin 822 // draw object to scan 823 P := Points; 824 CGContextBeginPath(ScanObj.Context); 825 CGContextMoveToPoint(ScanObj.Context, P^.X, P^.Y); 826 for I := 1 to NumPts - 1 do 827 begin 828 Inc(P); 829 CGContextAddLineToPoint(ScanObj.Context, P^.X, P^.Y); 830 end; 831 CGContextClosePath(ScanObj.Context); 832 if FillMode = ALTERNATE then 833 CGContextEOFillPath(ScanObj.Context) 834 else 835 CGContextFillPath(ScanObj.Context); 836 837 // scan object in current path 838 ScanObj.Scan; 839 end; 840 finally 841 ScanObj.free; 842 end; 843end; 844 845constructor TCarbonRegion.CreateEllipse(X1, Y1, X2, Y2: Integer); 846var 847 R: CGRect; 848 ScanObj: TScanObject; 849 i: Integer; 850begin 851 FShape := HIShapeCreateMutable; 852 853 if X2<X1 then begin i:=X1; X1:=X2; X2:=i; end; 854 if Y2<Y1 then begin i:=Y1; Y1:=Y2; Y2:=i; end; 855 856 R := getCGRect(X1, Y1, X2, Y2); 857 R.origin.x := R.origin.x + 0.5; 858 R.origin.y := R.origin.y + 0.5; 859 R.size.width := R.size.width - 1; 860 R.size.height := R.size.height - 1; 861 862 with R do 863 ScanObj := TScanObject.create(FShape, X1, Y1, X2-X1+1, Y2-Y1+1); 864 try 865 with ScanObj do 866 if Setup then begin 867 CGContextSetGrayStrokeColor(Context, 1.0, 1.0); // draw white stroke 868 CGContextSetGrayFillColor(Context, 0.0, 0.0); // draw black fill 869 CGContextBeginPath(Context); 870 CGContextAddEllipseInRect(Context, R); 871 CGContextDrawPath(Context, kCGPathFillStroke); 872 // scan object in current path 873 ScanConvex; 874 end; 875 finally 876 ScanObj.free; 877 end; 878 879end; 880 881{------------------------------------------------------------------------------ 882 Method: TCarbonRegion.Destroy 883 884 Destroys Carbon region 885 ------------------------------------------------------------------------------} 886destructor TCarbonRegion.Destroy; 887begin 888 CFRelease(FShape); 889 890 inherited Destroy; 891end; 892 893{------------------------------------------------------------------------------ 894 Method: TCarbonRegion.Apply 895 Params: ADC - Context to apply to 896 897 Applies region to the specified context 898 Note: Clipping region is only reducing 899 ------------------------------------------------------------------------------} 900procedure TCarbonRegion.Apply(ADC: TCarbonContext); 901var 902 DeviceShape: HIShapeRef; 903begin 904 if ADC = nil then Exit; 905 if ADC.CGContext = nil then Exit; 906 DeviceShape := HIShapeCreateMutableCopy(Shape); 907 try 908 with ADC.GetLogicalOffset do 909 HIShapeOffset(DeviceShape, -X, -Y); 910 if HIShapeIsEmpty(DeviceShape) or OSError(HIShapeReplacePathInCGContext(DeviceShape, ADC.CGContext), 911 Self, 'Apply', 'HIShapeReplacePathInCGContext') then Exit; 912 CGContextClip(ADC.CGContext); 913 finally 914 CFRelease(DeviceShape); 915 end; 916end; 917 918{------------------------------------------------------------------------------ 919 Method: TCarbonRegion.GetBounds 920 Returns: The bounding box of Carbon region 921 ------------------------------------------------------------------------------} 922function TCarbonRegion.GetBounds: TRect; 923var 924 R: HIRect; 925begin 926 if HIShapeGetBounds(FShape, R{%H-}) = nil then 927 begin 928 DebugLn('TCarbonRegion.GetBounds Error!'); 929 Exit; 930 end; 931 932 Result := CGRectToRect(R); 933end; 934 935{------------------------------------------------------------------------------ 936 Method: TCarbonRegion.GetType 937 Returns: The type of Carbon region 938 ------------------------------------------------------------------------------} 939function TCarbonRegion.GetType: Integer; 940begin 941 Result := ERROR; 942 if HIShapeIsEmpty(FShape) then 943 Result := NULLREGION 944 else 945 if HIShapeIsRectangular(FShape) then 946 Result := SIMPLEREGION 947 else 948 Result := COMPLEXREGION; 949end; 950 951{------------------------------------------------------------------------------ 952 Method: TCarbonRegion.ContainsPoint 953 Params: P - Point 954 Returns: If the specified point lies in Carbon region 955 ------------------------------------------------------------------------------} 956function TCarbonRegion.ContainsPoint(const P: TPoint): Boolean; 957begin 958 Result := HIShapeContainsPoint(FShape, PointToHIPoint(P)); 959end; 960 961procedure TCarbonRegion.SetShape(AShape: HIShapeRef); 962begin 963 if Assigned(FShape) then CFRelease(FShape); 964 FShape := AShape; 965end; 966 967function TCarbonRegion.CombineWith(ARegion: TCarbonRegion; CombineMode: Integer): Integer; 968var 969 sh1, sh2: HIShapeRef; 970const 971 MinCoord=-35000; 972 MaxSize=65000; 973begin 974 if not Assigned(ARegion) then 975 Result := LCLType.Error 976 else 977 begin 978 if (CombineMode in [RGN_AND, RGN_OR, RGN_XOR]) and HIShapeIsEmpty(FShape) then 979 CombineMode := RGN_COPY; 980 981 case CombineMode of 982 RGN_AND: 983 begin 984 Shape := HIShapeCreateIntersection(FShape, ARegion.Shape); 985 Result := GetType; 986 end; 987 RGN_XOR: 988 begin 989 sh1 := HIShapeCreateUnion(FShape, ARegion.Shape); 990 sh2 := HIShapeCreateIntersection(FShape, ARegion.Shape); 991 Shape := HIShapeCreateDifference(sh1, sh2); 992 CFRelease(sh1); 993 CFRelease(sh2); 994 Result := GetType; 995 end; 996 RGN_OR: 997 begin 998 Shape := HIShapeCreateUnion(FShape, ARegion.Shape); 999 Result := GetType; 1000 end; 1001 RGN_DIFF: 1002 begin 1003 if HIShapeIsEmpty(FShape) then 1004 {HIShapeCreateDifference doesn't work properly if original shape is empty} 1005 {to simulate "emptieness" very big shape is created } 1006 Shape := HIShapeCreateWithRect(GetCGRect(MinCoord, MinCoord, MaxSize, MaxSize)); // create clip nothing. 1007 1008 Shape := HIShapeCreateDifference(FShape, ARegion.Shape); 1009 Result := GetType; 1010 end; 1011 RGN_COPY: 1012 begin 1013 Shape := HIShapeCreateCopy(ARegion.Shape); 1014 Result := GetType; 1015 end 1016 else 1017 Result := LCLType.Error; 1018 end; 1019 end; 1020end; 1021 1022procedure TCarbonRegion.Offset(dx, dy: Integer); 1023begin 1024 MakeMutable; 1025 HIShapeOffset(FShape, dx, dy); 1026end; 1027 1028function TCarbonRegion.GetShapeCopy: HIShapeRef; 1029begin 1030 Result := HIShapeCreateCopy(Shape); 1031end; 1032 1033procedure TCarbonRegion.MakeMutable; 1034begin 1035 Shape := HIShapeCreateMutableCopy(Shape); 1036end; 1037 1038{ TCarbonTextLayout } 1039 1040procedure TCarbonTextLayout.Release; 1041begin 1042 Free; 1043end; 1044 1045function TCarbonTextLayout.GetHeight: Integer; 1046begin 1047 Result := RoundFixed(Descent + Ascent); 1048end; 1049 1050function TCarbonTextLayout.GetWidth: Integer; 1051begin 1052 Result := RoundFixed(TextAfter - TextBefore); 1053end; 1054 1055function TCarbonTextLayout.GetDrawBounds(X, Y: Integer): CGRect; 1056begin 1057 Result := GetCGRectSorted(X - RoundFixed(FTextBefore), 1058 -Y, X + RoundFixed(FTextAfter), -Y - RoundFixed(FAscent + FDescent)); 1059end; 1060 1061 1062{------------------------------------------------------------------------------ 1063 Method: TCarbonTextLayoutBuffer.Create 1064 Params: Text - UTF-8 text 1065 Font - Text font 1066 TextFractional 1067 1068 Creates new Carbon text layout with buffer 1069 ------------------------------------------------------------------------------} 1070constructor TCarbonTextLayoutBuffer.Create(const Text: String; Font: TCarbonFont; TextFractional: Boolean); 1071var 1072 TextStyle: ATSUStyle; 1073 TextLength: LongWord; 1074 Tag: ATSUAttributeTag; 1075 DataSize: ByteCount; 1076 Options: ATSLineLayoutOptions; 1077 PValue: ATSUAttributeValuePtr; 1078begin 1079 // keep copy of text 1080 FTextBuffer := UTF8ToUTF16(Text); 1081 if FTextBuffer='' then 1082 FTextBuffer:=#0#0; 1083 TextStyle := Font.Style; 1084 1085 // create text layout 1086 TextLength := kATSUToTextEnd; 1087 if OSError(ATSUCreateTextLayoutWithTextPtr(ConstUniCharArrayPtr(@FTextBuffer[1]), 1088 kATSUFromTextBeginning, kATSUToTextEnd, Length(FTextBuffer), 1, @TextLength, 1089 @TextStyle, FLayout), Self, SCreate, 'ATSUCreateTextLayoutWithTextPtr') then Exit; 1090 1091 // set layout line orientation 1092 Tag := kATSULineRotationTag; 1093 DataSize := SizeOf(Fixed); 1094 1095 FLineRotation := Font.LineRotation; 1096 PValue := @(FLineRotation); 1097 if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue), 1098 Self, SCreate, 'ATSUSetLayoutControls', 'LineRotation') then Exit; 1099 1100 if not TextFractional then 1101 begin 1102 // disable fractional positions of glyphs in layout 1103 Tag := kATSULineLayoutOptionsTag; 1104 DataSize := SizeOf(ATSLineLayoutOptions); 1105 1106 Options := kATSLineFractDisable or kATSLineDisableAutoAdjustDisplayPos or 1107 kATSLineDisableAllLayoutOperations or kATSLineUseDeviceMetrics; 1108 PValue := @Options; 1109 if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue), 1110 Self, SCreate, 'ATSUSetLayoutControls', 'LineLayoutOptions') then Exit; 1111 end; 1112 1113 FDC := nil; 1114 FWidget := nil; 1115 1116 // allow font substitution for exotic glyphs 1117 OSError(ATSUSetTransientFontMatching(FLayout, True), Self, SCreate, 1118 'ATSUSetTransientFontMatching'); 1119end; 1120 1121{------------------------------------------------------------------------------ 1122 Method: TCarbonTextLayoutBuffer.Apply 1123 Params: ADC - Context to apply to 1124 1125 Applies text layout to the specified context 1126 ------------------------------------------------------------------------------} 1127procedure TCarbonTextLayoutBuffer.Apply(ADC: TCarbonContext); 1128var 1129 Tag: ATSUAttributeTag; 1130 DataSize: ByteCount; 1131 PValue: ATSUAttributeValuePtr; 1132begin 1133 // check if must reset layout to new context 1134 if FDC = ADC then 1135 begin 1136 if (ADC is TCarbonControlContext) then 1137 begin 1138 if FWidget = (ADC as TCarbonControlContext).Owner.Content then Exit; 1139 end 1140 else 1141 if FWidget = nil then Exit; 1142 end; 1143 1144 FDC := ADC; 1145 if ADC is TCarbonControlContext then 1146 FWidget := (ADC as TCarbonControlContext).Owner.Content 1147 else 1148 FWidget := nil; 1149 1150 // set layout context 1151 Tag := kATSUCGContextTag; 1152 DataSize := SizeOf(CGContextRef); 1153 1154 PValue := @(ADC.CGContext); 1155 if OSError(ATSUSetLayoutControls(FLayout, 1, @Tag, @DataSize, @PValue), 1156 Self, 'Apply', 'ATSUSetLayoutControls', 'CGContext') then Exit; 1157 1158 // get text ascent 1159 if OSError( 1160 ATSUGetUnjustifiedBounds(FLayout, kATSUFromTextBeginning, kATSUToTextEnd, 1161 FTextBefore, FTextAfter, FAscent, FDescent), 1162 Self, 'Apply', SGetUnjustifiedBounds) then Exit; 1163end; 1164 1165 1166function ATSUCallback({%H-}iCurrentOperation: ATSULayoutOperationSelector; iLineRef: ATSULineRef; iRefCon: UInt32; {%H-}iOperationCallbackParameterPtr: UnivPtr; 1167 var oCallbackStatus: ATSULayoutOperationCallbackStatus ): OSStatus; {$ifdef DARWIN}mwpascal;{$endif} 1168var 1169 Buffer : TCarbonTextLayoutBuffer; 1170 Handled : Boolean; 1171begin 1172 Result := noErr; 1173 Buffer := TCarbonTextLayoutBuffer(iRefCon); 1174 oCallbackStatus:=kATSULayoutOperationCallbackStatusHandled; 1175 1176 if Assigned(Buffer) then begin 1177 Handled:=false; 1178 Buffer.DoJustify(iLineRef, Handled); 1179 end; 1180end; 1181 1182procedure TCarbonTextLayoutBuffer.DoJustify(iLineRef: ATSULineRef; var Handled: Boolean); 1183type 1184 ATSLayoutRecord1 = packed record 1185 glyphID: ATSGlyphRef; 1186 flags: ATSGlyphInfoFlags; 1187 originalOffset: ByteCount; 1188 realPos: Fixed; 1189 end; 1190 1191type 1192 TATSLayoutRecordArray = array [Word] of ATSLayoutRecord1; 1193 PATSLayoutRecordArray = ^TATSLayoutRecordArray; 1194var 1195 i, ofs : Integer; 1196 Layouts : PATSLayoutRecordArray; 1197 LayCount : ItemCount; 1198begin 1199 if not Assigned(FDX) or (FDXCount=0) then Exit; 1200 Laycount:=0; 1201 ATSUDirectGetLayoutDataArrayPtrFromLineRef( iLineRef, 1202 kATSUDirectDataLayoutRecordATSLayoutRecordVersion1, true, @Layouts, Laycount); 1203 if Assigned(Layouts) and (Laycount>0) then 1204 begin 1205 ofs:=0; 1206 for i:=0 to Min(FDXCount, LayCount)-1 do 1207 begin 1208 Layouts^[i].realPos:=Long2Fix(ofs); 1209 inc(ofs, FDX[i]); 1210 end; 1211 end; 1212 ATSUDirectReleaseLayoutDataArrayPtr(iLineRef, kATSUDirectDataLayoutRecordATSLayoutRecordCurrent, @Layouts ); 1213 Handled:=True; 1214end; 1215 1216function TCarbonTextLayoutBuffer.Draw(X, Y: Integer; Dx: PInteger; DXCount: Integer): Boolean; 1217var 1218 MX, MY: ATSUTextMeasurement; 1219 A: Single; 1220 theTag : ATSUAttributeTag; 1221 theSize : ByteCount; 1222 theValue : ATSUAttributeValuePtr; 1223 OverSpec : ATSULayoutOperationOverrideSpecifier; 1224begin 1225 Result := False; 1226 1227 if FLineRotation <> 0 then 1228 begin 1229 A := FLineRotation * (PI / ($10000 * 180)); 1230 MX := Round(Ascent * Sin(A)); 1231 MY := Round(Ascent - Ascent * Cos(A)); 1232 end 1233 else 1234 begin 1235 MX := 0; 1236 MY := 0; 1237 end; 1238 1239 if Assigned(Dx) then begin 1240 FDX := Dx; 1241 FDxCount := DXCount; 1242 idx:=0; 1243 OverSpec.operationSelector := kATSULayoutOperationPostLayoutAdjustment; 1244 OverSpec.overrideUPP := NewATSUDirectLayoutOperationOverrideUPP(@ATSUCallback); 1245 theTag := kATSULayoutOperationOverrideTag; 1246 theSize := sizeof (ATSULayoutOperationOverrideSpecifier); 1247 theValue := @OverSpec; 1248 ATSUSetTextLayoutRefCon(FLayout, UInt32(Self)); 1249 ATSUSetLayoutControls (FLayout, 1, @theTag, @theSize, @theValue); 1250 end else begin 1251 FDX:=nil; 1252 FDXCount:=0; 1253 end; 1254 1255 if OSError(ATSUDrawText(FLayout, kATSUFromTextBeginning, kATSUToTextEnd, 1256 X shl 16 - FTextBefore + MX, -(Y shl 16) - FAscent + MY), 1257 Self, 'Draw', 'ATSUDrawText') then Exit; 1258 1259 if Assigned(Dx) then begin 1260 DisposeATSUDirectLayoutOperationOverrideUPP(OverSpec.overrideUPP); 1261 OverSpec.overrideUPP := nil; 1262 ATSUSetLayoutControls (FLayout, 1, @theTag, @theSize, @theValue); 1263 fDX := nil; 1264 end; 1265 1266 Result := True; 1267end; 1268 1269{------------------------------------------------------------------------------ 1270 Method: TCarbonTextLayoutBuffer.Release 1271 1272 Releases text layout 1273 ------------------------------------------------------------------------------} 1274procedure TCarbonTextLayoutBuffer.Release; 1275begin 1276 if FLayout <> nil then 1277 OSError(ATSUDisposeTextLayout(FLayout), Self, 'Release', 'ATSUDisposeTextLayout'); 1278 1279 inherited; 1280end; 1281 1282{ TCarbonTextLayoutArray } 1283 1284{------------------------------------------------------------------------------ 1285 Method: TCarbonTextLayoutArray.Create 1286 Params: Text - UTF-8 text 1287 Font - Text font 1288 1289 Creates new Carbon text layout array 1290 ------------------------------------------------------------------------------} 1291constructor TCarbonTextLayoutArray.Create(const Text: String; Font: TCarbonFont); 1292begin 1293 FText := Text; 1294 FFont := Font; 1295end; 1296 1297{------------------------------------------------------------------------------ 1298 Method: TCarbonTextLayoutArray.Apply 1299 Params: ADC - Context to apply to 1300 1301 Applies text layout to the specified context 1302 ------------------------------------------------------------------------------} 1303procedure TCarbonTextLayoutArray.Apply(ADC: TCarbonContext); 1304var 1305 I: Integer; 1306begin 1307 FAscent := 0; 1308 FDescent := 0; 1309 FTextBefore := 0; 1310 FTextAfter := 0; 1311 1312 for I := 1 to Length(FText) do 1313 begin 1314 FFont.FCachedLayouts[Ord(FText[I])].Apply(ADC); 1315 1316 if I = 1 then 1317 begin 1318 FAscent := FFont.FCachedLayouts[Ord(FText[1])].FAscent; 1319 FDescent := FFont.FCachedLayouts[Ord(FText[1])].FDescent; 1320 FTextBefore := FFont.FCachedLayouts[Ord(FText[1])].FTextBefore; 1321 FTextAfter := FTextBefore; 1322 end; 1323 FTextAfter := FTextAfter + Long2Fix(FFont.FCachedLayouts[Ord(FText[I])].GetWidth); 1324 end; 1325end; 1326 1327function TCarbonTextLayoutArray.Draw(X, Y: Integer; Dx: PInteger; DXCount: Integer): Boolean; 1328var 1329 I : Integer; 1330 ix : Integer; 1331begin 1332 Result := False; 1333 ix := 0; 1334 for I := 1 to Length(FText) do 1335 begin 1336 Result := FFont.FCachedLayouts[Ord(FText[I])].Draw(X, Y, nil, 0); 1337 if Assigned(dx) and (ix < DXCount) then 1338 begin 1339 Inc(X, Dx[ix]); 1340 inc(ix); 1341 end 1342 else 1343 Inc(X, FFont.FCachedLayouts[Ord(FText[I])].GetWidth); 1344 end; 1345 1346 Result := True; 1347end; 1348 1349{ TCarbonFont } 1350 1351{------------------------------------------------------------------------------ 1352 Method: TCarbonFont.Create 1353 Params: AGlobal 1354 1355 Creates default Carbon font 1356 ------------------------------------------------------------------------------} 1357constructor TCarbonFont.Create(AGlobal: Boolean); 1358begin 1359 inherited Create(AGlobal); 1360 1361 FStyle := DefaultTextStyle; 1362 FLineRotation := 0; 1363end; 1364 1365{------------------------------------------------------------------------------ 1366 Method: TCarbonFont.Create 1367 Params: ALogFont - Font characteristics 1368 AFaceName - Name of the font 1369 1370 Creates Carbon font with the specified name and characteristics 1371 ------------------------------------------------------------------------------} 1372constructor TCarbonFont.Create(ALogFont: TLogFont; const AFaceName: String); 1373begin 1374 inherited Create(False); 1375 1376 FStyle := CreateStyle(ALogFont, AFaceName); 1377 1378 // applied when creating text layout 1379 FLineRotation := (ALogFont.lfEscapement shl 16) div 10; 1380end; 1381 1382{------------------------------------------------------------------------------ 1383 Method: TCarbonFont.CreateStyle 1384 Params: ALogFont - Font characteristics 1385 AFaceName - Name of the font 1386 Returns: ATSUStyle for the specified font name and characteristics 1387 ------------------------------------------------------------------------------} 1388function TCarbonFont.CreateStyle(ALogFont: TLogFont; const AFaceName: String): ATSUStyle; 1389var 1390 Attr: ATSUAttributeTag; 1391 M: ATSUTextMeasurement; 1392 O: ATSStyleRenderingOptions; 1393 B: Boolean; 1394 S: ByteCount; 1395 A: ATSUAttributeValuePtr; 1396 ID: ATSUFontID; 1397 H: Integer; 1398 Bold, Italic: Boolean; 1399const 1400 SSetAttrs = 'ATSUSetAttributes'; 1401 SName = 'CreateStyle'; 1402 ATSStyleRenderingOption: Array [NONANTIALIASED_QUALITY..ANTIALIASED_QUALITY] of 1403 ATSStyleRenderingOptions = (kATSStyleNoAntiAliasing, kATSStyleApplyAntiAliasing); 1404begin 1405 inherited Create(False); 1406 1407 Result:=nil; 1408 OSError(ATSUCreateStyle(Result), Self, SName, SCreateStyle); 1409 1410 Bold := ALogFont.lfWeight > FW_NORMAL; 1411 Italic := ALogFont.lfItalic > 0; 1412 ID := FindCarbonFontID(AFaceName, Bold, Italic, (ALogFont.lfPitchAndFamily and FIXED_PITCH) <> 0); 1413 1414 if ID <> 0 then 1415 begin 1416 Attr := kATSUFontTag; 1417 A := @ID; 1418 S := SizeOf(ID); 1419 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1420 SSetAttrs, 'kATSUFontTag'); 1421 end; 1422 1423 if ALogFont.lfHeight = 0 1424 then H := CarbonDefaultFontSize 1425 else H := ALogFont.lfHeight; 1426 1427 Attr := kATSUSizeTag; 1428 M := Abs(H) shl 16; 1429 A := @M; 1430 S := SizeOf(M); 1431 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1432 SSetAttrs, 'kATSUSizeTag'); 1433 1434 if Bold then 1435 begin 1436 Attr := kATSUQDBoldfaceTag; 1437 B := True; 1438 A := @B; 1439 S := SizeOf(B); 1440 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1441 SSetAttrs, 'kATSUQDBoldfaceTag'); 1442 end; 1443 1444 if Italic then 1445 begin 1446 Attr := kATSUQDItalicTag; 1447 B := True; 1448 A := @B; 1449 S := SizeOf(B); 1450 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, SSetAttrs, 1451 'kATSUQDItalicTag'); 1452 end; 1453 1454 if ALogFont.lfUnderline > 0 then 1455 begin 1456 Attr := kATSUQDUnderlineTag; 1457 B := True; 1458 A := @B; 1459 S := SizeOf(B); 1460 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1461 SSetAttrs, 'kATSUQDUnderlineTag'); 1462 end; 1463 1464 if ALogFont.lfStrikeOut > 0 then 1465 begin 1466 Attr := kATSUStyleStrikeThroughTag; 1467 B := True; 1468 A := @B; 1469 S := SizeOf(B); 1470 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1471 SSetAttrs, 'kATSUStyleStrikeThroughTag'); 1472 end; 1473 1474 if (ALogFont.lfQuality >= NONANTIALIASED_QUALITY) and 1475 (ALogFont.lfQuality <= ANTIALIASED_QUALITY) then 1476 begin 1477 Attr := kATSUStyleRenderingOptionsTag; 1478 O := ATSStyleRenderingOption[ALogFont.lfQuality]; 1479 A := @O; 1480 S := SizeOf(O); 1481 OSError(ATSUSetAttributes(Result, 1, @Attr, @S, @A), Self, SName, 1482 SSetAttrs, 'kATSUStyleRenderingOptionsTag'); 1483 end; 1484end; 1485 1486{------------------------------------------------------------------------------ 1487 Method: TCarbonFont.QueryStyle 1488 Params: ALogFont - Font characteristics 1489 ------------------------------------------------------------------------------} 1490procedure TCarbonFont.QueryStyle(ALogFont: PLogFont); 1491var 1492 Attr: ATSUAttributeTag; 1493 M: ATSUTextMeasurement; 1494 O: ATSStyleRenderingOptions; 1495 B: Boolean; 1496 S: ByteCount; 1497 A: ATSUAttributeValuePtr; 1498 ID: ATSUFontID; 1499 Ascent, Leading, Descent: Integer; 1500const 1501 SGetAttr = 'ATSUGetAttribute'; 1502 SName = 'QueryStyle'; 1503 1504begin 1505 1506 Attr := kATSUFontTag; 1507 A := @ID; 1508 S := SizeOf(ID); 1509 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, 1510 SGetAttr, 'kATSUFontTag', kATSUNotSetErr); 1511 1512 ALogFont^.lfFaceName := CarbonFontIDTOFontName(ID); 1513 1514 1515 A := @M; 1516 S := SizeOf(M); 1517 OSError(ATSUGetAttribute(Style, kATSUAscentTag, S, A, nil), Self, SName, 1518 SGetAttr, 'kATSUAscentTag', kATSUNotSetErr); 1519 Ascent := (M shr 16); 1520 1521 OSError(ATSUGetAttribute(Style, kATSULeadingTag, S, A, nil), Self, SName, 1522 SGetAttr, 'kATSULeadingTag', kATSUNotSetErr); 1523 Leading := (M shr 16); 1524 1525 OSError(ATSUGetAttribute(Style, kATSUDescentTag, S, A, nil), Self, SName, 1526 SGetAttr, 'kATSUDescentTag', kATSUNotSetErr); 1527 Descent := (M shr 16); 1528 1529 ALogFont^.lfHeight := Ascent + Leading + Descent; 1530 1531 1532 Attr := kATSUQDBoldfaceTag; 1533 A := @B; 1534 S := SizeOf(B); 1535 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, 1536 SGetAttr, 'kATSUQDBoldfaceTag', kATSUNotSetErr); 1537 1538 if B then ALogFont^.lfWeight := FW_BOLD else ALogFont^.lfWeight := FW_NORMAL; 1539 1540 1541 Attr := kATSUQDItalicTag; 1542 A := @B; 1543 S := SizeOf(B); 1544 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, SGetAttr, 1545 'kATSUQDItalicTag', kATSUNotSetErr); 1546 1547 if B then ALogFont^.lfItalic := 1 else ALogFont^.lfItalic := 0; 1548 1549 1550 Attr := kATSUQDUnderlineTag; 1551 A := @B; 1552 S := SizeOf(B); 1553 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, 1554 SGetAttr, 'kATSUQDUnderlineTag', kATSUNotSetErr); 1555 1556 if B then ALogFont^.lfUnderline := 1 else ALogFont^.lfUnderLine := 0; 1557 1558 1559 Attr := kATSUStyleStrikeThroughTag; 1560 A := @B; 1561 S := SizeOf(B); 1562 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, 1563 SGetAttr, 'kATSUStyleStrikeThroughTag', kATSUNotSetErr); 1564 1565 if B then ALogFont^.lfStrikeOut := 1 else ALogFont^.lfStrikeOut := 0; 1566 1567 1568 Attr := kATSUStyleRenderingOptionsTag; 1569 A := @O; 1570 S := SizeOf(O); 1571 OSError(ATSUGetAttribute(Style, Attr, S, A, nil), Self, SName, 1572 SGetAttr, 'kATSUStyleRenderingOptionsTag', kATSUNotSetErr); 1573 1574 case O of 1575 kATSStyleApplyAntiAliasing: ALogFont^.lfQuality := ANTIALIASED_QUALITY; 1576 kATSStyleNoAntiAliasing: ALogFont^.lfQuality := NONANTIALIASED_QUALITY; 1577 else 1578 ALogFont^.lfQuality := DEFAULT_QUALITY; 1579 end; 1580end; 1581 1582{------------------------------------------------------------------------------ 1583 Method: TCarbonFont.Destroy 1584 1585 Frees Carbon font 1586 ------------------------------------------------------------------------------} 1587destructor TCarbonFont.Destroy; 1588var 1589 I: Integer; 1590begin 1591 if FStyle <> DefaultTextStyle then 1592 OSError(ATSUDisposeStyle(FStyle), Self, SDestroy, SDisposeStyle); 1593 for I := 0 to High(FCachedLayouts) do 1594 if FCachedLayouts[I] <> nil then FCachedLayouts[I].Release; 1595 1596 inherited; 1597end; 1598 1599{------------------------------------------------------------------------------ 1600 Method: TCarbonFont.SetColor 1601 Params: AColor - Font color 1602 1603 Chnage font style color 1604 ------------------------------------------------------------------------------} 1605procedure TCarbonFont.SetColor(AColor: TColor); 1606var 1607 Attr: ATSUAttributeTag; 1608 S: ByteCount; 1609 A: ATSUAttributeValuePtr; 1610 C: RGBColor; 1611begin 1612 C := ColorToRGBColor(AColor); 1613 1614 Attr := kATSUColorTag; 1615 A := @C; 1616 S := SizeOf(C); 1617 OSError(ATSUSetAttributes(Style, 1, @Attr, @S, @A), Self, SSetColor, 1618 'ATSUSetAttributes'); 1619end; 1620 1621function TCarbonFont.CreateTextLayout(const Text: String; 1622 TextFractional: Boolean): TCarbonTextLayout; 1623 1624 function IsTextASCII: Boolean; 1625 var 1626 I: Integer; 1627 C: Byte; 1628 begin 1629 Result := False; 1630 1631 for I := 1 to Length(Text) do 1632 begin 1633 C := Ord(Text[I]); 1634 if (C > 127) or (C = 10) or (C = 13) then Exit; 1635 end; 1636 1637 Result := True; 1638 end; 1639var 1640 I, J, L: Integer; 1641 C: Byte; 1642begin 1643 if (FLineRotation <> 0) or TextFractional or not IsTextASCII then 1644 Result := TCarbonTextLayoutBuffer.Create(Text, Self, TextFractional) 1645 else 1646 begin 1647 for I := 1 to Length(Text) do 1648 begin 1649 C := Ord(Text[I]); 1650 if C > High(FCachedLayouts) then 1651 begin 1652 L := Length(FCachedLayouts); 1653 SetLength(FCachedLayouts, C + 1); 1654 for J := L to C do FCachedLayouts[J] := nil; 1655 end; 1656 1657 if FCachedLayouts[C] = nil then 1658 FCachedLayouts[C] := TCarbonTextLayoutBuffer.Create(Text[I], Self, TextFractional); 1659 end; 1660 1661 Result := TCarbontextLayoutArray.Create(Text, Self); 1662 end; 1663end; 1664 1665{ TCarbonColorObject } 1666 1667function TCarbonColorObject.GetColorRef: TColorRef; 1668begin 1669 Result := TColorRef(RGBToColor(FR, FG, FB)); 1670end; 1671 1672{------------------------------------------------------------------------------ 1673 Method: TCarbonColorObject.Create 1674 Params: AColor - Color 1675 ASolid - Opacity 1676 AGlobal - Global 1677 1678 Creates Carbon color object 1679 ------------------------------------------------------------------------------} 1680constructor TCarbonColorObject.Create(const AColor: TColor; ASolid, AGlobal: Boolean); 1681begin 1682 inherited Create(AGlobal); 1683 1684 SetColor(AColor, ASolid); 1685end; 1686 1687{------------------------------------------------------------------------------ 1688 Method: TCarbonColorObject.SetColor 1689 Params: AColor - Color 1690 ASolid - Opacity 1691 1692 Sets the color and opacity 1693 ------------------------------------------------------------------------------} 1694procedure TCarbonColorObject.SetColor(const AColor: TColor; ASolid: Boolean); 1695begin 1696 RedGreenBlue(ColorToRGB(AColor), FR, FG, FB); 1697 FA := ASolid; 1698end; 1699 1700{------------------------------------------------------------------------------ 1701 Method: TCarbonColorObject.GetRGBA 1702 Params: AROP2 - Binary raster operation 1703 AR, AG, AB, AA - Red, green, blue, alpha component of color 1704 1705 Gets the individual color components according to the binary raster operation 1706 ------------------------------------------------------------------------------} 1707procedure TCarbonColorObject.GetRGBA(AROP2: Integer; out AR, AG, AB, AA: Single); 1708begin 1709 case AROP2 of 1710 R2_BLACK: 1711 begin 1712 AR := 0; 1713 AG := 0; 1714 AB := 0; 1715 AA := Byte(FA); 1716 end; 1717 R2_WHITE: 1718 begin 1719 AR := 1; 1720 AG := 1; 1721 AB := 1; 1722 AA := Byte(FA); 1723 end; 1724 R2_NOP: 1725 begin 1726 AR := 1; 1727 AG := 1; 1728 AB := 1; 1729 AA := 0; 1730 end; 1731 R2_NOT: 1732 begin 1733 AR := 1; 1734 AG := 1; 1735 AB := 1; 1736 AA := Byte(FA); 1737 end; 1738 R2_NOTXORPEN, R2_NOTCOPYPEN: 1739 begin 1740 AR := (255 - FR) / 255; 1741 AG := (255 - FG) / 255; 1742 AB := (255 - FB) / 255; 1743 AA := Byte(FA); 1744 end; 1745 else // copy 1746 begin 1747 AR := FR / 255; 1748 AG := FG / 255; 1749 AB := FB / 255; 1750 AA := Byte(FA); 1751 end; 1752 end; 1753end; 1754 1755{------------------------------------------------------------------------------ 1756 Method: TCarbonColorObject.CreateCGColor 1757 Returns: CGColor 1758 ------------------------------------------------------------------------------} 1759function TCarbonColorObject.CreateCGColor: CGColorRef; 1760var 1761 F: Array [0..3] of Single; 1762begin 1763 F[0] := FR / 255; 1764 F[1] := FG / 255; 1765 F[2] := FB / 255; 1766 F[3] := Byte(FA); 1767 1768 Result := CGColorCreate(RGBColorSpace, @F[0]); 1769end; 1770 1771{ TCarbonBrush } 1772 1773procedure DrawBitmapPattern(info: UnivPtr; c: CGContextRef); MWPascal; 1774var 1775 ABrush: TCarbonBrush absolute info; 1776 AImage: CGImageRef; 1777begin 1778 AImage := ABrush.FBitmap.CGImage; 1779 CGContextDrawImage(c, GetCGRect(0, 0, CGImageGetWidth(AImage), CGImageGetHeight(AImage)), 1780 AImage); 1781end; 1782 1783procedure TCarbonBrush.SetHatchStyle(AHatch: PtrInt); 1784const 1785 HATCH_DATA: array[HS_HORIZONTAL..HS_DIAGCROSS] of array[0..7] of Byte = 1786 ( 1787 { HS_HORIZONTAL } ($FF, $FF, $FF, $00, $FF, $FF, $FF, $FF), 1788 { HS_VERTICAL } ($F7, $F7, $F7, $F7, $F7, $F7, $F7, $F7), 1789 { HS_FDIAGONAL } ($7F, $BF, $DF, $EF, $F7, $FB, $FD, $FE), 1790 { HS_BDIAGONAL } ($FE, $FD, $FB, $F7, $EF, $DF, $BF, $7F), 1791 { HS_CROSS } ($F7, $F7, $F7, $00, $F7, $F7, $F7, $F7), 1792 { HS_DIAGCROSS } ($7E, $BD, $DB, $E7, $E7, $DB, $BD, $7E) 1793 ); 1794var 1795 ACallBacks: CGPatternCallbacks; 1796begin 1797 if AHatch in [HS_HORIZONTAL..HS_DIAGCROSS] then 1798 begin 1799 FillChar(ACallBacks{%H-}, SizeOf(ACallBacks), 0); 1800 ACallBacks.drawPattern := @DrawBitmapPattern; 1801 FBitmap := TCarbonBitmap.Create(8, 8, 1, 1, cbaByte, cbtMask, @HATCH_DATA[AHatch]); 1802 FColored := False; 1803 FCGPattern := CGPatternCreate(Self, GetCGRect(0, 0, 8, 8), 1804 CGAffineTransformIdentity, 8, 8, kCGPatternTilingConstantSpacing, 1805 Ord(FColored), ACallBacks); 1806 end; 1807end; 1808 1809procedure TCarbonBrush.SetBitmap(ABitmap: TCarbonBitmap); 1810var 1811 AWidth, AHeight: Integer; 1812 ACallBacks: CGPatternCallbacks; 1813begin 1814 AWidth := ABitmap.Width; 1815 AHeight := ABitmap.Height; 1816 FillChar(ACallBacks{%H-}, SizeOf(ACallBacks), 0); 1817 ACallBacks.drawPattern := @DrawBitmapPattern; 1818 FBitmap := TCarbonBitmap.Create(ABitmap); 1819 FColored := True; 1820 FCGPattern := CGPatternCreate(Self, GetCGRect(0, 0, AWidth, AHeight), 1821 CGAffineTransformIdentity, AWidth, AHeight, kCGPatternTilingConstantSpacing, 1822 Ord(FColored), ACallBacks); 1823end; 1824 1825{------------------------------------------------------------------------------ 1826 Method: TCarbonBrush.Create 1827 Params: AGlobal 1828 1829 Creates default Carbon brush 1830 ------------------------------------------------------------------------------} 1831constructor TCarbonBrush.Create(AGlobal: Boolean); 1832begin 1833 inherited Create(clWhite, True, AGlobal); 1834 FCGPattern := nil; 1835 FBitmap := nil; 1836end; 1837 1838{------------------------------------------------------------------------------ 1839 Method: TCarbonBrush.Create 1840 Params: ALogBrush - Brush characteristics 1841 1842 Creates Carbon brush with the specified characteristics 1843 ------------------------------------------------------------------------------} 1844constructor TCarbonBrush.Create(ALogBrush: TLogBrush); 1845begin 1846 FCGPattern := nil; 1847 FBitmap := nil; 1848 case ALogBrush.lbStyle of 1849 BS_SOLID: 1850 inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), True, False); 1851 BS_HATCHED: // Hatched brush. 1852 begin 1853 inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), True, False); 1854 SetHatchStyle(ALogBrush.lbHatch); 1855 end; 1856 BS_DIBPATTERN, 1857 BS_DIBPATTERN8X8, 1858 BS_DIBPATTERNPT, 1859 BS_PATTERN, 1860 BS_PATTERN8X8: 1861 begin 1862 inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), False, False); 1863 SetBitmap(TCarbonBitmap(ALogBrush.lbHatch)); 1864 end 1865 else 1866 inherited Create(ColorToRGB(TColor(ALogBrush.lbColor)), False, False); 1867 end; 1868end; 1869 1870destructor TCarbonBrush.Destroy; 1871begin 1872 if FCGPattern <> nil then 1873 CGPatternRelease(FCGPattern); 1874 FBitmap.Free; 1875 inherited Destroy; 1876end; 1877 1878{------------------------------------------------------------------------------ 1879 Method: TCarbonBrush.Apply 1880 Params: ADC - Context to apply to 1881 UseROP2 - Consider binary raster operation? 1882 1883 Applies brush to the specified context 1884 ------------------------------------------------------------------------------} 1885procedure TCarbonBrush.Apply(ADC: TCarbonContext; UseROP2: Boolean); 1886var 1887 RGBA: array[0..3] of Single; 1888 AROP2: Integer; 1889 APatternSpace: CGColorSpaceRef; 1890 BaseSpace : CGColorSpaceRef; 1891begin 1892 if ADC = nil then Exit; 1893 if ADC.CGContext = nil then Exit; 1894 1895 if UseROP2 then 1896 AROP2 := (ADC as TCarbonDeviceContext).ROP2 1897 else 1898 AROP2 := R2_COPYPEN; 1899 1900 GetRGBA(AROP2, RGBA[0], RGBA[1], RGBA[2], RGBA[3]); 1901 1902 // Blend Mode is set via TCarbonPen.Apply() 1903 //if AROP2 <> R2_NOT then 1904 // CGContextSetBlendMode(ADC.CGContext, kCGBlendModeNormal) 1905 //else 1906 // CGContextSetBlendMode(ADC.CGContext, kCGBlendModeDifference); 1907 1908 if FCGPattern <> nil then 1909 begin 1910 if not FColored then 1911 BaseSpace:=CGColorSpaceCreateDeviceRGB 1912 else 1913 begin 1914 BaseSpace:=nil; 1915 RGBA[0] := 1.0; 1916 end; 1917 APatternSpace := CGColorSpaceCreatePattern(BaseSpace); 1918 CGContextSetFillColorSpace(ADC.CGContext, APatternSpace); 1919 CGColorSpaceRelease(APatternSpace); 1920 if Assigned(BaseSpace) then CGColorSpaceRelease(BaseSpace); 1921 CGContextSetFillPattern(ADC.CGcontext, FCGPattern, @RGBA[0]); 1922 end 1923 else 1924 CGContextSetRGBFillColor(ADC.CGContext, RGBA[0], RGBA[1], RGBA[2], RGBA[3]); 1925end; 1926 1927{ TCarbonPen } 1928 1929{------------------------------------------------------------------------------ 1930 Method: TCarbonPen.Create 1931 Params: AGlobal 1932 1933 Creates default Carbon pen 1934 ------------------------------------------------------------------------------} 1935constructor TCarbonPen.Create(AGlobal: Boolean); 1936begin 1937 inherited Create(clBlack, True, AGlobal); 1938 FStyle := PS_SOLID; 1939 FWidth := 1; 1940 FIsExtPen := False; 1941 Dashes := nil; 1942end; 1943 1944{------------------------------------------------------------------------------ 1945 Method: TCarbonPen.Create 1946 Params: ALogPen - Pen characteristics 1947 1948 Creates Carbon pen with the specified characteristics 1949 ------------------------------------------------------------------------------} 1950constructor TCarbonPen.Create(ALogPen: TLogPen); 1951begin 1952 case ALogPen.lopnStyle of 1953 PS_SOLID..PS_DASHDOTDOT, 1954 PS_INSIDEFRAME: 1955 begin 1956 inherited Create(ColorToRGB(TColor(ALogPen.lopnColor)), True, False); 1957 FWidth := Max(1, ALogPen.lopnWidth.x); 1958 end; 1959 else 1960 begin 1961 inherited Create(ColorToRGB(TColor(ALogPen.lopnColor)), False, False); 1962 FWidth := 1; 1963 end; 1964 end; 1965 1966 FStyle := ALogPen.lopnStyle; 1967end; 1968 1969constructor TCarbonPen.Create(dwPenStyle, dwWidth: DWord; const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord); 1970var 1971 i: integer; 1972begin 1973 case dwPenStyle and PS_STYLE_MASK of 1974 PS_SOLID..PS_DASHDOTDOT, 1975 PS_USERSTYLE: 1976 begin 1977 inherited Create(ColorToRGB(TColor(lplb.lbColor)), True, False); 1978 end; 1979 else 1980 begin 1981 inherited Create(ColorToRGB(TColor(lplb.lbColor)), False, False); 1982 end; 1983 end; 1984 1985 FIsExtPen := True; 1986 FIsGeometric := (dwPenStyle and PS_TYPE_MASK) = PS_GEOMETRIC; 1987 1988 if IsGeometric then 1989 begin 1990 case dwPenStyle and PS_JOIN_MASK of 1991 PS_JOIN_ROUND: FJoinStyle := kCGLineJoinRound; 1992 PS_JOIN_BEVEL: FJoinStyle := kCGLineJoinBevel; 1993 PS_JOIN_MITER: FJoinStyle := kCGLineJoinMiter; 1994 end; 1995 1996 case dwPenStyle and PS_ENDCAP_MASK of 1997 PS_ENDCAP_ROUND: FEndCap := kCGLineCapRound; 1998 PS_ENDCAP_SQUARE: FEndCap := kCGLineCapSquare; 1999 PS_ENDCAP_FLAT: FEndCap := kCGLineCapButt; 2000 end; 2001 FWidth := Max(1, dwWidth); 2002 end 2003 else 2004 FWidth := 1; 2005 2006 if (dwPenStyle and PS_STYLE_MASK) = PS_USERSTYLE then 2007 begin 2008 SetLength(Dashes, dwStyleCount); 2009 for i := 0 to dwStyleCount - 1 do 2010 Dashes[i] := lpStyle[i]; 2011 end; 2012 2013 FStyle := dwPenStyle and PS_STYLE_MASK; 2014end; 2015 2016{------------------------------------------------------------------------------ 2017 Method: TCarbonPen.Apply 2018 Params: ADC - Context to apply to 2019 UseROP2 - Consider binary raster operation? 2020 2021 Applies pen to the specified context 2022 ------------------------------------------------------------------------------} 2023procedure TCarbonPen.Apply(ADC: TCarbonContext; UseROP2: Boolean); 2024 2025 function GetDashes(Source: TCarbonDashes): TCarbonDashes; 2026 var 2027 i: Integer; 2028 begin 2029 Result := Source; 2030 for i := Low(Result) to High(Result) do 2031 Result[i] := Result[i] * FWidth; 2032 end; 2033 2034var 2035 AR, AG, AB, AA: Single; 2036 AROP2: Integer; 2037 ADashes: TCarbonDashes; 2038 blendmode: CGBlendMode; 2039begin 2040 if ADC = nil then Exit; 2041 if ADC.CGContext = nil then Exit; 2042 2043 if UseROP2 then AROP2 := (ADC as TCarbonDeviceContext).ROP2 2044 else AROP2 := R2_COPYPEN; 2045 2046 GetRGBA(AROP2, AR, AG, AB, AA); 2047 2048 case AROP2 of 2049 R2_NOT: blendmode := kCGBlendModeDifference; 2050 R2_NOTXORPEN: blendmode := kCGBlendModeExclusion; 2051 R2_XORPEN: blendmode := kCGBlendModeDifference; 2052 else 2053 blendmode := kCGBlendModeNormal; 2054 end; 2055 CGContextSetBlendMode(ADC.CGContext, blendmode); 2056 2057 CGContextSetRGBStrokeColor(ADC.CGContext, AR, AG, AB, AA); 2058 CGContextSetLineWidth(ADC.CGContext, FWidth); 2059 2060 if IsExtPen then 2061 begin 2062 if IsGeometric then 2063 begin 2064 CGContextSetLineCap(ADC.CGContext, FEndCap); 2065 CGContextSetLineJoin(ADC.CGContext, FJoinStyle); 2066 end; 2067 end; 2068 2069 case FStyle of 2070 PS_DASH: 2071 begin 2072 ADashes := GetDashes(CarbonDashStyle); 2073 CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes)); 2074 end; 2075 PS_DOT: 2076 begin 2077 ADashes := GetDashes(CarbonDotStyle); 2078 CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes)); 2079 end; 2080 PS_DASHDOT: 2081 begin 2082 ADashes := GetDashes(CarbonDashDotStyle); 2083 CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes)); 2084 end; 2085 PS_DASHDOTDOT: 2086 begin 2087 ADashes := GetDashes(CarbonDashDotDotStyle); 2088 CGContextSetLineDash(ADC.CGContext, 0, @ADashes[0], Length(ADashes)); 2089 end; 2090 PS_USERSTYLE: 2091 if Length(Dashes) = 0 then 2092 CGContextSetLineDash(ADC.CGContext, 0, nil, Length(Dashes)) 2093 else 2094 CGContextSetLineDash(ADC.CGContext, 0, @Dashes[0], Length(Dashes)); 2095 else 2096 CGContextSetLineDash(ADC.CGContext, 0, nil, 0); 2097 end; 2098end; 2099 2100{ TCarbonBitmap } 2101 2102{------------------------------------------------------------------------------ 2103 Method: TCarbonBitmap.GetBitsPerComponent 2104 Returns: Bitmap bits per component 2105 ------------------------------------------------------------------------------} 2106function TCarbonBitmap.GetBitsPerComponent: Integer; 2107begin 2108 case FType of 2109 cbtMask, 2110 cbtGray: Result := FDepth; 2111 cbtRGB, 2112 cbtBGR: Result := FDepth div 3; 2113 cbtARGB, 2114 cbtRGBA, 2115 cbtBGRA: Result := FDepth shr 2; 2116 else 2117 Result := 0; 2118 end; 2119end; 2120 2121{------------------------------------------------------------------------------ 2122 Method: TCarbonBitmap.GetColorSpace 2123 Returns: The colorspace for this type of bitmap 2124 ------------------------------------------------------------------------------} 2125function TCarbonBitmap.GetColorSpace: CGColorSpaceRef; 2126begin 2127 if FType in [cbtMask, cbtGray] 2128 then Result := GrayColorSpace 2129 else Result := RGBColorSpace 2130end; 2131 2132{------------------------------------------------------------------------------ 2133 Method: TCarbonBitmap.GetInfo 2134 Returns: The CGBitmapInfo for this type of bitmap 2135 ------------------------------------------------------------------------------} 2136function TCarbonBitmap.GetInfo: CGBitmapInfo; 2137begin 2138 Result := BITMAPINFOMAP[FType]; 2139end; 2140 2141procedure TCarbonBitmap.SetCGImage(const AValue: CGImageRef); 2142begin 2143 if FCGImage = AValue then 2144 Exit; 2145 2146 if FCGImage <> nil then 2147 CGImageRelease(FCGImage); 2148 2149 FCGImage := AValue; 2150 2151 UpdateInfo; 2152end; 2153 2154{------------------------------------------------------------------------------ 2155 Method: TCarbonBitmap.Create 2156 Params: AWidth - Bitmap width 2157 AHeight - Bitmap height 2158 ADepth - Significant bits per pixel 2159 ABitsPerPixel - The number of allocated bits per pixel (can be larger than depth) 2160 AAlignment - Alignment of the data for each row 2161 ABytesPerRow - The number of bytes between rows 2162 ACopyData - Copy supplied bitmap data (OPTIONAL) 2163 2164 Creates Carbon bitmap with the specified characteristics 2165 ------------------------------------------------------------------------------} 2166constructor TCarbonBitmap.Create(AWidth, AHeight, ADepth, ABitsPerPixel: Integer; 2167 AAlignment: TCarbonBitmapAlignment; AType: TCarbonBitmapType; AData: Pointer; 2168 ACopyData: Boolean); 2169begin 2170 inherited Create(False); 2171 2172 FCGImage := nil; 2173 2174 SetInfo(AWidth, AHeight, ADepth, ABitsPerPixel, AAlignment, AType); 2175 2176 if (AData = nil) or ACopyData then 2177 begin 2178 System.GetMem(FData, FDataSize); 2179 FFreeData := True; 2180 if AData <> nil then 2181 System.Move(AData^, FData^, FDataSize) // copy data 2182 else 2183 FillDWord(FData^, FDataSize shr 2, 0); // clear bitmap 2184 end 2185 else 2186 begin 2187 FData := AData; 2188 FFreeData := False; 2189 end; 2190 2191//DebugLn(Format('TCarbonBitmap.Create %d x %d Data: %d RowSize: %d Size: %d', 2192// [AWidth, AHeight, Integer(AData), DataRowSize, FDataSize])); 2193 2194 UpdateImage; 2195 2196 //DbgDumpImage(FCGImage, 'TCarbonBitmap.Create'); 2197end; 2198 2199{------------------------------------------------------------------------------ 2200 Method: TCarbonBitmap.Create 2201 Params: ABitmap - Source bitmap 2202 2203 Creates Carbon bitmap as a copy of specified bitmap 2204 ------------------------------------------------------------------------------} 2205constructor TCarbonBitmap.Create(ABitmap: TCarbonBitmap); 2206begin 2207 Create(ABitmap.Width, ABitmap.Height, ABitmap.Depth, ABitmap.FBitsPerPixel, 2208 ABitmap.FAlignment, ABitmap.FType, ABitmap.Data); 2209end; 2210 2211{------------------------------------------------------------------------------ 2212 Method: TCarbonBitmap.Destroy 2213 2214 Frees Carbon bitmap 2215 ------------------------------------------------------------------------------} 2216destructor TCarbonBitmap.Destroy; 2217begin 2218 CGImageRelease(FCGImage); 2219 if FFreeData then System.FreeMem(FData); 2220 2221 inherited Destroy; 2222end; 2223 2224procedure TCarbonBitmap.SetInfo(AWidth, AHeight, ADepth, 2225 ABitsPerPixel: Integer; AAlignment: TCarbonBitmapAlignment; 2226 AType: TCarbonBitmapType); 2227const 2228 ALIGNBITS: array[TCarbonBitmapAlignment] of Integer = (0, 1, 3, 7, $F); 2229var 2230 M: Integer; 2231begin 2232 if AWidth < 1 then AWidth := 1; 2233 if AHeight < 1 then AHeight := 1; 2234 FWidth := AWidth; 2235 FHeight := AHeight; 2236 FDepth := ADepth; 2237 FBitsPerPixel := ABitsPerPixel; 2238 FType := AType; 2239 FAlignment := AAlignment; 2240 2241 //todo: FDepth should not be Zero. Need to find out what's causing it. 2242 if (FType in [cbtMono, cbtGray]) and (FDepth=0) then 2243 FDepth:=FBitsPerPixel; 2244 2245 FBytesPerRow := ((AWidth * ABitsPerPixel) + 7) shr 3; 2246 M := FBytesPerRow and ALIGNBITS[AAlignment]; 2247 if M <> 0 then Inc(FBytesPerRow, ALIGNBITS[AAlignment] + 1 - M); 2248 2249 FDataSize := FBytesPerRow * FHeight; 2250end; 2251 2252{------------------------------------------------------------------------------ 2253 Method: TCarbonBitmap.UpdateImage 2254 2255 Updates Carbon bitmap 2256 ------------------------------------------------------------------------------} 2257procedure TCarbonBitmap.UpdateImage; 2258var 2259 CGDataProvider: CGDataProviderRef; 2260begin 2261 // we have a data and description and we need to build CGImage 2262 2263 if FData = nil then Exit; 2264 if FCGImage <> nil then CGImageRelease(FCGImage); 2265 2266 CGDataProvider := CGDataProviderCreateWithData(nil, FData, FDataSize, nil); 2267 try 2268 if FType = cbtMask 2269 then FCGImage := CGImageMaskCreate(FWidth, FHeight, GetBitsPerComponent, 2270 FBitsPerPixel, FBytesPerRow, CGDataProvider, nil, 0) 2271 else FCGImage := CGImageCreate(FWidth, FHeight, GetBitsPerComponent, 2272 FBitsPerPixel, FBytesPerRow, GetColorSpace, BITMAPINFOMAP[FType], 2273 CGDataProvider, nil, 0, kCGRenderingIntentDefault); 2274 finally 2275 CGDataProviderRelease(CGDataProvider); 2276 end; 2277end; 2278 2279procedure TCarbonBitmap.UpdateInfo; 2280const 2281 ALIGNMAP: array[TRawImageLineEnd] of TCarbonBitmapAlignment = (cbaByte, cbaByte, cbaWord, cbaDWord, cbaQWord, cbaDQWord); 2282var 2283 ADesc: TRawImageDescription; 2284 AType: TCarbonBitmapType; 2285 ADataSize: PtrUInt; 2286begin 2287 // we have a CGImage and we need to update all info related to that image 2288 2289 if FFreeData then System.FreeMem(FData); 2290 FData := nil; 2291 FFreeData := True; 2292 2293 if not CarbonWidgetSet.RawImage_DescriptionFromCarbonBitmap(ADesc, Self) then 2294 Exit; 2295 2296 if not CarbonWidgetSet.RawImage_DescriptionToBitmapType(ADesc, AType) then 2297 Exit; 2298 2299 SetInfo(ADesc.Width, ADesc.Height, ADesc.Depth, ADesc.BitsPerPixel, 2300 ALIGNMAP[ADesc.LineEnd], AType); 2301 2302 FData := CarbonWidgetSet.GetImagePixelData(FCGImage, ADataSize); 2303 FDataSize := FDataSize; 2304end; 2305 2306{------------------------------------------------------------------------------ 2307 Method: TCarbonBitmap.CreateSubImage 2308 Returns: New image ref to portion of image data according to the rect 2309 ------------------------------------------------------------------------------} 2310function TCarbonBitmap.CreateSubImage(const ARect: TRect): CGImageRef; 2311begin 2312 if CGImage = nil then Result := nil 2313 else Result := CGImageCreateWithImageInRect(CGImage, RectToCGRect(ARect)); 2314end; 2315 2316{------------------------------------------------------------------------------ 2317 Method: TCarbonBitmap.CreateMaskImage 2318 Returns: New mask image ref to portion of image data according to the rect 2319 ------------------------------------------------------------------------------} 2320function TCarbonBitmap.CreateMaskImage(const ARect: TRect): CGImageRef; 2321var 2322 CGDataProvider: CGDataProviderRef; 2323 Mask: CGImageRef; 2324begin 2325 CGDataProvider := CGDataProviderCreateWithData(nil, FData, FDataSize, nil); 2326 try 2327 Mask := CGImageMaskCreate(FWidth, FHeight, FBitsPerPixel, 2328 FBitsPerPixel, FBytesPerRow, CGDataProvider, nil, 0); 2329 Result := CGImageCreateWithImageInRect(Mask, RectToCGRect(ARect)); 2330 finally 2331 CGDataProviderRelease(CGDataProvider); 2332 CGImageRelease(Mask); 2333 end; 2334end; 2335 2336{------------------------------------------------------------------------------ 2337 Method: TCarbonBitmap.CreateMaskedImage 2338 Returns: New image ref to masked image data 2339 ------------------------------------------------------------------------------} 2340function TCarbonBitmap.CreateMaskedImage(AMask: TCarbonBitmap): CGImageRef; 2341begin 2342 Result := CreateMaskedImage(AMask, Classes.Rect(0, 0, Width, Height)); 2343end; 2344 2345{------------------------------------------------------------------------------ 2346 Method: TCarbonBitmap.CreateMaskedImage 2347 Returns: New image ref to portion of masked image data according to the rect 2348 ------------------------------------------------------------------------------} 2349function TCarbonBitmap.CreateMaskedImage(AMask: TCarbonBitmap; 2350 const ARect: TRect): CGImageRef; 2351var 2352 CGSubImage: CGImageRef; 2353 CGSubMaskImage: CGImageRef; 2354begin 2355 Result := nil; 2356 if CGImage = nil then Exit; 2357 if (AMask <> nil) and (AMask.CGImage <> nil) then 2358 begin 2359 CGSubImage := CreateSubImage(ARect); 2360 CGSubMaskImage := AMask.CreateMaskImage(ARect); 2361 try 2362 Result := CGImageCreateWithMask(CGSubImage, CGSubMaskImage); 2363 finally 2364 CGImageRelease(CGSubMaskImage); 2365 CGImageRelease(CGSubImage); 2366 end; 2367 end 2368 else 2369 Result := CreateSubImage(ARect); 2370end; 2371 2372procedure TCarbonBitmap.AddMask(AMask: TCarbonBitmap); 2373begin 2374 if AMask = nil then 2375 Exit; 2376 2377 CGImage := CreateMaskedImage(AMask); 2378end; 2379 2380{ TCarbonCursor } 2381 2382{------------------------------------------------------------------------------ 2383 Method: TCarbonCursor.Create 2384 2385 Creates Carbon cursor 2386 ------------------------------------------------------------------------------} 2387constructor TCarbonCursor.Create; 2388begin 2389 inherited Create(False); 2390 2391 FCursorType := cctUnknown; 2392 FThemeCursor := 0; 2393 FAnimationStep := 0; 2394 FQDHardwareCursorName := ''; 2395 FPixmapHandle := nil; 2396end; 2397 2398{------------------------------------------------------------------------------ 2399 Method: TCarbonCursor.CreateThread 2400 2401 Creates cursor animation thread 2402 ------------------------------------------------------------------------------} 2403procedure TCarbonCursor.CreateThread; 2404begin 2405 FTaskID := nil; 2406 OSError(MPCreateTask(@AnimationCursorHandler, Self, 0, nil, nil, nil, 0, @FTaskID), 2407 Self, 'CreateThread', 'MPCreateTask'); 2408end; 2409 2410{------------------------------------------------------------------------------ 2411 Method: TCarbonCursor.DestroyThread 2412 2413 Destroys cursor animation thread 2414 ------------------------------------------------------------------------------} 2415procedure TCarbonCursor.DestroyThread; 2416begin 2417 OSError(MPTerminateTask(FTaskID, noErr), Self, 'DestroyThread', 'MPTerminateTask'); 2418 FTaskID := nil; 2419end; 2420 2421{------------------------------------------------------------------------------ 2422 Method: TCarbonCursor.CreateHardwareCursor 2423 Params: ABitmap - Cursor image 2424 AHotSpot - Hot spot position 2425 2426 Creates new hardware cursor 2427 ------------------------------------------------------------------------------} 2428procedure TCarbonCursor.CreateHardwareCursor(ABitmap: TCarbonBitmap; AHotSpot: Point); 2429var 2430 B: Rect; 2431begin 2432 FCursorType := cctQDHardware; 2433 2434 B.top := 0; 2435 B.left := 0; 2436 B.bottom := ABitmap.Height; 2437 B.right := ABitmap.Width; 2438 2439 FPixmapHandle := PixMapHandle(NewHandleClear(SizeOf(PixMap))); 2440 // tell that this is pixmap (bit 15 := 1) 2441 FPixmapHandle^^.rowBytes := SInt16(ABitmap.BytesPerRow or $8000); 2442 FPixmapHandle^^.bounds := B; 2443 FPixmapHandle^^.pmVersion := 0; 2444 FPixmapHandle^^.packType := 0; 2445 FPixmapHandle^^.packSize := 0; 2446 FPixmapHandle^^.hRes := $00480000; // 72 dpi 2447 FPixmapHandle^^.vRes := $00480000; // 72 dpi 2448 FPixmapHandle^^.pixelType := RGBDirect; 2449 FPixmapHandle^^.cmpSize := ABitmap.BitsPerComponent; 2450 FPixmapHandle^^.cmpCount := ABitmap.Depth div FPixmapHandle^^.cmpSize; // $AARRGGBB 2451 FPixmapHandle^^.pixelSize := ABitmap.FBitsPerPixel; // depth 2452 FPixmapHandle^^.pmTable := nil; 2453 FPixmapHandle^^.baseAddr := Ptr(ABitmap.Data); 2454 2455 FQDHardwareCursorName := Application.Title + LazarusCursorInfix + IntToStr(Integer(FPixmapHandle)); 2456 OSError( 2457 QDRegisterNamedPixMapCursor(FPixmapHandle, nil, AHotSpot, PChar(FQDHardwareCursorName)), 2458 Self, 'CreateHardwareCursor', 'QDRegisterNamedPixMapCursor'); 2459end; 2460 2461{------------------------------------------------------------------------------ 2462 Method: TCarbonCursor.CreateColorCursor 2463 Params: ABitmap - Cursor image 2464 AHotSpot - Hot spot position 2465 2466 Creates new color cursor 2467 ------------------------------------------------------------------------------} 2468procedure TCarbonCursor.CreateColorCursor(ABitmap: TCarbonBitmap; AHotSpot: Point); 2469var 2470 Bounds: Rect; 2471 i, j, rowBytes: integer; 2472 SrcRowPtr, SrcPtr, DstRowPtr: PByte; 2473 RowMask, RowData, Bit: UInt16; 2474begin 2475 FCursorType := cctQDColor; 2476 Bounds.top := 0; 2477 Bounds.left := 0; 2478 Bounds.bottom := 16; 2479 Bounds.right := 16; 2480 2481 FPixmapHandle := PixMapHandle(NewHandleClear(SizeOf(PixMap))); 2482 FPixmapHandle^^.baseAddr := nil; 2483 FPixmapHandle^^.bounds := Bounds; 2484 FPixmapHandle^^.pmVersion := 0; 2485 FPixmapHandle^^.packType := 0; 2486 FPixmapHandle^^.packSize := 0; 2487 FPixmapHandle^^.hRes := $00480000; // 72 dpi 2488 FPixmapHandle^^.vRes := $00480000; // 72 dpi 2489 FPixmapHandle^^.pixelType := RGBDirect; 2490 FPixmapHandle^^.cmpSize := ABitmap.BitsPerComponent; 2491 FPixmapHandle^^.cmpCount := ABitmap.Depth div FPixmapHandle^^.cmpSize; // $AARRGGBB 2492 FPixmapHandle^^.pixelSize := ABitmap.FBitsPerPixel; // depth 2493 rowBytes := FPixmapHandle^^.Bounds.right * (FPixmapHandle^^.pixelSize shr 3); 2494 // tell that this is pixmap (bit 15 := 1) 2495 FPixmapHandle^^.rowBytes := SInt16(rowBytes or $8000); 2496 FPixmapHandle^^.pmTable := nil; 2497 2498 // create cursor handle 2499 FQDColorCursorHandle := CCrsrHandle(NewHandleClear(SizeOf(CCrsr))); 2500 FQDColorCursorHandle^^.crsrType := SInt16($8001); // color cursor ($8000 - bw) 2501 FQDColorCursorHandle^^.crsrMap := FPixmapHandle; 2502 FQDColorCursorHandle^^.crsrXData := nil; 2503 FQDColorCursorHandle^^.crsrXValid := 0; 2504 FQDColorCursorHandle^^.crsrXHandle := nil; 2505 FQDColorCursorHandle^^.crsrHotspot.h := Min(15, AHotSpot.h); 2506 FQDColorCursorHandle^^.crsrHotspot.v := Min(15, AHotSpot.v); 2507 FQDColorCursorHandle^^.crsrXTable := 0; 2508 FQDColorCursorHandle^^.crsrID := GetCTSeed; 2509 2510 // handle for data with size = rowBytes * height 2511 FQDColorCursorHandle^^.crsrData := NewHandleClear(rowBytes * FPixmapHandle^^.bounds.bottom); 2512 2513 // fill cursor bitmap and mask 2514 SrcRowPtr := ABitmap.Data; 2515 DstRowPtr := PByte(FQDColorCursorHandle^^.crsrData^); 2516 for i := 0 to 15 do 2517 begin 2518 RowMask := 0; 2519 RowData := 0; 2520 Bit := $8000; 2521 SrcPtr := SrcRowPtr; 2522 System.Move(SrcPtr^, DstRowPtr^, 16 * 4); 2523 for j := 0 to 15 do 2524 begin 2525 // check alpha 2526 if SrcPtr[0] and $FF = 0 then 2527 RowData := RowData or Bit 2528 else 2529 RowMask := RowMask or Bit; 2530 2531 Bit := Bit shr 1; 2532 Inc(SrcPtr, 4); 2533 end; 2534 {$IFDEF ENDIAN_BIG} 2535 FQDColorCursorHandle^^.crsrMask[i] := SInt16(RowMask); 2536 FQDColorCursorHandle^^.crsr1Data[i] := SInt16(RowData); 2537 {$ELSE} 2538 FQDColorCursorHandle^^.crsrMask[i] := SInt16(CFSwapInt16(RowMask)); 2539 FQDColorCursorHandle^^.crsr1Data[i] := SInt16(CFSwapInt16(RowData)); 2540 {$ENDIF} 2541 Inc(SrcRowPtr, ABitmap.BytesPerRow); 2542 Inc(DstRowPtr, rowBytes); 2543 end; 2544end; 2545 2546 2547{------------------------------------------------------------------------------ 2548 Method: TCarbonCursor.CreateFromInfo 2549 Params: AInfo - Array of cursor info 2550 ACount - Number of items in array 2551 2552 Creates new cursor from the specified info 2553 ------------------------------------------------------------------------------} 2554constructor TCarbonCursor.CreateAnimatedFromInfo(AInfo: PIconInfo; ACount: Integer); 2555var 2556 i: Integer; 2557begin 2558 FAnimationTimer := TTimer.Create(nil); 2559 FAnimationTimer.Enabled := False; 2560 FAnimationTimer.Interval := 150;//kThemeCursorAnimationDelay; 2561 FAnimationTimer.OnTimer := @StepQDAnimation; 2562 SetLength(FAnimationFrames, ACount); 2563 for i := 0 to ACount - 1 do begin 2564 CreateFromInfo(AInfo); 2565 FAnimationFrames[i].QDColorCursorHandle := FQDColorCursorHandle; 2566 FAnimationFrames[i].QDHardwareCursorName := FQDHardwareCursorName; 2567 FAnimationFrames[i].PixmapHandle := FPixmapHandle; 2568 Inc(AInfo); 2569 end; 2570end; 2571 2572{------------------------------------------------------------------------------ 2573 Method: TCarbonCursor.CreateFromInfo 2574 Params: AInfo - Cusrsor info 2575 2576 Creates new cursor from the specified info 2577 ------------------------------------------------------------------------------} 2578constructor TCarbonCursor.CreateFromInfo(AInfo: PIconInfo); 2579var 2580 AHotspot: Point; 2581 AMaskedBitmap: TCarbonBitmap; 2582begin 2583 Create; 2584 2585 if (AInfo^.hbmColor = 0) or not (TObject(AInfo^.hbmColor) is TCarbonBitmap) then 2586 Exit; 2587 2588 AHotspot.h := AInfo^.xHotspot; 2589 AHotspot.v := AInfo^.yHotspot; 2590 2591 AMaskedBitmap := TCarbonBitmap(AInfo^.hbmColor); 2592 if (AInfo^.hbmMask <> 0) then 2593 begin 2594 AMaskedBitmap := TCarbonBitmap.Create(AMaskedBitmap); 2595 AMaskedBitmap.AddMask(TCarbonBitmap(AInfo^.hbmMask)); 2596 end; 2597 2598 if HardwareCursorsSupported then 2599 CreateHardwareCursor(AMaskedBitmap, AHotSpot) 2600 else 2601 CreateColorCursor(AMaskedBitmap, AHotSpot); 2602 2603 if (AInfo^.hbmMask <> 0) then 2604 AMaskedBitmap.Free; 2605end; 2606 2607{------------------------------------------------------------------------------ 2608 Method: TCarbonCursor.CreateThemed 2609 Params: AThemeCursor - Theme cursor kind 2610 2611 Creates new theme cursor 2612 ------------------------------------------------------------------------------} 2613constructor TCarbonCursor.CreateThemed(AThemeCursor: ThemeCursor; 2614 ADefault: Boolean); 2615const 2616 kThemeCursorTypeMap: array[kThemeArrowCursor..22] of TCarbonCursorType = 2617 ( 2618 cctTheme, // kThemeArrowCursor 2619 cctTheme, // kThemeCopyArrowCursor 2620 cctTheme, // kThemeAliasArrowCursor 2621 cctTheme, // kThemeContextualMenuArrowCursor 2622 cctTheme, // kThemeIBeamCursor 2623 cctTheme, // kThemeCrossCursor 2624 cctTheme, // kThemePlusCursor 2625 cctAnimated, // kThemeWatchCursor 2626 cctTheme, // kThemeClosedHandCursor 2627 cctTheme, // kThemeOpenHandCursor 2628 cctTheme, // kThemePointingHandCursor 2629 cctAnimated, // kThemeCountingUpHandCursor 2630 cctAnimated, // kThemeCountingDownHandCursor 2631 cctAnimated, // kThemeCountingUpAndDownHandCursor 2632 cctWait, // kThemeSpinningCursor (!!! obsolte and thats why we should use wait instead) 2633 cctTheme, // kThemeResizeLeftCursor 2634 cctTheme, // kThemeResizeRightCursor 2635 cctTheme, // kThemeResizeLeftRightCursor 2636 cctTheme, // kThemeNotAllowedCursor 2637 cctTheme, // kThemeResizeUpCursor 2638 cctTheme, // kThemeResizeDownCursor 2639 cctTheme, // kThemeResizeUpDownCursor 2640 cctTheme // kThemePoofCursor 2641 ); 2642begin 2643 Create; 2644 FDefault := ADefault; 2645 FThemeCursor := AThemeCursor; 2646 if (AThemeCursor {%H-}>= Low(kThemeCursorTypeMap)) and 2647 (AThemeCursor <= High(kThemeCursorTypeMap)) then 2648 FCursorType := kThemeCursorTypeMap[FThemeCursor] else 2649 FCursorType := cctTheme; 2650end; 2651 2652 2653{------------------------------------------------------------------------------ 2654 Method: TCarbonCursor.Destroy 2655 2656 Frees QuickDraw cursor 2657 ------------------------------------------------------------------------------} 2658procedure TCarbonCursor.DestroyCursor; 2659begin 2660 case CursorType of 2661 cctQDHardware: 2662 if FQDHardwareCursorName <> '' then 2663 begin 2664 OSError(QDUnregisterNamedPixmapCursor(PChar(FQDHardwareCursorName)), 2665 Self, SDestroy, 'QDUnregisterNamedPixmapCursor'); 2666 2667 FPixmapHandle^^.baseAddr := nil; 2668 DisposePixMap(FPixmapHandle); 2669 end; 2670 cctQDColor: 2671 DisposeCCursor(FQDColorCursorHandle); // suppose pixmap will be disposed too 2672 end; 2673end; 2674 2675{------------------------------------------------------------------------------ 2676 Method: TCarbonCursor.Destroy 2677 2678 Frees Carbon cursor 2679 ------------------------------------------------------------------------------} 2680destructor TCarbonCursor.Destroy; 2681var 2682 i: Integer; 2683begin 2684 UnInstall; 2685 2686 if FAnimationFrames <> nil then 2687 begin 2688 FAnimationTimer.Free; 2689 for i := 0 to Length(FAnimationFrames) - 1 do 2690 begin 2691 FQDColorCursorHandle := FAnimationFrames[i].QDColorCursorHandle; 2692 FQDHardwareCursorName := FAnimationFrames[i].QDHardwareCursorName; 2693 FPixmapHandle := FAnimationFrames[i].PixmapHandle; 2694 DestroyCursor; 2695 end; 2696 end 2697 else 2698 DestroyCursor; 2699 2700 inherited Destroy; 2701end; 2702 2703{------------------------------------------------------------------------------ 2704 Method: TCarbonCursor.Install 2705 2706 Installs Carbon cursor 2707 ------------------------------------------------------------------------------} 2708procedure TCarbonCursor.Install; 2709const 2710 SName = 'Install'; 2711begin 2712 {$IFDEF VerboseCursor} 2713 DebugLn('TCarbonCursor.Install type: ', DbgS(Ord(CursorType))); 2714 {$ENDIF} 2715 2716 if FAnimationTimer <> nil then 2717 begin 2718 FAnimationStep := 0; 2719 FAnimationTimer.Enabled := True; 2720 end; 2721 case CursorType of 2722 cctQDHardware: 2723 if FQDHardwareCursorName <> '' then 2724 OSError(QDSetNamedPixmapCursor(PChar(FQDHardwareCursorName)), 2725 Self, SName, 'QDSetNamedPixmapCursor'); 2726 cctQDColor: 2727 SetCCursor(FQDColorCursorHandle); 2728 cctTheme: 2729 OSError(SetThemeCursor(FThemeCursor), 2730 Self, SName, 'SetThemeCursor'); 2731 cctAnimated: 2732 begin 2733 FAnimationStep := 0; 2734 CreateThread; 2735 end; 2736 cctWait: 2737 QDDisplayWaitCursor(True); 2738 else 2739 DebugLn('[TCarbonCursor.Apply] !!! Unknown cursor type'); 2740 end; 2741end; 2742 2743{------------------------------------------------------------------------------ 2744 Method: TCarbonCursor.UnInstall 2745 2746 Uninstalls Carbon cursor 2747 ------------------------------------------------------------------------------} 2748procedure TCarbonCursor.UnInstall; 2749begin 2750 case CursorType of 2751 cctWait: QDDisplayWaitCursor(False); 2752 cctAnimated: DestroyThread; 2753 cctQDColor, cctQDHardware: 2754 if FAnimationTimer <> nil then 2755 FAnimationTimer.Enabled := False; 2756 end; 2757end; 2758 2759{------------------------------------------------------------------------------ 2760 Method: TCarbonCursor.StepAnimation 2761 Returns: If the function succeeds 2762 2763 Steps Carbon cursor animation 2764 ------------------------------------------------------------------------------} 2765function TCarbonCursor.StepAnimation: Boolean; 2766begin 2767 Result := SetAnimatedThemeCursor(FThemeCursor, FAnimationStep) <> themeBadCursorIndexErr; 2768 if Result then 2769 begin 2770 inc(FAnimationStep); 2771 end else 2772 begin 2773 FCursorType := cctTheme; 2774 SetThemeCursor(FThemeCursor); 2775 end; 2776end; 2777 2778{------------------------------------------------------------------------------ 2779 Method: TCarbonCursor.StepQDAnimation 2780 2781 Steps Carbon QuickDraw cursor animation 2782 ------------------------------------------------------------------------------} 2783procedure TCarbonCursor.StepQDAnimation(Sender: TObject); 2784begin 2785 case CursorType of 2786 cctQDHardware: 2787 with FAnimationFrames[FAnimationStep] do 2788 if QDHardwareCursorName <> '' then 2789 OSError(QDSetNamedPixmapCursor(PChar(QDHardwareCursorName)), 2790 Self, 'StepAnimation', 'QDSetNamedPixmapCursor'); 2791 cctQDColor: 2792 SetCCursor(FAnimationFrames[FAnimationStep].QDColorCursorHandle); 2793 end; 2794 FAnimationStep := (FAnimationStep + 1) mod Length(FAnimationFrames); 2795end; 2796 2797{------------------------------------------------------------------------------ 2798 Method: TCarbonCursor.HardwareCursorsSupported 2799 Returns: If hardware cursors are supported 2800 ------------------------------------------------------------------------------} 2801class function TCarbonCursor.HardwareCursorsSupported: Boolean; 2802var 2803 P: Point; 2804 ATestCursorName: String; 2805 ATempPixmap: PixmapHandle; 2806begin 2807 if MHardwareCursorsSupported = hcaUndef then 2808 begin 2809 ATestCursorName := Application.Title + LazarusCursorInfix + 'test'; 2810 P.v := 0; 2811 P.h := 0; 2812 2813 ATempPixmap := PixMapHandle(NewHandleClear(SizeOf(PixMap))); 2814 if QDRegisterNamedPixMapCursor(ATempPixmap, nil, P, PChar(ATestCursorName)) = kQDNoColorHWCursorSupport then 2815 MHardwareCursorsSupported := hcaUnavailable else 2816 MHardwareCursorsSupported := hcaAvailable; 2817 QDUnregisterNamedPixmapCursor(PChar(ATestCursorName)); 2818 DisposePixMap(ATempPixmap); 2819 end; 2820 Result := MHardwareCursorsSupported = hcaAvailable; 2821end; 2822 2823function GetScanLine(Bitmap: TCarbonBitmap; Line: Integer): PByteArray; 2824begin 2825 if (Line>=Bitmap.Height) or (Line<0) then Result:=nil 2826 else Result:=PByteArray(@PByteArray(Bitmap.Data)^[ Bitmap.BytesPerRow*Line ]); 2827end; 2828 2829type 2830 TColorPos = record 2831 ri : Byte; 2832 gi : Byte; 2833 bi : Byte; 2834 ai : Byte; 2835 end; 2836 2837procedure GetRGBA24(Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos); 2838var 2839 line : PByteArray; 2840begin 2841 line:=GetScanLine(Bitmap, Y); 2842 if not Assigned(line) then begin 2843 r:=0;g:=0;b:=0;a:=$FF; 2844 Exit; 2845 end; 2846 r:=line^[x*3+pos.ri]; 2847 g:=line^[x*3+pos.gi]; 2848 b:=line^[x*3+pos.bi]; 2849 a:=255; 2850end; 2851 2852procedure SetRGBA24(Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,{%H-}a: Byte; const pos: TColorPos); 2853var 2854 line : PByteArray; 2855begin 2856 line:=GetScanLine(Bitmap, Y); 2857 if not Assigned(line) then Exit; 2858 line^[x*3+pos.ri]:=r; 2859 line^[x*3+pos.gi]:=g; 2860 line^[x*3+pos.bi]:=b; 2861end; 2862 2863procedure GetRGBA32(Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos); 2864var 2865 line : PByteArray; 2866begin 2867 line:=GetScanLine(Bitmap, Y); 2868 if not Assigned(line) then begin 2869 r:=0;g:=0;b:=0;a:=$FF; 2870 Exit; 2871 end; 2872 r:=line^[x*4+pos.ri]; 2873 g:=line^[x*4+pos.gi]; 2874 b:=line^[x*4+pos.bi]; 2875 a:=line^[x*4+pos.ai]; 2876end; 2877 2878procedure SetRGBA32(Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,a: Byte; const pos: TColorPos); 2879var 2880 line : PByteArray; 2881begin 2882 line:=GetScanLine(Bitmap, Y); 2883 if not Assigned(line) then Exit; 2884 line^[x*4+pos.ri]:=r; 2885 line^[x*4+pos.gi]:=g; 2886 line^[x*4+pos.bi]:=b; 2887 line^[x*4+pos.ai]:=a; 2888end; 2889 2890//todo: add support for non 24-32 bit images 2891//todo: faster and better code! 2892//todo: support for iBorderColor (currently ignored both ABorderColor and isBorderColor settings) 2893function FloodFillBitmap(const Bitmap: TCarbonBitmap; X,Y: Integer; ABorderColor, FillColor: TColor; isBorderColor: Boolean): Boolean; 2894var 2895 sr, sg, sb, sa : Byte; 2896 tr, tg, tb, ta : Byte; 2897 r,g,b,a : Byte; 2898 data : array of TPoint; 2899 cnt : Integer; 2900 i,j : Integer; 2901 k : Integer; 2902 clpos : TColorPos; 2903 FillColorRef: TColorRef; 2904const 2905 LEPos : TColorPos = (ri:1;gi:2;bi:3;ai:0); 2906const 2907 dx : array [0..3] of Integer = (-1,1,0,0); 2908 dy : array [0..3] of Integer = (0,0,-1,1); 2909var 2910 GetRGBA: procedure (Bitmap: TCarbonBitmap; X,Y: Integer; out r,g,b,a: Byte; const pos: TColorPos); 2911 SetRGBA: procedure (Bitmap: TCarbonBitmap; X,Y: Integer; r,g,b,a: Byte; const pos: TColorPos); 2912begin 2913 FillColorRef:=ColorToRGB(FillColor); 2914 r:=FillColorRef and $FF; 2915 g:=(FillColorRef shr 8) and $FF; 2916 b:=(FillColorRef shr 16) and $FF; 2917 a:=$FF; 2918 GetRGBA:=nil; 2919 SetRGBA:=nil; 2920 clpos:=LEPos; //todo: Little endian, big endian or bitmap specific 2921 if Bitmap.BitsPerComponent=8 then 2922 begin 2923 if Bitmap.FBitsPerPixel=32 then 2924 begin 2925 GetRGBA:=@GetRGBA32; 2926 SetRGBA:=@SetRGBA32; 2927 end else 2928 begin 2929 GetRGBA:=@GetRGBA24; 2930 SetRGBA:=@SetRGBA24; 2931 end; 2932 end; 2933 Result:=Assigned(GetRGBA); 2934 if not Result then Exit; 2935 2936 try 2937 GetRGBA(Bitmap, x,y, sr, sg, sb, sa, clpos); 2938 if (sr=r) and (sg=g) and (sb=b) then Exit; 2939 SetLength(data, Bitmap.Width*Bitmap.Height); 2940 cnt:=1; 2941 data[0].x:=x; 2942 data[0].y:=y; 2943 SetRGBA(Bitmap, x,y, r, g, b, a, clPos); 2944 2945 while cnt>0 do 2946 begin 2947 x:=data[0].x; 2948 y:=data[0].y; 2949 for k:=0 to 3 do 2950 begin 2951 i:=x+dx[k]; 2952 j:=y+dy[k]; 2953 if (i<0) or (j<0) or (i>=Bitmap.Width) or (j>=Bitmap.Height) then Continue; 2954 GetRGBA(Bitmap, i,j, tr, tg, tb, ta, clPos); 2955 if (tr=sr) and (tg=sg) and (tb=sb) then 2956 begin 2957 SetRGBA(Bitmap, i,j, r, g, b, a, clPos); 2958 data[cnt].X:=i; 2959 data[cnt].Y:=j; 2960 inc(cnt); 2961 end; 2962 end; 2963 dec(cnt); 2964 data[0]:=data[cnt]; 2965 end; 2966 finally 2967 Bitmap.UpdateImage; 2968 end; 2969end; 2970 2971var 2972 LogBrush: TLogBrush; 2973 2974initialization 2975 2976 InitCursor; 2977 2978 StockSystemFont := TCarbonFont.Create(True); 2979 2980 LogBrush.lbStyle := BS_NULL; 2981 LogBrush.lbColor := 0; 2982 StockNullBrush := TCarbonBrush.Create(LogBrush); 2983 2984 WhiteBrush := TCarbonBrush.Create(True); 2985 BlackPen := TCarbonPen.Create(True); 2986 2987 DefaultFont := TCarbonFont.Create(True); 2988 2989 DefaultBrush := TCarbonBrush.Create(True); 2990 DefaultPen := TCarbonPen.Create(True); 2991 2992 DefaultContext := TCarbonBitmapContext.Create; 2993 DefaultBitmap := TCarbonBitmap.Create(1, 1, 32, 32, cbaDQWord, cbtARGB, nil); 2994 DefaultContext.Bitmap := DefaultBitmap; 2995 2996 ScreenContext := TCarbonScreenContext.Create; 2997 ScreenContext.CGContext := DefaultContext.CGContext; // workaround 2998 2999finalization 3000 DefaultContext.Free; 3001 ScreenContext.Free; 3002 3003 DefaultBrush.Free; 3004 DefaultPen.Free; 3005 3006 DefaultFont.Free; 3007 3008 BlackPen.Free; 3009 WhiteBrush.Free; 3010 3011 StockNullBrush.Free; 3012 StockSystemFont.Free; 3013 3014 DefaultBitmap.Free; 3015 3016end. 3017