paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-07-25 18:16:50 +02:00
Code Issues Packages Projects Releases Wiki Activity
1259df9b51
lazarus/lcl/interfaces/carbon/carboncanvas.pp

1929 lines
60 KiB
ObjectPascal
Raw Blame History

{ -----------------------------------------
carboncanvas.pp - Carbon device context
-----------------------------------------
*****************************************************************************
This file is part of the Lazarus Component Library (LCL)
See the file COPYING.modifiedLGPL.txt, included in this distribution,
for details about the license.
*****************************************************************************
}
unit CarbonCanvas;
{$mode objfpc}{$H+}
interface
// defines
{$I carbondefines.inc}
uses
// rtl+ftl
Types, Classes, SysUtils, Math, Contnrs,
// carbon bindings
MacOSAll,
// LCL
LCLProc, LCLType, Graphics, GraphType, IntfGraphics, Controls, Forms,
// LCL Carbon
CarbonDef, CarbonUtils,
{$ifdef DebugBitmaps}
CarbonDebug,
{$endif}
CarbonGDIObjects;
type
// device context data for SaveDC/RestoreDC
TCarbonDCData = class
public
CurrentFont: TCarbonFont;
CurrentBrush: TCarbonBrush;
CurrentPen: TCarbonPen;
CurrentRegion: TCarbonRegion;
BkColor: TColor;
BkMode: Integer;
BkBrush: TCarbonBrush;
TextColor: TColor;
TextBrush: TCarbonBrush;
ROP2: Integer;
PenPos: TPoint;
WindowOfs: TPoint;
ViewportOfs: TPoint;
isClipped: Boolean;
ClipShape: HIShapeRef;
end;
TCarbonBitmapContext = class;
{ TCarbonDeviceContext }
TCarbonDeviceContext = class(TCarbonContext)
private
FCurrentFont: TCarbonFont;
FCurrentBrush: TCarbonBrush;
FCurrentPen: TCarbonPen;
FCurrentRegion: TCarbonRegion;
FBkColor: TColor;
FBkMode: Integer;
FBkBrush: TCarbonBrush;
FTextColor: TColor;
FTextBrush: TCarbonBrush; // text color is fill color
FROP2: Integer;
FPenPos: TPoint;
FClipRegion: TCarbonRegion;
FSavedDCList: TFPObjectList;
FTextFractional: Boolean;
FViewPortOfs,
FWindowOfs: TPoint;
isClipped : Boolean;
procedure SetBkColor(AValue: TColor);
procedure SetBkMode(const AValue: Integer);
procedure SetCurrentBrush(const AValue: TCarbonBrush);
procedure SetCurrentFont(const AValue: TCarbonFont);
procedure SetCurrentPen(const AValue: TCarbonPen);
procedure SetCurrentRegion(const AValue: TCarbonRegion);
procedure SetROP2(const AValue: Integer);
procedure SetTextColor(AValue: TColor);
protected
function GetSize: TPoint; virtual; abstract;
function SaveDCData: TCarbonDCData; virtual;
procedure RestoreDCData(const AData: TCarbonDCData); virtual;
procedure ExcludeClipRect(Left, Top, Right, Bottom: Integer);
procedure ApplyTransform(Trans: CGAffineTransform);
procedure ClearClipping;
public
constructor Create;
destructor Destroy; override;
procedure Reset; override;
function SaveDC: Integer;
function RestoreDC(ASavedDC: Integer): Boolean;
function BeginTextRender(AStr: PChar; ACount: Integer; out ALayout: TCarbonTextLayout): Boolean;
procedure EndTextRender(var ALayout: TCarbonTextLayout);
procedure SetAntialiasing(AValue: Boolean);
function GetBlendModeFromROP(ROP: DWORD) : CGBlendMode;
function DrawCGImage(X, Y, Width, Height: Integer; CGImage: CGImageRef; BlendMode: CGBlendMode = kCGBlendModeNormal): Boolean;
procedure SetCGFillping(Ctx: CGContextRef; Width, Height: Integer); // Width and Height must be negative to flip the image
procedure RestoreCGFillping(Ctx: CGContextRef; Width, Height: Integer); // Width and Height must be negative to restore
public
procedure DrawFocusRect(ARect: TRect);
procedure DrawGrid(const ARect: TRect; DX, DY: Integer);
procedure Ellipse(X1, Y1, X2, Y2: Integer);
function ExtTextOut(X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
procedure FillRect(Rect: TRect; Brush: TCarbonBrush);
procedure Frame(X1, Y1, X2, Y2: Integer);
procedure Frame3D(var ARect: TRect; const FrameWidth: integer; const Style: TBevelCut);
function GetClipRect: TRect;
function GetLineLastPixelPos(PrevPos, NewPos: TPoint): TPoint;
function GetPixel({%H-}X, {%H-}Y: Integer): TGraphicsColor; virtual;
function GetTextExtentPoint(Str: PChar; Count: Integer; var Size: TSize): Boolean;
function GetTextMetrics(var TM: TTextMetric): Boolean;
procedure InvertRectangle(X1, Y1, X2, Y2: Integer);
procedure LineTo(X, Y: Integer);
procedure PolyBezier(Points: PPoint; NumPts: Integer; Filled, Continuous: boolean);
procedure Polygon(Points: PPoint; NumPts: Integer; Winding: boolean);
procedure Polyline(Points: PPoint; NumPts: Integer);
procedure Rectangle(X1, Y1, X2, Y2: Integer);
procedure SetPixel(X, Y: Integer; AColor: TGraphicsColor);
function StretchDraw(X, Y, Width, Height: Integer; SrcDC: TCarbonBitmapContext;
XSrc, YSrc, SrcWidth, SrcHeight: Integer; Msk: TCarbonBitmap; XMsk,
YMsk: Integer; {%H-}Rop: DWORD): Boolean;
function SetClipRegion(AClipRegion: TCarbonRegion; Mode: Integer): Integer;
function CopyClipRegion(ADstRegion: TCarbonRegion): Integer;
procedure UpdateContextOfs(const AWindowOfs, AViewOfs: TPoint);
procedure SetWindowOfs(const AWindowOfs: TPoint);
procedure SetViewPortOfs(const AViewOfs: TPoint);
function GetLogicalOffset: TPoint; override;
public
property Size: TPoint read GetSize;
property CurrentFont: TCarbonFont read FCurrentFont write SetCurrentFont;
property CurrentBrush: TCarbonBrush read FCurrentBrush write SetCurrentBrush;
property CurrentPen: TCarbonPen read FCurrentPen write SetCurrentPen;
property CurrentRegion: TCarbonRegion read FCurrentRegion write SetCurrentRegion;
property BkColor: TColor read FBkColor write SetBkColor;
property BkMode: Integer read FBkMode write SetBkMode;
property BkBrush: TCarbonBrush read FBkBrush;
property TextColor: TColor read FTextColor write SetTextColor;
property TextBrush: TCarbonBrush read FTextBrush;
property ROP2: Integer read FROP2 write SetROP2;
property PenPos: TPoint read FPenPos write FPenPos;
property TextFractional: Boolean read FTextFractional write FTextFractional;
property WindowOfs: TPoint read FWindowOfs write SetWindowOfs;
property ViewPortOfs: TPoint read FViewPortOfs write SetViewPortOfs;
end;
{ TCarbonScreenContext }
TCarbonScreenContext = class(TCarbonDeviceContext)
protected
function GetSize: TPoint; override;
public
constructor Create; // TODO
end;
{ TCarbonControlContext }
TCarbonControlContext = class(TCarbonDeviceContext)
private
FOwner: TCarbonWidget; // owner widget
FClipShapeRef: HIShapeRef;
protected
function GetSize: TPoint; override;
public
constructor Create(AOwner: TCarbonWidget);
function IsInClipRegion(ARect: TRect): Boolean;
property Owner: TCarbonWidget read FOwner;
property ClipShapeRef: HIShapeRef read FClipShapeRef write FClipShapeRef;
end;
{ TCarbonBitmapContext }
TCarbonBitmapContext = class(TCarbonDeviceContext)
private
FBitmap: TCarbonBitmap;
function GetBitmap: TCarbonBitmap;
procedure SetBitmap(const AValue: TCarbonBitmap);
protected
function GetSize: TPoint; override;
public
constructor Create;
destructor Destroy; override;
procedure Reset; override;
function GetPixel(X, Y: Integer): TGraphicsColor; override;
public
property Bitmap: TCarbonBitmap read GetBitmap write SetBitmap;
end;
// TODO: TCarbonPrinterContext
function CheckDC(const DC: HDC; const AMethodName: String; AParamName: String = ''): Boolean;
var
// context for calculating text parameters for invisible controls
DefaultContext: TCarbonBitmapContext;
ScreenContext: TCarbonScreenContext;
implementation
uses LCLIntf, CarbonProc, CarbonDbgConsts;
{------------------------------------------------------------------------------
Name: CheckDC
Params: DC - Handle to a device context (TCarbonDeviceContext)
AMethodName - Method name
AParamName - Param name
Returns: If the DC is valid
------------------------------------------------------------------------------}
function CheckDC(const DC: HDC; const AMethodName: String;
AParamName: String): Boolean;
begin
if TObject(DC) is TCarbonDeviceContext then Result := True
else
begin
Result := False;
if Pos('.', AMethodName) = 0 then
DebugLn(SCarbonWSPrefix + AMethodName + ' Error - invalid DC ' +
AParamName + ' = ' + DbgS(DC) + '!')
else
DebugLn(AMethodName + ' Error - invalid DC ' + AParamName + ' = ' +
DbgS(DC) + '!');
end;
end;
{ TCarbonDeviceContext }
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetBkColor
Params: AValue - New background color
Sets the background color
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetBkColor(AValue: TColor);
begin
AValue := TColor(ColorToRGB(AValue));
FBkColor := AValue;
FBkBrush.SetColor(AValue, BkMode = OPAQUE);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetBkMode
Params: AValue - New background mode (OPAQUE, TRANSPARENT)
Sets the background mode
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetBkMode(const AValue: Integer);
begin
if FBkMode <> AValue then
begin
FBkMode := AValue;
FBkBrush.SetColor(FBkColor, FBkMode = OPAQUE);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetCurrentBrush
Params: AValue - New brush
Sets the current brush
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetCurrentBrush(const AValue: TCarbonBrush);
begin
if AValue = nil then
begin
DebugLn('TCarbonDeviceContext.SetCurrentBrush Error - Value is nil!');
Exit;
end;
if FCurrentBrush <> AValue then
begin
if FCurrentBrush <> nil then FCurrentBrush.Unselect;
FCurrentBrush := AValue;
FCurrentBrush.Select;
FCurrentBrush.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetCurrentFont
Params: AValue - New font
Sets the current font
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetCurrentFont(const AValue: TCarbonFont);
begin
if AValue = nil then
begin
DebugLn('TCarbonDeviceContext.SetCurrentFont Error - Value is nil!');
Exit;
end;
if FCurrentFont <> AValue then
begin
//DebugLn('TCarbonDeviceContext.SetCurrentFont ', DbgS(FCurrentFont), '->',
// DbgS(AValue));
if FCurrentFont <> nil then FCurrentFont.Unselect;
FCurrentFont := AValue;
FCurrentFont.Select;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetCurrentPen
Params: AValue - New pen
Sets the current pen
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetCurrentPen(const AValue: TCarbonPen);
begin
if AValue = nil then
begin
DebugLn('TCarbonDeviceContext.SetCurrentPen Error - Value is nil!');
Exit;
end;
if FCurrentPen <> AValue then
begin
if FCurrentPen <> nil then FCurrentPen.Unselect;
FCurrentPen := AValue;
FCurrentPen.Select;
FCurrentPen.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetCurrentRegion
Params: AValue - New region
Sets the current region
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetCurrentRegion(const AValue: TCarbonRegion);
begin
if AValue = nil then
begin
DebugLn('TCarbonDeviceContext.SetCurrentRegion Error - Value is nil!');
Exit;
end;
if FCurrentRegion <> AValue then
begin
if FCurrentRegion <> nil then FCurrentRegion.Unselect;
FCurrentRegion := AValue;
FCurrentRegion.Select;
FCurrentRegion.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetROP2
Params: AValue - New binary raster operation
Sets the binary raster operation
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetROP2(const AValue: Integer);
begin
if FROP2 <> AValue then
begin
FROP2 := AValue;
CurrentPen.Apply(Self);
CurrentBrush.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetTextColor
Params: AValue - New text color
Sets the text color
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetTextColor(AValue: TColor);
begin
AValue := TColor(ColorToRGB(AValue));
FTextColor := AValue;
TextBrush.SetColor(AValue, True);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Create
Creates new Carbon device context
------------------------------------------------------------------------------}
constructor TCarbonDeviceContext.Create;
begin
inherited Create;
FBkBrush := TCarbonBrush.Create(False);
FTextBrush := TCarbonBrush.Create(False);
FCurrentPen := DefaultPen;
FCurrentPen.Select;
FCurrentBrush := DefaultBrush;
FCurrentBrush.Select;
FCurrentFont := DefaultFont;
FCurrentFont.Select;
FClipRegion := TCarbonRegion.Create;
FCurrentRegion := FClipRegion;
FCurrentRegion.Select;
FTextFractional := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Destroy
Frees Carbon device context
------------------------------------------------------------------------------}
destructor TCarbonDeviceContext.Destroy;
begin
BkBrush.Free;
TextBrush.Free;
FSavedDCList.Free;
if FCurrentPen <> nil then FCurrentPen.Unselect;
if FCurrentBrush <> nil then FCurrentBrush.Unselect;
if FCurrentFont <> nil then FCurrentFont.Unselect;
if FCurrentRegion <> nil then FCurrentRegion.Unselect;
FClipRegion.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Reset
Resets the device context properties to defaults (pen, brush, ...)
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Reset;
begin
FPenPos.x := 0;
FPenPos.y := 0;
// create brush for bk color and mode
FBkColor := clWhite;
FBkMode := TRANSPARENT;
FBkBrush.SetColor(clWhite, False);
// create brush for text color
FTextColor := clBlack;
FTextBrush.SetColor(clBlack, True);
// set raster operation to copy
FROP2 := R2_COPYPEN;
CurrentFont := DefaultFont;
if CGContext <> nil then
begin
{$IFDEF VerboseCanvas}
DebugLn('TCarbonDeviceContext.Reset set defaults');
{$ENDIF}
// enable anti-aliasing
CGContextSetShouldAntialias(CGContext, 1);
// set initial pen, brush and font
CurrentPen := DefaultPen;
CurrentBrush := DefaultBrush;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SaveDC
Returns: Index of saved device context state
Note: must be used in pair with RestoreDC!
------------------------------------------------------------------------------}
function TCarbonDeviceContext.SaveDC: Integer;
begin
ClearClipping;
Result := 0;
if CGContext = nil then
begin
DebugLn('TCarbonDeviceContext.SaveDC CGContext is nil!');
Exit;
end;
if FSavedDCList = nil then FSavedDCList := TFPObjectList.Create(True);
CGContextSaveGState(CGContext);
Result := FSavedDCList.Add(SaveDCData) + 1;
{$IFDEF VerboseCanvas}
DebugLn('TCarbonDeviceContext.SaveDC Result: ', DbgS(Result));
{$ENDIF}
if isClipped then
begin
CGContextSaveGState(CGContext);
FClipRegion.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.RestoreDC
Params: ASavedDC - Index of saved device context
Returns: If the function succeeds
Restores the previously saved state of device context
------------------------------------------------------------------------------}
function TCarbonDeviceContext.RestoreDC(ASavedDC: Integer): Boolean;
begin
ClearClipping;
Result := False;
if (FSavedDCList = nil) or (ASavedDC <= 0) or (ASavedDC > FSavedDCList.Count) then
begin
DebugLn(Format('TCarbonDeviceContext.RestoreDC SavedDC %d is not valid!', [ASavedDC]));
Exit;
end;
if FSavedDCList.Count > ASavedDC then
DebugLn(Format('TCarbonDeviceContext.RestoreDC Warning: SaveDC - RestoreDC' +
' not used in pair, skipped %d saved states!', [FSavedDCList.Count - ASavedDC]));
while FSavedDCList.Count > ASavedDC do
begin
CGContextRestoreGState(CGContext);
FSavedDCList.Delete(FSavedDCList.Count - 1);
end;
{$IFDEF VerboseCanvas}
DebugLn('TCarbonDeviceContext.RestoreDC SavedDC: ', DbgS(ASavedDC));
{$ENDIF}
CGContextRestoreGState(CGContext);
RestoreDCData(TCarbonDCData(FSavedDCList[ASavedDC - 1]));
FSavedDCList.Delete(ASavedDC - 1);
Result := True;
{$IFDEF VerboseCanvas}
DebugLn('TCarbonDeviceContext.RestoreDC End');
{$ENDIF}
if FSavedDCList.Count = 0 then FreeAndNil(FSavedDCList);
if isClipped then
begin
CGContextSaveGState(CGContext);
FClipRegion.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SaveDCData
Returns: The device context data
------------------------------------------------------------------------------}
function TCarbonDeviceContext.SaveDCData: TCarbonDCData;
begin
Result := TCarbonDCData.Create;
Result.CurrentFont := FCurrentFont;
Result.CurrentBrush := FCurrentBrush;
Result.CurrentPen := FCurrentPen;
Result.CurrentRegion := FCurrentRegion;
Result.BkColor := FBkColor;
Result.BkMode := FBkMode;
Result.BkBrush := FBkBrush;
Result.TextColor := FTextColor;
Result.TextBrush := FTextBrush;
Result.ROP2 := FROP2;
Result.PenPos := FPenPos;
Result.WindowOfs := FWindowOfs;
Result.ViewportOfs := FViewportOfs;
Result.isClipped := isClipped;
Result.ClipShape := FClipRegion.GetShapeCopy;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.RestoreDCData
Params: AData - Device context data
Restores device context data
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.RestoreDCData(const AData: TCarbonDCData);
begin
if (FCurrentFont <> AData.CurrentFont) then
begin
if (FCurrentFont <> nil) then
FCurrentFont.Unselect;
if (AData.CurrentFont <> nil) then
AData.CurrentFont.Select;
end;
FCurrentFont := AData.CurrentFont;
if (FCurrentBrush <> AData.CurrentBrush) then
begin
if (FCurrentBrush <> nil) then
FCurrentBrush.Unselect;
if (AData.CurrentBrush <> nil) then
AData.CurrentBrush.Select;
end;
FCurrentBrush := AData.CurrentBrush;
FCurrentBrush.Apply(Self);
if (FCurrentPen <> AData.CurrentPen) then
begin
if (FCurrentPen <> nil) then
FCurrentPen.Unselect;
if (AData.CurrentPen <> nil) then
AData.CurrentPen.Select;
end;
FCurrentPen := AData.CurrentPen;
FCurrentPen.Apply(Self);
if (FCurrentRegion <> AData.CurrentRegion) then
begin
if (FCurrentRegion <> nil) then
FCurrentRegion.Unselect;
if (AData.CurrentRegion <> nil) then
AData.CurrentRegion.Select;
end;
FCurrentRegion := AData.CurrentRegion;
FBkColor := AData.BkColor;
FBkMode := AData.BkMode;
FBkBrush := AData.BkBrush;
FTextColor := AData.TextColor;
FTextBrush := AData.TextBrush;
FROP2 := AData.ROP2;
FPenPos := AData.PenPos;
FWindowOfs := AData.WindowOfs;
FViewportOfs := AData.ViewportOfs;
isClipped := AData.isClipped;
FClipRegion.Shape := AData.ClipShape;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.BeginTextRender
Params: AStr - UTF8 string to render
ACount - Count of chars to render
ALayout - ATSU layout
Returns: If the function suceeds
Creates the ATSU text layout for the specified text and manages the device
context to render the text.
NOTE: Coordination system is set upside-down!
------------------------------------------------------------------------------}
function TCarbonDeviceContext.BeginTextRender(AStr: PChar; ACount: Integer; out
ALayout: TCarbonTextLayout): Boolean;
var
S: String;
begin
Result := False;
if ACount = 0 then Exit;
// save context
CGContextSaveGState(CGContext);
// change coordination system
CGContextScaleCTM(CGContext, 1, -1);
if ACount < 0 then S := AStr
else S := Copy(AStr, 1, ACount);
ALayout := CurrentFont.CreateTextLayout(S, TextFractional);
ALayout.Apply(Self);
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.EndTextRender
Params: ALayout - ATSU layout
Frees the ATSU text layout and manages the device
context to render ordinary graphic
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.EndTextRender(var ALayout: TCarbonTextLayout);
begin
// restore context
CGContextRestoreGState(CGContext);
ALayout.Release;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetAntialiasing
Params: AValue - If should antialias
Sets whether device context should antialias
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetAntialiasing(AValue: Boolean);
begin
if not AValue then
CGContextSetInterpolationQuality(CGContext, kCGInterpolationNone)
else
CGContextSetInterpolationQuality(CGContext, kCGInterpolationDefault);
CGContextSetShouldAntialias(CGContext, CBool(AValue));
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.GetBlendModeFromROP
Params: ROP - The raster operation. See TCopyMode
Returns: The CGBlendMode corresponding to this operation if such mode exists,
the default kCGBlendModeNormal otherwise
Converts a TCopoyMode raster operation to a BlendMode
------------------------------------------------------------------------------}
function TCarbonDeviceContext.GetBlendModeFromROP(ROP: DWORD) : CGBlendMode;
begin
case ROP of
cmSrcPaint : result := kCGBlendModeNormal;
cmSrcInvert : result := kCGBlendModeExclusion;
else result := kCGBlendModeNormal;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.DrawCGImage
Params: X, Y - Left, Top
Width, Height
CGImage
BlendMode
Returns: If the function succeeds
Draws CGImage into CGContext
------------------------------------------------------------------------------}
function TCarbonDeviceContext.DrawCGImage(X, Y, Width, Height: Integer;
CGImage: CGImageRef; BlendMode: CGBlendMode): Boolean;
begin
Result := False;
// save dest context
CGContextSaveGState(CGContext);
CGContextSetBlendMode(CGContext, BlendMode);
try
SetCGFillping(CGContext, Width, Height);
if OSError(
HIViewDrawCGImage(CGContext,
GetCGRectSorted(X, Y, X + Width, Y + Height), CGImage),
'DrawCGImage', 'HIViewDrawCGImage') then Exit;
RestoreCGFillping(CGContext, Width, Height);
finally
CGContextRestoreGState(CGContext);
end;
Result := True;
end;
procedure TCarbonDeviceContext.SetCGFillping(Ctx: CGContextRef; Width, Height: Integer);
begin
if Width < 0 then begin
CGContextTranslateCTM(Ctx, -Width, 0);
CGContextScaleCTM(Ctx, -1, 1);
end;
if Height < 0 then begin
CGContextTranslateCTM(Ctx, 0, -Height);
CGContextScaleCTM(Ctx, 1, -1);
end;
end;
procedure TCarbonDeviceContext.RestoreCGFillping(Ctx: CGContextRef; Width, Height: Integer);
begin
if Height < 0 then begin
CGContextTranslateCTM(Ctx, 0, Height);
CGContextScaleCTM(Ctx, 1, -1);
end;
if Width < 0 then begin
CGContextScaleCTM(Ctx, -1, 1);
CGContextTranslateCTM(Ctx, Width, 0);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.DrawFocusRect
Params: ARect - Bounding rectangle
Returns: If the function succeeds
Draws a focus rectangle
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.DrawFocusRect(ARect: TRect);
var
AOutSet: SInt32;
begin
// LCL thinks that focus cannot be drawn outside focus rects, but carbon do that
// => correct rect
OSError(GetThemeMetric(kThemeMetricFocusRectOutset, AOutSet{%H-}),
Self, 'DrawFocusRect', 'GetThemeMetric');
InflateRect(ARect, -AOutSet, -AOutSet);
OSError(
HIThemeDrawFocusRect(RectToCGRect(ARect), True, CGContext, kHIThemeOrientationNormal),
Self, 'DrawFocusRect', 'HIThemeDrawFocusRect');
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.DrawGrid
Params: Arect - Grid rectangle
DX, DY - Grid cell width and height
Draws the point grid
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.DrawGrid(const ARect: TRect; DX, DY: Integer);
var
Y: Integer;
GridLine: Array [0..1] of Single;
begin
CGContextSaveGState(CGContext);
try
CGContextSetShouldAntialias(CGContext, 0);
GridLine[0] := 1;
GridLine[1] := DX - 1;
CGContextSetLineDash(CGContext, 0, @GridLine[0], Length(GridLine));
CGContextBeginPath(CGContext);
// draw horzontal dotted lines
for Y := 0 to (ARect.Bottom - ARect.Top - 1) div DY do
begin
CGContextMoveToPoint(CGContext, ARect.Left, ARect.Top + Y * DY + 1);
CGContextAddLineToPoint(CGContext, ARect.Right, ARect.Top + Y * DY + 1);
end;
CGContextStrokePath(CGContext);
finally
CGContextRestoreGState(CGContext);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Ellipse
Params:
X1 - X-coord. of bounding rectangle's upper-left corner
Y1 - Y-coord. of bounding rectangle's upper-left corner
X2 - X-coord. of bounding rectangle's lower-right corner
Y2 - Y-coord. of bounding rectangle's lower-right corner
Draws a ellipse. The ellipse is outlined by using the current pen and filled
by using the current brush.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Ellipse(X1, Y1, X2, Y2: Integer);
var
R: CGRect;
begin
if (X1 = X2) or (Y1 = Y2) then Exit;
R := GetCGRectSorted(X1, Y1, X2, Y2);
R.origin.x := R.origin.x + 0.5;
R.origin.y := R.origin.y + 0.5;
R.size.width := R.size.width - 1;
R.size.height := R.size.height - 1;
CGContextBeginPath(CGContext);
CGContextAddEllipseInRect(CGContext, R);
CGContextDrawPath(CGContext, kCGPathFillStroke);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.ExcludeClipRect
Params: Left, Top, Right, Bottom - Rectangle coordinates
Subtracts all intersecting points of the passed bounding rectangle from the
current clipping region of the device context.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.ExcludeClipRect(Left, Top, Right, Bottom: Integer);
var
ClipBox: TRect;
Rects: CGRectArray;
begin
if (Left < Right) and (Top < Bottom) then
begin
// get clip bounding box, exclude passed rect and intersect result
// with clip region
ClipBox := CGRectToRect(CGContextGetClipBoundingBox(CGContext));
Rects := ExcludeRect(ClipBox, Classes.Rect(Left, Top, Right, Bottom));
if Length(Rects) > 0 then
CGContextClipToRects(CGContext, @Rects[0], Length(Rects))
else
CGContextClipToRect(CGContext, CGRectZero);
end;
end;
procedure TCarbonDeviceContext.ApplyTransform(Trans: CGAffineTransform);
var
T2: CGAffineTransform;
begin
T2 := CGContextGetCTM(CGContext);
// restore old CTM since CTM may changed after the clipping
if CGAffineTransformEqualToTransform(Trans, T2) = 0 then
CGContextTranslateCTM(CGContext, Trans.a * Trans.tx - T2.a * T2.tx,
Trans.d * Trans.ty - T2.d * T2.ty);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.ExtTextOut
Params: X - X-coordinate of reference point
Y - Y-coordinate of reference point
Options - Text-output options
Rect - Optional clipping and/or opaquing rectangle (TODO)
Str - Character string to be drawn
Count - Number of characters in string
Dx - Pointer to array of intercharacter spacing values
Returns: If the string was drawn
Draws a character string by using the currently selected font
------------------------------------------------------------------------------}
function TCarbonDeviceContext.ExtTextOut(X, Y: Integer; Options: Longint;
Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean;
var
TextLayout: TCarbonTextLayout;
BrushSolid: Boolean;
begin
Result := False;
//DebugLn('TCarbonDeviceContext.ExtTextOut ' + DbgS(X) + ', ' + DbgS(Y) + ' R: ' + DbgS(Rect^) +
// ' S: ' + Str + ' C: ' + DbgS(Count));
if Assigned(Rect) then
begin
// fill background
if (Options and ETO_OPAQUE) > 0 then
begin
BrushSolid := BkBrush.Solid; // must ignore BkMode
BkBrush.Solid := True;
FillRect(Rect^, BkBrush);
BkBrush.Solid := BrushSolid;
end;
//DebugLn('TCarbonDeviceContext.ExtTextOut fill ' + DbgS(Rect^));
end;
if not BeginTextRender(Str, Count, TextLayout) then Exit;
try
if CurrentFont.LineRotation = 0 then // TODO: fill rotated text background
begin
// fill drawed text background
if BkMode = OPAQUE then
begin
BrushSolid := BkBrush.Solid; // must ignore BkMode
BkBrush.Solid := True;
BkBrush.Apply(Self, False); // do not use ROP2
CGContextFillRect(CGContext, TextLayout.GetDrawBounds(X, Y));
BkBrush.Solid := BrushSolid;
end;
end;
// apply text color
TextBrush.Apply(Self, False); // do not use ROP2
// finally draw the text
if not TextLayout.Draw(X, Y, DX, Count) then Exit;
Result := True;
finally
EndTextRender(TextLayout);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.FillRect
Params: Rect - Record with rectangle coordinates
Brush - Carbon brush
Fills the rectangle by using the specified brush
It includes the left and top borders, but excludes the right and
bottom borders of the rectangle!
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.FillRect(Rect: TRect; Brush: TCarbonBrush);
begin
Brush.Apply(Self, False); // do not use ROP2
try
CGContextFillRect(CGContext, GetCGRectSorted(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom));
finally
CurrentBrush.Apply(Self); // apply current brush
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Frame
Params: X1 - X-coordinate of bounding rectangle's upper-left corner
Y1 - Y-coordinate of bounding rectangle's upper-left corner
X2 - X-coordinate of bounding rectangle's lower-right corner
Y2 - Y-coordinate of bounding rectangle's lower-right corner
Draws a border in Carbon native style
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Frame(X1, Y1, X2, Y2: Integer);
begin
StockNullBrush.Apply(Self, False); // do not use ROP2
try
Rectangle(X1, Y1, X2 + 1, Y2 + 1);
finally
CurrentBrush.Apply(Self); // apply current brush
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Frame3D
Params: ARect - Bounding box of frame
FrameWidth - Frame width
Style - Frame style
Draws a 3D border in Carbon native style
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Frame3D(var ARect: TRect;
const FrameWidth: integer; const Style: TBevelCut);
var
I, D: Integer;
DrawInfo: HIThemeGroupBoxDrawInfo;
const
SName = 'Frame3D';
begin
if Style = bvRaised then
begin
D := GetCarbonThemeMetric(kThemeMetricPrimaryGroupBoxContentInset, 1);
// draw frame as group box
DrawInfo.version := 0;
DrawInfo.state := kThemeStateActive;
DrawInfo.kind := kHIThemeGroupBoxKindPrimary;
for I := 1 to FrameWidth do
begin
OSError(
HIThemeDrawGroupBox(RectToCGRect(ARect), DrawInfo, CGContext,
kHIThemeOrientationNormal),
Self, SName, 'HIThemeDrawGroupBox');
InflateRect(ARect, -D, -D);
end;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.GetClipRect
Returns: Clipping rectangle
------------------------------------------------------------------------------}
function TCarbonDeviceContext.GetClipRect: TRect;
begin
Result := CGRectToRect(CGContextGetClipBoundingBox(CGContext));
end;
function TCarbonDeviceContext.GetLineLastPixelPos(PrevPos, NewPos: TPoint
): TPoint;
begin
Result := NewPos;
if NewPos.X > PrevPos.X then
dec(Result.X)
else
if NewPos.X < PrevPos.X then
inc(Result.X);
if NewPos.Y > PrevPos.Y then
dec(Result.Y)
else
if NewPos.Y < PrevPos.Y then
inc(Result.Y);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.GetPixel
Params: X, Y - Coordinates of pixel
Returns: Specified pixel color
------------------------------------------------------------------------------}
function TCarbonDeviceContext.GetPixel(X, Y: Integer): TGraphicsColor;
begin
Result := clNone;
DebugLn('TODO: Implement get pixel for CGContext.');
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.GetTextExtentPoint
Params: Str - Text string
Count - Number of characters in string
Size - The record for the dimensions of the string
Returns: If the function succeeds
Computes the width and height of the specified string of text
------------------------------------------------------------------------------}
function TCarbonDeviceContext.GetTextExtentPoint(Str: PChar; Count: Integer;
var Size: TSize): Boolean;
var
TextLayout: TCarbonTextLayout;
begin
Result := False;
Size.cx := 0;
Size.cy := 0;
if not BeginTextRender(Str, Count, TextLayout) then Exit;
try
Size.cx := TextLayout.GetWidth;
Size.cy := TextLayout.GetHeight;
Result := True;
finally
EndTextRender(TextLayout);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.GetTextMetrics
Params: TM - The Record for the text metrics
Returns: If the function succeeds
Fills the specified buffer with the metrics for the currently selected font
TODO: get exact max. and av. char width, pitch and charset
------------------------------------------------------------------------------}
function TCarbonDeviceContext.GetTextMetrics(var TM: TTextMetric): Boolean;
var
TextStyle: ATSUStyle;
M: ATSUTextMeasurement;
B: Boolean;
TextLayout: TCarbonTextLayout;
const
SName = 'GetTextMetrics';
SGetAttrName = 'ATSUGetAttribute';
begin
Result := False;
TextStyle := CurrentFont.Style;
FillChar(TM, SizeOf(TM), 0);
// According to the MSDN library, TEXTMETRIC:
// the average char width is generally defined as the width of the letter x
if not BeginTextRender('x', 1, TextLayout) then Exit;
try
TM.tmAscent := RoundFixed(TextLayout.Ascent);
TM.tmDescent := RoundFixed(TextLayout.Descent);
TM.tmHeight := RoundFixed(TextLayout.Ascent + TextLayout.Descent);
if OSError(ATSUGetAttribute(TextStyle, kATSULeadingTag, SizeOf(M), @M, nil),
Self, SName, SGetAttrName, 'kATSULeadingTag', kATSUNotSetErr) then Exit;
TM.tmInternalLeading := RoundFixed(M);
TM.tmExternalLeading := 0;
TM.tmAveCharWidth := RoundFixed(TextLayout.TextAfter - TextLayout.TextBefore);
finally
EndTextRender(TextLayout);
end;
TM.tmPitchAndFamily := TRUETYPE_FONTTYPE;
{ Heuristic for determining fixed pitch; "i" is typically small }
if BeginTextRender('i', 1, TextLayout) then
try
if TM.tmAveCharWidth = RoundFixed(TextLayout.TextAfter - TextLayout.TextBefore) then
TM.tmPitchAndFamily := TM.tmPitchAndFamily or FIXED_PITCH;
finally
EndTextRender(TextLayout);
end;
TM.tmMaxCharWidth := TM.tmAscent; // TODO: don't know how to determine this right
TM.tmOverhang := 0;
TM.tmDigitizedAspectX := 0;
TM.tmDigitizedAspectY := 0;
TM.tmFirstChar := 'a';
TM.tmLastChar := 'z';
TM.tmDefaultChar := 'x';
TM.tmBreakChar := '?';
if OSError(ATSUGetAttribute(TextStyle, kATSUQDBoldfaceTag, SizeOf(B), @B, nil),
Self, SName, SGetAttrName, 'kATSUQDBoldfaceTag', kATSUNotSetErr) then Exit;
if B then TM.tmWeight := FW_NORMAL
else TM.tmWeight := FW_BOLD;
if OSError(ATSUGetAttribute(TextStyle, kATSUQDItalicTag, SizeOf(B), @B, nil),
Self, SName, SGetAttrName, 'kATSUQDItalicTag', kATSUNotSetErr) then Exit;
TM.tmItalic := Byte(B);
if OSError(ATSUGetAttribute(TextStyle, kATSUQDUnderlineTag, SizeOf(B), @B, nil),
Self, SName, SGetAttrName, 'kATSUQDUnderlineTag', kATSUNotSetErr) then Exit;
TM.tmUnderlined := Byte(B);
if OSError(ATSUGetAttribute(TextStyle, kATSUStyleStrikeThroughTag, SizeOf(B), @B, nil),
Self, SName, SGetAttrName, 'kATSUStyleStrikeThroughTag', kATSUNotSetErr) then Exit;
TM.tmStruckOut := Byte(B);
// TODO: get these from font
TM.tmCharSet := DEFAULT_CHARSET;
Result := True;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.InvertRectangle
Params: X1 - X-coordinate of bounding rectangle's upper-left corner
Y1 - Y-coordinate of bounding rectangle's upper-left corner
X2 - X-coordinate of bounding rectangle's lower-right corner
Y2 - Y-coordinate of bounding rectangle's lower-right corner
Draws an inverted rectangle.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.InvertRectangle(X1, Y1, X2, Y2: Integer);
begin
// save dest context
CGContextSaveGState(CGContext);
try
WhiteBrush.Apply(Self, False);
CGContextSetBlendMode(CGContext, kCGBlendModeDifference);
CGContextFillRect(CGContext, GetCGRectSorted(X1, Y1, X2, Y2));
finally
CGContextRestoreGState(CGContext);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.LineTo
Params: X - X-coordinate of line's ending point
Y - Y-coordinate of line's ending point
Draws a line from the current position up to the specified point and updates
the current position
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.LineTo(X, Y: Integer);
var
deltaX, deltaY, absDeltaX, absDeltaY: Integer;
clipDeltaX, clipDeltaY: Float32;
tx, ty, bx, by: Float32;
begin
bx := FPenPos.x;
by := FPenPos.y;
deltaX := X - FPenPos.x;
deltaY := Y - FPenPos.y;
if (deltaX=0) and (deltaY=0) then Exit;
absDeltaX := Abs(deltaX);
absDeltaY := Abs(deltaY);
if (absDeltaX<=1) and (absDeltaY<=1) then
begin
// special case for 1-pixel lines
tx := bx + 0.05 * deltaX;
ty := by + 0.05 * deltaY;
end
else
begin
// correct start/end coordinates
if absDeltaX > absDeltaY then
begin
if deltaX > 0 then clipDeltaX := -0.5 else clipDeltaX := 0.5;
clipDeltaY := clipDeltaX * deltaY / deltaX;
end
else
begin
if deltaY > 0 then clipDeltaY := -0.5 else clipDeltaY := 0.5;
clipDeltaX := clipDeltaY * deltaX / deltaY;
end;
bx := bx + clipDeltaX;
by := by + clipDeltaY;
tx := X + clipDeltaX;
ty := Y + clipDeltaY;
end;
CGContextBeginPath(CGContext);
CGContextMoveToPoint(CGContext, bx + 0.5, by + 0.5);
CGContextAddLineToPoint(CGContext, tx + 0.5, ty + 0.5);
CGContextStrokePath(CGContext);
FPenPos.x := X;
FPenPos.y := Y;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.PolyBezier
Params: Points - Points defining the cubic Bézier curve
NumPts - Number of points passed
Filled - Fill the drawed shape
Continous - Connect Bézier curves
Draws a cubic Bézier curves. The first curve is drawn from the first point to
the fourth point with the second and third points being the control points.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.PolyBezier(Points: PPoint; NumPts: Integer;
Filled, Continuous: boolean);
var
C1, C2: TPoint;
begin
if Points = nil then Exit;
if NumPts < 4 then Exit;
CGContextBeginPath(CGContext);
if Continuous then
begin
CGContextMoveToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts);
while NumPts >= 3 do
begin
Inc(Points);
C1 := Points^;
Inc(Points);
C2 := Points^;
Inc(Points);
CGContextAddCurveToPoint(CGContext, C1.x + 0.5, C1.y + 0.5, C2.x + 0.5, C2.y + 0.5,
Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts, 3);
end;
end
else
begin
while NumPts >= 4 do
begin
CGContextMoveToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Inc(Points);
C1 := Points^;
Inc(Points);
C2 := Points^;
Inc(Points);
CGContextAddCurveToPoint(CGContext, C1.x + 0.5, C1.y + 0.5, C2.x + 0.5, C2.y + 0.5,
Points^.x + 0.5, Points^.y + 0.5);
Inc(Points);
Dec(NumPts, 4);
end;
end;
if Filled and Continuous then
CGContextDrawPath(CGContext, kCGPathFillStroke)
else
CGContextDrawPath(CGContext, kCGPathStroke);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Polygon
Params: Points - Pointer to polygon's vertices
NumPts - Number of polygon's vertices
Winding - Use winding fill rule
Draws a closed, many-sided shape on the canvas, using the pen and brush.
If Winding is set, Polygon fills the shape using the Winding fill algorithm.
Otherwise, Polygon uses the even-odd (alternative) fill algorithm. The first
point is always connected to the last point.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Polygon(Points: PPoint; NumPts: Integer;
Winding: boolean);
begin
if Points = nil then Exit;
if NumPts < 2 then Exit;
CGContextBeginPath(CGContext);
CGContextMoveToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts);
while NumPts > 0 do
begin
Inc(Points);
CGContextAddLineToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts);
end;
CGContextClosePath(CGContext);
if Winding then
CGContextDrawPath(CGContext, kCGPathFillStroke)
else
CGContextDrawPath(CGContext, kCGPathEOFillStroke);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Polyline
Params: Points - Pointer to array containing points
NumPts - Number of points in the array
Draws a series of line segments by connecting the points in the specified
array
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Polyline(Points: PPoint; NumPts: Integer);
var
P: TPoint;
begin
if Points = nil then Exit;
if NumPts < 1 then Exit;
CGContextBeginPath(CGContext);
CGContextMoveToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts);
while NumPts > 1 do
begin
Inc(Points);
CGContextAddLineToPoint(CGContext, Points^.x + 0.5, Points^.y + 0.5);
Dec(NumPts);
end;
P := GetLineLastPixelPos(Points[0], Points[1]);
CGContextAddLineToPoint(CGContext, P.x + 0.5, P.y + 0.5);
CGContextStrokePath(CGContext);
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.Rectangle
Params: X1 - X-coordinate of bounding rectangle's upper-left corner
Y1 - Y-coordinate of bounding rectangle's upper-left corner
X2 - X-coordinate of bounding rectangle's lower-right corner
Y2 - Y-coordinate of bounding rectangle's lower-right corner
Draws a rectangle. The rectangle is outlined by using the current pen and
filled by using the current brush.
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.Rectangle(X1, Y1, X2, Y2: Integer);
var
R: CGRect;
begin
//DebugLn('TCarbonDeviceContext.Rectangle ' + DbgS(Classes.Rect(X1, Y1, X2, Y2)));
if (X1 = X2) or (Y1 = Y2) then Exit;
R := GetCGRectSorted(X1, Y1, X2, Y2);
R.origin.x := R.origin.x + 0.5;
R.origin.y := R.origin.y + 0.5;
R.size.width := R.size.width - 1;
R.size.height := R.size.height - 1;
CurrentBrush.Apply(Self, false); // apply current brush
try
CGContextBeginPath(CGContext);
CGContextAddRect(CGContext, R);
CGContextDrawPath(CGContext, kCGPathFillStroke);
finally
CurrentBrush.Apply(Self);
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonDeviceContext.SetPixel
Params: X, Y - Position
AColor - New color for specified position
Sets the color of the specified pixel on the canvas
------------------------------------------------------------------------------}
procedure TCarbonDeviceContext.SetPixel(X, Y: Integer; AColor: TGraphicsColor);
var
R, G, B: Byte;
begin
CGContextSaveGState(CGContext);
try
// apply color to fill
CGContextSetBlendMode(CGContext, kCGBlendModeNormal);
RedGreenBlue(ColorToRGB(AColor), R, G, B);
CGContextSetRGBFillColor(CGContext, R / 255, G / 255, B / 255, 1.0);
CGContextFillRect(CGContext, GetCGRect(X, Y, X + 1, Y + 1));
finally
CGContextRestoreGState(CGContext);
end;
end;
{------------------------------------------------------------------------------
Method: StretchMaskBlt
Params: X, Y - Left/top corner of the destination rectangle
Width, Height - Size of the destination rectangle
SrcDC - Carbon device context
XSrc, YSrc - Left/top corner of the source rectangle
SrcWidth, SrcHeight - Size of the source rectangle
Mask - mask bitmap
XMask, YMask - Left/top corner of the mask rectangle
Rop - Raster operation to be performed (TODO)
Returns: If the function succeeds
Copies a bitmap from a source rectangle into a destination rectangle using
the specified raster operations. If needed it resizes the bitmap to
fit the dimensions of the destination rectangle. Sizing is done according to
the stretching mode currently set in the destination device context.
TODO: copy from any canvas
ROP
stretch mode (should be set by winapi call in DC (MWE))
------------------------------------------------------------------------------}
function TCarbonDeviceContext.StretchDraw(X, Y, Width, Height: Integer;
SrcDC: TCarbonBitmapContext; XSrc, YSrc, SrcWidth, SrcHeight: Integer;
Msk: TCarbonBitmap; XMsk, YMsk: Integer; Rop: DWORD): Boolean;
var
Image, MskImage: CGImageRef;
SubImage, SubMask: Boolean;
Bitmap: TCarbonBitmap;
LayRect, DstRect: CGRect;
ImgRect: CGRect;
LayerContext: CGContextRef;
Layer: CGLayerRef;
UseLayer: Boolean;
begin
Result := False;
Image := nil;
Bitmap := SrcDC.GetBitmap;
if Bitmap <> nil then Image := Bitmap.CGImage;
if Image = nil then Exit;
//apply window offset
XSrc := XSrc - SrcDC.WindowOfs.X;
YSrc := YSrc - SrcDC.WindowOfs.Y;
DstRect := CGRectMake(X, Y, Abs(Width), Abs(Height));
SubMask := (Msk <> nil)
and (Msk.CGImage <> nil)
and ( (XMsk <> 0)
or (YMsk <> 0)
or (Msk.Width <> SrcWidth)
or (Msk.Height <> SrcHeight));
SubImage := ((Msk <> nil) and (Msk.CGImage <> nil))
or (XSrc <> 0)
or (YSrc <> 0)
or (SrcWidth <> Bitmap.Width)
or (SrcHeight <> Bitmap.Height);
if SubMask then
MskImage := Msk.CreateSubImage(Bounds(XMsk, YMsk, SrcWidth, SrcHeight))
else
if Msk <> nil then MskImage := Msk.CGImage
else MskImage := nil;
if SubImage then
Image := Bitmap.CreateSubImage(Bounds(XSrc, YSrc, SrcWidth, SrcHeight));
UseLayer:=Assigned(MskImage)
or (CGImageGetWidth(Image){%H-}<>SrcWidth)
or (CGImageGetHeight(Image){%H-}<>SrcHeight);
try
if not UseLayer then
begin
// Normal drawing
Result := DrawCGImage(X, Y, Width, Height, Image, GetBlendModeFromROP(Rop));
end
else
begin
// use temp layer to mask source image
// todo find a way to mask "hard" when stretching, now some soft remains are visible
LayRect := CGRectMake(0, 0, SrcWidth, SrcHeight);
Layer := CGLayerCreateWithContext(SrcDC.CGContext, LayRect.size, nil);
// the sub-image is out of edges
if (CGImageGetWidth(Image){%H-}<>SrcWidth) or (CGImageGetHeight(Image){%H-}<>SrcHeight) then
begin
with ImgRect do
if XSrc<0 then origin.x:=SrcWidth-CGImageGetWidth(Image) else origin.x:=0;
with ImgRect do
if YSrc<0 then origin.y:=0 else origin.y:=SrcHeight-CGImageGetHeight(Image);
ImgRect.size.width:=CGImageGetWidth(Image);
ImgRect.size.height:=CGImageGetHeight(Image);
end
else
ImgRect:=LayRect;
try
LayerContext := CGLayerGetContext(Layer);
CGContextScaleCTM(LayerContext, 1, -1);
CGContextTranslateCTM(LayerContext, 0, -SrcHeight);
SetCGFillping(LayerContext, Width, Height);
if Assigned(MskImage) then CGContextClipToMask(LayerContext, ImgRect, MskImage);
CGContextDrawImage(LayerContext, ImgRect, Image);
CGContextDrawLayerInRect(CGContext, DstRect, Layer);
Result := True;
finally
CGLayerRelease(Layer);
end;
end;
finally
if SubImage then CGImageRelease(Image);
if SubMask then CGImageRelease(MskImage);
end;
//DebugLn('StretchMaskBlt succeeds: ', Format('Dest %d Src %d X %d Y %d',
// [Integer(CGContext),
// Integer(Image),
// X, Y]));
end;
procedure TCarbonDeviceContext.ClearClipping;
var
Trans: CGAffineTransform;
begin
if isClipped then
begin
Trans := CGContextGetCTM(CGContext);
CGContextRestoreGState(CGContext);
ApplyTransform(Trans);
end;
end;
function TCarbonDeviceContext.SetClipRegion(AClipRegion: TCarbonRegion; Mode: Integer): Integer;
begin
ClearClipping;
isClipped := False;
if not Assigned(AClipRegion) then
HIShapeSetEmpty(FClipRegion.Shape)
else
begin
CGContextSaveGState(CGContext);
FClipRegion.CombineWith(AClipRegion, Mode);
FClipRegion.Apply(Self);
isClipped := true;
end;
Result := FClipRegion.GetType;
end;
function TCarbonDeviceContext.CopyClipRegion(ADstRegion: TCarbonRegion): Integer;
begin
if Assigned(ADstRegion)
then Result := ADstRegion.CombineWith(FClipRegion, RGN_COPY)
else Result := LCLType.Error;
end;
procedure GetWindowViewTranslate(const AWindowOfs, AViewOfs: TPoint; out dx, dy: Integer); inline;
begin
dx := AViewOfs.x - AWindowOfs.x;
dy := AViewOfs.y - AWindowOfs.y;
end;
function isSamePoint(const p1, p2: TPoint): Boolean;
begin
Result:=(p1.x=p2.x) and (p1.y=p2.y);
end;
procedure TCarbonDeviceContext.UpdateContextOfs(const AWindowOfs, AViewOfs: TPoint);
var
dx, dy: Integer;
begin
if isSamePoint(AWindowOfs, fWindowOfs) and isSamePoint(AViewOfs, fViewPortOfs) then Exit;
GetWindowViewTranslate(FWindowOfs, FViewPortOfs, dx{%H-}, dy{%H-});
CGContextTranslateCTM(CGContext, -dx, -dy);
FWindowOfs := AWindowOfs;
FViewPortOfs := AViewOfs;
GetWindowViewTranslate(FWindowOfs, FViewPortOfs, dx, dy);
CGContextTranslateCTM(CGContext, dx, dy);
end;
procedure TCarbonDeviceContext.SetWindowOfs(const AWindowOfs: TPoint);
begin
UpdateContextOfs(AWindowOfs, ViewPortOfs);
end;
procedure TCarbonDeviceContext.SetViewPortOfs(const AViewOfs: TPoint);
begin
UpdateContextOfs(WindowOfs, AViewOfs);
end;
function TCarbonDeviceContext.GetLogicalOffset: TPoint;
begin
GetWindowViewTranslate(WindowOfs, ViewportOfs, Result.X, Result.Y);
end;
{ TCarbonScreenContext }
{------------------------------------------------------------------------------
Method: TCarbonScreenContext.GetSize
Returns: Size of screen context
------------------------------------------------------------------------------}
function TCarbonScreenContext.GetSize: TPoint;
begin
Result.X := CGDisplayPixelsWide(CGMainDisplayID);
Result.Y := CGDisplayPixelsHigh(CGMainDisplayID);
end;
{------------------------------------------------------------------------------
Method: TCarbonScreenContext.Create
Creates new screen context
------------------------------------------------------------------------------}
constructor TCarbonScreenContext.Create;
begin
inherited Create;
Reset;
end;
{ TCarbonControlContext }
{------------------------------------------------------------------------------
Method: TCarbonControlContext.GetSize
Returns: Size of control context
------------------------------------------------------------------------------}
function TCarbonControlContext.GetSize: TPoint;
var
R: TRect;
begin
FOwner.GetClientRect(R{%H-});
Result.X := (R.Right - R.Left);
Result.Y := (R.Bottom - R.Top);
end;
{------------------------------------------------------------------------------
Method: TCarbonControlContext.Create
Params: AOwner - Context widget
Creates new control context
------------------------------------------------------------------------------}
constructor TCarbonControlContext.Create(AOwner: TCarbonWidget);
begin
inherited Create;
FOwner := AOwner;
Reset;
end;
function TCarbonControlContext.IsInClipRegion(ARect: TRect): Boolean;
begin
Result := True;
if ClipShapeRef <> nil then
Result := HIShapeIntersectsRect(ClipShapeRef, RectToCGRect(ARect));
end;
{ TCarbonBitmapContext }
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.SetBitmap
Params: AValue - New bitmap
Sets the bitmap
------------------------------------------------------------------------------}
procedure TCarbonBitmapContext.SetBitmap(const AValue: TCarbonBitmap);
begin
if AValue = nil then
begin
DebugLn('TCarbonBitmapContext.SetBitmap Error - Value is nil!');
Exit;
end;
if FBitmap <> AValue then
begin
FBitmap := AValue;
Reset;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.GetSize
Returns: Size of bitmap context
------------------------------------------------------------------------------}
function TCarbonBitmapContext.GetSize: TPoint;
begin
if FBitmap <> nil then
begin
Result.X := FBitmap.Width;
Result.Y := FBitmap.Height;
end
else
begin
Result.X := 0;
Result.Y := 0;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.Create
Creates new bitmap context
------------------------------------------------------------------------------}
constructor TCarbonBitmapContext.Create;
begin
inherited Create;
FBitmap := DefaultBitmap;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.Destroy
Frees bitmap context
------------------------------------------------------------------------------}
destructor TCarbonBitmapContext.Destroy;
begin
if CGContext <> nil then CGContextRelease(CGContext);
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.Reset
Resets the bitmap context properties to defaults (pen, brush, ...)
------------------------------------------------------------------------------}
procedure TCarbonBitmapContext.Reset;
var
Info: CGBitmapInfo;
begin
if CGContext <> nil then
begin
CGContextRelease(CGContext);
CGContext := nil;
end;
if FBitmap <> nil then
begin
{$note TODO: convert data if image format is incomatible with context}
// MWE:
// A CGContext only supports a few formats of all the available image formats.
// When a format doesn't match we should convert the image data to the closest
// format supported. In order to do so, we should create the context and not
// the bitmap, since if a conversion is needed, we need to manage our own data.
// See QA1037 (for all)
//
// supported formats might use (there are more)
// Gray 8 kCGImageAlphaNone WWWWWWWW
// RGB 5 kCGImageAlphaNoneSkipFirst -RRRRRGGGGGBBBBB
// RGB 8 kCGImageAlphaNoneSkipFirst --------RRRRRRRRRGGGGGGGGBBBBBBBB
// RGB 8 kCGImageAlphaNoneSkipLast RRRRRRRRRGGGGGGGGBBBBBBBB--------
// RGB 8 kCGImageAlphaPremultipliedFirst AAAAAAAARRRRRRRRRGGGGGGGGBBBBBBBB
// RGB 8 kCGImageAlphaPremultipliedLast RRRRRRRRRGGGGGGGGBBBBBBBBAAAAAAAA
// create CGBitmapContext
Info := FBitmap.Info;
// convert kCGImageAlphaFirst -> kCGImageAlphaPremultipliedFirst
if (Info and kCGImageAlphaFirst > 0) then
Info := (Info and (not kCGImageAlphaFirst)) or kCGImageAlphaPremultipliedFirst;
CGContext := CGBitmapContextCreate(FBitmap.Data, FBitmap.Width, FBitmap.Height,
FBitmap.BitsPerComponent, FBitmap.BytesPerRow, FBitmap.ColorSpace,
Info);
if CGContext = nil then
DebugLn('Unable to create Canvas Handle for Bitmap. Format "', DbgS(Info), '" is not supported!');
// flip and offset CTM to upper left corner
CGContextTranslateCTM(CGContext, 0, FBitmap.Height);
CGContextScaleCTM(CGContext, 1, -1);
end;
inherited Reset;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.GetPixel
Params: X, Y - Coordinates of pixel
Returns: Specified pixel color
------------------------------------------------------------------------------}
function TCarbonBitmapContext.GetPixel(X, Y: Integer): TGraphicsColor;
var
S: TPoint;
R: TRect;
RawImage: TRawImage;
IntfImage: TLazIntfImage;
begin
Result := clNone;
S := GetSize;
if (X < 0) or (Y < 0) or (X > S.X - 1) or (Y > S.Y - 1) then Exit;
R := Classes.Bounds(X, Y, 1, 1);
if not RawImage_FromBitmap(RawImage, HBITMAP(Bitmap), 0, @R) then Exit;
IntfImage := TLazIntfImage.Create(RawImage, True);
try
Result := IntfImage.TColors[0, 0];
finally
IntfImage.Free;
end;
end;
{------------------------------------------------------------------------------
Method: TCarbonBitmapContext.GetBitmap
Returns: The bitmap of bitmap context
------------------------------------------------------------------------------}
function TCarbonBitmapContext.GetBitmap: TCarbonBitmap;
begin
if FBitmap = nil then Result := nil
else
begin
{$note TODO: convert data if image format is incomatible with context}
// See also comments in Reset.
// Before we update the bitmap, if needed, first the context data need to be
// converted
// update bitmap to reflect changes made via canvas
FBitmap.UpdateImage;
Result := FBitmap;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink