castle-game-engine-src 4.1.1-1 / usr / src / castle-game-engine-4.1.1 / window / castlewindow_lcl.inc

{
  Copyright 2013 Michalis Kamburelis.

  This file is part of "Castle Game Engine".

  "Castle Game Engine" is free software; see the file COPYING.txt,
  included in this distribution, for details about the copyright.

  "Castle Game Engine" is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

  ----------------------------------------------------------------------------
}

(*CastleWindow backend using Lazarus LCL underneath.
  Should work with all LCL widgetsets, but was especially done and tested
  to use LCL Carbon widgetset under Mac OS X (since for other OSes
  we already have more native CastleWindow backends).

  TODO:
  - Mouse look still stutters awfully on both Carbon and GTK2.
    AggressiveUpdate helps (without it, mouse look would not work at all)
    but doesn't completely fix the problem. Other CastleWindow backends
    have smooth mouse look.

  Bugs on GTK2, not on Carbon:
  - All radio menu items are always on. Why?

  Bugs on Carbon, untested elsewhere:
  - When you switch FullScreen, at application exit there is an access violation
    in LCL. Seems harmless, so we just ignore it for now.
*)

{$ifdef read_interface_uses}
Interfaces, Forms, Dialogs, OpenGLContext, Menus,
Controls, FileUtil, Graphics, LCLType, CastleLCLUtils, Clipbrd, CustomTimer, LCLVersion,
{$endif}

