Add initial commit for generative example

.ghcid

@@ -1,3 +1,3 @@
---command "stack repl --main-is monomer:exe:monomer-exe"
+--command "stack repl --main-is monomer:exe:generative"
 --test ":main"
 --restart=package.yaml

examples/generative/GenerativeTypes.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module GenerativeTypes where
+
+import Control.Lens.TH
+import Data.Default
+import Data.Text (Text)
+
+import Monomer
+
+data GenerativeType
+  = CirclesGrid
+  | ExampleB
+  deriving (Eq, Show, Enum)
+
+newtype GenerativeModel = GenerativeModel {
+  _activeGenerative :: GenerativeType
+} deriving (Eq, Show)
+
+data GenerativeEvt
+  = GenerativeInit
+  deriving (Eq, Show)
+
+makeLenses ''GenerativeType
+makeLenses ''GenerativeModel
+
+generativeTypes :: [GenerativeType]
+generativeTypes = enumFrom (toEnum 0)

examples/generative/Main.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import Control.Lens
+import Data.Default
+import Data.Maybe
+import Data.Text (Text)
+import TextShow
+
+import Monomer
+import Monomer.Widgets.Single
+
+import GenerativeTypes
+import Widgets.CirclesGrid
+
+import qualified Monomer.Lens as L
+
+buildUI
+  :: WidgetEnv GenerativeModel GenerativeEvt
+  -> GenerativeModel
+  -> WidgetNode GenerativeModel GenerativeEvt
+buildUI wenv model = widgetTree where
+  widgetTree = vstack [
+      textDropdownS activeGenerative generativeTypes `key` "activeType",
+      spacer,
+      circlesGrid def
+    ]
+
+handleEvent
+  :: WidgetEnv GenerativeModel GenerativeEvt
+  -> WidgetNode GenerativeModel GenerativeEvt
+  -> GenerativeModel
+  -> GenerativeEvt
+  -> [EventResponse GenerativeModel GenerativeEvt ()]
+handleEvent wenv node model evt = case evt of
+  GenerativeInit -> [setFocus wenv "activeType"]
+
+setFocus :: WidgetEnv s e -> Text -> EventResponse s e ep
+setFocus wenv key = Request (SetFocus widgetId) where
+  widgetId = fromMaybe def (globalKeyWidgetId wenv key)
+
+main :: IO ()
+main = do
+  simpleApp (GenerativeModel CirclesGrid) handleEvent buildUI config
+  where
+    config = [
+      appWindowTitle "Generative art",
+      appTheme darkTheme,
+      appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf",
+      appInitEvent GenerativeInit
+      ]

examples/generative/Widgets/CirclesGrid.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Widgets.CirclesGrid where
+
+import Control.Lens
+--import Control.Lens.TH (abbreviatedFields, makeLensesWith)
+import Data.Default
+import System.Random
+
+import Monomer.Graphics.ColorTable
+import Monomer.Widgets.Single
+
+import qualified Monomer.Lens as L
+
+newtype CirclesGridCfg = CirclesGridCfg {
+  _cgcItemWidth :: Double
+} deriving (Eq, Show)
+
+instance Default CirclesGridCfg where
+  def = CirclesGridCfg {
+    _cgcItemWidth = 25
+  }
+
+data CirclesGridState = CirclesGridState {
+  _cgcMouseX :: Double,
+  _cgcMouseY :: Double
+} deriving (Eq, Show)
+
+makeLensesWith abbreviatedFields ''CirclesGridCfg
+makeLensesWith abbreviatedFields ''CirclesGridState
+
+circlesGrid :: CirclesGridCfg -> WidgetNode s e
+circlesGrid cfg = defaultWidgetNode "circlesGrid" widget where
+  widget = makeCirclesGrid cfg (CirclesGridState 0 0)
+
+makeCirclesGrid :: CirclesGridCfg -> CirclesGridState -> Widget s e
+makeCirclesGrid cfg state = widget where
+  widget = createSingle state def {
+    singleUseScissor = True,
+    singleHandleEvent = handleEvent,
+    singleGetSizeReq = getSizeReq,
+    singleRender = render
+  }
+
+  handleEvent wenv node target evt = case evt of
+    Move (Point x y) -> Just (resultReqs newNode [RenderOnce]) where
+      newState = CirclesGridState x y
+      newNode = node
+        & L.widget .~ makeCirclesGrid cfg newState
+    _ -> Nothing
+
+  getSizeReq wenv node = (expandSize 100 1, expandSize 100 1)
+
+  render wenv node renderer = do
+    setStdGen (mkStdGen 42)
+
+    mapM_ (drawCircle renderer state vp iw cols) [0..cols * rows - 1]
+    where
+      vp = node ^. L.info . L.viewport
+      iw = cfg ^. itemWidth
+      cols = round (vp ^. L.w / iw)
+      rows = round (vp ^. L.h / iw)
+
+drawCircle
+  :: Renderer -> CirclesGridState -> Rect -> Double -> Int -> Int -> IO ()
+drawCircle renderer state vp iw cols idx = do
+  colorIdx :: Double <- randomIO
+  offsetX <- randomIO
+  offsetY <- randomIO
+  let color = colors !! floor (fromIntegral (length colors) * colorIdx)
+  let colorFill = color & L.a .~ 0.3
+  beginPath renderer
+  setStrokeWidth renderer 2
+  setStrokeColor renderer color
+  setFillColor renderer colorFill
+  renderEllipse renderer (rect offsetX offsetY)
+  fill renderer
+  stroke renderer
+  where
+    colors = [magenta, orange, yellow, green]
+    sizeFactor = 1.1 * state ^. mouseY / vp ^. L.h
+    randFactor = state ^. mouseX / vp ^. L.w
+    currw = sizeFactor * iw
+    szDiff = (1 - sizeFactor) * iw
+    x = vp ^. L.x + iw * fromIntegral (idx `rem` cols)
+    y = vp ^. L.y + iw * fromIntegral (idx `div` cols)
+    rect ox oy = Rect rx ry currw currw where
+      rx = x + randFactor * (ox - 0.5) * iw
+      ry = y + randFactor * (oy - 0.5) * iw

