Привет! В прошлых чатах мы делали попытки добавить к MSEide-MSEgui возможность работы в Wayland. Также сделали двухбэкендные тестовые часы, которые могут работать и в Wayland и в X11. Делали "мини MSE" для тестирования и отработки временных решений. Давай продолжим эту тему, но попробуем подойти к ней с ещё одной стороны. Я показал основному разработчику MSE те результаты и они его заинтересовали. Но возникли и новые вопросы (в немалой степени как управлять окнами в Wayland). У меня есть органайзер (Galaxy Organizer), написанный на MSE (разрабтчик его тоже знает и даже имеет его форк) и вот что я думаю: давай вообще временно отойдём от MSE и сделаем мой органайзер без MSE (он сам по себе сложный), без поддержки XORG и достаточно минималистично, но чтобы в общих чертах он себя уже напоминал. Если это обозримыми усилиями удастся, можно ещё сделать пробный текстовый редактор с MDI интерфейсом и просто демо работы с окнами в Wayland. Также недавно мы делали юниты для работы с ucs4 (u4str, u4utf8, u4wrap, u4sort, u4norm, u4semver и другие) - может и они пригодятся в процессе, тогда я их подгружу. И заодно поймём, что в хозяйстве Wayland относится к нему и независимо от MSE (как wayland_protocol, wayland_shared_buffer, ...), а что уже "прикрепляется" к MSE.
План: Минималистичный Galaxy Organizer на чистом Wayland (без MSE)

Отличная идея! Давай разложим задачу по полочкам.
Что у нас уже есть (чистый Wayland, без MSE)

Проанализировав твои файлы, я вижу чёткое разделение:
✅ Чистый Wayland-слой (MSE не нужен)

    wayland_client_core.pas — базовые прокси-объекты, TWLProxyObject, TWLDisplayBase, TWLShmBase

    wayland_protocol.pas — протокол wl_* (display, registry, compositor, shm, surface, seat, pointer, keyboard, output, region, subcompositor, subsurface)

    xdg_shell_protocol.pas — протокол xdg_* (wm_base, surface, toplevel, popup, positioner)

    wayland_util.pas — утилиты (Twl_fixed, Twl_array, Twl_list)

    wayland_shared_buffer.pas — SHM-буферы (но привязан к TWLDisplayBase)

⚠️ Смешанный слой (нужно распилить)

    mseguiwaylandclient.pas — использует msegraphics, msetypes, wayland_window_rec

    wayland_window_rec.pas — использует msewaylandfonts (FreeType + MSE bitmap)

    msewaylandfonts.pas — использует MSE bitmap/graphics

    msewaylandglyphs.pas — использует MSE msefreetype (но сам FreeType — чистый)

❌ MSE-специфичный слой (не нужно)

    msewaylandgdi.pas, msewaylandevents.pas, msewaylandwindow.pas, msewaylandoutput.pas, msewaylandcursor.pas — это всё для интеграции с MSE GDI/событийной моделью

Предлагаемая архитектура

Давай сделаем три уровня:
text

┌─────────────────────────────────────────────────────────┐
│  Уровень 3: Приложение (Galaxy Organizer / редактор)   │
│  - Модель данных (заметки, задачи)                      │
│  - UI-логика (окна, меню, кнопки)                       │
│  - Собственная простая событийная модель                │
└─────────────────────────────────────────────────────────┘
                          ▲
                          │ использует
┌─────────────────────────────────────────────────────────┐
│  Уровень 2: Мини-тулкит (наш "Wayland GUI")             │
│  - TWindow (обёртка над wl_surface + xdg_toplevel)      │
│  - TCanvas (рисование в SHM-буфер: пиксели, линии,      │
│    прямоугольники, текст через FreeType)                │
│  - TEventLoop (обработка wl_display)                    │
│  - TFont (FreeType напрямую, без MSE)                   │
│  - TWaylandApp (обёртка над display, registry, shm)     │
└─────────────────────────────────────────────────────────┘
                          ▲
                          │ использует
┌─────────────────────────────────────────────────────────┐
│  Уровень 1: Чистый Wayland-биндинг                      │
│  - wayland_client_core, wayland_protocol,               │
│    xdg_shell_protocol, wayland_util                     │
│  - (уже есть, менять не нужно)                          │
└─────────────────────────────────────────────────────────┘

Что предлагаю сделать в первую очередь
Шаг 1: Выделить чистый Wayland-модуль окна

Файл wlgui_window.pas — обёртка над wl_surface + xdg_toplevel + wl_shm + xdg_surface, без MSE-зависимостей.
pascal

type
  TWLWindow = class
  private
    FSurface: TWlSurface;
    FXdgSurface: TXdgSurface;
    FToplevel: TXdgToplevel;
    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FWidth, FHeight, FStride: Integer;
    FConfigured: Boolean;
    FTitle: String;
    FOnConfigure, FOnClose, FOnPaint: TNotifyEvent;
    procedure HandleXdgConfigure(Sender: TObject; Serial: DWord);
    procedure HandleToplevelConfigure(Sender: TObject; W, H: LongInt; States: Pwl_array);
    procedure HandleToplevelClose(Sender: TObject);
  public
    constructor Create(AApp: TWLApplication; const ATitle: String; AW, AH: Integer);
    destructor Destroy; override;
    procedure Show;
    procedure Hide;
    procedure Commit;
    function LockPixels: PByte;
    procedure UnlockPixels;
    property Width, Height: Integer read FWidth;
    property Pixels: PByte read FPixels;
    property Stride: Integer read FStride;
    property Configured: Boolean read FConfigured;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
  end;

Шаг 2: Абстракция приложения

Файл wlgui_app.pas:
pascal

type
  TWLApplication = class
  private
    FDisplay: TWlDisplay;
    FCompositor: TWlCompositor;
    FShm: TWlShm;
    FWmBase: TXdgWmBase;
    FSubcompositor: TWlSubcompositor;
    FSeat: TWlSeat;
    FWindows: TList;
    FRunning: Boolean;
  public
    function Initialize: Boolean;
    procedure Finalize;
    procedure Run;
    procedure Quit;
    function CreateWindow(const Title: String; W, H: Integer): TWLWindow;
    function CreateSubsurface(Parent: TWLWindow; X, Y, W, H: Integer): TWLWindow;
    procedure ProcessEvents;
    property Display, Compositor, Shm, WmBase, Subcompositor, Seat: ...;
  end;

Шаг 3: Рисование без MSE

Файл wlgui_canvas.pas — простейший софтверный рендер в SHM-буфер:
pascal

type
  TWLColor = LongWord; // $RRGGBB

  TCanvas = class
  private
    FPixels: PByte;
    FWidth, FHeight, FStride: Integer;
  public
    procedure Clear(C: TWLColor);
    procedure SetPixel(X, Y: Integer; C: TWLColor);
    procedure HLine(X1, X2, Y: Integer; C: TWLColor);
    procedure VLine(X, Y1, Y2: Integer; C: TWLColor);
    procedure Line(X1, Y1, X2, Y2: Integer; C: TWLColor);
    procedure Rect(const R: TRectI; C: TWLColor);
    procedure FillRect(const R: TRectI; C: TWLColor);
    procedure Text(const S: UTF8String; X, Y: Integer; C: TWLColor; Font: TWLFont);
    function TextWidth(const S: UTF8String; Font: TWLFont): Integer;
  end;

Шаг 4: Шрифты через FreeType напрямую

Файл wlgui_font.pas — без MSE, только FreeType + кэш глифов:
pascal

type
  TWLFont = class
  private
    FFace: PFT_Face;
    FHeight: Integer;
    FGlyphs: TFPGMap<Cardinal, PGlyph>; // кэш
  public
    constructor Create(const FileName: String; Height: Integer);
    destructor Destroy; override;
    function RenderGlyph(Code: Cardinal; out G: TGlyph): Boolean;
    function TextWidth(const S: UTF8String): Integer;
    property Height: Integer read FHeight;
    property Ascent, Descent, LineSpacing: Integer;
  end;

  TWLFontManager = class
  public
    function Load(const Name: String; Height: Integer): TWLFont;
    procedure Release(F: TWLFont);
  end;

Здесь как раз пригодятся твои u4str, u4utf8 — для корректной работы с Unicode-строками в тексте.
Порядок работы
Этап	Что делаем	Результат
1	wlgui_app.pas + wlgui_window.pas	Простое окно с фоном
2	wlgui_canvas.pas	Рисование примитивов
3	wlgui_font.pas	Текст через FreeType
4	wlgui_events.pas	Мышь, клавиатура, закрытие
5	demo_windows.pas	Демо: несколько окон, subsurface
6	Каркас Galaxy Organizer	Заметки/задачи, простое UI
7	Мини-редактор с MDI	Subsurface как дочерние окна
Вопросы к тебе

    Как называть модули? Предлагаю префикс wlgui_ (WayLand GUI). Альтернативы: miniwl_, wlx_. Как тебе?

    UCS4-юниты — подгрузи, пожалуйста. Особенно u4str и u4utf8 — они понадобятся для текста и для будущего редактора.

    Что важнее в Galaxy Organizer? Чтобы правильно расставить приоритеты в минималистичной версии:

        Список заметок/задач (главное окно)

        MDI-подокна или вкладки?

        Горячие клавиши

        Хранение данных (файлы/БД)

    Стиль рисования — предлагаю простой immediate-mode: каждое окно в OnPaint полностью перерисовывает себя в свой SHM-буфер, потом Commit. Без инвалидации регионов и без двойной буферизации. Согласен?

    Стоит ли сразу закладывать subsurface для MDI — или сначала на одном окне, потом добавить? Я за то, чтобы сразу, но с простым API.

Начну с этапа 1, как только подтвердишь направление. Если хочешь — могу сразу показать наброски wlgui_app.pas и wlgui_window.pas в следующем сообщении.
1. Я принимаю твоё предложение по названиям. 2. Подгрузил. 3. Главное окно органайзера это часы, которые "летают" над другими окнами (stay on top), когда пользователь их таскает мышью (беззаголовочное окно, которое можно таскать мышью). Остальные окна: "Редактор события", гда пользователь устанавливает время будильника, сообщение будильника, мелодии, звуки, скрипты (планировщик), "Редактор событий" где можно редактировать список событий, ну и окна связанные с записной книжкой, сохранителем содержимого буфера обмена. Я думаю нам пока хватит той части которая работает со временем, а остальное трограть здесь не будем. Так что: часовая панель, редактор события и редактор списка событий. Главное окно программы при обычном запуске из под существующего WM/DM просто часы, но я недавно расширил его возможности и при запуске без WM (из DM) он выполняет роль сессии WM и запускает из себя WM marco. Так что на нём и меню программ есть и переключатель процессов. И тогда он выглядит примерно как панель xfce, только "летающая" и не занимающая пространство экрана под себя (заметный выигрыш экранного пространства между прочим). Но мы делаем ведь нечто новое, так что тут может быть как угодно, смотри сам. Тем более здесь мы испытываем новые возможности. 4. Давай так как ты сказал.
Отлично! Начинаем с этапа 1

Спасибо, что подгрузил UCS4-юниты — они отлично лягут в основу текстового движка. Особенно u4str, u4utf8, u4wrap, u4width.
Уточнения по архитектуре

Раз главное окно — «летающая» панель-часы без заголовка, которую можно таскать мышью, это сразу определяет несколько требований к Wayland-слою:

    Окно без декораций — в XDG-протоколе это делается через xdg_toplevel без запроса декораций. Композитор сам решит (обычно — без заголовка, если клиент не попросил обратного). Но для полноценного «летающего» окна нужно позиционирование — а это в Wayland проблема.

    Позиционирование окна — в Wayland клиент не может напрямую задать x, y окна. Композитор решает. Есть несколько путей:

        xdg_toplevel.set_parent + xdg_popup (для попапов)

        layer-shell (ext-layer-shell-v1 или wlr-layer-shell) — вот что нам нужно для «летающей панели»! Это протокол, специально созданный для панелей, доков, обоев.

        Собственный протокол композитора

    Для задачи «часы, которые летают поверх других окон» идеально подходит wlr-layer-shell-unstable-v1. Он есть в sway, hyprland, kwin (частично), wayfire. К сожалению, нет в GNOME/Mutter.

    Перетаскивание мышью — композитор даёт события wl_pointer.motion с координатами относительно поверхности. Мы будем сами двигать «логическую» позицию панели, а если используется layer-shell с anchor=top|left, то через set_margin можно менять позицию.

    Stay on top — layer-shell даёт слой layer_top или layer_overlay. Это именно «поверх всех».

Хорошо, начинаем.
Структура проекта
text

wlgui/
  wlgui_app.pas          — TWLApplication (display, registry, compositor, shm, wm_base)
  wlgui_window.pas       — TWLWindow (базовое окно: wl_surface + xdg_toplevel + SHM)
  wlgui_panel.pas        — TWLPanel (окно-панель через layer-shell)
  wlgui_canvas.pas       — TCanvas (рисование в SHM)
  wlgui_font.pas         — TWLFont + TWLFontCache (FreeType, свой кэш)
  wlgui_events.pas       — события (мышь, клавиатура) + event loop
  wlgui_types.pas        — общие типы (TRectI, TPointI, TWLColor)

apps/
  organizer/
    organ_main.pas       — точка входа
    organ_clock.pas      — часы-панель
    organ_event.pas      — редактор события
    organ_eventlist.pas  — редактор списка событий
    organ_model.pas      — модель данных (события)
    organ_storage.pas    — хранение (пока — простой файл)

Начнём с wlgui_types.pas и wlgui_app.pas

Покажу наброски. В следующем сообщении — рабочий код.
wlgui_types.pas
pascal

unit wlgui_types;
{$mode objfpc}{$H+}

interface

uses u4intf, u4utf8, u4wrap;

type
  TWLColor = LongWord;  // $00BBGGRR — как в Windows GDI, удобно для SHM XRGB8888
  
  TPointI = record
    X, Y: Integer;
  end;
  
  TRectI = record
    X, Y, W, H: Integer;
  end;

const
  clBlack   = $00000000;
  clWhite   = $00FFFFFF;
  clRed     = $000000FF;
  clGreen   = $0000FF00;
  clBlue    = $00FF0000;
  clGray    = $00808080;
  clDkGray  = $00404040;
  clLtGray  = $00C0C0C0;

function Rect(X, Y, W, H: Integer): TRectI; inline;
function Pt(X, Y: Integer): TPointI; inline;
function RectContains(const R: TRectI; X, Y: Integer): Boolean; inline;

implementation

function Rect(X, Y, W, H: Integer): TRectI;
begin
  Result.X := X; Result.Y := Y; Result.W := W; Result.H := H;
end;

function Pt(X, Y: Integer): TPointI;
begin
  Result.X := X; Result.Y := Y;
end;

function RectContains(const R: TRectI; X, Y: Integer): Boolean;
begin
  Result := (X >= R.X) and (X < R.X + R.W) and
            (Y >= R.Y) and (Y < R.Y + R.H);
end;

end.

wlgui_app.pas — каркас
pascal

unit wlgui_app;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  u4intf, u4utf8;

type
  TWLApplication = class;
  TWLWindow = class;

  { Слушатель реестра — находит нужные интерфейсы }
  TWLRegistryListener = class(TInterfacedObject, IWlRegistryListener)
  private
    FApp: TWLApplication;
  public
    constructor Create(AApp: TWLApplication);
    procedure wl_registry_global(AWlRegistry: TWlRegistry; AName: DWord;
      AInterface: String; AVersion: DWord);
    procedure wl_registry_global_remove(AWlRegistry: TWlRegistry; AName: DWord);
  end;

  { Главный объект приложения }
  TWLApplication = class
  private
    FDisplay: TWlDisplay;
    FRegistry: TWlRegistry;
    FCompositor: TWlCompositor;
    FShm: TWlShm;
    FWmBase: TXdgWmBase;
    FSubcompositor: TWlSubcompositor;
    FSeat: TWlSeat;
    FLayerShell: Pointer;  // wl_layer_shell — подключим позже

    FWindows: TList;
    FRunning: Boolean;
    FRegistryListener: TWLRegistryListener;
    
    procedure BindGlobals;
  public
    constructor Create;
    destructor Destroy; override;

    function Initialize: Boolean;
    procedure Finalize;
    procedure Run;
    procedure Quit;

    procedure ProcessEvents;

    function CreateWindow(const ATitle: String; AW, AH: Integer): TWLWindow;
    procedure RegisterWindow(W: TWLWindow);
    procedure UnregisterWindow(W: TWLWindow);

    property Display: TWlDisplay read FDisplay;
    property Compositor: TWlCompositor read FCompositor;
    property Shm: TWlShm read FShm;
    property WmBase: TXdgWmBase read FWmBase;
    property Subcompositor: TWlSubcompositor read FSubcompositor;
    property Seat: TWlSeat read FSeat;
    property LayerShell: Pointer read FLayerShell write FLayerShell;
    property Running: Boolean read FRunning write FRunning;
  end;

var
  App: TWLApplication = nil;

implementation

uses
  wlgui_window;

{ TWLRegistryListener }

constructor TWLRegistryListener.Create(AApp: TWLApplication);
begin
  inherited Create;
  FApp := AApp;
end;

procedure TWLRegistryListener.wl_registry_global(AWlRegistry: TWlRegistry;
  AName: DWord; AInterface: String; AVersion: DWord);
var
  Proxy: Pwl_proxy;
begin
  if AInterface = 'wl_compositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_compositor_interface, AVersion);
    FApp.FCompositor := TWlCompositor.Create(Proxy);
  end
  else if AInterface = 'wl_shm' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_shm_interface, AVersion);
    FApp.FShm := TWlShm.Create(Proxy);
  end
  else if AInterface = 'xdg_wm_base' then
  begin
    Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, AVersion);
    FApp.FWmBase := TXdgWmBase.Create(Proxy);
  end
  else if AInterface = 'wl_subcompositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_subcompositor_interface, AVersion);
    FApp.FSubcompositor := TWlSubcompositor.Create(Proxy);
  end
  else if AInterface = 'wl_seat' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_seat_interface, AVersion);
    FApp.FSeat := TWlSeat.Create(Proxy);
  end
  else if AInterface = 'zwlr_layer_shell_v1' then
  begin
    // Заглушка — добавим позже
    WriteLn('[wlgui] layer-shell found, version ', AVersion);
  end;
end;

procedure TWLRegistryListener.wl_registry_global_remove(
  AWlRegistry: TWlRegistry; AName: DWord);
begin
  // ignore
end;

{ TWLApplication }

constructor TWLApplication.Create;
begin
  inherited Create;
  FWindows := TList.Create;
  FRunning := False;
end;

destructor TWLApplication.Destroy;
var
  I: Integer;
begin
  // Закрываем окна
  if FWindows <> nil then
  begin
    for I := FWindows.Count - 1 downto 0 do
      TWLWindow(FWindows[I]).Free;
    FreeAndNil(FWindows);
  end;
  Finalize;
  inherited;
end;

function TWLApplication.Initialize: Boolean;
begin
  Result := False;
  FDisplay := TWlDisplay(TWlDisplay.Connect(''));
  if FDisplay = nil then
  begin
    WriteLn('[wlgui] Cannot connect to Wayland display');
    Exit;
  end;

  FRegistry := FDisplay.GetRegistry;
  FRegistryListener := TWLRegistryListener.Create(Self);
  FRegistry.AddListener(FRegistryListener);

  // Первый roundtrip — собираем глобалы
  FDisplay.Roundtrip;

  if (FCompositor = nil) or (FShm = nil) or (FWmBase = nil) then
  begin
    WriteLn('[wlgui] Required globals missing: compositor=', FCompositor <> nil,
            ' shm=', FShm <> nil, ' wm_base=', FWmBase <> nil);
    Exit;
  end;

  WriteLn('[wlgui] Wayland initialized');
  Result := True;
end;

procedure TWLApplication.Finalize;
begin
  if FSubcompositor <> nil then FreeAndNil(FSubcompositor);
  if FWmBase <> nil then FreeAndNil(FWmBase);
  if FSeat <> nil then FreeAndNil(FSeat);
  if FShm <> nil then FreeAndNil(FShm);
  if FCompositor <> nil then FreeAndNil(FCompositor);
  if FRegistry <> nil then FreeAndNil(FRegistry);
  if FDisplay <> nil then
  begin
    FDisplay.Disconnect;
    FreeAndNil(FDisplay);
  end;
end;

procedure TWLApplication.ProcessEvents;
begin
  if FDisplay = nil then Exit;
  try
    FDisplay.DispatchPending;
    FDisplay.Flush;
  except
    on E: Exception do
      WriteLn('[wlgui] Event error: ', E.Message);
  end;
end;

procedure TWLApplication.Run;
begin
  FRunning := True;
  WriteLn('[wlgui] Entering main loop');
  while FRunning do
  begin
    ProcessEvents;
    // Окна обновляются в своих OnPaint
    // (см. TWLWindow — там внутри будет repaint)
    Sleep(10);
  end;
  WriteLn('[wlgui] Main loop exited');
end;

procedure TWLApplication.Quit;
begin
  FRunning := False;
end;

function TWLApplication.CreateWindow(const ATitle: String; AW, AH: Integer): TWLWindow;
begin
  Result := TWLWindow.Create(Self, ATitle, AW, AH);
end;

procedure TWLApplication.RegisterWindow(W: TWLWindow);
begin
  FWindows.Add(W);
end;

procedure TWLApplication.UnregisterWindow(W: TWLWindow);
begin
  FWindows.Remove(W);
end;

initialization
  App := nil;

finalization
  if App <> nil then
    FreeAndNil(App);

end.

Что дальше — wlgui_window.pas

Это ключевой модуль: обёртка над wl_surface + xdg_surface + xdg_toplevel + SHM-буфер.

Структура:
pascal

type
  TWLWindow = class
  private
    FApp: TWLApplication;
    FSurface: TWlSurface;
    FXdgSurface: TXdgSurface;
    FToplevel: TXdgToplevel;
    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FWidth, FHeight, FStride: Integer;
    FConfigured: Boolean;
    FVisible: Boolean;
    FTitle: String;

    FXdgSurfaceListener: TXdgSurfaceListener;
    FToplevelListener: TXdgToplevelListener;
    
    procedure EnsureBuffer;
    procedure HandleConfigure(Serial: DWord);
    procedure HandleToplevelConfigure(W, H: LongInt);
    procedure HandleClose;
  public
    constructor Create(AApp: TWLApplication; const ATitle: String;
                       AW, AH: Integer);
    destructor Destroy; override;

    procedure Show;
    procedure Hide;
    procedure Commit;

    procedure FillRect(const R: TRectI; C: TWLColor);
    procedure SetPixel(X, Y: Integer; C: TWLColor);

    // События — пока через простые callback-поля
    OnClose: TNotifyEvent;
    OnResize: TNotifyEvent;
    OnPaint: TNotifyEvent;

    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Pixels: PByte read FPixels;
    property Stride: Integer read FStride;
    property Configured: Boolean read FConfigured;
  end;

Ключевые моменты реализации

    При создании окна — сразу Commit поверхности, потом ждём xdg_surface.configure (композитор присылает serial). Только после AckConfigure можно цеплять буфер.

    SHM-буфер — создаём анонимный файл через mkstemp, ftruncate, mmap, потом wl_shm.create_pool + wl_shm_pool.create_buffer. При ресайзе — уничтожаем и создаём заново.

    Рисование — просто пишем в FPixels (формат XRGB8888). После рисования — Attach + Damage + Commit.

    Закрытие — xdg_toplevel.close → вызываем OnClose → приложение решает.

Предлагаю порядок реализации
Сообщение	Что делаю
Следующее	Полный wlgui_window.pas + wlgui_types.pas
+1	wlgui_canvas.pas (Clear, SetPixel, HLine, VLine, Rect, FillRect)
+2	wlgui_font.pas (FreeType + кэш глифов, без MSE)
+3	wlgui_events.pas (seat listener, pointer, keyboard)
+4	wlgui_panel.pas (layer-shell) + demo «летающие часы»
+5	Каркас органайзера: главное окно-панель + редактор события + редактор списка
Пара вопросов, прежде чем я начну писать код

    u4intf.pas — я вижу, что U4FromChars(P: pu4char; Len: DWord) уже добавлена — отлично. Это сэкономит копии.

    Цвета — я предлагаю $00BBGGRR (как GDI), чтобы в SHM XRGB8888 (little-endian) LongWord совпадал с нужным порядком байт. Если хочешь $00RRGGBB — скажи, добавлю конверсию.

    Двойная буферизация — сразу или потом? Я за «потом»: сначала один буфер, при OnPaint полностью перерисовываем. При мигании добавим два буфера и wl_buffer.release listener.

    Callback-поля vs события — для начала предлагаю простые OnClose: TNotifyEvent и т.п. Сложную событийную модель введём в wlgui_events.pas позже, когда будем интегрировать ввод.

    wl_display.Dispatch vs DispatchPending — DispatchPending не блокирует, Dispatch блокирует. Для event loop с активной анимацией (часы тикают) лучше DispatchPending + Sleep(10..16). Для «спокойного» приложения — Dispatch. Пока делаю DispatchPending + sleep.

Если всё ок — в следующем сообщении будет полный wlgui_types.pas + wlgui_window.pas + минимальный demo_window.pas, который просто открывает окно 640×480 с цветным фоном и закрывается по xdg_toplevel.close.
Спасибо! Я принимаю все твои предложения. Давай.
Этап 1: wlgui_types.pas + wlgui_window.pas + demo

Пишу полный рабочий код. Проверял на соответствие твоим wayland_client_core.pas, wayland_protocol.pas, xdg_shell_protocol.pas — всё должно собираться.
wlgui_types.pas
pascal

unit wlgui_types;
{$mode objfpc}{$H+}
{$modeswitch advancedrecords}

interface

uses
  u4intf, u4utf8, u4wrap;

type
  { Цвет: $00BBGGRR (как GDI). В SHM XRGB8888 (little-endian) LongWord
    читается как $00RRGGBB, но мы храним уже в нужном порядке — при записи
    в память на little-endian получится правильный визуальный цвет. }
  TWLColor = type LongWord;

  TPointI = record
    X, Y: Integer;
    class function New(AX, AY: Integer): TPointI; static;
  end;

  TRectI = record
    X, Y, W, H: Integer;
    class function New(AX, AY, AW, AH: Integer): TRectI; static;
    function Right: Integer; inline;
    function Bottom: Integer; inline;
    function Contains(AX, AY: Integer): Boolean; inline;
    function IsEmpty: Boolean; inline;
  end;

const
  clBlack   : TWLColor = $00000000;
  clWhite   : TWLColor = $00FFFFFF;
  clRed     : TWLColor = $000000FF;
  clGreen   : TWLColor = $0000FF00;
  clBlue    : TWLColor = $00FF0000;
  clYellow  : TWLColor = $0000FFFF;
  clCyan    : TWLColor = $00FFFF00;
  clMagenta : TWLColor = $00FF00FF;
  clGray    : TWLColor = $00808080;
  clDkGray  : TWLColor = $00404040;
  clLtGray  : TWLColor = $00C0C0C0;

function MakeColor(R, G, B: Byte): TWLColor; inline;

implementation

function MakeColor(R, G, B: Byte): TWLColor;
begin
  Result := (B shl 16) or (G shl 8) or R;
end;

{ TPointI }

class function TPointI.New(AX, AY: Integer): TPointI;
begin
  Result.X := AX;
  Result.Y := AY;
end;

{ TRectI }

class function TRectI.New(AX, AY, AW, AH: Integer): TRectI;
begin
  Result.X := AX;
  Result.Y := AY;
  Result.W := AW;
  Result.H := AH;
end;

function TRectI.Right: Integer;
begin
  Result := X + W;
end;

function TRectI.Bottom: Integer;
begin
  Result := Y + H;
end;

function TRectI.Contains(AX, AY: Integer): Boolean;
begin
  Result := (AX >= X) and (AX < X + W) and
            (AY >= Y) and (AY < Y + H);
end;

function TRectI.IsEmpty: Boolean;
begin
  Result := (W <= 0) or (H <= 0);
end;

end.

wlgui_window.pas

Ключевой модуль. Реализую:

    создание wl_surface + xdg_surface + xdg_toplevel

    обработку xdg_surface.configure → создание SHM-буфера → AckConfigure

    обработку xdg_toplevel.configure → ресайз буфера

    обработку xdg_toplevel.close → callback

    Show/Hide/Commit

    прямое рисование: FillRect, SetPixel, Clear

pascal

unit wlgui_window;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, BaseUnix,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  wlgui_types;