{$ifdef read_window_interface}
private
  type
    { Descendant of LCL TMenuItem used for our menu. }
    TGoodMenuItem = class(Menus.TMenuItem)
    public
      Window: TCastleWindowBase;
      Entry: TMenuEntry;

      { Capture IntfDoSelect, which is fired on GTK2
        event 'select' on menu item, which we have to capture to call
        ReleaseAllKeysAndMouse.

        Just like in our gtk/castlewindow_gtk_menu.inc: capturing 'select' GTK2
        event is the only way to capture when user opened menu bar.
        And we need to capture it, to work with GTK2 and menu bar,
        e.g. when you use Alt+F to reach "File" menu, do not keep "Alt" key in
        the pressed state indefinitely (e.g. it would make camera keys non-working
        after opening a file using Alt+F and recent files in view3dscene).

        This should be also harmless on other non-GTK2 widgetsets. }
      procedure IntfDoSelect; override;
    end;

    { Like TOpenGLControl but tracks Invalidated state. }
    TGoodOpenGLControl = class(TOpenGLControl)
    public
      Invalidated: boolean;
      procedure Invalidate; override;
      procedure Paint; override;
    end;

  var
    Form: TForm;
    OpenGLControl: TGoodOpenGLControl;
    Menu: TMainMenu;

  procedure MenuCastleToLCL(const MyMenu: TMenu; const AMenu: Menus.TMenuItem);
  function MenuEntryCastleToLCL(const MyEntry: TMenuEntry): TGoodMenuItem;

  procedure MenuItemClick(Sender: TObject);
  procedure MenuUpdateShortcut(Entry: TMenuItem);
  procedure AggressiveUpdate;
  procedure UpdateFullScreen;

  procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  procedure FormDeactivate(Sender: TObject);
  procedure FormDropFiles(Sender: TObject; const FileNames: array of string);

  procedure OpenGLControlPaint(Sender: TObject);
  procedure OpenGLControlResize(Sender: TObject);
  procedure OpenGLControlKeyDown(Sender: TObject; var Key: Word;
    Shift: TShiftState);
  procedure OpenGLControlKeyUp(Sender: TObject; var Key: Word;
    Shift: TShiftState);
  procedure OpenGLControlMouseDown(Sender: TObject; Button: Controls.TMouseButton;
    Shift: TShiftState; X, Y: Integer);
  procedure OpenGLControlMouseUp(Sender: TObject; Button: Controls.TMouseButton;
    Shift: TShiftState; X, Y: Integer);
  procedure OpenGLControlMouseMove(Sender: TObject; Shift: TShiftState; X,
    Y: Integer);
  procedure OpenGLControlMouseWheel(Sender: TObject; Shift: TShiftState;
    WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
{$endif read_window_interface}

{$ifdef read_application_interface}
private
  LastDoTimerTime: TMilisecTime;
  {$ifdef LCLCarbon}
  FTimer: TCustomTimer;
  procedure ApplicationTimer(Sender: TObject);
  {$endif LCLCarbon}
  procedure ApplicationIdle(Sender: TObject; var Done: Boolean);
{$endif read_application_interface}

{$ifdef read_implementation}

const
  MaxDesiredFPS = DefaultLimitFPS;

{ TGoodMenuItem ---------------------------------------------------------------- }

procedure TCastleWindowBase.TGoodMenuItem.IntfDoSelect;
begin
  inherited;
  Window.ReleaseAllKeysAndMouse;
end;

{ TGoodOpenGLControl --------------------------------------------------------- }

procedure TCastleWindowBase.TGoodOpenGLControl.Invalidate;
begin
  Invalidated := true;
  inherited;
end;

procedure TCastleWindowBase.TGoodOpenGLControl.Paint;
begin
  { We need to set Invalidated := false before OnPaint
    (that calls TCastleWindow.OnDraw), because TCastleWindow guarantees
    that calling TCastleWindow.PostRedisplay within OnDraw will cause following
    redraw. }
  Invalidated := false;
  inherited;
end;

{ TCastleWindowBase ------------------------------------------------------------------ }

procedure TCastleWindowBase.CreateBackend;
begin
end;

function TCastleWindowBase.MenuEntryCastleToLCL(const MyEntry: TMenuEntry): TGoodMenuItem;
begin
  Result := TGoodMenuItem.Create(Form);
  Result.Window := Self;
  Result.OnClick := @MenuItemClick;
  { store connection both ways between LCL menu item <-> our menu entry }
  Result.Entry := MyEntry;
  MyEntry.Handle := Result;
  if MyEntry is TMenuItem then
    MenuUpdateShortcut(TMenuItem(MyEntry));
  if MyEntry is TMenuEntryWithCaption then
  begin
    { set MenuItem.Caption and Enabled }
    MenuUpdateCaption(TMenuEntryWithCaption(MyEntry));
    MenuUpdateEnabled(TMenuEntryWithCaption(MyEntry));
    if MyEntry is TMenuItemChecked then
    begin
      Result.ShowAlwaysCheckable := true;
      Result.RadioItem := MyEntry is TMenuItemRadio;
      MenuUpdateChecked(TMenuItemChecked(MyEntry));
    end;
  end else
  if MyEntry is TMenuSeparator then
    { set Result.Caption - special for separator }
    Result.Caption := '-';
  { if we have submenu, do this recursively }
  if MyEntry is TMenu then
    MenuCastleToLCL(TMenu(MyEntry), Result);
end;

procedure TCastleWindowBase.MenuCastleToLCL(const MyMenu: TMenu;
  const AMenu: Menus.TMenuItem);
var
  I: Integer;
begin
  for I := 0 to MyMenu.Count - 1 do
    AMenu.Add(MenuEntryCastleToLCL(MyMenu[I]));
end;

procedure TCastleWindowBase.BackendMenuInitialize;
begin
  Menu := TMainMenu.Create(Form);
  { connet Menu with Form }
  Menu.Parent := Form;
  Form.Menu := Menu;
  MenuCastleToLCL(MainMenu, Menu.Items);
end;

procedure TCastleWindowBase.BackendMenuFinalize;
begin
  FreeAndNil(Menu);
  MainMenu.ClearHandles;
end;

function CheckMenu(const Entry: TMenuEntry; out EntryLCL: Menus.TMenuItem): boolean;
begin
  EntryLCL := Menus.TMenuItem(Entry.Handle);
  Result := EntryLCL <> nil;
  if (not Result) and Log then
    WritelnLog('Menu', 'Warning: menu entry has Handle = nil (this means that corresponding LCL menu item object was not created, but it should)');
end;

procedure TCastleWindowBase.MenuUpdateShortcut(Entry: TMenuItem);
var
  LazKey: Word;
  Shift: TShiftState;
  EntryLCL: Menus.TMenuItem;
begin
  if not CheckMenu(Entry, EntryLCL) then Exit;

  {$ifdef LCLCarbon}
  { Workaround yet another bug in LCL Carbon.
    When a menu item is disabled (because Entry.Enabled is false or
    MainMenu.Enabled is false), it turns out we have to disable it's shortcut.
    Otherwise pressing this shortcut can be captured and cause strange behavior
    later.

    view3dscene bugs (when this workaround not present) on Mac OS X:
    - Enter "Open Link" with Command+L. Press Command+O (that leads to disabled
      menu item, and doesn't do anything!). Nothing happens, dummy letter with
      Ord(CtrlO) is inserted, that's Ok. Then press Escape. And the dialog appears
      again... Somehow, the Command+O (pressed when it was disabled!) was captured,
      with delay, and caused weird double menu item activation.
    - Similarly, after Command+R, press Command+O before escaping.
      It causes the raytracing dialog to appear again after escaping.
  }
  if not EntryLCL.Enabled then
  begin
    EntryLCL.ShortCut := 0;
    Exit;
  end;
  {$endif}

  KeyCastleToLCL(Entry.Key, Entry.CharKey, Entry.Modifiers, LazKey, Shift);
  EntryLCL.ShortCut := KeyToShortCut(LazKey, Shift);
end;

procedure TCastleWindowBase.MenuUpdateCaption(Entry: TMenuEntryWithCaption);

  function MenuCaptionCastleToLCL(const S: string): string;
  begin
    { We use _ for the same purpose as LCL uses &, to mark mnemonics.
      But we cannot just replace _ with &:
      Double underscore should be converted to single underscore.
      Only unpaired single underscore should be converted to &.
      Our SReplacePatterns guarantees correct behavior. }
    Result := SReplacePatterns(S, ['__', '_'], ['_', '&'], [soMatchCase]);
  end;

var
  EntryLCL: Menus.TMenuItem;
begin
  if not CheckMenu(Entry, EntryLCL) then Exit;
  EntryLCL.Caption := MenuCaptionCastleToLCL(Entry.Caption);
end;

procedure TCastleWindowBase.MenuUpdateEnabled(Entry: TMenuEntryWithCaption);

  procedure RefreshEnabled(MyMenu: TMenu);

    procedure RefreshEnabledEntry(const MyEntry: TMenuEntry);
    begin
      if MyEntry is TMenuEntryWithCaption then
        MenuUpdateEnabled(TMenuEntryWithCaption(MyEntry));
      if MyEntry is TMenu then
        RefreshEnabled(TMenu(MyEntry));
    end;

  var
    I: Integer;
  begin
    for I := 0 to MyMenu.Count - 1 do
      RefreshEnabledEntry(MyMenu[I]);
  end;

var
  EntryLCL: Menus.TMenuItem;
begin
  { To apply MainMenu.Enabled: we would prefer to map MainMenu.Enabled
    on LCL Menu.Items.Enabled, and just handle MainMenu.Enabled like
    every other menu item. But LCL (at least GTK2 and Carbon) seems to
    completely ignore Menu.Items.Enabled.

    So to do make it work, we
    1. Always combine MainMenu.Enabled with particular item's Enabled value
       (in particular, this way BackendMenuInitialize applies it to every item).
    2. At MenuUpdateEnabled for MainMenu (so when you change MainMenu.Enabled
       value) we do a refresh (update enabled state) of all the menu items.

    Note that we cannot just do MenuFinalize + MenuInitialize to implement
    the 2nd step, because Mac OS X (Carbon) reacts very badly to menu rebuilds.
    There is a problem when you have a menu item with key shortcut,
    and when this menu item is executed --- we destroy and create new menu
    that also reacts to this shortcut. In this case, Carbon executes
    the menu item again! Consider e.g. view3dscene "File->Open" with
    Ctrl+O shortcut, that after opening a new file rebuilds the menu
    to update the "recent files" menu section. Consider also "Display->Raytrace"
    with Ctrl+R shortcut, that after choosing options changes
    the MainMenu.Enabled. If we would do a MenuFinalize + MenuInitialize
    to easiy recreate LCL menu, we would see open dialog twice after Ctrl+O,
    and raytrace dialog twice after Ctrl+R. So we don't do it.
    In MenuInsert and MenuDelete and in this method, MenuUpdateEnabled,
    we merely change the existing LCL menu instances.

    This all could be considered Carbon's bug, anyway we have to work with it.
  }

  if Entry = MainMenu then
  begin
    RefreshEnabled(MainMenu);
    Exit;
  end;

  if not CheckMenu(Entry, EntryLCL) then Exit;
  EntryLCL.Enabled := Entry.Enabled and MainMenu.Enabled;

  {$ifdef LCLCarbon}
  if Entry is TMenuItem then
    MenuUpdateShortcut(TMenuItem(Entry));
  {$endif}
end;

procedure TCastleWindowBase.MenuUpdateChecked(Entry: TMenuItemChecked);
var
  EntryLCL: Menus.TMenuItem;
begin
  if not CheckMenu(Entry, EntryLCL) then Exit;
  EntryLCL.Checked := Entry.Checked;
end;

function TCastleWindowBase.MenuUpdateCheckedFast: boolean;
begin
  Result := true;
end;

procedure TCastleWindowBase.MenuInsert(const Parent: TMenu;
  const ParentPosition: Integer; const Entry: TMenuEntry);
var
  ParentLCL: Menus.TMenuItem;
begin
  if not CheckMenu(Parent, ParentLCL) then Exit;
  ParentLCL.Insert(ParentPosition, MenuEntryCastleToLCL(Entry));
end;

procedure TCastleWindowBase.MenuDelete(const Parent: TMenu;
  const ParentPosition: Integer; const Entry: TMenuEntry);
var
  EntryLCL: Menus.TMenuItem;
begin
  if not CheckMenu(Entry, EntryLCL) then Exit;
  Entry.ClearHandles;

  {$ifdef LCLCarbon}
    (*Workaround LCL on Carbon bug http://bugs.freepascal.org/view.php?id=20688 .

      Symptoms:
      Sometimes after menu changes we have a segfault in Carbon widgetset,
      like our menu item reference was invalid.
      Happens after various menu changes: rebuilding the menu, also fast changes
      like MenuDelete (like when changing recent files submenu in view3dscene).
      It seems that Carbon doesn't like deleting a menu currently used.

      Happens both when debugging and not debugging.
      Using the file menu to choose a recent file to load from view3dscene
      is the most common case.

      In Lazarus debuggger:
        Project view3dscene.app raised exception class 'External: EXC_BAD_ACCESS'.
        In file './carbon/carbonlclintf.inc' at line 342:
        end; {TCarbonWidgetSet.PromptUser}

      When running from console:
        TApplication.HandleException Access violation
          Stack trace:
          $0039566B  CARBONAPP_COMMANDPROCESS,  line 2872 of /Users/michalis/sources/lazarus/trunk/lcl/interfaces/./carbon/carbonint.pas

      Most probably this is the same thing as reported on
      http://bugs.freepascal.org/view.php?id=20688  .
      Less likely, to http://bugs.freepascal.org/view.php?id=18908 ?

      Workaround for now is just to not remove LCL menu items, only hide them.
      This at least fixes the issue when we delete menu by MenuDelete
      (as opposed to menu rebuild).
    *)
    EntryLCL.Visible := false;
  {$else}
    FreeAndNil(EntryLCL);
  {$endif}
end;

procedure TCastleWindowBase.SwapBuffers;
begin
  OpenGLControl.SwapBuffers;
end;

procedure TCastleWindowBase.OpenBackend;
begin
  { We use Forms.Application.CreateForm, not just "Form := TForm.CreateNew(nil)",
    because we want our Form to be set as Forms.Application.MainForm.

    And there is no other way to set Forms.Application.MainForm,
    we have to use mechanism that "the first form created by Application.CreateForm
    is set as main", see http://www.lazarus.freepascal.org/index.php?topic=14438.0
    and LCL sources of TApplication.UpdateMainForm.
    The "Forms.Application.MainForm" property is not directly settable.

    And we need to have a main form, as that's the only way to capture (in form
    close event) the Mac OS X "ProjectName -> Quit" automatic menu item (see
    http://bugs.freepascal.org/view.php?id=10983).

    Note: This would be a problem if we used TForm descendant,
    as then Forms.Application.CreateForm would search for a related resource.
    Unless we set RequireDerivedFormResource to false (which actually
    is the default RequireDerivedFormResource value for now, but the adviced
    value is true).
    Fortunately, the whole resource-searching is not used when we just
    have a TForm class (see TCustomForm.Create in LCL), so that's not a problem. }

  Forms.Application.CreateForm(TForm, Form);
  Form.OnDropFiles := @FormDropFiles;

  Form.Top := Top;
  Form.Left := Left;
  { We would prefer to leave Form.AutoSize := true and allow form to adjust
    to OpenGLControl.Width/Height. But it doesn't work. }
  Form.Width := Width;
  Form.Height := Height;
  Form.Caption := GetWholeCaption; // SetCaption may also change it later
  Form.Cursor := CursorCastleToLCL[Cursor]; // SetCursor may also change it later

  UpdateFullScreen;

  Form.OnCloseQuery := @FormCloseQuery;
  { Note: I tried also using OpenGLControl.OnExit for this, seems to be quivalent
    in our case. And, similarly, both methods still need manual workaround
    to call ReleaseAllKeysAndMouse manually in MessageOK and similar methods
    (otherwise: check e.g. window_events with Window.MessageOk from Update:
    entering MessageOK *must* make ReleaseAllKeysAndMouse, otherwise it hangs.) }
  Form.OnDeactivate := @FormDeactivate;

  OpenGLControl := TGoodOpenGLControl.Create(Form);
  OpenGLControl.Parent := Form;
  OpenGLControl.Align := alClient;
  OpenGLControl.Width := Width;
  OpenGLControl.Height := Height;
  OpenGLControl.Constraints.MinWidth := MinWidth;
  OpenGLControl.Constraints.MinHeight := MinHeight;
  OpenGLControl.Constraints.MaxWidth := MaxWidth;
  OpenGLControl.Constraints.MaxHeight := MaxHeight;
  OpenGLControl.TabStop := true;

  OpenGLControl.DoubleBuffered := DoubleBuffer;
  {$if (LCL_FullVersion > 1001000)}
  OpenGLControl.StencilBits := StencilBits;
  OpenGLControl.DepthBits := DepthBits;
  OpenGLControl.AlphaBits := AlphaBits;
  OpenGLControl.MultiSampling := MultiSampling;
  {$else}
  {$warning Using LCL (Lazarus library) version before 1.1. OpenGL control doesn't have features to control stencil/alpha/multi-sampling etc.}
  {$endif}

  Form.ActiveControl := OpenGLControl;

  if MainMenu <> nil then MenuInitialize;

  Form.Visible := Visible;

  { pass the actual OpenGLControl sizes (e.g. after accounting for MainMenu size
    under GTK2 widgetset, actually under all widgetsets that do not have global
    menu (like Mac OS X), and after accounting for FullScreen).
    DoResize is already implemented to handle such
    call (from OpenBackend, before EventOpen was called) correctly. }
  DoResize(OpenGLControl.Width, OpenGLControl.Height, false);

  { Assign OpenGLControl.OnPaint *after* making Form visible.
    If we would assign OpenGLControl.OnPaint earlier, then
    Form.Visible := true would cause OpenGLControlPaint *before*
    OpenGL context was created. }
  OpenGLControl.OnPaint := @OpenGLControlPaint;
  OpenGLControl.OnResize := @OpenGLControlResize;
  OpenGLControl.OnKeyDown := @OpenGLControlKeyDown;
  OpenGLControl.OnKeyUp := @OpenGLControlKeyUp;
  OpenGLControl.OnMouseDown := @OpenGLControlMouseDown;
  OpenGLControl.OnMouseUp := @OpenGLControlMouseUp;
  OpenGLControl.OnMouseMove := @OpenGLControlMouseMove;
  OpenGLControl.OnMouseWheel := @OpenGLControlMouseWheel;

  { Make sure we have OpenGL context created now, and send initial Invalidate
    (it may not happen automatically, testcase: glViewImage on Carbon).
    TCastleWindowBase.OpenCore will call MakeCurrent next. }
  OpenGLControl.HandleNeeded;
  OpenGLControl.Invalidate;

  Application.OpenWindowsAdd(Self);
end;

procedure TCastleWindowBase.UpdateFullScreen;
begin
  if FullScreen then
  begin
    Form.BorderStyle := bsNone;
    Form.WindowState := wsFullScreen;
  end else
  begin
    if ResizeAllowed <> raAllowed then
      Form.BorderStyle := bsSingle else
      Form.BorderStyle := bsSizeable;
    Form.WindowState := wsNormal;
  end;
end;

procedure TCastleWindowBase.SetFullScreen(const Value: boolean);
begin
  if FFullScreen <> Value then
  begin
    FFullScreen := Value;
    if not Closed then
      UpdateFullScreen;
  end;
end;

procedure TCastleWindowBase.CloseBackend;
begin
  FreeAndNil(Form);
  { freeing the Form will automatically free other owned components }
  OpenGLControl := nil;
  Menu := nil;

  { although Menu was already freed, but make sure we also change state,
    like TCastleWindowBase.MenuInitialized and clear TMenuItem.Handle. }
  MenuFinalize;
end;

procedure TCastleWindowBase.PostRedisplay;
begin
  if not Closed then OpenGLControl.Invalidate;
end;

procedure TCastleWindowBase.SetCaption(const Part: TCaptionPart; const Value: string);
begin
  FCaption[Part] := Value;
  if not Closed then Form.Caption := GetWholeCaption;
end;

procedure TCastleWindowBase.BackendMakeCurrent;
begin
  OpenGLControl.MakeCurrent;
end;

procedure TCastleWindowBase.FlushRedisplay;
begin
  if OpenGLControl.Invalidated then DoDraw;
end;

procedure TCastleWindowBase.SetCursor(const Value: TMouseCursor);
begin
  if FCursor <> Value then
  begin
    FCursor := Value;
    if not Closed then
      { Do not use Form.Cursor for this, e.g. hiding the cursor would not work
        then on Carbon. }
      OpenGLControl.Cursor := CursorCastleToLCL[Value];
  end;
end;

procedure TCastleWindowBase.SetCustomCursor(const Value: TRGBAlphaImage);
begin
  { TODO }
  FCustomCursor := Value;
end;

function TCastleWindowBase.RedirectKeyDownToMenuClick: boolean;
begin
  Result := false;
end;

procedure TCastleWindowBase.SetMousePosition(const NewMouseX, NewMouseY: Integer);
begin
  if not Closed then
    Mouse.CursorPos := OpenGLControl.ControlToScreen(Point(NewMouseX, NewMouseY))
end;

procedure TCastleWindowBase.MenuItemClick(Sender: TObject);
var
  Entry: TMenuEntry;
begin
  Entry := (Sender as TGoodMenuItem).Entry;
  if Entry is TMenuItem then
  begin
    { It seems that checked menu item is always automatically swapped,
      at least with LCL-GTK2. So manually revert it to original setting,
      as we don't want this (DoMenuClick will change Checked as necessary). }
    if Entry is TMenuItemChecked then
      MenuUpdateChecked(TMenuItemChecked(Entry));
    DoMenuClick(TMenuItem(Entry));
  end;
end;

procedure TCastleWindowBase.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  DoCloseQuery;
  CanClose := false; // DoCloseQuery will call Close when needed
end;

procedure TCastleWindowBase.FormDeactivate(Sender: TObject);
begin
  ReleaseAllKeysAndMouse;
end;

procedure TCastleWindowBase.OpenGLControlPaint(Sender: TObject);
begin
  DoDraw;
end;

procedure TCastleWindowBase.OpenGLControlResize(Sender: TObject);
begin
  DoResize(OpenGLControl.Width, OpenGLControl.Height, false);
end;

procedure TCastleWindowBase.OpenGLControlKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
var
  MyKey: TKey;
  MyCharKey: char;
begin
  KeyLCLToCastle(Key, Shift, MyKey, MyCharKey);
  if (MyKey <> K_None) or (MyCharKey <> #0) then
    DoKeyDown(MyKey, MyCharKey);
end;

procedure TCastleWindowBase.OpenGLControlKeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  MyKey: TKey;
  MyCharKey: char;
begin
  KeyLCLToCastle(Key, Shift, MyKey, MyCharKey);
  if MyKey <> K_None then
    DoKeyUp(MyKey);
end;

procedure TCastleWindowBase.OpenGLControlMouseDown(Sender: TObject;
  Button: Controls.TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  MyButton: CastleKeysMouse.TMouseButton;
begin
  if MouseButtonLCLToCastle(Button, MyButton) then
    DoMouseDown(X, Y, MyButton);
end;

procedure TCastleWindowBase.OpenGLControlMouseUp(Sender: TObject;
  Button: Controls.TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  MyButton: CastleKeysMouse.TMouseButton;
begin
  if MouseButtonLCLToCastle(Button, MyButton) then
    DoMouseUp(X, Y, MyButton);
end;

{ Since LCL event loop may become clogged when dragging with mouse
  (like when using mouse look), force doing update and (if needed) redraw
  from time to time.
  See TCastleControl implementation for analogous AggressiveUpdate
  procedure with detailed discussion about why this is needed. }
procedure TCastleWindowBase.AggressiveUpdate;
var
  DesiredFPS: Single;
begin
  if Application.LimitFPS <= 0 then
    DesiredFPS := MaxDesiredFPS else
    DesiredFPS := Min(MaxDesiredFPS, Application.LimitFPS);
  if Timer - Fps.UpdateStartTime > TimerFrequency / DesiredFPS then
  begin
    DoUpdate;

    { TODO:
      - TCastleApplication.OnIdle is not taken care of here.
        This takes care of calling OnUpdate for this window.
        Other windows (in case you have multiple TCastleWindow instances)
        will take care of themselves too, they all have separate Fps counter.
        But TCastleApplication.OnIdle is left not called.
      - OnTimer (both from Application and TCastleWindow)
        is not taken care of here.
    }

    FlushRedisplay;
  end;
end;

procedure TCastleWindowBase.OpenGLControlMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  DoMouseMove(X, Y);
  AggressiveUpdate;
end;

procedure TCastleWindowBase.OpenGLControlMouseWheel(Sender: TObject;
  Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
  var Handled: Boolean);
begin
  DoMouseWheel(WheelDelta/120, true);
end;

{ TCastleWindowBase dialogs ---------------------------------------------------------- }

function TCastleWindowBase.BackendFileDialog(const Title: string; var FileName: string;
  OpenDialog: boolean; FileFilters: TFileFilterList): boolean;
var
  Dialog: TFileDialog;
  ExpandedFileName: string;
begin
  if OpenDialog then
    Dialog := TOpenDialog.Create(nil) else
    Dialog := TSaveDialog.Create(nil);
  try
    Dialog.Title := Title;
    if FileName = '' then
      Dialog.InitialDir := SysToUTF8(GetCurrentDir) else
    begin
      ExpandedFileName := ExpandFileName(FileName);
      Dialog.InitialDir := SysToUTF8(ExtractFilePath(ExpandedFileName));
      Dialog.FileName := SysToUTF8(ExtractFileName(ExpandedFileName));
    end;
    FileFiltersToDialog(FileFilters, Dialog);
    ReleaseAllKeysAndMouse; // do it manually
    Result := Dialog.Execute;
    if Result then
      FileName := UTF8ToSys(Dialog.FileName);
  finally FreeAndNil(Dialog) end;
end;

function TCastleWindowBase.ColorDialog(var Color: TVector3Single): boolean;
var
  Dialog: TColorDialog;
  ColorByte: TVector3Byte;
begin
  Dialog := TColorDialog.Create(nil);
  try
    ColorByte := Vector3Byte(Color);
    Dialog.Color := RGBToColor(ColorByte[0], ColorByte[1], ColorByte[2]);
    ReleaseAllKeysAndMouse; // do it manually
    Result := Dialog.Execute;
    if Result then
    begin
      RedGreenBlue(Dialog.Color, ColorByte[0], ColorByte[1], ColorByte[2]);
      Color := Vector3Single(ColorByte);
    end;
  finally FreeAndNil(Dialog) end;
end;

procedure TCastleWindowBase.MessageOK(const S: string; const MessageType: TWindowMessageType);
const
  MessageTypeCastleToLCL: array [TWindowMessageType] of TMsgDlgType =
  (Dialogs.mtInformation, Dialogs.mtWarning, Dialogs.mtConfirmation, Dialogs.mtError, Dialogs.mtCustom);
begin
  ReleaseAllKeysAndMouse; // do it manually
  MessageDlg(S, MessageTypeCastleToLCL[MessageType], [mbOK], 0);
end;

function TCastleWindowBase.MessageYesNo(const S: string;
  const MessageType: TWindowMessageType): boolean;
begin
  ReleaseAllKeysAndMouse; // do it manually
  Result := MessageDlg(S, mtConfirmation, mbYesNo, 0) = mrYes;
end;

procedure TCastleWindowBase.FormDropFiles(Sender: TObject; const FileNames: array of string);
begin
  DoDropFiles(FileNames);
end;

{ TCastleApplication ---------------------------------------------------------- }

procedure TCastleApplication.CreateBackend;
begin
  { Do not install LCL handler for ExceptProc, we want to use our own handler
    in CastleUtils. }
  Forms.Application.CaptureExceptions := false;

  Forms.Application.Initialize;
  Forms.Application.AddOnIdleHandler(@ApplicationIdle);

  {$ifdef LCLCarbon}
  FTimer := TCustomTimer.Create(Self);
  FTimer.Interval := Round(1000 / MaxDesiredFPS);
  FTimer.OnTimer := @ApplicationTimer;
  FTimer.Enabled := true;
  {$endif LCLCarbon}
end;

procedure TCastleApplication.DestroyBackend;
begin
  Forms.Application.RemoveOnIdleHandler(@ApplicationIdle);
  {$ifdef LCLCarbon}
  FreeAndNil(FTimer);
  {$endif LCLCarbon}
end;

{$ifdef LCLCarbon}
{ Only for LCL Carbon: Using LCL timer (that is translated to Carbon timer)
  is the only way to receive continous messages in some cases.

  Otherwise such bugs can be observed (only on LCL-Carbon, not on LCL-GTK2):

  - When trying to Walk using mouse dragging in view3dscene, it doesn't
    work smoothly: when you simply keep some mouse button pressed,
    but don't move the mouse anymore (which should result in constant
    movement forward/backward if you did it after dragging up/down),
    then we don't get any events (so no movement, no redraw...).

  - Using view3dscene Navigation->Jump to viewpoint... doesn't work
    smoothly, there is a visible delay when we don't receive messages
    right after menu click, and so transtion is visible with some delay.
}
procedure TCastleApplication.ApplicationTimer(Sender: TObject);
var
  I: Integer;
begin
  for I := 0 to OpenWindowsCount - 1 do
    OpenWindows[I].AggressiveUpdate;
end;
{$endif LCLCarbon}

procedure TCastleApplication.ApplicationIdle(Sender: TObject; var Done: Boolean);
begin
  { Call Update and timer events of Application and all windows.
    Update events are handled by DoSelfUpdate and OpenWindows.DoUpdate.
    Timer events are handled by MaybeDoTimer, that in turn will call
    (when needed) DoSelfTimer and OpenWindows.DoTimer. }
  DoSelfUpdate;
  FOpenWindows.DoUpdate;
  MaybeDoTimer(LastDoTimerTime);

  { We need Done := false, otherwise the widgetset will hang waiting
    for next message. See ../components/castlecontrol.pas comments.

    Done := false also prevents other application idle handlers,
    but fortunately in this case we're the only thing interfacing with LCL,
    so that's not a problem. }
  Done := false;
end;

function TCastleApplication.ProcessMessage(WaitForMessage, WaitToLimitFPS: boolean): boolean;
var
  I: Integer;
begin
  if Forms.Application.Terminated then Exit(false);

  { TODO: take WaitToLimitFPS into account }

  if WaitForMessage then
  begin
    { HandleMessage will call ApplicationIdle, so no need for AggressiveUpdate
      hack in this case. }
    Forms.Application.HandleMessage;
    Result := not Forms.Application.Terminated;
  end else
  begin
    Forms.Application.ProcessMessages;
    Result := not Forms.Application.Terminated;

    { Without this, OnUpdate will not be called when application calls
      TCastleApplication.ProcessMessage in a loop, because LCL will not make
      ApplicationIdle calls from Forms.Application.ProcessMessages.

      Bugs observed when the below workaround is not used (on both LCL-Carbon and LCL-GTK2):
      - Arrow keys up/down do not work in CastleMessages window.
        E.g. view3dscene "OpenGL info".
        That's becaue UpdateMessg is never called.
        (Although this is now fixed anyway by above HandleMessage usage.)
      - Progress is not rendered smoothly.
        E.g. in fps_game, define -dTESTING_PROGRESS_DELAY, and notice that progress
        is not smoothly updated (if you don't move the mouse, since MouseMove
        already causes AggressiveUpdate).
    }
    if Result then
    begin
      for I := 0 to OpenWindowsCount - 1 do
        OpenWindows[I].AggressiveUpdate;
    end;
  end;
end;

function TCastleApplication.ProcessAllMessages: boolean;
begin
//  Result := not Forms.Application.Terminated;
//  while Result do
    Result := ProcessMessage(true, true);
end;

procedure TCastleApplication.Run;
begin
  if OpenWindowsCount = 0 then Exit;

  { Implementing Run by calling ProcessMessage in a loop (like below)
    is a valid and good implementation. Make sure your ProcessMessage
    honours WaitForMessage and WaitToLimitFPS = true,
    to avoid wasting CPU on "busy waiting". }
  // while ProcessMessage(true, true) do ;

  { We have to call here Forms.Application.Run, not just call our
    ProcessMessage (which makes Forms.Application.ProcessMessage) in a loop.
    That is because on some LCL widgetsets, you really need to run
    Forms.Application.Run, see e.g. Carbon that does special stuff inside
    TCarbonWidgetSet.AppRun inside lcl/interfaces/carbon/carbonobject.inc.
    Without this, global menu on Carbon is always blocked.

    TODO: that's unfortunate, as our TCastleWindowBase interface
    promises that it's not necessary to call Run, it should be always
    equivalent to call just ProcessMessage in a loop.

    TODO: this makes Update/timer broken, they need our
    TCastleApplication.ProcessMessage to work. }

  Forms.Application.Run;
end;

procedure TCastleApplication.QuitWhenNoOpenWindows;
begin
  Forms.Application.Terminate; // break also Forms.Application.Run
end;

function TCastleApplication.ScreenWidth: integer;
begin
  Result := Screen.Width;
end;

function TCastleApplication.ScreenHeight: integer;
begin
  Result := Screen.Height;
end;

function TCastleApplication.BackendName: string;
begin
  Result := 'LCL';
end;

{ TCastleClipboard ----------------------------------------------------------- }

function TCastleClipboard.GetAsText: string;
begin
  Result := UTF8ToSys(Clipbrd.Clipboard.AsText);
end;

procedure TCastleClipboard.SetAsText(const Value: string);
begin
  Clipbrd.Clipboard.AsText := SysToUTF8(Value);
end;

{$endif read_implementation}