GLScene/Externals/Graphics32/Source/GR32.Paint.Controller.pas

unit GR32.Paint.Controller;

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1 or LGPL 2.1 with linking exception
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * Alternatively, the contents of this file may be used under the terms of the
 * Free Pascal modified version of the GNU Lesser General Public License
 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
 * of this license are applicable instead of those above.
 * Please see the file LICENSE.txt for additional information concerning this
 * license.
 *
 * The Original Code is Paint tools for Graphics32
 *
 * The Initial Developer of the Original Code is
 * Anders Melander, [email protected]
 *
 * Portions created by the Initial Developer are Copyright (C) 2008-2025
 * the Initial Developer. All Rights Reserved.
 *
 * ***** END LICENSE BLOCK ***** *)

interface

{$INCLUDE GR32.inc}

uses
  Classes,
  Controls,
  GR32,
  GR32_System,
  GR32_Image,
  GR32.Paint.Host.API,
  GR32.Paint.Tool.API,
  GR32.Paint.Controller.API;


//------------------------------------------------------------------------------
//
//      TCustomBitmap32PaintController
//
//------------------------------------------------------------------------------
// Sample paint controller base class.
//------------------------------------------------------------------------------
type
  TCustomBitmap32PaintController = class(TInterfacedObject, IBitmap32PaintController)
  strict private
    FPaintHost: IBitmap32PaintHost;
    // Cached feature capabilities
    FFeatureCursor: IBitmap32PaintFeatureCursor;
    FFeatureVectorCursor: IBitmap32PaintFeatureVectorCursor;

  strict protected
    property PaintHost: IBitmap32PaintHost read FPaintHost;

  strict private
    // Tool
    FPaintTool: IBitmap32PaintTool; // The selected tool
    FActivePaintTool: IBitmap32PaintTool; // The tool that is currently handling mouse messages. Nil if none.
    FActivePaintToolContext: IBitmap32PaintToolContext;

  strict protected
    procedure SetActivePaintTool(const Value: IBitmap32PaintTool);
    property PaintTool: IBitmap32PaintTool read FPaintTool;
    property ActivePaintTool: IBitmap32PaintTool read FActivePaintTool;
    property ActivePaintToolContext: IBitmap32PaintToolContext read FActivePaintToolContext;

  strict protected
    // Cursor
    procedure ShowToolCursor(AShow, ATransientChange: Boolean);
    procedure UpdateToolCursor;

  strict protected
    // IBitmap32PaintController
    function BeginOperation(const Context: IBitmap32PaintToolContext): boolean;
    function ContinueOperation(const Context: IBitmap32PaintToolContext): boolean;
    procedure EndOperation(Complete: boolean);

    procedure MouseDown(const Context: IBitmap32PaintToolContext; Button: TMouseButton);
    procedure MouseMove(const Context: IBitmap32PaintToolContext);
    procedure MouseUp(const Context: IBitmap32PaintToolContext; Button: TMouseButton);

    procedure MouseEnter;
    procedure MouseExit;

    function CreateToolContext: IBitmap32PaintToolContext;

    function GetPaintTool: IBitmap32PaintTool;
    procedure SetPaintTool(const Value: IBitmap32PaintTool);

    function GetActivePaintTool: IBitmap32PaintTool;
    function GetActivePaintToolContext: IBitmap32PaintToolContext;

  public
    constructor Create(const APaintHost: IBitmap32PaintHost);
    destructor Destroy; override;
  end;


//------------------------------------------------------------------------------
//
//      TBitmap32PaintController
//
//------------------------------------------------------------------------------
// An example paint controller optimized for use with TImage32 and TImgView32.
//------------------------------------------------------------------------------
type
  TBitmap32PaintController = class(TCustomBitmap32PaintController, IBitmap32PaintController)
  strict private
    FImage: TCustomImage32;

  strict private
    // Update optimization
    FUpdateTimer: TStopwatch;

  strict protected
    function GetHasCapture: boolean;
    procedure SetHasCapture(const Value: boolean);

  strict protected
    // IBitmap32PaintController
    function BeginOperation(const Context: IBitmap32PaintToolContext): boolean;
    function ContinueOperation(const Context: IBitmap32PaintToolContext): boolean;
    procedure EndOperation(Complete: boolean);
    property HasCapture: boolean read GetHasCapture write SetHasCapture;
  public
    constructor Create(AImage: TCustomImage32; const APaintHost: IBitmap32PaintHost = nil);
  end;