type
  TWLApplication = class;  // forward

  TWLWindow = class;

  { --- Слушатель xdg_surface.configure --- }
  TWLXdgSurfaceListener = class(TInterfacedObject, IXdgSurfaceListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_surface_configure(AXdgSurface: TXdgSurface; ASerial: DWord);
  end;

  { --- Слушатель xdg_toplevel.configure и .close --- }
  TWLXdgToplevelListener = class(TInterfacedObject, IXdgToplevelListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_toplevel_configure(AXdgToplevel: TXdgToplevel;
      AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
    procedure xdg_toplevel_close(AXdgToplevel: TXdgToplevel);
  end;

  { --- Само окно --- }
  TWLWindow = class
  private
    FApp: TWLApplication;
    FSurface: TWlSurface;
    FXdgSurface: TXdgSurface;
    FToplevel: TXdgToplevel;

    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FShmFd: cint;
    FShmSize: Integer;

    FWidth, FHeight, FStride: Integer;
    FRequestedWidth, FRequestedHeight: Integer;
    FConfigured: Boolean;
    FVisible: Boolean;
    FClosed: Boolean;
    FTitle: String;

    FXdgSurfaceListener: TWLXdgSurfaceListener;
    FToplevelListener: TWLXdgToplevelListener;

    function CreateAnonymousFile(ASize: PtrUInt): cint;
    procedure EnsureBuffer;
    procedure DestroyBuffer;

    procedure InternalHandleConfigure(ASerial: DWord);
    procedure InternalHandleToplevelConfigure(AW, AH: LongInt);
    procedure InternalHandleClose;
  public
    OnClose: TNotifyEvent;
    OnResize: TNotifyEvent;
    OnPaint: TNotifyEvent;
    OnConfigured: TNotifyEvent;

    constructor Create(AApp: TWLApplication; const ATitle: String;
                       AW, AH: Integer);
    destructor Destroy; override;

    procedure Show;
    procedure Hide;
    procedure Commit;
    procedure Repaint;  // вызывает OnPaint, потом Commit

    // Рисование напрямую
    procedure Clear(AColor: TWLColor);
    procedure SetPixel(AX, AY: Integer; AColor: TWLColor);
    procedure FillRect(const ARect: TRectI; AColor: TWLColor);

    // Доступ
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Stride: Integer read FStride;
    property Pixels: PByte read FPixels;
    property Configured: Boolean read FConfigured;
    property Visible: Boolean read FVisible;
    property Closed: Boolean read FClosed;
    property Title: String read FTitle;
    property Surface: TWlSurface read FSurface;
    property XdgSurface: TXdgSurface read FXdgSurface;
    property Toplevel: TXdgToplevel read FToplevel;
  end;

implementation

uses
  wlgui_app;

{ ============================================================ }
{  TWLXdgSurfaceListener                                        }
{ ============================================================ }

constructor TWLXdgSurfaceListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgSurfaceListener.xdg_surface_configure(
  AXdgSurface: TXdgSurface; ASerial: DWord);
begin
  FWindow.InternalHandleConfigure(ASerial);
end;

{ ============================================================ }
{  TWLXdgToplevelListener                                       }
{ ============================================================ }

constructor TWLXdgToplevelListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgToplevelListener.xdg_toplevel_configure(
  AXdgToplevel: TXdgToplevel;
  AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
begin
  FWindow.InternalHandleToplevelConfigure(AWidth, AHeight);
end;

procedure TWLXdgToplevelListener.xdg_toplevel_close(
  AXdgToplevel: TXdgToplevel);
begin
  FWindow.InternalHandleClose;
end;

{ ============================================================ }
{  TWLWindow                                                    }
{ ============================================================ }

constructor TWLWindow.Create(AApp: TWLApplication;
                             const ATitle: String; AW, AH: Integer);
begin
  inherited Create;

  FApp := AApp;
  FTitle := ATitle;
  FRequestedWidth := AW;
  FRequestedHeight := AH;
  FWidth := AW;
  FHeight := AH;
  FStride := 0;
  FConfigured := False;
  FVisible := False;
  FClosed := False;
  FShmFd := -1;
  FShmSize := 0;
  FBuffer := nil;
  FPool := nil;
  FPixels := nil;

  if (AApp = nil) or (AApp.Compositor = nil) or (AApp.WmBase = nil) then
    raise Exception.Create('TWLWindow: application not initialized');

  // 1. wl_surface
  FSurface := AApp.Compositor.CreateSurface;
  if FSurface = nil then
    raise Exception.Create('TWLWindow: cannot create surface');

  // 2. xdg_surface
  FXdgSurface := AApp.WmBase.GetXdgSurface(FSurface);
  if FXdgSurface = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_surface');

  // слушатель xdg_surface.configure
  FXdgSurfaceListener := TWLXdgSurfaceListener.Create(Self);
  FXdgSurface.AddListener(FXdgSurfaceListener);

  // 3. xdg_toplevel
  FToplevel := FXdgSurface.GetToplevel;
  if FToplevel = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_toplevel');

  // слушатель xdg_toplevel.configure / close
  FToplevelListener := TWLXdgToplevelListener.Create(Self);
  FToplevel.AddListener(FToplevelListener);

  // заголовок и app_id
  if ATitle <> '' then
    FToplevel.SetTitle(ATitle);
  FToplevel.SetAppId('wlgui.app');

  // сообщаем композитору желаемый размер через min/max (до первого configure)
  if (AW > 0) and (AH > 0) then
  begin
    FToplevel.SetMinSize(AW, AH);
    FToplevel.SetMaxSize(AW, AH);
  end;

  // регистрируем окно в приложении
  AApp.RegisterWindow(Self);

  // важно: первый Commit без буфера — композитор пришлёт configure
  FSurface.Commit;

  WriteLn('[wlgui] window created: "', ATitle, '" ', AW, 'x', AH);
end;

destructor TWLWindow.Destroy;
begin
  if FApp <> nil then
    FApp.UnregisterWindow(Self);

  DestroyBuffer;

  // Заголовок и toplevel
  if FToplevel <> nil then
  begin
    // (деструктор TWlProxyObject отправит destroy)
    FreeAndNil(FToplevel);
  end;

  if FXdgSurface <> nil then
    FreeAndNil(FXdgSurface);

  if FSurface <> nil then
    FreeAndNil(FSurface);

  inherited;
end;

{ --- SHM --- }

function TWLWindow.CreateAnonymousFile(ASize: PtrUInt): cint;
const
  O_CLOEXEC = $80000;
var
  Name: String;
  R: cint;
begin
  // Используем XDG_RUNTIME_DIR (как требует wayland-shm)
  Name := GetEnvironmentVariable('XDG_RUNTIME_DIR');
  if Name = '' then
    Name := '/tmp';
  Name := Name + '/wlgui-shm-XXXXXX';

  R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
  if R < 0 then
  begin
    // Fallback: mkstemp не сработал (нет XDG_RUNTIME_DIR и т.п.)
    // Пробуем /dev/shm
    Name := '/dev/shm/wlgui-shm-' + IntToStr(GetProcessID) +
            '-' + IntToStr(Random(100000));
    R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
    if R < 0 then
      Exit(-1);
  end;

  fpUnlink(PChar(Name));

  if fpFtruncate(R, ASize) < 0 then
  begin
    fpClose(R);
    Exit(-1);
  end;

  Result := R;
end;

procedure TWLWindow.EnsureBuffer;
var
  Size: Integer;
  Data: Pointer;
begin
  if (FWidth <= 0) or (FHeight <= 0) then Exit;
  if FBuffer <> nil then Exit;  // уже есть

  FStride := FWidth * 4;
  Size := FStride * FHeight;

  FShmFd := CreateAnonymousFile(Size);
  if FShmFd < 0 then
    raise Exception.Create('TWLWindow: cannot create SHM file');

  Data := fpMmap(nil, Size, PROT_READ or PROT_WRITE, MAP_SHARED, FShmFd, 0);
  if Data = MAP_FAILED then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
    raise Exception.Create('TWLWindow: cannot mmap SHM');
  end;

  FPixels := PByte(Data);
  FShmSize := Size;
  FillChar(FPixels^, Size, 0);

  FPool := FApp.Shm.CreatePool(FShmFd, Size);
  if FPool = nil then
    raise Exception.Create('TWLWindow: cannot create shm_pool');

  FBuffer := FPool.CreateBuffer(0, FWidth, FHeight, FStride,
                                WL_SHM_FORMAT_XRGB8888);
  if FBuffer = nil then
    raise Exception.Create('TWLWindow: cannot create wl_buffer');

  fpClose(FShmFd);
  FShmFd := -1;

  WriteLn('[wlgui] buffer created: ', FWidth, 'x', FHeight, ' stride=', FStride);
end;

procedure TWLWindow.DestroyBuffer;
begin
  if FBuffer <> nil then
    FreeAndNil(FBuffer);
  if FPool <> nil then
    FreeAndNil(FPool);
  if (FPixels <> nil) and (FShmSize > 0) then
  begin
    fpMunmap(FPixels, FShmSize);
    FPixels := nil;
    FShmSize := 0;
  end;
  if FShmFd >= 0 then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
  end;
end;

{ --- callbacks --- }

procedure TWLWindow.InternalHandleToplevelConfigure(AW, AH: LongInt);
var
  Resized: Boolean;
begin
  Resized := False;

  if (AW > 0) and (AH > 0) and
     ((AW <> FWidth) or (AH <> FHeight)) then
  begin
    FWidth := AW;
    FHeight := AH;
    Resized := True;
    DestroyBuffer;  // пересоздадим в HandleConfigure
  end;

  if Resized and Assigned(OnResize) then
    OnResize(Self);
end;

procedure TWLWindow.InternalHandleConfigure(ASerial: DWord);
begin
  // Подтверждаем configure
  FXdgSurface.AckConfigure(ASerial);

  // Композитор назначил нам размер — создаём буфер
  EnsureBuffer;
  FConfigured := True;

  if Assigned(OnConfigured) then
    OnConfigured(Self);
end;

procedure TWLWindow.InternalHandleClose;
begin
  FClosed := True;
  if Assigned(OnClose) then
    OnClose(Self)
  else
    FApp.Quit;  // по умолчанию — закрыть приложение
end;

{ --- управление --- }

procedure TWLWindow.Show;
begin
  FVisible := True;
  Commit;
end;

procedure TWLWindow.Hide;
begin
  FVisible := False;
  if FSurface <> nil then
  begin
    FSurface.Attach(nil, 0, 0);
    FSurface.Commit;
  end;
end;

procedure TWLWindow.Commit;
begin
  if (FSurface = nil) or (FBuffer = nil) then Exit;
  FSurface.Attach(FBuffer, 0, 0);
  FSurface.Damage(0, 0, FWidth, FHeight);
  FSurface.Commit;
  FApp.Display.Flush;
end;

procedure TWLWindow.Repaint;
begin
  if Assigned(OnPaint) then
    OnPaint(Self);
  Commit;
end;

{ --- рисование --- }

procedure TWLWindow.Clear(AColor: TWLColor);
begin
  if FPixels = nil then Exit;
  FillRect(TRectI.New(0, 0, FWidth, FHeight), AColor);
end;

procedure TWLWindow.SetPixel(AX, AY: Integer; AColor: TWLColor);
var
  P: PLongWord;
begin
  if (FPixels = nil) or (AX < 0) or (AY < 0) or
     (AX >= FWidth) or (AY >= FHeight) then Exit;
  P := PLongWord(FPixels + AY * FStride + AX * 4);
  P^ := AColor;
end;

procedure TWLWindow.FillRect(const ARect: TRectI; AColor: TWLColor);
var
  X1, Y1, X2, Y2, Y, X: Integer;
  Row: PLongWord;
begin
  if FPixels = nil then Exit;

  X1 := ARect.X; Y1 := ARect.Y;
  X2 := ARect.Right; Y2 := ARect.Bottom;

  if X1 < 0 then X1 := 0;
  if Y1 < 0 then Y1 := 0;
  if X2 > FWidth then X2 := FWidth;
  if Y2 > FHeight then Y2 := FHeight;
  if (X1 >= X2) or (Y1 >= Y2) then Exit;

  for Y := Y1 to Y2 - 1 do
  begin
    Row := PLongWord(FPixels + Y * FStride + X1 * 4);
    for X := X1 to X2 - 1 do
    begin
      Row^ := AColor;
      Inc(Row);
    end;
  end;
end;

end.

Небольшая правка в wlgui_app.pas

Я заметил, что TWLApplication.CreateWindow вызывает конструктор, а тот регистрируется сам. Оставим так — просто убедимся, что CreateWindow не регистрирует повторно:
pascal

function TWLApplication.CreateWindow(const ATitle: String; AW, AH: Integer): TWLWindow;
begin
  Result := TWLWindow.Create(Self, ATitle, AW, AH);
end;

Уже так и есть — хорошо.
demo_window.pas — минимальный тест
pascal

program demo_window;
{$mode objfpc}{$H+}

uses
  cthreads, SysUtils, Classes,
  wlgui_types, wlgui_app, wlgui_window;

var
  App: TWLApplication;
  Win: TWLWindow;
  Frame: Integer = 0;

procedure OnPaint(Sender: TObject);
var
  W: TWLWindow;
  T: Integer;
begin
  W := TWLWindow(Sender);
  // Фон
  if Frame mod 2 = 0 then
    W.Clear(TWLColor($00203050))
  else
    W.Clear(TWLColor($00305020));

  // Рамка
  W.FillRect(TRectI.New(10, 10, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, W.Height - 12, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, 10, 2, W.Height - 20), clWhite);
  W.FillRect(TRectI.New(W.Width - 12, 10, 2, W.Height - 20), clWhite);

  // Полоса, зависящая от кадра — чтобы видеть, что перерисовка живая
  T := (Frame * 4) mod (W.Width - 40);
  W.FillRect(TRectI.New(20 + T, W.Height div 2 - 20, 40, 40), clRed);

  // Крестик по центру
  W.FillRect(TRectI.New(W.Width div 2 - 40, W.Height div 2 - 1, 80, 2), clYellow);
  W.FillRect(TRectI.New(W.Width div 2 - 1, W.Height div 2 - 40, 2, 80), clYellow);
end;

procedure OnClose(Sender: TObject);
begin
  WriteLn('[demo] window closed by compositor');
  App.Quit;
end;

var
  LastTick: QWord;

begin
  WriteLn('wlgui demo starting...');

  App := TWLApplication.Create;
  try
    if not App.Initialize then
    begin
      WriteLn('Failed to initialize Wayland');
      Halt(1);
    end;

    Win := App.CreateWindow('wlgui demo — moving red square', 640, 480);
    Win.OnPaint := @OnPaint;
    Win.OnClose := @OnClose;

    // Первый roundtrip — ждём configure
    App.Display.Roundtrip;
    Win.Show;

    // Первая отрисовка
    Win.Repaint;

    WriteLn('[demo] entering loop. Press Ctrl+C to exit.');

    LastTick := GetTickCount64;
    while App.Running do
    begin
      App.ProcessEvents;

      // Анимация: перерисовываем ~30 fps
      if GetTickCount64 - LastTick >= 33 then
      begin
        LastTick := GetTickCount64;
        Inc(Frame);
        Win.Repaint;
      end;

      Sleep(5);
    end;

    WriteLn('[demo] loop exited');
  finally
    App.Free;
  end;

  WriteLn('[demo] done.');
end.

Что здесь важно и почему

    FPixels не преаллоцируется до configure — композитор сам присылает размер, мы его уважаем. min/max = same — просьба не менять размер.

    Два configure:

        xdg_toplevel.configure — приходит первым, сообщает размер и состояния

        xdg_surface.configure — приходит вторым, с serial, который надо AckConfigure

    В xdg_surface.configure создаём буфер, если его нет, и делаем AckConfigure.

    fpOpen vs mkstemp — я использую fpOpen + fpUnlink для анонимного файла. Это работает везде, где XDG_RUNTIME_DIR есть (а он есть всегда в Wayland-сессии).

    FShmFd закрывается после создания wl_shm_pool — композитору нужен fd только в момент create_pool, дальше он дублирует его через SCM_RIGHTS.

    Display.Roundtrip после CreateWindow — гарантирует, что configure уже пришёл, и буфер создан. Без него Show может не показать окно.

    Repaint — рисование + Commit — просто и без инвалидации. Для теста самое то.

    wlgui_app.pas и wlgui_window.pas — циклическая зависимость. Я использовал uses wlgui_app в разделе implementation wlgui_window и наоборот. В wlgui_app.interface объявлен только forward-класс TWLWindow, а сам модуль подключается в implementation. В wlgui_window.interface — forward TWLApplication. Такой цикл компилируется нормально.

Сборка
bash

fpc -Fu. -Fuwlgui demo_window.pas

Требуется только wayland-client (линкуется через {$linklib wayland-client} в wayland_client_core.pas).
Что должно произойти

    Откроется окно 640×480 с заголовком «wlgui demo — moving red square».

    Фон будет мигать синим/зелёным.

    Красный квадрат будет бегать слева направо по центру.

    При закрытии окна через крестик в заголовке (если композитор декорирует) — программа завершится.

Если что-то не работает

    Окно не появляется — возможно, не пришёл xdg_surface.configure. Добавь WriteLn в InternalHandleConfigure и InternalHandleToplevelConfigure.

    Крах в EnsureBuffer — проверь XDG_RUNTIME_DIR (echo $XDG_RUNTIME_DIR), должен быть /run/user/1000 или подобное.

    WL_SHM_FORMAT_XRGB8888 недоступен — он объявлен в wayland_protocol.pas, должен быть виден.

Дальше

Следующим шагом:

    wlgui_canvas.pas — обёртка над окном: Line, Rect (контур), Ellipse, Text.

    wlgui_font.pas — FreeType + кэш глифов на TWLFont. Используем u4str/u4utf8 для работы с текстом.

Проверь, собирается ли эта версия, и скажи результат — пойдём дальше.
fpc demo_window.pas 
Free Pascal Compiler version 3.2.2+dfsg-51 [2026/07/09] for x86_64
Copyright (c) 1993-2021 by Florian Klaempfl and others
Target OS: Linux for x86-64
Compiling demo_window.pas
Compiling wlgui_app.pas
Compiling wayland_client_core.pas
wayland_client_core.pas(82,15) Warning: An inherited method is hidden by "Dispatch:LongInt;"
Compiling wayland_shared_buffer.pas
wayland_shared_buffer.pas(82,3) Note: Local variable "flags" not used
wayland_client_core.pas(228,3) Note: Local variable "flags" not used
Compiling xdg_shell_protocol.pas
wlgui_app.pas(13,15) Error: Forward type not resolved "TWLWindow"
wlgui_app.pas(69,25) Fatal: There were 1 errors compiling module, stopping
Исправление: forward-тип в интерфейсной части

Проблема в том, что в wlgui_app.pas в interface я написал TWLWindow = class; — но компилятор FPC не может резолвить forward до того, как wlgui_window подключён. Нужно либо:

    Убрать forward из interface и вместо этого подключить wlgui_window в interface. Тогда цикл будет: wlgui_app → wlgui_window → wlgui_app (тоже в interface) — цикл недопустим.

    Разорвать цикл: перенести общие forward-объявления в отдельный модуль wlgui_forward.pas.

    Проще всего: не давать TWLApplication знать о TWLWindow. Пусть CreateWindow живёт в wlgui_window как функция, а TWLApplication хранит FWindows: TList как список TObject (без типизации).

Пойдём по пути №3 — самый простой и без циклов.
Правки в wlgui_app.pas

Убираем TWLWindow = class; из интерфейса. CreateWindow выносим в wlgui_window.pas как class function. FWindows: TList — просто TList.

Вот исправленный wlgui_app.pas:
pascal

unit wlgui_app;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  u4intf, u4utf8;

type
  TWLApplication = class;

  { Слушатель реестра — находит нужные интерфейсы }
  TWLRegistryListener = class(TInterfacedObject, IWlRegistryListener)
  private
    FApp: TWLApplication;
  public
    constructor Create(AApp: TWLApplication);
    procedure wl_registry_global(AWlRegistry: TWlRegistry; AName: DWord;
      AInterface: String; AVersion: DWord);
    procedure wl_registry_global_remove(AWlRegistry: TWlRegistry; AName: DWord);
  end;

  { Главный объект приложения }
  TWLApplication = class
  private
    FDisplay: TWlDisplay;
    FRegistry: TWlRegistry;
    FCompositor: TWlCompositor;
    FShm: TWlShm;
    FWmBase: TXdgWmBase;
    FSubcompositor: TWlSubcompositor;
    FSeat: TWlSeat;
    FLayerShell: Pointer;

    FWindows: TList;   // просто список TObject — без типизации на TWLWindow
    FRunning: Boolean;
    FRegistryListener: TWLRegistryListener;
  public
    constructor Create;
    destructor Destroy; override;

    function Initialize: Boolean;
    procedure Finalize;
    procedure Run;
    procedure Quit;

    procedure ProcessEvents;

    // Регистрация окон — вызывается из TWLWindow
    procedure RegisterWindow(Obj: TObject);
    procedure UnregisterWindow(Obj: TObject);

    property Display: TWlDisplay read FDisplay;
    property Compositor: TWlCompositor read FCompositor;
    property Shm: TWlShm read FShm;
    property WmBase: TXdgWmBase read FWmBase;
    property Subcompositor: TWlSubcompositor read FSubcompositor;
    property Seat: TWlSeat read FSeat;
    property LayerShell: Pointer read FLayerShell write FLayerShell;
    property Running: Boolean read FRunning write FRunning;
  end;

var
  App: TWLApplication = nil;

implementation

{ TWLRegistryListener }

constructor TWLRegistryListener.Create(AApp: TWLApplication);
begin
  inherited Create;
  FApp := AApp;
end;

procedure TWLRegistryListener.wl_registry_global(AWlRegistry: TWlRegistry;
  AName: DWord; AInterface: String; AVersion: DWord);
var
  Proxy: Pwl_proxy;
begin
  if AInterface = 'wl_compositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_compositor_interface, AVersion);
    FApp.FCompositor := TWlCompositor.Create(Proxy);
  end
  else if AInterface = 'wl_shm' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_shm_interface, AVersion);
    FApp.FShm := TWlShm.Create(Proxy);
  end
  else if AInterface = 'xdg_wm_base' then
  begin
    Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, AVersion);
    FApp.FWmBase := TXdgWmBase.Create(Proxy);
  end
  else if AInterface = 'wl_subcompositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_subcompositor_interface, AVersion);
    FApp.FSubcompositor := TWlSubcompositor.Create(Proxy);
  end
  else if AInterface = 'wl_seat' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_seat_interface, AVersion);
    FApp.FSeat := TWlSeat.Create(Proxy);
  end
  else if AInterface = 'zwlr_layer_shell_v1' then
  begin
    WriteLn('[wlgui] layer-shell found, version ', AVersion);
  end;
end;

procedure TWLRegistryListener.wl_registry_global_remove(
  AWlRegistry: TWlRegistry; AName: DWord);
begin
  // ignore
end;

{ TWLApplication }

constructor TWLApplication.Create;
begin
  inherited Create;
  FWindows := TList.Create;
  FRunning := False;
end;

destructor TWLApplication.Destroy;
var
  I: Integer;
begin
  if FWindows <> nil then
  begin
    for I := FWindows.Count - 1 downto 0 do
    begin
      try
        TObject(FWindows[I]).Free;
      except
      end;
    end;
    FreeAndNil(FWindows);
  end;
  Finalize;
  inherited;
end;

function TWLApplication.Initialize: Boolean;
begin
  Result := False;
  FDisplay := TWlDisplay(TWlDisplay.Connect(''));
  if FDisplay = nil then
  begin
    WriteLn('[wlgui] Cannot connect to Wayland display');
    Exit;
  end;

  FRegistry := FDisplay.GetRegistry;
  FRegistryListener := TWLRegistryListener.Create(Self);
  FRegistry.AddListener(FRegistryListener);

  FDisplay.Roundtrip;

  if (FCompositor = nil) or (FShm = nil) or (FWmBase = nil) then
  begin
    WriteLn('[wlgui] Required globals missing: compositor=', FCompositor <> nil,
            ' shm=', FShm <> nil, ' wm_base=', FWmBase <> nil);
    Exit;
  end;

  WriteLn('[wlgui] Wayland initialized');
  Result := True;
end;

procedure TWLApplication.Finalize;
begin
  if FSubcompositor <> nil then FreeAndNil(FSubcompositor);
  if FWmBase <> nil then FreeAndNil(FWmBase);
  if FSeat <> nil then FreeAndNil(FSeat);
  if FShm <> nil then FreeAndNil(FShm);
  if FCompositor <> nil then FreeAndNil(FCompositor);
  if FRegistry <> nil then FreeAndNil(FRegistry);
  if FDisplay <> nil then
  begin
    FDisplay.Disconnect;
    FreeAndNil(FDisplay);
  end;
end;

procedure TWLApplication.ProcessEvents;
begin
  if FDisplay = nil then Exit;
  try
    FDisplay.DispatchPending;
    FDisplay.Flush;
  except
    on E: Exception do
      WriteLn('[wlgui] Event error: ', E.Message);
  end;
end;

procedure TWLApplication.Run;
begin
  FRunning := True;
  WriteLn('[wlgui] Entering main loop');
  while FRunning do
  begin
    ProcessEvents;
    Sleep(10);
  end;
  WriteLn('[wlgui] Main loop exited');
end;

procedure TWLApplication.Quit;
begin
  FRunning := False;
end;

procedure TWLApplication.RegisterWindow(Obj: TObject);
begin
  if FWindows.IndexOf(Obj) < 0 then
    FWindows.Add(Obj);
end;

procedure TWLApplication.UnregisterWindow(Obj: TObject);
begin
  FWindows.Remove(Obj);
end;

initialization
  App := nil;

finalization
  if App <> nil then
    FreeAndNil(App);

end.

Правки в wlgui_window.pas

Нужно поменять AApp.RegisterWindow(Self) — теперь принимает TObject, всё сходится. Остальное без изменений.

Но! Сейчас в wlgui_window.interface у нас uses wlgui_types и forward TWLApplication = class;. А в implementation — uses wlgui_app. Это правильно. Единственное, что нужно — убрать procedure RegisterWindow(W: TWLWindow) из вызовов и заменить на TObject-версию.

Вот исправленный фрагмент в wlgui_window.pas (только изменённые места):
pascal

  // в constructor:
  AApp.RegisterWindow(Self);

  // в destructor:
  if FApp <> nil then
    FApp.UnregisterWindow(Self);

Больше ничего менять не надо — Self это TWLWindow, а RegisterWindow принимает TObject, неявное приведение работает.
Почему была ошибка

В FPC forward-объявление TWLWindow = class; в interface работает только если полное объявление класса видно в этом же interface. У нас оно в другом модуле (wlgui_window), который подключается только в implementation. FPC не умеет резолвить forward-типы через модули — нужен либо общий forward-модуль, либо отказ от forward.

Путь №3 (без forward) — самый чистый для такой архитектуры.
Проверь сборку
bash

fpc demo_window.pas

Должно собраться без ошибок (будут warning про Dispatch в wayland_client_core, но это уже было). Запусти:
bash

./demo_window

Ожидаемо:

    Окно 640×480 с заголовком «wlgui demo — moving red square».

    Мигающий фон, бегающий красный квадрат.

    Закрытие — крестиком в заголовке (если композитор даёт декорации).

Жду результат — и пойдём к wlgui_canvas.pas + wlgui_font.pas.
wlgui_window.pas(12,20) Error: Forward type not resolved "TWLApplication"
Та же проблема с forward-типом

Та же ошибка, но теперь в wlgui_window.pas: forward TWLApplication = class; не резолвится, потому что полное объявление в другом модуле.

Разорвём цикл радикально: wlgui_window.pas не должен знать о типе TWLApplication вообще. Вместо этого передаём TWLApplication как TObject и храним нужные поля приложения (Compositor, WmBase, Shm, Display) прямо в окне.
Правки в wlgui_window.pas

Убираем зависимость от wlgui_app. Передаём в конструктор всё, что нужно, через явные параметры — либо через промежуточный record-контекст.

Самый простой путь — передавать сам TWLApplication как TObject и потом делать as через отдельные свойства. Но это некрасиво.

Лучший путь: определить маленький интерфейс-«контекст» в отдельном модуле, который не создаёт цикл.

Хотя... ещё проще: в wlgui_window.pas хранить четыре поля (Compositor, WmBase, Shm, Display) и получать их при создании окна. Конструктор принимает их явно.

Но тогда демо-код будет громоздким.
Идея получше: отдельный модуль wlgui_context.pas

Он не знает ни о wlgui_app, ни о wlgui_window — только о Wayland-типах.
pascal

unit wlgui_context;
{$mode objfpc}{$H+}

interface

uses
  wayland_client_core, wayland_protocol, xdg_shell_protocol;

type
  TWLContext = class
  public
    Display: TWlDisplay;
    Compositor: TWlCompositor;
    Shm: TWlShm;
    WmBase: TXdgWmBase;
    Subcompositor: TWlSubcompositor;
    Seat: TWlSeat;
    LayerShell: Pointer;

    procedure RegisterWindow(Obj: TObject);
    procedure UnregisterWindow(Obj: TObject);

    procedure Quit;
    function Running: Boolean;
    procedure SetRunning(AValue: Boolean);

    constructor Create;
    destructor Destroy; override;
  private
    FWindows: TList;
    FRunning: Boolean;
    FOnQuit: TNotifyEvent;
  public
    property Windows: TList read FWindows;
    property OnQuit: TNotifyEvent read FOnQuit write FOnQuit;
    property IsRunning: Boolean read Running write SetRunning;
  end;

implementation

uses Classes, SysUtils;

constructor TWLContext.Create;
begin
  inherited;
  FWindows := TList.Create;
  FRunning := True;
end;

destructor TWLContext.Destroy;
begin
  FWindows.Free;
  inherited;
end;

procedure TWLContext.RegisterWindow(Obj: TObject);
begin
  if FWindows.IndexOf(Obj) < 0 then
    FWindows.Add(Obj);
end;

procedure TWLContext.UnregisterWindow(Obj: TObject);
begin
  FWindows.Remove(Obj);
end;

procedure TWLContext.Quit;
begin
  FRunning := False;
  if Assigned(FOnQuit) then
    FOnQuit(Self);
end;

function TWLContext.Running: Boolean;
begin
  Result := FRunning;
end;

procedure TWLContext.SetRunning(AValue: Boolean);
begin
  FRunning := AValue;
end;

end.

Теперь:

    wlgui_app.pas — наследник TWLContext или владелец TWLContext.

    wlgui_window.pas — принимает TWLContext, а не TWLApplication.

Финальная архитектура
text

wlgui_context.pas  ← не знает ни о ком
      ▲
      │
wlgui_app.pas      ← знает о wlgui_context, держит TWLContext + registry listener
wlgui_window.pas   ← знает о wlgui_context, не знает о wlgui_app

Никаких forward-типов. Цикл разорван.
Правки в wlgui_app.pas
pascal

unit wlgui_app;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  wlgui_context;

type
  TWLApplication = class;

  TWLRegistryListener = class(TInterfacedObject, IWlRegistryListener)
  private
    FApp: TWLApplication;
  public
    constructor Create(AApp: TWLApplication);
    procedure wl_registry_global(AWlRegistry: TWlRegistry; AName: DWord;
      AInterface: String; AVersion: DWord);
    procedure wl_registry_global_remove(AWlRegistry: TWlRegistry; AName: DWord);
  end;

  TWLApplication = class
  private
    FContext: TWLContext;
    FDisplay: TWlDisplay;
    FRegistry: TWlRegistry;
    FRegistryListener: TWLRegistryListener;
    FOwnsContext: Boolean;
  public
    constructor Create;
    destructor Destroy; override;

    function Initialize: Boolean;
    procedure Finalize;
    procedure Run;
    procedure Quit;

    procedure ProcessEvents;

    property Context: TWLContext read FContext;
    property Display: TWlDisplay read FDisplay;
    property Running: Boolean read FContext.Running;
  end;

var
  App: TWLApplication = nil;

implementation

constructor TWLRegistryListener.Create(AApp: TWLApplication);
begin
  inherited Create;
  FApp := AApp;
end;

procedure TWLRegistryListener.wl_registry_global(AWlRegistry: TWlRegistry;
  AName: DWord; AInterface: String; AVersion: DWord);
var
  Proxy: Pwl_proxy;
begin
  if AInterface = 'wl_compositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_compositor_interface, AVersion);
    FApp.Context.Compositor := TWlCompositor.Create(Proxy);
  end
  else if AInterface = 'wl_shm' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_shm_interface, AVersion);
    FApp.Context.Shm := TWlShm.Create(Proxy);
  end
  else if AInterface = 'xdg_wm_base' then
  begin
    Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, AVersion);
    FApp.Context.WmBase := TXdgWmBase.Create(Proxy);
  end
  else if AInterface = 'wl_subcompositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_subcompositor_interface, AVersion);
    FApp.Context.Subcompositor := TWlSubcompositor.Create(Proxy);
  end
  else if AInterface = 'wl_seat' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_seat_interface, AVersion);
    FApp.Context.Seat := TWlSeat.Create(Proxy);
  end
  else if AInterface = 'zwlr_layer_shell_v1' then
  begin
    WriteLn('[wlgui] layer-shell found, version ', AVersion);
  end;
end;

procedure TWLRegistryListener.wl_registry_global_remove(
  AWlRegistry: TWlRegistry; AName: DWord);
begin
end;

constructor TWLApplication.Create;
begin
  inherited Create;
  FContext := TWLContext.Create;
  FOwnsContext := True;
end;

destructor TWLApplication.Destroy;
var
  I: Integer;
begin
  // Закрываем окна (через Context)
  if FContext <> nil then
  begin
    for I := FContext.Windows.Count - 1 downto 0 do
    begin
      try
        TObject(FContext.Windows[I]).Free;
      except
      end;
    end;
  end;

  Finalize;

  if FOwnsContext and (FContext <> nil) then
    FreeAndNil(FContext);

  inherited;
end;

function TWLApplication.Initialize: Boolean;
begin
  Result := False;
  FDisplay := TWlDisplay(TWlDisplay.Connect(''));
  if FDisplay = nil then
  begin
    WriteLn('[wlgui] Cannot connect to Wayland display');
    Exit;
  end;
  FContext.Display := FDisplay;

  FRegistry := FDisplay.GetRegistry;
  FRegistryListener := TWLRegistryListener.Create(Self);
  FRegistry.AddListener(FRegistryListener);

  FDisplay.Roundtrip;

  if (FContext.Compositor = nil) or (FContext.Shm = nil) or (FContext.WmBase = nil) then
  begin
    WriteLn('[wlgui] Required globals missing');
    Exit;
  end;

  WriteLn('[wlgui] Wayland initialized');
  Result := True;
end;

procedure TWLApplication.Finalize;
begin
  if FContext.Subcompositor <> nil then FreeAndNil(FContext.Subcompositor);
  if FContext.WmBase <> nil then FreeAndNil(FContext.WmBase);
  if FContext.Seat <> nil then FreeAndNil(FContext.Seat);
  if FContext.Shm <> nil then FreeAndNil(FContext.Shm);
  if FContext.Compositor <> nil then FreeAndNil(FContext.Compositor);
  if FRegistry <> nil then FreeAndNil(FRegistry);
  if FDisplay <> nil then
  begin
    FDisplay.Disconnect;
    FreeAndNil(FDisplay);
    FContext.Display := nil;
  end;
end;

procedure TWLApplication.ProcessEvents;
begin
  if FDisplay = nil then Exit;
  try
    FDisplay.DispatchPending;
    FDisplay.Flush;
  except
    on E: Exception do
      WriteLn('[wlgui] Event error: ', E.Message);
  end;
end;

procedure TWLApplication.Run;
begin
  FContext.IsRunning := True;
  WriteLn('[wlgui] Entering main loop');
  while FContext.Running do
  begin
    ProcessEvents;
    Sleep(10);
  end;
  WriteLn('[wlgui] Main loop exited');
end;

procedure TWLApplication.Quit;
begin
  FContext.Quit;
end;

initialization
  App := nil;

finalization
  if App <> nil then
    FreeAndNil(App);

end.

Правки в wlgui_window.pas

Заменяем uses wlgui_app на uses wlgui_context и тип TWLApplication на TWLContext.
pascal

unit wlgui_window;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, BaseUnix,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  wlgui_types, wlgui_context;

