|
- unit uMainForm;
-
- {$mode objfpc}{$H+}
-
- {$IFDEF LINUX}
- {$DEFINE USE_FREETYPE}
- {$ENDIF}
-
- interface
-
- uses
- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
- ulibTextSuite, dglOpenGL
- {$IF DEFINED(WIN32) OR DEFINED(WIN64)}
- , Windows
- {$ELSEIF DEFINED(LINUX)}
- , LCLType, LMessages, XUtil, XLib, gdk2x, gtk2, gdk2, WSLCLClasses, X, glib2
- , Gtk2Def, Gtk2Int, InterfaceBase, WSControls
- {$ENDIF};
-
- type
- {$IF DEFINED(LINUX)}
- TRenderControl = class(TWinControl)
- private
- fIntWidget: PGtkWidget;
- fVisualID: TVisualID;
- fTarget: TWinControl;
- protected
- function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
- procedure WSBeforeDestroyHandle;
- procedure WndProc(var Message: TLMessage); override;
- public
- property Widget: PGtkWidget read FIntWidget;
- property Target: TWinControl read fTarget write fTarget;
- constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload;
- end;
-
- TWSCustomVisualControl = class(TWSWinControl)
- published
- class function CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle; override;
- class procedure DestroyHandle(const AWinControl: TWinControl); override;
- end;
- {$ENDIF}
-
- TMainForm = class(TForm)
- procedure FormCreate(Sender: TObject);
- procedure FormDestroy(Sender: TObject);
- procedure FormPaint(Sender: TObject);
- procedure FormResize(Sender: TObject);
-
- private
- fCanRender: Boolean;
- fHasRenderContext: Boolean;
-
- {$IF DEFINED(WIN32) OR DEFINED(WIN64)}
- fDC: HDC;
- fRC: HGLRC;
- procedure CreateRenderContext;
- procedure DestroyRenderContext;
- procedure SwapBuffers;
- {$ELSEIF DEFINED(LINUX)}
- fVisual: PXVisualInfo;
- fDisplay: PDisplay;
- fWidget: PGtkWidget;
- fContext: GLXContext;
- fRenderControl: TRenderControl;
- procedure CreateRenderContext;
- procedure DestroyRenderContext;
- procedure SwapBuffers;
- {$ENDIF}
-
- private
- fltsContext: TltsContext;
- fltsRenderer: TltsRendererOpenGL;
- fltsCreator: {$IFDEF USE_FREETYPE}TltsFontCreatorFreeType{$ELSE}TltsFontCreatorGDI{$ENDIF};
- fltsFont: TltsFont;
- fltsPostProcessorList: TltsPostProcessorList;
- procedure Render;
- end;
-
- var
- MainForm: TMainForm;
-
- implementation
-
- {$R *.lfm}
-
- const
- {$IF DEFINED(WIN32)}
- LibName = '..\..\..\libTextSuite-i386-win32.dll';
- {$ELSEIF DEFINED(WIN64)}
- LibName = '..\..\..\libTextSuite-x86_64-win64.dll';
- {$ELSEIF DEFINED(LINUX) AND DEFINED(CPU32)}
- LibName = '../../../libTextSuite-i386-linux.so';
- {$ELSEIF DEFINED(LINUX) AND DEFINED(CPU64)}
- LibName = '../../../libTextSuite-x86_64-linux.so';
- {$ELSE}
- {$ERROR 'unknown operation system'}
- {$IFEND}
-
- TEST_TEXT = 'Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.';
-
- PATTER_DATA: array[0..15] of Byte = (
- $FF, $BF, $7F, $BF,
- $BF, $FF, $BF, $7F,
- $7F, $BF, $FF, $BF,
- $BF, $7F, $BF, $FF);
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IFDEF LINUX}
- type
- TGLIntArray = packed array of GLInt;
-
- PGtkCustomWidget = ^TGtkCustomWidget;
- TGtkCustomWidget = record
- darea: TGtkDrawingArea;
- end;
-
- PGtkCustomWidgetClass = ^TGtkCustomWidgetClass;
- TGtkCustomWidgetClass = record
- parent_class: TGtkDrawingAreaClass;
- end;
-
- var
- custom_widget_type: TGtkType = 0;
- custom_widget_parent_class: Pointer = nil;
-
- function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure g_return_if_fail(b: boolean; const Msg: string);
- begin
- if not b then raise Exception.Create(Msg);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure g_return_if_fail(b: boolean);
- begin
- g_return_if_fail(b,'');
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean;
- begin
- GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget;
- begin
- g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),'');
- Result := PGtkCustomWidget(obj);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl;
- begin
- gtk_widget_set_double_buffered(PGtkWidget(custom_widget),gdkFALSE);
- GTK_WIDGET_UNSET_FLAGS(PGtkWidget(custom_widget),GTK_NO_WINDOW);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl;
- begin
- g_return_if_fail (obj <>nil,'');
- g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),'');
-
- if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then
- GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure gtk_custom_widget_class_init(klass: Pointer); cdecl;
- var
- object_class: PGtkObjectClass;
- begin
- custom_widget_parent_class := gtk_type_class(gtk_drawing_area_get_type());
- g_return_if_fail(custom_widget_parent_class<>nil,'gtk_custom_widget_class_init parent_class=nil');
- object_class := PGtkObjectClass(klass);
- g_return_if_fail(object_class<>nil,'gtk_custom_widget_class_init object_class=nil');
- object_class^.destroy := @gtk_custom_widget_destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function custom_widget_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation; Data: gPointer): GBoolean; cdecl;
- const
- CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF};
- var
- SizeMsg: TLMSize;
- GtkWidth, GtkHeight: integer;
- LCLControl: TWinControl;
- begin
- Result := CallBackDefaultReturn;
- if not GTK_WIDGET_REALIZED(Widget) then begin
- // the widget is not yet realized, so this GTK resize was not a user change.
- // => ignore
- exit;
- end;
- if Size=nil then ;
- LCLControl:=TWinControl(Data);
- if LCLControl=nil then exit;
- //DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]);
-
- gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);
-
- SizeMsg.Msg:=0;
- FillChar(SizeMsg,SizeOf(SizeMsg),0);
- with SizeMsg do
- begin
- Result := 0;
- Msg := LM_SIZE;
- SizeType := Size_SourceIsInterface;
- Width := SmallInt(GtkWidth);
- Height := SmallInt(GtkHeight);
- end;
- //DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]);
- LCLControl.WindowProc(TLMessage(SizeMsg));
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function GTK_TYPE_CUSTOM_WIDGET: TGtkType;
- const
- custom_widget_type_name = 'GtkGLArea';
- custom_widget_info: TGtkTypeInfo = (
- type_name: custom_widget_type_name;
- object_size: SizeOf(TGtkCustomWidget);
- class_size: SizeOf(TGtkCustomWidgetClass);
- class_init_func: @gtk_custom_widget_class_init;
- object_init_func: @gtk_custom_widget_init;
- reserved_1: nil;
- reserved_2: nil;
- base_class_init_func: nil;);
- begin
- if (custom_widget_type=0) then begin
- custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info);
- end;
- Result:=custom_widget_type;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function CreateOpenGLContextAttrList(UseFB: boolean; aDoubleBuffered: Boolean; aColorBits, aDepthBits: Integer): TGLIntArray;
- var
- p: integer;
-
- procedure Add(i: integer);
- begin
- SetLength(Result, p+1);
- Result[p]:=i;
- inc(p);
- end;
-
- procedure CreateList;
- begin
- if UseFB then begin Add(GLX_X_RENDERABLE); Add(1); end;
- if aDoubleBuffered then begin
- if UseFB then begin
- Add(GLX_DOUBLEBUFFER); Add(1);
- end else
- Add(GLX_DOUBLEBUFFER);
- end;
- if not UseFB and (aColorBits > 24) then Add(GLX_RGBA);
- if UseFB then begin
- Add(GLX_DRAWABLE_TYPE);
- Add(GLX_WINDOW_BIT);
- end;
- Add(GLX_RED_SIZE); Add(8);
- Add(GLX_GREEN_SIZE); Add(8);
- Add(GLX_BLUE_SIZE); Add(8);
- if (aColorBits > 24) then
- Add(GLX_ALPHA_SIZE); Add(8);
- Add(GLX_DEPTH_SIZE); Add(aDepthBits);
- Add(GLX_STENCIL_SIZE); Add(0);
- Add(GLX_AUX_BUFFERS); Add(0);
-
- Add(0); { 0 = X.None (be careful: GLX_NONE is something different) }
- end;
-
- begin
- SetLength(Result, 0);
- p := 0;
- CreateList;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function FBglXChooseVisual(dpy:PDisplay; screen:longint; attrib_list:Plongint):PXVisualInfo;
- type
- PGLXFBConfig = ^GLXFBConfig;
- var
- FBConfigsCount: integer;
- FBConfigs: PGLXFBConfig;
- FBConfig: GLXFBConfig;
- begin
- Result:= nil;
- FBConfigsCount:=0;
- FBConfigs:= glXChooseFBConfig(dpy, screen, attrib_list, @FBConfigsCount);
- if FBConfigsCount = 0 then
- exit;
-
- { just choose the first FB config from the FBConfigs list.
- More involved selection possible. }
- FBConfig := FBConfigs^;
- Result:=glXGetVisualFromFBConfig(dpy, FBConfig);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TRenderControl////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TRenderControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
- var
- cmap: PGdkColormap;
- gdkvis: PGdkVisual;
- begin
- // is the requested VisualID different from what the widget would get?
- cmap := gdk_colormap_get_system;
- gdkvis:= gdk_colormap_get_visual(cmap);
- if XVisualIDFromVisual(gdk_x11_visual_get_xvisual(gdkvis)) <> FVisualID then begin
- gdkvis := gdkx_visual_get(FVisualID);
- cmap := gdk_colormap_new(gdkvis, false);
- end;
-
- fIntWidget := gtk_type_new(GTK_TYPE_CUSTOM_WIDGET);
- gtk_widget_set_colormap(fIntWidget, cmap);
-
- Result := TLCLIntfHandle({%H-}PtrUInt(fIntWidget));
- PGtkobject(fIntWidget)^.flags:= PGtkobject(fIntWidget)^.flags or GTK_CAN_FOCUS;
- TGTK2WidgetSet(WidgetSet).FinishCreateHandle(Self,fIntWidget,AParams);
- g_signal_connect_after(fIntWidget, 'size-allocate', TGTKSignalFunc(@custom_widget_size_allocateCB), Self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TRenderControl.WSBeforeDestroyHandle;
- begin
- if not HandleAllocated then exit;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TRenderControl.WndProc(var Message: TLMessage);
- begin
- case Message.msg of
- //LM_ACTIVATEITEM,
- //LM_CHANGED,
- //LM_FOCUS,
- LM_CLICKED,
- //LM_RELEASED,
- LM_ENTER,
- LM_LEAVE,
- //LM_CHECKRESIZE,
- //LM_SETEDITABLE,
- //LM_MOVEWORD,
- //LM_MOVEPAGE,
- //LM_MOVETOROW,
- //LM_MOVETOCOLUMN,
- //LM_KILLCHAR,
- //LM_KILLWORD,
- //LM_KILLLINE,
- //LM_CLOSEQUERY,
- //LM_DRAGSTART,
- //LM_MONTHCHANGED,
- //LM_YEARCHANGED,
- //LM_DAYCHANGED,
- LM_LBUTTONTRIPLECLK,
- LM_LBUTTONQUADCLK,
- LM_MBUTTONTRIPLECLK,
- LM_MBUTTONQUADCLK,
- LM_RBUTTONTRIPLECLK,
- LM_RBUTTONQUADCLK,
- LM_MOUSEENTER,
- LM_MOUSELEAVE,
- LM_XBUTTONTRIPLECLK,
- LM_XBUTTONQUADCLK,
-
- //SC_SIZE,
- //SC_MOVE,
- //SC_MINIMIZE,
- //SC_MAXIMIZE,
- //SC_NEXTWINDOW,
- //SC_PREVWINDOW,
- //SC_CLOSE,
- SC_VSCROLL,
- SC_HSCROLL,
- SC_MOUSEMENU,
- SC_KEYMENU,
- //SC_ARRANGE,
- //SC_RESTORE,
- //SC_TASKLIST,
- //SC_SCREENSAVE,
- //SC_HOTKEY,
- //SC_DEFAULT,
- //SC_MONITORPOWER,
- //SC_CONTEXTHELP,
- //SC_SEPARATOR,
-
- //LM_MOVE,
- //LM_SIZE,
- LM_ACTIVATE,
- LM_SETFOCUS,
- LM_KILLFOCUS,
- //LM_ENABLE,
- //LM_GETTEXTLENGTH,
- //LM_SHOWWINDOW,
- //LM_CANCELMODE,
- //LM_DRAWITEM,
- //LM_MEASUREITEM,
- //LM_DELETEITEM,
- //LM_VKEYTOITEM,
- //LM_CHARTOITEM,
- //LM_COMPAREITEM,
- //LM_WINDOWPOSCHANGING,
- //LM_WINDOWPOSCHANGED,
- //LM_NOTIFY,
- //LM_HELP,
- //LM_NOTIFYFORMAT,
- //LM_CONTEXTMENU,
- //LM_NCCALCSIZE,
- //LM_NCHITTEST,
- //LM_NCPAINT,
- //LM_NCACTIVATE,
- //LM_GETDLGCODE,
- LM_NCMOUSEMOVE,
- LM_NCLBUTTONDOWN,
- LM_NCLBUTTONUP,
- LM_NCLBUTTONDBLCLK,
- LM_KEYDOWN,
- LM_KEYUP,
- LM_CHAR,
- LM_SYSKEYDOWN,
- LM_SYSKEYUP,
- LM_SYSCHAR,
- LM_COMMAND,
- LM_SYSCOMMAND,
- LM_TIMER,
- LM_HSCROLL,
- LM_VSCROLL,
- //LM_CTLCOLORMSGBOX,
- //LM_CTLCOLOREDIT,
- //LM_CTLCOLORLISTBOX,
- //LM_CTLCOLORBTN,
- //LM_CTLCOLORDLG,
- //LM_CTLCOLORSCROLLBAR,
- //LM_CTLCOLORSTATIC,
- LM_MOUSEMOVE,
- LM_LBUTTONDOWN,
- LM_LBUTTONUP,
- LM_LBUTTONDBLCLK,
- LM_RBUTTONDOWN,
- LM_RBUTTONUP,
- LM_RBUTTONDBLCLK,
- LM_MBUTTONDOWN,
- LM_MBUTTONUP,
- LM_MBUTTONDBLCLK,
- LM_MOUSEWHEEL,
- LM_XBUTTONDOWN,
- LM_XBUTTONUP,
- LM_XBUTTONDBLCLK,
- //LM_PARENTNOTIFY,
- //LM_CAPTURECHANGED,
- //LM_DROPFILES,
- //LM_SELCHANGE,
- LM_CUT,
- LM_COPY,
- LM_PASTE,
- //LM_CLEAR,
- //LM_CONFIGUREEVENT,
- //LM_EXIT,
- //LM_QUIT,
- //LM_NULL,
- //LM_PAINT,
- //LM_ERASEBKGND,
- //LM_SETCURSOR,
- //LM_SETFONT:
-
- //CM_ACTIVATE,
- //CM_DEACTIVATE,
- //CM_FOCUSCHANGED,
- //CM_PARENTFONTCHANGED,
- //CM_PARENTCOLORCHANGED,
- //CM_HITTEST,
- //CM_VISIBLECHANGED,
- //CM_ENABLEDCHANGED,
- //CM_COLORCHANGED,
- //CM_FONTCHANGED,
- //CM_CURSORCHANGED,
- //CM_TEXTCHANGED,
- CM_MOUSEENTER,
- CM_MOUSELEAVE,
- //CM_MENUCHANGED,
- //CM_APPSYSCOMMAND,
- //CM_BUTTONPRESSED,
- //CM_SHOWINGCHANGED,
- //CM_ENTER,
- //CM_EXIT,
- //CM_DESIGNHITTEST,
- //CM_ICONCHANGED,
- //CM_WANTSPECIALKEY,
- //CM_RELEASE,
- //CM_FONTCHANGE,
- //CM_TABSTOPCHANGED,
- //CM_UIACTIVATE,
- //CM_CONTROLLISTCHANGE,
- //CM_GETDATALINK,
- //CM_CHILDKEY,
- //CM_HINTSHOW,
- //CM_SYSFONTCHANGED,
- //CM_CONTROLCHANGE,
- //CM_CHANGED,
- //CM_BORDERCHANGED,
- //CM_BIDIMODECHANGED,
- //CM_PARENTBIDIMODECHANGED,
- //CM_ALLCHILDRENFLIPPED,
- //CM_ACTIONUPDATE,
- //CM_ACTIONEXECUTE,
- //CM_HINTSHOWPAUSE,
- //CM_DOCKNOTIFICATION,
- CM_MOUSEWHEEL,
- //CM_APPSHOWBTNGLYPHCHANGED,
- //CM_APPSHOWMENUGLYPHCHANGED,
-
- //CN_BASE,
- //CN_CHARTOITEM,
- //CN_COMMAND,
- //CN_COMPAREITEM,
- //CN_CTLCOLORBTN,
- //CN_CTLCOLORDLG,
- //CN_CTLCOLOREDIT,
- //CN_CTLCOLORLISTBOX,
- //CN_CTLCOLORMSGBOX,
- //CN_CTLCOLORSCROLLBAR,
- //CN_CTLCOLORSTATIC,
- //CN_DELETEITEM,
- //CN_DRAWITEM,
- CN_HSCROLL,
- //CN_MEASUREITEM,
- //CN_PARENTNOTIFY,
- //CN_VKEYTOITEM,
- CN_VSCROLL,
- CN_KEYDOWN,
- CN_KEYUP,
- CN_CHAR,
- CN_SYSKEYUP,
- CN_SYSKEYDOWN,
- CN_SYSCHAR,
- CN_NOTIFY:
- begin
- if Assigned(fTarget) then
- Message.Result := fTarget.Perform(Message.msg, Message.wParam, Message.lParam);
- end;
- end;
- inherited WndProc(Message);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TRenderControl.Create(TheOwner: TComponent; const aVisualID: TVisualID);
- begin
- inherited Create(TheOwner);
- fIntWidget := nil;
- fVisualID := aVisualID;
- SetBounds(0, 0, 200, 200);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TWSCustomVisualControl////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle;
- begin
- if csDesigning in AWinControl.ComponentState then begin
- // do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
- Result:= TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
- end else
- Result:= (AWinControl as TRenderControl).WSCreateHandle(WSPrivate, AParams);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl);
- begin
- (AWinControl as TRenderControl).WSBeforeDestroyHandle;
- // do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
- TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //MainForm//////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.FormCreate(Sender: TObject);
- var
- pp: TltsPostProcessor;
- img: TltsImage;
- begin
- CreateRenderContext;
- glDisable(GL_DEPTH_TEST);
- glDisable(GL_CULL_FACE);
- glClearColor(1.0, 1.0, 1.0, 1.0);
-
- ltsInitialize(LibName);
- Caption := 'libTextSuite example (Version: ' + ltsGetVersion() + ')';
-
- fltsContext := TltsContext.Create;
- fltsRenderer := TltsRendererOpenGL.Create(fltsContext, ltsFormatRGBA8);
- fltsCreator := {$IFDEF USE_FREETYPE}TltsFontCreatorFreeType{$ELSE}TltsFontCreatorGDI{$ENDIF}.Create(fltsContext);
-
- fltsPostProcessorList := TltsPostProcessorList.Create(fltsContext, true);
-
- img := TltsImage.Create(fltsContext);
- img.CreateEmpty(ltsFormatAlpha8, 4, 4);
- Move(PATTER_DATA[0], img.Data^, 16);
- pp := TltsPostProcessorFillPattern.Create(fltsContext, img, true, ltsPosition(0, 0), LTS_IMAGE_MODES_MODULATE_ALL, LTS_COLOR_CHANNELS_RGBA);
- pp.AddChars(ltsUsageInclude, 'Lorem');
- fltsPostProcessorList.Add(pp);
-
- pp := TltsPostProcessorFillColor.Create(fltsContext, ltsColor4f(0, 0, 0.5, 1), LTS_IMAGE_MODES_REPLACE_ALL, LTS_COLOR_CHANNELS_RGB);
- pp.AddChars(ltsUsageExclude, 'e');
- fltsPostProcessorList.Add(pp);
-
- pp := TltsPostProcessorBorder.Create(fltsContext, 3.0, 0.5, ltsColor4f(0.0, 0.5, 0.0, 1.0), true);
- pp.AddChars(ltsUsageInclude, 'e');
- fltsPostProcessorList.Add(pp);
-
- fltsFont := fltsCreator.GetFontByFile(ExpandFileName('../Prototype.ttf'), 40, [], ltsAANormal);
- fltsFont.PostProcessor := fltsPostProcessorList;
-
- fCanRender := true;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.FormDestroy(Sender: TObject);
- begin
- FreeAndNil(fltsFont);
- FreeAndNil(fltsPostProcessorList);
- FreeAndNil(fltsCreator);
- FreeAndNil(fltsRenderer);
- FreeAndNil(fltsContext);
- ltsFinalize;
- DestroyRenderContext;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.FormPaint(Sender: TObject);
- begin
- if fCanRender then
- Render;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.FormResize(Sender: TObject);
- begin
- if fHasRenderContext then begin
- glViewport(0, 0, ClientWidth, ClientHeight);
- glMatrixMode(GL_PROJECTION);
- glLoadIdentity;
- glOrtho(0, ClientWidth, ClientHeight, 0, 10, -10);
- glMatrixMode(GL_MODELVIEW);
- glLoadIdentity;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- {$IF DEFINED(WIN32) OR DEFINED(WIN64)}
- procedure TMainForm.CreateRenderContext;
-
- function FindPixelFormat: Integer;
- const
- MemoryDCs = [OBJ_MEMDC, OBJ_METADC, OBJ_ENHMETADC];
- var
- AType: DWord;
- PFDescriptor: TPixelFormatDescriptor;
- begin
- result := 0;
- FillChar(PFDescriptor{%H-}, SizeOf(PFDescriptor), #0);
- with PFDescriptor do begin
- nSize := SizeOf(PFDescriptor);
- nVersion := 1;
- dwFlags := PFD_SUPPORT_OPENGL;
- AType := GetObjectType(fDC);
- if AType = 0 then
- raise Exception.Create('unable to get device context object type');
- dwFlags := dwFlags or PFD_DOUBLEBUFFER;
- if AType in MemoryDCs then
- dwFlags := dwFlags or PFD_DRAW_TO_BITMAP
- else
- dwFlags := dwFlags or PFD_DRAW_TO_WINDOW;
-
- iPixelType := PFD_TYPE_RGBA;
- cColorBits := 32;
- cDepthBits := 24;
- cStencilBits := 0;
- cAccumBits := 0;
- cAuxBuffers := 0;
- iLayerType := PFD_MAIN_PLANE;
- end;
- result := ChoosePixelFormat(fDC, @PFDescriptor);
- end;
-
- var
- pf: Integer;
- err: DWORD;
- begin
- InitOpenGL;
-
- fDC := GetDC(Handle);
- if (fDC = 0) then
- raise Exception.Create('unable to get device context');
-
- pf := FindPixelFormat;
- if not SetPixelFormat(fDC, pf, nil) then begin
- ReleaseDC(Handle, fDC);
- raise Exception.CreateFmt('Cannot set PF %d on Control %x DC %d', [pf, Handle, FDC]);
- end;
-
- fRC := wglCreateContext(FDC);
- if (fRC = 0) then begin
- ReleaseDC(Handle, FDC);
- raise Exception.CreateFmt('Cannot create context on Control %x DC %d', [pf, Handle, FDC]);
- end;
-
- if not wglMakeCurrent(fDC, fRC) then begin
- err := GetLastError;
- raise Exception.Create('unable to activate context: (' + IntToStr(err) + ') ' + SysErrorMessage(err));
- end;
-
- ReadOpenGLCore;
- ReadExtensions;
- ReadImplementationProperties;
-
- fHasRenderContext := true;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.DestroyRenderContext;
- begin
- wglMakeCurrent(0, 0);
- DestroyRenderingContext(fRC);
- ReleaseDC(Handle, fDC);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.SwapBuffers;
- begin
- Windows.SwapBuffers(fDC);
- end;
-
- {$ELSEIF DEFINED(LINUX)}
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.CreateRenderContext;
-
- procedure UpdateVisual;
- var
- attrList: TGLIntArray;
- drawable: PGdkDrawable;
- begin
- { Temporary (realized) widget to get to display }
- fWidget:= {%H-}PGtkWidget(PtrUInt(Handle));
- gtk_widget_realize(fWidget);
- drawable := GTK_WIDGET(fWidget)^.window;
- fDisplay := GDK_WINDOW_XDISPLAY(drawable);
-
- { Find a suitable visual from PixelFormat using GLX 1.3 FBConfigs or
- old-style Visuals }
- if Assigned(glXChooseFBConfig) then begin
- attrList := CreateOpenGLContextAttrList(true, true, 32, 24);
- fVisual := FBglXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]);
- end;
- if not Assigned(fVisual) then begin
- attrList := CreateOpenGLContextAttrList(false, true, 32, 24);
- fVisual := glXChooseVisual(FDisplay, DefaultScreen(FDisplay), @attrList[0]);
- end;
- if not Assigned(fVisual) then
- raise Exception.Create('choose visual failed');
-
- { Most widgets inherit the drawable of their parent. In contrast to Windows, descending from
- TWinControl does not mean it's actually always a window of its own.
- Famous example: TPanel is just a frame painted on a canvas.
- Also, the LCL does somethin weird to colormaps in window creation, so we have
- to use a custom widget here to have full control about visual selection. }
- fRenderControl:= TRenderControl.Create(self, fVisual^.visual^.visualid);
- try
- fRenderControl.Parent := self;
- fRenderControl.HandleNeeded;
- fRenderControl.Target := self;
- except
- FreeAndNil(fRenderControl);
- raise;
- end;
-
- { Real Widget handle, unrealized!!! }
- fWidget := fRenderControl.Widget;
- gtk_widget_realize(fWidget);
- drawable := GTK_WIDGET(fWidget)^.window;
- FDisplay := GDK_WINDOW_XDISPLAY(drawable);
-
- // fRenderControl.Align:= alClient breaks the context or something
- fRenderControl.BoundsRect := ClientRect;
- fRenderControl.Anchors := [akLeft, akTop, akRight, akBottom];
- end;
-
- var
- glxID: GLXDrawable;
- begin
- InitOpenGL;
- UpdateVisual;
- if not Assigned(FVisual) then
- raise Exception.Create('Failed to find Visual');
-
- fContext := glXCreateContext(FDisplay, FVisual, nil, true);
- if not Assigned(fContext) then
- raise Exception.Create('Failed to create Context');
-
- gtk_widget_realize(fWidget);
- if not GTK_WIDGET_REALIZED(fWidget) then
- exit;
-
- glxID := GDK_DRAWABLE_XID(GTK_WIDGET(fWidget)^.window);
- glXMakeCurrent(fDisplay, glxID, fContext);
-
- ReadOpenGLCore;
- ReadExtensions;
- ReadImplementationProperties;
-
- fHasRenderContext := true;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.DestroyRenderContext;
- var
- glxID: GLXDrawable;
- begin
- glxID := GDK_DRAWABLE_XID(GTK_WIDGET(fWidget)^.window);
- glXMakeCurrent(FDisplay, glxID, nil);
- if Assigned(fContext) then
- glXDestroyContext(fDisplay, fContext);
- FreeAndNil(fRenderControl);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.SwapBuffers;
- var
- glxID: GLXDrawable;
- begin
- if not Assigned(fWidget) then
- exit;
- glxID := GDK_DRAWABLE_XID(GTK_WIDGET(fWidget)^.window);
- glXSwapBuffers(fDisplay, glxID);
- end;
- {$ENDIF}
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TMainForm.Render;
- var
- block: TltsTextBlock;
- begin
- glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
- glLoadIdentity;
-
- glEnable(GL_BLEND);
- glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
-
- block := fltsRenderer.BeginBlock(10, 10, ClientWidth-20, ClientHeight-20, [ltsBlockFlagWordWrap]);
- try
- block.HorzAlign := ltsHorzAlignJustify;
- block.ChangeFont(fltsFont);
- block.ChangeColor(ltsColor4f(1.0, 1.0, 1.0, 1.0));
- block.TextOutW(TEST_TEXT);
- finally
- fltsRenderer.EndBlock(block);
- end;
-
- SwapBuffers;
- end;
-
- {$IFDEF LINUX}
- initialization
- RegisterWSComponent(TRenderControl, TWSCustomVisualControl);
- {$ENDIF}
-
- end.
|