//------------------------------------------------------------------------------
//
//      Global settings
//
//------------------------------------------------------------------------------
var
  // Max time between repaints during MouseMove/ContinueOperation
  Bitmap32PaintControllerMaxUpdateInterval: Cardinal = 50; // mS (zero for continuous update)


//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------

implementation

uses
{$if defined(MSWINDOWS)}
  Windows,
{$ifend}
  SysUtils,
  GR32.Paint.Host;

type
  TImage32Cracker = class(TCustomImage32);

//------------------------------------------------------------------------------
//
//      TCustomBitmap32PaintController
//
//------------------------------------------------------------------------------
constructor TCustomBitmap32PaintController.Create(const APaintHost: IBitmap32PaintHost);
begin
  inherited Create;

  FPaintHost := APaintHost;

  // Cache feature capabilities so we don't have to resolve these continously
  if (not Supports(FPaintHost, IBitmap32PaintFeatureCursor, FFeatureCursor)) then
    FFeatureCursor := nil;

  if (not Supports(FPaintHost, IBitmap32PaintFeatureVectorCursor, FFeatureVectorCursor)) then
    FFeatureVectorCursor := nil;
end;

destructor TCustomBitmap32PaintController.Destroy;
begin
  SetPaintTool(nil);

  FPaintTool := nil; // In case the above failed
  FActivePaintTool := nil;
  FActivePaintToolContext := nil;

  inherited;
end;

//------------------------------------------------------------------------------

function TCustomBitmap32PaintController.CreateToolContext: IBitmap32PaintToolContext;
var
  Tool: IBitmap32PaintTool;
begin
  if (FActivePaintTool <> nil) then
    Tool := FActivePaintTool
  else
    Tool := FPaintTool;

  if (Tool <> nil) then
    Result := FPaintHost.CreateToolContext(Tool)
  else
    Result := nil;
end;

//------------------------------------------------------------------------------

function TCustomBitmap32PaintController.GetActivePaintTool: IBitmap32PaintTool;
begin
  Result := FActivePaintTool;
end;

function TCustomBitmap32PaintController.GetActivePaintToolContext: IBitmap32PaintToolContext;
begin
  Result := FActivePaintToolContext;
end;

procedure TCustomBitmap32PaintController.SetActivePaintTool(const Value: IBitmap32PaintTool);
begin
  FActivePaintToolContext := nil;
  FActivePaintTool := Value;
end;

//------------------------------------------------------------------------------

function TCustomBitmap32PaintController.GetPaintTool: IBitmap32PaintTool;
begin
  Result := FPaintTool;
end;

procedure TCustomBitmap32PaintController.SetPaintTool(const Value: IBitmap32PaintTool);
var
  Continue: boolean;
begin

  if (Value = FPaintTool) then
    exit;

  if (FActivePaintTool <> nil) then
    EndOperation(False);

  // Only activate new tool if we managed to deactivate old tool - or if there was no old tool
  if (FActivePaintTool = nil) then
  begin
    // Hide old cursor
    ShowToolCursor(False, False);

    if (FPaintTool <> nil) then
    begin
      FPaintTool.Deactivate;
      FPaintTool := nil;
    end;

    if (Value <> nil) then
    begin
      Continue := True;
      Value.Activate(Continue);

      if (Continue) then
      begin
        FPaintTool := Value;

        // Display new cursor
        UpdateToolCursor;
      end;
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure TCustomBitmap32PaintController.ShowToolCursor(AShow, ATransientChange: boolean);
begin
  if (FFeatureCursor <> nil) then
    FFeatureCursor.ShowToolCursor(AShow, ATransientChange);
end;