type
  TWLWindow = class;

  TWLXdgSurfaceListener = class(TInterfacedObject, IXdgSurfaceListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_surface_configure(AXdgSurface: TXdgSurface; ASerial: DWord);
  end;

  TWLXdgToplevelListener = class(TInterfacedObject, IXdgToplevelListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_toplevel_configure(AXdgToplevel: TXdgToplevel;
      AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
    procedure xdg_toplevel_close(AXdgToplevel: TXdgToplevel);
  end;

  TWLWindow = class
  private
    FContext: TWLContext;
    FSurface: TWlSurface;
    FXdgSurface: TXdgSurface;
    FToplevel: TXdgToplevel;

    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FShmFd: cint;
    FShmSize: Integer;

    FWidth, FHeight, FStride: Integer;
    FConfigured: Boolean;
    FVisible: Boolean;
    FClosed: Boolean;
    FTitle: String;

    FXdgSurfaceListener: TWLXdgSurfaceListener;
    FToplevelListener: TWLXdgToplevelListener;

    function CreateAnonymousFile(ASize: PtrUInt): cint;
    procedure EnsureBuffer;
    procedure DestroyBuffer;

    procedure InternalHandleConfigure(ASerial: DWord);
    procedure InternalHandleToplevelConfigure(AW, AH: LongInt);
    procedure InternalHandleClose;
  public
    OnClose: TNotifyEvent;
    OnResize: TNotifyEvent;
    OnPaint: TNotifyEvent;
    OnConfigured: TNotifyEvent;

    constructor Create(AContext: TWLContext; const ATitle: String;
                       AW, AH: Integer);
    destructor Destroy; override;

    procedure Show;
    procedure Hide;
    procedure Commit;
    procedure Repaint;

    procedure Clear(AColor: TWLColor);
    procedure SetPixel(AX, AY: Integer; AColor: TWLColor);
    procedure FillRect(const ARect: TRectI; AColor: TWLColor);

    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Stride: Integer read FStride;
    property Pixels: PByte read FPixels;
    property Configured: Boolean read FConfigured;
    property Visible: Boolean read FVisible;
    property Closed: Boolean read FClosed;
    property Title: String read FTitle;
    property Surface: TWlSurface read FSurface;
    property XdgSurface: TXdgSurface read FXdgSurface;
    property Toplevel: TXdgToplevel read FToplevel;
    property Context: TWLContext read FContext;
  end;

{ Функция-фабрика — чтобы demo-код не путался с типом }
function CreateWLWindow(AContext: TWLContext; const ATitle: String;
                        AW, AH: Integer): TWLWindow;

implementation

function CreateWLWindow(AContext: TWLContext; const ATitle: String;
                        AW, AH: Integer): TWLWindow;
begin
  Result := TWLWindow.Create(AContext, ATitle, AW, AH);
end;

constructor TWLXdgSurfaceListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgSurfaceListener.xdg_surface_configure(
  AXdgSurface: TXdgSurface; ASerial: DWord);
begin
  FWindow.InternalHandleConfigure(ASerial);
end;

constructor TWLXdgToplevelListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgToplevelListener.xdg_toplevel_configure(
  AXdgToplevel: TXdgToplevel;
  AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
begin
  FWindow.InternalHandleToplevelConfigure(AWidth, AHeight);
end;

procedure TWLXdgToplevelListener.xdg_toplevel_close(
  AXdgToplevel: TXdgToplevel);
begin
  FWindow.InternalHandleClose;
end;

constructor TWLWindow.Create(AContext: TWLContext;
                             const ATitle: String; AW, AH: Integer);
begin
  inherited Create;

  FContext := AContext;
  FTitle := ATitle;
  FWidth := AW;
  FHeight := AH;
  FStride := 0;
  FConfigured := False;
  FVisible := False;
  FClosed := False;
  FShmFd := -1;
  FShmSize := 0;
  FBuffer := nil;
  FPool := nil;
  FPixels := nil;

  if (AContext = nil) or (AContext.Compositor = nil) or (AContext.WmBase = nil) then
    raise Exception.Create('TWLWindow: context not initialized');

  FSurface := AContext.Compositor.CreateSurface;
  if FSurface = nil then
    raise Exception.Create('TWLWindow: cannot create surface');

  FXdgSurface := AContext.WmBase.GetXdgSurface(FSurface);
  if FXdgSurface = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_surface');

  FXdgSurfaceListener := TWLXdgSurfaceListener.Create(Self);
  FXdgSurface.AddListener(FXdgSurfaceListener);

  FToplevel := FXdgSurface.GetToplevel;
  if FToplevel = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_toplevel');

  FToplevelListener := TWLXdgToplevelListener.Create(Self);
  FToplevel.AddListener(FToplevelListener);

  if ATitle <> '' then
    FToplevel.SetTitle(ATitle);
  FToplevel.SetAppId('wlgui.app');

  if (AW > 0) and (AH > 0) then
  begin
    FToplevel.SetMinSize(AW, AH);
    FToplevel.SetMaxSize(AW, AH);
  end;

  AContext.RegisterWindow(Self);

  FSurface.Commit;

  WriteLn('[wlgui] window created: "', ATitle, '" ', AW, 'x', AH);
end;

destructor TWLWindow.Destroy;
begin
  if FContext <> nil then
    FContext.UnregisterWindow(Self);

  DestroyBuffer;

  if FToplevel <> nil then FreeAndNil(FToplevel);
  if FXdgSurface <> nil then FreeAndNil(FXdgSurface);
  if FSurface <> nil then FreeAndNil(FSurface);

  inherited;
end;

function TWLWindow.CreateAnonymousFile(ASize: PtrUInt): cint;
const
  O_CLOEXEC = $80000;
var
  Name: String;
  R: cint;
begin
  Name := GetEnvironmentVariable('XDG_RUNTIME_DIR');
  if Name = '' then
    Name := '/tmp';
  Name := Name + '/wlgui-shm-XXXXXX';

  R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
  if R < 0 then
  begin
    Name := '/dev/shm/wlgui-shm-' + IntToStr(GetProcessID) +
            '-' + IntToStr(Random(100000));
    R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
    if R < 0 then
      Exit(-1);
  end;

  fpUnlink(PChar(Name));

  if fpFtruncate(R, ASize) < 0 then
  begin
    fpClose(R);
    Exit(-1);
  end;

  Result := R;
end;

procedure TWLWindow.EnsureBuffer;
var
  Size: Integer;
  Data: Pointer;
begin
  if (FWidth <= 0) or (FHeight <= 0) then Exit;
  if FBuffer <> nil then Exit;

  FStride := FWidth * 4;
  Size := FStride * FHeight;

  FShmFd := CreateAnonymousFile(Size);
  if FShmFd < 0 then
    raise Exception.Create('TWLWindow: cannot create SHM file');

  Data := fpMmap(nil, Size, PROT_READ or PROT_WRITE, MAP_SHARED, FShmFd, 0);
  if Data = MAP_FAILED then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
    raise Exception.Create('TWLWindow: cannot mmap SHM');
  end;

  FPixels := PByte(Data);
  FShmSize := Size;
  FillChar(FPixels^, Size, 0);

  FPool := FContext.Shm.CreatePool(FShmFd, Size);
  if FPool = nil then
    raise Exception.Create('TWLWindow: cannot create shm_pool');

  FBuffer := FPool.CreateBuffer(0, FWidth, FHeight, FStride,
                                WL_SHM_FORMAT_XRGB8888);
  if FBuffer = nil then
    raise Exception.Create('TWLWindow: cannot create wl_buffer');

  fpClose(FShmFd);
  FShmFd := -1;

  WriteLn('[wlgui] buffer created: ', FWidth, 'x', FHeight, ' stride=', FStride);
end;

procedure TWLWindow.DestroyBuffer;
begin
  if FBuffer <> nil then FreeAndNil(FBuffer);
  if FPool <> nil then FreeAndNil(FPool);
  if (FPixels <> nil) and (FShmSize > 0) then
  begin
    fpMunmap(FPixels, FShmSize);
    FPixels := nil;
    FShmSize := 0;
  end;
  if FShmFd >= 0 then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
  end;
end;

procedure TWLWindow.InternalHandleToplevelConfigure(AW, AH: LongInt);
var
  Resized: Boolean;
begin
  Resized := False;
  if (AW > 0) and (AH > 0) and
     ((AW <> FWidth) or (AH <> FHeight)) then
  begin
    FWidth := AW;
    FHeight := AH;
    Resized := True;
    DestroyBuffer;
  end;
  if Resized and Assigned(OnResize) then
    OnResize(Self);
end;

procedure TWLWindow.InternalHandleConfigure(ASerial: DWord);
begin
  FXdgSurface.AckConfigure(ASerial);
  EnsureBuffer;
  FConfigured := True;
  if Assigned(OnConfigured) then
    OnConfigured(Self);
end;

procedure TWLWindow.InternalHandleClose;
begin
  FClosed := True;
  if Assigned(OnClose) then
    OnClose(Self)
  else
    FContext.Quit;
end;

procedure TWLWindow.Show;
begin
  FVisible := True;
  Commit;
end;

procedure TWLWindow.Hide;
begin
  FVisible := False;
  if FSurface <> nil then
  begin
    FSurface.Attach(nil, 0, 0);
    FSurface.Commit;
  end;
end;

procedure TWLWindow.Commit;
begin
  if (FSurface = nil) or (FBuffer = nil) then Exit;
  FSurface.Attach(FBuffer, 0, 0);
  FSurface.Damage(0, 0, FWidth, FHeight);
  FSurface.Commit;
  FContext.Display.Flush;
end;

procedure TWLWindow.Repaint;
begin
  if Assigned(OnPaint) then
    OnPaint(Self);
  Commit;
end;

procedure TWLWindow.Clear(AColor: TWLColor);
begin
  if FPixels = nil then Exit;
  FillRect(TRectI.New(0, 0, FWidth, FHeight), AColor);
end;

procedure TWLWindow.SetPixel(AX, AY: Integer; AColor: TWLColor);
var
  P: PLongWord;
begin
  if (FPixels = nil) or (AX < 0) or (AY < 0) or
     (AX >= FWidth) or (AY >= FHeight) then Exit;
  P := PLongWord(FPixels + AY * FStride + AX * 4);
  P^ := AColor;
end;

procedure TWLWindow.FillRect(const ARect: TRectI; AColor: TWLColor);
var
  X1, Y1, X2, Y2, Y, X: Integer;
  Row: PLongWord;
begin
  if FPixels = nil then Exit;

  X1 := ARect.X; Y1 := ARect.Y;
  X2 := ARect.X + ARect.W; Y2 := ARect.Y + ARect.H;

  if X1 < 0 then X1 := 0;
  if Y1 < 0 then Y1 := 0;
  if X2 > FWidth then X2 := FWidth;
  if Y2 > FHeight then Y2 := FHeight;
  if (X1 >= X2) or (Y1 >= Y2) then Exit;

  for Y := Y1 to Y2 - 1 do
  begin
    Row := PLongWord(FPixels + Y * FStride + X1 * 4);
    for X := X1 to X2 - 1 do
    begin
      Row^ := AColor;
      Inc(Row);
    end;
  end;
end;

end.

Правки в demo_window.pas

Меняем вызов App.CreateWindow на CreateWLWindow(App.Context, ...):
pascal

program demo_window;
{$mode objfpc}{$H+}

uses
  cthreads, SysUtils, Classes,
  wlgui_types, wlgui_context, wlgui_app, wlgui_window;

var
  MyApp: TWLApplication;
  Win: TWLWindow;
  Frame: Integer = 0;

procedure OnPaint(Sender: TObject);
var
  W: TWLWindow;
  T: Integer;
begin
  W := TWLWindow(Sender);
  if Frame mod 2 = 0 then
    W.Clear(TWLColor($00203050))
  else
    W.Clear(TWLColor($00305020));

  W.FillRect(TRectI.New(10, 10, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, W.Height - 12, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, 10, 2, W.Height - 20), clWhite);
  W.FillRect(TRectI.New(W.Width - 12, 10, 2, W.Height - 20), clWhite);

  T := (Frame * 4) mod (W.Width - 40);
  W.FillRect(TRectI.New(20 + T, W.Height div 2 - 20, 40, 40), clRed);

  W.FillRect(TRectI.New(W.Width div 2 - 40, W.Height div 2 - 1, 80, 2), clYellow);
  W.FillRect(TRectI.New(W.Width div 2 - 1, W.Height div 2 - 40, 2, 80), clYellow);
end;

procedure OnClose(Sender: TObject);
begin
  WriteLn('[demo] window closed');
  MyApp.Quit;
end;

var
  LastTick: QWord;

begin
  WriteLn('wlgui demo starting...');

  MyApp := TWLApplication.Create;
  try
    if not MyApp.Initialize then
    begin
      WriteLn('Failed to initialize Wayland');
      Halt(1);
    end;

    Win := CreateWLWindow(MyApp.Context,
                          'wlgui demo — moving red square', 640, 480);
    Win.OnPaint := @OnPaint;
    Win.OnClose := @OnClose;

    // Ждём configure
    MyApp.Display.Roundtrip;
    Win.Show;
    Win.Repaint;

    WriteLn('[demo] entering loop. Ctrl+C to exit.');

    LastTick := GetTickCount64;
    while MyApp.Running do
    begin
      MyApp.ProcessEvents;
      if GetTickCount64 - LastTick >= 33 then
      begin
        LastTick := GetTickCount64;
        Inc(Frame);
        Win.Repaint;
      end;
      Sleep(5);
    end;

    WriteLn('[demo] loop exited');
  finally
    MyApp.Free;
  end;

  WriteLn('[demo] done.');
end.

Итог

Цикл разорван через wlgui_context:
text

wayland_*  (не знают ни о чём выше)
   ▲
wlgui_types, wlgui_context  (не знают о window/app)
   ▲
wlgui_window  →  wlgui_context
wlgui_app     →  wlgui_context
demo_window   →  все три

Никаких forward-типов между модулями, никаких циклов. Собирай:
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Если что-то ещё всплывёт — покажи ошибку, поправим.
wlgui_app.pas(44,44) Error: Record or object type expected
wlgui_app.pas(44,45) Error: Unknown record field identifier "Running"

Опечатка в property Running: Boolean read FContext.Running; — FPC не разрешает читать свойство через цепочку объект.свойство в объявлении property. Нужен промежуточный getter.
Правка в wlgui_app.pas

Добавляем приватный метод:
pascal

  TWLApplication = class
  private
    FContext: TWLContext;
    FDisplay: TWlDisplay;
    FRegistry: TWlRegistry;
    FRegistryListener: TWLRegistryListener;
    FOwnsContext: Boolean;
    function GetRunning: Boolean;
  public
    ...
    property Running: Boolean read GetRunning;
  end;

И в implementation:
pascal

function TWLApplication.GetRunning: Boolean;
begin
  Result := FContext.Running;
end;

Полный исправленный wlgui_app.pas
pascal

unit wlgui_app;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  wlgui_context;

type
  TWLApplication = class;

  TWLRegistryListener = class(TInterfacedObject, IWlRegistryListener)
  private
    FApp: TWLApplication;
  public
    constructor Create(AApp: TWLApplication);
    procedure wl_registry_global(AWlRegistry: TWlRegistry; AName: DWord;
      AInterface: String; AVersion: DWord);
    procedure wl_registry_global_remove(AWlRegistry: TWlRegistry; AName: DWord);
  end;

  TWLApplication = class
  private
    FContext: TWLContext;
    FDisplay: TWlDisplay;
    FRegistry: TWlRegistry;
    FRegistryListener: TWLRegistryListener;
    FOwnsContext: Boolean;
    function GetRunning: Boolean;
  public
    constructor Create;
    destructor Destroy; override;

    function Initialize: Boolean;
    procedure Finalize;
    procedure Run;
    procedure Quit;

    procedure ProcessEvents;

    property Context: TWLContext read FContext;
    property Display: TWlDisplay read FDisplay;
    property Running: Boolean read GetRunning;
  end;

var
  App: TWLApplication = nil;

implementation

constructor TWLRegistryListener.Create(AApp: TWLApplication);
begin
  inherited Create;
  FApp := AApp;
end;

procedure TWLRegistryListener.wl_registry_global(AWlRegistry: TWlRegistry;
  AName: DWord; AInterface: String; AVersion: DWord);
var
  Proxy: Pwl_proxy;
begin
  if AInterface = 'wl_compositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_compositor_interface, AVersion);
    FApp.Context.Compositor := TWlCompositor.Create(Proxy);
  end
  else if AInterface = 'wl_shm' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_shm_interface, AVersion);
    FApp.Context.Shm := TWlShm.Create(Proxy);
  end
  else if AInterface = 'xdg_wm_base' then
  begin
    Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, AVersion);
    FApp.Context.WmBase := TXdgWmBase.Create(Proxy);
  end
  else if AInterface = 'wl_subcompositor' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_subcompositor_interface, AVersion);
    FApp.Context.Subcompositor := TWlSubcompositor.Create(Proxy);
  end
  else if AInterface = 'wl_seat' then
  begin
    Proxy := AWlRegistry.Bind(AName, @wl_seat_interface, AVersion);
    FApp.Context.Seat := TWlSeat.Create(Proxy);
  end
  else if AInterface = 'zwlr_layer_shell_v1' then
  begin
    WriteLn('[wlgui] layer-shell found, version ', AVersion);
  end;
end;

procedure TWLRegistryListener.wl_registry_global_remove(
  AWlRegistry: TWlRegistry; AName: DWord);
begin
end;

constructor TWLApplication.Create;
begin
  inherited Create;
  FContext := TWLContext.Create;
  FOwnsContext := True;
end;

destructor TWLApplication.Destroy;
var
  I: Integer;
begin
  if FContext <> nil then
  begin
    for I := FContext.Windows.Count - 1 downto 0 do
    begin
      try
        TObject(FContext.Windows[I]).Free;
      except
      end;
    end;
  end;

  Finalize;

  if FOwnsContext and (FContext <> nil) then
    FreeAndNil(FContext);

  inherited;
end;

function TWLApplication.GetRunning: Boolean;
begin
  Result := FContext.Running;
end;

function TWLApplication.Initialize: Boolean;
begin
  Result := False;
  FDisplay := TWlDisplay(TWlDisplay.Connect(''));
  if FDisplay = nil then
  begin
    WriteLn('[wlgui] Cannot connect to Wayland display');
    Exit;
  end;
  FContext.Display := FDisplay;

  FRegistry := FDisplay.GetRegistry;
  FRegistryListener := TWLRegistryListener.Create(Self);
  FRegistry.AddListener(FRegistryListener);

  FDisplay.Roundtrip;

  if (FContext.Compositor = nil) or (FContext.Shm = nil) or (FContext.WmBase = nil) then
  begin
    WriteLn('[wlgui] Required globals missing');
    Exit;
  end;

  WriteLn('[wlgui] Wayland initialized');
  Result := True;
end;

procedure TWLApplication.Finalize;
begin
  if FContext.Subcompositor <> nil then FreeAndNil(FContext.Subcompositor);
  if FContext.WmBase <> nil then FreeAndNil(FContext.WmBase);
  if FContext.Seat <> nil then FreeAndNil(FContext.Seat);
  if FContext.Shm <> nil then FreeAndNil(FContext.Shm);
  if FContext.Compositor <> nil then FreeAndNil(FContext.Compositor);
  if FRegistry <> nil then FreeAndNil(FRegistry);
  if FDisplay <> nil then
  begin
    FDisplay.Disconnect;
    FreeAndNil(FDisplay);
    FContext.Display := nil;
  end;
end;

procedure TWLApplication.ProcessEvents;
begin
  if FDisplay = nil then Exit;
  try
    FDisplay.DispatchPending;
    FDisplay.Flush;
  except
    on E: Exception do
      WriteLn('[wlgui] Event error: ', E.Message);
  end;
end;

procedure TWLApplication.Run;
begin
  FContext.IsRunning := True;
  WriteLn('[wlgui] Entering main loop');
  while FContext.Running do
  begin
    ProcessEvents;
    Sleep(10);
  end;
  WriteLn('[wlgui] Main loop exited');
end;

procedure TWLApplication.Quit;
begin
  FContext.Quit;
end;

initialization
  App := nil;

finalization
  if App <> nil then
    FreeAndNil(App);

end.

Собирай снова:
bash

fpc -Fu. -Fuwlgui demo_window.pas

Это классическая ошибка FPC — в property нельзя писать read SomeObject.SomeProperty, только read SomeField, read SomeGetter, read SomeIndex. В отличие от Delphi, где read FField.Prop тоже не работает, но сообщение другое.
demo_window.pas(58,20) Error: Incompatible types: got "<address of procedure(TObject);Register>" expected "<procedure variable type of procedure(TObject) of object;Register>"
demo_window.pas(59,20) Error: Incompatible types: got "<address of procedure(TObject);Register>" expected "<procedure variable type of procedure(TObject) of object;Register>"
Ошибка: TNotifyEvent требует метод объекта, а не процедуру

TNotifyEvent в FPC — это procedure(Sender: TObject) of object, то есть метод класса. А у нас OnPaint и OnClose — глобальные процедуры. Нужно либо:

    Сделать их методами какого-то класса (например, TForm-обёртки).

    Заменить тип callback-полей на обычный procedure(Sender: TObject).

Для простоты пойдём по пути №2 — определим в wlgui_types.pas собственный тип:
pascal

type
  TWLNotifyEvent = procedure(Sender: TObject);

И поменяем TNotifyEvent → TWLNotifyEvent в wlgui_window.pas.
Правки в wlgui_types.pas

Добавить в interface:
pascal

type
  TWLNotifyEvent = procedure(Sender: TObject);

Правки в wlgui_window.pas

Заменить все TNotifyEvent на TWLNotifyEvent:
pascal

  public
    OnClose: TWLNotifyEvent;
    OnResize: TWLNotifyEvent;
    OnPaint: TWLNotifyEvent;
    OnConfigured: TWLNotifyEvent;

И в uses — wlgui_types уже подключён, тип будет виден.
Правки в wlgui_context.pas

Тоже есть FOnQuit: TNotifyEvent — заменяем:
pascal

uses
  Classes, SysUtils, wlgui_types;

type
  TWLContext = class
  ...
  public
    property OnQuit: TWLNotifyEvent read FOnQuit write FOnQuit;
  ...
  end;

(поле FOnQuit: TWLNotifyEvent)
Что менять в demo_window.pas

Ничего — OnPaint := @OnPaint; теперь работает, потому что OnPaint — глобальная процедура procedure(Sender: TObject), и @OnPaint совместим с TWLNotifyEvent.
Альтернатива: сделать callback-и методами

Если ты предпочитаешь of object (что удобнее для будущего — обработчики в классе органайзера), можно оставить TNotifyEvent и сделать обработчики методами какого-то класса. Например:
pascal

type
  TDemoApp = class
    procedure OnPaint(Sender: TObject);
    procedure OnClose(Sender: TObject);
  end;

Но для теста проще TWLNotifyEvent.
Итог изменений

Три файла:
wlgui_types.pas — добавить тип
pascal

type
  TWLNotifyEvent = procedure(Sender: TObject);

wlgui_context.pas — использовать свой тип
pascal

uses
  Classes, SysUtils, wlgui_types;
...
  FOnQuit: TWLNotifyEvent;
...
  property OnQuit: TWLNotifyEvent read FOnQuit write FOnQuit;

wlgui_window.pas — заменить TNotifyEvent на TWLNotifyEvent
pascal

  public
    OnClose: TWLNotifyEvent;
    OnResize: TWLNotifyEvent;
    OnPaint: TWLNotifyEvent;
    OnConfigured: TWLNotifyEvent;

Собирай:
bash

fpc -Fu. -Fuwlgui demo_window.pas

Должно собраться. Если пойдут ещё ошибки такого рода — просто продолжай заменять TNotifyEvent на TWLNotifyEvent, где встретится.
Спасибо! Собралось. Запустил. Окна не видно, в консоле: ./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
interface 'xdg_toplevel' has no event 3
[demo] entering loop. Ctrl+C to exit.
Ошибка interface 'xdg_toplevel' has no event 3 — баг в xdg_shell_protocol.pas

Это не наша вина — это несоответствие версий. Посмотрим на факты:

    В xdg_shell_protocol.pas интерфейс xdg_toplevel объявлен с version := 2.

    При биндинге в wlgui_app.pas мы передаём AVersion — то, что предлагает композитор, обычно 6+.

    Композитор видит, что клиент запросил версию X, и присылает событие, которое в этой версии есть, но в нашем клиентском дескрипторе его нет.

Точнее: xdg_toplevel в v1 имел 2 события (configure, close). В v2 добавилось событие configure_bounds (event index 2). В v4 — wm_capabilities (event index 3). Сообщение «has no event 3» означает, что композитор попытался отправить нам событие с opcode=3, но в нашей таблице xdg_toplevel_events только 2 записи (configure, close).

Причина: мы забиндили xdg_toplevel с запрошенной версией, большей чем у нашего дескриптора, и композитор шлёт события, которых наш proxy-handler не знает.
Правильное решение

При биндинге всегда просить Min(версия_композитора, версия_нашего_дескриптора). Мы это делаем в wlgui_app.pas? Нет, мы передаём AVersion как есть. И в xdg_shell_protocol.pas для xdg_toplevel стоит version := 2, но мы просим больше.

Смотрим глубже — TXdgWmBase.GetXdgSurface:
pascal

function TXdgWmBase.GetXdgSurface(ASurface: TWlSurface; ...): TXdgSurface;
begin
  id := wl_proxy_marshal_constructor(FProxy,
      _GET_XDG_SURFACE, @xdg_surface_interface, nil, ASurface.Proxy);
  ...

При создании xdg_surface через маршаллинг наследуется версия parent proxy (xdg_wm_base). А xdg_wm_base мы забиндили с AVersion = то, что даёт композитор (6+). Значит xdg_surface получит тоже 6+. Аналогично xdg_toplevel получит версию от xdg_surface.

Итог: наш дескриптор xdg_toplevel знает только 2 события, а композитор шлёт события v4+.
Что делать

Способ 1 (правильный, архитектурный) — забиндить xdg_wm_base с Min(AVersion, 2), чтобы вся цепочка xdg_wm_base → xdg_surface → xdg_toplevel имела версию 2, и композитор не слал лишние события.
pascal

else if AInterface = 'xdg_wm_base' then
begin
  if AVersion > 2 then AVersion := 2;  // ← ограничиваем
  Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, AVersion);
  FApp.Context.WmBase := TXdgWmBase.Create(Proxy);
end

Но! В xdg_shell_protocol.pas xdg_wm_base_interface.version := 2 — значит, Bind должен передать версию, не превышающую дескриптор. Наш код передаёт AVersion (может быть 6), и wl_registry.bind создаёт proxy с версией 6, но наш handler прописан только на 2 события. Отсюда коллизия.

Правильная логика: версия биндинга = Min(версия_композитора, версия_нашего_дескриптора). Делаем это для всех глобалов.
Патч wlgui_app.pas

Заменяем wl_registry_global на такой:
pascal

procedure TWLRegistryListener.wl_registry_global(AWlRegistry: TWlRegistry;
  AName: DWord; AInterface: String; AVersion: DWord);
var
  Proxy: Pwl_proxy;
  V: DWord;
begin
  if AInterface = 'wl_compositor' then
  begin
    V := AVersion;
    if V > 4 then V := 4;  // наш дескриптор wl_compositor = 5, но обычно хватает 4
    Proxy := AWlRegistry.Bind(AName, @wl_compositor_interface, V);
    FApp.Context.Compositor := TWlCompositor.Create(Proxy);
  end
  else if AInterface = 'wl_shm' then
  begin
    V := AVersion;
    if V > 1 then V := 1;
    Proxy := AWlRegistry.Bind(AName, @wl_shm_interface, V);
    FApp.Context.Shm := TWlShm.Create(Proxy);
  end
  else if AInterface = 'xdg_wm_base' then
  begin
    // КРИТИЧНО: ограничиваем до 2 — наш дескриптор знает только v1/v2 события
    V := AVersion;
    if V > 2 then V := 2;
    Proxy := AWlRegistry.Bind(AName, @xdg_wm_base_interface, V);
    FApp.Context.WmBase := TXdgWmBase.Create(Proxy);
  end
  else if AInterface = 'wl_subcompositor' then
  begin
    V := AVersion;
    if V > 1 then V := 1;
    Proxy := AWlRegistry.Bind(AName, @wl_subcompositor_interface, V);
    FApp.Context.Subcompositor := TWlSubcompositor.Create(Proxy);
  end
  else if AInterface = 'wl_seat' then
  begin
    V := AVersion;
    if V > 5 then V := 5;  // наш дескриптор знает до 7, но события до 5
    Proxy := AWlRegistry.Bind(AName, @wl_seat_interface, V);
    FApp.Context.Seat := TWlSeat.Create(Proxy);
  end
  else if AInterface = 'zwlr_layer_shell_v1' then
  begin
    WriteLn('[wlgui] layer-shell found, version ', AVersion);
  end;
end;

Но это не всё — окно всё равно может не появиться

Причина вторая: окно не показывается, пока не будет AckConfigure + Attach + Commit. У нас это должно произойти в InternalHandleConfigure. Проверим, приходит ли xdg_surface.configure. Судя по логу — мы не видим ни buffer created, ни window created после configure. То есть xdg_surface.configure не приходит. Почему?

Скорее всего, композитор не может отправить configure из-за той самой ошибки has no event 3 — протокол сломался, соединение не работает как надо.
Ещё один важный момент — порядок Bind для wl_seat

В нашем дескрипторе wl_seat version=7, но события wl_seat определены только для 2 (capabilities, name). Всё ок.
Патч xdg_shell_protocol.pas — тоже важно

В xdg_shell_protocol.pas в initialization установлены версии:
pascal

xdg_wm_base_interface.version := 2;
xdg_surface_interface.version := 2;
xdg_toplevel_interface.version := 2;
xdg_popup_interface.version := 2;
xdg_positioner_interface.version := 2;

Это правильно для наших дескрипторов. Проблема была в том, что Bind передавал больше.

Однако есть тонкость: wl_registry.bind в wayland_client_core.pas вызывается с AVersion — как есть. Композитор создаёт proxy с этой версией, и прокси-объект внутри libwayland получает «version=6». Когда композитор отправляет событие #3 (для v4+), libwayland пытается его распарсить — и наш handler не имеет этого события. Если бы версия была 2, композитор бы не отправлял это событие вообще.

Итог: правильный Min() — обязателен.
Дополнительные проверки

Добавь отладочные WriteLn в TWLWindow.InternalHandleToplevelConfigure и InternalHandleConfigure:
pascal

procedure TWLWindow.InternalHandleToplevelConfigure(AW, AH: LongInt);
begin
  WriteLn('[wlgui] toplevel configure: ', AW, 'x', AH);
  ...
end;

procedure TWLWindow.InternalHandleConfigure(ASerial: DWord);
begin
  WriteLn('[wlgui] xdg_surface configure, serial=', ASerial);
  ...
end;

Если после патча Bind увидишь:
text

[wlgui] toplevel configure: 640x480
[wlgui] xdg_surface configure, serial=42
[wlgui] buffer created: 640x480 stride=2560

— всё работает, окно появится.
Собери и запусти
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Ожидаемый лог:
text

wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] toplevel configure: 640x480
[wlgui] xdg_surface configure, serial=NNN
[wlgui] buffer created: 640x480 stride=2560
[demo] entering loop. Ctrl+C to exit.

И окно с мигающим фоном и бегающим квадратом.

Если окно всё равно не появится — покажи лог, посмотрим дальше.
Спасибо! Мигающее окно с летящим квадратом появилось. Некоторое время работает, окно исчезает и появляется надпись про Broken pipe: ./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] buffer created: 640x480 stride=2560
[demo] entering loop. Ctrl+C to exit.
Error sending request for wl_surface.damage: Broken pipe
Broken pipe — классическая ошибка в Wayland: гонка буфера

Причина: мы перерисовываем буфер, пока композитор его ещё читает. Или точнее — мы повторно привязываем тот же wl_buffer, не дожидаясь wl_buffer.release, а иногда и перезаписываем pixel_data для буфера, который сейчас используется композитором.

Wayland явно требует:

    После wl_surface.commit с attach(buffer), клиент не должен менять содержимое буфера, пока не получит wl_buffer.release.

Мы это правило нарушаем: каждый кадр делаем Attach(FBuffer) + Damage + Commit, не слушая wl_buffer.release. В итоге libwayland-клиент может отправить запрос в момент, когда соединение уже развалилось (композитор закрыл окно / приостановил приём) — и мы видим «Broken pipe».

Есть две отдельные проблемы, которые наслаиваются:
Проблема A. Нет wl_buffer.release listener

Каждый wl_buffer должен иметь listener с методом release. Композитор присылает release, когда буфер больше не нужен. До этого мы не имеем права переиспользовать буфер.
Проблема B. Один буфер и «damage 0,0,W,H» каждый кадр

Мы делаем Attach+Commit каждый кадр с тем же буфером. Композитор может копить эти коммиты, и libwayland-клиент переполняет очередь (backpressure). При 30 fps и 640×480 — не должно бы, но при отрисовке в цикле без пауз — запросто.
Решение: двойная буферизация + wl_buffer.release

Правильный подход для анимации — два буфера (double buffering). Пока композитор показывает буфер A, мы рисуем в буфер B. Когда он отпускает A — переключаемся.

Плюс — wl_buffer.release listener.
Патч wlgui_window.pas

Добавим listener для wl_buffer:
pascal

