mirror of
https://git.vladimir.cc/vladimir/lazopenglcontextex.git
synced 2026-08-25 17:37:31 +00:00
LazOpenGLContextEx: TOpenGLControl с Qt-бэкендом на QOpenGLWidget
Форк штатного пакета LazOpenGLContext (Lazarus components/opengl). Qt5/Qt6-бэкенд (glqtnativecontext.pas) использует собственный контекст настоящего QOpenGLWidget вместо ручного GLX на winId(): EGL на Wayland, GLX на X11, WGL/CGL на Windows/macOS под ws=qt6. QOpenGLWidget-наследник с paintGL-хуком живёт в маленькой C++-либе csrc/qlclglwidget.cpp (QLCLOpenGLWidget из libQt6Pas — не QOpenGLWidget, а голый QWidget под внешний GLX). Сборка: csrc/Makefile (linux/macos/windows-кросс mingw-w64/windows-native MSYS2, install, install-app) + build-msvc.bat для MSVC-Qt. Либа грузится в рантайме рядом с бинарником приложения. Бэкенды gtk2/gtk3/win32/cocoa скопированы из стока без изменений (юниты переименованы с суффиксом Ex). Детали и нюансы — в README.md. Проверено: EWSDR, спектр/водопад через GL в нативном Wayland (KDE, qt6), живой эфир QO-100. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
This commit is contained in:
+11
@@ -0,0 +1,11 @@
|
|||||||
|
# Lazarus package output
|
||||||
|
lib/
|
||||||
|
backup/
|
||||||
|
*.compiled
|
||||||
|
|
||||||
|
# built helper library artifacts
|
||||||
|
*.so
|
||||||
|
*.dylib
|
||||||
|
*.dll
|
||||||
|
*.dll.a
|
||||||
|
csrc/*.obj
|
||||||
@@ -0,0 +1,110 @@
|
|||||||
|
# LazOpenGLContextEx
|
||||||
|
|
||||||
|
Форк штатного пакета `LazOpenGLContext` (Lazarus `components/opengl`), в котором
|
||||||
|
Qt5/Qt6-бэкенд построен на настоящем `QOpenGLWidget` вместо GLX.
|
||||||
|
|
||||||
|
## Зачем
|
||||||
|
|
||||||
|
Штатный `TOpenGLControl` под `--ws=qt5/qt6` работает только в X11-сессии и
|
||||||
|
вообще не собирается с Qt-виджетсетом на Windows/macOS: он руками создаёт
|
||||||
|
GLX-контекст на `winId()`. Важно: `QLCLOpenGLWidget` из libQt6Pas — это **не**
|
||||||
|
QOpenGLWidget, а голый QWidget с `WA_NativeWindow` и `paintEngine()=nullptr`,
|
||||||
|
т.е. просто мишень для внешнего GLX-рендера (вызов на нём методов
|
||||||
|
QOpenGLWidget = access violation — проверено).
|
||||||
|
|
||||||
|
Здесь контекст создаёт сам Qt через платформенный API:
|
||||||
|
|
||||||
|
| Платформа | Контекст |
|
||||||
|
|------------------|----------|
|
||||||
|
| Linux Wayland | EGL |
|
||||||
|
| Linux X11 | GLX |
|
||||||
|
| Windows (ws=qt6) | WGL |
|
||||||
|
| macOS (ws=qt6) | CGL |
|
||||||
|
|
||||||
|
Бэкенды gtk2/gtk3/win32/cocoa скопированы из штатного пакета без изменений
|
||||||
|
(юниты переименованы с суффиксом `Ex`, чтобы не конфликтовать со стоковым пакетом).
|
||||||
|
|
||||||
|
## Состав
|
||||||
|
|
||||||
|
- `openglcontextex.pas` — `TOpenGLControl` (класс называется так же, юнит `OpenGLContextEx`).
|
||||||
|
- `glqtnativecontext.pas` — Qt-бэкенд поверх QOpenGLWidget.
|
||||||
|
- `csrc/qlclglwidget.cpp` — **вспомогательная C++-библиотека** `libqlclglwidget.so`:
|
||||||
|
наследник QOpenGLWidget с paintGL-хуком в Pascal + плоские экспорты
|
||||||
|
(`makeCurrent`, `doneCurrent`, `isValid`, `setFormat`,
|
||||||
|
`defaultFramebufferObject`, `devicePixelRatioF`). Грузится в рантайме:
|
||||||
|
сначала рядом с исполняемым файлом, затем по системным путям.
|
||||||
|
|
||||||
|
## Сборка вспомогательной библиотеки (csrc/)
|
||||||
|
|
||||||
|
| Где собираем | Команда | Результат |
|
||||||
|
|---|---|---|
|
||||||
|
| Linux | `make -C csrc` | `libqlclglwidget.so` |
|
||||||
|
| macOS | `make -C csrc` (авто) или `make -C csrc macos` | `libqlclglwidget.dylib` |
|
||||||
|
| Linux → Windows (кросс) | `make -C csrc windows` | `qlclglwidget.dll` (MinGW) |
|
||||||
|
| Windows, MSYS2 MinGW64 shell | `make -C csrc` (авто) или `make -C csrc windows-native` | `qlclglwidget.dll` (MinGW) |
|
||||||
|
| Windows, Qt MinGW-kit без pkg-config | `make -C csrc windows MINGW_CXX=g++ WIN_QT_INC=C:/Qt/6.x/mingw_64/include WIN_QT_LIB=C:/Qt/6.x/mingw_64/lib` | `qlclglwidget.dll` (MinGW) |
|
||||||
|
| Windows, MSVC | `csrc\build-msvc.bat` из «x64 Native Tools Command Prompt» с выставленным `QTDIR` | `qlclglwidget.dll` (MSVC) |
|
||||||
|
|
||||||
|
Плюс:
|
||||||
|
|
||||||
|
```
|
||||||
|
make -C csrc install # установить в /usr/local/lib (PREFIX/DESTDIR поддерживаются)
|
||||||
|
make -C csrc install-app APPDIR=/путь/к/бинарнику # положить рядом с приложением
|
||||||
|
```
|
||||||
|
|
||||||
|
Для кросс-сборки нужен тулчейн mingw-w64 и **MinGW-сборка Qt6** (AUR
|
||||||
|
`mingw-w64-qt6-base`, MXE, либо Qt MinGW-kit; пути переопределяются
|
||||||
|
`MINGW_PREFIX`/`WIN_QT_INC`/`WIN_QT_LIB`). Для MSYS2:
|
||||||
|
`pacman -S mingw-w64-x86_64-gcc mingw-w64-x86_64-qt6-base pkgconf make`.
|
||||||
|
|
||||||
|
⚠ **ABI:** MinGW-DLL работает только с MinGW-сборкой Qt6 на целевой машине,
|
||||||
|
MSVC-DLL — только с MSVC-Qt (официальные бинарники Qt из online-инсталлятора —
|
||||||
|
MSVC). Выбирайте вариант под ту Qt6, с которой собрана libQt6Pas приложения.
|
||||||
|
|
||||||
|
## Использование
|
||||||
|
|
||||||
|
В проекте: зависимость `LazOpenGLContext` → `LazOpenGLContextEx`,
|
||||||
|
в uses: `OpenGLContext` → `OpenGLContextEx`.
|
||||||
|
|
||||||
|
```
|
||||||
|
make -C csrc
|
||||||
|
lazbuild --ws=qt6 lazopenglcontextex.lpk
|
||||||
|
make -C csrc install-app APPDIR=<каталог с бинарником приложения>
|
||||||
|
```
|
||||||
|
|
||||||
|
## Как устроен Qt-бэкенд
|
||||||
|
|
||||||
|
- Qt сам делает контекст текущим и биндит FBO виджета перед вызовом `paintGL()`;
|
||||||
|
оттуда доставляется `LM_PAINT`, так что весь рендер в `OnPaint` работает как раньше.
|
||||||
|
- `SwapBuffers` внутри paint — no-op (композитингом FBO занимается Qt после
|
||||||
|
возврата из `paintGL`); вне paint — планирует перерисовку (`QWidget::update`).
|
||||||
|
- `MakeCurrent`/`ReleaseContext` вне paint → `QOpenGLWidget::makeCurrent/doneCurrent`.
|
||||||
|
До первого показа виджета контекста ещё нет — `MakeCurrent` вернёт False.
|
||||||
|
- `LOpenGLViewport` (AutoResizeViewport) умножает координаты на devicePixelRatio.
|
||||||
|
|
||||||
|
## Ограничения / нюансы
|
||||||
|
|
||||||
|
- **Не вызывать `glBindFramebuffer(..., 0)`** — QOpenGLWidget рендерит в свой FBO.
|
||||||
|
- **Альфа фреймбуфера = прозрачность виджета.** Qt композитит FBO с учётом
|
||||||
|
альфы; легаси-GL-код после блендинга оставляет alpha<1, и виджет просвечивал
|
||||||
|
бы насквозь. Поэтому обёртка после каждого paintGL принудительно заливает
|
||||||
|
альфу единицей (`QLCLGLWidget_setForceOpaque`, включено по умолчанию).
|
||||||
|
Отключается автоматически, если контрол запросил `AlphaBits > 0` — тогда
|
||||||
|
альфа остаётся под контролем приложения.
|
||||||
|
- **SharedControl игнорируется**: Qt автоматически шарит контексты всех
|
||||||
|
QOpenGLWidget внутри одного top-level окна. Для шаринга между окнами нужно
|
||||||
|
выставить `Qt::AA_ShareOpenGLContexts` до создания QApplication.
|
||||||
|
- **Windows + qt6**: чтобы Qt не выбрал ANGLE/GLES (где нет immediate mode),
|
||||||
|
выставить `QT_OPENGL=desktop` или атрибут `AA_UseDesktopOpenGL`.
|
||||||
|
- **HiDPI (devicePixelRatio > 1)**: FBO больше логического размера виджета.
|
||||||
|
Явные вызовы `glViewport` в коде приложения должны умножать на dpr сами.
|
||||||
|
- AUXBuffers не поддерживаются QSurfaceFormat (игнорируются).
|
||||||
|
- Qt4 (LCLQT), gtk1 и carbon из форка выброшены.
|
||||||
|
|
||||||
|
## Статус проверки
|
||||||
|
|
||||||
|
- Linux Wayland (KDE, qt6): спектр EWSDR рендерится через GL, стартует без
|
||||||
|
ошибок, скриншот подтверждён (2026-07-03).
|
||||||
|
- Linux XWayland/xcb: стартует без ошибок.
|
||||||
|
- Windows/macOS: не проверялось (build.sh под них ещё нет — нужен аналог
|
||||||
|
с MSVC/clang и Qt-заголовками).
|
||||||
+144
@@ -0,0 +1,144 @@
|
|||||||
|
# ----------------------------------------------------------------------------
|
||||||
|
# libqlclglwidget — QOpenGLWidget helper library for LazOpenGLContextEx
|
||||||
|
#
|
||||||
|
# Build variants:
|
||||||
|
# make / make linux native Linux build -> ../libqlclglwidget.so
|
||||||
|
# make macos native macOS build (on a Mac) -> ../libqlclglwidget.dylib
|
||||||
|
# make windows qlclglwidget.dll with a MinGW toolchain:
|
||||||
|
# * cross-build from Linux (mingw-w64), OR
|
||||||
|
# * natively on Windows with a Qt MinGW kit that has
|
||||||
|
# no pkg-config — override the variables:
|
||||||
|
# make windows MINGW_CXX=g++ \
|
||||||
|
# WIN_QT_INC=C:/Qt/6.x.x/mingw_64/include \
|
||||||
|
# WIN_QT_LIB=C:/Qt/6.x.x/mingw_64/lib
|
||||||
|
# make windows-native natively on Windows in an MSYS2 MinGW64 shell
|
||||||
|
# (uses pkg-config; auto-selected by plain `make` there)
|
||||||
|
# build-msvc.bat natively on Windows with MSVC (see the .bat file);
|
||||||
|
# required when the target Qt6/libQt6Pas is an MSVC
|
||||||
|
# build — MinGW and MSVC C++ ABIs are incompatible
|
||||||
|
#
|
||||||
|
# make install install the host-platform artifact into $(PREFIX)/lib
|
||||||
|
# (DESTDIR supported; run ldconfig yourself on Linux)
|
||||||
|
# make install-app APPDIR=/path/to/app/dir
|
||||||
|
# copy every built artifact next to the app binary
|
||||||
|
# (the Pascal loader looks there first)
|
||||||
|
# make clean
|
||||||
|
#
|
||||||
|
# Windows cross-build requirements (on the Linux build machine):
|
||||||
|
# - mingw-w64 toolchain: x86_64-w64-mingw32-g++
|
||||||
|
# - a *MinGW* build of Qt6 (headers + import libs), one of:
|
||||||
|
# * Arch AUR: mingw-w64-qt6-base (installs to /usr/x86_64-w64-mingw32)
|
||||||
|
# * MXE (https://mxe.cc) with qt6 (set MINGW_PREFIX to the MXE usr dir)
|
||||||
|
# * a Qt "MinGW" kit copied from a Windows Qt install
|
||||||
|
# (set WIN_QT_INC / WIN_QT_LIB manually)
|
||||||
|
#
|
||||||
|
# Windows native (MSYS2 MinGW64 shell) requirements:
|
||||||
|
# pacman -S mingw-w64-x86_64-gcc mingw-w64-x86_64-qt6-base pkgconf make
|
||||||
|
#
|
||||||
|
# The MinGW-built DLL works only with MinGW Qt6 DLLs on the target machine,
|
||||||
|
# the MSVC-built DLL only with MSVC Qt6 DLLs (incompatible C++ ABIs).
|
||||||
|
#
|
||||||
|
# macOS notes: needs Xcode command line tools + Qt6 with pkg-config files,
|
||||||
|
# e.g. Homebrew: brew install qt pkgconf
|
||||||
|
# export PKG_CONFIG_PATH="$(brew --prefix qt)/libexec/lib/pkgconfig"
|
||||||
|
# ----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
NAME := qlclglwidget
|
||||||
|
SRC := qlclglwidget.cpp
|
||||||
|
OUTDIR := ..
|
||||||
|
|
||||||
|
PREFIX ?= /usr/local
|
||||||
|
DESTDIR ?=
|
||||||
|
|
||||||
|
CXXFLAGS ?= -O2
|
||||||
|
CXXSTD := -std=c++17
|
||||||
|
|
||||||
|
PKG_CONFIG ?= pkg-config
|
||||||
|
QT_PKGS := Qt6Widgets Qt6OpenGLWidgets
|
||||||
|
|
||||||
|
# Windows cross toolchain / Qt location (override as needed)
|
||||||
|
MINGW_CXX ?= x86_64-w64-mingw32-g++
|
||||||
|
MINGW_PREFIX ?= /usr/x86_64-w64-mingw32
|
||||||
|
WIN_QT_INC ?= $(MINGW_PREFIX)/include/qt6
|
||||||
|
WIN_QT_LIB ?= $(MINGW_PREFIX)/lib
|
||||||
|
WIN_QT_LIBS ?= -lQt6Widgets -lQt6OpenGLWidgets -lQt6Gui -lQt6Core
|
||||||
|
|
||||||
|
LINUX_OUT := $(OUTDIR)/lib$(NAME).so
|
||||||
|
MACOS_OUT := $(OUTDIR)/lib$(NAME).dylib
|
||||||
|
WIN_OUT := $(OUTDIR)/$(NAME).dll
|
||||||
|
|
||||||
|
UNAME := $(shell uname -s)
|
||||||
|
ifeq ($(UNAME),Darwin)
|
||||||
|
HOST_OUT := $(MACOS_OUT)
|
||||||
|
HOST_TARGET := macos
|
||||||
|
else ifneq (,$(findstring MINGW,$(UNAME))$(findstring MSYS,$(UNAME)))
|
||||||
|
# MSYS2 MinGW64 shell on Windows
|
||||||
|
HOST_OUT := $(WIN_OUT)
|
||||||
|
HOST_TARGET := windows-native
|
||||||
|
else
|
||||||
|
HOST_OUT := $(LINUX_OUT)
|
||||||
|
HOST_TARGET := linux
|
||||||
|
endif
|
||||||
|
|
||||||
|
.PHONY: all linux macos windows windows-native install install-app clean
|
||||||
|
|
||||||
|
all: $(HOST_TARGET)
|
||||||
|
|
||||||
|
linux: $(LINUX_OUT)
|
||||||
|
|
||||||
|
$(LINUX_OUT): $(SRC)
|
||||||
|
$(CXX) $(CXXFLAGS) $(CXXSTD) -shared -fPIC \
|
||||||
|
$(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \
|
||||||
|
-o $@ $(SRC) \
|
||||||
|
$(shell $(PKG_CONFIG) --libs $(QT_PKGS))
|
||||||
|
|
||||||
|
macos: $(MACOS_OUT)
|
||||||
|
|
||||||
|
$(MACOS_OUT): $(SRC)
|
||||||
|
$(CXX) $(CXXFLAGS) $(CXXSTD) -dynamiclib -fPIC \
|
||||||
|
$(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \
|
||||||
|
-o $@ $(SRC) \
|
||||||
|
$(shell $(PKG_CONFIG) --libs $(QT_PKGS)) \
|
||||||
|
-Wl,-install_name,@rpath/lib$(NAME).dylib
|
||||||
|
|
||||||
|
# MinGW build: cross from Linux, or native on Windows with a Qt MinGW kit
|
||||||
|
# (no pkg-config needed — plain include/lib paths)
|
||||||
|
windows: $(WIN_OUT)
|
||||||
|
|
||||||
|
$(WIN_OUT): $(SRC)
|
||||||
|
$(MINGW_CXX) $(CXXFLAGS) $(CXXSTD) -shared \
|
||||||
|
-I$(WIN_QT_INC) \
|
||||||
|
-I$(WIN_QT_INC)/QtCore \
|
||||||
|
-I$(WIN_QT_INC)/QtGui \
|
||||||
|
-I$(WIN_QT_INC)/QtWidgets \
|
||||||
|
-I$(WIN_QT_INC)/QtOpenGL \
|
||||||
|
-I$(WIN_QT_INC)/QtOpenGLWidgets \
|
||||||
|
-o $@ $(SRC) \
|
||||||
|
-L$(WIN_QT_LIB) $(WIN_QT_LIBS) \
|
||||||
|
-static-libgcc -static-libstdc++ \
|
||||||
|
-Wl,--out-implib,$(OUTDIR)/lib$(NAME).dll.a
|
||||||
|
|
||||||
|
# native Windows build in an MSYS2 MinGW64 shell (pkg-config available)
|
||||||
|
windows-native:
|
||||||
|
$(CXX) $(CXXFLAGS) $(CXXSTD) -shared \
|
||||||
|
$(shell $(PKG_CONFIG) --cflags $(QT_PKGS)) \
|
||||||
|
-o $(WIN_OUT) $(SRC) \
|
||||||
|
$(shell $(PKG_CONFIG) --libs $(QT_PKGS)) \
|
||||||
|
-static-libgcc -static-libstdc++ \
|
||||||
|
-Wl,--out-implib,$(OUTDIR)/lib$(NAME).dll.a
|
||||||
|
|
||||||
|
install: $(HOST_OUT)
|
||||||
|
install -d $(DESTDIR)$(PREFIX)/lib
|
||||||
|
install -m755 $(HOST_OUT) $(DESTDIR)$(PREFIX)/lib/
|
||||||
|
|
||||||
|
install-app:
|
||||||
|
@test -n "$(APPDIR)" || { echo "usage: make install-app APPDIR=/path/to/app/dir"; exit 1; }
|
||||||
|
install -d $(APPDIR)
|
||||||
|
@for f in $(LINUX_OUT) $(MACOS_OUT) $(WIN_OUT); do \
|
||||||
|
if [ -f $$f ]; then install -m755 $$f $(APPDIR)/ && echo "installed $$f -> $(APPDIR)/"; fi; \
|
||||||
|
done
|
||||||
|
|
||||||
|
clean:
|
||||||
|
rm -f $(LINUX_OUT) $(MACOS_OUT) $(WIN_OUT) \
|
||||||
|
$(OUTDIR)/lib$(NAME).dll.a $(OUTDIR)/$(NAME).lib $(OUTDIR)/$(NAME).exp \
|
||||||
|
$(NAME).obj
|
||||||
@@ -0,0 +1,43 @@
|
|||||||
|
@echo off
|
||||||
|
rem ---------------------------------------------------------------------------
|
||||||
|
rem Builds qlclglwidget.dll natively on Windows with MSVC.
|
||||||
|
rem
|
||||||
|
rem Use this when the target Qt6 / libQt6Pas is an MSVC build (the official
|
||||||
|
rem Qt online-installer binaries are MSVC). A MinGW-built DLL cannot link
|
||||||
|
rem against MSVC Qt DLLs - the C++ ABIs are incompatible.
|
||||||
|
rem
|
||||||
|
rem How to run:
|
||||||
|
rem 1. Open "x64 Native Tools Command Prompt for VS" (vcvars64 environment).
|
||||||
|
rem 2. set QTDIR=C:\Qt\6.7.2\msvc2019_64 (your MSVC Qt kit)
|
||||||
|
rem 3. build-msvc.bat
|
||||||
|
rem
|
||||||
|
rem Output: ..\qlclglwidget.dll (put it next to the application executable).
|
||||||
|
rem ---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
if "%QTDIR%"=="" (
|
||||||
|
echo error: set QTDIR to your MSVC Qt kit first, e.g.:
|
||||||
|
echo set QTDIR=C:\Qt\6.7.2\msvc2019_64
|
||||||
|
exit /b 1
|
||||||
|
)
|
||||||
|
if not exist "%QTDIR%\include\QtOpenGLWidgets" (
|
||||||
|
echo error: %QTDIR%\include\QtOpenGLWidgets not found - is QTDIR an MSVC Qt6 kit?
|
||||||
|
exit /b 1
|
||||||
|
)
|
||||||
|
|
||||||
|
cl /nologo /LD /EHsc /std:c++17 /permissive- /Zc:__cplusplus /MD /O2 ^
|
||||||
|
/I"%QTDIR%\include" ^
|
||||||
|
/I"%QTDIR%\include\QtCore" ^
|
||||||
|
/I"%QTDIR%\include\QtGui" ^
|
||||||
|
/I"%QTDIR%\include\QtWidgets" ^
|
||||||
|
/I"%QTDIR%\include\QtOpenGL" ^
|
||||||
|
/I"%QTDIR%\include\QtOpenGLWidgets" ^
|
||||||
|
qlclglwidget.cpp /Fe:..\qlclglwidget.dll ^
|
||||||
|
/link /LIBPATH:"%QTDIR%\lib" Qt6Widgets.lib Qt6OpenGLWidgets.lib Qt6Gui.lib Qt6Core.lib
|
||||||
|
|
||||||
|
if errorlevel 1 (
|
||||||
|
echo build FAILED
|
||||||
|
exit /b 1
|
||||||
|
)
|
||||||
|
|
||||||
|
del qlclglwidget.obj ..\qlclglwidget.exp ..\qlclglwidget.lib 2>nul
|
||||||
|
echo built ..\qlclglwidget.dll
|
||||||
@@ -0,0 +1,124 @@
|
|||||||
|
//******************************************************************************
|
||||||
|
// qlclglwidget - a real QOpenGLWidget subclass with a Pascal paintGL hook.
|
||||||
|
//
|
||||||
|
// libQt6Pas's QLCLOpenGLWidget is NOT a QOpenGLWidget: it is a plain QWidget
|
||||||
|
// with WA_NativeWindow/paintEngine()=nullptr, designed as a target for an
|
||||||
|
// external GLX context (X11 only). This tiny library provides the missing
|
||||||
|
// piece: a genuine QOpenGLWidget whose context is created and managed by Qt
|
||||||
|
// itself (EGL on Wayland, GLX on X11, WGL on Windows, CGL on macOS), plus
|
||||||
|
// flat C exports for the methods the Lazarus side needs.
|
||||||
|
//
|
||||||
|
// Build: make (Linux .so / macOS .dylib)
|
||||||
|
// make windows (cross-build .dll with mingw-w64, see Makefile)
|
||||||
|
// make install (into /usr/local/lib)
|
||||||
|
//******************************************************************************
|
||||||
|
|
||||||
|
#include <QOpenGLWidget>
|
||||||
|
#include <QOpenGLContext>
|
||||||
|
#include <QOpenGLFunctions>
|
||||||
|
#include <QSurfaceFormat>
|
||||||
|
|
||||||
|
// mirrors QHook/QOverrideHook from libQt6Pas pascalbind.h:
|
||||||
|
// an FPC "procedure of object; cdecl" method pointer passed by value
|
||||||
|
typedef struct {
|
||||||
|
void *func;
|
||||||
|
void *data;
|
||||||
|
} QGLOverrideHook;
|
||||||
|
|
||||||
|
class QLCLGLWidget : public QOpenGLWidget {
|
||||||
|
public:
|
||||||
|
QGLOverrideHook paintGLHook;
|
||||||
|
// The widget renders into an RGBA FBO that Qt composites with alpha into
|
||||||
|
// the window. Legacy GL code written for GLX/WGL windows leaves arbitrary
|
||||||
|
// alpha in the framebuffer (there it was simply ignored), which makes the
|
||||||
|
// widget translucent here. Unless the user explicitly asked for an alpha
|
||||||
|
// channel, force alpha to 1 after each paint.
|
||||||
|
bool forceOpaque;
|
||||||
|
|
||||||
|
explicit QLCLGLWidget(QWidget *parent = nullptr,
|
||||||
|
Qt::WindowFlags flags = Qt::WindowFlags())
|
||||||
|
: QOpenGLWidget(parent, flags) {
|
||||||
|
paintGLHook.func = nullptr;
|
||||||
|
paintGLHook.data = nullptr;
|
||||||
|
forceOpaque = true;
|
||||||
|
}
|
||||||
|
|
||||||
|
protected:
|
||||||
|
// Qt makes the context current and binds the widget's FBO before this call
|
||||||
|
void paintGL() override {
|
||||||
|
if (paintGLHook.func) {
|
||||||
|
typedef void (*func_type)(void *data);
|
||||||
|
(*(func_type)paintGLHook.func)(paintGLHook.data);
|
||||||
|
if (forceOpaque)
|
||||||
|
fillAlpha();
|
||||||
|
} else {
|
||||||
|
QOpenGLWidget::paintGL();
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
private:
|
||||||
|
void fillAlpha() {
|
||||||
|
QOpenGLFunctions *f = QOpenGLContext::currentContext()->functions();
|
||||||
|
GLboolean mask[4];
|
||||||
|
GLfloat clearColor[4];
|
||||||
|
f->glGetBooleanv(GL_COLOR_WRITEMASK, mask);
|
||||||
|
f->glGetFloatv(GL_COLOR_CLEAR_VALUE, clearColor);
|
||||||
|
GLboolean scissor = f->glIsEnabled(GL_SCISSOR_TEST);
|
||||||
|
if (scissor)
|
||||||
|
f->glDisable(GL_SCISSOR_TEST);
|
||||||
|
f->glColorMask(GL_FALSE, GL_FALSE, GL_FALSE, GL_TRUE);
|
||||||
|
f->glClearColor(0.f, 0.f, 0.f, 1.f);
|
||||||
|
f->glClear(GL_COLOR_BUFFER_BIT);
|
||||||
|
f->glColorMask(mask[0], mask[1], mask[2], mask[3]);
|
||||||
|
f->glClearColor(clearColor[0], clearColor[1], clearColor[2], clearColor[3]);
|
||||||
|
if (scissor)
|
||||||
|
f->glEnable(GL_SCISSOR_TEST);
|
||||||
|
}
|
||||||
|
};
|
||||||
|
|
||||||
|
extern "C" {
|
||||||
|
|
||||||
|
Q_DECL_EXPORT void *QLCLGLWidget_Create(void *parent, unsigned int flags) {
|
||||||
|
return (void *)new QLCLGLWidget((QWidget *)parent, (Qt::WindowFlags)flags);
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_Destroy(void *handle) {
|
||||||
|
delete (QLCLGLWidget *)handle;
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_override_paintGL(void *handle,
|
||||||
|
QGLOverrideHook hook) {
|
||||||
|
((QLCLGLWidget *)handle)->paintGLHook = hook;
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_makeCurrent(void *handle) {
|
||||||
|
((QLCLGLWidget *)handle)->makeCurrent();
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_doneCurrent(void *handle) {
|
||||||
|
((QLCLGLWidget *)handle)->doneCurrent();
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT bool QLCLGLWidget_isValid(void *handle) {
|
||||||
|
return ((QLCLGLWidget *)handle)->isValid();
|
||||||
|
}
|
||||||
|
|
||||||
|
// fmt is a QSurfaceFormatH created via libQt6Pas QSurfaceFormat_Create
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_setFormat(void *handle, void *fmt) {
|
||||||
|
((QLCLGLWidget *)handle)->setFormat(*(const QSurfaceFormat *)fmt);
|
||||||
|
}
|
||||||
|
|
||||||
|
// enabled by default; pass false when the control requests AlphaBits > 0
|
||||||
|
Q_DECL_EXPORT void QLCLGLWidget_setForceOpaque(void *handle, bool enable) {
|
||||||
|
((QLCLGLWidget *)handle)->forceOpaque = enable;
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT unsigned int QLCLGLWidget_defaultFramebufferObject(void *handle) {
|
||||||
|
return ((QLCLGLWidget *)handle)->defaultFramebufferObject();
|
||||||
|
}
|
||||||
|
|
||||||
|
Q_DECL_EXPORT double QLCLGLWidget_devicePixelRatioF(void *handle) {
|
||||||
|
return ((QLCLGLWidget *)handle)->devicePixelRatioF();
|
||||||
|
}
|
||||||
|
|
||||||
|
} // extern "C"
|
||||||
@@ -0,0 +1,539 @@
|
|||||||
|
{
|
||||||
|
*****************************************************************************
|
||||||
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
||||||
|
for details about the license.
|
||||||
|
*****************************************************************************
|
||||||
|
|
||||||
|
Author: Mattias Gaertner
|
||||||
|
|
||||||
|
ToDo:
|
||||||
|
use custom pixelformat
|
||||||
|
attributes: doublebufferd, version, ...
|
||||||
|
It should work with initWithFrame_pixelFormat, but this paints nothing
|
||||||
|
SwapBuffers - there is no function like aglSwapBuffers in CGL/NS
|
||||||
|
Mouse:
|
||||||
|
the TLCLCommonCallback mouse handlers check Owner.isEnabled, which
|
||||||
|
for a NSView always returns false.
|
||||||
|
}
|
||||||
|
unit GLCocoaNSContextEx;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
{$ModeSwitch objectivec1}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, Types, LCLType, Controls,
|
||||||
|
LMessages, LCLMessageGlue, WSLCLClasses, LazLoggerBase,
|
||||||
|
MacOSAll, CocoaAll,
|
||||||
|
CocoaPrivate, CocoaCommonCallback, CocoaUtils, Cocoa_Extra;
|
||||||
|
|
||||||
|
function LBackingScaleFactor(Handle: HWND): single;
|
||||||
|
procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND);
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
procedure LOpenGLClip(Handle: HWND);
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
{%H-}WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, AMacRetinaMode: boolean;
|
||||||
|
MajorVersion, MinorVersion: Cardinal;
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const {%H-}AParams: TCreateParams): HWND;
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
function CreateOpenGLContextAttrList(DoubleBuffered: boolean;
|
||||||
|
MajorVersion, MinorVersion: Cardinal;
|
||||||
|
MultiSampling, AlphaBits, DepthBits,
|
||||||
|
StencilBits, AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr;
|
||||||
|
|
||||||
|
const
|
||||||
|
// missing constants in FPC 3.1.1 rev 31197 and below
|
||||||
|
NSOpenGLPFAOpenGLProfile = 99; //cr: name changed to match https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html
|
||||||
|
NSOpenGLProfileLegacy = $1000;
|
||||||
|
NSOpenGLProfileVersion3_2Core = $3200;
|
||||||
|
NSOpenGLProfileVersion4_1Core = $4100; //requires OSX SDK 10.10 or later, https://github.com/google/gxui/issues/98
|
||||||
|
|
||||||
|
type
|
||||||
|
NSOpenGLViewFix = objccategory external (NSOpenGLView)
|
||||||
|
procedure setWantsBestResolutionOpenGLSurface(bool: NSInteger); message 'setWantsBestResolutionOpenGLSurface:';
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TCocoaOpenGLView }
|
||||||
|
|
||||||
|
TCocoaOpenGLView = objcclass(NSOpenGLView)
|
||||||
|
public
|
||||||
|
Owner: TWinControl;
|
||||||
|
callback: TLCLCommonCallback;
|
||||||
|
backingScaleFactor: Single;
|
||||||
|
function acceptsFirstResponder: LCLObjCBoolean; override;
|
||||||
|
function becomeFirstResponder: LCLObjCBoolean; override;
|
||||||
|
function resignFirstResponder: LCLObjCBoolean; override;
|
||||||
|
procedure drawRect(dirtyRect: NSRect); override;
|
||||||
|
procedure dealloc; override;
|
||||||
|
function lclGetCallback: ICommonCallback; override;
|
||||||
|
procedure lclClearCallback; override;
|
||||||
|
function lclIsEnabled: Boolean; override;
|
||||||
|
// mouse
|
||||||
|
procedure mouseDown(event: NSEvent); override;
|
||||||
|
procedure mouseUp(event: NSEvent); override;
|
||||||
|
procedure rightMouseDown(event: NSEvent); override;
|
||||||
|
procedure rightMouseUp(event: NSEvent); override;
|
||||||
|
procedure rightMouseDragged(event: NSEvent); override;
|
||||||
|
procedure otherMouseDown(event: NSEvent); override;
|
||||||
|
procedure otherMouseUp(event: NSEvent); override;
|
||||||
|
procedure otherMouseDragged(event: NSEvent); override;
|
||||||
|
procedure mouseDragged(event: NSEvent); override;
|
||||||
|
procedure mouseEntered(event: NSEvent); override;
|
||||||
|
procedure mouseExited(event: NSEvent); override;
|
||||||
|
procedure mouseMoved(event: NSEvent); override;
|
||||||
|
procedure scrollWheel(event: NSEvent); override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj;
|
||||||
|
(*function CreateCGLContextAttrList(DoubleBuffered: boolean;
|
||||||
|
{$IFDEF UsesModernGL}
|
||||||
|
MajorVersion, MinorVersion: Cardinal;
|
||||||
|
{$ENDIF}
|
||||||
|
MultiSampling, AlphaBits, DepthBits,
|
||||||
|
StencilBits, AUXBuffers: cardinal): PInteger;
|
||||||
|
function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean;*)
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
//value > 1 if screen is scaled, e.g. default for MOST retina displays is 2
|
||||||
|
function LBackingScaleFactor(Handle: HWND): single;
|
||||||
|
begin
|
||||||
|
result := TCocoaOpenGLView(Handle).backingScaleFactor;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LSetWantsBestResolutionOpenGLSurface(const AValue: boolean; Handle: HWND);
|
||||||
|
var
|
||||||
|
View: TCocoaOpenGLView;
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit;
|
||||||
|
View:=TCocoaOpenGLView(Handle);
|
||||||
|
if not View.respondsToSelector(objcselector('setWantsBestResolutionOpenGLSurface:')) then exit;
|
||||||
|
if AValue then
|
||||||
|
View.setWantsBestResolutionOpenGLSurface(1)
|
||||||
|
else
|
||||||
|
View.setWantsBestResolutionOpenGLSurface(0);
|
||||||
|
if (AValue) and (NSScreen.mainScreen.respondsToSelector(objcselector('backingScaleFactor'))) then //MacOS >=10.7
|
||||||
|
View.backingScaleFactor := NSScreen.mainScreen.backingScaleFactor
|
||||||
|
else
|
||||||
|
View.backingScaleFactor := 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
var
|
||||||
|
View: NSOpenGLView absolute Handle;
|
||||||
|
lFinalWidth, lFinalHeight: Integer;
|
||||||
|
begin
|
||||||
|
lFinalWidth := Width;
|
||||||
|
lFinalHeight := Height;
|
||||||
|
if View <> nil then
|
||||||
|
begin
|
||||||
|
lFinalWidth := Round(Width * LBackingScaleFactor(Handle));
|
||||||
|
lFinalHeight := Round(Height * LBackingScaleFactor(Handle));
|
||||||
|
end;
|
||||||
|
glViewport(Left,Top,lFinalWidth,lFinalHeight);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
//var
|
||||||
|
// View: TCocoaOpenGLView; //TCocoaOpenGLView
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit;
|
||||||
|
glFlush();
|
||||||
|
// View:=TCocoaOpenGLView(Handle);
|
||||||
|
// View.nsGL.flushBuffer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
CGLContext: CGLContextObj;
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit(false);
|
||||||
|
CGLContext:=GetCGLContextObj(Handle);
|
||||||
|
Result:=CGLSetCurrentContext(CGLContext)=kCGLNoError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit(false);
|
||||||
|
Result:=CGLSetCurrentContext(nil)=kCGLNoError;
|
||||||
|
//Result:=true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLClip(Handle: HWND);
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit;
|
||||||
|
// ToDo
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, AMacRetinaMode: boolean;
|
||||||
|
MajorVersion, MinorVersion: Cardinal;
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits,
|
||||||
|
AUXBuffers: Cardinal; const AParams: TCreateParams): HWND;
|
||||||
|
var
|
||||||
|
View: TCocoaOpenGLView;
|
||||||
|
Attrs: NSOpenGLPixelFormatAttributePtr;
|
||||||
|
PixFmt: NSOpenGLPixelFormat;
|
||||||
|
p: NSView;
|
||||||
|
ns: NSRect;
|
||||||
|
aNSOpenGLContext, SharedContext: NSOpenGLContext;
|
||||||
|
begin
|
||||||
|
Result:=0;
|
||||||
|
p := nil;
|
||||||
|
if (AParams.WndParent <> 0) then
|
||||||
|
p := NSObject(AParams.WndParent).lclContentView;
|
||||||
|
if Assigned(p) then
|
||||||
|
TCocoaTypeUtil.toRect(types.Bounds(AParams.X, AParams.Y, AParams.Width, AParams.Height),
|
||||||
|
p.frame.size.height, ns)
|
||||||
|
else
|
||||||
|
ns := NSMakeRect(AParams.X, AParams.Y, AParams.Width, AParams.Height);
|
||||||
|
Attrs:=CreateOpenGLContextAttrList(DoubleBuffered,MajorVersion,MinorVersion, MultiSampling,AlphaBits,DepthBits,StencilBits,AUXBuffers);
|
||||||
|
try
|
||||||
|
PixFmt:=NSOpenGLPixelFormat(NSOpenGLPixelFormat.alloc).initWithAttributes(Attrs);
|
||||||
|
{ Use SharedControl to share OpenGL resources with another TOpenGLControl instance }
|
||||||
|
if SharedControl <> nil then
|
||||||
|
SharedContext := TCocoaOpenGLView(SharedControl.Handle).openGLContext
|
||||||
|
else
|
||||||
|
SharedContext := nil;
|
||||||
|
aNSOpenGLContext:=NSOpenGLContext(NSOpenGLContext.alloc).initWithFormat_shareContext(PixFmt,SharedContext);
|
||||||
|
if aNSOpenGLContext = nil then
|
||||||
|
debugln(['LOpenGLCreateContext Error']);
|
||||||
|
View := TCocoaOpenGLView(TCocoaOpenGLView.alloc).initWithFrame_pixelFormat(ns,PixFmt);
|
||||||
|
if not Assigned(View) then Exit;
|
||||||
|
finally
|
||||||
|
FreeMem(Attrs);
|
||||||
|
end;
|
||||||
|
View.setHidden(AParams.Style and WS_VISIBLE = 0);
|
||||||
|
if Assigned(p) then
|
||||||
|
p.addSubview(View);
|
||||||
|
TCocoaViewUtil.setDefaultMargin(View);
|
||||||
|
View.Owner:=AWinControl;
|
||||||
|
{ If we wouldn't set View.openGLContext, it would get automatically created.
|
||||||
|
But then aNSOpenGLContext is ignored, and so SharedContext and SharedControl don't work. }
|
||||||
|
View.setOpenGLContext(aNSOpenGLContext);
|
||||||
|
View.callback:=TLCLCommonCallback.Create(View, AWinControl);
|
||||||
|
LSetWantsBestResolutionOpenGLSurface(AMacRetinaMode, HWND(View));
|
||||||
|
//View.setPixelFormat(PixFmt);
|
||||||
|
Result:=TLCLHandle(View);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
begin
|
||||||
|
// no special needed, simply release handle
|
||||||
|
if AWinControl=nil then
|
||||||
|
raise Exception.Create('');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CreateOpenGLContextAttrList(DoubleBuffered: boolean; MajorVersion,
|
||||||
|
MinorVersion: Cardinal; MultiSampling, AlphaBits, DepthBits, StencilBits,
|
||||||
|
AUXBuffers: cardinal): NSOpenGLPixelFormatAttributePtr;
|
||||||
|
var
|
||||||
|
p: integer;
|
||||||
|
|
||||||
|
procedure AddUInt32(i: NSOpenGLPixelFormatAttribute);
|
||||||
|
begin
|
||||||
|
if Result<>nil then
|
||||||
|
Result[p]:=i;
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CreateList;
|
||||||
|
begin
|
||||||
|
//see https://developer.apple.com/library/mac/documentation//Cocoa/Reference/ApplicationKit/Classes/NSOpenGLPixelFormat_Class/index.html
|
||||||
|
//AddUInt32(NSOpenGLPFAAccelerated); // <- comment out: we can run in software if hardware is not available
|
||||||
|
//AddUInt32(NSOpenGLPFAOpenGLProfile); //Versions beyond 'Legacy' appear to break CULL_FACE and DEPTH_BUFFER, legacy seems to be default, so comment out whole instruction
|
||||||
|
//if (MajorVersion>=4) and (MinorVersion>=1)
|
||||||
|
// AddUInt32(NSOpenGLProfileVersion4_1Core);
|
||||||
|
//else if (MajorVersion>=3) and (MinorVersion>=2) then
|
||||||
|
// AddUInt32(NSOpenGLProfileVersion3_2Core);
|
||||||
|
//else
|
||||||
|
//AddUInt32(NSOpenGLProfileLegacy); // NSOpenGLProfileLegacy is default and sufficient, later versions depend on SDK we are building against
|
||||||
|
AddUInt32(NSOpenGLPFAOpenGLProfile);
|
||||||
|
if (MajorVersion>=4) and (MinorVersion>=1) then
|
||||||
|
AddUInt32(NSOpenGLProfileVersion4_1Core) //OpenGL 4.1, GLSL 4.1
|
||||||
|
else if (MajorVersion>=3) and (MinorVersion>=2) then
|
||||||
|
AddUInt32(NSOpenGLProfileVersion3_2Core)
|
||||||
|
else
|
||||||
|
AddUInt32(NSOpenGLProfileLegacy); //OpenGL 2.1, GLSL 1.2
|
||||||
|
AddUInt32(NSOpenGLPFAColorSize); AddUInt32(24);
|
||||||
|
if DepthBits > 0 then begin
|
||||||
|
AddUInt32(NSOpenGLPFADepthSize); AddUInt32(32);
|
||||||
|
end;
|
||||||
|
if AlphaBits>0 then begin
|
||||||
|
AddUInt32(NSOpenGLPFAAlphaSize); AddUInt32(AlphaBits);
|
||||||
|
end;
|
||||||
|
AddUInt32(NSOpenGLPFAAccelerated);
|
||||||
|
if MultiSampling > 1 then begin
|
||||||
|
AddUInt32(NSOpenGLPFAMultisample);
|
||||||
|
AddUInt32(NSOpenGLPFASampleBuffers); AddUInt32(1);
|
||||||
|
AddUInt32(NSOpenGLPFASamples); AddUInt32(MultiSampling);
|
||||||
|
end;
|
||||||
|
if StencilBits>0 then
|
||||||
|
begin
|
||||||
|
AddUInt32(NSOpenGLPFAStencilSize); AddUInt32(StencilBits);
|
||||||
|
end;
|
||||||
|
if AUXBuffers>0 then
|
||||||
|
begin
|
||||||
|
AddUInt32(NSOpenGLPFAAuxBuffers); AddUInt32(AUXBuffers);
|
||||||
|
end;
|
||||||
|
//if DoubleBuffered then //requires fix for nsGL
|
||||||
|
// AddUInt32(NSOpenGLPFADoubleBuffer); //this doen't work with Lazarus
|
||||||
|
AddUInt32(NSOpenGLPFAMaximumPolicy); //allows future changes to make attributes more demanding, e.g. add multisampling
|
||||||
|
|
||||||
|
AddUInt32(NSOpenGLPFANoRecovery); //see apple web page: "not generally useful" but might help with multisample
|
||||||
|
AddUInt32(0); // end of list
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=nil;
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
GetMem(Result,SizeOf(NSOpenGLPixelFormatAttribute)*(p+1));
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetCGLContextObj(OpenGLControlHandle: HWND): CGLContextObj;
|
||||||
|
var
|
||||||
|
View: NSOpenGLView;
|
||||||
|
begin
|
||||||
|
Result:=nil;
|
||||||
|
if OpenGLControlHandle=0 then exit;
|
||||||
|
View:=TCocoaOpenGLView(OpenGLControlHandle);
|
||||||
|
Result:=CGLContextObj(View.openGLContext.CGLContextObj);
|
||||||
|
NSScreen.mainScreen.colorSpace;
|
||||||
|
end;
|
||||||
|
|
||||||
|
(*
|
||||||
|
//these functions are commented out: this was an attempt to use CGL, porting NSOpenGLView instead was more successful
|
||||||
|
function CreateCGLContextAttrList(DoubleBuffered: boolean; MultiSampling,
|
||||||
|
AlphaBits, DepthBits, StencilBits, AUXBuffers: cardinal): PInteger;
|
||||||
|
var
|
||||||
|
p: integer;
|
||||||
|
|
||||||
|
procedure Add(i: integer);
|
||||||
|
begin
|
||||||
|
if Result<>nil then
|
||||||
|
Result[p]:=i;
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CreateList;
|
||||||
|
begin
|
||||||
|
//Add(kCGLPFAWindow); deprecated since 10.9
|
||||||
|
Add(kCGLPFAAccelerated);
|
||||||
|
if DoubleBuffered then
|
||||||
|
Add(kCGLPFADoubleBuffer);
|
||||||
|
//if (MajorVersion>=3) and (MinorVersion>=2) then
|
||||||
|
// Add(kCGLOGLPVersion);
|
||||||
|
Add(kCGLPFANoRecovery);
|
||||||
|
Add(kCGLPFAMaximumPolicy);
|
||||||
|
Add(kCGLPFASingleRenderer);
|
||||||
|
if AlphaBits>0 then
|
||||||
|
begin
|
||||||
|
Add(kCGLPFAAlphaSize); Add(AlphaBits);
|
||||||
|
end;
|
||||||
|
if DepthBits>0 then
|
||||||
|
begin
|
||||||
|
Add(kCGLPFADepthSize); Add(DepthBits);
|
||||||
|
end;
|
||||||
|
if StencilBits>0 then
|
||||||
|
begin
|
||||||
|
Add(kCGLPFAStencilSize); Add(StencilBits);
|
||||||
|
end;
|
||||||
|
if AUXBuffers>0 then
|
||||||
|
begin
|
||||||
|
//Add(kCGLPFAAuxBuffers); Add(AUXBuffers); ToDo
|
||||||
|
end;
|
||||||
|
if MultiSampling > 1 then
|
||||||
|
begin
|
||||||
|
Add(kCGLPFASampleBuffers); Add(1);
|
||||||
|
Add(kCGLPFASamples); Add(MultiSampling);
|
||||||
|
end;
|
||||||
|
|
||||||
|
Add(0); // end of list
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=nil;
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
GetMem(Result,SizeOf(integer)*p);
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function IsCGLPixelFormatAvailable(Attribs: PInteger): boolean;
|
||||||
|
var
|
||||||
|
//display: CGDirectDisplayID;
|
||||||
|
aPixFormatObj: CGLPixelFormatObj;
|
||||||
|
aPixObjCountAttrList: GLint;
|
||||||
|
begin
|
||||||
|
//display := CGMainDisplayID();
|
||||||
|
if CGLChoosePixelFormat(Attribs, @aPixFormatObj, @aPixObjCountAttrList)<>kCGLNoError
|
||||||
|
then
|
||||||
|
exit(false);
|
||||||
|
if aPixFormatObj=nil then
|
||||||
|
exit(false);
|
||||||
|
Result:=true;
|
||||||
|
// ToDo: free aPixFormatObj
|
||||||
|
end; *)
|
||||||
|
|
||||||
|
{ TCocoaOpenGLView }
|
||||||
|
|
||||||
|
function TCocoaOpenGLView.acceptsFirstResponder: LCLObjCBoolean;
|
||||||
|
begin
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCocoaOpenGLView.becomeFirstResponder: LCLObjCBoolean;
|
||||||
|
begin
|
||||||
|
Result:=inherited becomeFirstResponder;
|
||||||
|
TCocoaLCLMessageUtil.BecomeFirstResponder(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCocoaOpenGLView.resignFirstResponder: LCLObjCBoolean;
|
||||||
|
begin
|
||||||
|
Result:=inherited resignFirstResponder;
|
||||||
|
TCocoaLCLMessageUtil.ResignFirstResponder(self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.dealloc;
|
||||||
|
begin
|
||||||
|
inherited dealloc;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCocoaOpenGLView.lclGetCallback: ICommonCallback;
|
||||||
|
begin
|
||||||
|
Result := callback;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.lclClearCallback;
|
||||||
|
begin
|
||||||
|
callback := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCocoaOpenGLView.lclIsEnabled: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Owner.Enabled;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseDown(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
begin
|
||||||
|
// do not pass mouseDown below or it will pass it to the parent control
|
||||||
|
// causing double events
|
||||||
|
//inherited mouseDown(event);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseUp(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
inherited mouseUp(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.rightMouseDown(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
inherited rightMouseDown(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.rightMouseUp(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
inherited rightMouseUp(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.rightMouseDragged(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseMove(event) then
|
||||||
|
inherited rightMouseDragged(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.otherMouseDown(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
inherited otherMouseDown(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.otherMouseUp(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseUpDownEvent(event) then
|
||||||
|
inherited otherMouseUp(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.otherMouseDragged(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseMove(event) then
|
||||||
|
inherited otherMouseDragged(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseDragged(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if Assigned(callback)
|
||||||
|
then callback.MouseMove(event)
|
||||||
|
else inherited mouseDragged(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseEntered(event: NSEvent);
|
||||||
|
begin
|
||||||
|
inherited mouseEntered(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseExited(event: NSEvent);
|
||||||
|
begin
|
||||||
|
inherited mouseExited(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.mouseMoved(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if not Assigned(callback) or not callback.MouseMove(event) then
|
||||||
|
inherited mouseMoved(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.scrollWheel(event: NSEvent);
|
||||||
|
begin
|
||||||
|
if Assigned(callback)
|
||||||
|
then callback.scrollWheel(event)
|
||||||
|
else inherited scrollWheel(event);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCocoaOpenGLView.drawRect(dirtyRect: NSRect);
|
||||||
|
var
|
||||||
|
ctx : NSGraphicsContext;
|
||||||
|
PS : TPaintStruct;
|
||||||
|
r : NSRect;
|
||||||
|
begin
|
||||||
|
ctx := NSGraphicsContext.currentContext;
|
||||||
|
inherited drawRect(dirtyRect);
|
||||||
|
if TCocoaApplicationUtil.isMainThread and Assigned(callback) then
|
||||||
|
begin
|
||||||
|
if ctx = nil then
|
||||||
|
begin
|
||||||
|
// In macOS 10.14 (mojave) current context is nil
|
||||||
|
// we still can paint anything related to OpenGL!
|
||||||
|
// todo: consider creating a dummy context (for a bitmap)
|
||||||
|
FillChar(PS, SizeOf(TPaintStruct), 0);
|
||||||
|
r := frame;
|
||||||
|
r.origin.x:=0;
|
||||||
|
r.origin.y:=0;
|
||||||
|
PS.hdc := HDC(0);
|
||||||
|
PS.rcPaint := TCocoaTypeUtil.toRect(r);
|
||||||
|
LCLSendPaintMsg(Owner, HDC(0), @PS);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
callback.Draw(ctx, bounds, dirtyRect);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
@@ -0,0 +1,143 @@
|
|||||||
|
unit GLGtk3GlxContextEx;
|
||||||
|
|
||||||
|
{$mode objfpc}
|
||||||
|
{$LinkLib GL}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, ctypes, X, XUtil, XLib, gl, glext, glx,
|
||||||
|
// LazUtils
|
||||||
|
LazUtilities,
|
||||||
|
// LCL
|
||||||
|
LCLType, InterfaceBase, LMessages, Controls,
|
||||||
|
WSLCLClasses, LCLMessageGlue,
|
||||||
|
glib2, gtk3int, LazGdk3, LazGtk3, gtk3widgets;
|
||||||
|
|
||||||
|
function LBackingScaleFactor(Handle: HWND): single;
|
||||||
|
procedure LOpenGLViewport({%H-}Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
function LOpenGLReleaseContext({%H-}Handle: HWND): boolean;
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA, DebugContext: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$assertions on}
|
||||||
|
|
||||||
|
procedure on_render(widget: PGtkWidget; context: gpointer{Pcairo_t}; data: TGtk3Widget); cdecl;
|
||||||
|
begin
|
||||||
|
data.LCLObject.Perform(LM_PAINT, WParam(data), 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function gtkglarea_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation; Data: gPointer): GBoolean; cdecl;
|
||||||
|
var
|
||||||
|
SizeMsg: TLMSize;
|
||||||
|
GtkWidth, GtkHeight: integer;
|
||||||
|
LCLControl: TWinControl;
|
||||||
|
begin
|
||||||
|
Result := true;
|
||||||
|
LCLControl:=TWinControl(Data);
|
||||||
|
if LCLControl=nil then exit;
|
||||||
|
|
||||||
|
gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);
|
||||||
|
|
||||||
|
SizeMsg.Msg:=0;
|
||||||
|
FillChar(SizeMsg,SizeOf(SizeMsg),0);
|
||||||
|
with SizeMsg do
|
||||||
|
begin
|
||||||
|
Result := 0;
|
||||||
|
Msg := LM_SIZE;
|
||||||
|
SizeType := Size_SourceIsInterface;
|
||||||
|
Width := SmallInt(GtkWidth);
|
||||||
|
Height := SmallInt(GtkHeight);
|
||||||
|
end;
|
||||||
|
LCLControl.WindowProc(TLMessage(SizeMsg));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function gtk_gl_area_get_error (area: PGtkGLArea): PGError; cdecl; external;
|
||||||
|
|
||||||
|
function LBackingScaleFactor(Handle: HWND): single;
|
||||||
|
var
|
||||||
|
glarea: TGtk3GLArea absolute Handle;
|
||||||
|
begin
|
||||||
|
if Assigned(glarea) then begin
|
||||||
|
Result := glarea.GetWindow^.get_scale_factor;
|
||||||
|
end else begin
|
||||||
|
Result := 1;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
var
|
||||||
|
scaleFactor: integer;
|
||||||
|
begin
|
||||||
|
scaleFactor := RoundToInt(LBackingScaleFactor(Handle));
|
||||||
|
glViewport(Left,Top,Width*scaleFactor,Height*scaleFactor);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
var
|
||||||
|
glarea: TGtk3GLArea absolute Handle;
|
||||||
|
begin
|
||||||
|
if Handle=0 then exit;
|
||||||
|
glFlush();
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
glarea: TGtk3GLArea absolute Handle;
|
||||||
|
begin
|
||||||
|
glarea.Widget^.realize;
|
||||||
|
PGtkGLArea(glarea.Widget)^.make_current;
|
||||||
|
Assert(gtk_gl_area_get_error(PGtkGLArea(glarea.Widget)) = nil, 'LOpenGLMakeCurrent failed');
|
||||||
|
result := true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
glarea: TGtk3GLArea absolute Handle;
|
||||||
|
begin
|
||||||
|
// todo(ryan): is it possible to make no context current?
|
||||||
|
result:=true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA, DebugContext: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
var
|
||||||
|
NewWidget: TGtk3GLArea;
|
||||||
|
glarea: PGtkGLArea;
|
||||||
|
begin
|
||||||
|
NewWidget := TGtk3GLArea.Create(AWinControl, AParams);
|
||||||
|
result := TLCLHandle(NewWidget);
|
||||||
|
glarea := PGtkGLArea(NewWidget.Widget);
|
||||||
|
|
||||||
|
g_signal_connect(glarea, 'render', TGCallback(@on_render), NewWidget);
|
||||||
|
// todo(ryan): do we need this?
|
||||||
|
g_signal_connect_after(glarea, 'size-allocate', TGCallback(@gtkglarea_size_allocateCB), AWinControl);
|
||||||
|
|
||||||
|
glarea^.set_auto_render(false);
|
||||||
|
glarea^.set_required_version(MajorVersion, MinorVersion);
|
||||||
|
glarea^.set_has_depth_buffer(DepthBits > 0);
|
||||||
|
glarea^.set_has_alpha(AlphaBits > 0);
|
||||||
|
glarea^.set_has_stencil_buffer(StencilBits > 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
begin
|
||||||
|
if not AWinControl.HandleAllocated then exit;
|
||||||
|
// nothing to do
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,371 @@
|
|||||||
|
{
|
||||||
|
*****************************************************************************
|
||||||
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
||||||
|
for details about the license.
|
||||||
|
*****************************************************************************
|
||||||
|
|
||||||
|
Qt5/Qt6 OpenGL backend built on a real QOpenGLWidget (libqlclglwidget)
|
||||||
|
instead of GLX. Qt creates and manages the GL context through the
|
||||||
|
platform-appropriate API (EGL on Wayland, GLX on X11, WGL on Windows,
|
||||||
|
CGL on macOS), so this backend works on every platform the Qt widgetset
|
||||||
|
runs on — including Wayland sessions, where the classic GLX backend
|
||||||
|
(GLQTContext) cannot work at all.
|
||||||
|
|
||||||
|
Why a helper library: libQt6Pas's QLCLOpenGLWidget is NOT a QOpenGLWidget —
|
||||||
|
it is a plain QWidget with WA_NativeWindow/paintEngine()=nullptr meant as a
|
||||||
|
target for an external GLX context, X11 only. The real QOpenGLWidget
|
||||||
|
subclass with a Pascal paintGL hook lives in the small companion library
|
||||||
|
libqlclglwidget (csrc/qlclglwidget.cpp), loaded at runtime from the
|
||||||
|
application directory or the system library path.
|
||||||
|
|
||||||
|
How it works:
|
||||||
|
- Qt makes the widget's context current and binds its backing FBO before
|
||||||
|
invoking paintGL(); we deliver LM_PAINT from there, so all rendering in
|
||||||
|
OnPaint just works. MakeCurrent during paint is a no-op.
|
||||||
|
- MakeCurrent/ReleaseContext outside of paint map to
|
||||||
|
QOpenGLWidget::makeCurrent/doneCurrent.
|
||||||
|
- SwapBuffers is a no-op during paint (Qt composites the FBO itself after
|
||||||
|
paintGL returns); outside of paint it schedules a repaint.
|
||||||
|
|
||||||
|
Notes:
|
||||||
|
- Contexts of all QOpenGLWidgets inside the same top-level window are
|
||||||
|
automatically shared by Qt; the SharedControl property is ignored.
|
||||||
|
- QOpenGLWidget renders into an FBO: do not call glBindFramebuffer(0)
|
||||||
|
from user code.
|
||||||
|
- On HiDPI (devicePixelRatio > 1) the backing FBO is larger than the
|
||||||
|
logical widget size; LOpenGLViewport (AutoResizeViewport) scales by the
|
||||||
|
devicePixelRatio, but explicit glViewport calls in user code must scale
|
||||||
|
themselves.
|
||||||
|
}
|
||||||
|
unit GLQtNativeContext;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
{$PACKRECORDS C}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
{$IF NOT (DEFINED(LCLQt5) OR DEFINED(LCLQt6))}
|
||||||
|
{$ERROR GLQtNativeContext supports only the Qt5/Qt6 widgetsets}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, Controls, LCLProc, LCLType, gl, dynlibs,
|
||||||
|
InterfaceBase, WSLCLClasses,
|
||||||
|
// Bindings
|
||||||
|
{$IFDEF LCLQt5}qt5,{$ENDIF}
|
||||||
|
{$IFDEF LCLQt6}qt6,{$ENDIF}
|
||||||
|
qtwidgets, qtint;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses LMessages, Forms;
|
||||||
|
|
||||||
|
{ ---------------------------------------------------------------------------
|
||||||
|
libqlclglwidget, loaded at runtime
|
||||||
|
--------------------------------------------------------------------------- }
|
||||||
|
|
||||||
|
const
|
||||||
|
GLWidgetLibName =
|
||||||
|
{$IFDEF WINDOWS}'qlclglwidget.dll'{$ELSE}
|
||||||
|
{$IFDEF DARWIN}'libqlclglwidget.dylib'{$ELSE}
|
||||||
|
'libqlclglwidget.so'{$ENDIF}{$ENDIF};
|
||||||
|
|
||||||
|
type
|
||||||
|
// an FPC method pointer passed by value; matches the C-side
|
||||||
|
// QGLOverrideHook {void *func; void *data;}
|
||||||
|
TGLWidgetPaintHook = procedure of object; cdecl;
|
||||||
|
|
||||||
|
TQLCLGLWidget_Create = function(parent: QWidgetH; flags: Cardinal): QWidgetH; cdecl;
|
||||||
|
TQLCLGLWidget_Method = procedure(handle: QWidgetH); cdecl;
|
||||||
|
TQLCLGLWidget_override_paintGL = procedure(handle: QWidgetH; hook: TGLWidgetPaintHook); cdecl;
|
||||||
|
TQLCLGLWidget_isValid = function(handle: QWidgetH): ByteBool; cdecl;
|
||||||
|
TQLCLGLWidget_setFormat = procedure(handle: QWidgetH; fmt: QSurfaceFormatH); cdecl;
|
||||||
|
TQLCLGLWidget_setForceOpaque = procedure(handle: QWidgetH; enable: ByteBool); cdecl;
|
||||||
|
TQLCLGLWidget_defaultFBO = function(handle: QWidgetH): Cardinal; cdecl;
|
||||||
|
TQLCLGLWidget_dprF = function(handle: QWidgetH): Double; cdecl;
|
||||||
|
|
||||||
|
var
|
||||||
|
GLWidgetLibTried: boolean = false;
|
||||||
|
GLWidgetLib: TLibHandle = NilHandle;
|
||||||
|
QLCLGLWidget_Create: TQLCLGLWidget_Create = nil;
|
||||||
|
QLCLGLWidget_override_paintGL: TQLCLGLWidget_override_paintGL = nil;
|
||||||
|
QLCLGLWidget_makeCurrent: TQLCLGLWidget_Method = nil;
|
||||||
|
QLCLGLWidget_doneCurrent: TQLCLGLWidget_Method = nil;
|
||||||
|
QLCLGLWidget_isValid: TQLCLGLWidget_isValid = nil;
|
||||||
|
QLCLGLWidget_setFormat: TQLCLGLWidget_setFormat = nil;
|
||||||
|
QLCLGLWidget_setForceOpaque: TQLCLGLWidget_setForceOpaque = nil;
|
||||||
|
QLCLGLWidget_defaultFramebufferObject: TQLCLGLWidget_defaultFBO = nil;
|
||||||
|
QLCLGLWidget_devicePixelRatioF: TQLCLGLWidget_dprF = nil;
|
||||||
|
|
||||||
|
function LoadGLWidgetLib: boolean;
|
||||||
|
|
||||||
|
function TryLoad(const AName: string): boolean;
|
||||||
|
begin
|
||||||
|
GLWidgetLib := LoadLibrary(AName);
|
||||||
|
Result := GLWidgetLib <> NilHandle;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function Need(const AName: string): Pointer;
|
||||||
|
begin
|
||||||
|
Result := GetProcedureAddress(GLWidgetLib, AName);
|
||||||
|
if Result = nil then
|
||||||
|
raise Exception.CreateFmt('%s: missing symbol %s', [GLWidgetLibName, AName]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
if not GLWidgetLibTried then begin
|
||||||
|
GLWidgetLibTried := true;
|
||||||
|
// next to the executable first, then the system library path
|
||||||
|
if TryLoad(ExtractFilePath(ParamStr(0)) + GLWidgetLibName)
|
||||||
|
or TryLoad(GLWidgetLibName) then begin
|
||||||
|
Pointer(QLCLGLWidget_Create) := Need('QLCLGLWidget_Create');
|
||||||
|
Pointer(QLCLGLWidget_override_paintGL) := Need('QLCLGLWidget_override_paintGL');
|
||||||
|
Pointer(QLCLGLWidget_makeCurrent) := Need('QLCLGLWidget_makeCurrent');
|
||||||
|
Pointer(QLCLGLWidget_doneCurrent) := Need('QLCLGLWidget_doneCurrent');
|
||||||
|
Pointer(QLCLGLWidget_isValid) := Need('QLCLGLWidget_isValid');
|
||||||
|
Pointer(QLCLGLWidget_setFormat) := Need('QLCLGLWidget_setFormat');
|
||||||
|
Pointer(QLCLGLWidget_setForceOpaque) := Need('QLCLGLWidget_setForceOpaque');
|
||||||
|
Pointer(QLCLGLWidget_defaultFramebufferObject) := Need('QLCLGLWidget_defaultFramebufferObject');
|
||||||
|
Pointer(QLCLGLWidget_devicePixelRatioF) := Need('QLCLGLWidget_devicePixelRatioF');
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
Result := GLWidgetLib <> NilHandle;
|
||||||
|
end;
|
||||||
|
|
||||||
|
type
|
||||||
|
{ TQtGLWidget }
|
||||||
|
|
||||||
|
TQtGLWidget = class(TQtWidget)
|
||||||
|
protected
|
||||||
|
function CreateWidget(const Params: TCreateParams): QWidgetH; override;
|
||||||
|
procedure paintGL(); cdecl; virtual;
|
||||||
|
public
|
||||||
|
InPaintGL: boolean;
|
||||||
|
function GetContainerWidget: QWidgetH; override;
|
||||||
|
procedure AttachEvents; override;
|
||||||
|
procedure DetachEvents; override;
|
||||||
|
procedure SlotPaintBg({%H-}Sender: QObjectH; {%H-}Event: QEventH); cdecl; override;
|
||||||
|
procedure SlotPaint({%H-}Sender: QObjectH; {%H-}Event: QEventH); cdecl; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TQtGLWidget }
|
||||||
|
|
||||||
|
function TQtGLWidget.CreateWidget(const Params: TCreateParams): QWidgetH;
|
||||||
|
var
|
||||||
|
Parent: QWidgetH;
|
||||||
|
begin
|
||||||
|
if Params.WndParent <> 0 then
|
||||||
|
Parent := TQtWidget(Params.WndParent).GetContainerWidget
|
||||||
|
else
|
||||||
|
Parent := nil;
|
||||||
|
Widget := QLCLGLWidget_Create(Parent, 0);
|
||||||
|
Result := Widget;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TQtGLWidget.GetContainerWidget: QWidgetH;
|
||||||
|
begin
|
||||||
|
Result := Widget;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtGLWidget.AttachEvents;
|
||||||
|
begin
|
||||||
|
QLCLGLWidget_override_paintGL(Widget, @paintGL);
|
||||||
|
inherited AttachEvents;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtGLWidget.DetachEvents;
|
||||||
|
var
|
||||||
|
NilHook: TGLWidgetPaintHook;
|
||||||
|
begin
|
||||||
|
inherited DetachEvents;
|
||||||
|
TMethod(NilHook).Code := nil;
|
||||||
|
TMethod(NilHook).Data := nil;
|
||||||
|
QLCLGLWidget_override_paintGL(Widget, NilHook);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtGLWidget.SlotPaintBg(Sender: QObjectH; Event: QEventH); cdecl;
|
||||||
|
begin
|
||||||
|
// QOpenGLWidget paints itself through paintGL
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtGLWidget.SlotPaint(Sender: QObjectH; Event: QEventH); cdecl;
|
||||||
|
begin
|
||||||
|
// QOpenGLWidget paints itself through paintGL
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TQtGLWidget.paintGL(); cdecl;
|
||||||
|
var
|
||||||
|
Msg: TLMPaint;
|
||||||
|
AStruct: PPaintStruct;
|
||||||
|
B: Boolean;
|
||||||
|
begin
|
||||||
|
// Qt has already made the widget's context current and bound its FBO
|
||||||
|
if not (CanSendLCLMessage and (LCLObject is TWinControl)) then begin
|
||||||
|
DebugLn('TQtGLWidget.paintGL error CanSendLCLMessage=',dbgs(CanSendLCLMessage),
|
||||||
|
' LCLObject=',dbgsName(LCLObject));
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
InPaintGL := true;
|
||||||
|
try
|
||||||
|
FillChar(Msg{%H-}, SizeOf(Msg), #0);
|
||||||
|
Msg.Msg := LM_PAINT;
|
||||||
|
New(AStruct);
|
||||||
|
try
|
||||||
|
try
|
||||||
|
FillChar(AStruct^, SizeOf(TPaintStruct), 0);
|
||||||
|
QWidget_rect(Widget, @AStruct^.rcPaint);
|
||||||
|
AStruct^.hdc := PtrUInt(Widget);
|
||||||
|
Msg.PaintStruct := AStruct;
|
||||||
|
Msg.DC := AStruct^.hdc;
|
||||||
|
LCLObject.WindowProc(TLMessage(Msg));
|
||||||
|
finally
|
||||||
|
Dispose(AStruct);
|
||||||
|
end;
|
||||||
|
except
|
||||||
|
// prevent recursive repainting !
|
||||||
|
B := QtWidgetSet.IsValidHandle(HWND(Self));
|
||||||
|
if B then
|
||||||
|
QWidget_setUpdatesEnabled(Widget, False);
|
||||||
|
try
|
||||||
|
Application.HandleException(nil);
|
||||||
|
finally
|
||||||
|
if B and Assigned(Application) and not Application.Terminated then
|
||||||
|
QWidget_setUpdatesEnabled(Widget, True);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
InPaintGL := false;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
var
|
||||||
|
Widget: TQtGLWidget;
|
||||||
|
Dpr: Double;
|
||||||
|
begin
|
||||||
|
Dpr := 1.0;
|
||||||
|
if (Handle <> 0) and Assigned(QLCLGLWidget_devicePixelRatioF) then begin
|
||||||
|
Widget := TQtGLWidget(Handle);
|
||||||
|
Dpr := QLCLGLWidget_devicePixelRatioF(Widget.Widget);
|
||||||
|
if Dpr <= 0 then Dpr := 1.0;
|
||||||
|
end;
|
||||||
|
glViewport(Round(Left*Dpr), Round(Top*Dpr), Round(Width*Dpr), Round(Height*Dpr));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
var
|
||||||
|
Widget: TQtGLWidget;
|
||||||
|
begin
|
||||||
|
if Handle=0 then
|
||||||
|
RaiseGDBException('LOpenGLSwapBuffers Handle=0');
|
||||||
|
Widget := TQtGLWidget(Handle);
|
||||||
|
// during paintGL Qt swaps/composites the FBO itself after the handler
|
||||||
|
// returns; outside of paint the best we can do is schedule a repaint
|
||||||
|
if not Widget.InPaintGL then
|
||||||
|
QWidget_update(Widget.Widget);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
Widget: TQtGLWidget;
|
||||||
|
begin
|
||||||
|
Result := false;
|
||||||
|
if Handle=0 then
|
||||||
|
RaiseGDBException('LOpenGLMakeCurrent Handle=0');
|
||||||
|
Widget := TQtGLWidget(Handle);
|
||||||
|
if Widget.InPaintGL then
|
||||||
|
exit(true); // Qt already made the context current for paintGL
|
||||||
|
// no context yet before the widget was first realized/shown
|
||||||
|
if not QLCLGLWidget_isValid(Widget.Widget) then
|
||||||
|
exit;
|
||||||
|
QLCLGLWidget_makeCurrent(Widget.Widget);
|
||||||
|
Result := true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
Widget: TQtGLWidget;
|
||||||
|
begin
|
||||||
|
Result := false;
|
||||||
|
if Handle=0 then
|
||||||
|
RaiseGDBException('LOpenGLReleaseContext Handle=0');
|
||||||
|
Widget := TQtGLWidget(Handle);
|
||||||
|
if Widget.InPaintGL then exit; // never unbind Qt's own paint context
|
||||||
|
QLCLGLWidget_doneCurrent(Widget.Widget);
|
||||||
|
Result := true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits, MajorVersion, MinorVersion,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
var
|
||||||
|
NewQtWidget: TQtGLWidget;
|
||||||
|
AFormat: QSurfaceFormatH;
|
||||||
|
begin
|
||||||
|
if WSPrivate=nil then ;
|
||||||
|
if SharedControl<>nil then ; // Qt shares QOpenGLWidget contexts per top-level window
|
||||||
|
if AUXBuffers>0 then ; // not supported by QSurfaceFormat
|
||||||
|
if not LoadGLWidgetLib then
|
||||||
|
raise Exception.Create(GLWidgetLibName+' not found (looked next to the '
|
||||||
|
+'executable and in the system library path). Build it with '
|
||||||
|
+'"make -C csrc" from the LazOpenGLContextEx package.');
|
||||||
|
|
||||||
|
NewQtWidget := TQtGLWidget.Create(AWinControl, AParams);
|
||||||
|
NewQtWidget.HasPaint := false;
|
||||||
|
|
||||||
|
// must be set before the widget is first shown
|
||||||
|
AFormat := QSurfaceFormat_Create();
|
||||||
|
try
|
||||||
|
QSurfaceFormat_setRenderableType(AFormat, QSurfaceFormatRenderableTypeOpenGL);
|
||||||
|
if MajorVersion > 0 then begin
|
||||||
|
QSurfaceFormat_setMajorVersion(AFormat, MajorVersion);
|
||||||
|
QSurfaceFormat_setMinorVersion(AFormat, MinorVersion);
|
||||||
|
end;
|
||||||
|
if DoubleBuffered then
|
||||||
|
QSurfaceFormat_setSwapBehavior(AFormat, QSurfaceSwapBehaviorDoubleBuffer);
|
||||||
|
if RGBA then begin
|
||||||
|
QSurfaceFormat_setRedBufferSize(AFormat, RedBits);
|
||||||
|
QSurfaceFormat_setGreenBufferSize(AFormat, GreenBits);
|
||||||
|
QSurfaceFormat_setBlueBufferSize(AFormat, BlueBits);
|
||||||
|
end;
|
||||||
|
if AlphaBits > 0 then
|
||||||
|
QSurfaceFormat_setAlphaBufferSize(AFormat, AlphaBits);
|
||||||
|
QSurfaceFormat_setDepthBufferSize(AFormat, DepthBits);
|
||||||
|
QSurfaceFormat_setStencilBufferSize(AFormat, StencilBits);
|
||||||
|
if MultiSampling > 1 then
|
||||||
|
QSurfaceFormat_setSamples(AFormat, MultiSampling);
|
||||||
|
QLCLGLWidget_setFormat(NewQtWidget.Widget, AFormat);
|
||||||
|
finally
|
||||||
|
QSurfaceFormat_Destroy(AFormat);
|
||||||
|
end;
|
||||||
|
// legacy GL code leaves arbitrary alpha in the FBO which would make the
|
||||||
|
// widget translucent when Qt composites it; force alpha to 1 unless the
|
||||||
|
// control explicitly asked for an alpha channel
|
||||||
|
QLCLGLWidget_setForceOpaque(NewQtWidget.Widget, AlphaBits = 0);
|
||||||
|
|
||||||
|
NewQtWidget.AttachEvents;
|
||||||
|
Result := HWND(NewQtWidget);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
begin
|
||||||
|
if not AWinControl.HandleAllocated then exit;
|
||||||
|
// the QOpenGLWidget owns its context; it dies with the widget
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
@@ -0,0 +1,699 @@
|
|||||||
|
{
|
||||||
|
*****************************************************************************
|
||||||
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
||||||
|
for details about the license.
|
||||||
|
*****************************************************************************
|
||||||
|
|
||||||
|
Author: Mattias Gaertner
|
||||||
|
|
||||||
|
}
|
||||||
|
unit GLWin32WGLContextEx;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, LMessages, Windows, LCLProc, LCLType, gl, Forms, Controls,
|
||||||
|
Win32Int, WSLCLClasses, WSControls, Win32WSControls, Win32Proc, LCLMessageGlue;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA, DebugContext: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
|
||||||
|
procedure InitWGL(RequireWGL_ARB_create_context : boolean);
|
||||||
|
procedure InitOpenGLContextGLWindowClass;
|
||||||
|
|
||||||
|
|
||||||
|
type
|
||||||
|
TWGLControlInfo = record
|
||||||
|
Window: HWND;
|
||||||
|
DC: HDC;
|
||||||
|
PixelFormat: GLUInt;
|
||||||
|
WGLContext: HGLRC;
|
||||||
|
end;
|
||||||
|
PWGLControlInfo = ^TWGLControlInfo;
|
||||||
|
|
||||||
|
var
|
||||||
|
WGLControlInfoAtom: ATOM = 0;
|
||||||
|
|
||||||
|
function AllocWGLControlInfo(Window: HWND): PWGLControlInfo;
|
||||||
|
function DisposeWGLControlInfo(Window: HWND): boolean;
|
||||||
|
function GetWGLControlInfo(Window: HWND): PWGLControlInfo;
|
||||||
|
|
||||||
|
|
||||||
|
const
|
||||||
|
WGL_SAMPLE_BUFFERS_ARB = $2041;
|
||||||
|
WGL_SAMPLES_ARB = $2042;
|
||||||
|
|
||||||
|
// WGL_ARB_pixel_format
|
||||||
|
WGL_NUMBER_PIXEL_FORMATS_ARB = $2000;
|
||||||
|
WGL_DRAW_TO_WINDOW_ARB = $2001;
|
||||||
|
WGL_DRAW_TO_BITMAP_ARB = $2002;
|
||||||
|
WGL_ACCELERATION_ARB = $2003;
|
||||||
|
WGL_NEED_PALETTE_ARB = $2004;
|
||||||
|
WGL_NEED_SYSTEM_PALETTE_ARB = $2005;
|
||||||
|
WGL_SWAP_LAYER_BUFFERS_ARB = $2006;
|
||||||
|
WGL_SWAP_METHOD_ARB = $2007;
|
||||||
|
WGL_NUMBER_OVERLAYS_ARB = $2008;
|
||||||
|
WGL_NUMBER_UNDERLAYS_ARB = $2009;
|
||||||
|
WGL_TRANSPARENT_ARB = $200A;
|
||||||
|
WGL_TRANSPARENT_RED_VALUE_ARB = $2037;
|
||||||
|
WGL_TRANSPARENT_GREEN_VALUE_ARB = $2038;
|
||||||
|
WGL_TRANSPARENT_BLUE_VALUE_ARB = $2039;
|
||||||
|
WGL_TRANSPARENT_ALPHA_VALUE_ARB = $203A;
|
||||||
|
WGL_TRANSPARENT_INDEX_VALUE_ARB = $203B;
|
||||||
|
WGL_SHARE_DEPTH_ARB = $200C;
|
||||||
|
WGL_SHARE_STENCIL_ARB = $200D;
|
||||||
|
WGL_SHARE_ACCUM_ARB = $200E;
|
||||||
|
WGL_SUPPORT_GDI_ARB = $200F;
|
||||||
|
WGL_SUPPORT_OPENGL_ARB = $2010;
|
||||||
|
WGL_DOUBLE_BUFFER_ARB = $2011;
|
||||||
|
WGL_STEREO_ARB = $2012;
|
||||||
|
WGL_PIXEL_TYPE_ARB = $2013;
|
||||||
|
WGL_COLOR_BITS_ARB = $2014;
|
||||||
|
WGL_RED_BITS_ARB = $2015;
|
||||||
|
WGL_RED_SHIFT_ARB = $2016;
|
||||||
|
WGL_GREEN_BITS_ARB = $2017;
|
||||||
|
WGL_GREEN_SHIFT_ARB = $2018;
|
||||||
|
WGL_BLUE_BITS_ARB = $2019;
|
||||||
|
WGL_BLUE_SHIFT_ARB = $201A;
|
||||||
|
WGL_ALPHA_BITS_ARB = $201B;
|
||||||
|
WGL_ALPHA_SHIFT_ARB = $201C;
|
||||||
|
WGL_ACCUM_BITS_ARB = $201D;
|
||||||
|
WGL_ACCUM_RED_BITS_ARB = $201E;
|
||||||
|
WGL_ACCUM_GREEN_BITS_ARB = $201F;
|
||||||
|
WGL_ACCUM_BLUE_BITS_ARB = $2020;
|
||||||
|
WGL_ACCUM_ALPHA_BITS_ARB = $2021;
|
||||||
|
WGL_DEPTH_BITS_ARB = $2022;
|
||||||
|
WGL_STENCIL_BITS_ARB = $2023;
|
||||||
|
WGL_AUX_BUFFERS_ARB = $2024;
|
||||||
|
WGL_NO_ACCELERATION_ARB = $2025;
|
||||||
|
WGL_GENERIC_ACCELERATION_ARB = $2026;
|
||||||
|
WGL_FULL_ACCELERATION_ARB = $2027;
|
||||||
|
WGL_SWAP_EXCHANGE_ARB = $2028;
|
||||||
|
WGL_SWAP_COPY_ARB = $2029;
|
||||||
|
WGL_SWAP_UNDEFINED_ARB = $202A;
|
||||||
|
WGL_TYPE_RGBA_ARB = $202B;
|
||||||
|
WGL_TYPE_COLORINDEX_ARB = $202C;
|
||||||
|
|
||||||
|
// WGL_NV_float_buffer
|
||||||
|
WGL_FLOAT_COMPONENTS_NV = $20B0;
|
||||||
|
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_R_NV = $20B1;
|
||||||
|
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RG_NV = $20B2;
|
||||||
|
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGB_NV = $20B3;
|
||||||
|
WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGBA_NV = $20B4;
|
||||||
|
WGL_TEXTURE_FLOAT_R_NV = $20B5;
|
||||||
|
WGL_TEXTURE_FLOAT_RG_NV = $20B6;
|
||||||
|
WGL_TEXTURE_FLOAT_RGB_NV = $20B7;
|
||||||
|
WGL_TEXTURE_FLOAT_RGBA_NV = $20B8;
|
||||||
|
|
||||||
|
// WGL_ARB_pbuffer
|
||||||
|
type
|
||||||
|
HPBUFFERARB = Integer;
|
||||||
|
TGLenum = uint;
|
||||||
|
|
||||||
|
const
|
||||||
|
WGL_DRAW_TO_PBUFFER_ARB = $202D;
|
||||||
|
WGL_MAX_PBUFFER_PIXELS_ARB = $202E;
|
||||||
|
WGL_MAX_PBUFFER_WIDTH_ARB = $202F;
|
||||||
|
WGL_MAX_PBUFFER_HEIGHT_ARB = $2030;
|
||||||
|
WGL_PBUFFER_LARGEST_ARB = $2033;
|
||||||
|
WGL_PBUFFER_WIDTH_ARB = $2034;
|
||||||
|
WGL_PBUFFER_HEIGHT_ARB = $2035;
|
||||||
|
WGL_PBUFFER_LOST_ARB = $2036;
|
||||||
|
|
||||||
|
// WGL_ARB_buffer_region
|
||||||
|
WGL_FRONT_COLOR_BUFFER_BIT_ARB = $00000001;
|
||||||
|
WGL_BACK_COLOR_BUFFER_BIT_ARB = $00000002;
|
||||||
|
WGL_DEPTH_BUFFER_BIT_ARB = $00000004;
|
||||||
|
WGL_STENCIL_BUFFER_BIT_ARB = $00000008;
|
||||||
|
|
||||||
|
WGL_CONTEXT_FLAGS_ARB = $2094;
|
||||||
|
WGL_CONTEXT_DEBUG_BIT_ARB = $0001;
|
||||||
|
|
||||||
|
const
|
||||||
|
opengl32 = 'OpenGL32.dll';
|
||||||
|
glu32 = 'GLU32.dll';
|
||||||
|
|
||||||
|
type
|
||||||
|
PWGLSwap = ^TWGLSwap;
|
||||||
|
_WGLSWAP = packed record
|
||||||
|
hdc: HDC;
|
||||||
|
uiFlags: UINT;
|
||||||
|
end;
|
||||||
|
TWGLSwap = _WGLSWAP;
|
||||||
|
WGLSWAP = _WGLSWAP;
|
||||||
|
|
||||||
|
function wglGetProcAddress(ProcName: PChar): Pointer; stdcall; external opengl32;
|
||||||
|
function wglCopyContext(p1: HGLRC; p2: HGLRC; p3: Cardinal): BOOL; stdcall; external opengl32;
|
||||||
|
function wglCreateContext(DC: HDC): HGLRC; stdcall; external opengl32;
|
||||||
|
function wglCreateLayerContext(p1: HDC; p2: Integer): HGLRC; stdcall; external opengl32;
|
||||||
|
function wglDeleteContext(p1: HGLRC): BOOL; stdcall; external opengl32;
|
||||||
|
function wglDescribeLayerPlane(p1: HDC; p2, p3: Integer; p4: Cardinal; var p5: TLayerPlaneDescriptor): BOOL; stdcall; external opengl32;
|
||||||
|
function wglGetCurrentContext: HGLRC; stdcall; external opengl32;
|
||||||
|
function wglGetCurrentDC: HDC; stdcall; external opengl32;
|
||||||
|
function wglGetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32;
|
||||||
|
function wglMakeCurrent(DC: HDC; p2: HGLRC): BOOL; stdcall; external opengl32;
|
||||||
|
function wglRealizeLayerPalette(p1: HDC; p2: Integer; p3: BOOL): BOOL; stdcall; external opengl32;
|
||||||
|
function wglSetLayerPaletteEntries(p1: HDC; p2, p3, p4: Integer; var pcr): Integer; stdcall; external opengl32;
|
||||||
|
function wglShareLists(p1, p2: HGLRC): BOOL; stdcall; external opengl32;
|
||||||
|
function wglSwapLayerBuffers(p1: HDC; p2: Cardinal): BOOL; stdcall; external opengl32;
|
||||||
|
function wglUseFontBitmapsA(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32;
|
||||||
|
function wglUseFontOutlinesA (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32;
|
||||||
|
function wglUseFontBitmapsW(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32;
|
||||||
|
function wglUseFontOutlinesW (p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32;
|
||||||
|
function wglUseFontBitmaps(DC: HDC; p2, p3, p4: DWORD): BOOL; stdcall; external opengl32 name 'wglUseFontBitmapsA';
|
||||||
|
function wglUseFontOutlines(p1: HDC; p2, p3, p4: DWORD; p5, p6: Single; p7: Integer; p8: PGlyphMetricsFloat): BOOL; stdcall; external opengl32 name 'wglUseFontOutlinesA';
|
||||||
|
|
||||||
|
var
|
||||||
|
// WGL Extensions ----------------------------
|
||||||
|
WGL_EXT_swap_control: boolean;
|
||||||
|
WGL_ARB_multisample: boolean;
|
||||||
|
WGL_ARB_extensions_string: boolean;
|
||||||
|
WGL_ARB_pixel_format: boolean;
|
||||||
|
WGL_ARB_pbuffer: boolean;
|
||||||
|
WGL_ARB_buffer_region: boolean;
|
||||||
|
WGL_ATI_pixel_format_float: boolean;
|
||||||
|
|
||||||
|
|
||||||
|
// ARB wgl extensions
|
||||||
|
wglCreateContextAttribsARB : function (DC: HDC; hShareContext:HGLRC; attribList:PInteger ):HGLRC;stdcall;
|
||||||
|
wglGetExtensionsStringARB: function(DC: HDC): PChar; stdcall;
|
||||||
|
wglGetPixelFormatAttribivARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum;
|
||||||
|
const piAttributes: PGLint; piValues : PGLint) : BOOL; stdcall;
|
||||||
|
wglGetPixelFormatAttribfvARB: function(DC: HDC; iPixelFormat, iLayerPlane: Integer; nAttributes: TGLenum;
|
||||||
|
const piAttributes: PGLint; piValues: PGLFloat) : BOOL; stdcall;
|
||||||
|
wglChoosePixelFormatARB: function(DC: HDC; const piAttribIList: PGLint; const pfAttribFList: PGLFloat;
|
||||||
|
nMaxFormats: GLint; piFormats: PGLint; nNumFormats: PGLenum) : BOOL; stdcall;
|
||||||
|
wglCreatePbufferARB: function(DC: HDC; iPixelFormat: Integer; iWidth, iHeight : Integer;
|
||||||
|
const piAttribList: PGLint) : HPBUFFERARB; stdcall;
|
||||||
|
wglGetPbufferDCARB: function(hPbuffer: HPBUFFERARB) : HDC; stdcall;
|
||||||
|
wglReleasePbufferDCARB: function(hPbuffer: HPBUFFERARB; DC: HDC) : Integer; stdcall;
|
||||||
|
wglDestroyPbufferARB: function(hPbuffer: HPBUFFERARB): BOOL; stdcall;
|
||||||
|
wglQueryPbufferARB: function(hPbuffer: HPBUFFERARB; iAttribute : Integer;
|
||||||
|
piValue: PGLint) : BOOL; stdcall;
|
||||||
|
|
||||||
|
wglCreateBufferRegionARB: function(DC: HDC; iLayerPlane: Integer; uType: TGLenum) : Integer; stdcall;
|
||||||
|
wglDeleteBufferRegionARB: procedure(hRegion: Integer); stdcall;
|
||||||
|
wglSaveBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer): BOOL; stdcall;
|
||||||
|
wglRestoreBufferRegionARB: function(hRegion: Integer; x, y, width, height: Integer;
|
||||||
|
xSrc, ySrc: Integer): BOOL; stdcall;
|
||||||
|
|
||||||
|
// non-ARB wgl extensions
|
||||||
|
wglSwapIntervalEXT: function(interval : Integer) : BOOL; stdcall;
|
||||||
|
wglGetSwapIntervalEXT: function : Integer; stdcall;
|
||||||
|
|
||||||
|
var
|
||||||
|
WGLInitialized: boolean = false;
|
||||||
|
OpenGLContextWindowClassInitialized: boolean = false;
|
||||||
|
OpenGLContextWindowClass: WNDCLASS;
|
||||||
|
|
||||||
|
const
|
||||||
|
DefaultOpenGLContextInitAttrList: array [0..0] of LongInt = (
|
||||||
|
0
|
||||||
|
);
|
||||||
|
|
||||||
|
implementation
|
||||||
|
uses glext;
|
||||||
|
|
||||||
|
function GLGetProcAddress(ProcName: PChar):Pointer;
|
||||||
|
begin
|
||||||
|
Result := wglGetProcAddress(ProcName);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLViewport(Handle: HWND; Left, Top, Width, Height: integer);
|
||||||
|
begin
|
||||||
|
glViewport(Left,Top,Width,Height);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLSwapBuffers(Handle: HWND);
|
||||||
|
var
|
||||||
|
Info: PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
Info:=GetWGLControlInfo(Handle);
|
||||||
|
// don't use wglSwapLayerBuffers or wglSwapBuffers!
|
||||||
|
SwapBuffers(Info^.DC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLMakeCurrent(Handle: HWND): boolean;
|
||||||
|
var
|
||||||
|
Info: PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
Info:=GetWGLControlInfo(Handle);
|
||||||
|
Result:=wglMakeCurrent(Info^.DC,Info^.WGLContext);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLReleaseContext(Handle: HWND): boolean;
|
||||||
|
begin
|
||||||
|
Result:=wglMakeCurrent(0,0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GlWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
|
||||||
|
LParam: Windows.LParam): LResult; stdcall;
|
||||||
|
var
|
||||||
|
PaintMsg : TLMPaint;
|
||||||
|
winctrl : TWinControl;
|
||||||
|
begin
|
||||||
|
case Msg of
|
||||||
|
WM_ERASEBKGND: begin
|
||||||
|
Result:=0;
|
||||||
|
end;
|
||||||
|
WM_PAINT: begin
|
||||||
|
winctrl := GetWin32WindowInfo(Window)^.WinControl;
|
||||||
|
if Assigned(winctrl) then begin
|
||||||
|
FillChar(PaintMsg, SizeOf(PaintMsg), 0);
|
||||||
|
PaintMsg.Msg := LM_PAINT;
|
||||||
|
PaintMsg.DC := WParam;
|
||||||
|
DeliverMessage(winctrl, PaintMsg);
|
||||||
|
Result:=PaintMsg.Result;
|
||||||
|
end else
|
||||||
|
Result:=WindowProc(Window, Msg, WParam, LParam);
|
||||||
|
end;
|
||||||
|
else
|
||||||
|
Result:=WindowProc(Window, Msg, WParam, LParam);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
Temp_h_GLRc: HGLRC;
|
||||||
|
Temp_h_Dc: HDC;
|
||||||
|
Temp_h_Wnd: HWND;
|
||||||
|
|
||||||
|
procedure LGlMsDestroyTemporaryWindow; forward;
|
||||||
|
|
||||||
|
procedure LGlMsCreateTemporaryWindow;
|
||||||
|
var
|
||||||
|
PixelFormat: LongInt;
|
||||||
|
pfd: PIXELFORMATDESCRIPTOR;
|
||||||
|
begin
|
||||||
|
Temp_h_Wnd := 0;
|
||||||
|
Temp_h_Dc := 0;
|
||||||
|
Temp_h_GLRc := 0;
|
||||||
|
|
||||||
|
try
|
||||||
|
{ create Temp_H_wnd }
|
||||||
|
Temp_H_wnd := CreateWindowEx(WS_EX_APPWINDOW or WS_EX_WINDOWEDGE,
|
||||||
|
PChar('STATIC'),
|
||||||
|
PChar('temporary window for wgl'),
|
||||||
|
WS_OVERLAPPEDWINDOW or WS_CLIPSIBLINGS or WS_CLIPCHILDREN,
|
||||||
|
0, 0, 100, 100,
|
||||||
|
0 { no parent window }, 0 { no menu }, hInstance,
|
||||||
|
nil);
|
||||||
|
if Temp_H_wnd=0 then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow CreateWindowEx failed');
|
||||||
|
|
||||||
|
{ create Temp_h_Dc }
|
||||||
|
Temp_h_Dc := GetDC(Temp_h_Wnd);
|
||||||
|
if Temp_h_Dc=0 then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow GetDC failed');
|
||||||
|
|
||||||
|
{ create and set PixelFormat (must support OpenGL to be able to
|
||||||
|
later do wglCreateContext) }
|
||||||
|
FillChar(pfd, SizeOf(pfd), 0);
|
||||||
|
with pfd do
|
||||||
|
begin
|
||||||
|
nSize := SizeOf(pfd);
|
||||||
|
nVersion := 1;
|
||||||
|
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
|
||||||
|
iPixelType := PFD_TYPE_RGBA;
|
||||||
|
iLayerType := PFD_MAIN_PLANE;
|
||||||
|
end;
|
||||||
|
PixelFormat := ChoosePixelFormat(Temp_h_Dc, @pfd);
|
||||||
|
if PixelFormat = 0 then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow ChoosePixelFormat failed');
|
||||||
|
|
||||||
|
if not SetPixelFormat(Temp_h_Dc, PixelFormat, @pfd) then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow SetPixelFormat failed');
|
||||||
|
|
||||||
|
{ create and make current Temp_h_GLRc }
|
||||||
|
Temp_h_GLRc := wglCreateContext(Temp_h_Dc);
|
||||||
|
if Temp_h_GLRc = 0 then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow wglCreateContext failed');
|
||||||
|
|
||||||
|
if not wglMakeCurrent(Temp_h_Dc, Temp_h_GLRc) then
|
||||||
|
raise Exception.Create('LGlMsCreateTemporaryWindow wglMakeCurrent failed');
|
||||||
|
except
|
||||||
|
{ make sure to finalize all partially initialized window parts }
|
||||||
|
LGlMsDestroyTemporaryWindow;
|
||||||
|
raise;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LGlMsDestroyTemporaryWindow;
|
||||||
|
begin
|
||||||
|
if Temp_h_GLRc <> 0 then
|
||||||
|
begin
|
||||||
|
wglMakeCurrent(Temp_h_Dc, 0);
|
||||||
|
wglDeleteContext(Temp_h_GLRc);
|
||||||
|
Temp_h_GLRc := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Temp_h_Dc <> 0 then
|
||||||
|
begin
|
||||||
|
ReleaseDC(Temp_h_Wnd, Temp_h_Dc);
|
||||||
|
Temp_h_Dc := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Temp_h_Wnd <> 0 then
|
||||||
|
begin
|
||||||
|
DestroyWindow(Temp_h_Wnd);
|
||||||
|
Temp_h_Wnd := 0;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LGlMsCreateOpenGLContextAttrList(DoubleBuffered: boolean; RGBA: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits,
|
||||||
|
StencilBits, AUXBuffers: Cardinal): PInteger;
|
||||||
|
var
|
||||||
|
p: integer;
|
||||||
|
|
||||||
|
procedure Add(i: integer);
|
||||||
|
begin
|
||||||
|
if Result<>nil then
|
||||||
|
Result[p]:=i;
|
||||||
|
inc(p);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure CreateList;
|
||||||
|
begin
|
||||||
|
Add(WGL_DRAW_TO_WINDOW_ARB); Add(GL_TRUE);
|
||||||
|
Add(WGL_SUPPORT_OPENGL_ARB); Add(GL_TRUE);
|
||||||
|
Add(WGL_ACCELERATION_ARB); Add(WGL_FULL_ACCELERATION_ARB);
|
||||||
|
if DoubleBuffered then
|
||||||
|
begin Add(WGL_DOUBLE_BUFFER_ARB); Add(GL_TRUE); end;
|
||||||
|
Add(WGL_PIXEL_TYPE_ARB);
|
||||||
|
if RGBA then
|
||||||
|
Add(WGL_TYPE_RGBA_ARB)
|
||||||
|
else
|
||||||
|
Add(WGL_TYPE_COLORINDEX_ARB);
|
||||||
|
|
||||||
|
Add(WGL_RED_BITS_ARB); Add(RedBits);
|
||||||
|
Add(WGL_GREEN_BITS_ARB); Add(GreenBits);
|
||||||
|
Add(WGL_BLUE_BITS_ARB); Add(BlueBits);
|
||||||
|
Add(WGL_COLOR_BITS_ARB); Add(RedBits+GreenBits+BlueBits);
|
||||||
|
Add(WGL_ALPHA_BITS_ARB); Add(AlphaBits);
|
||||||
|
Add(WGL_DEPTH_BITS_ARB); Add(DepthBits);
|
||||||
|
Add(WGL_STENCIL_BITS_ARB); Add(StencilBits);
|
||||||
|
Add(WGL_AUX_BUFFERS_ARB); Add(AUXBuffers);
|
||||||
|
if MultiSampling > 1 then
|
||||||
|
begin
|
||||||
|
Add(WGL_SAMPLE_BUFFERS_ARB); Add(1);
|
||||||
|
Add(WGL_SAMPLES_ARB); Add(MultiSampling);
|
||||||
|
end;
|
||||||
|
Add(0); Add(0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Result:=nil;
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
GetMem(Result,SizeOf(integer)*p);
|
||||||
|
p:=0;
|
||||||
|
CreateList;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LOpenGLCreateContext(AWinControl: TWinControl;
|
||||||
|
WSPrivate: TWSPrivateClass; SharedControl: TWinControl;
|
||||||
|
DoubleBuffered, RGBA, DebugContext: boolean;
|
||||||
|
const RedBits, GreenBits, BlueBits,
|
||||||
|
MultiSampling, AlphaBits, DepthBits, StencilBits, AUXBuffers: Cardinal;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
var
|
||||||
|
Params: TCreateWindowExParams;
|
||||||
|
pfd: PIXELFORMATDESCRIPTOR;
|
||||||
|
Info, SharedInfo: PWGLControlInfo;
|
||||||
|
|
||||||
|
ReturnedFormats: UINT;
|
||||||
|
VisualAttrList: PInteger;
|
||||||
|
VisualAttrFloat: array [0..1] of Single;
|
||||||
|
MsInitSuccess: WINBOOL;
|
||||||
|
FailReason : string;
|
||||||
|
attribList : array [0..2] of Integer;
|
||||||
|
begin
|
||||||
|
InitWGL( DebugContext );
|
||||||
|
//InitOpenGLContextGLWindowClass;
|
||||||
|
|
||||||
|
// general initialization of Params
|
||||||
|
PrepareCreateWindow(AWinControl, AParams, Params);
|
||||||
|
// customization of Params
|
||||||
|
with Params do begin
|
||||||
|
pClassName := @ClsName;
|
||||||
|
WindowTitle := StrCaption;
|
||||||
|
SubClassWndProc := @GlWindowProc;
|
||||||
|
end;
|
||||||
|
// create window
|
||||||
|
FinishCreateWindow(AWinControl, Params, false);
|
||||||
|
Result := Params.Window;
|
||||||
|
|
||||||
|
// create info
|
||||||
|
Info:=AllocWGLControlInfo(Result);
|
||||||
|
|
||||||
|
// create device context
|
||||||
|
Info^.DC := GetDC(Result);
|
||||||
|
if Info^.DC=0 then
|
||||||
|
raise Exception.Create('LOpenGLCreateContext GetDC failed');
|
||||||
|
|
||||||
|
// get pixelformat
|
||||||
|
FillChar(pfd,SizeOf(pfd),0);
|
||||||
|
with pfd do begin
|
||||||
|
nSize:=sizeOf(pfd);
|
||||||
|
nVersion:=1;
|
||||||
|
dwFlags:=PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
|
||||||
|
if DoubleBuffered then
|
||||||
|
dwFlags:=dwFlags or PFD_DOUBLEBUFFER;
|
||||||
|
if RGBA then
|
||||||
|
iPixelType:=PFD_TYPE_RGBA
|
||||||
|
else
|
||||||
|
iPixelType:=PFD_TYPE_COLORINDEX;
|
||||||
|
cColorBits:=RedBits+GreenBits+BlueBits; // color depth
|
||||||
|
cRedBits:=RedBits;
|
||||||
|
cGreenBits:=GreenBits;
|
||||||
|
cBlueBits:=BlueBits;
|
||||||
|
cAlphaBits:=AlphaBits;
|
||||||
|
cDepthBits:=DepthBits; // Z-Buffer
|
||||||
|
cStencilBits:=StencilBits;
|
||||||
|
cAuxBuffers:=AUXBuffers;
|
||||||
|
iLayerType:=PFD_MAIN_PLANE;
|
||||||
|
end;
|
||||||
|
|
||||||
|
MsInitSuccess := false;
|
||||||
|
if (MultiSampling > 1) and WGL_ARB_multisample and WGL_ARB_pixel_format
|
||||||
|
and Assigned(wglChoosePixelFormatARB) then
|
||||||
|
begin
|
||||||
|
VisualAttrList := LGlMsCreateOpenGLContextAttrList(DoubleBuffered, RGBA,
|
||||||
|
RedBits, GreenBits, BlueBits, MultiSampling, AlphaBits, DepthBits,
|
||||||
|
StencilBits, AUXBuffers);
|
||||||
|
try
|
||||||
|
FillChar(VisualAttrFloat, SizeOf(VisualAttrFloat), 0);
|
||||||
|
MsInitSuccess := wglChoosePixelFormatARB(Info^.DC, PGLint(VisualAttrList),
|
||||||
|
@VisualAttrFloat[0], 1, @Info^.PixelFormat, @ReturnedFormats);
|
||||||
|
finally FreeMem(VisualAttrList) end;
|
||||||
|
|
||||||
|
if MsInitSuccess and (ReturnedFormats >= 1) then
|
||||||
|
SetPixelFormat(Info^.DC, Info^.PixelFormat, nil)
|
||||||
|
else
|
||||||
|
MsInitSuccess := false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if not MsInitSuccess then
|
||||||
|
begin
|
||||||
|
Info^.PixelFormat:=ChoosePixelFormat(Info^.DC,@pfd);
|
||||||
|
if Info^.PixelFormat=0 then
|
||||||
|
raise Exception.Create('LOpenGLCreateContext ChoosePixelFormat failed');
|
||||||
|
|
||||||
|
// set pixel format in device context
|
||||||
|
if not SetPixelFormat(Info^.DC,Info^.PixelFormat,@pfd) then
|
||||||
|
raise Exception.Create('LOpenGLCreateContext SetPixelFormat failed');
|
||||||
|
end;
|
||||||
|
|
||||||
|
// create WGL context
|
||||||
|
Info^.WGLContext:=0;
|
||||||
|
if not DebugContext then
|
||||||
|
begin
|
||||||
|
Info^.WGLContext:=wglCreateContext(Info^.DC);
|
||||||
|
FailReason:='wglCreateContext failed';
|
||||||
|
end
|
||||||
|
else if wglCreateContextAttribsARB = nil then
|
||||||
|
begin
|
||||||
|
FailReason:='wglCreateContextAttribsARB not supported';
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
// try to create debug context
|
||||||
|
attribList[0]:=WGL_CONTEXT_FLAGS_ARB;
|
||||||
|
attribList[1]:=WGL_CONTEXT_DEBUG_BIT_ARB;
|
||||||
|
attribList[2]:=0;
|
||||||
|
Info^.WGLContext:=wglCreateContextAttribsARB(Info^.DC, 0, @attribList);
|
||||||
|
FailReason:='wglCreateContextAttribsARB failed';
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Info^.WGLContext=0 then
|
||||||
|
raise Exception.CreateFmt('LOpenGLCreateContext: %s', [FailReason]);
|
||||||
|
|
||||||
|
// share context objects
|
||||||
|
if Assigned(SharedControl) then begin
|
||||||
|
SharedInfo:=GetWGLControlInfo(SharedControl.Handle);
|
||||||
|
if Assigned(SharedInfo) then wglShareLists(SharedInfo^.WGLContext, Info^.WGLContext);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure LOpenGLDestroyContextInfo(AWinControl: TWinControl);
|
||||||
|
var
|
||||||
|
Info: PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
if not AWinControl.HandleAllocated then exit;
|
||||||
|
Info:=GetWGLControlInfo(AWinControl.Handle);
|
||||||
|
if Info=nil then exit;
|
||||||
|
if wglMakeCurrent(Info^.DC,Info^.WGLContext) then begin
|
||||||
|
wglDeleteContext(Info^.WGLContext);
|
||||||
|
Info^.WGLContext:=0;
|
||||||
|
end;
|
||||||
|
if (Info^.DC<>0) then begin
|
||||||
|
ReleaseDC(Info^.Window,Info^.DC);
|
||||||
|
end;
|
||||||
|
DisposeWGLControlInfo(Info^.Window);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure InitWGL( RequireWGL_ARB_create_context : boolean );
|
||||||
|
var
|
||||||
|
Buffer: string;
|
||||||
|
|
||||||
|
// Checks if the given Extension string is in Buffer.
|
||||||
|
function CheckExtension(const extension : String) : Boolean;
|
||||||
|
begin
|
||||||
|
Result:=(Pos(extension, Buffer)>0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
if WGLInitialized then exit;
|
||||||
|
WGLInitialized:=true;
|
||||||
|
|
||||||
|
try
|
||||||
|
{ to successfully use wglGetExtensionsStringARB (to query e.g. ARB_multisample,
|
||||||
|
needed for MultiSampling), you need to have OpenGL context
|
||||||
|
already initialized. We create a temporary window for this purpose. }
|
||||||
|
LGlMsCreateTemporaryWindow;
|
||||||
|
|
||||||
|
if wglGetCurrentContext() = 0 then
|
||||||
|
raise Exception.Create('Context is not active');
|
||||||
|
|
||||||
|
// ARB wgl extensions
|
||||||
|
Pointer(wglCreateContextAttribsARB) := GLGetProcAddress('wglCreateContextAttribsARB');
|
||||||
|
Pointer(wglGetExtensionsStringARB) := GLGetProcAddress('wglGetExtensionsStringARB');
|
||||||
|
Pointer(wglGetPixelFormatAttribivARB) := GLGetProcAddress('wglGetPixelFormatAttribivARB');
|
||||||
|
Pointer(wglGetPixelFormatAttribfvARB) := GLGetProcAddress('wglGetPixelFormatAttribfvARB');
|
||||||
|
Pointer(wglChoosePixelFormatARB) := GLGetProcAddress('wglChoosePixelFormatARB');
|
||||||
|
|
||||||
|
Pointer(wglCreatePbufferARB) := GLGetProcAddress('wglCreatePbufferARB');
|
||||||
|
Pointer(wglGetPbufferDCARB) := GLGetProcAddress('wglGetPbufferDCARB');
|
||||||
|
Pointer(wglReleasePbufferDCARB) := GLGetProcAddress('wglReleasePbufferDCARB');
|
||||||
|
Pointer(wglDestroyPbufferARB) := GLGetProcAddress('wglDestroyPbufferARB');
|
||||||
|
Pointer(wglQueryPbufferARB) := GLGetProcAddress('wglQueryPbufferARB');
|
||||||
|
|
||||||
|
Pointer(wglCreateBufferRegionARB) := GLGetProcAddress('wglCreateBufferRegionARB');
|
||||||
|
Pointer(wglDeleteBufferRegionARB) := GLGetProcAddress('wglDeleteBufferRegionARB');
|
||||||
|
Pointer(wglSaveBufferRegionARB) := GLGetProcAddress('wglSaveBufferRegionARB');
|
||||||
|
Pointer(wglRestoreBufferRegionARB) := GLGetProcAddress('wglRestoreBufferRegionARB');
|
||||||
|
|
||||||
|
// -EGG- ----------------------------
|
||||||
|
Pointer(wglSwapIntervalEXT) := GLGetProcAddress('wglSwapIntervalEXT');
|
||||||
|
Pointer(wglGetSwapIntervalEXT) := GLGetProcAddress('wglGetSwapIntervalEXT');
|
||||||
|
|
||||||
|
// ARB wgl extensions
|
||||||
|
if Assigned(wglGetExtensionsStringARB) then
|
||||||
|
begin
|
||||||
|
Buffer:=wglGetExtensionsStringARB(Temp_h_Dc);
|
||||||
|
{ Writeln('WGL extensions supported: ', Buffer); }
|
||||||
|
end else
|
||||||
|
Buffer:='';
|
||||||
|
WGL_ARB_multisample:=CheckExtension('WGL_ARB_multisample');
|
||||||
|
WGL_EXT_swap_control:=CheckExtension('WGL_EXT_swap_control');
|
||||||
|
WGL_ARB_buffer_region:=CheckExtension('WGL_ARB_buffer_region');
|
||||||
|
WGL_ARB_extensions_string:=CheckExtension('WGL_ARB_extensions_string');
|
||||||
|
WGL_ARB_pbuffer:=CheckExtension('WGL_ARB_pbuffer ');
|
||||||
|
WGL_ARB_pixel_format:=CheckExtension('WGL_ARB_pixel_format');
|
||||||
|
WGL_ATI_pixel_format_float:=CheckExtension('WGL_ATI_pixel_format_float');
|
||||||
|
except
|
||||||
|
on E: Exception do begin
|
||||||
|
DebugLn('InitWGL ',E.Message);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
try
|
||||||
|
if RequireWGL_ARB_create_context then
|
||||||
|
begin
|
||||||
|
if wglGetExtensionsStringARB = nil then
|
||||||
|
raise Exception.Create('InitWGL : wglGetExtensionsStringARB = nil');
|
||||||
|
if not CheckExtension('WGL_ARB_create_context') then
|
||||||
|
begin
|
||||||
|
raise Exception.CreateFmt('InitWGL : WGL_ARB_create_context not found. Version %s Renderer=%s'
|
||||||
|
+ sLineBreak + 'Extensions found:' + sLineBreak + '%s',
|
||||||
|
[String(glGetString(GL_VERSION)), String(glGetString(GL_RENDERER)), Buffer]);
|
||||||
|
end;
|
||||||
|
if wglCreateContextAttribsARB = nil then
|
||||||
|
raise Exception.Create('InitWGL : wglCreateContextAttribsARB = nil');
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
LGlMsDestroyTemporaryWindow;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure InitOpenGLContextGLWindowClass;
|
||||||
|
begin
|
||||||
|
if OpenGLContextWindowClassInitialized then exit;
|
||||||
|
OpenGLContextWindowClassInitialized:=true;
|
||||||
|
with OpenGLContextWindowClass do begin
|
||||||
|
style:=CS_HREDRAW or CS_VREDRAW or CS_OWNDC;// Redraw On Move, And Own DC For Window
|
||||||
|
lpfnWndProc := @WindowProc; // WndProc Handles Messages
|
||||||
|
cbClsExtra := 0; // No Extra Window Data
|
||||||
|
cbWndExtra := 0; // No Extra Window Data
|
||||||
|
hInstance := System.HInstance; // Set The Instance
|
||||||
|
hIcon := LoadIcon(NULL, IDI_WINLOGO);// Load The Default Icon
|
||||||
|
hCursor := LoadCursor(NULL, IDC_ARROW);// Load The Arrow Pointer
|
||||||
|
hbrBackground:= NULL; // No Background Required For GL
|
||||||
|
lpszMenuName := nil; // We Don't Want A Menu
|
||||||
|
lpszClassName:= 'LazOpenGLContext'; // Set The Class Name
|
||||||
|
end;
|
||||||
|
if RegisterClass(@OpenGLContextWindowClass)=0 then
|
||||||
|
raise Exception.Create('registering OpenGLContextWindowClass failed');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function AllocWGLControlInfo(Window: HWND): PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
New(Result);
|
||||||
|
FillChar(Result^, sizeof(Result^), 0);
|
||||||
|
Result^.Window := Window;
|
||||||
|
if WGLControlInfoAtom=0 then
|
||||||
|
WGLControlInfoAtom := Windows.GlobalAddAtom('WGLControlInfo');
|
||||||
|
Windows.SetProp(Window, PChar(PtrUInt(WGLControlInfoAtom)), PtrUInt(Result));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function DisposeWGLControlInfo(Window: HWND): boolean;
|
||||||
|
var
|
||||||
|
Info: PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
Info := PWGLControlInfo(Windows.GetProp(Window,
|
||||||
|
PChar(PtrUInt(WGLControlInfoAtom))));
|
||||||
|
Result := Windows.RemoveProp(Window, PChar(PtrUInt(WGLControlInfoAtom)))<>0;
|
||||||
|
if Result then begin
|
||||||
|
Dispose(Info);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetWGLControlInfo(Window: HWND): PWGLControlInfo;
|
||||||
|
begin
|
||||||
|
Result:=PWGLControlInfo(Windows.GetProp(Window,
|
||||||
|
PChar(PtrUInt(WGLControlInfoAtom))));
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
@@ -0,0 +1,69 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<Package Version="4">
|
||||||
|
<Name Value="LazOpenGLContextEx"/>
|
||||||
|
<Type Value="RunAndDesignTime"/>
|
||||||
|
<AddToProjectUsesSection Value="True"/>
|
||||||
|
<Author Value="Mattias Gaertner (original), Vladimir (Qt native backend)"/>
|
||||||
|
<CompilerOptions>
|
||||||
|
<Version Value="11"/>
|
||||||
|
<SearchPaths>
|
||||||
|
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/$(LCLWidgetType)"/>
|
||||||
|
</SearchPaths>
|
||||||
|
<Conditionals Value="if LCLWidgetType='cocoa' then begin
|
||||||
|
UsageLinkerOptions := ' -framework OpenGL'
|
||||||
|
+' ''-dylib_file'' ''/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib''';
|
||||||
|
end;"/>
|
||||||
|
</CompilerOptions>
|
||||||
|
<Description Value="Cross-platform OpenGL control. Fork of LazOpenGLContext with a Qt5/Qt6 backend on top of QOpenGLWidget: works on Wayland and with the Qt widgetset on Windows/macOS."/>
|
||||||
|
<License Value="modified LGPL-2"/>
|
||||||
|
<Version Release="1"/>
|
||||||
|
<Files Count="6">
|
||||||
|
<Item1>
|
||||||
|
<Filename Value="openglcontextex.pas"/>
|
||||||
|
<HasRegisterProc Value="True"/>
|
||||||
|
<UnitName Value="OpenGLContextEx"/>
|
||||||
|
</Item1>
|
||||||
|
<Item2>
|
||||||
|
<Filename Value="glgtkglxcontextex.pas"/>
|
||||||
|
<AddToUsesPkgSection Value="False"/>
|
||||||
|
<UnitName Value="GLGtkGlxContextEx"/>
|
||||||
|
</Item2>
|
||||||
|
<Item3>
|
||||||
|
<Filename Value="glgtk3glxcontextex.pas"/>
|
||||||
|
<AddToUsesPkgSection Value="False"/>
|
||||||
|
<UnitName Value="GLGtk3GlxContextEx"/>
|
||||||
|
</Item3>
|
||||||
|
<Item4>
|
||||||
|
<Filename Value="glwin32wglcontextex.pas"/>
|
||||||
|
<AddToUsesPkgSection Value="False"/>
|
||||||
|
<UnitName Value="GLWin32WGLContextEx"/>
|
||||||
|
</Item4>
|
||||||
|
<Item5>
|
||||||
|
<Filename Value="glcocoanscontextex.pas"/>
|
||||||
|
<AddToUsesPkgSection Value="False"/>
|
||||||
|
<UnitName Value="GLCocoaNSContextEx"/>
|
||||||
|
</Item5>
|
||||||
|
<Item6>
|
||||||
|
<Filename Value="glqtnativecontext.pas"/>
|
||||||
|
<AddToUsesPkgSection Value="False"/>
|
||||||
|
<UnitName Value="GLQtNativeContext"/>
|
||||||
|
</Item6>
|
||||||
|
</Files>
|
||||||
|
<RequiredPkgs Count="2">
|
||||||
|
<Item1>
|
||||||
|
<PackageName Value="FCL"/>
|
||||||
|
<MinVersion Major="1" Valid="True"/>
|
||||||
|
</Item1>
|
||||||
|
<Item2>
|
||||||
|
<PackageName Value="LCL"/>
|
||||||
|
</Item2>
|
||||||
|
</RequiredPkgs>
|
||||||
|
<UsageOptions>
|
||||||
|
<UnitPath Value="$(PkgOutDir)"/>
|
||||||
|
</UsageOptions>
|
||||||
|
<PublishOptions>
|
||||||
|
<Version Value="2"/>
|
||||||
|
</PublishOptions>
|
||||||
|
</Package>
|
||||||
|
</CONFIG>
|
||||||
@@ -0,0 +1,22 @@
|
|||||||
|
{ This file was automatically created by Lazarus. Do not edit!
|
||||||
|
This source is only used to compile and install the package.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit LazOpenGLContextEx;
|
||||||
|
|
||||||
|
{$warn 5023 off : no warning about unused units}
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
OpenGLContextEx, LazarusPackageIntf;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
RegisterUnit('OpenGLContextEx', @OpenGLContextEx.Register);
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterPackage('LazOpenGLContextEx', @Register);
|
||||||
|
end.
|
||||||
@@ -0,0 +1,748 @@
|
|||||||
|
{
|
||||||
|
*****************************************************************************
|
||||||
|
See the file COPYING.modifiedLGPL.txt, included in this distribution,
|
||||||
|
for details about the license.
|
||||||
|
*****************************************************************************
|
||||||
|
|
||||||
|
Author: Mattias Gaertner
|
||||||
|
|
||||||
|
Abstract:
|
||||||
|
TOpenGLControl is a LCL control with an opengl context.
|
||||||
|
Fork of the stock LazOpenGLContext package where the Qt5/Qt6 backend
|
||||||
|
uses the widget's own QOpenGLWidget context (GLQtNativeContext) instead
|
||||||
|
of GLX, so it works on Wayland and with the Qt widgetset on Windows and
|
||||||
|
macOS as well.
|
||||||
|
Supported: gtk2/gtk3 (glx), win32 (wgl), cocoa, qt5/qt6 (QOpenGLWidget).
|
||||||
|
}
|
||||||
|
unit OpenGLContextEx;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
// choose the right backend depending on used LCL widgetset
|
||||||
|
{$IFDEF LCLGTK2}
|
||||||
|
{$IF defined(Linux) or defined(FreeBSD)}
|
||||||
|
{$DEFINE UseGtk2GLX}
|
||||||
|
{$DEFINE UsesModernGL}
|
||||||
|
{$DEFINE HasRGBA}
|
||||||
|
{$DEFINE HasRGBBits}
|
||||||
|
{$DEFINE HasDebugContext}
|
||||||
|
{$DEFINE OpenGLTargetDefined}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF LCLGTK3}
|
||||||
|
{$IF defined(Linux) or defined(FreeBSD)}
|
||||||
|
{$DEFINE UseGtk3GLX}
|
||||||
|
{$DEFINE UsesModernGL}
|
||||||
|
{$DEFINE HasRGBA}
|
||||||
|
{$DEFINE HasRGBBits}
|
||||||
|
{$DEFINE HasDebugContext}
|
||||||
|
{$DEFINE OpenGLTargetDefined}
|
||||||
|
{$ENDIF}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF LCLCocoa}
|
||||||
|
{$DEFINE UseCocoaNS}
|
||||||
|
{$DEFINE UsesModernGL}
|
||||||
|
{$DEFINE OpenGLTargetDefined}
|
||||||
|
{$DEFINE HasMacRetinaMode}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF LCLWin32}
|
||||||
|
{$DEFINE UseWin32WGL}
|
||||||
|
{$DEFINE HasRGBA}
|
||||||
|
{$DEFINE HasRGBBits}
|
||||||
|
{$DEFINE HasDebugContext}
|
||||||
|
{$DEFINE OpenGLTargetDefined}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IF DEFINED(LCLQT5) OR DEFINED(LCLQt6)}
|
||||||
|
{$DEFINE UseQtNative}
|
||||||
|
{$DEFINE UsesModernGL}
|
||||||
|
{$DEFINE HasRGBA}
|
||||||
|
{$DEFINE HasRGBBits}
|
||||||
|
{$DEFINE OpenGLTargetDefined}
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFNDEF OpenGLTargetDefined}
|
||||||
|
{$ERROR this LCL widgetset/OS is not yet supported}
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils,
|
||||||
|
// LCL
|
||||||
|
LCLType, LCLIntf, LResources, Forms, Controls, Graphics, LMessages,
|
||||||
|
WSLCLClasses, WSControls,
|
||||||
|
{$IFDEF UseGtk2GLX}
|
||||||
|
GLGtkGlxContextEx;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UseGtk3GLX}
|
||||||
|
GLGtk3GlxContextEx;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UseCocoaNS}
|
||||||
|
GLCocoaNSContextEx;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UseWin32WGL}
|
||||||
|
GLWin32WGLContextEx;
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UseQtNative}
|
||||||
|
GLQtNativeContext;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
const
|
||||||
|
DefaultDepthBits = 24;
|
||||||
|
|
||||||
|
type
|
||||||
|
TOpenGlCtrlMakeCurrentEvent = procedure(Sender: TObject;
|
||||||
|
var Allow: boolean) of object;
|
||||||
|
|
||||||
|
TOpenGLControlOption = (ocoMacRetinaMode, ocoRenderAtDesignTime);
|
||||||
|
TOpenGLControlOptions = set of TOpenGLControlOption;
|
||||||
|
|
||||||
|
{ TCustomOpenGLControl }
|
||||||
|
{ Sharing:
|
||||||
|
You can share opengl contexts. For example:
|
||||||
|
Assume OpenGLControl2 and OpenGLControl3 should share the same as
|
||||||
|
OpenGLControl1. Then set
|
||||||
|
|
||||||
|
OpenGLControl2.SharedControl:=OpenGLControl1;
|
||||||
|
OpenGLControl3.SharedControl:=OpenGLControl1;
|
||||||
|
|
||||||
|
After this OpenGLControl1.SharingControlCount will be two and
|
||||||
|
OpenGLControl1.SharingControls will contain OpenGLControl2 and
|
||||||
|
OpenGLControl3.
|
||||||
|
}
|
||||||
|
|
||||||
|
TCustomOpenGLControl = class(TWinControl)
|
||||||
|
private
|
||||||
|
FAutoResizeViewport: boolean;
|
||||||
|
FCanvas: TCanvas; // only valid at designtime
|
||||||
|
FDebugContext: boolean;
|
||||||
|
FFrameDiffTime: integer;
|
||||||
|
FOnMakeCurrent: TOpenGlCtrlMakeCurrentEvent;
|
||||||
|
FOnPaint: TNotifyEvent;
|
||||||
|
FCurrentFrameTime: integer; // in msec
|
||||||
|
FLastFrameTime: integer; // in msec
|
||||||
|
fOpenGLMajorVersion: Cardinal;
|
||||||
|
fOpenGLMinorVersion: Cardinal;
|
||||||
|
FRGBA: boolean;
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
FRedBits, FGreenBits, FBlueBits,
|
||||||
|
{$ENDIF}
|
||||||
|
FMultiSampling, FAlphaBits, FDepthBits, FStencilBits, FAUXBuffers: Cardinal;
|
||||||
|
FSharedOpenGLControl: TCustomOpenGLControl;
|
||||||
|
FSharingOpenGlControls: TList;
|
||||||
|
FOptions: TOpenGLControlOptions;
|
||||||
|
function GetSharingControls(Index: integer): TCustomOpenGLControl;
|
||||||
|
procedure SetAutoResizeViewport(const AValue: boolean);
|
||||||
|
procedure SetDebugContext(AValue: boolean);
|
||||||
|
procedure SetOpenGLMajorVersion(AValue: Cardinal);
|
||||||
|
procedure SetOpenGLMinorVersion(AValue: Cardinal);
|
||||||
|
procedure SetOptions(AValue: TOpenGLControlOptions);
|
||||||
|
procedure SetRGBA(const AValue: boolean);
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
procedure SetRedBits(const AValue: Cardinal);
|
||||||
|
procedure SetGreenBits(const AValue: Cardinal);
|
||||||
|
procedure SetBlueBits(const AValue: Cardinal);
|
||||||
|
{$ENDIF}
|
||||||
|
procedure SetMultiSampling(const AMultiSampling: Cardinal);
|
||||||
|
procedure SetAlphaBits(const AValue: Cardinal);
|
||||||
|
procedure SetDepthBits(const AValue: Cardinal);
|
||||||
|
procedure SetStencilBits(const AValue: Cardinal);
|
||||||
|
procedure SetAUXBuffers(const AValue: Cardinal);
|
||||||
|
procedure SetSharedControl(const AValue: TCustomOpenGLControl);
|
||||||
|
function IsOpenGLRenderAllowed: boolean;
|
||||||
|
protected
|
||||||
|
class procedure WSRegisterClass; override;
|
||||||
|
procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
|
||||||
|
procedure WMSize(var Message: TLMSize); message LM_SIZE;
|
||||||
|
procedure DestroyWnd; override;
|
||||||
|
procedure UpdateFrameTimeDiff;
|
||||||
|
procedure OpenGLAttributesChanged;
|
||||||
|
procedure CMDoubleBufferedChanged(var Message: TLMessage); message CM_DOUBLEBUFFEREDCHANGED;
|
||||||
|
public
|
||||||
|
constructor Create(TheOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
Procedure Paint; virtual;
|
||||||
|
procedure RealizeBounds; override;
|
||||||
|
procedure DoOnPaint; virtual;
|
||||||
|
procedure SwapBuffers; virtual;
|
||||||
|
function MakeCurrent(SaveOldToStack: boolean = false): boolean; virtual;
|
||||||
|
function ReleaseContext: boolean; virtual;
|
||||||
|
function RestoreOldOpenGLControl: boolean;
|
||||||
|
function SharingControlCount: integer;
|
||||||
|
property SharingControls[Index: integer]: TCustomOpenGLControl read GetSharingControls;
|
||||||
|
procedure Invalidate; override;
|
||||||
|
procedure EraseBackground(DC: HDC); override;
|
||||||
|
public
|
||||||
|
property FrameDiffTimeInMSecs: integer read FFrameDiffTime;
|
||||||
|
property OnMakeCurrent: TOpenGlCtrlMakeCurrentEvent read FOnMakeCurrent
|
||||||
|
write FOnMakeCurrent;
|
||||||
|
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
|
||||||
|
property SharedControl: TCustomOpenGLControl read FSharedOpenGLControl
|
||||||
|
write SetSharedControl;
|
||||||
|
property AutoResizeViewport: boolean read FAutoResizeViewport
|
||||||
|
write SetAutoResizeViewport default false;
|
||||||
|
property DoubleBuffered stored True default True;
|
||||||
|
property ParentDoubleBuffered default False;
|
||||||
|
property DebugContext: boolean read FDebugContext write SetDebugContext default false; // create context with debugging enabled. Requires OpenGLMajorVersion!
|
||||||
|
property RGBA: boolean read FRGBA write SetRGBA default true;
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
property RedBits: Cardinal read FRedBits write SetRedBits default 8;
|
||||||
|
property GreenBits: Cardinal read FGreenBits write SetGreenBits default 8;
|
||||||
|
property BlueBits: Cardinal read FBlueBits write SetBlueBits default 8;
|
||||||
|
{$ENDIF}
|
||||||
|
property OpenGLMajorVersion: Cardinal read fOpenGLMajorVersion write SetOpenGLMajorVersion default 0;
|
||||||
|
property OpenGLMinorVersion: Cardinal read fOpenGLMinorVersion write SetOpenGLMinorVersion default 0;
|
||||||
|
{ Number of samples per pixel, for OpenGL multi-sampling (anti-aliasing).
|
||||||
|
|
||||||
|
Value <= 1 means that we use 1 sample per pixel, which means no anti-aliasing.
|
||||||
|
Higher values mean anti-aliasing. Exactly which values are supported
|
||||||
|
depends on GPU, common modern GPUs support values like 2 and 4.
|
||||||
|
|
||||||
|
If this is > 1, and we will not be able to create OpenGL
|
||||||
|
with multi-sampling, we will fallback to normal non-multi-sampled context.
|
||||||
|
You can query OpenGL values GL_SAMPLE_BUFFERS_ARB and GL_SAMPLES_ARB
|
||||||
|
(see ARB_multisample extension) to see how many samples have been
|
||||||
|
actually allocated for your context. }
|
||||||
|
property MultiSampling: Cardinal read FMultiSampling write SetMultiSampling default 1;
|
||||||
|
|
||||||
|
property AlphaBits: Cardinal read FAlphaBits write SetAlphaBits default 0;
|
||||||
|
property DepthBits: Cardinal read FDepthBits write SetDepthBits default DefaultDepthBits;
|
||||||
|
property StencilBits: Cardinal read FStencilBits write SetStencilBits default 0;
|
||||||
|
property AUXBuffers: Cardinal read FAUXBuffers write SetAUXBuffers default 0;
|
||||||
|
property Options: TOpenGLControlOptions read FOptions write SetOptions;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TOpenGLControl }
|
||||||
|
|
||||||
|
TOpenGLControl = class(TCustomOpenGLControl)
|
||||||
|
published
|
||||||
|
property Align;
|
||||||
|
property Anchors;
|
||||||
|
property AutoResizeViewport;
|
||||||
|
property BorderSpacing;
|
||||||
|
property Enabled;
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
property RedBits;
|
||||||
|
property GreenBits;
|
||||||
|
property BlueBits;
|
||||||
|
{$ENDIF}
|
||||||
|
property OpenGLMajorVersion;
|
||||||
|
property OpenGLMinorVersion;
|
||||||
|
property MultiSampling;
|
||||||
|
property AlphaBits;
|
||||||
|
property DepthBits;
|
||||||
|
property StencilBits;
|
||||||
|
property AUXBuffers;
|
||||||
|
property OnChangeBounds;
|
||||||
|
property OnClick;
|
||||||
|
property OnConstrainedResize;
|
||||||
|
property OnDblClick;
|
||||||
|
property OnDragDrop;
|
||||||
|
property OnDragOver;
|
||||||
|
property OnEnter;
|
||||||
|
property OnExit;
|
||||||
|
property OnKeyDown;
|
||||||
|
property OnKeyPress;
|
||||||
|
property OnKeyUp;
|
||||||
|
property OnMakeCurrent;
|
||||||
|
property OnMouseDown;
|
||||||
|
property OnMouseEnter;
|
||||||
|
property OnMouseLeave;
|
||||||
|
property OnMouseMove;
|
||||||
|
property OnMouseUp;
|
||||||
|
property OnMouseWheel;
|
||||||
|
property OnMouseWheelDown;
|
||||||
|
property OnMouseWheelUp;
|
||||||
|
property OnPaint;
|
||||||
|
property OnResize;
|
||||||
|
property OnShowHint;
|
||||||
|
property PopupMenu;
|
||||||
|
property ShowHint;
|
||||||
|
property Visible;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TWSOpenGLControl }
|
||||||
|
|
||||||
|
TWSOpenGLControl = class(TWSWinControl)
|
||||||
|
published
|
||||||
|
class function CreateHandle(const AWinControl: TWinControl;
|
||||||
|
const AParams: TCreateParams): HWND; override;
|
||||||
|
class procedure DestroyHandle(const AWinControl: TWinControl); override;
|
||||||
|
class function GetDoubleBuffered(const AWinControl: TWinControl): Boolean; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$R openglcontextex.res}
|
||||||
|
|
||||||
|
var
|
||||||
|
OpenGLControlStack: TList = nil;
|
||||||
|
|
||||||
|
procedure Register;
|
||||||
|
begin
|
||||||
|
RegisterComponents('OpenGL',[TOpenGLControl]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TCustomOpenGLControl }
|
||||||
|
|
||||||
|
function TCustomOpenGLControl.GetSharingControls(Index: integer
|
||||||
|
): TCustomOpenGLControl;
|
||||||
|
begin
|
||||||
|
Result:=TCustomOpenGLControl(FSharingOpenGlControls[Index]);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetAutoResizeViewport(const AValue: boolean);
|
||||||
|
begin
|
||||||
|
if FAutoResizeViewport=AValue then exit;
|
||||||
|
FAutoResizeViewport:=AValue;
|
||||||
|
if AutoResizeViewport
|
||||||
|
and ([csLoading,csDestroying]*ComponentState=[])
|
||||||
|
and IsVisible and HandleAllocated
|
||||||
|
and MakeCurrent then
|
||||||
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetDebugContext(AValue: boolean);
|
||||||
|
begin
|
||||||
|
if FDebugContext=AValue then Exit;
|
||||||
|
FDebugContext:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.CMDoubleBufferedChanged(var Message: TLMessage);
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetOpenGLMajorVersion(AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if fOpenGLMajorVersion=AValue then Exit;
|
||||||
|
fOpenGLMajorVersion:=AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetOpenGLMinorVersion(AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if fOpenGLMinorVersion=AValue then Exit;
|
||||||
|
fOpenGLMinorVersion:=AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetOptions(AValue: TOpenGLControlOptions);
|
||||||
|
var
|
||||||
|
RemovedRenderAtDesignTime: boolean;
|
||||||
|
begin
|
||||||
|
if FOptions=AValue then Exit;
|
||||||
|
|
||||||
|
RemovedRenderAtDesignTime:=
|
||||||
|
(ocoRenderAtDesignTime in FOptions) and
|
||||||
|
(not (ocoRenderAtDesignTime in AValue));
|
||||||
|
|
||||||
|
FOptions:=AValue;
|
||||||
|
|
||||||
|
{ if you remove the flag ocoRenderAtDesignTime at design-time,
|
||||||
|
we need to destroy the handle. The call to OpenGLAttributesChanged
|
||||||
|
would not do this, so do it explicitly by calling ReCreateWnd
|
||||||
|
(ReCreateWnd will destroy handle, and not create new one,
|
||||||
|
since IsOpenGLRenderAllowed = false). }
|
||||||
|
if (csDesigning in ComponentState) and
|
||||||
|
RemovedRenderAtDesignTime and
|
||||||
|
HandleAllocated then
|
||||||
|
ReCreateWnd(Self);
|
||||||
|
|
||||||
|
OpenGLAttributesChanged();
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetRGBA(const AValue: boolean);
|
||||||
|
begin
|
||||||
|
if FRGBA=AValue then exit;
|
||||||
|
FRGBA:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
procedure TCustomOpenGLControl.SetRedBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FRedBits=AValue then exit;
|
||||||
|
FRedBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetGreenBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FGreenBits=AValue then exit;
|
||||||
|
FGreenBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetBlueBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FBlueBits=AValue then exit;
|
||||||
|
FBlueBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
{$ENDIF}
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetMultiSampling(const AMultiSampling: Cardinal);
|
||||||
|
begin
|
||||||
|
if FMultiSampling=AMultiSampling then exit;
|
||||||
|
FMultiSampling:=AMultiSampling;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetAlphaBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FAlphaBits=AValue then exit;
|
||||||
|
FAlphaBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetDepthBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FDepthBits=AValue then exit;
|
||||||
|
FDepthBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetStencilBits(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FStencilBits=AValue then exit;
|
||||||
|
FStencilBits:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetAUXBuffers(const AValue: Cardinal);
|
||||||
|
begin
|
||||||
|
if FAUXBuffers=AValue then exit;
|
||||||
|
FAUXBuffers:=AValue;
|
||||||
|
OpenGLAttributesChanged;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SetSharedControl(
|
||||||
|
const AValue: TCustomOpenGLControl);
|
||||||
|
begin
|
||||||
|
if FSharedOpenGLControl=AValue then exit;
|
||||||
|
if AValue=Self then
|
||||||
|
Raise Exception.Create('A control can not be shared by itself.');
|
||||||
|
// unshare old
|
||||||
|
if (AValue<>nil) and (AValue.SharedControl<>nil) then
|
||||||
|
Raise Exception.Create('Target control is sharing too. A sharing control can not be shared.');
|
||||||
|
if FSharedOpenGLControl<>nil then
|
||||||
|
FSharedOpenGLControl.FSharingOpenGlControls.Remove(Self);
|
||||||
|
// share new
|
||||||
|
if (AValue<>nil) and (csDestroying in AValue.ComponentState) then
|
||||||
|
FSharedOpenGLControl:=nil
|
||||||
|
else begin
|
||||||
|
FSharedOpenGLControl:=AValue;
|
||||||
|
if (FSharedOpenGLControl<>nil) then begin
|
||||||
|
if FSharedOpenGLControl.FSharingOpenGlControls=nil then
|
||||||
|
FSharedOpenGLControl.FSharingOpenGlControls:=TList.Create;
|
||||||
|
FSharedOpenGLControl.FSharingOpenGlControls.Add(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
// recreate handle if needed
|
||||||
|
if HandleAllocated and IsOpenGLRenderAllowed then
|
||||||
|
ReCreateWnd(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ OpenGL rendering allowed, because not in design-mode or because we
|
||||||
|
should render even in design-mode. }
|
||||||
|
function TCustomOpenGLControl.IsOpenGLRenderAllowed: boolean;
|
||||||
|
begin
|
||||||
|
Result := (not (csDesigning in ComponentState)) or
|
||||||
|
(ocoRenderAtDesignTime in Options);
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TCustomOpenGLControl.WSRegisterClass;
|
||||||
|
const
|
||||||
|
Registered : Boolean = False;
|
||||||
|
begin
|
||||||
|
if Registered then
|
||||||
|
Exit;
|
||||||
|
inherited WSRegisterClass;
|
||||||
|
RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
|
||||||
|
Registered := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.WMPaint(var Message: TLMPaint);
|
||||||
|
begin
|
||||||
|
Include(FControlState, csCustomPaint);
|
||||||
|
inherited WMPaint(Message);
|
||||||
|
//debugln('TCustomGTKGLAreaControl.WMPaint A ',dbgsName(Self),' ',dbgsName(FCanvas));
|
||||||
|
if (not IsOpenGLRenderAllowed) and (FCanvas<>nil) then begin
|
||||||
|
with FCanvas do begin
|
||||||
|
if Message.DC <> 0 then
|
||||||
|
Handle := Message.DC;
|
||||||
|
Brush.Color:=clLtGray;
|
||||||
|
Pen.Color:=clRed;
|
||||||
|
Rectangle(0,0,Self.Width,Self.Height);
|
||||||
|
MoveTo(0,0);
|
||||||
|
LineTo(Self.Width,Self.Height);
|
||||||
|
MoveTo(0,Self.Height);
|
||||||
|
LineTo(Self.Width,0);
|
||||||
|
if Message.DC <> 0 then
|
||||||
|
Handle := 0;
|
||||||
|
end;
|
||||||
|
end else begin
|
||||||
|
Paint;
|
||||||
|
end;
|
||||||
|
Exclude(FControlState, csCustomPaint);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.WMSize(var Message: TLMSize);
|
||||||
|
begin
|
||||||
|
if (Message.SizeType and Size_SourceIsInterface)>0 then
|
||||||
|
DoOnResize;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.DestroyWnd;
|
||||||
|
begin
|
||||||
|
inherited DestroyWnd;
|
||||||
|
|
||||||
|
if FCanvas <> nil then
|
||||||
|
TControlCanvas(FCanvas).FreeHandle;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.UpdateFrameTimeDiff;
|
||||||
|
begin
|
||||||
|
FCurrentFrameTime:=integer(GetTickCount);
|
||||||
|
if FLastFrameTime=0 then
|
||||||
|
FLastFrameTime:=FCurrentFrameTime;
|
||||||
|
// calculate time since last call:
|
||||||
|
FFrameDiffTime:=FCurrentFrameTime-FLastFrameTime;
|
||||||
|
// if the counter is reset restart:
|
||||||
|
if (FFrameDiffTime<0) then FFrameDiffTime:=1;
|
||||||
|
FLastFrameTime:=FCurrentFrameTime;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.OpenGLAttributesChanged;
|
||||||
|
begin
|
||||||
|
if HandleAllocated and
|
||||||
|
( ([csLoading,csDestroying]*ComponentState=[]) and IsOpenGLRenderAllowed ) then
|
||||||
|
RecreateWnd(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.EraseBackground(DC: HDC);
|
||||||
|
begin
|
||||||
|
if DC=0 then ;
|
||||||
|
// everything is painted, so erasing the background is not needed
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TCustomOpenGLControl.Create(TheOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(TheOwner);
|
||||||
|
ParentDoubleBuffered:=False;
|
||||||
|
FDoubleBuffered:=true;
|
||||||
|
FRGBA:=true;
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
FRedBits:=8;
|
||||||
|
FGreenBits:=8;
|
||||||
|
FBlueBits:=8;
|
||||||
|
{$ENDIF}
|
||||||
|
fOpenGLMajorVersion:=0;
|
||||||
|
fOpenGLMinorVersion:=0;
|
||||||
|
FMultiSampling:=1;
|
||||||
|
FDepthBits:=DefaultDepthBits;
|
||||||
|
ControlStyle:=ControlStyle-[csSetCaption];
|
||||||
|
if not IsOpenGLRenderAllowed then begin
|
||||||
|
FCanvas := TControlCanvas.Create;
|
||||||
|
TControlCanvas(FCanvas).Control := Self;
|
||||||
|
end else
|
||||||
|
FCompStyle:=csNonLCL;
|
||||||
|
SetInitialBounds(0, 0, 160, 90);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TCustomOpenGLControl.Destroy;
|
||||||
|
begin
|
||||||
|
if FSharingOpenGlControls<>nil then begin
|
||||||
|
while SharingControlCount>0 do
|
||||||
|
SharingControls[SharingControlCount-1].SharedControl:=nil;
|
||||||
|
FreeAndNil(FSharingOpenGlControls);
|
||||||
|
end;
|
||||||
|
SharedControl:=nil;
|
||||||
|
if OpenGLControlStack<>nil then begin
|
||||||
|
OpenGLControlStack.Remove(Self);
|
||||||
|
if OpenGLControlStack.Count=0 then
|
||||||
|
FreeAndNil(OpenGLControlStack);
|
||||||
|
end;
|
||||||
|
FCanvas.Free;
|
||||||
|
FCanvas:=nil;
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.Paint;
|
||||||
|
begin
|
||||||
|
if IsVisible and HandleAllocated then begin
|
||||||
|
UpdateFrameTimeDiff;
|
||||||
|
if IsOpenGLRenderAllowed and ([csDestroying]*ComponentState=[]) then begin
|
||||||
|
if AutoResizeViewport then begin
|
||||||
|
if not MakeCurrent then exit;
|
||||||
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
//LOpenGLClip(Handle);
|
||||||
|
DoOnPaint;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.RealizeBounds;
|
||||||
|
begin
|
||||||
|
if IsVisible and HandleAllocated
|
||||||
|
and IsOpenGLRenderAllowed
|
||||||
|
and ([csDestroying]*ComponentState=[])
|
||||||
|
and AutoResizeViewport then begin
|
||||||
|
if MakeCurrent then
|
||||||
|
LOpenGLViewport(Handle,0,0,Width,Height);
|
||||||
|
end;
|
||||||
|
inherited RealizeBounds;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.DoOnPaint;
|
||||||
|
begin
|
||||||
|
if Assigned(OnPaint) then begin
|
||||||
|
if not MakeCurrent then exit;
|
||||||
|
OnPaint(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.SwapBuffers;
|
||||||
|
begin
|
||||||
|
LOpenGLSwapBuffers(Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomOpenGLControl.MakeCurrent(SaveOldToStack: boolean): boolean;
|
||||||
|
var
|
||||||
|
Allowed: Boolean;
|
||||||
|
begin
|
||||||
|
if not IsOpenGLRenderAllowed then exit(false);
|
||||||
|
if Assigned(FOnMakeCurrent) then begin
|
||||||
|
Allowed:=true;
|
||||||
|
OnMakeCurrent(Self,Allowed);
|
||||||
|
if not Allowed then begin
|
||||||
|
Result:=False;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
// make current
|
||||||
|
Result:=LOpenGLMakeCurrent(Handle);
|
||||||
|
if Result and SaveOldToStack then begin
|
||||||
|
// on success push on stack
|
||||||
|
if OpenGLControlStack=nil then
|
||||||
|
OpenGLControlStack:=TList.Create;
|
||||||
|
OpenGLControlStack.Add(Self);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomOpenGLControl.ReleaseContext: boolean;
|
||||||
|
begin
|
||||||
|
Result:=false;
|
||||||
|
if not HandleAllocated then exit;
|
||||||
|
Result:=LOpenGLReleaseContext(Handle);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomOpenGLControl.RestoreOldOpenGLControl: boolean;
|
||||||
|
var
|
||||||
|
RestoredControl: TCustomOpenGLControl;
|
||||||
|
begin
|
||||||
|
Result:=false;
|
||||||
|
// check if the current context is on stack
|
||||||
|
if (OpenGLControlStack=nil) or (OpenGLControlStack.Count=0) then exit;
|
||||||
|
// pop
|
||||||
|
OpenGLControlStack.Delete(OpenGLControlStack.Count-1);
|
||||||
|
// make old control the current control
|
||||||
|
if OpenGLControlStack.Count>0 then begin
|
||||||
|
RestoredControl:=
|
||||||
|
TCustomOpenGLControl(OpenGLControlStack[OpenGLControlStack.Count-1]);
|
||||||
|
if (not LOpenGLMakeCurrent(RestoredControl.Handle)) then
|
||||||
|
exit;
|
||||||
|
end else begin
|
||||||
|
FreeAndNil(OpenGLControlStack);
|
||||||
|
end;
|
||||||
|
Result:=true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TCustomOpenGLControl.SharingControlCount: integer;
|
||||||
|
begin
|
||||||
|
if FSharingOpenGlControls=nil then
|
||||||
|
Result:=0
|
||||||
|
else
|
||||||
|
Result:=FSharingOpenGlControls.Count;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TCustomOpenGLControl.Invalidate;
|
||||||
|
begin
|
||||||
|
if csCustomPaint in FControlState then exit;
|
||||||
|
inherited Invalidate;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TWSOpenGLControl }
|
||||||
|
|
||||||
|
class function TWSOpenGLControl.CreateHandle(const AWinControl: TWinControl;
|
||||||
|
const AParams: TCreateParams): HWND;
|
||||||
|
var
|
||||||
|
OpenGlControl: TCustomOpenGLControl;
|
||||||
|
AttrControl: TCustomOpenGLControl;
|
||||||
|
begin
|
||||||
|
OpenGlControl:=AWinControl as TCustomOpenGLControl;
|
||||||
|
if not OpenGlControl.IsOpenGLRenderAllowed then
|
||||||
|
begin
|
||||||
|
// do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
|
||||||
|
Result:=TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
if OpenGlControl.SharedControl<>nil then
|
||||||
|
AttrControl:=OpenGlControl.SharedControl
|
||||||
|
else
|
||||||
|
AttrControl:=OpenGlControl;
|
||||||
|
Result:=LOpenGLCreateContext(OpenGlControl,WSPrivate,
|
||||||
|
OpenGlControl.SharedControl,
|
||||||
|
AttrControl.DoubleBuffered,
|
||||||
|
{$IFDEF HasMacRetinaMode}
|
||||||
|
ocoMacRetinaMode in OpenGlControl.Options,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HasRGBA}
|
||||||
|
AttrControl.RGBA,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HasDebugContext}
|
||||||
|
AttrControl.DebugContext,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF HasRGBBits}
|
||||||
|
AttrControl.RedBits,
|
||||||
|
AttrControl.GreenBits,
|
||||||
|
AttrControl.BlueBits,
|
||||||
|
{$ENDIF}
|
||||||
|
{$IFDEF UsesModernGL}
|
||||||
|
AttrControl.OpenGLMajorVersion,
|
||||||
|
AttrControl.OpenGLMinorVersion,
|
||||||
|
{$ENDIF}
|
||||||
|
AttrControl.MultiSampling,
|
||||||
|
AttrControl.AlphaBits,
|
||||||
|
AttrControl.DepthBits,
|
||||||
|
AttrControl.StencilBits,
|
||||||
|
AttrControl.AUXBuffers,
|
||||||
|
AParams);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
class procedure TWSOpenGLControl.DestroyHandle(const AWinControl: TWinControl);
|
||||||
|
begin
|
||||||
|
LOpenGLDestroyContextInfo(AWinControl);
|
||||||
|
// do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
|
||||||
|
TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
|
||||||
|
end;
|
||||||
|
|
||||||
|
class function TWSOpenGLControl.GetDoubleBuffered(const AWinControl: TWinControl): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
if AWinControl=nil then ;
|
||||||
|
end;
|
||||||
|
{~bk
|
||||||
|
initialization
|
||||||
|
RegisterWSComponent(TCustomOpenGLControl,TWSOpenGLControl);
|
||||||
|
}
|
||||||
|
|
||||||
|
end.
|
||||||
Binary file not shown.
Reference in New Issue
Block a user