procedure TCustomBitmap32PaintController.UpdateToolCursor;
var
  NewCursor: TCursor;
begin
  if (FFeatureCursor = nil) then
    exit;

  // Note: Calling FPaintTool.GetCursor will automatically create
  // a complex cursor, if the tool supplies one.

  if (FPaintTool = nil) or (not FPaintTool.GetCursor(NewCursor)) then
    NewCursor := crDefault;

  FFeatureCursor.SetToolCursor(NewCursor);

  ShowToolCursor(True, False);
end;

//------------------------------------------------------------------------------

function TCustomBitmap32PaintController.BeginOperation(const Context: IBitmap32PaintToolContext): boolean;
var
  ToolState: TBitmap32PaintToolState;
  Continue: boolean;
begin
  Assert(FPaintTool <> nil);
  Continue := True;
  Result := False;

  FPaintTool.BeginTool(Continue);
  try

    if (not Continue) then
    begin
      ToolState := tsAbort;
      Exit;
    end;

    ToolState := tsContinue;
    try

      FPaintTool.BeginAction(Context, ToolState);

    except
      ToolState := tsAbort;
      FPaintTool.EndAction(Context, ToolState);
      raise;
    end;

    case ToolState of
      tsComplete:
        ;

      tsAbort:
        ;

      tsContinue:
        begin
          SetActivePaintTool(FPaintTool);
          FActivePaintToolContext := Context;
          Result := True;
        end;
    end;

  finally
    if (not Result) then
    begin
      FPaintTool.EndTool;
      SetActivePaintTool(nil);
    end;
  end;
end;

//------------------------------------------------------------------------------

function TCustomBitmap32PaintController.ContinueOperation(const Context: IBitmap32PaintToolContext): boolean;
var
  ToolState: TBitmap32PaintToolState;
begin
  if (FActivePaintTool = nil) then
    raise Exception.Create('Operation is not in progress');

  Result := False;

  ToolState := tsContinue;
  try

    try
      FActivePaintTool.ContinueAction(FActivePaintToolContext, ToolState);

      // Note: EndOperation may be called from Tool.ContinueAction so we must
      // not assume that the tool is still active when ContinueAction returns.
      if (FActivePaintTool = nil) then
        exit;

    except
      ToolState := tsAbort;
      raise;
    end;

    case ToolState of
      tsComplete:
        ;

      tsAbort:
        ;

      tsContinue:
        Result := True;
    end;

  finally
    if (not Result) and (FActivePaintTool <> nil) then
    begin
      FActivePaintTool.EndTool;
      SetActivePaintTool(nil);
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure TCustomBitmap32PaintController.EndOperation(Complete: boolean);
var
  ToolState: TBitmap32PaintToolState;
begin
  if (FActivePaintTool = nil) then
    exit; // TODO : Is this an error condition?

  if (Complete) then
    ToolState := tsComplete
  else
    ToolState := tsAbort;
  try

    try

      FActivePaintTool.EndAction(FActivePaintToolContext, ToolState);

      if (FActivePaintTool = nil) then
        exit;

    except
      ToolState := tsAbort;
      raise;
    end;

    case ToolState of
      tsComplete:
        ;

      tsAbort:
        ;
    end;

  finally
    if (ToolState <> tsContinue) and (FActivePaintTool <> nil) then
    begin
      FActivePaintTool.EndTool;
      SetActivePaintTool(nil);
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure TCustomBitmap32PaintController.MouseEnter;
begin
  // Enable vector cursor
  ShowToolCursor(True, True);
end;

procedure TCustomBitmap32PaintController.MouseExit;
begin
  // Disable vector cursor
  ShowToolCursor(False, True);
end;

//------------------------------------------------------------------------------

procedure TCustomBitmap32PaintController.MouseDown(const Context: IBitmap32PaintToolContext; Button: TMouseButton);
begin
  if (Context.PaintTool <> nil) then
    Context.PaintTool.MouseDown(Context, Button);
end;