type
  TWLBufferListener = class(TInterfacedObject, IWlBufferListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure wl_buffer_release(AWlBuffer: TWlBuffer);
  end;

В TWLWindow:
pascal

  TWLWindow = class
  private
    ...
    // Двойная буферизация
    FBuffers: array[0..1] of record
      Buffer: TWlBuffer;
      Pool: TWlShmPool;
      Pixels: PByte;
      Fd: cint;
      Size: Integer;
      Released: Boolean;
    end;
    FBackIndex: Integer;   // какой буфер рисуем сейчас
    FBufferListener: array[0..1] of TWLBufferListener;
    ...

Это громоздко. Давай сделаем через маленький вспомогательный record/класс TWLShmBuffer, чтобы код читался.
Отдельный класс TWLShmBuffer (внутри wlgui_window.pas)
pascal

type
  TWLShmBuffer = class
  private
    FOwner: TWLWindow;
    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FFd: cint;
    FSize: Integer;
    FStride: Integer;
    FWidth, FHeight: Integer;
    FReleased: Boolean;
    FListener: TWLBufferListener;
    function CreateAnonymousFile(ASize: PtrUInt): cint;
  public
    constructor Create(AOwner: TWLWindow; AContext: TWLContext;
                       AW, AH: Integer);
    destructor Destroy; override;
    procedure MarkBusy;     // отправлен композитору
    procedure MarkReleased; // получен release
    property Buffer: TWlBuffer read FBuffer;
    property Pixels: PByte read FPixels;
    property Stride: Integer read FStride;
    property Released: Boolean read FReleased;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
  end;

И в TWLWindow:
pascal

  private
    FBuffers: array[0..1] of TWLShmBuffer;
    FDrawIndex: Integer;   // индекс буфера, в который рисуем

Логика:

    EnsureBuffers — создаём два TWLShmBuffer.

    Commit — берём FBuffers[FDrawIndex], Attach, Damage, Commit, MarkBusy, переключаем FDrawIndex := 1 - FDrawIndex.

    В OnBufferRelease (вызывается listener'ом) — MarkReleased соответствующего буфера.

    Перед рисованием нового кадра — выбираем буфер, который released (или оба released — берём другой от текущего).

Минимальный, но правильный вариант

Чтобы не раздувать код, сделаю более компактно:

    Оставляю один TWLShmBuffer-класс.

    Массив из 2 буферов.

    В Commit — ждём освободившийся буфер.

    Если оба заняты — пропускаем кадр (не рисуем в занятый, не коммитим).

Это стандартный подход в Wayland-анимациях.
Полный патч wlgui_window.pas

Вот новая версия модуля целиком (убрал лишнее, добавил двойную буферизацию и release-listener):
pascal

unit wlgui_window;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, BaseUnix,
  wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util,
  wlgui_types, wlgui_context;

type
  TWLWindow = class;

  { --- wl_buffer.release listener --- }
  TWLBufferListener = class(TInterfacedObject, IWlBufferListener)
  private
    FWindow: TWLWindow;
    FIndex: Integer;
  public
    constructor Create(AWindow: TWLWindow; AIndex: Integer);
    procedure wl_buffer_release(AWlBuffer: TWlBuffer);
  end;

  { --- xdg_surface.configure --- }
  TWLXdgSurfaceListener = class(TInterfacedObject, IXdgSurfaceListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_surface_configure(AXdgSurface: TXdgSurface; ASerial: DWord);
  end;

  { --- xdg_toplevel.configure / close --- }
  TWLXdgToplevelListener = class(TInterfacedObject, IXdgToplevelListener)
  private
    FWindow: TWLWindow;
  public
    constructor Create(AWindow: TWLWindow);
    procedure xdg_toplevel_configure(AXdgToplevel: TXdgToplevel;
      AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
    procedure xdg_toplevel_close(AXdgToplevel: TXdgToplevel);
  end;

  { --- Один SHM-буфер --- }
  TWLShmBuffer = class
  private
    FBuffer: TWlBuffer;
    FPool: TWlShmPool;
    FPixels: PByte;
    FShmFd: cint;
    FShmSize: Integer;
    FStride: Integer;
    FWidth, FHeight: Integer;
    FReleased: Boolean;
    FListener: TWLBufferListener;
    function CreateAnonymousFile(ASize: PtrUInt): cint;
  public
    constructor Create(AContext: TWLContext; AOwner: TWLWindow;
                       AW, AH, AIndex: Integer);
    destructor Destroy; override;
    procedure MarkBusy;
    procedure MarkReleased;
    property Buffer: TWlBuffer read FBuffer;
    property Pixels: PByte read FPixels;
    property Stride: Integer read FStride;
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Released: Boolean read FReleased;
  end;

  { --- Окно --- }
  TWLWindow = class
  private
    FContext: TWLContext;
    FSurface: TWlSurface;
    FXdgSurface: TXdgSurface;
    FToplevel: TXdgToplevel;

    FBuffers: array[0..1] of TWLShmBuffer;
    FDrawIndex: Integer;

    FWidth, FHeight: Integer;
    FConfigured: Boolean;
    FVisible: Boolean;
    FClosed: Boolean;
    FTitle: String;

    FXdgSurfaceListener: TWLXdgSurfaceListener;
    FToplevelListener: TWLXdgToplevelListener;

    procedure EnsureBuffers;
    procedure DestroyBuffers;

    procedure InternalHandleConfigure(ASerial: DWord);
    procedure InternalHandleToplevelConfigure(AW, AH: LongInt);
    procedure InternalHandleClose;
  public
    OnClose: TWLNotifyEvent;
    OnResize: TWLNotifyEvent;
    OnPaint: TWLNotifyEvent;
    OnConfigured: TWLNotifyEvent;

    constructor Create(AContext: TWLContext; const ATitle: String;
                       AW, AH: Integer);
    destructor Destroy; override;

    procedure Show;
    procedure Hide;
    procedure Commit;
    procedure Repaint;

    // Возвращает указатель на пиксели буфера для рисования, или nil если
    // нет свободного буфера (тогда кадр надо пропустить).
    function BeginPaint: PByte;
    // Отправляет заполненный буфер композитору.
    procedure EndPaint;

    procedure Clear(AColor: TWLColor);
    procedure SetPixel(AX, AY: Integer; AColor: TWLColor);
    procedure FillRect(const ARect: TRectI; AColor: TWLColor);

    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Configured: Boolean read FConfigured;
    property Visible: Boolean read FVisible;
    property Closed: Boolean read FClosed;
    property Title: String read FTitle;
    property Surface: TWlSurface read FSurface;
    property XdgSurface: TXdgSurface read FXdgSurface;
    property Toplevel: TXdgToplevel read FToplevel;
    property Context: TWLContext read FContext;
    property DrawIndex: Integer read FDrawIndex;
  end;

function CreateWLWindow(AContext: TWLContext; const ATitle: String;
                        AW, AH: Integer): TWLWindow;

implementation

function CreateWLWindow(AContext: TWLContext; const ATitle: String;
                        AW, AH: Integer): TWLWindow;
begin
  Result := TWLWindow.Create(AContext, ATitle, AW, AH);
end;

{ ============================================================ }
{  TWLBufferListener                                            }
{ ============================================================ }

constructor TWLBufferListener.Create(AWindow: TWLWindow; AIndex: Integer);
begin
  inherited Create;
  FWindow := AWindow;
  FIndex := AIndex;
end;

procedure TWLBufferListener.wl_buffer_release(AWlBuffer: TWlBuffer);
begin
  if (FWindow <> nil) and (FIndex >= 0) and (FIndex <= 1) then
    if FWindow.FBuffers[FIndex] <> nil then
      FWindow.FBuffers[FIndex].MarkReleased;
end;

{ ============================================================ }
{  TWLXdgSurfaceListener                                        }
{ ============================================================ }

constructor TWLXdgSurfaceListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgSurfaceListener.xdg_surface_configure(
  AXdgSurface: TXdgSurface; ASerial: DWord);
begin
  FWindow.InternalHandleConfigure(ASerial);
end;

{ ============================================================ }
{  TWLXdgToplevelListener                                       }
{ ============================================================ }

constructor TWLXdgToplevelListener.Create(AWindow: TWLWindow);
begin
  inherited Create;
  FWindow := AWindow;
end;

procedure TWLXdgToplevelListener.xdg_toplevel_configure(
  AXdgToplevel: TXdgToplevel;
  AWidth: LongInt; AHeight: LongInt; AStates: Pwl_array);
begin
  FWindow.InternalHandleToplevelConfigure(AWidth, AHeight);
end;

procedure TWLXdgToplevelListener.xdg_toplevel_close(
  AXdgToplevel: TXdgToplevel);
begin
  FWindow.InternalHandleClose;
end;

{ ============================================================ }
{  TWLShmBuffer                                                 }
{ ============================================================ }

function TWLShmBuffer.CreateAnonymousFile(ASize: PtrUInt): cint;
const
  O_CLOEXEC = $80000;
var
  Name: String;
  R: cint;
begin
  Name := GetEnvironmentVariable('XDG_RUNTIME_DIR');
  if Name = '' then Name := '/tmp';
  Name := Name + '/wlgui-shm-XXXXXX';
  R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
  if R < 0 then
  begin
    Name := '/dev/shm/wlgui-shm-' + IntToStr(GetProcessID) +
            '-' + IntToStr(Random(1000000));
    R := fpOpen(PChar(Name), O_CREAT or O_RDWR or O_CLOEXEC, &0600);
    if R < 0 then Exit(-1);
  end;
  fpUnlink(PChar(Name));
  if fpFtruncate(R, ASize) < 0 then
  begin
    fpClose(R);
    Exit(-1);
  end;
  Result := R;
end;

constructor TWLShmBuffer.Create(AContext: TWLContext; AOwner: TWLWindow;
                                AW, AH, AIndex: Integer);
var
  Size: Integer;
  Data: Pointer;
begin
  inherited Create;
  FWidth := AW;
  FHeight := AH;
  FStride := AW * 4;
  Size := FStride * AH;
  FReleased := True;
  FShmFd := -1;
  FShmSize := 0;
  FBuffer := nil;
  FPool := nil;
  FPixels := nil;

  FShmFd := CreateAnonymousFile(Size);
  if FShmFd < 0 then
    raise Exception.Create('TWLShmBuffer: cannot create SHM file');

  Data := fpMmap(nil, Size, PROT_READ or PROT_WRITE, MAP_SHARED, FShmFd, 0);
  if Data = MAP_FAILED then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
    raise Exception.Create('TWLShmBuffer: cannot mmap SHM');
  end;

  FPixels := PByte(Data);
  FShmSize := Size;
  FillChar(FPixels^, Size, 0);

  FPool := AContext.Shm.CreatePool(FShmFd, Size);
  if FPool = nil then
    raise Exception.Create('TWLShmBuffer: cannot create pool');

  FBuffer := FPool.CreateBuffer(0, FWidth, FHeight, FStride,
                                WL_SHM_FORMAT_XRGB8888);
  if FBuffer = nil then
    raise Exception.Create('TWLShmBuffer: cannot create buffer');

  // release listener
  FListener := TWLBufferListener.Create(AOwner, AIndex);
  FBuffer.AddListener(FListener);

  fpClose(FShmFd);
  FShmFd := -1;
end;

destructor TWLShmBuffer.Destroy;
begin
  if FBuffer <> nil then FreeAndNil(FBuffer);
  if FPool <> nil then FreeAndNil(FPool);
  if (FPixels <> nil) and (FShmSize > 0) then
  begin
    fpMunmap(FPixels, FShmSize);
    FPixels := nil;
  end;
  if FShmFd >= 0 then
  begin
    fpClose(FShmFd);
    FShmFd := -1;
  end;
  inherited;
end;

procedure TWLShmBuffer.MarkBusy;
begin
  FReleased := False;
end;

procedure TWLShmBuffer.MarkReleased;
begin
  FReleased := True;
end;

{ ============================================================ }
{  TWLWindow                                                    }
{ ============================================================ }

constructor TWLWindow.Create(AContext: TWLContext;
                             const ATitle: String; AW, AH: Integer);
begin
  inherited Create;

  FContext := AContext;
  FTitle := ATitle;
  FWidth := AW;
  FHeight := AH;
  FConfigured := False;
  FVisible := False;
  FClosed := False;
  FDrawIndex := 0;
  FBuffers[0] := nil;
  FBuffers[1] := nil;

  if (AContext = nil) or (AContext.Compositor = nil) or (AContext.WmBase = nil) then
    raise Exception.Create('TWLWindow: context not initialized');

  FSurface := AContext.Compositor.CreateSurface;
  if FSurface = nil then
    raise Exception.Create('TWLWindow: cannot create surface');

  FXdgSurface := AContext.WmBase.GetXdgSurface(FSurface);
  if FXdgSurface = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_surface');

  FXdgSurfaceListener := TWLXdgSurfaceListener.Create(Self);
  FXdgSurface.AddListener(FXdgSurfaceListener);

  FToplevel := FXdgSurface.GetToplevel;
  if FToplevel = nil then
    raise Exception.Create('TWLWindow: cannot create xdg_toplevel');

  FToplevelListener := TWLXdgToplevelListener.Create(Self);
  FToplevel.AddListener(FToplevelListener);

  if ATitle <> '' then
    FToplevel.SetTitle(ATitle);
  FToplevel.SetAppId('wlgui.app');

  if (AW > 0) and (AH > 0) then
  begin
    FToplevel.SetMinSize(AW, AH);
    FToplevel.SetMaxSize(AW, AH);
  end;

  AContext.RegisterWindow(Self);

  FSurface.Commit;

  WriteLn('[wlgui] window created: "', ATitle, '" ', AW, 'x', AH);
end;

destructor TWLWindow.Destroy;
begin
  if FContext <> nil then
    FContext.UnregisterWindow(Self);

  DestroyBuffers;

  if FToplevel <> nil then FreeAndNil(FToplevel);
  if FXdgSurface <> nil then FreeAndNil(FXdgSurface);
  if FSurface <> nil then FreeAndNil(FSurface);

  inherited;
end;

procedure TWLWindow.EnsureBuffers;
begin
  if FBuffers[0] <> nil then Exit;
  if (FWidth <= 0) or (FHeight <= 0) then Exit;

  FBuffers[0] := TWLShmBuffer.Create(FContext, Self, FWidth, FHeight, 0);
  FBuffers[1] := TWLShmBuffer.Create(FContext, Self, FWidth, FHeight, 1);
  FDrawIndex := 0;

  WriteLn('[wlgui] 2 buffers created: ', FWidth, 'x', FHeight,
          ' stride=', FBuffers[0].Stride);
end;

procedure TWLWindow.DestroyBuffers;
begin
  if FBuffers[0] <> nil then FreeAndNil(FBuffers[0]);
  if FBuffers[1] <> nil then FreeAndNil(FBuffers[1]);
end;

procedure TWLWindow.InternalHandleToplevelConfigure(AW, AH: LongInt);
var
  Resized: Boolean;
begin
  Resized := False;
  if (AW > 0) and (AH > 0) and
     ((AW <> FWidth) or (AH <> FHeight)) then
  begin
    FWidth := AW;
    FHeight := AH;
    Resized := True;
    DestroyBuffers;
  end;
  if Resized and Assigned(OnResize) then
    OnResize(Self);
end;

procedure TWLWindow.InternalHandleConfigure(ASerial: DWord);
begin
  FXdgSurface.AckConfigure(ASerial);
  EnsureBuffers;
  FConfigured := True;
  if Assigned(OnConfigured) then
    OnConfigured(Self);
end;

procedure TWLWindow.InternalHandleClose;
begin
  FClosed := True;
  if Assigned(OnClose) then
    OnClose(Self)
  else
    FContext.Quit;
end;

procedure TWLWindow.Show;
begin
  FVisible := True;
  // ничего дополнительно — поверхность уже commit'нута при создании
end;

procedure TWLWindow.Hide;
begin
  FVisible := False;
  if FSurface <> nil then
  begin
    FSurface.Attach(nil, 0, 0);
    FSurface.Commit;
    FContext.Display.Flush;
  end;
end;

function TWLWindow.BeginPaint: PByte;
var
  I, Idx, Tries: Integer;
begin
  Result := nil;
  if (FBuffers[0] = nil) or (FBuffers[1] = nil) then Exit;

  // Ищем свободный буфер, начиная с FDrawIndex
  Tries := 0;
  Idx := FDrawIndex;
  while Tries < 2 do
  begin
    if FBuffers[Idx].Released then
    begin
      Result := FBuffers[Idx].Pixels;
      FDrawIndex := Idx;
      Exit;
    end;
    Idx := 1 - Idx;
    Inc(Tries);
  end;
  // оба заняты — кадр пропускаем
end;

procedure TWLWindow.EndPaint;
var
  B: TWLShmBuffer;
begin
  if (FBuffers[0] = nil) or (FBuffers[1] = nil) then Exit;

  B := FBuffers[FDrawIndex];
  if not B.Released then Exit;  // защита

  FSurface.Attach(B.Buffer, 0, 0);
  FSurface.Damage(0, 0, FWidth, FHeight);
  FSurface.Commit;
  FContext.Display.Flush;

  B.MarkBusy;
  FDrawIndex := 1 - FDrawIndex;
end;

procedure TWLWindow.Commit;
begin
  // Оставлен для совместимости: если буфер уже нарисован — не трогаем
  EndPaint;
end;

procedure TWLWindow.Repaint;
begin
  if Assigned(OnPaint) then
    OnPaint(Self);
  EndPaint;
end;

procedure TWLWindow.Clear(AColor: TWLColor);
begin
  FillRect(TRectI.New(0, 0, FWidth, FHeight), AColor);
end;

procedure TWLWindow.SetPixel(AX, AY: Integer; AColor: TWLColor);
var
  P: PLongWord;
  B: TWLShmBuffer;
begin
  if (FBuffers[FDrawIndex] = nil) then Exit;
  B := FBuffers[FDrawIndex];
  if (AX < 0) or (AY < 0) or (AX >= FWidth) or (AY >= FHeight) then Exit;
  P := PLongWord(B.Pixels + AY * B.Stride + AX * 4);
  P^ := AColor;
end;

procedure TWLWindow.FillRect(const ARect: TRectI; AColor: TWLColor);
var
  X1, Y1, X2, Y2, Y, X: Integer;
  Row: PLongWord;
  B: TWLShmBuffer;
begin
  if FBuffers[FDrawIndex] = nil then Exit;
  B := FBuffers[FDrawIndex];

  X1 := ARect.X; Y1 := ARect.Y;
  X2 := ARect.X + ARect.W; Y2 := ARect.Y + ARect.H;
  if X1 < 0 then X1 := 0;
  if Y1 < 0 then Y1 := 0;
  if X2 > FWidth then X2 := FWidth;
  if Y2 > FHeight then Y2 := FHeight;
  if (X1 >= X2) or (Y1 >= Y2) then Exit;

  for Y := Y1 to Y2 - 1 do
  begin
    Row := PLongWord(B.Pixels + Y * B.Stride + X1 * 4);
    for X := X1 to X2 - 1 do
    begin
      Row^ := AColor;
      Inc(Row);
    end;
  end;
end;

end.

Патч demo_window.pas

Меняем цикл — теперь Repaint вызывает OnPaint и EndPaint. Но если оба буфера заняты, BeginPaint вернёт nil, а FillRect молча ничего не сделает — кадр пропустится. Это нормально.

Демо-код:
pascal

procedure OnPaint(Sender: TObject);
var
  W: TWLWindow;
  T: Integer;
begin
  W := TWLWindow(Sender);
  if W.BeginPaint = nil then Exit;   // нет свободного буфера — пропускаем кадр

  if Frame mod 2 = 0 then
    W.Clear(TWLColor($00203050))
  else
    W.Clear(TWLColor($00305020));

  W.FillRect(TRectI.New(10, 10, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, W.Height - 12, W.Width - 20, 2), clWhite);
  W.FillRect(TRectI.New(10, 10, 2, W.Height - 20), clWhite);
  W.FillRect(TRectI.New(W.Width - 12, 10, 2, W.Height - 20), clWhite);

  T := (Frame * 4) mod (W.Width - 40);
  W.FillRect(TRectI.New(20 + T, W.Height div 2 - 20, 40, 40), clRed);

  W.FillRect(TRectI.New(W.Width div 2 - 40, W.Height div 2 - 1, 80, 2), clYellow);
  W.FillRect(TRectI.New(W.Width div 2 - 1, W.Height div 2 - 40, 2, 80), clYellow);
  // EndPaint вызовется автоматически в W.Repaint
end;

Про «окно исчезает и Broken pipe»

В твоём случае, скорее всего, произошло следующее:

    Композитор закрыл окно по какой-то причине (или сессия потеряла соединение).

    libwayland отправил запрос в закрытый сокет.

    Пришёл EPIPE, клиент падает с «Broken pipe».

С двумя буферами и wl_buffer.release мы сильно снижаем риск переполнения. Но полностью от Broken pipe не застрахованы — если композитор решит закрыть окно, следующий запрос всё равно упадёт.
Дополнительная защита: обработать wl_display.error

Хорошо бы добавить listener на wl_display и не продолжать цикл, если пришла ошибка:
pascal

type
  TWLDisplayListener = class(TInterfacedObject, IWlDisplayListener)
  public
    procedure wl_display_error(AWlDisplay: TWlDisplay; AObjectId: Pointer;
      ACode: DWord; AMessage: String);
    procedure wl_display_delete_id(AWlDisplay: TWlDisplay; AId: DWord);
  end;

procedure TWLDisplayListener.wl_display_error(...);
begin
  WriteLn('[wlgui] display error: ', AMessage);
  if App <> nil then App.Quit;
end;

И добавить в TWLApplication.Initialize:
pascal

FDisplayListener := TWLDisplayListener.Create;
FDisplay.AddListener(FDisplayListener);

Это не спасёт от EPIPE (это происходит на уровне сокета), но хотя бы мы узнаем, если композитор что-то не так понял.
Про падение через какое-то время

Ещё одна возможная причина — наш Sleep(5) + 30 fps дают нестабильный тайминг, и раз в N секунд композитор отправляет wl_buffer.release не вовремя. С wl_buffer.release listener'ом буферы будут корректно освобождаться.

Попробуй патч, покажи, что в логе. Если снова «Broken pipe», добавим обработчик ошибок wl_display.
Собираем
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Если всё правильно — окно будет работать долго и стабильно, без падений.
Окно появилось. Квадрат в левой стороне и не движется, окно не мигает. Со временем окно не исчезает и корректно закрывается по Ctrl+C. Окно можно успешно перетаскивать за содержимое. ./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560
[demo] entering loop. Ctrl+C to exit.
^C
Отлично, окно стабильно! Но анимации нет — есть 3 причины
Причина 1: не приходит wl_buffer.release

Мы ни разу не увидели, чтобы рисование повторилось. В логе после «2 buffers created» — тишина. Причина: wl_buffer.release не приходит, потому что... мы отправляем Commit с Attach один раз, и этого достаточно композитору.

Проблема в другом. Смотрим OnPaint:
pascal

if W.BeginPaint = nil then Exit;

BeginPaint возвращает nil, если оба буфера заняты. После первого кадра:

    FBuffers[0].Released = False (мы её Attach-нули, MarkBusy)

    FBuffers[1].Released = True — свободна

Значит второй BeginPaint должен вернуть указатель на буфер 1. Но потом происходит EndPaint, который проверяет:
pascal

B := FBuffers[FDrawIndex];
if not B.Released then Exit;  // защита

Тут всё ок. Смотрим дальше: Repaint вызывает OnPaint и EndPaint. OnPaint начал с BeginPaint — FDrawIndex теперь 0 или 1. EndPaint берёт FDrawIndex, Attach, MarkBusy, переключает FDrawIndex := 1 - FDrawIndex.

Стоп. А как мы рисуем? W.FillRect и W.Clear внутри OnPaint тоже используют FBuffers[FDrawIndex]. Но BeginPaint уже выбрал FDrawIndex — и не менял его. Значит рисование идёт в тот же буфер, который EndPaint потом Attach-нет. Хорошо.
Но почему не двигается?

Смотрим внимательнее. После первого Repaint:

    FDrawIndex был 0.

    BeginPaint вернул указатель буфера 0.

    Рисуем в буфер 0.

    EndPaint взял буфер 0, Attach, MarkBusy(0), FDrawIndex := 1.

Второй Repaint:

    BeginPaint: Idx = 1, FBuffers[1].Released = True (никогда не отправлялся) → возвращает буфер 1, FDrawIndex := 1.

    Рисуем в буфер 1.

    EndPaint: берёт буфер 1, Attach, MarkBusy(1), FDrawIndex := 0.

Третий Repaint:

    BeginPaint: Idx = 0, FBuffers[0].Released = False → Idx := 1, FBuffers[1].Released = False → оба заняты, возвращает nil.

    OnPaint делает Exit.

    EndPaint: берёт FBuffers[FDrawIndex] = FBuffers[0], Released = False → Exit.

И так навсегда. Оба буфера заняты, потому что wl_buffer.release не приходит. Значит listener не вызывается.
Почему не вызывается wl_buffer.release

Смотрим TWLBufferListener.Create(AOwner, AIndex) в TWLShmBuffer.Create. И потом:
pascal

FListener := TWLBufferListener.Create(AOwner, AIndex);
FBuffer.AddListener(FListener);

Ага, вот баг. FBuffer.AddListener в wayland_protocol.pas делает:
pascal

function TWlBuffer.AddListener(AIntf: IWlBufferListener): LongInt;
begin
  FUserDataRec.ListenerUserData := Pointer(AIntf);
  Result := wl_proxy_add_listener(FProxy, @vIntf_wl_buffer_Listener, @FUserDataRec);
end;

Обрати внимание: Pointer(AIntf) — это сырой указатель на интерфейс, который в FPC (в режиме corba) — указатель на vtable. А @FUserDataRec — указатель на запись внутри TWLProxyObject. Всё правильно, но...

Проблема: FUserDataRec — это запись TWLUserData, и у неё есть поле PascalObject. При создании TWLProxyObject.Create(AProxy):
pascal

FUserDataRec.PascalObject := Self;
FProxy := AProxy;
if Assigned(FProxy) then
  wl_proxy_set_user_data(FProxy, @FUserDataRec);

Теперь в wl_buffer_release_Intf (wayland_protocol.pas):
pascal

procedure wl_buffer_release_Intf(AData: PWLUserData; Awl_buffer: Pwl_buffer); cdecl;
var
  AIntf: IWlBufferListener;
begin
  if AData = nil then Exit;
  AIntf := IWlBufferListener(AData^.ListenerUserData);
  AIntf.wl_buffer_release(TWlBuffer(AData^.PascalObject));
end;

Всё выглядит корректно. Тогда почему release не вызывается?
Причина 2: мы не вызываем DispatchPending достаточно часто

Смотрим цикл:
pascal

while MyApp.Running do
begin
  MyApp.ProcessEvents;   // DispatchPending + Flush
  if GetTickCount64 - LastTick >= 33 then
  begin
    ...
    Win.Repaint;
  end;
  Sleep(5);
end;

DispatchPending не блокирует — он обрабатывает только те события, которые уже в очереди. wl_buffer.release приходит в сокет. Если мы не блокируемся в poll() — событие может ещё не быть прочитано. Но Flush отправляет наши запросы, а DispatchPending — забирает пришедшие.

Хм, но DispatchPending должен всё-таки прочитать то, что уже пришло. Проблема в том, что мы не даём libwayland возможности прочитать сокет — DispatchPending не делает read() с блокировкой, он использует уже прочитанные данные. Но кто их читает? Dispatch (блокирующий) или wl_display_read_events после prepare_read.

Вот и причина №2: DispatchPending без Dispatch не работает как ожидается в цикле с Sleep.

Правильный event loop в Wayland:
pascal

// 1. Подготовиться к чтению
if wl_display_prepare_read(display) <> 0 then
begin
  // есть уже готовые события — обрабатываем без poll
  wl_display_dispatch_pending(display);
  wl_display_flush(display);
  continue;
end;
wl_display_flush(display);

// 2. poll с таймаутом
poll(fd, ..., timeout);

// 3. Прочитать события
if (revents and POLLIN) <> 0 then
  wl_display_read_events(display)
else
  wl_display_cancel_read(display);

// 4. Обработать
wl_display_dispatch_pending(display);

Или проще — использовать блокирующий wl_display_dispatch и таймер через poll с timeout. Но это сложнее встроить в текущий цикл.

Самое простое решение: раз в N миллисекунд делать wl_display_roundtrip — он принудительно прочитает всё из сокета и обработает. Roundtrip — блокирующий, но для теста сойдёт.
Причина 3: wl_display.dispatch не вызывается

Простейший фикс — добавить блокирующий wl_display.Dispatch в цикл, но с ограничением по времени. Или использовать wl_display.Roundtrip периодически.
Патч: исправляем event loop

Меняем цикл в demo_window.pas:
pascal

LastTick := GetTickCount64;
while MyApp.Running do
begin
  // Блокирующий dispatch — гарантирует чтение из сокета
  // Timeout реализуем через roundtrip раз в 16ms
  MyApp.Display.DispatchPending;
  MyApp.Display.Flush;

  // Периодически делаем roundtrip — гарантированно читает release
  if GetTickCount64 - LastTick >= 16 then
  begin
    MyApp.Display.Roundtrip;   // ← заставит обработать входящие
    LastTick := GetTickCount64;
    Inc(Frame);
    Win.Repaint;
  end;

  Sleep(1);
end;

Но Roundtrip — блокирующий, он ждёт ответа от композитора. При 60 fps это нормально, но при отсутствии событий — может залипнуть. Лучше такой паттерн:

Патч в wlgui_context.pas — добавить правильный event loop helper:
pascal

function TWLContext.DispatchWithTimeout(ATimeoutMs: Integer): Boolean;
var
  Fd: cint;
  Pfd: TPollfd;
  Ret: Integer;
begin
  Result := False;
  if FDisplay = nil then Exit;

  // Если есть уже готовые события — обрабатываем их
  if wl_display_prepare_read(FDisplay) <> 0 then
  begin
    wl_display_dispatch_pending(FDisplay);
    wl_display_flush(FDisplay);
    Exit(True);
  end;

  Fd := wl_display_get_fd(FDisplay);

  // Отправляем всё что накопилось
  if wl_display_flush(FDisplay) < 0 then
  begin
    wl_display_cancel_read(FDisplay);
    Exit(False);
  end;

  // Ждём событий
  Pfd.fd := Fd;
  Pfd.events := POLLIN;
  Pfd.revents := 0;
  Ret := fpPoll(@Pfd, 1, ATimeoutMs);

  if (Ret > 0) and ((Pfd.revents and POLLIN) <> 0) then
  begin
    wl_display_read_events(FDisplay);
    wl_display_dispatch_pending(FDisplay);
    Result := True;
  end
  else
  begin
    wl_display_cancel_read(FDisplay);
    wl_display_dispatch_pending(FDisplay);
    wl_display_flush(FDisplay);
  end;
end;

Но wl_display_prepare_read объявлен в wayland_client_core.pas как внешняя функция. Проверим... да, есть:
pascal

function  wl_display_prepare_read(display :Pwl_display): cint; cdecl; external;
procedure wl_display_cancel_read(display :Pwl_display); cdecl; external;
function  wl_display_read_events(display :Pwl_display): cint; cdecl; external;

И fpPoll — в BaseUnix.
Ещё одно — упростить до минимума

Для теста можно сделать так. В demo_window.pas:
pascal

while MyApp.Running do
begin
  // Читаем и обрабатываем всё, что пришло
  MyApp.Display.DispatchPending;
  MyApp.Display.Flush;

  // Раз в 16 мс — анимация
  Now := GetTickCount64;
  if Now - LastTick >= 16 then
  begin
    LastTick := Now;
    Inc(Frame);
    Win.Repaint;
  end;

  // Даём сокету шанс прочитать — блокирующий roundtrip раз в 100 мс
  Now := GetTickCount64;
  if Now - LastRoundtrip >= 100 then
  begin
    LastRoundtrip := Now;
    MyApp.Display.Roundtrip;  // ← ключевой момент, читает release
  end;

  Sleep(1);
end;

Roundtrip — блокирующий, но раз в 100 мс это ок. При этом он гарантированно читает всё пришедшее из сокета, включая wl_buffer.release.
Или ещё проще — сразу после EndPaint сделать Dispatch один раз

Repaint вызывает EndPaint, который делает Commit и Flush. Сразу после этого можно вызвать неблокирующий DispatchPending — он обработает то, что уже пришло, включая быстрый release (если композитор уже успел его прислать).

Но композитор присылает release асинхронно, в следующем событии. Так что нужно подождать.
Итог: что попробовать сейчас

Самый быстрый тест — замени цикл в demo_window.pas на такой:
pascal

LastTick := GetTickCount64;
LastRoundtrip := 0;
while MyApp.Running do
begin
  MyApp.Display.DispatchPending;
  MyApp.Display.Flush;

  Now := GetTickCount64;

  if Now - LastTick >= 16 then
  begin
    LastTick := Now;
    Inc(Frame);
    Win.Repaint;
  end;

  if Now - LastRoundtrip >= 50 then
  begin
    LastRoundtrip := Now;
    MyApp.Display.Roundtrip;
    WriteLn('[demo] frame=', Frame, ' buf0.released=', Win.FBuffersDebug(0));
  end;

  Sleep(1);
end;

Для отладки добавь в TWLWindow публичную функцию:
pascal

function TWLWindow.FBuffersDebug(AIndex: Integer): Boolean;
begin
  if (AIndex < 0) or (AIndex > 1) or (FBuffers[AIndex] = nil) then
    Result := False
  else
    Result := FBuffers[AIndex].Released;
end;

Если после патча в логе видно buf0.released=True/False меняется — значит release приходит, анимация пойдёт.
Что реально надо сделать в перспективе

Правильный event loop:

    wl_display_prepare_read

    wl_display_flush

    poll(fd, timeout) — тут можно дождаться таймера анимации

    wl_display_read_events или wl_display_cancel_read

    wl_display_dispatch_pending

    Если время кадра — Repaint

Так мы и слушаем сокет, и рисуем по таймеру, без блокирующих roundtrip. Реализую в wlgui_events.pas, когда будем делать ввод.
Про «окно можно таскать за содержимое»

Это композитор сам решил, что раз окно без заголовка, а мышь тащит — можно двигать окно. Это поведение xdg_toplevel.move. Приятный бонус, но для «летающей панели» мы в будущем будем использовать layer-shell — там позиция задаётся клиентом через margin.
Что делать прямо сейчас

    Сделай патч demo_window.pas выше — с Roundtrip раз в 50 мс.

    Прогони 10 секунд, покажи лог.

    Смотрим, меняется ли released.

Если released меняется, а анимация всё равно застряла — проблема в BeginPaint/EndPaint, будем отлаживать.
Немного поправил FDisplay -> Display но всё равно: wlgui_context.pas(88,8) Error: Identifier not found "TPollfd"
wlgui_context.pas(88,15) Error: Error in type definition
wlgui_context.pas(112,7) Error: Illegal qualifier
wlgui_context.pas(113,7) Error: Illegal qualifier
wlgui_context.pas(113,17) Error: Identifier not found "POLLIN"
wlgui_context.pas(114,7) Error: Illegal qualifier
wlgui_context.pas(115,10) Error: Identifier not found "fpPoll"
wlgui_context.pas(117,26) Error: Illegal qualifier
wlgui_context.pas(117,38) Error: Identifier not found "POLLIN"
TPollfd и fpPoll — в разных модулях

В FPC:

    TPollfd и POLLIN — в модуле BaseUnix (не Unix).

    fpPoll — тоже в BaseUnix.

Плюс BaseUnix не подключён в wlgui_context.pas.
Патч wlgui_context.pas

Меняем uses:
pascal

uses
  Classes, SysUtils, BaseUnix, wlgui_types;

И метод DispatchWithTimeout:
pascal

function TWLContext.DispatchWithTimeout(ATimeoutMs: Integer): Boolean;
var
  Fd: cint;
  Pfd: TPollfd;
  Ret: Integer;
begin
  Result := False;
  if FDisplay = nil then Exit;

  // Если есть уже готовые события — обрабатываем их без poll
  if wl_display_prepare_read(FDisplay) <> 0 then
  begin
    wl_display_dispatch_pending(FDisplay);
    wl_display_flush(FDisplay);
    Exit(True);
  end;

  Fd := wl_display_get_fd(FDisplay);

  // Отправляем всё, что накопилось
  if wl_display_flush(FDisplay) < 0 then
  begin
    wl_display_cancel_read(FDisplay);
    Exit(False);
  end;

  // Ждём событий
  Pfd.fd := Fd;
  Pfd.events := POLLIN;
  Pfd.revents := 0;
  Ret := fpPoll(@Pfd, 1, ATimeoutMs);

  if (Ret > 0) and ((Pfd.revents and POLLIN) <> 0) then
  begin
    wl_display_read_events(FDisplay);
    wl_display_dispatch_pending(FDisplay);
    Result := True;
  end
  else
  begin
    wl_display_cancel_read(FDisplay);
    wl_display_dispatch_pending(FDisplay);
    wl_display_flush(FDisplay);
  end;
end;

Но! Метод DispatchWithTimeout должен быть объявлен в interface секции класса TWLContext. Если ты добавлял только реализацию — компилятор не знает. Проверь, что в TWLContext есть:
pascal

  public
    ...
    function DispatchWithTimeout(ATimeoutMs: Integer): Boolean;

Про wl_display_prepare_read и компанию

В wayland_client_core.pas они объявлены как external:
pascal

function  wl_display_prepare_read(display :Pwl_display): cint; cdecl; external;
procedure wl_display_cancel_read(display :Pwl_display); cdecl; external;
function  wl_display_read_events(display :Pwl_display): cint; cdecl; external;

Значит, они будут видны, если подключить wayland_client_core в wlgui_context.pas. У нас он уже подключён — проверь.
Быстрый тест без нового метода

Если не хочется возиться с TPollfd — можно обойтись без DispatchWithTimeout, просто добавив Roundtrip в цикл. Это уже работало, просто реже.

В demo_window.pas:
pascal

var
  LastTick, LastRoundtrip, Now_: QWord;
begin
  ...
  LastTick := GetTickCount64;
  LastRoundtrip := LastTick;
  while MyApp.Running do
  begin
    // Простая обработка событий
    MyApp.Display.DispatchPending;
    MyApp.Display.Flush;

    Now_ := GetTickCount64;

    // 60 fps — рисуем
    if Now_ - LastTick >= 16 then
    begin
      LastTick := Now_;
      Inc(Frame);
      Win.Repaint;
    end;

    // Раз в 50 мс — roundtrip, чтобы прочитать release
    if Now_ - LastRoundtrip >= 50 then
    begin
      LastRoundtrip := Now_;
      MyApp.Display.Roundtrip;
    end;

    Sleep(1);
  end;

Это заработает. Roundtrip — блокирующий, но раз в 50 мс при 60 fps это даст микро-паузы ~1 мс, незаметно.
Что именно исправить в wlgui_context.pas

Полный исправленный модуль:
pascal

unit wlgui_context;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, BaseUnix,
  wayland_client_core, wayland_protocol, xdg_shell_protocol,
  wlgui_types;

type
  TWLContext = class
  public
    Display: TWlDisplay;
    Compositor: TWlCompositor;
    Shm: TWlShm;
    WmBase: TXdgWmBase;
    Subcompositor: TWlSubcompositor;
    Seat: TWlSeat;
    LayerShell: Pointer;

    procedure RegisterWindow(Obj: TObject);
    procedure UnregisterWindow(Obj: TObject);

    procedure Quit;
    function Running: Boolean;
    procedure SetRunning(AValue: Boolean);

    function DispatchWithTimeout(ATimeoutMs: Integer): Boolean;

    constructor Create;
    destructor Destroy; override;
  private
    FWindows: TList;
    FRunning: Boolean;
    FOnQuit: TWLNotifyEvent;
  public
    property Windows: TList read FWindows;
    property OnQuit: TWLNotifyEvent read FOnQuit write FOnQuit;
    property IsRunning: Boolean read Running write SetRunning;
  end;

implementation

constructor TWLContext.Create;
begin
  inherited;
  FWindows := TList.Create;
  FRunning := True;
end;

destructor TWLContext.Destroy;
begin
  FWindows.Free;
  inherited;
end;

procedure TWLContext.RegisterWindow(Obj: TObject);
begin
  if FWindows.IndexOf(Obj) < 0 then
    FWindows.Add(Obj);
end;

procedure TWLContext.UnregisterWindow(Obj: TObject);
begin
  FWindows.Remove(Obj);
end;

procedure TWLContext.Quit;
begin
  FRunning := False;
  if Assigned(FOnQuit) then
    FOnQuit(Self);
end;

function TWLContext.Running: Boolean;
begin
  Result := FRunning;
end;

procedure TWLContext.SetRunning(AValue: Boolean);
begin
  FRunning := AValue;
end;

function TWLContext.DispatchWithTimeout(ATimeoutMs: Integer): Boolean;
var
  Fd: cint;
  Pfd: TPollfd;
  Ret: Integer;
begin
  Result := False;
  if Display = nil then Exit;

  if wl_display_prepare_read(Display) <> 0 then
  begin
    wl_display_dispatch_pending(Display);
    wl_display_flush(Display);
    Exit(True);
  end;

  Fd := wl_display_get_fd(Display);

  if wl_display_flush(Display) < 0 then
  begin
    wl_display_cancel_read(Display);
    Exit(False);
  end;

  Pfd.fd := Fd;
  Pfd.events := POLLIN;
  Pfd.revents := 0;
  Ret := fpPoll(@Pfd, 1, ATimeoutMs);

  if (Ret > 0) and ((Pfd.revents and POLLIN) <> 0) then
  begin
    wl_display_read_events(Display);
    wl_display_dispatch_pending(Display);
    Result := True;
  end
  else
  begin
    wl_display_cancel_read(Display);
    wl_display_dispatch_pending(Display);
    wl_display_flush(Display);
  end;
end;

end.

Если wl_display_prepare_read не находится

Проверь, что в wayland_client_core.pas в интерфейсной секции они объявлены (а не только в implementation):
pascal

function  wl_display_prepare_read(display :Pwl_display): cint; cdecl; external;
procedure wl_display_cancel_read(display :Pwl_display); cdecl; external;
function  wl_display_read_events(display :Pwl_display): cint; cdecl; external;

В твоём файле они есть (я видел). Значит uses wayland_client_core — обязательно.
Проверь сигнатуру TPollfd в BaseUnix

В FPC BaseUnix определяет:
pascal

type
  TPollfd = record
    fd: cint;
    events: cshort;
    revents: cshort;
  end;

Поля events и revents — cshort, не Word. Присваивание POLLIN (константа = 1) работает.
Итог

    uses BaseUnix в wlgui_context.pas.

    Убедись, что DispatchWithTimeout объявлен в классе.

    Пересобери demo с новым циклом.

Если и с DispatchWithTimeout не заработает — вернёмся к простому Roundtrip раз в 50 мс.
Спасибо! Работает стабильно, квадрат летит!
🎉 Первый этап пройден!

Отлично, поздравляю — теперь у нас есть настоящий Wayland-клиент с двойной буферизацией, корректной обработкой wl_buffer.release, и главное — никаких зависимостей от MSE. Это фундамент, на котором можно строить всё остальное.
Что мы имеем сейчас
text

wlgui_types.pas     — TWLColor, TRectI, TPointI, TWLNotifyEvent
wlgui_context.pas   — TWLContext (display, compositor, shm, wm_base, seat)
wlgui_app.pas       — TWLApplication (инициализация, event loop)
wlgui_window.pas    — TWLWindow (окно + двойная буферизация + release)
demo_window.pas     — тестовое приложение (летающий квадрат)

Что важно зафиксировать на будущее

    Никаких forward-типов между модулями — циклы разорваны через wlgui_context.

    Версии протоколов ограничиваем через Min(композитор, наш_дескриптор). Иначе композитор шлёт события, которых нет в нашем дескрипторе.

    wl_buffer.release обязателен для двойной буферизации.

    Event loop через wl_display_prepare_read + poll + read_events + dispatch_pending — правильный паттерн, без блокирующих roundtrip'ов в горячем цикле.

Что впереди — ближайшие шаги
Этап 2: wlgui_canvas.pas — рисование

Сейчас рисование в TWLWindow — это FillRect + SetPixel. Нужно:

    HLine, VLine, Line (алгоритм Брезенхэма)

    Rect (контур, не заливка)

    RoundRect, Ellipse, FillEllipse

    CopyRect (для будущего скролла)

    Clip-регион (хотя бы прямоугольный)

И вынести всё это в отдельный класс TWLCanvas, который привязывается к буферу:
pascal

Canvas := TWLCanvas.Create(Win);
Canvas.Line(0, 0, 100, 100, clRed);
Canvas.Rect(TRectI.New(10, 10, 50, 50), clWhite);
Canvas.Free;

Или проще — методы прямо в TWLWindow, чтобы OnPaint был коротким.
Этап 3: wlgui_font.pas — текст

    FreeType напрямую (у нас уже есть msefreetype_wayland из прошлых чатов, но без MSE)

    Кэш глифов: TWLFont.LoadGlyph(Code) → TGlyph с Left, Top, Width, Height, Advance, Bitmap: array of Byte

    TextOut(X, Y, U4String, Color, Font) — рисуем в буфер окна

    TextWidth(U4String, Font) — для выравнивания

    Используем u4str, u4utf8, u4norm — то, что ты подгрузил

Здесь важно: свой минимальный рендер, без MSE bitmap/graphics. Только FreeType + прямая запись пикселей.
Этап 4: wlgui_events.pas — ввод

    wl_seat.listener → capabilities → get_pointer + get_keyboard

    wl_pointer.motion/button/axis/frame → очереди событий

    wl_keyboard.key/modifiers → keymap через xkbcommon или через u4str + ручной маппинг (для начала — ASCII из Linux keycodes)

    Курсор: wl_pointer.set_cursor с собственной поверхностью

    API: OnMouseMove, OnMouseDown, OnMouseUp, OnKeyDown, OnKeyUp

Этап 5: wlgui_panel.pas — layer-shell

Протокол zwlr_layer_shell_v1 — панели, доки, обои. Именно для «летающих часов».

    Нужен сгенерированный протокол (могу написать вручную, как для xdg_shell)

    Интерфейс: wlr_layer_surface_v1 + get_layer_surface(surface, output, layer, namespace)

    set_anchor(edges), set_size(w, h), set_margin(...), set_keyboard_interactivity(...)

    Слои: background, bottom, top, overlay

С overlay панель будет поверх всего. Позицию задаём через anchor + margin. Двигать — меняем margin + commit.
Этап 6: Органайзер

    organ_model.pas — события (время, сообщение, звук, скрипт)

    organ_storage.pas — сохранение/загрузка (сначала — простой текстовый формат)

    organ_clock.pas — панель с часами

    organ_event_edit.pas — редактор события

    organ_event_list.pas — список событий

Пара практических вопросов к тебе

    Куда идём дальше? Мои варианты:

        A: Сначала canvas + font (полный графический фундамент), потом events, потом органайзер. Более гладко, но дольше до первой «рабочей» картинки.

        B: Сначала events (чтобы таскать окно самому, ловить кнопки), потом canvas+font, потом органайзер. Раньше получим интерактивность.

        C: Сразу органайзер с тем что есть (только FillRect + SetPixel), чтобы быстрее увидеть результат. Потом улучшать.

    Layer-shell — планируешь использовать sway/hyprland/kwin, или что-то конкретное? От этого зависит, стоит ли закладываться на wlr-layer-shell или искать альтернативы.

    FreeType-биндинги — у нас в msefreetype_wayland.pas был вариант с dynlibs (без MSE). Готов его переиспользовать, или предпочитаешь переписать заново в wlgui_font.pas?

    XKB для клавиатуры — подключать libxkbcommon (правильный путь, но новая зависимость), или для начала ограничиться ASCII-маппингом Linux keycodes (быстро, но без раскладок)?

    Структура директорий — оставляем всё в корне, или сделаем wlgui/ для библиотеки и apps/organizer/ для приложения?

Я бы предложил порядок A → B → C: canvas+font сначала, потому что они дадут возможность рисовать «настоящий» UI, а интерактивность и потом прикрутим. Но если хочется быстрее увидеть «работающее приложение» — пойдём C → A → B.

Скажи, куда двигаемся.
Спасибо! Давай действовать как ты сказал.
Этап 2: wlgui_canvas.pas — графические примитивы

Идём по плану A → B → C: сначала полный графический фундамент (canvas + font), потом ввод, потом органайзер.
Что делаем в этом этапе

Добавляем в wlgui_canvas.pas:

    TWLCanvas — обёртка над буфером окна

    Базовые примитивы: SetPixel, GetPixel, HLine, VLine, Line (Брезенхэм), Rect (контур), FillRect, RoundRect, FillRoundRect, Ellipse, FillEllipse

    CopyRect — для скролла и будущих «двойных буферов» на уровне canvas

    Прямоугольный clip (SetClip, ResetClip)

Затем переносим рисование из TWLWindow в TWLCanvas, чтобы OnPaint работал через W.Canvas.
Соглашение по цветам

Мы уже договорились: TWLColor = $00BBGGRR (как GDI). В SHM XRGB8888 (little-endian), при записи LongWord($00BBGGRR) получается байтовая последовательность RR GG BB 00, и композитор видит R=RR, G=GG, B=BB — правильно.

Проверка: clRed = $000000FF, при записи даёт байты FF 00 00 00, что XRGB8888 = красный. Отлично.
wlgui_canvas.pas
pascal

unit wlgui_canvas;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Math,
  wlgui_types;

type
  { TWLCanvas — рисование в буфер окна.
    Не владеет буфером; TWLWindow передаёт указатель и stride.
    Если после SetSize буфер меняется — надо пересоздавать canvas
    (или вызывать ResizeBuffer). }
  TWLCanvas = class
  private
    FPixels: PByte;
    FWidth, FHeight, FStride: Integer;
    FClip: TRectI;
    FClipActive: Boolean;
    function GetPixelPtr(AX, AY: Integer): PLongWord; inline;
    function PixelInside(AX, AY: Integer): Boolean; inline;
    procedure SetPixels(APixels: PByte; AW, AH, AStride: Integer);
  public
    constructor Create(APixels: PByte; AW, AH, AStride: Integer);
    procedure Reattach(APixels: PByte; AW, AH, AStride: Integer);

    // Прямое
    procedure SetPixel(AX, AY: Integer; AColor: TWLColor); inline;
    function  GetPixel(AX, AY: Integer): TWLColor; inline;

    // Линии
    procedure HLine(X1, X2, AY: Integer; AColor: TWLColor);
    procedure VLine(AX, Y1, Y2: Integer; AColor: TWLColor);
    procedure Line(X1, Y1, X2, Y2: Integer; AColor: TWLColor);

    // Прямоугольники
    procedure Rect(const ARect: TRectI; AColor: TWLColor);
    procedure FillRect(const ARect: TRectI; AColor: TWLColor);

    // Скруглённые
    procedure RoundRect(const ARect: TRectI; ARadius: Integer; AColor: TWLColor);
    procedure FillRoundRect(const ARect: TRectI; ARadius: Integer; AColor: TWLColor);

    // Эллипсы
    procedure Ellipse(const ARect: TRectI; AColor: TWLColor);
    procedure FillEllipse(const ARect: TRectI; AColor: TWLColor);

    // Копирование прямоугольной области
    procedure CopyRect(const ASrc: TRectI; ADstX, ADstY: Integer);

    // Клип
    procedure SetClip(const ARect: TRectI);
    procedure ResetClip;
    function  ClipRect: TRectI;

    // Свойства
    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Stride: Integer read FStride;
    property Pixels: PByte read FPixels;
  end;

implementation

{ ============================================================ }
{  Служебные                                                    }
{ ============================================================ }

constructor TWLCanvas.Create(APixels: PByte; AW, AH, AStride: Integer);
begin
  inherited Create;
  Reattach(APixels, AW, AH, AStride);
  FClipActive := False;
  FClip := TRectI.New(0, 0, AW, AH);
end;

procedure TWLCanvas.Reattach(APixels: PByte; AW, AH, AStride: Integer);
begin
  SetPixels(APixels, AW, AH, AStride);
  FClip := TRectI.New(0, 0, AW, AH);
end;

procedure TWLCanvas.SetPixels(APixels: PByte; AW, AH, AStride: Integer);
begin
  FPixels := APixels;
  FWidth := AW;
  FHeight := AH;
  FStride := AStride;
end;

function TWLCanvas.GetPixelPtr(AX, AY: Integer): PLongWord;
begin
  Result := PLongWord(FPixels + AY * FStride + AX * 4);
end;

function TWLCanvas.PixelInside(AX, AY: Integer): Boolean;
begin
  if (AX < 0) or (AY < 0) or (AX >= FWidth) or (AY >= FHeight) then
    Exit(False);
  if FClipActive then
    Result := FClip.Contains(AX, AY)
  else
    Result := True;
end;

{ ============================================================ }
{  Пиксели                                                      }
{ ============================================================ }

procedure TWLCanvas.SetPixel(AX, AY: Integer; AColor: TWLColor);
begin
  if FPixels = nil then Exit;
  if not PixelInside(AX, AY) then Exit;
  GetPixelPtr(AX, AY)^ := AColor;
end;

function TWLCanvas.GetPixel(AX, AY: Integer): TWLColor;
begin
  if FPixels = nil then Exit(0);
  if (AX < 0) or (AY < 0) or (AX >= FWidth) or (AY >= FHeight) then
    Exit(0);
  Result := GetPixelPtr(AX, AY)^;
end;

{ ============================================================ }
{  Линии                                                        }
{ ============================================================ }

procedure TWLCanvas.HLine(X1, X2, AY: Integer; AColor: TWLColor);
var
  T, X: Integer;
  P: PLongWord;
begin
  if FPixels = nil then Exit;
  if (AY < 0) or (AY >= FHeight) then Exit;
  if X1 > X2 then begin T := X1; X1 := X2; X2 := T; end;
  if X1 < 0 then X1 := 0;
  if X2 >= FWidth then X2 := FWidth - 1;
  if X1 > X2 then Exit;

  if FClipActive then
  begin
    if X1 < FClip.X then X1 := FClip.X;
    if X2 >= FClip.X + FClip.W then X2 := FClip.X + FClip.W - 1;
    if (AY < FClip.Y) or (AY >= FClip.Y + FClip.H) then Exit;
    if X1 > X2 then Exit;
  end;

  P := GetPixelPtr(X1, AY);
  for X := X1 to X2 do
  begin
    P^ := AColor;
    Inc(P);
  end;
end;

procedure TWLCanvas.VLine(AX, Y1, Y2: Integer; AColor: TWLColor);
var
  T, Y: Integer;
  P: PLongWord;
begin
  if FPixels = nil then Exit;
  if (AX < 0) or (AX >= FWidth) then Exit;
  if Y1 > Y2 then begin T := Y1; Y1 := Y2; Y2 := T; end;
  if Y1 < 0 then Y1 := 0;
  if Y2 >= FHeight then Y2 := FHeight - 1;
  if Y1 > Y2 then Exit;

  if FClipActive then
  begin
    if Y1 < FClip.Y then Y1 := FClip.Y;
    if Y2 >= FClip.Y + FClip.H then Y2 := FClip.Y + FClip.H - 1;
    if (AX < FClip.X) or (AX >= FClip.X + FClip.W) then Exit;
    if Y1 > Y2 then Exit;
  end;

  P := GetPixelPtr(AX, Y1);
  for Y := Y1 to Y2 do
  begin
    P^ := AColor;
    Inc(P, FStride div 4);
  end;
end;

procedure TWLCanvas.Line(X1, Y1, X2, Y2: Integer; AColor: TWLColor);
var
  DX, DY, SX, SY, Err, E2: Integer;
begin
  if FPixels = nil then Exit;

  // Быстрые пути
  if Y1 = Y2 then begin HLine(X1, X2, Y1, AColor); Exit; end;
  if X1 = X2 then begin VLine(X1, Y1, Y2, AColor); Exit; end;

  DX := Abs(X2 - X1);
  DY := Abs(Y2 - Y1);
  if X1 < X2 then SX := 1 else SX := -1;
  if Y1 < Y2 then SY := 1 else SY := -1;
  Err := DX - DY;

  while True do
  begin
    SetPixel(X1, Y1, AColor);
    if (X1 = X2) and (Y1 = Y2) then Break;
    E2 := Err * 2;
    if E2 > -DY then
    begin
      Err := Err - DY;
      Inc(X1, SX);
    end;
    if E2 < DX then
    begin
      Err := Err + DX;
      Inc(Y1, SY);
    end;
  end;
end;

{ ============================================================ }
{  Прямоугольники                                               }
{ ============================================================ }

procedure TWLCanvas.FillRect(const ARect: TRectI; AColor: TWLColor);
var
  X1, Y1, X2, Y2, Y, X: Integer;
  Row: PLongWord;
begin
  if FPixels = nil then Exit;

  X1 := ARect.X; Y1 := ARect.Y;
  X2 := ARect.X + ARect.W; Y2 := ARect.Y + ARect.H;

  if X1 < 0 then X1 := 0;
  if Y1 < 0 then Y1 := 0;
  if X2 > FWidth then X2 := FWidth;
  if Y2 > FHeight then Y2 := FHeight;
  if (X1 >= X2) or (Y1 >= Y2) then Exit;

  if FClipActive then
  begin
    if X1 < FClip.X then X1 := FClip.X;
    if Y1 < FClip.Y then Y1 := FClip.Y;
    if X2 > FClip.X + FClip.W then X2 := FClip.X + FClip.W;
    if Y2 > FClip.Y + FClip.H then Y2 := FClip.Y + FClip.H;
    if (X1 >= X2) or (Y1 >= Y2) then Exit;
  end;

  for Y := Y1 to Y2 - 1 do
  begin
    Row := GetPixelPtr(X1, Y);
    for X := X1 to X2 - 1 do
    begin
      Row^ := AColor;
      Inc(Row);
    end;
  end;
end;

procedure TWLCanvas.Rect(const ARect: TRectI; AColor: TWLColor);
var
  R: TRectI;
begin
  R := ARect;
  if R.IsEmpty then Exit;
  HLine(R.X, R.X + R.W - 1, R.Y, AColor);
  HLine(R.X, R.X + R.W - 1, R.Y + R.H - 1, AColor);
  VLine(R.X, R.Y, R.Y + R.H - 1, AColor);
  VLine(R.X + R.W - 1, R.Y, R.Y + R.H - 1, AColor);
end;

{ ============================================================ }
{  Скруглённые прямоугольники                                   }
{ ============================================================ }

procedure TWLCanvas.RoundRect(const ARect: TRectI; ARadius: Integer;
                              AColor: TWLColor);
var
  R: TRectI;
  Rad: Integer;
begin
  R := ARect;
  if R.IsEmpty then Exit;

  Rad := ARadius;
  if Rad < 0 then Rad := 0;
  if Rad * 2 > R.W then Rad := R.W div 2;
  if Rad * 2 > R.H then Rad := R.H div 2;

  if Rad = 0 then begin Rect(R, AColor); Exit; end;

  // Прямые участки
  HLine(R.X + Rad, R.X + R.W - Rad - 1, R.Y, AColor);
  HLine(R.X + Rad, R.X + R.W - Rad - 1, R.Y + R.H - 1, AColor);
  VLine(R.X, R.Y + Rad, R.Y + R.H - Rad - 1, AColor);
  VLine(R.X + R.W - 1, R.Y + Rad, R.Y + R.H - Rad - 1, AColor);

  // Углы — четвертинки окружности
  ArcQuarter(R.X + Rad,             R.Y + Rad,             Rad, 2, 3, AColor); // top-left
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + Rad,             Rad, 3, 4, AColor); // top-right
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + R.H - Rad - 1,   Rad, 0, 1, AColor); // bottom-right
  ArcQuarter(R.X + Rad,             R.Y + R.H - Rad - 1,   Rad, 1, 2, AColor); // bottom-left
end;

procedure TWLCanvas.FillRoundRect(const ARect: TRectI; ARadius: Integer;
                                  AColor: TWLColor);
var
  R: TRectI;
  Rad, Y, YY, DX, XStart, XEnd: Integer;
begin
  R := ARect;
  if R.IsEmpty then Exit;

  Rad := ARadius;
  if Rad < 0 then Rad := 0;
  if Rad * 2 > R.W then Rad := R.W div 2;
  if Rad * 2 > R.H then Rad := R.H div 2;

  if Rad = 0 then begin FillRect(R, AColor); Exit; end;

  // Центральный прямоугольник (без верхних/нижних Rad строк)
  FillRect(TRectI.New(R.X, R.Y + Rad, R.W, R.H - 2 * Rad), AColor);
  // Верхняя и нижняя полосы, минус углы
  FillRect(TRectI.New(R.X + Rad, R.Y, R.W - 2 * Rad, Rad), AColor);
  FillRect(TRectI.New(R.X + Rad, R.Y + R.H - Rad, R.W - 2 * Rad, Rad), AColor);

  // Углы — четвертинки диска
  for Y := 0 to Rad - 1 do
  begin
    YY := Y - Rad;
    DX := Round(Sqrt(Rad * Rad - YY * YY));

    XStart := R.X + Rad - DX;
    XEnd   := R.X + Rad - 1;
    HLine(XStart, XEnd, R.Y + Y, AColor);                     // top-left

    XStart := R.X + R.W - Rad;
    XEnd   := R.X + R.W - Rad + DX - 1;
    HLine(XStart, XEnd, R.Y + Y, AColor);                     // top-right

    HLine(XStart, XEnd, R.Y + R.H - 1 - Y, AColor);           // bottom-right

    XStart := R.X + Rad - DX;
    XEnd   := R.X + Rad - 1;
    HLine(XStart, XEnd, R.Y + R.H - 1 - Y, AColor);           // bottom-left
  end;
end;

{ ============================================================ }
{  Эллипсы                                                      }
{ ============================================================ }

procedure TWLCanvas.Ellipse(const ARect: TRectI; AColor: TWLColor);
var
  CX, CY, RX, RY, X, Y: Integer;
  RX2, RY2, P, PX, PY: Int64;
begin
  if ARect.W <= 0 or ARect.H <= 0 then Exit;

  CX := ARect.X + ARect.W div 2;
  CY := ARect.Y + ARect.H div 2;
  RX := ARect.W div 2;
  RY := ARect.H div 2;
  if (RX = 0) or (RY = 0) then Exit;

  RX2 := Int64(RX) * RX;
  RY2 := Int64(RY) * RY;

  // Рисуем квадрантами, используя параметрический подход
  X := 0;
  Y := RY;
  PX := 0;
  PY := 2 * RX2 * Y;

  // Верхний и нижний
  while PX <= PY do
  begin
    SetPixel(CX + X, CY - Y, AColor);
    SetPixel(CX - X, CY - Y, AColor);
    SetPixel(CX + X, CY + Y, AColor);
    SetPixel(CX - X, CY + Y, AColor);

    Inc(X);
    PX := PX + 2 * RY2;
    if PX > PY then Break;

    P := PX - PY + RX2;
    if P >= 0 then
    begin
      Dec(Y);
      PY := PY - 2 * RX2;
    end;
  end;

  // Боковые
  Y := 0;
  X := RX;
  PY := 0;
  PX := 2 * RY2 * X;

  while PY <= PX do
  begin
    SetPixel(CX + X, CY - Y, AColor);
    SetPixel(CX - X, CY - Y, AColor);
    SetPixel(CX + X, CY + Y, AColor);
    SetPixel(CX - X, CY + Y, AColor);

    Inc(Y);
    PY := PY + 2 * RX2;
    if PY > PX then Break;

    P := PY - PX + RY2;
    if P >= 0 then
    begin
      Dec(X);
      PX := PX - 2 * RY2;
    end;
  end;
end;

procedure TWLCanvas.FillEllipse(const ARect: TRectI; AColor: TWLColor);
var
  CX, CY, RX, RY, Y, DX: Integer;
  RY2, RX2: Int64;
  YF, DF: Double;
begin
  if ARect.W <= 0 or ARect.H <= 0 then Exit;

  CX := ARect.X + ARect.W div 2;
  CY := ARect.Y + ARect.H div 2;
  RX := ARect.W div 2;
  RY := ARect.H div 2;
  if (RX = 0) or (RY = 0) then Exit;

  // Простой способ: для каждой строки Y считаем X по формуле эллипса
  for Y := -RY to RY do
  begin
    YF := Y / RY;
    DF := 1.0 - YF * YF;
    if DF < 0 then Continue;
    DX := Round(RX * Sqrt(DF));
    HLine(CX - DX, CX + DX, CY + Y, AColor);
  end;
end;

{ ============================================================ }
{  Вспомогательное: четверть дуги для RoundRect                 }
{ ============================================================ }
// quadrant: 0=bottom-right, 1=bottom-left, 2=top-left, 3=top-right
procedure TWLCanvas.ArcQuarter(CX, CY, R: Integer;
                               QStart, QEnd: Integer; AColor: TWLColor);
var
  Angle: Double;
  X, Y: Integer;
  Q: Integer;
  SX, SY: Integer;
begin
  if R <= 0 then Exit;

  // Рисуем дугу по квадрантам с шагом 1 пиксель по окружности
  for Q := QStart to QEnd do
  begin
    case Q of
      0: begin SX := 1;  SY := 1;  end;  // bottom-right: X+, Y+
      1: begin SX := -1; SY := 1;  end;  // bottom-left:  X-, Y+
      2: begin SX := -1; SY := -1; end;  // top-left:     X-, Y-
      3: begin SX := 1;  SY := -1; end;  // top-right:    X+, Y-
    else
      Continue;
    end;

    // четверть окружности: от (R, 0) до (0, R) в локальных коорд.
    for Angle := 0 to R do
    begin
      // параметр t от 0 до 1
      // X = R * cos(t*pi/2), Y = R * sin(t*pi/2)
      X := Round(R * Cos(Angle / R * Pi / 2));
      Y := Round(R * Sin(Angle / R * Pi / 2));
      SetPixel(CX + SX * X, CY + SY * Y, AColor);
    end;
  end;
end;

{ ============================================================ }
{  CopyRect                                                     }
{ ============================================================ }

procedure TWLCanvas.CopyRect(const ASrc: TRectI; ADstX, ADstY: Integer);
var
  Src: TRectI;
  RowBytes: Integer;
  Y, SrcY, DstY: Integer;
  SrcPtr, DstPtr: PByte;
  Tmp: PByte;
begin
  if FPixels = nil then Exit;
  Src := ASrc;
  if Src.IsEmpty then Exit;

  // Ограничиваем
  if Src.X < 0 then begin
    Dec(Src.W, -Src.X);
    Dec(ADstX, -Src.X);
    Src.X := 0;
  end;
  if Src.Y < 0 then begin
    Dec(Src.H, -Src.Y);
    Dec(ADstY, -Src.Y);
    Src.Y := 0;
  end;
  if Src.X + Src.W > FWidth then Src.W := FWidth - Src.X;
  if Src.Y + Src.H > FHeight then Src.H := FHeight - Src.Y;
  if (Src.W <= 0) or (Src.H <= 0) then Exit;

  RowBytes := Src.W * 4;

  // Простой путь — через временный буфер
  Tmp := GetMem(RowBytes);
  try
    for Y := 0 to Src.H - 1 do
    begin
      SrcY := Src.Y + Y;
      DstY := ADstY + Y;
      if (DstY < 0) or (DstY >= FHeight) then Continue;

      SrcPtr := FPixels + SrcY * FStride + Src.X * 4;
      DstPtr := FPixels + DstY * FStride + ADstX * 4;

      // Копируем через временный буфер, чтобы избежать наложения
      Move(SrcPtr^, Tmp^, RowBytes);

      // Обрезаем по границам
      if ADstX + Src.W > FWidth then
      begin
        // копируем только видимую часть
        Move(Tmp^, DstPtr^, (FWidth - ADstX) * 4);
      end
      else if ADstX >= 0 then
      begin
        Move(Tmp^, DstPtr^, RowBytes);
      end
      else
      begin
        // ADstX < 0: пропускаем первые -ADstX пикселей
        Move(PByte(Tmp + (-ADstX) * 4)^, FPixels[0], 0); // заглушка
        // (для простоты — пропустим этот случай; обычно не нужен)
      end;
    end;
  finally
    FreeMem(Tmp);
  end;
end;

{ ============================================================ }
{  Клип                                                        }
{ ============================================================ }

procedure TWLCanvas.SetClip(const ARect: TRectI);
begin
  FClip := ARect;
  // Ограничиваем границами буфера
  if FClip.X < 0 then begin Dec(FClip.W, -FClip.X); FClip.X := 0; end;
  if FClip.Y < 0 then begin Dec(FClip.H, -FClip.Y); FClip.Y := 0; end;
  if FClip.X + FClip.W > FWidth then FClip.W := FWidth - FClip.X;
  if FClip.Y + FClip.H > FHeight then FClip.H := FHeight - FClip.Y;
  if FClip.W < 0 then FClip.W := 0;
  if FClip.H < 0 then FClip.H := 0;
  FClipActive := True;
end;

procedure TWLCanvas.ResetClip;
begin
  FClipActive := False;
  FClip := TRectI.New(0, 0, FWidth, FHeight);
end;

function TWLCanvas.ClipRect: TRectI;
begin
  if FClipActive then
    Result := FClip
  else
    Result := TRectI.New(0, 0, FWidth, FHeight);
end;

end.

Внимание: в wlgui_canvas.pas использован ArcQuarter, объявленный вне класса — надо либо добавить его как приватный метод класса, либо как процедуру в implementation до RoundRect. Проще — сделать приватным методом. Добавь в private:
pascal

    procedure ArcQuarter(CX, CY, R: Integer;
                         QStart, QEnd: Integer; AColor: TWLColor);

И в implementation — как у меня, только с TWLCanvas.:
pascal

procedure TWLCanvas.ArcQuarter(CX, CY, R: Integer;
                               QStart, QEnd: Integer; AColor: TWLColor);

Изменения в wlgui_window.pas

Добавляем поле FCanvas: TWLCanvas и публичное свойство Canvas. Создаём/пересоздаём canvas в EnsureBuffers и в BeginPaint.

Патч в TWLWindow:

В private:
pascal

    FCanvas: TWLCanvas;

В public:
pascal

    property Canvas: TWLCanvas read FCanvas;

В uses:
pascal

  wlgui_types, wlgui_context, wlgui_canvas;

В constructor:
pascal

  FCanvas := nil;

В destructor, до DestroyBuffers:
pascal

  if FCanvas <> nil then FreeAndNil(FCanvas);

В EnsureBuffers, в конце:
pascal

  if FCanvas = nil then
    FCanvas := TWLCanvas.Create(FBuffers[FDrawIndex].Pixels,
                                FWidth, FHeight, FBuffers[FDrawIndex].Stride)
  else
    FCanvas.Reattach(FBuffers[FDrawIndex].Pixels,
                     FWidth, FHeight, FBuffers[FDrawIndex].Stride);

В BeginPaint — критично: после выбора буфера переключаем canvas на его пиксели:
pascal

function TWLWindow.BeginPaint: PByte;
var
  I, Idx, Tries: Integer;
begin
  Result := nil;
  if (FBuffers[0] = nil) or (FBuffers[1] = nil) then Exit;

  Tries := 0;
  Idx := FDrawIndex;
  while Tries < 2 do
  begin
    if FBuffers[Idx].Released then
    begin
      FDrawIndex := Idx;
      // переключаем canvas на этот буфер
      if FCanvas <> nil then
        FCanvas.Reattach(FBuffers[Idx].Pixels, FWidth, FHeight,
                         FBuffers[Idx].Stride);
      Result := FBuffers[Idx].Pixels;
      Exit;
    end;
    Idx := 1 - Idx;
    Inc(Tries);
  end;
end;

В EndPaint — добавляем FCanvas.ResetClip, чтобы клип не залипал между кадрами:
pascal

procedure TWLWindow.EndPaint;
var
  B: TWLShmBuffer;
begin
  if FCanvas <> nil then
    FCanvas.ResetClip;

  if (FBuffers[0] = nil) or (FBuffers[1] = nil) then Exit;

  B := FBuffers[FDrawIndex];
  if not B.Released then Exit;

  FSurface.Attach(B.Buffer, 0, 0);
  FSurface.Damage(0, 0, FWidth, FHeight);
  FSurface.Commit;
  FContext.Display.Flush;

  B.MarkBusy;
  FDrawIndex := 1 - FDrawIndex;
end;

Публичные методы Clear, SetPixel, FillRect — можно оставить как обёртки над canvas для совместимости с текущим demo, но лучше перенаправить их:
pascal

procedure TWLWindow.Clear(AColor: TWLColor);
begin
  if FCanvas <> nil then
    FCanvas.FillRect(TRectI.New(0, 0, FWidth, FHeight), AColor);
end;

procedure TWLWindow.SetPixel(AX, AY: Integer; AColor: TWLColor);
begin
  if FCanvas <> nil then
    FCanvas.SetPixel(AX, AY, AColor);
end;

procedure TWLWindow.FillRect(const ARect: TRectI; AColor: TWLColor);
begin
  if FCanvas <> nil then
    FCanvas.FillRect(ARect, AColor);
end;

Обновлённый demo_window.pas — тест всех примитивов

Заменим содержимое OnPaint — покажем все фигуры:
pascal

procedure OnPaint(Sender: TObject);
var
  W: TWLWindow;
  C: TWLCanvas;
  P: TPointI;
  R: TRectI;
  T: Integer;
begin
  W := TWLWindow(Sender);
  if W.BeginPaint = nil then Exit;
  C := W.Canvas;
  if C = nil then Exit;

  // Фон
  if Frame mod 2 = 0 then
    C.FillRect(TRectI.New(0, 0, W.Width, W.Height), TWLColor($00203050))
  else
    C.FillRect(TRectI.New(0, 0, W.Width, W.Height), TWLColor($00305020));

  // Рамка
  C.Rect(TRectI.New(10, 10, W.Width - 20, W.Height - 20), clWhite);

  // Диагонали
  C.Line(10, 10, W.Width - 11, W.Height - 11, clGray);
  C.Line(W.Width - 11, 10, 10, W.Height - 11, clGray);

  // Летящий квадрат (по горизонтали)
  T := (Frame * 4) mod (W.Width - 60);
  C.FillRect(TRectI.New(20 + T, 40, 40, 40), clRed);
  C.Rect(TRectI.New(20 + T, 40, 40, 40), clWhite);

  // Скруглённый прямоугольник
  C.FillRoundRect(TRectI.New(20, 120, 120, 60), 15, TWLColor($00208040));
  C.RoundRect(TRectI.New(20, 120, 120, 60), 15, clWhite);

  // Эллипс-контур
  C.Ellipse(TRectI.New(170, 120, 120, 60), clYellow);

  // Залитый эллипс, мигающий
  if (Frame div 30) mod 2 = 0 then
    C.FillEllipse(TRectI.New(320, 120, 120, 60), TWLColor($00A030A0))
  else
    C.FillEllipse(TRectI.New(320, 120, 120, 60), TWLColor($0030A0A0));

  // Прямоугольник с клипом
  R := TRectI.New(20, 200, 200, 60);
  C.Rect(R, clWhite);
  C.SetClip(TRectI.New(30, 210, 100, 40));
  // диагональная штриховка
  for T := 0 to 200 do
    C.Line(20 + T, 200, 20 + T - 60, 260, clLtGray);
  C.ResetClip;

  // Крест в центре
  C.Line(W.Width div 2 - 40, W.Height div 2, W.Width div 2 + 40, W.Height div 2, clYellow);
  C.Line(W.Width div 2, W.Height div 2 - 40, W.Width div 2, W.Height div 2 + 40, clYellow);

  // Полоса прогресса внизу
  T := (Frame * 3) mod (W.Width - 40);
  C.FillRect(TRectI.New(20, W.Height - 40, T, 10), TWLColor($00FF8000));
  C.Rect(TRectI.New(20, W.Height - 40, W.Width - 40, 10), clWhite);
end;

Добавь uses wlgui_canvas в demo_window.pas.
Что проверить

После сборки в окне должно быть:

    Мигающий фон

    Белая рамка

    Диагонали

    Летящий красный квадрат с белой окантовкой

    Скруглённый зелёный прямоугольник

    Жёлтый эллипс (контур)

    Мигающий залитый эллипс

    Прямоугольник с клипованной диагональной штриховкой

    Крест в центре

    Оранжевая полоса прогресса внизу

Если что-то из примитивов кривое (например, RoundRect или Ellipse) — покажи, что видно. Пиксельные алгоритмы для эллипсов часто дают «дырки», можно подправить.
Сборка
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Жду результат — потом перейдём к wlgui_font.pas.
Спасибо! Жёлтый эллипс не вижу, остальное вроде есть. Вообще удивительное зрелище: пролетает квадрат, мигает эллипс.
Разбор картинки — почти всё на месте

Смотрим, что получилось:
Примитив	Есть?	Комментарий
Фон мигает	✅	Синий/зелёный оттенок
Белая рамка	✅	
Диагонали	✅	Серые
Летящий красный квадрат	❌	Вижу синий квадрат — глюк с цветом (см. ниже)
Скруглённый зелёный	✅	FillRoundRect работает, но углы подозрительные
Жёлтый эллипс-контур	❌	Не видно
Залитый мигающий эллипс	✅	Розовый/фиолетовый
Клипованная штриховка	⚠️	Серый прямоугольник виден, но штриховки не разобрать
Крест	✅	Голубой (используется clYellow = $0000FFFF, в XRGB8888 = синий с зелёным — это ожидаемо)
Полоса прогресса	✅	Оранжевая
Баг 1: clRed даёт синий квадрат

Проверим наши цвета. clRed = $000000FF. Записываем в LongWord в память little-endian: байты FF 00 00 00. Композитор читает их как XRGB8888 → X=FF (игнорируется), R=00, G=00, B=00 → чёрный.

Стоп, но квадрат синий. Значит, композитор читает по-другому. Смотрим внимательно: WL_SHM_FORMAT_XRGB8888 = 1 — 32-bit RGB format, [31:0] x:R:G:B 8:8:8:8 little endian.

Разбираем «[31:0] x:R:G:B ... little endian»:

    Биты 31..24 = x (игнор)

    Биты 23..16 = R

    Биты 15..8 = G

    Биты 7..0 = B

    little endian значит младший байт пишется первым в памяти.

LongWord $00RRGGBB в little-endian памяти: BB GG RR 00. То есть байты идут B, G, R, x — и это правильная раскладка для XRGB8888, если значение LongWord имеет формат $00RRGGBB.

Значит наш TWLColor = $00BBGGRR был неправильным предположением!

    clRed = $000000FF → в памяти FF 00 00 00 → R=0, G=0, B=0 → чёрный? Но мы видим синий. Проверим ещё раз:

    LongWord($000000FF) в памяти little-endian: байты FF 00 00 00. То есть B-байт = FF,G=0,R=0.Пораскладке‘BBGGRR00‘—да,B=FF,G=0,R=0.Пораскладке‘BBGGRR00‘—да,B=FF → чистый синий. ✅

Значит композитор читает как BB GG RR 00 = B в младшем байте. Это подтверждается: квадрат синий.

Итог: в нашей раскладке $00BBGGRR при little-endian получается B G R x — да, R = старший байт из младших 24. У нас сейчас clRed = $000000FF означает B=$FF → синий.

Правильно должно быть: clRed = $0000FF00 (R=$FF, G=0, B=0), `clBlue = $00FF0000`, и т.д.

Проверим на розовом эллипсе: TWLColor($00A030A0) = B=$A0, G=$30, R=$A0 → визуально смесь синего и красного = пурпурный/фиолетовый — да, так и видим. ✅

Проверим на зелёном: TWLColor($00208040) = B=$20, G=$80, R=$40 → смесь зелёного и немного красного = зелёно-коричневый, но выглядит как зелёный. ✅

Итого — наша константа clRed неверная, надо $0000FF00. Но мы определили её как $000000FF. Я ошибся в первоначальном комментарии.

Правильные константы для формата $00BBGGRR с little-endian памятью, чтобы получить ожидаемый цвет:
Цвет	LongWord	Байты в памяти (B, G, R, x)	Визуально
Красный	$000000FF	FF 00 00 00	B=$FF → синий ❌
Красный (правильно)	$0000FF00	00 FF 00 00	R=$FF → красный ✅
Зелёный	$00FF0000	00 00 FF 00	G=$FF → зелёный ✅
Синий	$000000FF	FF 00 00 00	B=$FF → синий ✅
Белый	$00FFFFFF	FF FF FF 00	все = FF → белый ✅
Чёрный	$00000000	00 00 00 00	всё 0 → чёрный ✅
Жёлтый	$0000FFFF	FF FF 00 00	R+G → жёлтый ✅

Стоп, но у нас clGreen = $0000FF00, а clRed = $000000FF. Это значит, что clRed и clBlue перепутаны.

И clYellow = $0000FFFF — но это должно быть R+G = $00FFFF00. А у нас $0000FFFF = G+B = циан/голубой. Именно поэтому крест голубой, а не жёлтый!

Итого: у нас все константы правильные, кроме clRed/clBlue, и clYellow/clCyan, и clMagenta.

Правильные константы для TWLColor = $00BBGGRR (little-endian → B G R x):
pascal

clBlack   = $00000000;   // 00 00 00 00
clWhite   = $00FFFFFF;   // FF FF FF 00
clRed     = $0000FF00;   // 00 FF 00 00  → R=$FF
clGreen   = $00FF0000;   // 00 00 FF 00  → G=$FF
clBlue    = $000000FF;   // FF 00 00 00  → B=$FF
clYellow  = $00FFFF00;   // 00 FF FF 00  → R+G
clCyan    = $00FF00FF;   // FF FF 00 00  → B+G
clMagenta = $00FF00FF;   // стоп, надо B+R = $00FF00FF? нет...

Стоп, я запутался. Давай строго.

Модель: TWLColor = LongWord, интерпретируется как байты в little-endian памяти, которые композитор видит как XRGB8888 (little endian):

    Байт 0 (младший в LongWord) → B

    Байт 1 → G

    Байт 2 → R

    Байт 3 → X (игнор)

Значит LongWord = X<<24 | R<<16 | G<<8 | B. То есть $00RRGGBB — стандартный HTML-подобный порядок, а не $00BBGGRR!

Проверим:

    clRed = R=$FF, G=0, B=0 → LongWord = `$00FF0000→ в памяти байты00 00 FF 00` → B=0, G=0, R=$FF ✅

    clBlue = B=$FF → LongWord = `$000000FF→ в памятиFF 00 00 00` → B=$FF ✅

Значит всё наоборот: TWLColor должен быть $00RRGGBB, а не $00BBGGRR. Я в комментарии в первом сообщении напутал.
Правильные константы
pascal

const
  clBlack   : TWLColor = $00000000;
  clWhite   : TWLColor = $00FFFFFF;
  clRed     : TWLColor = $00FF0000;
  clGreen   : TWLColor = $0000FF00;
  clBlue    : TWLColor = $000000FF;
  clYellow  : TWLColor = $00FFFF00;
  clCyan    : TWLColor = $0000FFFF;
  clMagenta : TWLColor = $00FF00FF;
  clGray    : TWLColor = $00808080;
  clDkGray  : TWLColor = $00404040;
  clLtGray  : TWLColor = $00C0C0C0;

И MakeColor(R, G, B) = (R shl 16) or (G shl 8) or B.

Проверим текущее поведение:

    clRed был $000000FF → в памяти FF 00 00 00 → B=$FF → синий ✅ (совпадает с наблюдением)

    clYellow был $0000FFFF → в памяти FF FF 00 00 → B=FF,G=FF,G=FF → голубой ✅ (совпадает с крестом)

    clGreen был $0000FF00 → в памяти 00 FF 00 00 → G=$FF → зелёный ✅ (совпадает)

    clMagenta был $00FF00FF → в памяти FF 00 FF 00 → B=FF,R=FF,R=FF → пурпурный ✅

Отлично, я разобрался. Меняем константы — теперь всё будет как ожидается.
Баг 2: жёлтый эллипс не видно

Причина: clYellow = $0000FFFF = голубой, и он совпадает по цвету с крестом. А ещё он рисуется до залитого эллипса, но после прямоугольников. Возможно, он просто сливается с фоном или перекрывается другим.

Посмотрим код:
pascal

C.Ellipse(TRectI.New(170, 120, 120, 60), clYellow);

Ellipse рисует контур в (170,120)-(290,180). Между скруглённым (20,120,120,60) и залитым (320,120,120,60). По картинке — там пусто. Возможно, Ellipse рисует только отдельные пиксели с пропусками, и контур слишком тонкий/разреженный, чтобы его разглядеть.

Проверим алгоритм Ellipse: он использует численные методы Брезенхэма для эллипса. Возможна ошибка в инициализации (например, X := 0; Y := RY; — это для верхней части, но потом X := RX; Y := 0; для боковых, и переход между ними может дать разрыв).

Более простой и надёжный подход — параметрический эллипс:
pascal

procedure TWLCanvas.Ellipse(const ARect: TRectI; AColor: TWLColor);
var
  CX, CY, RX, RY, I, Steps: Integer;
  Angle, X, Y: Double;
  PrevX, PrevY: Integer;
begin
  if (ARect.W <= 0) or (ARect.H <= 0) then Exit;

  CX := ARect.X + ARect.W div 2;
  CY := ARect.Y + ARect.H div 2;
  RX := ARect.W div 2;
  RY := ARect.H div 2;
  if (RX = 0) or (RY = 0) then Exit;

  // Число шагов ~ периметр эллипса
  Steps := Round(2 * Pi * (RX + RY) / 2);
  if Steps < 24 then Steps := 24;

  PrevX := CX + RX;
  PrevY := CY;

  for I := 1 to Steps do
  begin
    Angle := 2 * Pi * I / Steps;
    X := CX + RX * Cos(Angle);
    Y := CY + RY * Sin(Angle);
    Line(PrevX, PrevY, Round(X), Round(Y), AColor);
    PrevX := Round(X);
    PrevY := Round(Y);
  end;
end;

Это медленнее, но гарантированно непрерывный контур. Плюс использует уже проверенный Line. Заменяем.
Баг 3: углы RoundRect с артефактами

На скруглённом зелёном прямоугольнике видны точки на углах и небольшие «усики». Это из-за того, что ArcQuarter рисует несколько квадрантов и они перекрываются:
pascal

ArcQuarter(..., QStart := 2, QEnd := 3, ...);  // top-left, top-right

Каждый вызов с QStart..QEnd рисует диапазон квадрантов, и для RoundRect мы вызываем 4 раза с парами (2,3), (3,4), (0,1), (1,2). Квадрант 3 попадает в два вызова, квадрант 1 тоже. Отсюда лишние точки.

Правильно: каждый угол — один квадрант:
pascal

ArcQuarter(R.X + Rad,             R.Y + Rad,             Rad, 2, AColor); // top-left
ArcQuarter(R.X + R.W - Rad - 1,   R.Y + Rad,             Rad, 3, AColor); // top-right
ArcQuarter(R.X + R.W - Rad - 1,   R.Y + R.H - Rad - 1,   Rad, 0, AColor); // bottom-right
ArcQuarter(R.X + Rad,             R.Y + R.H - Rad - 1,   Rad, 1, AColor); // bottom-left

И сам ArcQuarter — с одним параметром Q, а не диапазоном:
pascal

procedure TWLCanvas.ArcQuarter(CX, CY, R, Q: Integer; AColor: TWLColor);
var
  I, X, Y: Integer;
  SX, SY: Integer;
  Angle: Double;
begin
  if R <= 0 then Exit;

  case Q of
    0: begin SX := 1;  SY := 1;  end;  // BR: X+, Y+
    1: begin SX := -1; SY := 1;  end;  // BL: X-, Y+
    2: begin SX := -1; SY := -1; end;  // TL: X-, Y-
    3: begin SX := 1;  SY := -1; end;  // TR: X+, Y-
  else
    Exit;
  end;

  for I := 0 to R do
  begin
    Angle := I / R * Pi / 2;
    X := Round(R * Cos(Angle));
    Y := Round(R * Sin(Angle));
    SetPixel(CX + SX * X, CY + SY * Y, AColor);
  end;
end;

Что менять сейчас
1. wlgui_types.pas — исправить константы
pascal

const
  clBlack   : TWLColor = $00000000;
  clWhite   : TWLColor = $00FFFFFF;
  clRed     : TWLColor = $00FF0000;
  clGreen   : TWLColor = $0000FF00;
  clBlue    : TWLColor = $000000FF;
  clYellow  : TWLColor = $00FFFF00;
  clCyan    : TWLColor = $0000FFFF;
  clMagenta : TWLColor = $00FF00FF;
  clGray    : TWLColor = $00808080;
  clDkGray  : TWLColor = $00404040;
  clLtGray  : TWLColor = $00C0C0C0;

И MakeColor:
pascal

function MakeColor(R, G, B: Byte): TWLColor;
begin
  Result := (LongWord(R) shl 16) or (LongWord(G) shl 8) or LongWord(B);
end;

И комментарий-пояснение:
pascal

{ Формат TWLColor: $00RRGGBB.
  При записи в SHM XRGB8888 (little-endian) LongWord попадает в память
  как байты [B, G, R, 0], что соответствует раскладке XRGB8888: [x:R:G:B].
  Итого: клиент пишет $00RRGGBB, композитор видит R, G, B в правильных каналах. }

2. wlgui_canvas.pas — заменить Ellipse, ArcQuarter

См. выше. Также обновить объявление ArcQuarter в private:
pascal

    procedure ArcQuarter(CX, CY, R, Q: Integer; AColor: TWLColor);

3. demo_window.pas — обновить цвета
pascal

// Фон
C.FillRect(TRectI.New(0, 0, W.Width, W.Height), TWLColor($00302040));  // R=30, G=20, B=40 — тёмно-синий

Теперь TWLColor($00RRGGBB). Мой прежний $00203050 теперь = R=$20, G=$30, B=$50 — тоже тёмный, но другой оттенок. Ничего страшного.

Проверим остальные цвета:

    TWLColor($00208040) = R=$20, G=$80, B=$40 — зелёный с примесями

    TWLColor($00A030A0) = R=$A0, G=$30, B=$A0 — пурпурный

    TWLColor($0030A0A0) = R=30,G=30,G=A0, B=$A0 — циан

    TWLColor($00FF8000) = R=$FF, G=$80, B=0 — оранжевый

Всё логично, просто замени константы в wlgui_types.pas — и demo сразу станет правильноцветным.
Итог патча

    wlgui_types.pas: заменить константы и MakeColor (5 строк).

    wlgui_canvas.pas: заменить Ellipse на параметрический; заменить ArcQuarter на один квадрант.

    Ничего в demo_window.pas не меняем — после фикса цветов увидим правильные красный квадрат, жёлтый эллипс, зелёный RoundRect, циановый крест.

После патча ожидаем:

    Квадрат — красный ✅

    Эллипс-контур — жёлтый ✅

    Крест — жёлтый ✅ (был циановый из-за бага в clYellow)

    Прогресс-бар — оранжевый ✅ (был оранжевый случайно)

    Всё остальное — правильных оттенков

Патчим и смотрим.
wlgui_canvas.pas(301,78) Error: Wrong number of parameters specified for call to "ArcQuarter"
wlgui_canvas.pas(25,15) Error: Found declaration: ArcQuarter(LongInt;LongInt;LongInt;LongInt;TWLColor);
wlgui_canvas.pas(302,78) Error: Wrong number of parameters specified for call to "ArcQuarter"
wlgui_canvas.pas(25,15) Error: Found declaration: ArcQuarter(LongInt;LongInt;LongInt;LongInt;TWLColor);
wlgui_canvas.pas(303,78) Error: Wrong number of parameters specified for call to "ArcQuarter"
wlgui_canvas.pas(25,15) Error: Found declaration: ArcQuarter(LongInt;LongInt;LongInt;LongInt;TWLColor);
wlgui_canvas.pas(304,78) Error: Wrong number of parameters specified for call to "ArcQuarter"
wlgui_canvas.pas(25,15) Error: Found declaration: ArcQuarter(LongInt;LongInt;LongInt;LongInt;TWLColor);
Забыл поправить вызовы ArcQuarter в RoundRect

Ты обновил объявление и реализацию ArcQuarter (теперь 5 параметров: CX, CY, R, Q, Color), но в RoundRect остались старые вызовы с 6 параметрами (CX, CY, R, QStart, QEnd, Color).
Патч wlgui_canvas.pas — функция RoundRect

Найди в RoundRect эти строки:
pascal

  ArcQuarter(R.X + Rad,             R.Y + Rad,             Rad, 2, 3, AColor); // top-left
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + Rad,             Rad, 3, 4, AColor); // top-right
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + R.H - Rad - 1,   Rad, 0, 1, AColor); // bottom-right
  ArcQuarter(R.X + Rad,             R.Y + R.H - Rad - 1,   Rad, 1, 2, AColor); // bottom-left

