mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
Add OpenGL example
This commit is contained in:
parent
5bafc22775
commit
4428b126df
2
.ghcid
2
.ghcid
@ -1,3 +1,3 @@
|
||||
--command "stack repl --main-is monomer:exe:tutorial"
|
||||
--command "stack repl --main-is monomer:exe:opengl"
|
||||
--test ":main"
|
||||
--restart=package.yaml
|
||||
|
90
docs/examples/05-opengl.md
Normal file
90
docs/examples/05-opengl.md
Normal file
@ -0,0 +1,90 @@
|
||||
# Example 05 - Custom OpenGL
|
||||
|
||||
## Description
|
||||
|
||||
This example provides the basics for implementing a widget using custom OpenGL
|
||||
rendering, bypassing Monomer's Renderer interface.
|
||||
|
||||
The objective of this example is explaining how to integrate OpenGL into a
|
||||
Monomer application, without focusing on OpenGL best practices.
|
||||
|
||||
## Preview
|
||||
|
||||
<img src="images/05_OpenGL.png" alt="Preview jpg" width="800" height="600" />
|
||||
|
||||
## Interesting bits
|
||||
|
||||
### Resource initialization
|
||||
|
||||
Rendering APIs, OpenGL in particular, impose restrictions on multi-threading. In
|
||||
general, a single thread is allowed to call rendering APIs for a given render
|
||||
context. Calling these APIs from a different thread usually results in a crash.
|
||||
|
||||
Monomer handles rendering in an isolated OS thread. The render function of a
|
||||
widget will be invoked from this thread, but any other functions will not. In
|
||||
particular, when using `RunTask` or `RunProducer`, the provided actions will not
|
||||
be run in the rendering thread. Calling OpenGL functions from a `RunTask` action
|
||||
will result in a crash.
|
||||
|
||||
To avoid using the `render` function to initialize resources Monomer provides
|
||||
`RunInRenderThread`, which is equivalent to `RunTask` except it runs in the
|
||||
rendering thread. The task should limit itself to rendering API initialization
|
||||
related tasks.
|
||||
|
||||
In the example the `init` function takes care of loading the vertex and fragment
|
||||
shaders that will be used for rendering, and also for allocating the Vertex
|
||||
Array Object and Vertex Buffer Object. The corresponding ids are stored in the
|
||||
widget's state for further usage. As in other widgets, it is important to
|
||||
implement merge to keep this information when the UI is rebuilt. The `dispose`
|
||||
function releases these OpenGL resources.
|
||||
|
||||
### Rendering passes
|
||||
|
||||
Each widget implements the render function to display its content, and each
|
||||
widget instance is invoked in the order defined by the widget tree (depth first,
|
||||
child widgets rendering on top of their parent's content). This is in general
|
||||
enough, but some widgets need to render on top of all the existing content. The
|
||||
`createOverlay` function provides this functionality, receiving an IO action
|
||||
that will be run after the normal render pass. The dropdown widget uses this to
|
||||
render its list when in open state.
|
||||
|
||||
Two additional rendering passes exist. When doing low level rendering, calling
|
||||
API functions directly may cause issues because of expectations regarding OpenGL
|
||||
state. To overcome this, a pair of functions exist: `createRawTask` and
|
||||
`createRawOverlay`. In the example only `createRawTask` is used.
|
||||
|
||||
The order of the render passes is:
|
||||
|
||||
- Regular render calls
|
||||
- Raw tasks
|
||||
- Regular overlays
|
||||
- Raw overlays
|
||||
|
||||
### Active viewport
|
||||
|
||||
A node has a viewport that represents its assigned region for rendering. When
|
||||
its render function is called the widget can draw freely inside this region,
|
||||
although it may not be completely visible: the widget could be partially outside
|
||||
the screen or wrapped in a scroll widget. The currently visible region can be
|
||||
found in the `viewport` field of `WidgetEnv`. Also important is the `offset`
|
||||
field, generally updated by the scroll widget.
|
||||
|
||||
When using the Renderer interface this is usually transparent, except for
|
||||
optimization purposes. Since custom rendering happens _after_ the Renderer pass,
|
||||
this has to be managed explicitly.
|
||||
|
||||
### Coordinates
|
||||
|
||||
In Monomer, y = 0 represents the top of the screen. Depending on how the vertex
|
||||
shader is implemented you may need to transform the active viewport (for
|
||||
scissoring) and the node's viewport. In this example the vertex shader does not
|
||||
perform any kind of transformation, so both x and y run from -1 to 1; this is
|
||||
the reason for the addition/substraction of w/2 and h/2.
|
||||
|
||||
### Device pixel rate
|
||||
|
||||
The remaining thing to consider is the Device Pixel Rate, or dpr. While Monomer
|
||||
takes care of it when using the Renderer interface, it needs to be considered
|
||||
when doing low level rendering. In this example it is only used for scissoring
|
||||
but, depending on how you handle projections, you may need to consider it there
|
||||
too.
|
BIN
docs/examples/images/05_OpenGL.png
Normal file
BIN
docs/examples/images/05_OpenGL.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 85 KiB |
91
examples/opengl/Main.hs
Normal file
91
examples/opengl/Main.hs
Normal file
@ -0,0 +1,91 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Text (Text)
|
||||
import Monomer
|
||||
|
||||
import qualified Data.Map as M
|
||||
import qualified Monomer.Lens as L
|
||||
|
||||
import OpenGLWidget
|
||||
|
||||
data AppModel = AppModel {
|
||||
_color1 :: Color,
|
||||
_color2 :: Color,
|
||||
_color3 :: Color,
|
||||
_color4 :: Color
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data AppEvent
|
||||
= AppInit
|
||||
deriving (Eq, Show)
|
||||
|
||||
makeLenses 'AppModel
|
||||
|
||||
buildUI
|
||||
:: WidgetEnv AppModel AppEvent
|
||||
-> AppModel
|
||||
-> WidgetNode AppModel AppEvent
|
||||
buildUI wenv model = widgetTree where
|
||||
colorsMap = M.fromList [(red, "Red"), (green, "Green"), (blue, "Blue"), (orange, "Orange")]
|
||||
colors = M.keys colorsMap
|
||||
colorDropdown field = textDropdown_ field colors (colorsMap M.!) []
|
||||
|
||||
widgetTree = vstack [
|
||||
hstack [
|
||||
label "Color 1:",
|
||||
spacer,
|
||||
colorDropdown color1,
|
||||
spacer,
|
||||
label "Color 2:",
|
||||
spacer,
|
||||
colorDropdown color2,
|
||||
spacer,
|
||||
label "Color 3:",
|
||||
spacer,
|
||||
colorDropdown color3,
|
||||
spacer,
|
||||
label "Color 4:",
|
||||
spacer,
|
||||
colorDropdown color4
|
||||
],
|
||||
spacer,
|
||||
vgrid [
|
||||
hgrid [
|
||||
openGLWidget (model ^. color1)
|
||||
`styleBasic` [padding 20],
|
||||
scroll (openGLWidget (model ^. color2) `styleBasic` [width 800, height 800])
|
||||
`styleBasic` [padding 20]
|
||||
],
|
||||
hgrid [
|
||||
openGLWidget (model ^. color3)
|
||||
`styleBasic` [padding 20],
|
||||
openGLWidget (model ^. color4)
|
||||
`styleBasic` [padding 20]
|
||||
]
|
||||
]
|
||||
] `styleBasic` [padding 10]
|
||||
|
||||
handleEvent
|
||||
:: WidgetEnv AppModel AppEvent
|
||||
-> WidgetNode AppModel AppEvent
|
||||
-> AppModel
|
||||
-> AppEvent
|
||||
-> [AppEventResponse AppModel AppEvent]
|
||||
handleEvent wenv node model evt = case evt of
|
||||
AppInit -> []
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
startApp model handleEvent buildUI config
|
||||
where
|
||||
config = [
|
||||
appWindowTitle "OpenGL",
|
||||
appTheme darkTheme,
|
||||
appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
|
||||
appInitEvent AppInit
|
||||
]
|
||||
model = AppModel red green blue orange
|
226
examples/opengl/OpenGLWidget.hs
Normal file
226
examples/opengl/OpenGLWidget.hs
Normal file
@ -0,0 +1,226 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module OpenGLWidget (
|
||||
openGLWidget
|
||||
) where
|
||||
|
||||
import Control.Lens ((&), (^.), (.~))
|
||||
import Control.Monad
|
||||
import Data.Default
|
||||
import Data.Typeable (cast)
|
||||
import Data.Vector.Storable (Vector)
|
||||
import Foreign.C.String
|
||||
import Foreign.Marshal.Alloc
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable
|
||||
import Graphics.GL
|
||||
|
||||
import qualified Data.Vector.Storable as V
|
||||
|
||||
import Monomer
|
||||
import Monomer.Widgets.Single
|
||||
|
||||
import qualified Monomer.Lens as L
|
||||
|
||||
data OpenGLWidgetMsg
|
||||
= OpenGLWidgetInit GLuint (Ptr GLuint) (Ptr GLuint)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data OpenGLWidgetState = OpenGLWidgetState {
|
||||
_ogsLoaded :: Bool,
|
||||
_ogsShaderId :: GLuint,
|
||||
_ogsVao :: Ptr GLuint,
|
||||
_ogsVbo :: Ptr GLuint
|
||||
} deriving (Show, Eq)
|
||||
|
||||
openGLWidget :: Color -> WidgetNode s e
|
||||
openGLWidget color = defaultWidgetNode "openGLWidget" widget where
|
||||
widget = makeOpenGLWidget color state
|
||||
state = OpenGLWidgetState False 0 nullPtr nullPtr
|
||||
|
||||
makeOpenGLWidget :: Color -> OpenGLWidgetState -> Widget s e
|
||||
makeOpenGLWidget color state = widget where
|
||||
widget = createSingle state def {
|
||||
singleInit = init,
|
||||
singleMerge = merge,
|
||||
singleDispose = dispose,
|
||||
singleHandleMessage = handleMessage,
|
||||
singleGetSizeReq = getSizeReq,
|
||||
singleRender = render
|
||||
}
|
||||
|
||||
init wenv node = resultReqs node reqs where
|
||||
widgetId = node ^. L.info . L.widgetId
|
||||
path = node ^. L.info . L.path
|
||||
buffers = 2
|
||||
|
||||
initOpenGL = do
|
||||
-- This needs to run in render thread
|
||||
program <- createShaderProgram
|
||||
vaoPtr <- malloc
|
||||
vboPtr <- malloc
|
||||
glGenVertexArrays buffers vaoPtr
|
||||
glGenBuffers buffers vboPtr
|
||||
|
||||
return $ OpenGLWidgetInit program vaoPtr vboPtr
|
||||
|
||||
reqs = [RunInRenderThread widgetId path initOpenGL]
|
||||
|
||||
merge wenv node oldNode oldState = resultNode newNode where
|
||||
newNode = node
|
||||
& L.widget .~ makeOpenGLWidget color oldState
|
||||
|
||||
dispose wenv node = resultReqs node reqs where
|
||||
OpenGLWidgetState _ shaderId vaoPtr vboPtr = state
|
||||
widgetId = node ^. L.info . L.widgetId
|
||||
path = node ^. L.info . L.path
|
||||
buffers = 2
|
||||
|
||||
disposeOpenGL = do
|
||||
-- This needs to run in render thread
|
||||
glDeleteProgram shaderId
|
||||
glDeleteVertexArrays buffers vaoPtr
|
||||
glDeleteBuffers buffers vboPtr
|
||||
free vaoPtr
|
||||
free vboPtr
|
||||
|
||||
reqs = [RunInRenderThread widgetId path disposeOpenGL]
|
||||
|
||||
handleMessage wenv node target msg = case cast msg of
|
||||
Just (OpenGLWidgetInit shaderId vao vbo) -> Just (resultNode newNode) where
|
||||
newState = OpenGLWidgetState True shaderId vao vbo
|
||||
newNode = node
|
||||
& L.widget .~ makeOpenGLWidget color newState
|
||||
_ -> Nothing
|
||||
|
||||
getSizeReq wenv node = (sizeReqW, sizeReqH) where
|
||||
sizeReqW = expandSize 100 1
|
||||
sizeReqH = expandSize 100 1
|
||||
|
||||
render wenv node renderer =
|
||||
when (_ogsLoaded state) $
|
||||
createRawTask renderer $
|
||||
doInScissor winSize dpr offset activeVp $
|
||||
drawVertices state (toVectorVAO winSize offset color triangle)
|
||||
where
|
||||
dpr = wenv ^. L.dpr
|
||||
winSize = wenv ^. L.windowSize
|
||||
activeVp = wenv ^. L.viewport
|
||||
offset = wenv ^. L.offset
|
||||
|
||||
-- Simple triangle
|
||||
style = currentStyle wenv node
|
||||
nodeVp = getContentArea node style
|
||||
|
||||
Rect rx ry rw rh = nodeVp
|
||||
triangle = [(rx + rw, ry + rh), (rx, ry + rh), (rx + rw / 2, ry)]
|
||||
|
||||
doInScissor :: Size -> Double -> Point -> Rect -> IO () -> IO ()
|
||||
doInScissor winSize dpr offset vp action = do
|
||||
glEnable GL_SCISSOR_TEST
|
||||
-- OpenGL's Y axis increases from bottom to top
|
||||
glScissor (round (rx + ox)) (round $ winH - ry - oy - rh) (round rw) (round rh)
|
||||
action
|
||||
glDisable GL_SCISSOR_TEST
|
||||
where
|
||||
winH = winSize ^. L.h * dpr
|
||||
Point ox oy = mulPoint dpr offset
|
||||
Rect rx ry rw rh = mulRect dpr vp
|
||||
|
||||
toVectorVAO :: Size -> Point -> Color -> [(Double, Double)] -> Vector Float
|
||||
toVectorVAO (Size w h) (Point ox oy) (Color r g b a) points = vec where
|
||||
px x = realToFrac $ (x + ox - w / 2) / (w / 2)
|
||||
-- OpenGL's Y axis increases from bottom to top
|
||||
py y = realToFrac $ (h / 2 - y - oy) / (h / 2)
|
||||
col c = realToFrac (fromIntegral c / 255)
|
||||
row (x, y) = [px x, py y, 0, col r, col g, col b]
|
||||
vec = V.fromList . concat $ row <$> points
|
||||
|
||||
drawVertices
|
||||
:: forall a . Storable a
|
||||
=> OpenGLWidgetState
|
||||
-> Vector a
|
||||
-> IO ()
|
||||
drawVertices state vertices = do
|
||||
vao <- peek vaoPtr
|
||||
vbo <- peek vboPtr
|
||||
|
||||
glBindVertexArray vao
|
||||
glBindBuffer GL_ARRAY_BUFFER vbo
|
||||
|
||||
-- Copies raw data from vector to OpenGL memory
|
||||
V.unsafeWith vertices $ \vertsPtr ->
|
||||
glBufferData
|
||||
GL_ARRAY_BUFFER
|
||||
(fromIntegral (V.length vertices * floatSize))
|
||||
(castPtr vertsPtr)
|
||||
GL_STATIC_DRAW
|
||||
|
||||
-- The vertex shader expects two arguments. Position:
|
||||
glVertexAttribPointer 0 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) nullPtr
|
||||
glEnableVertexAttribArray 0
|
||||
|
||||
-- Color:
|
||||
glVertexAttribPointer 1 3 GL_FLOAT GL_FALSE (fromIntegral (floatSize * 6)) (nullPtr `plusPtr` (floatSize * 3))
|
||||
glEnableVertexAttribArray 1
|
||||
|
||||
glUseProgram shaderId
|
||||
glBindVertexArray vao
|
||||
glDrawArrays GL_TRIANGLES 0 3
|
||||
|
||||
where
|
||||
floatSize = sizeOf (undefined :: Float)
|
||||
OpenGLWidgetState _ shaderId vaoPtr vboPtr = state
|
||||
|
||||
createShaderProgram :: IO GLuint
|
||||
createShaderProgram = do
|
||||
shaderProgram <- glCreateProgram
|
||||
vertexShader <- compileShader GL_VERTEX_SHADER "examples/opengl/shaders/vert.glsl"
|
||||
fragmentShader <- compileShader GL_FRAGMENT_SHADER "examples/opengl/shaders/frag.glsl"
|
||||
|
||||
glAttachShader shaderProgram vertexShader
|
||||
glAttachShader shaderProgram fragmentShader
|
||||
|
||||
glLinkProgram shaderProgram
|
||||
checkProgramLink shaderProgram
|
||||
|
||||
glDeleteShader vertexShader
|
||||
glDeleteShader fragmentShader
|
||||
|
||||
return shaderProgram
|
||||
|
||||
compileShader :: GLenum -> FilePath -> IO GLuint
|
||||
compileShader shaderType shaderFile = do
|
||||
shader <- glCreateShader shaderType
|
||||
shaderSource <- readFile shaderFile >>= newCString
|
||||
|
||||
alloca $ \shadersStr -> do
|
||||
shadersStr `poke` shaderSource
|
||||
glShaderSource shader 1 shadersStr nullPtr
|
||||
glCompileShader shader
|
||||
checkShaderCompile shader
|
||||
|
||||
return shader
|
||||
|
||||
checkProgramLink :: GLuint -> IO ()
|
||||
checkProgramLink programId = do
|
||||
alloca $ \successPtr -> do
|
||||
alloca $ \infoLogPtr -> do
|
||||
glGetProgramiv programId GL_LINK_STATUS successPtr
|
||||
success <- peek successPtr
|
||||
|
||||
when (success <= 0) $ do
|
||||
glGetProgramInfoLog programId 512 nullPtr infoLogPtr
|
||||
putStrLn =<< peekCString infoLogPtr
|
||||
|
||||
checkShaderCompile :: GLuint -> IO ()
|
||||
checkShaderCompile shaderId = do
|
||||
alloca $ \successPtr ->
|
||||
alloca $ \infoLogPtr -> do
|
||||
glGetShaderiv shaderId GL_COMPILE_STATUS successPtr
|
||||
success <- peek successPtr
|
||||
|
||||
when (success <= 0) $ do
|
||||
glGetShaderInfoLog shaderId 512 nullPtr infoLogPtr
|
||||
putStrLn "Failed to compile shader "
|
9
examples/opengl/shaders/frag.glsl
Normal file
9
examples/opengl/shaders/frag.glsl
Normal file
@ -0,0 +1,9 @@
|
||||
#version 330 core
|
||||
|
||||
out vec4 FragColor;
|
||||
in vec3 ourColor;
|
||||
|
||||
void main()
|
||||
{
|
||||
FragColor = vec4(ourColor,1.0);
|
||||
}
|
12
examples/opengl/shaders/vert.glsl
Normal file
12
examples/opengl/shaders/vert.glsl
Normal file
@ -0,0 +1,12 @@
|
||||
#version 330 core
|
||||
|
||||
layout (location = 0) in vec3 aPos;
|
||||
layout (location = 1) in vec3 aColor;
|
||||
|
||||
out vec3 ourColor;
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_Position = vec4(aPos, 1.0);
|
||||
ourColor = aColor;
|
||||
}
|
@ -274,6 +274,49 @@ executable generative
|
||||
, wreq >=0.5.2 && <0.6
|
||||
default-language: Haskell2010
|
||||
|
||||
executable opengl
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
OpenGLWidget
|
||||
Paths_monomer
|
||||
hs-source-dirs:
|
||||
examples/opengl
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
ghc-options: -threaded
|
||||
build-depends:
|
||||
JuicyPixels >=3.2.9 && <3.5
|
||||
, OpenGL ==3.0.*
|
||||
, OpenGLRaw ==3.3.*
|
||||
, async >=2.1 && <2.3
|
||||
, attoparsec >=0.12 && <0.15
|
||||
, base >=4.11 && <5
|
||||
, bytestring >=0.10 && <0.12
|
||||
, bytestring-to-vector ==0.3.*
|
||||
, containers >=0.5.11 && <0.7
|
||||
, data-default >=0.5 && <0.8
|
||||
, exceptions ==0.10.*
|
||||
, extra >=1.6 && <1.9
|
||||
, formatting >=6.0 && <8.0
|
||||
, http-client >=0.6 && <0.9
|
||||
, lens >=4.16 && <5.1
|
||||
, monomer
|
||||
, mtl >=2.1 && <2.3
|
||||
, nanovg >=0.8 && <1.0
|
||||
, process ==1.6.*
|
||||
, random >=1.1 && <1.3
|
||||
, safe ==0.3.*
|
||||
, sdl2 >=2.4.0 && <2.6
|
||||
, stm ==2.5.*
|
||||
, text ==1.2.*
|
||||
, text-show >=3.7 && <3.10
|
||||
, time >=1.8 && <1.13
|
||||
, transformers >=0.5 && <0.7
|
||||
, unordered-containers >=0.2.8 && <0.3
|
||||
, vector >=0.12 && <0.14
|
||||
, wreq >=0.5.2 && <0.6
|
||||
default-language: Haskell2010
|
||||
|
||||
executable ticker
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
|
12
package.yaml
12
package.yaml
@ -123,6 +123,18 @@ executables:
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
|
||||
opengl:
|
||||
main: Main.hs
|
||||
source-dirs: examples/opengl
|
||||
ghc-options:
|
||||
- -threaded
|
||||
dependencies:
|
||||
- lens >= 4.16 && < 5.1
|
||||
- monomer
|
||||
- OpenGLRaw >= 3.3 && < 3.4
|
||||
- random >= 1.1 && < 1.3
|
||||
- text-show >= 3.7 && < 3.10
|
||||
|
||||
tutorial:
|
||||
main: Main.hs
|
||||
source-dirs: examples/tutorial
|
||||
|
@ -131,6 +131,10 @@ subtractFromSize (Size w h) w2 h2 = newSize where
|
||||
moveRect :: Point -> Rect -> Rect
|
||||
moveRect (Point x y) (Rect rx ry rw rh) = Rect (rx + x) (ry + y) rw rh
|
||||
|
||||
-- | Scales a rect by the provided factor.
|
||||
mulRect :: Double -> Rect -> Rect
|
||||
mulRect f (Rect rx ry rw rh) = Rect (f * rx) (f * ry) (f * rw) (f * rh)
|
||||
|
||||
-- | Returns the middle point of a rect.
|
||||
rectCenter :: Rect -> Point
|
||||
rectCenter (Rect rx ry rw rh) = Point (rx + rw / 2) (ry + rh / 2)
|
||||
|
@ -40,7 +40,7 @@ data Color = Color {
|
||||
_colorG :: {-# UNPACK #-} !Int,
|
||||
_colorB :: {-# UNPACK #-} !Int,
|
||||
_colorA :: {-# UNPACK #-} !Double
|
||||
} deriving (Eq, Show, Generic)
|
||||
} deriving (Eq, Show, Ord, Generic)
|
||||
|
||||
instance Default Color where
|
||||
def = Color 255 255 255 1.0
|
||||
|
Loading…
Reference in New Issue
Block a user