procedure TCustomBitmap32PaintController.MouseMove(const Context: IBitmap32PaintToolContext);
begin
  if (Context.PaintTool <> nil) then
    Context.PaintTool.MouseMove(Context);

  // Update cursor layer with most recent position
  if (FFeatureVectorCursor <> nil) then
    FFeatureVectorCursor.MoveToolVectorCursor(Context.MouseParams.ViewPortPos);
end;

procedure TCustomBitmap32PaintController.MouseUp(const Context: IBitmap32PaintToolContext; Button: TMouseButton);
begin
  if (Context.PaintTool <> nil) then
    Context.PaintTool.MouseUp(Context, Button);
end;


//------------------------------------------------------------------------------
//
//      TBitmap32PaintController
//
//------------------------------------------------------------------------------
constructor TBitmap32PaintController.Create(AImage: TCustomImage32; const APaintHost: IBitmap32PaintHost);
var
  PaintHost: IBitmap32PaintHost;
begin
  if (APaintHost = nil) then
    // Embed
    PaintHost := TBitmap32PaintHost.Create(AImage)
  else
    // Inject
    PaintHost := APaintHost;

  inherited Create(PaintHost);

  FImage := AImage;
end;

//------------------------------------------------------------------------------

function TBitmap32PaintController.BeginOperation(const Context: IBitmap32PaintToolContext): boolean;
begin
  Result := inherited;

  if (Result) then
  begin
    // Reacquire capture in case tool did something stupid that caused us to lose it (e.g. Move Select tool)
    if (not (betfMouseCapture in PaintTool.ToolFeatures)) and (not HasCapture) then
      HasCapture := True;
  end;
end;

//------------------------------------------------------------------------------

function TBitmap32PaintController.ContinueOperation(const Context: IBitmap32PaintToolContext): boolean;
begin
  Result := inherited;

  if (Result) then
  begin
    // Reacquire capture in case tool did something stupid that caused us to lose it (e.g. Move Select tool)
    if (not (betfMouseCapture in PaintTool.ToolFeatures)) and (not HasCapture) then
      HasCapture := True;
  end;

  // Repaint ASAP to avoid lag caused by continous mouse messages during the operation.
  // The WM_PAINT messages are only generated once the message queue is otherwise empty or
  // UpdateWindow is called.
  if (not TImage32Cracker(FImage).CacheValid) or (not TImage32Cracker(FImage).BufferValid) then
  begin
    // Buffer has been invalidated. Limit how long we wait for an update.

    if (Bitmap32PaintControllerMaxUpdateInterval = 0) then
      // No wait; Update immediately
      FImage.Update
    else
    if (FUpdateTimer.IsRunning) then
    begin
      // Already waiting; Have we waited long enough?
      if (FUpdateTimer.ElapsedMilliseconds > Bitmap32PaintControllerMaxUpdateInterval) then
      begin
        FImage.Update;
        FUpdateTimer.Stop;
      end;
    end else
      // Not already waiting; Start timer
      FUpdateTimer := TStopwatch.StartNew;
  end else
    // Nothing to update; Don't wait.
    FUpdateTimer.Stop;
end;

//------------------------------------------------------------------------------

procedure TBitmap32PaintController.EndOperation(Complete: boolean);
begin
  inherited;

  // Ensure mouse capture is released (this takes care of right-button which TImage32 doesn't handle properly)
  // TODO : I'm not sure that this is necessary anymore but there's no harm in it
  if (ActivePaintTool = nil) and (HasCapture) then
    HasCapture := False;
end;

//------------------------------------------------------------------------------

function TBitmap32PaintController.GetHasCapture: boolean;
begin
{$if defined(MSWINDOWS)}
  Result := (GetCapture = FImage.Handle);
{$else}
  Result := (GetCaptureControl = FImage);
{$ifend}
end;

procedure TBitmap32PaintController.SetHasCapture(const Value: boolean);
begin
{$if defined(MSWINDOWS)}
  if (Value) then
    SetCapture(FImage.Handle)
  else
    ReleaseCapture;
{$else}
  if (Value) then
    SetCaptureControl(FImage)
  else
    SetCaptureControl(nil);
{$ifend}
end;

//------------------------------------------------------------------------------

end.