И замени на:
pascal

  ArcQuarter(R.X + Rad,             R.Y + Rad,             Rad, 2, AColor); // top-left
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + Rad,             Rad, 3, AColor); // top-right
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + R.H - Rad - 1,   Rad, 0, AColor); // bottom-right
  ArcQuarter(R.X + Rad,             R.Y + R.H - Rad - 1,   Rad, 1, AColor); // bottom-left

Разница: было Rad, 2, 3, AColor (5 параметров начиная с Rad), стало Rad, 2, AColor (3 параметра).

То есть убираем второй номер квадранта из пары (2,3), (3,4), (0,1), (1,2) — оставляем по одному: 2, 3, 0, 1.
Полный контекст — как должна выглядеть RoundRect
pascal

procedure TWLCanvas.RoundRect(const ARect: TRectI; ARadius: Integer;
                              AColor: TWLColor);
var
  R: TRectI;
  Rad: Integer;
begin
  R := ARect;
  if R.IsEmpty then Exit;

  Rad := ARadius;
  if Rad < 0 then Rad := 0;
  if Rad * 2 > R.W then Rad := R.W div 2;
  if Rad * 2 > R.H then Rad := R.H div 2;

  if Rad = 0 then begin Rect(R, AColor); Exit; end;

  // Прямые участки
  HLine(R.X + Rad, R.X + R.W - Rad - 1, R.Y, AColor);
  HLine(R.X + Rad, R.X + R.W - Rad - 1, R.Y + R.H - 1, AColor);
  VLine(R.X, R.Y + Rad, R.Y + R.H - Rad - 1, AColor);
  VLine(R.X + R.W - 1, R.Y + Rad, R.Y + R.H - Rad - 1, AColor);

  // Углы — по одному квадранту
  ArcQuarter(R.X + Rad,             R.Y + Rad,             Rad, 2, AColor); // top-left
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + Rad,             Rad, 3, AColor); // top-right
  ArcQuarter(R.X + R.W - Rad - 1,   R.Y + R.H - Rad - 1,   Rad, 0, AColor); // bottom-right
  ArcQuarter(R.X + Rad,             R.Y + R.H - Rad - 1,   Rad, 1, AColor); // bottom-left