examples/todo/Main.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 

examples/todo/TodoTypes.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 

package.yaml

@@ -77,14 +77,6 @@ executables:
     - lens
     - monomer
 
-  todo:
-    main: Main.hs
-    source-dirs: examples/todo
-    dependencies:
-    - lens
-    - monomer
-    - text-show
-
   books:
     main: Main.hs
     source-dirs: examples/books
@@ -95,6 +87,15 @@ executables:
     - text-show
     - wreq
 
+  generative:
+    main: Main.hs
+    source-dirs: examples/generative
+    dependencies:
+    - lens
+    - monomer
+    - random
+    - text-show
+
   ticker:
     main: Main.hs
     source-dirs: examples/ticker
@@ -107,6 +108,14 @@ executables:
     - websockets
     - wuss
 
+  todo:
+    main: Main.hs
+    source-dirs: examples/todo
+    dependencies:
+    - lens
+    - monomer
+    - text-show
+
 tests:
   monomer-test:
     main: Spec.hs

src/Monomer/Graphics/NanoVGRenderer.hs

@@ -58,6 +58,7 @@ data ImageReq = ImageReq {
 
 data Env = Env {
   overlays :: Seq (IO ()),
+  overlaysRaw :: Seq (IO ()),
   validFonts :: Set Text,
   imagesMap :: ImagesMap,
   addedImages :: Seq ImageReq
@@ -83,6 +84,7 @@ makeRenderer fonts dpr = do
 
   envRef <- newIORef $ Env {
     overlays = Seq.empty,
+    overlaysRaw = Seq.empty,
     validFonts = validFonts,
     imagesMap = M.empty,
     addedImages = Seq.empty
@@ -130,6 +132,19 @@ newRenderer c dpr lock envRef = Renderer {..} where
       overlays = Seq.empty
     }
 
+  -- Overlays
+  createRawOverlay overlay = L.with lock $
+    modifyIORef envRef $ \env -> env {
+      overlaysRaw = overlaysRaw env |> overlay
+    }
+
+  renderRawOverlays = do
+    env <- readIORef envRef
+    sequence_ $ overlaysRaw env
+    writeIORef envRef env {
+      overlaysRaw = Seq.empty
+    }
+
   -- Scissor
   intersectScissor rect = do
     VG.intersectScissor c cx cy cw ch

src/Monomer/Graphics/Types.hs

@@ -162,6 +162,9 @@ data Renderer = Renderer {
   -- Overlays
   createOverlay :: IO () -> IO (),
   renderOverlays :: IO (),
+  -- Raw overlays
+  createRawOverlay :: IO () -> IO (),
+  renderRawOverlays :: IO (),
   -- Scissor
   intersectScissor :: Rect -> IO (),
   -- Translation

src/Monomer/Main/Core.hs

@@ -326,6 +326,8 @@ renderWidgets !window renderer clearColor wenv widgetRoot = do
   liftIO $ renderOverlays renderer
 
   liftIO $ endFrame renderer
+
+  liftIO $ renderRawOverlays renderer
   SDL.glSwapWindow window
   where
     r = fromIntegral (clearColor ^. L.r) / 255

tasks.md

@@ -593,7 +593,6 @@
 
 Next
   - Add examples
-    - OpenGL example
     - Something of generative art (custom Widget example)
   - Rename ListView -> SelectList
     - Add support for multiple selection