Add OpenGL example

.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

docs/examples/05-opengl.md

@@ -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.

examples/opengl/Main.hs

@@ -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

examples/opengl/OpenGLWidget.hs

@@ -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 "

examples/opengl/shaders/frag.glsl

@@ -0,0 +1,9 @@
+#version 330 core
+
+out vec4 FragColor;
+in vec3 ourColor;
+
+void main()
+{
+    FragColor = vec4(ourColor,1.0);
+}

examples/opengl/shaders/vert.glsl

@@ -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;
+}

monomer.cabal

@@ -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:

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

src/Monomer/Common/BasicTypes.hs

@@ -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)

src/Monomer/Graphics/Types.hs

@@ -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