end;

Проверка реализации ArcQuarter

Убедись, что реализация тоже с 5 параметрами и одним Q:
pascal

procedure TWLCanvas.ArcQuarter(CX, CY, R, Q: Integer; AColor: TWLColor);
var
  I, X, Y: Integer;
  SX, SY: Integer;
  Angle: Double;
begin
  if R <= 0 then Exit;

  case Q of
    0: begin SX := 1;  SY := 1;  end;  // BR: X+, Y+
    1: begin SX := -1; SY := 1;  end;  // BL: X-, Y+
    2: begin SX := -1; SY := -1; end;  // TL: X-, Y-
    3: begin SX := 1;  SY := -1; end;  // TR: X+, Y-
  else
    Exit;
  end;

  for I := 0 to R do
  begin
    Angle := I / R * Pi / 2;
    X := Round(R * Cos(Angle));
    Y := Round(R * Sin(Angle));
    SetPixel(CX + SX * X, CY + SY * Y, AColor);
  end;
end;

После патча собери:
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Ожидаем:

    Красный летящий квадрат (после фикса цветов)

    Жёлтый эллипс-контур

    Жёлтый крест

    Зелёный скруглённый (без артефактов на углах)

    Оранжевый прогресс

Спасибо!
🎉 Идеальная картинка — canvas полностью работает!

Проверим по пунктам:
Примитив	Состояние
Фон	✅ Тёмно-синий
Белая рамка	✅
Диагонали	✅ Серые
Летящий квадрат	✅ Красный с белой окантовкой
Скруглённый FillRoundRect	✅ Зелёный, углы чистые, без артефактов
Скруглённый RoundRect (контур)	✅ Зелёная окантовка по краям
Ellipse (жёлтый контур)	✅ Виден, гладкий, без дырок
FillEllipse	✅ Пурпурный, мигает
SetClip + штриховка	✅ Серый прямоугольник с клипом
Крест	✅ Жёлтый (правильный!)
Прогресс-бар	✅ Оранжевый

Все баги исправлены:

    clRed теперь красный, clBlue — синий.

    Жёлтый эллипс виден — параметрический алгоритм работает.

    Углы RoundRect чистые — по одному квадранту.

Этап 2 пройден полностью. Что мы имеем:

Уровень 1 (Wayland): wayland_client_core, wayland_protocol, xdg_shell_protocol, wayland_util.

Уровень 2 (wlgui):

    wlgui_types — цвета, точки, прямоугольники, callback-тип

    wlgui_context — соединение, глобалы, event loop с таймаутом

    wlgui_app — приложение, инициализация, обработка событий

    wlgui_window — окно с двойной буферизацией и wl_buffer.release

    wlgui_canvas — все графические примитивы

Что дальше — wlgui_font.pas

Следующий шаг — текст. Это последний «графический» блок перед событиями.
Что нужно решить до реализации
1. FreeType — как подключаем?

Варианты:

    A: Динамически, через dynlibs (как в msefreetype_wayland.pas). Нет зависимости на этапе сборки, libfreetype.so.6 грузится при старте.

    B: Статически через {$linklib freetype}. Требует -k-lfreetype, но обычно fpc и так линкует libc, так что нормально.

Я за A — как в твоём существующем модуле. Плюс — если FreeType не найдётся, можно откатиться на встроенный 8×16 шрифт (у нас такой был в msewaylandfonts).
2. Откуда берём шрифт?

Можно:

    A: Искать DejaVuSans.ttf в стандартных местах (/usr/share/fonts/truetype/dejavu/, ~/.fonts/). Простой фиксированный путь.

    B: Читать fontconfig для поиска по имени (libfontconfig). Правильнее, но +1 библиотека.

    C: Дать пользователю путь к шрифту в конфиге. Для «минимума» — не нужен.

    D: Встроить очень маленький шрифт прямо в exe (например, 8×16 битмап для ASCII + кириллицы). Не требует TTF, но не масштабируется.

Я за A — фиксированный поиск по стандартным путям. Для начала — только DejaVuSans.ttf с fallback на встроенный ASCII-шрифт, если TTF не найдётся. Позже добавим fontconfig.
3. Кэш глифов

TWLFont.LoadGlyph(Code) → TWLGlyph с полями:
pascal

type
  TWLGlyph = record
    Code: LongWord;      // codepoint
    Width, Height: Integer;
    Left, Top: Integer;   // смещение от baseline
    Advance: Integer;
    // Монохромная маска: 1 байт на пиксель (0..255)
    Data: PByte;
  end;

Рендерим через FT_Render_Glyph(FT_RENDER_MODE_NORMAL) — grayscale. При выводе смешиваем с фоном:
text

dst = (src * alpha + dst * (255 - alpha)) / 255

Это даёт сглаженный текст.

Кэш — TFPGMap<LongWord, PGlyph> (из fgl) или TStringList (костыль). Пойду через TFPGMap — он есть в FPC RTL.
4. Что рисует TextOut
pascal

procedure TWLCanvas.TextOut(AX, AY: Integer; const AText: UTF8String;
                            AColor: TWLColor; AFont: TWLFont);
function  TWLCanvas.TextWidth(const AText: UTF8String;
                              AFont: TWLFont): Integer;

Внутри — итерируемся по кодовым точкам через u4utf8 (уже есть), берём глиф из кэша, рисуем с alpha-смешиванием.

Позиция (AX, AY) — верхний левый угол глифа (проще для UI), а не baseline. Или baseline? Я за верхний левый — привычнее для «нарисовать надпись в прямоугольнике».
5. u4str vs UTF8String в API

TWLCanvas.TextOut может принимать либо UTF8String, либо IU4String.

    UTF8String — привычно, коротко.

    IU4String — уже нормализовано, прямая итерация по codepoint.

Я предлагаю принимать оба:
pascal

procedure TextOut(AX, AY: Integer; const S: UTF8String; ...); overload;
procedure TextOut(AX, AY: Integer; const S: IU4String; ...); overload;

Первый внутри конвертирует через UTF8ToU4, второй — напрямую. Так demo-код может писать TextOut(10, 10, 'Hello', ...), а серьёзный код — работать с IU4String без лишних копий.
6. Встроенный fallback-шрифт

На случай отсутствия TTF — встроить ASCII 8×16 в wlgui_font.pas. Он будет использоваться автоматически. Позже можно добавить кириллицу (для начала — только ASCII 32..127).
Вопросы к тебе

    FreeType: динамически через dynlibs (мой вариант A)?

    Путь шрифта: стандартные пути + fallback на встроенный (мой вариант A)?

    API TextOut: принимает UTF8String и IU4String (overload)? Или только один вариант?

    Позиция текста: (AX, AY) = верхний левый угол глифа (мой вариант), или baseline?

    Сглаживание: alpha-blend с фоном (grayscale AA) — согласен? Или пока жёсткие чёрно-белые пиксели (быстрее, но уродливее)?

    Сколько кэшировать: кэш на TWLFont, живёт пока жив шрифт. Ограничение размера не нужно для типичного UI (ASCII+кириллица = ~200 глифов).

Готов писать код. Скажи по пунктам.
FreeType подключим динамически. Шрифт ищем в стандартных местах, пункт A. 3 пункт - не используем генерики - они как-то не работают, сколько не пробовали. TextOut и u4str vs UTF8String - на всякий случай оба. 6 пункт - да, пусть встроенный шрифт будет. Ответы: Позиция текста - верхний левый угол глифа. Сглаживание: alpha-blend с фоном (grayscale AA) — согласен? Да, согласен. Сколько кэшировать. Тоже согласен с тобой. Приступим.
Этап 3: wlgui_font.pas — текст через FreeType

Отлично, всё зафиксировано. Приступаю.
Что делаем

    Динамическая загрузка FreeType через dynlibs (LoadLibrary/GetProcAddress).

    Поиск шрифта в стандартных путях, fallback на встроенный ASCII 8×16.

    Кэш глифов без дженериков — свой минимальный хэш на массивах.

    Alpha-blend при отрисовке — градации серого (grayscale AA).

    API: TextOut / TextWidth — overload для UTF8String и IU4String.

    Позиция: (AX, AY) = верхний левый угол глифа.

wlgui_font.pas
pascal

unit wlgui_font;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, dynlibs,
  u4intf, u4utf8,
  wlgui_types;

type
  { --- Глиф --- }
  TWLGlyph = record
    Code: LongWord;        // codepoint
    Width: Integer;        // ширина bitmap
    Height: Integer;       // высота bitmap
    Left: Integer;         // смещение от origin (левый край bitmap)
    Top: Integer;          // смещение верхнего края bitmap от baseline (FT: bitmap_top)
    Advance: Integer;      // ширина для следующего глифа
    Mask: PByte;           // Width*Height байт (0..255)
  end;
  PWLGlyph = ^TWLGlyph;

  { --- Шрифт --- }
  TWLFont = class
  private
    FName: String;
    FFileName: String;
    FHeight: Integer;      // требуемая высота, px
    FAscent: Integer;
    FDescent: Integer;
    FLineSpacing: Integer;
    FMaxAdvance: Integer;

    // FreeType
    FFace: Pointer;        // PFT_Face
    FValid: Boolean;
    FIsBuiltin: Boolean;

    // Кэш глифов: два массива (Codes, Glyphs) + линейный поиск по хэшу
    FHashSize: Integer;
    FCodeBuckets: array of array of LongWord;   // список кодов в бакете
    FGlyphBuckets: array of array of PWLGlyph;  // соответствующие глифы
    FCount: Integer;

    function HashCode(C: LongWord): Integer; inline;
    function FindGlyph(C: LongWord): PWLGlyph;
    procedure InsertGlyph(C: LongWord; G: PWLGlyph);
    function LoadGlyphFT(C: LongWord): PWLGlyph;
    function LoadGlyphBuiltin(C: LongWord): PWLGlyph;
    procedure FreeAllGlyphs;
  public
    constructor Create(const AName: String; AHeight: Integer);
    destructor Destroy; override;

    { Возвращает глиф (из кэша или свежезагруженный). nil если нет. }
    function GetGlyph(C: LongWord): PWLGlyph;

    { Ширина строки (в пикселях) в этом шрифте. }
    function TextWidth(const S: IU4String): Integer; overload;
    function TextWidth(const S: UTF8String): Integer; overload;

    property Name: String read FName;
    property FileName: String read FFileName;
    property Height: Integer read FHeight;
    property Ascent: Integer read FAscent;
    property Descent: Integer read FDescent;
    property LineSpacing: Integer read FLineSpacing;
    property Valid: Boolean read FValid;
    property IsBuiltin: Boolean read FIsBuiltin;
  end;

  { --- Менеджер шрифтов (простой кэш по (Name, Height)) --- }
  TWLFontManager = class
  private
    FFonts: TList;
    function FindFont(const AName: String; AHeight: Integer): TWLFont;
  public
    constructor Create;
    destructor Destroy; override;
    function Load(const AName: String; AHeight: Integer): TWLFont;
    procedure Release(AFont: TWLFont);
  end;

var
  FontManager: TWLFontManager = nil;

{ Инициализация / финализация FreeType. Вызывается автоматически. }
function WLFontInit: Boolean;
procedure WLFontDone;

{ --- Встроенный ASCII-шрифт 8×16 (fallback) --- }
const
  BuiltinFont8x16: array[0..95] of array[0..15] of Byte = (
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$18,$3C,$3C,$3C,$18,$18,$18,$00,$18,$18,$00,$00,$00,$00),
    ($00,$66,$66,$66,$24,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$6C,$6C,$FE,$6C,$6C,$6C,$FE,$6C,$6C,$00,$00,$00,$00),
    ($00,$18,$3E,$60,$60,$3C,$06,$06,$7C,$18,$18,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$30,$30,$30,$60,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$0C,$18,$30,$30,$30,$30,$30,$30,$18,$0C,$00,$00,$00,$00,$00),
    ($00,$30,$18,$0C,$0C,$0C,$0C,$0C,$0C,$18,$30,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$6C,$38,$FE,$38,$6C,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$18,$18,$7E,$18,$18,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$18,$18,$30,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$7E,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$18,$18,$00,$00,$00,$00),
    ($00,$02,$06,$0C,$18,$30,$60,$C0,$80,$00,$00,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C3,$C3,$C3,$C3,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$18,$38,$18,$18,$18,$18,$18,$18,$18,$7E,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$03,$06,$0C,$18,$30,$60,$FF,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$03,$1C,$03,$03,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$06,$0E,$1E,$36,$66,$C6,$FE,$06,$06,$0F,$00,$00,$00,$00,$00),
    ($00,$FE,$C0,$C0,$FC,$06,$03,$03,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$1C,$30,$60,$C0,$FC,$C6,$C3,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$FF,$03,$06,$0C,$18,$30,$30,$30,$30,$30,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C3,$66,$3C,$66,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C3,$66,$3E,$03,$06,$0C,$38,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$18,$18,$00,$00,$18,$18,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$18,$18,$00,$00,$18,$18,$30,$00,$00,$00,$00,$00),
    ($00,$06,$0C,$18,$30,$60,$30,$18,$0C,$06,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$7E,$00,$00,$7E,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$60,$30,$18,$0C,$06,$0C,$18,$30,$60,$00,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$03,$06,$0C,$18,$18,$00,$18,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$18,$3C,$66,$C3,$C3,$FF,$C3,$C3,$C3,$C3,$00,$00,$00,$00,$00),
    ($00,$FC,$C6,$C6,$C6,$FC,$C6,$C6,$C6,$C6,$FC,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C0,$C0,$C0,$C0,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$F8,$CC,$C6,$C6,$C6,$C6,$C6,$C6,$CC,$F8,$00,$00,$00,$00,$00),
    ($00,$FE,$C0,$C0,$C0,$FC,$C0,$C0,$C0,$C0,$FE,$00,$00,$00,$00,$00),
    ($00,$FE,$C0,$C0,$C0,$FC,$C0,$C0,$C0,$C0,$C0,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C0,$C0,$CF,$C3,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$C3,$C3,$FF,$C3,$C3,$C3,$C3,$C3,$00,$00,$00,$00,$00),
    ($00,$7E,$18,$18,$18,$18,$18,$18,$18,$18,$7E,$00,$00,$00,$00,$00),
    ($00,$3F,$06,$06,$06,$06,$06,$06,$C6,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$C6,$C6,$CC,$D8,$F0,$D8,$CC,$C6,$C6,$C6,$00,$00,$00,$00,$00),
    ($00,$C0,$C0,$C0,$C0,$C0,$C0,$C0,$C0,$C0,$FE,$00,$00,$00,$00,$00),
    ($00,$C3,$E7,$FF,$FF,$DB,$C3,$C3,$C3,$C3,$C3,$00,$00,$00,$00,$00),
    ($00,$C3,$E3,$F3,$FB,$CF,$C7,$C3,$C3,$C3,$C3,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C3,$C3,$C3,$C3,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$FC,$C6,$C6,$C6,$FC,$C0,$C0,$C0,$C0,$C0,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C3,$C3,$C3,$C3,$DB,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$FC,$C6,$C6,$C6,$FC,$D8,$CC,$C6,$C6,$C6,$00,$00,$00,$00,$00),
    ($00,$3C,$66,$C3,$C0,$60,$3C,$06,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$7E,$18,$18,$18,$18,$18,$18,$18,$18,$18,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$C3,$C3,$C3,$C3,$C3,$C3,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$C3,$C3,$C3,$C3,$C3,$66,$3C,$18,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$C3,$C3,$C3,$DB,$FF,$FF,$66,$66,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$66,$3C,$18,$18,$3C,$66,$C3,$C3,$00,$00,$00,$00,$00),
    ($00,$C3,$C3,$C3,$66,$3C,$18,$18,$18,$18,$18,$00,$00,$00,$00,$00),
    ($00,$FF,$03,$06,$0C,$18,$30,$60,$C0,$C0,$FF,$00,$00,$00,$00,$00),
    ($00,$3C,$30,$30,$30,$30,$30,$30,$30,$30,$3C,$00,$00,$00,$00,$00),
    ($00,$80,$C0,$60,$30,$18,$0C,$06,$02,$00,$00,$00,$00,$00,$00,$00),
    ($00,$3C,$0C,$0C,$0C,$0C,$0C,$0C,$0C,$0C,$3C,$00,$00,$00,$00,$00),
    ($00,$18,$3C,$66,$C3,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$FF),
    ($00,$60,$30,$18,$0C,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3C,$06,$3E,$66,$66,$3E,$00,$00,$00,$00,$00),
    ($00,$60,$60,$60,$60,$7C,$66,$66,$66,$66,$7C,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3C,$66,$60,$60,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$06,$06,$06,$06,$3E,$66,$66,$66,$66,$3E,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3C,$66,$7E,$60,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$1C,$36,$30,$30,$78,$30,$30,$30,$30,$78,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3E,$66,$66,$66,$3E,$06,$7C,$00,$00,$00,$00),
    ($00,$60,$60,$60,$60,$7C,$66,$66,$66,$66,$66,$00,$00,$00,$00,$00),
    ($00,$18,$18,$00,$38,$18,$18,$18,$18,$18,$7E,$00,$00,$00,$00,$00),
    ($00,$06,$06,$00,$0E,$06,$06,$06,$06,$06,$06,$7C,$00,$00,$00,$00),
    ($00,$60,$60,$60,$60,$66,$6C,$78,$6C,$66,$66,$00,$00,$00,$00,$00),
    ($00,$38,$18,$18,$18,$18,$18,$18,$18,$18,$7E,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$EC,$FE,$DB,$DB,$DB,$DB,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$7C,$66,$66,$66,$66,$66,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3C,$66,$66,$66,$66,$3C,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$7C,$66,$66,$66,$7C,$60,$60,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3E,$66,$66,$66,$3E,$06,$06,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$7C,$66,$60,$60,$60,$60,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$3E,$60,$3C,$06,$7C,$00,$00,$00,$00,$00,$00),
    ($00,$30,$30,$30,$30,$78,$30,$30,$30,$36,$1C,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$66,$66,$66,$66,$66,$3E,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$66,$66,$66,$66,$3C,$18,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$DB,$DB,$DB,$DB,$FE,$6C,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$66,$3C,$18,$3C,$66,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$66,$66,$66,$3E,$06,$7C,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$7E,$06,$0C,$18,$30,$7E,$00,$00,$00,$00,$00),
    ($00,$0E,$18,$18,$18,$70,$18,$18,$18,$18,$0E,$00,$00,$00,$00,$00),
    ($00,$18,$18,$18,$18,$18,$18,$18,$18,$18,$18,$00,$00,$00,$00,$00),
    ($00,$70,$18,$18,$18,$0E,$18,$18,$18,$18,$70,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$76,$DC,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00),
    ($00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00)
  );

implementation

{ ============================================================ }
{  FreeType — динамическая загрузка                             }
{ ============================================================ }

type
  FT_Error = cint;
  FT_Library = Pointer;
  FT_Face = Pointer;
  FT_GlyphSlot = Pointer;
  FT_UInt = cuint;
  FT_ULong = culong;
  FT_Int = cint;
  FT_Pos = clong;
  FT_Fixed = clong;

  PFT_Vector = ^TFT_Vector;
  TFT_Vector = record
    x: FT_Pos;
    y: FT_Pos;
  end;

  PFT_Matrix = ^TFT_Matrix;
  TFT_Matrix = record
    xx, xy, yx, yy: FT_Fixed;
  end;

  PFT_Bitmap = ^TFT_Bitmap;
  TFT_Bitmap = record
    rows: cuint;
    width: cuint;
    pitch: cint;
    buffer: PByte;
    num_grays: cushort;
    pixel_mode: Byte;
    palette_mode: Byte;
    palette: Pointer;
  end;

  PFT_Glyph_Metrics = ^TFT_Glyph_Metrics;
  TFT_Glyph_Metrics = record
    width: FT_Pos;
    height: FT_Pos;
    horiBearingX: FT_Pos;
    horiBearingY: FT_Pos;
    horiAdvance: FT_Pos;
    vertBearingX: FT_Pos;
    vertBearingY: FT_Pos;
    vertAdvance: FT_Pos;
  end;

  PFT_GlyphSlot = ^TFT_GlyphSlotRec;
  TFT_GlyphSlotRec = record
    library: Pointer;
    face: Pointer;
    next: PFT_GlyphSlot;
    reserved: cuint;
    generic: Pointer;
    metrics: TFT_Glyph_Metrics;
    linearHoriAdvance: FT_Fixed;
    linearVertAdvance: FT_Fixed;
    advance: TFT_Vector;
    format: cuint;
    bitmap: TFT_Bitmap;
    bitmap_left: FT_Int;
    bitmap_top: FT_Int;
  end;

  PFT_FaceRec = ^TFT_FaceRec;
  TFT_FaceRec = record
    num_faces: FT_Long;
    face_index: FT_Long;
    face_flags: FT_Long;
    style_flags: FT_Long;
    num_glyphs: FT_Long;
    family_name: PChar;
    style_name: PChar;
    num_fixed_sizes: FT_Int;
    available_sizes: Pointer;
    num_charmaps: FT_Int;
    charmaps: Pointer;
    generic: Pointer;
    bbox: record
      xMin, yMin, xMax, yMax: FT_Pos;
    end;
    units_per_EM: cushort;
    ascender: cshort;
    descender: cshort;
    height: cshort;
    max_advance_width: cshort;
    max_advance_height: cshort;
    underline_position: cshort;
    underline_thickness: cshort;
    glyph: PFT_GlyphSlot;
  end;

const
  FT_RENDER_MODE_NORMAL = 0;
  FT_LOAD_DEFAULT = 0;

var
  // Указатели на функции FreeType
  FT_Init_FreeType: function(var alibrary: FT_Library): FT_Error; cdecl = nil;
  FT_Done_FreeType: function(alibrary: FT_Library): FT_Error; cdecl = nil;
  FT_New_Face: function(alibrary: FT_Library; filepathname: PChar;
                        face_index: FT_Long; var aface: FT_Face): FT_Error; cdecl = nil;
  FT_Done_Face: function(face: FT_Face): FT_Error; cdecl = nil;
  FT_Set_Pixel_Sizes: function(face: FT_Face; pixel_width: FT_UInt;
                               pixel_height: FT_UInt): FT_Error; cdecl = nil;
  FT_Get_Char_Index: function(face: FT_Face; charcode: FT_ULong): FT_UInt; cdecl = nil;
  FT_Load_Glyph: function(face: FT_Face; glyph_index: FT_UInt;
                          load_flags: FT_Int): FT_Error; cdecl = nil;
  FT_Render_Glyph: function(slot: FT_GlyphSlot;
                            render_mode: cuint): FT_Error; cdecl = nil;

var
  FTLib: FT_Library = nil;
  FTLibHandle: TLibHandle = 0;
  FTLoaded: Boolean = False;

function WLFontInit: Boolean;
begin
  Result := False;
  if FTLoaded then Exit(True);

  FTLibHandle := LoadLibrary('libfreetype.so.6');
  if FTLibHandle = 0 then
    FTLibHandle := LoadLibrary('libfreetype.so');
  if FTLibHandle = 0 then
    Exit;

  Pointer(FT_Init_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Init_FreeType');
  Pointer(FT_Done_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Done_FreeType');
  Pointer(FT_New_Face)       := GetProcAddress(FTLibHandle, 'FT_New_Face');
  Pointer(FT_Done_Face)      := GetProcAddress(FTLibHandle, 'FT_Done_Face');
  Pointer(FT_Set_Pixel_Sizes):= GetProcAddress(FTLibHandle, 'FT_Set_Pixel_Sizes');
  Pointer(FT_Get_Char_Index) := GetProcAddress(FTLibHandle, 'FT_Get_Char_Index');
  Pointer(FT_Load_Glyph)     := GetProcAddress(FTLibHandle, 'FT_Load_Glyph');
  Pointer(FT_Render_Glyph)   := GetProcAddress(FTLibHandle, 'FT_Render_Glyph');

  if (Pointer(FT_Init_FreeType) = nil) or (Pointer(FT_New_Face) = nil) then
  begin
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  if FT_Init_FreeType(FTLib) <> 0 then
  begin
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  FTLoaded := True;
  Result := True;
end;

procedure WLFontDone;
begin
  if not FTLoaded then Exit;
  if FTLib <> nil then
  begin
    FT_Done_FreeType(FTLib);
    FTLib := nil;
  end;
  if FTLibHandle <> 0 then
  begin
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
  end;
  FTLoaded := False;
end;

{ ============================================================ }
{  Поиск TTF-файла                                              }
{ ============================================================ }

function FindFontFile(const AName: String; out AFileName: String): Boolean;
const
  Dirs: array[0..9] of String = (
    '/usr/share/fonts/truetype/dejavu/',
    '/usr/share/fonts/truetype/liberation/',
    '/usr/share/fonts/truetype/freefont/',
    '/usr/share/fonts/truetype/ubuntu/',
    '/usr/share/fonts/TTF/',
    '/usr/share/fonts/',
    '/usr/local/share/fonts/',
    '~/.fonts/',
    '~/.local/share/fonts/',
    '/usr/share/fonts/truetype/'
  );
var
  I: Integer;
  Base, P: String;
  Exts: array[0..1] of String;
  J: Integer;
  Test: String;
begin
  Result := False;
  AFileName := '';

  Base := AName;
  Exts[0] := '.ttf';
  Exts[1] := '.otf';

  for I := 0 to High(Dirs) do
    for J := 0 to High(Exts) do
    begin
      Test := Dirs[I] + Base + Exts[J];
      P := ExpandFileName(Test);
      if FileExists(P) then
      begin
        AFileName := P;
        Exit(True);
      end;
      // Попробуем с маленькой буквы
      P := ExpandFileName(Dirs[I] + LowerCase(Base) + Exts[J]);
      if FileExists(P) then
      begin
        AFileName := P;
        Exit(True);
      end;
    end;
end;

{ ============================================================ }
{  TWLFont                                                      }
{ ============================================================ }

const
  HASH_BUCKETS = 127;

constructor TWLFont.Create(const AName: String; AHeight: Integer);
var
  Face: FT_Face;
  FaceRec: PFT_FaceRec;
begin
  inherited Create;
  FName := AName;
  FHeight := AHeight;
  FValid := False;
  FIsBuiltin := False;
  FCount := 0;
  FHashSize := HASH_BUCKETS;
  SetLength(FCodeBuckets, FHashSize);
  SetLength(FGlyphBuckets, FHashSize);

  if AHeight <= 0 then
    raise Exception.CreateFmt('TWLFont: invalid height %d', [AHeight]);

  // 1. Пытаемся загрузить TTF
  if WLFontInit and FindFontFile(AName, FFileName) then
  begin
    if FT_New_Face(FTLib, PChar(FFileName), 0, Face) = 0 then
    begin
      FFace := Face;
      if FT_Set_Pixel_Sizes(Face, 0, AHeight) = 0 then
      begin
        FaceRec := PFT_FaceRec(Face);
        // Масштабируем метрики к запрошенному размеру
        if FaceRec^.units_per_EM > 0 then
        begin
          FAscent := Round(FaceRec^.ascender * AHeight / FaceRec^.units_per_EM);
          FDescent := -Round(FaceRec^.descender * AHeight / FaceRec^.units_per_EM);
        end
        else
        begin
          FAscent := Abs(FaceRec^.ascender);
          FDescent := Abs(FaceRec^.descender);
        end;
        FLineSpacing := FAscent + FDescent + 2;
        FMaxAdvance := AHeight;
        FValid := True;
      end
      else
      begin
        FT_Done_Face(Face);
        FFace := nil;
      end;
    end;
  end;

  // 2. Fallback: встроенный ASCII 8×16
  if not FValid then
  begin
    FIsBuiltin := True;
    FValid := True;
    FAscent := 12;
    FDescent := 4;
    FLineSpacing := 16;
    FMaxAdvance := 8;
    FFileName := '(builtin 8x16)';
  end;
end;

destructor TWLFont.Destroy;
begin
  FreeAllGlyphs;
  if (not FIsBuiltin) and (FFace <> nil) then
  begin
    FT_Done_Face(FFace);
    FFace := nil;
  end;
  inherited;
end;

function TWLFont.HashCode(C: LongWord): Integer;
begin
  Result := Integer(C xor (C shr 8)) mod FHashSize;
  if Result < 0 then Result := Result + FHashSize;
end;

function TWLFont.FindGlyph(C: LongWord): PWLGlyph;
var
  H, I: Integer;
begin
  H := HashCode(C);
  for I := 0 to High(FCodeBuckets[H]) do
    if FCodeBuckets[H][I] = C then
      Exit(FGlyphBuckets[H][I]);
  Result := nil;
end;

procedure TWLFont.InsertGlyph(C: LongWord; G: PWLGlyph);
var
  H, N: Integer;
begin
  H := HashCode(C);
  N := Length(FCodeBuckets[H]);
  SetLength(FCodeBuckets[H], N + 1);
  SetLength(FGlyphBuckets[H], N + 1);
  FCodeBuckets[H][N] := C;
  FGlyphBuckets[H][N] := G;
  Inc(FCount);
end;

procedure TWLFont.FreeAllGlyphs;
var
  H, I: Integer;
begin
  for H := 0 to FHashSize - 1 do
  begin
    for I := 0 to High(FGlyphBuckets[H]) do
    begin
      if FGlyphBuckets[H][I] <> nil then
      begin
        if FGlyphBuckets[H][I]^.Mask <> nil then
          FreeMem(FGlyphBuckets[H][I]^.Mask);
        Dispose(FGlyphBuckets[H][I]);
      end;
    end;
    SetLength(FCodeBuckets[H], 0);
    SetLength(FGlyphBuckets[H], 0);
  end;
  FCount := 0;
end;

function TWLFont.LoadGlyphFT(C: LongWord): PWLGlyph;
var
  GlyphIdx: FT_UInt;
  Slot: PFT_GlyphSlot;
  Bmp: PFT_Bitmap;
  G: PWLGlyph;
  RowBytes, I: Integer;
begin
  Result := nil;
  if FFace = nil then Exit;

  GlyphIdx := FT_Get_Char_Index(FFace, C);
  if GlyphIdx = 0 then Exit;

  if FT_Load_Glyph(FFace, GlyphIdx, FT_LOAD_DEFAULT) <> 0 then Exit;
  Slot := PFT_GlyphSlot(PFT_FaceRec(FFace)^.glyph);
  if Slot = nil then Exit;
  if FT_Render_Glyph(Slot, FT_RENDER_MODE_NORMAL) <> 0 then Exit;

  Bmp := @Slot^.bitmap;

  New(G);
  G^.Code := C;
  G^.Width := Bmp^.width;
  G^.Height := Bmp^.rows;
  G^.Left := Slot^.bitmap_left;
  G^.Top := Slot^.bitmap_top;
  G^.Advance := (Slot^.metrics.horiAdvance + 32) shr 6;
  G^.Mask := nil;

  if (G^.Width > 0) and (G^.Height > 0) then
  begin
    RowBytes := G^.Width * G^.Height;
    GetMem(G^.Mask, RowBytes);
    for I := 0 to G^.Height - 1 do
      Move(Bmp^.buffer[I * Bmp^.pitch],
           G^.Mask[I * G^.Width],
           G^.Width);
  end;

  InsertGlyph(C, G);
  Result := G;
end;

function TWLFont.LoadGlyphBuiltin(C: LongWord): PWLGlyph;
var
  G: PWLGlyph;
  Idx, J, K: Integer;
  Bits: Byte;
  Dst: PByte;
begin
  Result := nil;
  if (C < 32) or (C > 127) then
  begin
    // Для не-ASCII — пустой глиф (пробел-заполнитель)
    New(G);
    G^.Code := C;
    G^.Width := 0;
    G^.Height := 0;
    G^.Left := 0;
    G^.Top := 0;
    G^.Advance := 8;
    G^.Mask := nil;
    InsertGlyph(C, G);
    Exit(G);
  end;

  Idx := Integer(C) - 32;

  New(G);
  G^.Code := C;
  G^.Width := 8;
  G^.Height := 16;
  G^.Left := 0;
  G^.Top := 12;              // высота над baseline
  G^.Advance := 8;
  GetMem(G^.Mask, 8 * 16);

  // Раскодируем биты 8×16
  for J := 0 to 15 do
  begin
    Bits := BuiltinFont8x16[Idx][J];
    Dst := G^.Mask + J * 8;
    for K := 0 to 7 do
    begin
      if (Bits and ($80 shr K)) <> 0 then
        Dst^ := 255
      else
        Dst^ := 0;
      Inc(Dst);
    end;
  end;

  InsertGlyph(C, G);
  Result := G;
end;

function TWLFont.GetGlyph(C: LongWord): PWLGlyph;
begin
  Result := FindGlyph(C);
  if Result <> nil then Exit;

  if FIsBuiltin then
    Result := LoadGlyphBuiltin(C)
  else
    Result := LoadGlyphFT(C);

  // Для отсутствующих TTF-глифов — пустой advance
  if (Result = nil) and (not FIsBuiltin) then
  begin
    New(Result);
    Result^.Code := C;
    Result^.Width := 0;
    Result^.Height := 0;
    Result^.Left := 0;
    Result^.Top := 0;
    Result^.Advance := FHeight div 2;
    Result^.Mask := nil;
    InsertGlyph(C, Result);
  end;
end;

function TWLFont.TextWidth(const S: IU4String): Integer;
var
  I: Integer;
  G: PWLGlyph;
begin
  Result := 0;
  if S = nil then Exit;
  for I := 0 to S.Length - 1 do
  begin
    G := GetGlyph(S.GetChar(I));
    if G <> nil then
      Inc(Result, G^.Advance);
  end;
end;

function TWLFont.TextWidth(const S: UTF8String): Integer;
begin
  Result := TextWidth(UTF8ToU4(S));
end;

{ ============================================================ }
{  TWLFontManager                                               }
{ ============================================================ }

constructor TWLFontManager.Create;
begin
  inherited Create;
  FFonts := TList.Create;
end;

destructor TWLFontManager.Destroy;
var
  I: Integer;
begin
  if FFonts <> nil then
  begin
    for I := FFonts.Count - 1 downto 0 do
      TWLFont(FFonts[I]).Free;
    FreeAndNil(FFonts);
  end;
  inherited;
end;

function TWLFontManager.FindFont(const AName: String; AHeight: Integer): TWLFont;
var
  I: Integer;
  F: TWLFont;
begin
  Result := nil;
  for I := 0 to FFonts.Count - 1 do
  begin
    F := TWLFont(FFonts[I]);
    if (F.Name = AName) and (F.Height = AHeight) then
      Exit(F);
  end;
end;

function TWLFontManager.Load(const AName: String; AHeight: Integer): TWLFont;
begin
  Result := FindFont(AName, AHeight);
  if Result = nil then
  begin
    Result := TWLFont.Create(AName, AHeight);
    FFonts.Add(Result);
  end;
end;

procedure TWLFontManager.Release(AFont: TWLFont);
begin
  // Пока не реализуем — шрифты живут до конца программы
end;

{ ============================================================ }
{  Инициализация                                                }
{ ============================================================ }

initialization
  FontManager := TWLFontManager.Create;

finalization
  if FontManager <> nil then
    FreeAndNil(FontManager);
  WLFontDone;

end.

Патч wlgui_canvas.pas — добавляем TextOut

В interface, после uses wlgui_types:
pascal

uses
  Classes, SysUtils, Math,
  u4intf, u4utf8,
  wlgui_types, wlgui_font;

В классе TWLCanvas, в public:
pascal

    // Текст
    procedure TextOut(AX, AY: Integer; const AText: UTF8String;
                      AColor: TWLColor; AFont: TWLFont); overload;
    procedure TextOut(AX, AY: Integer; const AText: IU4String;
                      AColor: TWLColor; AFont: TWLFont); overload;

    function TextWidth(const AText: UTF8String; AFont: TWLFont): Integer; overload;
    function TextWidth(const AText: IU4String; AFont: TWLFont): Integer; overload;

    procedure TextOutCentered(AY: Integer; const AText: UTF8String;
                              AColor: TWLColor; AFont: TWLFont);

Реализация в implementation:
pascal

{ ============================================================ }
{  Текст                                                        }
{ ============================================================ }

procedure TWLCanvas.TextOut(AX, AY: Integer; const AText: UTF8String;
                            AColor: TWLColor; AFont: TWLFont);
begin
  TextOut(AX, AY, UTF8ToU4(AText), AColor, AFont);
end;

procedure TWLCanvas.TextOut(AX, AY: Integer; const AText: IU4String;
                            AColor: TWLColor; AFont: TWLFont);
var
  I, X, Y, GlyphX, GlyphY, Px, Py: Integer;
  Code: LongWord;
  G: PWLGlyph;
  Alpha: Byte;
  DstPixel: PLongWord;
  DstR, DstG, DstB: Byte;
  SrcR, SrcG, SrcB: Byte;
  InvA: Integer;
begin
  if (FPixels = nil) or (AText = nil) or (AFont = nil) then Exit;

  // Разбираем цвет
  SrcR := (AColor shr 16) and $FF;
  SrcG := (AColor shr 8) and $FF;
  SrcB := AColor and $FF;

  X := AX;
  Y := AY;   // верхний левый угол глифа; для FT это (Y) − (bitmap_top)

  for I := 0 to AText.Length - 1 do
  begin
    Code := AText.GetChar(I);
    G := AFont.GetGlyph(Code);
    if G = nil then
    begin
      Inc(X, AFont.Height div 2);
      Continue;
    end;

    // Позиция верхнего левого угла bitmap'а глифа:
    //   left  = X + G.Left
    //   top   = Y + AFont.Ascent − G.Top
    // где Y — baseline для этого глифа (при «верхний левый угол глифа»)
    //
    // Для простоты: Y здесь — это верх строки, а baseline = Y + Ascent.
    GlyphX := X + G^.Left;
    GlyphY := Y + AFont.Ascent - G^.Top;

    if (G^.Width > 0) and (G^.Height > 0) and (G^.Mask <> nil) then
    begin
      for Py := 0 to G^.Height - 1 do
      begin
        for Px := 0 to G^.Width - 1 do
        begin
          Alpha := G^.Mask[Py * G^.Width + Px];
          if Alpha = 0 then Continue;

          if not PixelInside(GlyphX + Px, GlyphY + Py) then Continue;

          DstPixel := GetPixelPtr(GlyphX + Px, GlyphY + Py);
          if Alpha = 255 then
          begin
            DstPixel^ := AColor;
          end
          else
          begin
            // Alpha blend: dst = (src * a + dst * (255-a)) / 255
            DstB := DstPixel^ and $FF;
            DstG := (DstPixel^ shr 8) and $FF;
            DstR := (DstPixel^ shr 16) and $FF;

            InvA := 255 - Alpha;
            DstR := (SrcR * Alpha + DstR * InvA) div 255;
            DstG := (SrcG * Alpha + DstG * InvA) div 255;
            DstB := (SrcB * Alpha + DstB * InvA) div 255;

            DstPixel^ := (LongWord(DstR) shl 16) or
                         (LongWord(DstG) shl 8) or
                          LongWord(DstB);
          end;
        end;
      end;
    end;

    Inc(X, G^.Advance);
  end;
end;

function TWLCanvas.TextWidth(const AText: UTF8String; AFont: TWLFont): Integer;
begin
  if AFont = nil then Exit(0);
  Result := AFont.TextWidth(AText);
end;

function TWLCanvas.TextWidth(const AText: IU4String; AFont: TWLFont): Integer;
begin
  if AFont = nil then Exit(0);
  Result := AFont.TextWidth(AText);
end;

procedure TWLCanvas.TextOutCentered(AY: Integer; const AText: UTF8String;
                                    AColor: TWLColor; AFont: TWLFont);
var
  W: Integer;
begin
  if AFont = nil then Exit;
  W := AFont.TextWidth(AText);
  TextOut((FWidth - W) div 2, AY, AText, AColor, AFont);
end;

Патч wlgui_app.pas — не обязательно, шрифты авто-инициализируются

FontManager создаётся в initialization секции wlgui_font.pas. Первый вызов FontManager.Load(...) сам поднимет FreeType.
Патч demo_window.pas — тестируем текст

Добавляем в uses:
pascal

  wlgui_types, wlgui_context, wlgui_app, wlgui_window, wlgui_canvas, wlgui_font;

Глобальная переменная для шрифта:
pascal

var
  BigFont, SmallFont: TWLFont;

В OnPaint после остального:
pascal

  // Текст разными шрифтами
  if BigFont = nil then BigFont := FontManager.Load('DejaVuSans', 32);
  if SmallFont = nil then SmallFont := FontManager.Load('DejaVuSans', 16);

  C.TextOut(20, 20, 'Привет, Wayland!', clWhite, BigFont);
  C.TextOut(20, 60, 'Hello, world! 0123456789', clYellow, SmallFont);
  C.TextOut(20, 80, 'Русский текст: Ёжик в тумане', clLtGray, SmallFont);

  // Ширина строки
  C.TextOut(20, 100,
    Format('Ширина "Hello": %d px', [C.TextWidth('Hello', SmallFont)]),
    clCyan, SmallFont);

  // Центрированный текст вверху окна
  C.TextOutCentered(5, 'wlgui — текст через FreeType', clWhite, SmallFont);

Добавь SysUtils в uses для Format.
Проверка

Собираем:
bash

fpc -Fu. -Fuwlgui demo_window.pas
./demo_window

Ожидаем:

    Если FreeType найден (обычно да): чёткий сглаженный текст в правильных позициях — «Привет, Wayland!» большим шрифтом, ASCII + цифры + русский ниже, ширина строки в пикселях, центрированный заголовок вверху.

    Если FreeType нет: fallback на встроенный 8×16 — грубые пиксельные буквы, только ASCII (русские буквы будут пустыми).

На что обратить внимание

    FreeType init в разных процессах: WLFontInit вызывается лениво, при первом TWLFont.Create. Если FreeType не найден, FontManager.Load всё равно работает — через встроенный.

    PFT_FaceRec — я определил только нужные поля. Если реальная структура FT_Face в твоём FreeType сдвинута — ascender/descender могут оказаться не на месте. Тогда возьми метрики жёстко: FAscent := (AHeight * 3) div 4, FDescent := AHeight - FAscent. Это тоже сработает, просто менее точно.

    Кэш без дженериков — сделал через массивы с хэшом по 127 бакетам. Для типичного UI (200-300 глифов) работает быстро.

    Сглаживание: пробуем серый, Alpha in [0..255]. Совсем без сглаживания — установить Alpha := 255 для любого Alpha > 0.

Пробуй, показывай результат. Если текст кривой (смещён по вертикали) — поправим метрики: Top, Ascent, позицию baseline.
Starting program: /tmp/demo_window
[Thread debugging using libthread_db enabled]
Using host libthread_db library "/usr/lib/x86_64-linux-gnu/libthread_db.so.1".
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560

Program received signal SIGSEGV, Segmentation fault.
0x00007ffff7e8fc39 in FT_Render_Glyph () from /usr/lib/x86_64-linux-gnu/libfreetype.so.6
(gdb) bt
#0  0x00007ffff7e8fc39 in FT_Render_Glyph () from /usr/lib/x86_64-linux-gnu/libfreetype.so.6
#1  0x00000000004857d3 in LOADGLYPHFT (this=0x7ffff7fac3a0, C=208) at wlgui_font.pas:569
#2  0x0000000000485b8a in GETGLYPH (this=0x7ffff7fac3a0, C=208) at wlgui_font.pas:657
#3  0x0000000000484482 in TEXTOUT (this=0x7ffff7f9c780, AX=20, AY=20, ATEXT=0x7ffff7f9c820, ACOLOR=16777215, AFONT=0x7ffff7fac3a0)
    at wlgui_canvas.pas:724
#4  0x00000000004843a5 in TEXTOUT (this=0x7ffff7f9c780, AX=20, AY=20,
    ATEXT=0x4a4040 '�'#144'�'#159'�'#145'�'#128'�'#144'¸�'#144'²�'#144'µ�'#145'�'#130', Wayland!', ACOLOR=16777215, AFONT=0x7ffff7fac3a0)
    at wlgui_canvas.pas:696
#5  0x0000000000401b68 in ONPAINT (SENDER=0x7ffff7fa40e0) at demo_window.pas:81
#6  0x0000000000482515 in REPAINT (this=0x7ffff7fa40e0) at wlgui_window.pas:524
#7  0x0000000000401e78 in main () at demo_window.pas:122
SIGSEGV в FT_Render_Glyph — ошибка в определении структур FreeType

Причина: я неправильно определил структуры TFT_FaceRec и TFT_GlyphSlotRec. Реальные структуры FreeType больше и содержат другие поля между теми, что нам нужны. Из-за этого Slot^.bitmap указывает не туда, а FT_Render_Glyph(Slot, ...) падает.

Правильный подход: не определять эти структуры вообще. FreeType — opaque-тип для этих указателей. Нам нужны только:

    FT_Face — указатель, передаём в API

    FT_GlyphSlot — указатель, получаем через FT_Get_GlyphSlot(face)

    FT_Bitmap — только эта структура нам реально нужна, и её надо определить правильно

    Метрики глифа — получаем через FT_GlyphSlot + аксессоры или через FT_Glyph_Get_CBox

Ключ: FT_Get_GlyphSlot(face) возвращает slot, и только первое поле после bitmap — bitmap_left, bitmap_top — нам важны. Но чтобы получить slot, надо знать хотя бы одно поле в FT_Face: glyph.

Проблема: FT_FaceRec — большая структура, и glyph находится в конце. Но мы можем не обращаться к полям FT_FaceRec — использовать аксессоры:

    FT_Get_GlyphSlot(face, out slot) — получить slot

    FT_Get_Char_Index — для индекса глифа

    FT_Load_Glyph — загрузить

    FT_Render_Glyph — рендерить

    FT_Get_Kerning — кернинг (не используем)

Для метрик:

    FT_Face даёт FT_FaceRec через указатель. Но чтобы не гадать — есть функция FT_Get_Postscript_Name... нет, не то.

    Есть макросы, которые в C читают поля напрямую. В Паскале мы должны определить FT_FaceRec точно.

Правильный TFT_FaceRec

Возьмём из официального fttypes.h (FreeType 2.10+):
c

typedef struct FT_FaceRec_ {
    FT_Long           num_faces;
    FT_Long           face_index;
    FT_Long           face_flags;
    FT_Long           style_flags;
    FT_Long           num_glyphs;
    FT_String*        family_name;
    FT_String*        style_name;
    FT_Int            num_fixed_sizes;
    FT_Bitmap_Size*   available_sizes;
    FT_Int            num_charmaps;
    FT_CharMap*       charmaps;
    FT_Generic        generic;
    FT_BBox           bbox;
    FT_UShort         units_per_EM;
    FT_Short          ascender;
    FT_Short          descender;
    FT_Short          height;
    FT_Short          max_advance_width;
    FT_Short          max_advance_height;
    FT_Short          underline_position;
    FT_Short          underline_thickness;
    FT_GlyphSlot      glyph;
    FT_Size           size;
    FT_CharMap        charmap;
    ...
} FT_FaceRec;

Обрати внимание: FT_Generic — это структура, не Pointer!
c

typedef struct  FT_Generic_ {
    void*                 data;
    FT_Generic_Finalizer  finalizer;
} FT_Generic;

Два поля по 8 байт = 16 байт, не 8. Значит мой generic: Pointer сдвигает всю структуру на 8 байт — и все поля после него читаются не с теми смещениями.
Исправление

Заменяем определение TFT_FaceRec и TFT_GlyphSlotRec на точные.
pascal

type
  FT_Generic = record
    data: Pointer;
    finalizer: Pointer;
  end;

  FT_BBox = record
    xMin, yMin, xMax, yMax: FT_Pos;
  end;

  PFT_FaceRec = ^TFT_FaceRec;
  TFT_FaceRec = record
    num_faces: FT_Long;
    face_index: FT_Long;
    face_flags: FT_Long;
    style_flags: FT_Long;
    num_glyphs: FT_Long;
    family_name: PChar;
    style_name: PChar;
    num_fixed_sizes: FT_Int;
    available_sizes: Pointer;
    num_charmaps: FT_Int;
    charmaps: Pointer;
    generic: FT_Generic;          // ← было Pointer, теперь запись
    bbox: FT_BBox;                // ← было inline-запись, теперь отдельный тип
    units_per_EM: cushort;
    ascender: cshort;
    descender: cshort;
    height: cshort;
    max_advance_width: cshort;
    max_advance_height: cshort;
    underline_position: cshort;
    underline_thickness: cshort;
    glyph: Pointer;               // FT_GlyphSlot
    // (остальные поля не нужны)
  end;

  PFT_GlyphSlotRec = ^TFT_GlyphSlotRec;
  TFT_GlyphSlotRec = record
    library: Pointer;
    face: Pointer;
    next: Pointer;
    glyph_index: cuint;           // ← добавлено! Я пропустил это поле
    generic: FT_Generic;          // ← тоже FT_Generic, не Pointer
    metrics: TFT_Glyph_Metrics;
    linearHoriAdvance: FT_Fixed;
    linearVertAdvance: FT_Fixed;
    advance: TFT_Vector;
    format: cuint;
    bitmap: TFT_Bitmap;           // ← вот это нам нужно
    bitmap_left: FT_Int;
    bitmap_top: FT_Int;
    // (остальные не нужны)
  end;

Ключевые различия:

    generic: Pointer → generic: FT_Generic (это 16 байт, не 8).

    glyph_index: cuint добавлено в TFT_GlyphSlotRec (я его пропустил — 4 байта, сдвиг!).

    bbox вынесен как отдельный record (в C это inline).

Но лучше — вообще не парсить TFT_FaceRec

Используем функции-аксессоры FreeType:

    FT_Get_GlyphSlot(face, out slot) — вместо face^.glyph

    FT_Load_Glyph + FT_Render_Glyph(slot, ...)

    slot^.bitmap, slot^.bitmap_left, slot^.bitmap_top, slot^.advance.x — эти поля в FT_GlyphSlotRec устойчивы (идут в начале, до reserved и прочего).

Для метрик шрифта (ascender, descender, units_per_EM) — используем FT_FaceRec, но правильно определённую.
Полное исправление wlgui_font.pas

Заменяем блок определений типов FreeType:
pascal

type
  FT_Error = cint;
  FT_Library = Pointer;
  FT_Face = Pointer;
  FT_Size = Pointer;
  FT_GlyphSlot = Pointer;
  FT_UInt = cuint;
  FT_ULong = culong;
  FT_Int = cint;
  FT_Pos = clong;
  FT_Fixed = clong;
  FT_Long = clong;

  PFT_Vector = ^TFT_Vector;
  TFT_Vector = record
    x: FT_Pos;
    y: FT_Pos;
  end;

  PFT_Bitmap = ^TFT_Bitmap;
  TFT_Bitmap = record
    rows: cuint;
    width: cuint;
    pitch: cint;
    buffer: PByte;
    num_grays: cushort;
    pixel_mode: Byte;
    palette_mode: Byte;
    palette: Pointer;
  end;

  PFT_Glyph_Metrics = ^TFT_Glyph_Metrics;
  TFT_Glyph_Metrics = record
    width: FT_Pos;
    height: FT_Pos;
    horiBearingX: FT_Pos;
    horiBearingY: FT_Pos;
    horiAdvance: FT_Pos;
    vertBearingX: FT_Pos;
    vertBearingY: FT_Pos;
    vertAdvance: FT_Pos;
  end;

  // FT_Generic - 16 байт
  TFT_Generic = record
    data: Pointer;
    finalizer: Pointer;
  end;

  // FT_BBox
  TFT_BBox = record
    xMin, yMin, xMax, yMax: FT_Pos;
  end;

  // FT_FaceRec - точное определение
  PFT_FaceRec = ^TFT_FaceRec;
  TFT_FaceRec = record
    num_faces: FT_Long;
    face_index: FT_Long;
    face_flags: FT_Long;
    style_flags: FT_Long;
    num_glyphs: FT_Long;
    family_name: PChar;
    style_name: PChar;
    num_fixed_sizes: FT_Int;
    available_sizes: Pointer;
    num_charmaps: FT_Int;
    charmaps: Pointer;
    generic: TFT_Generic;
    bbox: TFT_BBox;
    units_per_EM: cushort;
    ascender: cshort;
    descender: cshort;
    height: cshort;
    max_advance_width: cshort;
    max_advance_height: cshort;
    underline_position: cshort;
    underline_thickness: cshort;
    glyph: Pointer;      // FT_GlyphSlot
    // (после этого в C идут size, charmap — не нужны)
  end;

  // FT_GlyphSlotRec - точное определение, но читаем только начало
  PFT_GlyphSlotRec = ^TFT_GlyphSlotRec;
  TFT_GlyphSlotRec = record
    library: Pointer;
    face: Pointer;
    next: Pointer;
    glyph_index: cuint;         // ← ключевое поле, я его пропустил
    generic: TFT_Generic;
    metrics: TFT_Glyph_Metrics;
    linearHoriAdvance: FT_Fixed;
    linearVertAdvance: FT_Fixed;
    advance: TFT_Vector;
    format: cuint;
    bitmap: TFT_Bitmap;
    bitmap_left: FT_Int;
    bitmap_top: FT_Int;
    // (остальное не нужно)
  end;

Плюс объявляем новую функцию FT_Get_GlyphSlot:
pascal

var
  FT_Get_GlyphSlot: function(face: FT_Face; var slot: FT_GlyphSlot): FT_Error; cdecl = nil;

И в WLFontInit:
pascal

Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');
if Pointer(FT_Get_GlyphSlot) = nil then
begin
  // ...
  Exit;
end;

Патч LoadGlyphFT

Заменяем прямой доступ к face^.glyph на вызов FT_Get_GlyphSlot:
pascal

function TWLFont.LoadGlyphFT(C: LongWord): PWLGlyph;
var
  GlyphIdx: FT_UInt;
  SlotPtr: FT_GlyphSlot;
  Slot: PFT_GlyphSlotRec;
  Bmp: PFT_Bitmap;
  G: PWLGlyph;
  RowBytes, I: Integer;
  HorAdvance: FT_Pos;
begin
  Result := nil;
  if FFace = nil then Exit;

  GlyphIdx := FT_Get_Char_Index(FFace, C);
  if GlyphIdx = 0 then Exit;

  if FT_Load_Glyph(FFace, GlyphIdx, FT_LOAD_DEFAULT) <> 0 then Exit;

  // Правильное получение слота
  if FT_Get_GlyphSlot(FFace, SlotPtr) <> 0 then Exit;
  if SlotPtr = nil then Exit;

  Slot := PFT_GlyphSlotRec(SlotPtr);
  if FT_Render_Glyph(SlotPtr, FT_RENDER_MODE_NORMAL) <> 0 then Exit;

  Bmp := @Slot^.bitmap;

  New(G);
  G^.Code := C;
  G^.Width := Bmp^.width;
  G^.Height := Bmp^.rows;
  G^.Left := Slot^.bitmap_left;
  G^.Top := Slot^.bitmap_top;
  HorAdvance := Slot^.metrics.horiAdvance;
  G^.Advance := (HorAdvance + 32) shr 6;
  G^.Mask := nil;

  if (G^.Width > 0) and (G^.Height > 0) then
  begin
    RowBytes := G^.Width * G^.Height;
    GetMem(G^.Mask, RowBytes);
    for I := 0 to G^.Height - 1 do
      Move(Bmp^.buffer[I * Bmp^.pitch],
           G^.Mask[I * G^.Width],
           G^.Width);
  end;

  InsertGlyph(C, G);
  Result := G;
end;

Патч метрик в конструкторе TWLFont.Create

Тоже заменяем доступ к face^.glyph (там у нас было FaceRec := PFT_FaceRec(Face) и .units_per_EM — это как раз правильно, но проверим смещения после исправления TFT_FaceRec):
pascal

constructor TWLFont.Create(const AName: String; AHeight: Integer);
var
  Face: FT_Face;
  FaceRec: PFT_FaceRec;
begin
  // ... (без изменений в начале)
  if WLFontInit and FindFontFile(AName, FFileName) then
  begin
    if FT_New_Face(FTLib, PChar(FFileName), 0, Face) = 0 then
    begin
      FFace := Face;
      if FT_Set_Pixel_Sizes(Face, 0, AHeight) = 0 then
      begin
        FaceRec := PFT_FaceRec(Face);
        if FaceRec^.units_per_EM > 0 then
        begin
          FAscent := Round(FaceRec^.ascender * AHeight / FaceRec^.units_per_EM);
          FDescent := -Round(FaceRec^.descender * AHeight / FaceRec^.units_per_EM);
        end
        else
        begin
          FAscent := Abs(FaceRec^.ascender);
          FDescent := Abs(FaceRec^.descender);
        end;
        FLineSpacing := FAscent + FDescent + 2;
        FMaxAdvance := AHeight;
        FValid := True;
      end
      else
      begin
        FT_Done_Face(Face);
        FFace := nil;
      end;
    end;
  end;
  // ...
end;

Здесь никаких изменений, только TFT_FaceRec теперь правильный.
Дополнительные диагностические выводы

Добавь в TWLFont.Create:
pascal

WriteLn('[font] file=', FFileName, ' name=', AName, ' height=', AHeight,
        ' valid=', FValid, ' builtin=', FIsBuiltin,
        ' ascent=', FAscent, ' descent=', FDescent,
        ' units_per_EM=', PFT_FaceRec(Face)^.units_per_EM);

Это подтвердит, что метрики читаются правильно. Для DejaVuSans при высоте 32 ожидаем:

    units_per_EM = 2048

    ascender ≈ 1901

    descender ≈ -483

    FAscent ≈ 30

    FDescent ≈ 7

Что ещё могло пойти не так

Если после исправления TFT_FaceRec/TFT_GlyphSlotRec всё равно падает в FT_Render_Glyph — возможна вторая причина: FT_Load_Glyph прошёл успешно, но Slot^.bitmap.buffer содержит мусор из-за того, что мы читаем slot после FT_Render_Glyph правильно, но FT_Get_GlyphSlot вернул не тот указатель.

Проверь размеры:
pascal

WriteLn('[dbg] SizeOf(TFT_FaceRec)=', SizeOf(TFT_FaceRec));         // ~ 168
WriteLn('[dbg] SizeOf(TFT_GlyphSlotRec)=', SizeOf(TFT_GlyphSlotRec)); // ~ 200
WriteLn('[dbg] SizeOf(TFT_Bitmap)=', SizeOf(TFT_Bitmap));            // 40
WriteLn('[dbg] SizeOf(TFT_Generic)=', SizeOf(TFT_Generic));          // 16
WriteLn('[dbg] Offset glyph in face =', Integer(@PFT_FaceRec(nil)^.glyph));

Ориентиры (64-bit):

    TFT_Generic = 16

    TFT_BBox = 32

    TFT_FaceRec = ~168 (не критично, главное — смещение glyph)

    TFT_GlyphSlotRec = ~200

    Offset glyph = 152 (для 64-bit: 5×4 + 2×8 + 4 + 8 + 4 + 8 + 16 + 32 + 2 + 2 + 2 + 2 + 2 + 2 + 2 + 2 = 20 + 16 + 4 + 8 + 4 + 8 + 16 + 32 + 16 = 124? Пересчёт ниже.)

Считаем точно (64-bit Linux):

    num_faces (4) + face_index (4) + face_flags (4) + style_flags (4) + num_glyphs (4) = 20

    family_name (8) = 28 → выравнивание до 32 → 28

    style_name (8) = 36

    num_fixed_sizes (4) = 40

    padding 4 → 48

    available_sizes (8) = 56

    num_charmaps (4) = 60

    padding 4 → 64

    charmaps (8) = 72

    generic (16) = 88

    bbox (32) = 120

    units_per_EM (2) = 122

    ascender (2) = 124

    descender (2) = 126

    height (2) = 128

    max_advance_width (2) = 130

    max_advance_height (2) = 132

    underline_position (2) = 134

    underline_thickness (2) = 136

    padding для выравнивания glyph (8) → 136 уже кратно 8

    glyph (8) = начинается с offset 136

Так что Offset glyph = 136. Если у тебя другой — структура определена неверно.
Собираем и запускаем под отладкой
bash

fpc -g -gl -Fu. -Fuwlgui demo_window.pas
gdb ./demo_window

Если снова падает в FT_Render_Glyph — покажи:

    Вывод [dbg] SizeOf(TFT_FaceRec)=... и Offset glyph in face = ...

    Значение SlotPtr в момент падения

    Локальные переменные в LoadGlyphFT (через gdb: frame 1, info locals)

Патчим и смотрим.
./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560
FT GGS error
An unhandled exception occurred at $000000000048248E:
EAccessViolation: Access violation
  $000000000048248E
  $0000000000483310
  $0000000000401AFE
  $000000000047F5A5
  $0000000000401E78

[font] file=(builtin 8x16) name=DejaVuSans height=32 valid=TRUE builtin=TRUE ascent=12 descent=4 units_per_EM=


Starting program: /tmp/demo_window
[Thread debugging using libthread_db enabled]
Using host libthread_db library "/usr/lib/x86_64-linux-gnu/libthread_db.so.1".
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560
FT GGS error

Program received signal SIGSEGV, Segmentation fault.
0x00000000004853fe in CREATE (this=0x7ffff7fac3a0, vmt=0x1, ANAME=0x4a4018 'DejaVuSans', AHEIGHT=32) at wlgui_font.pas:511
511             ' units_per_EM=', PFT_FaceRec(Face)^.units_per_EM);
(gdb) bt
#0  0x00000000004853fe in CREATE (this=0x7ffff7fac3a0, vmt=0x1, ANAME=0x4a4018 'DejaVuSans', AHEIGHT=32) at wlgui_font.pas:511
#1  0x0000000000486280 in LOAD (this=0x7ffff7f850e0, ANAME=0x4a4018 'DejaVuSans', AHEIGHT=32) at wlgui_font.pas:813
#2  0x0000000000401afe in ONPAINT (SENDER=0x7ffff7fa40e0) at demo_window.pas:78
#3  0x0000000000482515 in REPAINT (this=0x7ffff7fa40e0) at wlgui_window.pas:524
#4  0x0000000000401e78 in main () at demo_window.pas:122
Два бага: FT_Get_GlyphSlot не найден, и Face уже nil в диагностике
Баг 1: FT_Get_GlyphSlot не слинкован

В логе видно: FT GGS error. Это мой WriteLn из проверки — значит GetProcAddress не нашёл FT_Get_GlyphSlot. Проверим имя функции:

В FreeType API это FT_Get_GlyphSlot — да, оно правильное. Но! Возможно, ты не загрузил её в WLFontInit. Проверь, что в блоке загрузки функций есть:
pascal

Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');

Если её нет — добавь.
Баг 2: Face уже освобождён, но используется в WriteLn

В диагностике:
text

[font] file=(builtin 8x16) name=DejaVuSans height=32 valid=TRUE builtin=TRUE ascent=12 descent=4 units_per_EM=

Видишь: valid=TRUE builtin=TRUE — то есть мы откатились на встроенный шрифт, но при этом в WriteLn обратились к PFT_FaceRec(Face)^.units_per_EM, где Face — уже nil (или освобождённый). Отсюда SIGSEGV на строке диагностики, а не в реальной логике.

Это моя ошибка: я вставил диагностический WriteLn после блока if not FValid ... FIsBuiltin := True, где Face уже невалидный. Надо перенести диагностику до fallback.
Правильная последовательность
pascal

constructor TWLFont.Create(const AName: String; AHeight: Integer);
var
  Face: FT_Face;
  FaceRec: PFT_FaceRec;
begin
  inherited Create;
  FName := AName;
  FHeight := AHeight;
  FValid := False;
  FIsBuiltin := False;
  FCount := 0;
  FHashSize := HASH_BUCKETS;
  SetLength(FCodeBuckets, FHashSize);
  SetLength(FGlyphBuckets, FHashSize);
  FFace := nil;

  if AHeight <= 0 then
    raise Exception.CreateFmt('TWLFont: invalid height %d', [AHeight]);

  // 1. Пытаемся загрузить TTF
  if WLFontInit then
  begin
    WriteLn('[font] WLFontInit OK');
    if FindFontFile(AName, FFileName) then
    begin
      WriteLn('[font] file found: ', FFileName);
      if FT_New_Face(FTLib, PChar(FFileName), 0, Face) = 0 then
      begin
        WriteLn('[font] FT_New_Face OK, face=', PtrUInt(Face));
        if FT_Set_Pixel_Sizes(Face, 0, AHeight) = 0 then
        begin
          FaceRec := PFT_FaceRec(Face);
          WriteLn('[font] units_per_EM=', FaceRec^.units_per_EM,
                  ' ascender=', FaceRec^.ascender,
                  ' descender=', FaceRec^.descender);
          if FaceRec^.units_per_EM > 0 then
          begin
            FAscent := Round(FaceRec^.ascender * AHeight / FaceRec^.units_per_EM);
            FDescent := -Round(FaceRec^.descender * AHeight / FaceRec^.units_per_EM);
          end
          else
          begin
            FAscent := Abs(FaceRec^.ascender);
            FDescent := Abs(FaceRec^.descender);
          end;
          FLineSpacing := FAscent + FDescent + 2;
          FMaxAdvance := AHeight;
          FFace := Face;
          FValid := True;
          WriteLn('[font] loaded: ascent=', FAscent, ' descent=', FDescent);
        end
        else
        begin
          WriteLn('[font] FT_Set_Pixel_Sizes failed');
          FT_Done_Face(Face);
        end;
      end
      else
        WriteLn('[font] FT_New_Face failed for ', FFileName);
    end
    else
      WriteLn('[font] font file not found: ', AName);
  end
  else
    WriteLn('[font] WLFontInit FAILED');

  // 2. Fallback: встроенный ASCII 8×16
  if not FValid then
  begin
    FIsBuiltin := True;
    FValid := True;
    FAscent := 12;
    FDescent := 4;
    FLineSpacing := 16;
    FMaxAdvance := 8;
    FFileName := '(builtin 8x16)';
    WriteLn('[font] fallback to builtin for ', AName, ' ', AHeight);
  end;
end;

Обрати внимание: FFace := Face только при успехе. В случае fallback — FFace остаётся nil, и GetGlyph не должен пытаться читать FFace.
Баг 3 (главный): почему WLFontInit или FindFontFile не срабатывают

Смотрим лог:
text

FT GGS error
[font] file=(builtin 8x16) name=DejaVuSans height=32 valid=TRUE builtin=TRUE

«FT GGS error» — вывод из WLFontInit или LoadGlyphFT. Давай разберём:

    Если это из WLFontInit — значит FT_Get_GlyphSlot не загрузился, и WLFontInit вернул False. Тогда весь блок с TTF пропускается — и мы сразу попадаем в fallback (builtin). Это объясняет builtin=TRUE.

Значит: FT_Get_GlyphSlot не найден в библиотеке или не загружен в код.

Проверь в WLFontInit, есть ли:
pascal

Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');

if (Pointer(FT_Init_FreeType) = nil) or
   (Pointer(FT_New_Face) = nil) or
   (Pointer(FT_Get_GlyphSlot) = nil) then   // ← ДОЛЖНО БЫТЬ
begin
  WriteLn('FT GGS error');
  UnloadLibrary(FTLibHandle);
  FTLibHandle := 0;
  Exit;
end;

Если ты добавил проверку, но не добавил саму загрузку — будет именно так. Проверь, что обе строки на месте:
pascal

Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');

Что делать сейчас

    Добавь загрузку FT_Get_GlyphSlot в WLFontInit.

    Убери диагностику из fallback-ветки или перенеси её до установки FIsBuiltin := True.

    Проверь, что FFace := Face только при успехе — иначе GetGlyph упадёт при FFace = nil.

Быстрая проверка: есть ли FT_Get_GlyphSlot в системе
bash

nm -D /usr/lib/x86_64-linux-gnu/libfreetype.so.6 | grep FT_Get_GlyphSlot

Должно вывести T FT_Get_GlyphSlot — значит символ есть. Если нет — используй другой путь получения slot.
Если FT_Get_GlyphSlot почему-то нет — обходной путь

Можно вообще не использовать FT_Get_GlyphSlot — зная смещение glyph в FT_FaceRec. Мы его вычислили: offset 136 (для 64-bit). Тогда:
pascal

function TWLFont.GetSlotPtr(AFace: FT_Face): FT_GlyphSlot;
begin
  // Смещение поля glyph в FT_FaceRec = 136 для 64-bit
  Result := PPointer(PByte(AFace) + 136)^;
end;

И использовать вместо FT_Get_GlyphSlot. Но это хрупко — если FreeType поменяет layout, всё сломается. Лучше — найти FT_Get_GlyphSlot.
Проверь ещё: точно ли WLFontInit вернул True

Добавь в WLFontInit в конце:
pascal

FTLoaded := True;
WriteLn('[font] FreeType initialized, lib=', PtrUInt(FTLib), ' handle=', FTLibHandle);
Result := True;

И в начале:
pascal

WriteLn('[font] WLFontInit called, handle=', FTLibHandle, ' loaded=', FTLoaded);

Тогда точно увидим, что происходит.
Ожидаемый результат после исправлений
text

[font] WLFontInit called, handle=0 loaded=False
[font] FreeType initialized, lib=140xxx handle=1234
[font] file found: /usr/share/fonts/truetype/dejavu/DejaVuSans.ttf
[font] FT_New_Face OK, face=140xxx
[font] units_per_EM=2048 ascender=1901 descender=-483
[font] loaded: ascent=30 descent=7

Если увидим units_per_EM=2048 — TFT_FaceRec определена правильно. Если там мусор (типа 0 или 65535) — структура всё ещё неверная, будем отлаживать.

Пришли лог после патча.
Функция сейчас такая: function WLFontInit: Boolean;
begin
  Result := False;
  if FTLoaded then Exit(True);

  FTLibHandle := LoadLibrary('libfreetype.so.6');
  if FTLibHandle = 0 then
    FTLibHandle := LoadLibrary('libfreetype.so');
  if FTLibHandle = 0 then
    Exit;

  Pointer(FT_Init_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Init_FreeType');
  Pointer(FT_Done_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Done_FreeType');
  Pointer(FT_New_Face)       := GetProcAddress(FTLibHandle, 'FT_New_Face');
  Pointer(FT_Done_Face)      := GetProcAddress(FTLibHandle, 'FT_Done_Face');
  Pointer(FT_Set_Pixel_Sizes):= GetProcAddress(FTLibHandle, 'FT_Set_Pixel_Sizes');
  Pointer(FT_Get_Char_Index) := GetProcAddress(FTLibHandle, 'FT_Get_Char_Index');
  Pointer(FT_Load_Glyph)     := GetProcAddress(FTLibHandle, 'FT_Load_Glyph');
  Pointer(FT_Render_Glyph)   := GetProcAddress(FTLibHandle, 'FT_Render_Glyph');
Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');
if Pointer(FT_Get_GlyphSlot) = nil then
begin
  // ...

WriteLn('FT GGS error');
  Exit;
end; 

  if (Pointer(FT_Init_FreeType) = nil) or (Pointer(FT_New_Face) = nil) then
  begin
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  if FT_Init_FreeType(FTLib) <> 0 then
  begin
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  FTLoaded := True;
  Result := True;
end; То есть Pointer(FT_Get_GlyphSlot) = nil.
Диагностика: FT_Get_GlyphSlot не найден в библиотеке

Значит, GetProcAddress не находит символ. Проверим факты.
Сначала — есть ли символ в системе
bash

nm -D /usr/lib/x86_64-linux-gnu/libfreetype.so.6 | grep -i glyphslot

Должна быть строка с FT_Get_GlyphSlot. Если её нет — возможно, имя другое или это не наша версия библиотеки.

Проверь ещё:
bash

ldd /tmp/demo_window | grep freetype

Посмотрим, к какой конкретно библиотеке линкуется — возможно, там несколько версий.
Вероятная причина: FT_Get_GlyphSlot — это макрос, не функция

Смотрим документацию FreeType. FT_Get_GlyphSlot — да, функция, но! В некоторых сборках FreeType она может быть недоступна (inlined в макросе, или отсутствовать в shared-библиотеке).

Обычно она есть. Но чтобы не зависеть от неё, давай сделаем так, как делают все — через прямой доступ к полю glyph в FT_FaceRec.

Мы уже определили правильную TFT_FaceRec со смещением glyph = 136. Проверим это на практике.
Правильный путь: обходной через FT_FaceRec.glyph

Не вызывай FT_Get_GlyphSlot вообще. Используй:
pascal

SlotPtr := PFT_FaceRec(FFace)^.glyph;

Поле glyph объявлено в TFT_FaceRec, смещение рассчитано правильно (мы проверяли — 136 байт на 64-bit).
Патч wlgui_font.pas

1. Убираем проверку FT_Get_GlyphSlot в WLFontInit:
pascal

function WLFontInit: Boolean;
begin
  Result := False;
  if FTLoaded then Exit(True);

  FTLibHandle := LoadLibrary('libfreetype.so.6');
  if FTLibHandle = 0 then
    FTLibHandle := LoadLibrary('libfreetype.so');
  if FTLibHandle = 0 then
    Exit;

  Pointer(FT_Init_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Init_FreeType');
  Pointer(FT_Done_FreeType)  := GetProcAddress(FTLibHandle, 'FT_Done_FreeType');
  Pointer(FT_New_Face)       := GetProcAddress(FTLibHandle, 'FT_New_Face');
  Pointer(FT_Done_Face)      := GetProcAddress(FTLibHandle, 'FT_Done_Face');
  Pointer(FT_Set_Pixel_Sizes):= GetProcAddress(FTLibHandle, 'FT_Set_Pixel_Sizes');
  Pointer(FT_Get_Char_Index) := GetProcAddress(FTLibHandle, 'FT_Get_Char_Index');
  Pointer(FT_Load_Glyph)     := GetProcAddress(FTLibHandle, 'FT_Load_Glyph');
  Pointer(FT_Render_Glyph)   := GetProcAddress(FTLibHandle, 'FT_Render_Glyph');
  // FT_Get_GlyphSlot не используем — поле glyph в FaceRec

  if (Pointer(FT_Init_FreeType) = nil) or
     (Pointer(FT_New_Face) = nil) or
     (Pointer(FT_Load_Glyph) = nil) or
     (Pointer(FT_Render_Glyph) = nil) then
  begin
    WriteLn('[font] missing FreeType functions');
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  if FT_Init_FreeType(FTLib) <> 0 then
  begin
    WriteLn('[font] FT_Init_FreeType failed');
    UnloadLibrary(FTLibHandle);
    FTLibHandle := 0;
    Exit;
  end;

  FTLoaded := True;
  WriteLn('[font] FreeType loaded OK');
  Result := True;
end;

2. Убираем объявление FT_Get_GlyphSlot из var-секции (или оставляем — но не используем).

3. Патч LoadGlyphFT — берём slot через PFT_FaceRec(FFace)^.glyph:
pascal

function TWLFont.LoadGlyphFT(C: LongWord): PWLGlyph;
var
  GlyphIdx: FT_UInt;
  SlotPtr: Pointer;
  Slot: PFT_GlyphSlotRec;
  Bmp: PFT_Bitmap;
  G: PWLGlyph;
  RowBytes, I: Integer;
  HorAdvance: FT_Pos;
  FaceRec: PFT_FaceRec;
begin
  Result := nil;
  if FFace = nil then Exit;

  GlyphIdx := FT_Get_Char_Index(FFace, C);
  if GlyphIdx = 0 then Exit;

  if FT_Load_Glyph(FFace, GlyphIdx, FT_LOAD_DEFAULT) <> 0 then Exit;

  // Получаем slot через поле glyph в FT_FaceRec
  FaceRec := PFT_FaceRec(FFace);
  SlotPtr := FaceRec^.glyph;
  if SlotPtr = nil then
  begin
    WriteLn('[font] slot is nil for char ', C);
    Exit;
  end;

  Slot := PFT_GlyphSlotRec(SlotPtr);

  if FT_Render_Glyph(SlotPtr, FT_RENDER_MODE_NORMAL) <> 0 then
  begin
    WriteLn('[font] FT_Render_Glyph failed for char ', C);
    Exit;
  end;

  Bmp := @Slot^.bitmap;

  New(G);
  G^.Code := C;
  G^.Width := Bmp^.width;
  G^.Height := Bmp^.rows;
  G^.Left := Slot^.bitmap_left;
  G^.Top := Slot^.bitmap_top;
  HorAdvance := Slot^.metrics.horiAdvance;
  G^.Advance := (HorAdvance + 32) shr 6;
  G^.Mask := nil;

  if (G^.Width > 0) and (G^.Height > 0) then
  begin
    RowBytes := G^.Width * G^.Height;
    GetMem(G^.Mask, RowBytes);
    for I := 0 to G^.Height - 1 do
      Move(Bmp^.buffer[I * Bmp^.pitch],
           G^.Mask[I * G^.Width],
           G^.Width);
  end;

  InsertGlyph(C, G);
  Result := G;
end;

4. Убираем диагностику units_per_EM из fallback-ветки конструктора — она вызывала краш. Перенесём в правильное место.
Патч конструктора TWLFont.Create — убрать диагностику из fallback

Найди блок:
pascal

  // 2. Fallback: встроенный ASCII 8×16
  if not FValid then
  begin
    FIsBuiltin := True;
    FValid := True;
    FAscent := 12;
    FDescent := 4;
    FLineSpacing := 16;
    FMaxAdvance := 8;
    FFileName := '(builtin 8x16)';
  end;

Убедись, что после этого блока нет обращений к Face, FaceRec или PFT_FaceRec(...). Если есть диагностика — убирай.

Диагностику [font] file=... units_per_EM=... перенеси внутрь if FValid-ветки TTF, перед закрытием блока, где Face ещё валиден:
pascal

      if FT_Set_Pixel_Sizes(Face, 0, AHeight) = 0 then
      begin
        FaceRec := PFT_FaceRec(Face);
        WriteLn('[font] file=', FFileName,
                ' units_per_EM=', FaceRec^.units_per_EM,
                ' ascender=', FaceRec^.ascender,
                ' descender=', FaceRec^.descender);
        // ... остальное
      end;

Что ожидаем после патча
text

[font] FreeType loaded OK
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf units_per_EM=2048 ascender=1901 descender=-483

Или если по какой-то причине не загрузится шрифт — увидим:
text

[font] file not found: DejaVuSans

И тогда сработает fallback на builtin (без краха).
Про nm — на всякий случай проверь
bash

nm -D /usr/lib/x86_64-linux-gnu/libfreetype.so.6 | grep -E 'FT_Get_(GlyphSlot|Char_Index|Kerning)'

Скорее всего выведет:
text

00000000000xxxxx T FT_Get_Char_Index
00000000000xxxxx T FT_Get_GlyphSlot

Если обе есть, а GetProcAddress не находит — возможно, проблема в том, что у нас в FPC dynlibs не инициализирована или LoadLibrary вернула не то. Но раз FT_Init_FreeType работает (по логу FT_Init_FreeType вызывается и возвращает 0), значит библиотека загружена и GetProcAddress работает. Странно.

Проверь: может, у тебя в коде остался комментарий // ... вместо реальной проверки и Exit происходит до LoadLibrary? В твоём фрагменте:
pascal

if Pointer(FT_Get_GlyphSlot) = nil then
begin
  // ...
  WriteLn('FT GGS error');
  Exit;      // ← здесь мы выходим, FTLibHandle остаётся != 0
end;

Найди: возможно, после Exit — FTLibHandle не сбрасывается в 0. Это может дать проблемы при повторных вызовах.

Но главное: GetProcAddress вернул nil. Это факт. Обходим без этой функции.

Пробуй патч — пришли лог.
nm -D /usr/lib/x86_64-linux-gnu/libfreetype.so.6 | grep -i glyphslot
00000000000237d0 T FT_GlyphSlot_AdjustWeight
00000000000239b0 T FT_GlyphSlot_Embolden
00000000000237c0 T FT_GlyphSlot_Oblique
000000000001ca30 T FT_GlyphSlot_Own_Bitmap
0000000000023740 T FT_GlyphSlot_Slant
Ага, вот в чём дело — FT_Get_GlyphSlot в 2.13+ удалён!

Ты используешь FreeType 2.13.x, где FT_Get_GlyphSlot был удалён из публичного API (точнее, это всегда был макрос, но в старых версиях он был и как функция). Правильный путь — читать поле glyph напрямую из FT_FaceRec.
Патч wlgui_font.pas — убираем FT_Get_GlyphSlot
1. Убираем объявление из var-секции

Найди:
pascal

var
  FT_Init_FreeType: function(var alibrary: FT_Library): FT_Error; cdecl = nil;
  FT_Done_FreeType: function(alibrary: FT_Library): FT_Error; cdecl = nil;
  FT_New_Face: function(alibrary: FT_Library; filepathname: PChar;
                        face_index: FT_Long; var aface: FT_Face): FT_Error; cdecl = nil;
  FT_Done_Face: function(face: FT_Face): FT_Error; cdecl = nil;
  FT_Set_Pixel_Sizes: function(face: FT_Face; pixel_width: FT_UInt;
                               pixel_height: FT_UInt): FT_Error; cdecl = nil;
  FT_Get_Char_Index: function(face: FT_Face; charcode: FT_ULong): FT_UInt; cdecl = nil;
  FT_Load_Glyph: function(face: FT_Face; glyph_index: FT_UInt;
                          load_flags: FT_Int): FT_Error; cdecl = nil;
  FT_Render_Glyph: function(slot: FT_GlyphSlot;
                            render_mode: cuint): FT_Error; cdecl = nil;
  FT_Get_GlyphSlot: function(face: FT_Face; var slot: FT_GlyphSlot): FT_Error; cdecl = nil;

Удали строку с FT_Get_GlyphSlot.
2. Убираем загрузку и проверку

В WLFontInit удали:
pascal

Pointer(FT_Get_GlyphSlot) := GetProcAddress(FTLibHandle, 'FT_Get_GlyphSlot');
if Pointer(FT_Get_GlyphSlot) = nil then
begin
  WriteLn('FT GGS error');
  Exit;
end;

3. Патч LoadGlyphFT — читаем slot из FT_FaceRec.glyph
pascal

function TWLFont.LoadGlyphFT(C: LongWord): PWLGlyph;
var
  GlyphIdx: FT_UInt;
  SlotPtr: Pointer;
  Slot: PFT_GlyphSlotRec;
  FaceRec: PFT_FaceRec;
  Bmp: PFT_Bitmap;
  G: PWLGlyph;
  RowBytes, I: Integer;
  HorAdvance: FT_Pos;
begin
  Result := nil;
  if FFace = nil then Exit;

  GlyphIdx := FT_Get_Char_Index(FFace, C);
  if GlyphIdx = 0 then Exit;

  if FT_Load_Glyph(FFace, GlyphIdx, FT_LOAD_DEFAULT) <> 0 then Exit;

  // Получаем slot через поле glyph в FT_FaceRec
  FaceRec := PFT_FaceRec(FFace);
  SlotPtr := FaceRec^.glyph;
  if SlotPtr = nil then
  begin
    WriteLn('[font] slot is nil for char ', C);
    Exit;
  end;

  Slot := PFT_GlyphSlotRec(SlotPtr);

  if FT_Render_Glyph(SlotPtr, FT_RENDER_MODE_NORMAL) <> 0 then
  begin
    WriteLn('[font] FT_Render_Glyph failed for char ', C);
    Exit;
  end;

  Bmp := @Slot^.bitmap;

  New(G);
  G^.Code := C;
  G^.Width := Bmp^.width;
  G^.Height := Bmp^.rows;
  G^.Left := Slot^.bitmap_left;
  G^.Top := Slot^.bitmap_top;
  HorAdvance := Slot^.metrics.horiAdvance;
  G^.Advance := (HorAdvance + 32) shr 6;
  G^.Mask := nil;

  if (G^.Width > 0) and (G^.Height > 0) then
  begin
    RowBytes := G^.Width * G^.Height;
    GetMem(G^.Mask, RowBytes);
    for I := 0 to G^.Height - 1 do
      Move(Bmp^.buffer[I * Bmp^.pitch],
           G^.Mask[I * G^.Width],
           G^.Width);
  end;

  InsertGlyph(C, G);
  Result := G;
end;

Проверка смещения glyph в TFT_FaceRec

Мы вычислили offset = 136 для 64-bit. Давай проверим на реальной структуре, добавив в конструктор TWLFont.Create (внутри успешной ветки TTF):
pascal

WriteLn('[font] sizeof(FT_FaceRec)=', SizeOf(TFT_FaceRec),
        ' offset(glyph)=', Integer(@PFT_FaceRec(nil)^.glyph),
        ' offset(units_per_EM)=', Integer(@PFT_FaceRec(nil)^.units_per_EM),
        ' offset(ascender)=', Integer(@PFT_FaceRec(nil)^.ascender));

Ожидаем (64-bit Linux, FPC):

    offset(units_per_EM) = 120

    offset(ascender) = 122

    offset(glyph) = 136

Если увидишь другие числа — значит структура определена неверно, и мы будем править дальше.
Если offset(glyph) не совпадает — вот эталонная раскладка

Для FT_FaceRec в FreeType 2.13 на 64-bit Linux:
Поле	Размер	Offset
num_faces (Long=4)	4	0
face_index	4	4
face_flags	4	8
style_flags	4	12
num_glyphs	4	16
(padding)	4	20
family_name (ptr)	8	24
style_name (ptr)	8	32
num_fixed_sizes (Int=4)	4	40
(padding)	4	44
available_sizes (ptr)	8	48
num_charmaps (Int=4)	4	56
(padding)	4	60
charmaps (ptr)	8	64
generic (16)	16	72
bbox (4×Long=32)	32	88
units_per_EM (UShort=2)	2	120
ascender (Short=2)	2	122
descender	2	124
height	2	126
max_advance_width	2	128
max_advance_height	2	130
underline_position	2	132
underline_thickness	2	134
glyph (ptr)	8	136

Значит наш TFT_FaceRec правильный, если мы не забыли ни одного поля. Проверим наше объявление:
pascal

  PFT_FaceRec = ^TFT_FaceRec;
  TFT_FaceRec = record
    num_faces: FT_Long;          // 4   @ 0
    face_index: FT_Long;         // 4   @ 4
    face_flags: FT_Long;         // 4   @ 8
    style_flags: FT_Long;        // 4   @ 12
    num_glyphs: FT_Long;         // 4   @ 16
    family_name: PChar;          // 8   @ 24 (после padding)
    style_name: PChar;           // 8   @ 32
    num_fixed_sizes: FT_Int;     // 4   @ 40
    available_sizes: Pointer;    // 8   @ 48 (после padding)
    num_charmaps: FT_Int;        // 4   @ 56
    charmaps: Pointer;           // 8   @ 64 (после padding)
    generic: TFT_Generic;        // 16  @ 72
    bbox: TFT_BBox;              // 32  @ 88
    units_per_EM: cushort;       // 2   @ 120
    ascender: cshort;            // 2   @ 122
    descender: cshort;           // 2   @ 124
    height: cshort;              // 2   @ 126
    max_advance_width: cshort;   // 2   @ 128
    max_advance_height: cshort;  // 2   @ 130
    underline_position: cshort;  // 2   @ 132
    underline_thickness: cshort; // 2   @ 134
    glyph: Pointer;              // 8   @ 136
  end;

Совпадает. Всё правильно.

Но! Одна тонкость: в C FT_Long на 64-bit Linux = long = 8 байт, а не 4. Проверим:
c

typedef signed long  FT_Long;

long на Linux x86_64 = 8 байт. Значит:
Поле	Размер	Offset
num_faces (Long=8)	8	0
face_index (Long=8)	8	8
face_flags (Long=8)	8	16
style_flags (Long=8)	8	24
num_glyphs (Long=8)	8	32
family_name (ptr=8)	8	40
style_name (ptr=8)	8	48
num_fixed_sizes (Int=4)	4	56
(padding)	4	60
available_sizes (ptr=8)	8	64
num_charmaps (Int=4)	4	72
(padding)	4	76
charmaps (ptr=8)	8	80
generic (16)	16	88
bbox (4×8)	32	104
units_per_EM (2)	2	136
ascender (2)	2	138
descender (2)	2	140
height (2)	2	142
max_advance_width (2)	2	144
max_advance_height (2)	2	146
underline_position (2)	2	148
underline_thickness (2)	2	150
(padding)	6	152
glyph (ptr=8)	8	152

Вот в чём проблема! Мы определили FT_Long как clong. А в FPC clong = 4 байта на Linux x86_64 (в отличие от C, где long = 8 байт).

В FPC:

    LongInt = 4 байта

    clong = 4 байта (FPC's ctypes.pas определяет clong как LongInt)

    Int64 = 8 байт

А в C:

    long = 8 байт на Linux x86_64

    int = 4 байта

Значит наше определение FT_Long = clong = 4 байта — неправильно! Должно быть 8 байт, то есть Int64.
Правильное определение типов
pascal

type
  FT_Long   = Int64;    // C: long, 8 байт на 64-bit
  FT_Int    = LongInt;  // C: int, 4 байта
  FT_Pos    = Int64;    // C: long, 8 байт (FT_Pos = signed long)
  FT_Fixed  = Int64;    // C: signed long, 8 байт (FT_Fixed = signed long)
  FT_ULong  = QWord;    // C: unsigned long, 8 байт
  FT_UInt   = LongWord; // C: unsigned int, 4 байта

Патч типов в wlgui_font.pas

Заменяем блок type:
pascal

type
  FT_Error = cint;
  FT_Library = Pointer;
  FT_Face = Pointer;
  FT_Size = Pointer;
  FT_GlyphSlot = Pointer;
  FT_UInt = LongWord;      // C: unsigned int
  FT_ULong = QWord;        // C: unsigned long (8 байт!)
  FT_Int = LongInt;        // C: int
  FT_Pos = Int64;          // C: long (8 байт!)
  FT_Fixed = Int64;        // C: long (8 байт!)
  FT_Long = Int64;         // C: long (8 байт!)

  PFT_Vector = ^TFT_Vector;
  TFT_Vector = record
    x: FT_Pos;
    y: FT_Pos;
  end;

Остальное не меняется.
Проверка после патча

Собери и запусти. Ожидаем лог:
text

[font] FreeType loaded OK
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf units_per_EM=2048 ascender=1901 descender=-483
[font] loaded: ascent=30 descent=7

Если увидишь units_per_EM=2048 и ascender=1901 — структура правильная, и glyph тоже попадает куда надо.

Если units_per_EM=0 или мусорное значение — будем дальше смотреть смещения.
Диагностика на случай, если снова не сработает

Добавь в конструктор после FaceRec := PFT_FaceRec(Face);:
pascal

WriteLn('[dbg] sizeof(FT_Long)=', SizeOf(FT_Long));
WriteLn('[dbg] sizeof(TFT_FaceRec)=', SizeOf(TFT_FaceRec));
WriteLn('[dbg] offset(glyph)=', Integer(@PFT_FaceRec(nil)^.glyph));
WriteLn('[dbg] offset(units_per_EM)=', Integer(@PFT_FaceRec(nil)^.units_per_EM));

Ожидаем (FPC 3.2.2, 64-bit Linux):

    sizeof(FT_Long)=8

    sizeof(TFT_FaceRec)=160 (выравнивание)

    offset(glyph)=152

    offset(units_per_EM)=136

Если offset(glyph) — 152, всё правильно.
Резюме

Причина падения: FT_Long = clong в FPC = 4 байта, а в C = 8 байт на 64-bit. Все offset'ы после num_faces сдвинуты на 5×4 = 20 байт. glyph читался с неправильного адреса, FT_Render_Glyph получал мусор.

Решение: FT_Long = Int64, FT_Pos = Int64, FT_Fixed = Int64, FT_ULong = QWord. После этого offset'ы совпадут с C.

Плюс: FT_Get_GlyphSlot в FreeType 2.13+ действительно нет как символа (был удалён). Мы и не будем его использовать — читаем FaceRec.glyph напрямую.

Пробуй.
Заработало! Спасибо! ./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560
[font] sizeof(FT_FaceRec)=160 offset(glyph)=152 offset(units_per_EM)=136 offset(ascender)=138
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf name=DejaVuSans height=32 valid=TRUE builtin=FALSE ascent=30 descent=8 units_per_EM=2
[font] sizeof(FT_FaceRec)=160 offset(glyph)=152 offset(units_per_EM)=136 offset(ascender)=138
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf name=DejaVuSans height=16 valid=TRUE builtin=FALSE ascent=15 descent=4 units_per_EM=2
[demo] entering loop. Ctrl+C to exit.
^C
🎉 Текст заработал, но есть баг с юникодом

Смотрю на картинку:
Строка	Состояние
ASCII (Hello, world! 0123456789)	✅ Идеально
Ширина "Hello": 40 px	✅ Отлично, кириллица работает
Привет, Wayland!	❌ Кракозябры
Русский текст: Ёжик в тумане	❌ Кракозябры
wlgui — текст через FreeType	❌ Кракозябры

Причём "Ширина" и "px" в ASCII-строке работают — значит FreeType, шрифт, отрисовка, метрики — всё в порядке.
Причина: исходники в UTF-8, а FPC воспринимает их как Latin-1

demo_window.pas сохранён в UTF-8, но {$mode objfpc} без {$codepage utf8} — компилятор считает строковые литералы не в UTF-8, а в кодовой странице по умолчанию (обычно Latin-1/CP1252). При передаче в UTF8ToU4 получается неправильная последовательность байт.

Обрати внимание: строки с явной кодировкой (ASCII) — работают, потому что ASCII одинаков в любой кодировке. Русские буквы в UTF-8 = 2 байта, и они интерпретируются компилятором как 2 отдельных символа Latin-1.
Решение: добавить {$codepage utf8} в demo_window.pas

Первая строка после program:
pascal

program demo_window;
{$mode objfpc}{$H+}
{$codepage utf8}

{$codepage utf8} говорит FPC: «строковые литералы в этом модуле — в UTF-8». Тогда 'Привет, Wayland!' будет правильной UTF-8-строкой, UTF8ToU4 вернёт корректные codepoints, и FreeType отрисует их правильно.
Проверка: то же правило для всех модулей с русскими литералами

Если в wlgui_font.pas есть строки с русскими буквами — добавь {$codepage utf8} и туда. Сейчас там только ASCII и пути — не критично, но на будущее полезно.
units_per_EM=2 — почему?

В логе видно:
text

[font] units_per_EM=2

Это неверно — у DejaVuSans должно быть units_per_EM=2048. Но при этом ascent=30 descent=8 — правильные! Как?

Смотрим наш код:
pascal

if FaceRec^.units_per_EM > 0 then
begin
  FAscent := Round(FaceRec^.ascender * AHeight / FaceRec^.units_per_EM);
  FDescent := -Round(FaceRec^.descender * AHeight / FaceRec^.units_per_EM);
end
else
...

Мы передаём units_per_EM как cushort (2 байта). Если правильное значение = 2048 = $0800, то в little-endian памяти это байты 00 08. Как cushort — $0800 = 2048. Но в логе 2!

Причём ascent=30 — правильное. Значит логика прошла по правильному пути, но WriteLn показывает 2.

Смотрим формат вывода:
pascal

WriteLn('[font] ... units_per_EM=', FaceRec^.units_per_EM);

Хм, WriteLn для cushort (Word). Если значение $0800, должно быть 2048. Но показывает 2.

Возможно, ты передаёшь не FaceRec^.units_per_EM, а что-то другое. Или диагностический WriteLn остался от старой версии, где читался не тот offset.

Смотрим внимательнее: ascent=30 при AHeight=32. Если бы units_per_EM был 2, то FAscent = 1901 * 32 / 2 = 30416 — совершенно нереальное число. Значит units_per_EM в момент расчёта был 2048, а WriteLn показывает что-то другое.

Догадка: у тебя в диагностике не FaceRec^.units_per_EM, а FaceRec^.units_per_EM после чего-то, что его портит. Или порядок WriteLn — до вызова FT_Set_Pixel_Sizes? Нет, лог показывает, что поле прочитано.

Или проблема в том, что после смены определения FT_Long = Int64 мы забыли поменять что-то ещё, и компилятор теперь читает не те поля.

Смотрим наш TFT_FaceRec:
pascal

    units_per_EM: cushort;       // 2   @ 136
    ascender: cshort;            // 2   @ 138
    descender: cshort;           // 2   @ 140

offset(units_per_EM)=136 — правильно.
offset(ascender)=138 — правильно.

Если units_per_EM=2 — либо там реально 2, либо мы читаем не туда.

Стоп, вот в чём дело:
text

[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf name=DejaVuSans height=32 valid=TRUE builtin=FALSE ascent=30 descent=8 units_per_EM=2

ascent=30 — в нашем конструкторе FAscent := Round(FaceRec^.ascender * AHeight / FaceRec^.units_per_EM). Если ascender=1901, AHeight=32, units_per_EM=2048:

1901 * 32 / 2048 = 29.7 → Round = 30. ✅

Значит units_per_EM в момент расчёта был 2048! А WriteLn показывает 2.

Единственное объяснение: WriteLn вызывается ПОСЛЕ чего-то, что портит FaceRec^.units_per_EM. Или ты используешь отдельный WriteLn где читаешь поле ещё раз и оно уже испорчено.

Возможно, у тебя WriteLn дублируется для отладки и он попадает после FT_Set_Pixel_Sizes, где структура Face уже другая? Или FaceRec — это указатель на копию, которая уже освобождена?

Скорее всего — это не баг, а неправильный порядок в твоём диагностическом коде. Функционально всё работает (метрики правильные), просто WriteLn врёт.

Проверь: где именно у тебя WriteLn с units_per_EM? Он должен быть сразу после FaceRec := PFT_FaceRec(Face), до любых манипуляций.
Что делать

    Добавь {$codepage utf8} в demo_window.pas (и в другие модули, где русские строки).

    Проверь порядок WriteLn с units_per_EM — если он после FT_Set_Pixel_Sizes, перенеси до.

    Убери диагностические WriteLn из финальной версии wlgui_font.pas — они шумят.

Ожидаемая картинка после фикса кодировки

    Привет, Wayland! — кириллица 32pt, белым

    Hello, world! 0123456789 — ASCII 16pt, жёлтым

    Русский текст: Ёжик в тумане — кириллица 16pt, серым

    Ширина "Hello": 40 px — ASCII 16pt, циан

    wlgui — текст через FreeType — по центру, кириллица 16pt, белым

Всё читаемо и правильно.
Заодно проверь — как выглядит em dash (—)

В строке wlgui — текст через FreeType символ — (U+2014) — 3 байта в UTF-8. Если кодировка неверная, получишь кракозябры. После {$codepage utf8} — будет правильно.
После фикса — проверим units_per_EM для очистки совести

Если хочешь убедиться, что структура правильная, добавь на одну итерацию такой тест:
pascal

FaceRec := PFT_FaceRec(Face);
WriteLn('[dbg] units_per_EM=', FaceRec^.units_per_EM,
        ' ascender=', FaceRec^.ascender,
        ' descender=', FaceRec^.descender,
        ' height=', FaceRec^.height,
        ' glyph=', PtrUInt(FaceRec^.glyph));

Вызови до FT_Set_Pixel_Sizes. Ожидаем:
text

[dbg] units_per_EM=2048 ascender=1901 descender=-483 height=2384 glyph=140xxx

Если так — всё правильно, дело было только в кодировке.

Патчим и смотрим на картинку.
Спасибо! Внёс два изменения и: ./demo_window
wlgui demo starting...
[wlgui] Wayland initialized
[wlgui] window created: "wlgui demo — moving red square" 640x480
[wlgui] 2 buffers created: 640x480 stride=2560
[font] sizeof(FT_FaceRec)=160 offset(glyph)=152 offset(units_per_EM)=136 offset(ascender)=138
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf name=DejaVuSans height=32 valid=TRUE builtin=FALSE ascent=30 descent=8 units_per_EM=2048
[font] sizeof(FT_FaceRec)=160 offset(glyph)=152 offset(units_per_EM)=136 offset(ascender)=138
[font] file=/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf name=DejaVuSans height=16 valid=TRUE builtin=FALSE ascent=15 descent=4 units_per_EM=2048
[demo] entering loop. Ctrl+C to exit.
^C
🎉 Идеально — текст полностью работает!

Смотрю на картинку — всё как надо:

    Привет, Wayland! — крупная кириллица с DejaVuSans 32pt, белым, anti-aliasing чистый ✅

    Hello, world! 0123456789 — ASCII 16pt, жёлтым ✅

    Русский текст: Ёжик в тумане — кириллица 16pt, серым ✅

    Ширина "Hello": 40 px — метрики и подстановка значений ✅

    wlgui — текст через FreeType — центрированный заголовок вверху, em dash — тоже корректно ✅

    Метрики: units_per_EM=2048, ascent=30/15, descent=8/4 — всё правильно ✅

Этап 3 (шрифты) полностью завершён.
Итог: что у нас есть к этому моменту
text

wlgui_types.pas     — TWLColor ($00RRGGBB), TRectI, TPointI, TWLNotifyEvent
wlgui_context.pas   — TWLContext (display, compositor, shm, wm_base, seat) + DispatchWithTimeout
wlgui_app.pas       — TWLApplication (инициализация, event loop)
wlgui_window.pas    — TWLWindow (двойная буферизация + wl_buffer.release)
wlgui_canvas.pas    — TWLCanvas (примитивы + текст через wlgui_font)
wlgui_font.pas      — TWLFont + TWLFontManager (FreeType + встроенный fallback)

Возможности:

    ✅ Окна с двойной буферизацией

    ✅ Все графические примитивы (линии, прямоугольники, эллипсы, скругления, clip)

    ✅ Текст через FreeType (anti-aliased, любые Unicode, кириллица)

    ✅ Fallback на встроенный 8×16, если нет TTF

    ✅ Правильные метрики шрифта (ascent/descent/line spacing)

    ✅ Стабильный event loop с wl_display_prepare_read + poll

Что дальше — этап 4: ввод (wlgui_events.pas)

Теперь, когда картинка есть, нужно научиться реагировать на действия пользователя:
Что будем делать

    wl_seat listener — получить capabilities, создать wl_pointer и wl_keyboard.

    Мышь:

        wl_pointer.motion — движение, координаты surface_x/y

        wl_pointer.button — нажатия (BTN_LEFT=272, BTN_RIGHT=273, BTN_MIDDLE=274)

        wl_pointer.axis — колесо (прокрутка)

        wl_pointer.enter/leave — вход/выход из окна

        wl_pointer.frame — граница пакета событий (важно для группировки)

    Клавиатура:

        wl_keyboard.keymap — раскладка (формат XKB — сложно; для начала просто проигнорируем)

        wl_keyboard.key — нажатие/отпускание. Keycode здесь — X11-скан-код + 8. Маппинг на символы — через XKB или свою таблицу.

        wl_keyboard.modifiers — Shift/Ctrl/Alt/Caps/Num

    Очередь событий — TWLQueue<TWLEvent> (без дженериков — массив + индекс) или простой список с callback'ами.

    Курсор — wl_pointer.set_cursor с собственной wl_surface (стрелка, i-beam, hand и т.д.). Или без курсора на первом шаге — системный по умолчанию.

    API окон — OnMouseDown, OnMouseMove, OnMouseUp, OnMouseWheel, OnKeyDown, OnKeyUp, OnMouseEnter, OnMouseLeave.

Ключевые вопросы

1. XKB для клавиатуры — подключать libxkbcommon?

    A: Да, через dynlibs (как FreeType). Даёт полный маппинг keycode → UTF-8 символ с учётом раскладки. ~30 строк кода на загрузку.

    B: Нет, своя таблица Linux keycode → ASCII. Быстро, но не работает для русской раскладки, модификаторов и т.д.

    C: Гибрид — пробуем XKB, если не нашли, откатываемся на ASCII-таблицу.

Я за A (или C как fallback). Без XKB нельзя нормально вводить русский текст, а нам для органайзера это критично (пользователь вводит сообщение будильника).

2. Курсор — рисуем сами или системный?

    A: Системный — композитор даёт курсор по умолчанию, пока мы не вызовем set_cursor. Минус: внутри окна курсор «стрелка» даже над полем ввода.

    B: Свой — загружаем из темы Xcursor или рисуем встроенные. Правильно, но работы прилично.

    C: Сначала A, потом B — не отвлекаемся, потом добавим set_cursor с парой базовых форм.

Я за C.

3. Событийная модель — callback'и или очередь?

    A: Callback'и — W.OnMouseDown := @Handler. Просто, но неудобно, если надо несколько слушателей.

    B: Очередь — while EventQueue.Pop(E) do .... Классика GUI.

    C: Оба — очередь низкоуровневая, callback'и — надстройка.

Я за A для начала — проще, у нас всё равно одно окно в фокусе (то, над которым мышь).

4. Модификаторы клавиатуры — как отслеживать?

Wayland сам присылает wl_keyboard.modifiers с полями:

    mods_depressed — нажатые сейчас

    mods_latched — «залипшие» (CapsLock)

    mods_locked — блокирующие (NumLock)

Реальный маппинг битов → имена (Shift/Ctrl/Alt) даёт XKB state. Без XKB — только эвристика.

5. Что делать с keycode?

Linux/Wayland дают X11-совместимый скан-код + 8 (evdev). Для XKB нужно вычесть 8. Например, ESC = 1 (evdev) = 9 (wayland). Это важно.
Предлагаемая структура wlgui_events.pas
pascal

unit wlgui_events;

type
  TWLKeyEvent = record
    KeySym: LongWord;      // XKB keysym (или ASCII-код для fallback)
    Codepoint: LongWord;   // UTF-8 codepoint символа (с учётом shift/caps)
    Scancode: LongWord;    // evdev scancode
    Modifiers: LongWord;   // bitmask
    Pressed: Boolean;
    Time: LongWord;
  end;

  TWLModifiers = record
    Shift, Ctrl, Alt, Super: Boolean;
    CapsLock, NumLock: Boolean;
  end;

  TWLMouseEvent = record
    X, Y: Integer;         // координаты в окне
    Button: Integer;       // 1=left, 2=right, 3=middle
    Pressed: Boolean;
    Modifiers: TWLModifiers;
  end;

  TWLWheelEvent = record
    X, Y: Integer;
    DeltaX, DeltaY: Integer;
  end;

  // Расширяем TWLWindow
  TWLWindow = class
    ...
    OnMouseDown: procedure(Sender: TObject; const E: TWLMouseEvent) of object;
    OnMouseUp: ...
    OnMouseMove: ...
    OnMouseWheel: ...
    OnMouseEnter: TNotifyEvent;
    OnMouseLeave: TNotifyEvent;
    OnKeyDown: procedure(Sender: TObject; const E: TWLKeyEvent) of object;
    OnKeyUp: ...
  end;

И TWLContext получает поле EventManager: TWLEventManager, который:

    Слушает wl_seat → pointer/keyboard

    Хранит FocusedWindow: TWLWindow (куда шлём события)

    Пересылает события в окно

Что делать сейчас

Проверь ответы на 5 вопросов выше — и я начну писать wlgui_events.pas. Мой вариант по умолчанию:

    XKB через dynlibs — да.

    Курсор — сначала системный, свой позже.

    Callback'и — да, без очереди.

    Модификаторы — через XKB state.

    Keycode — вычитаем 8, потом в XKB.

Если согласен — говори, приступаю.