From 4efe1ff8920ef45b6a348ca079867970099a7a17 Mon Sep 17 00:00:00 2001 From: Francisco Vallarino Date: Tue, 27 Apr 2021 01:03:36 -0300 Subject: [PATCH] Add initial commit for generative example --- .ghcid | 2 +- examples/generative/GenerativeTypes.hs | 29 +++++++ examples/generative/Main.hs | 52 ++++++++++++ examples/generative/Widgets/CirclesGrid.hs | 93 ++++++++++++++++++++++ examples/todo/Main.hs | 1 - examples/todo/TodoTypes.hs | 1 - package.yaml | 25 ++++-- src/Monomer/Graphics/NanoVGRenderer.hs | 15 ++++ src/Monomer/Graphics/Types.hs | 3 + src/Monomer/Main/Core.hs | 2 + tasks.md | 1 - 11 files changed, 212 insertions(+), 12 deletions(-) create mode 100644 examples/generative/GenerativeTypes.hs create mode 100644 examples/generative/Main.hs create mode 100644 examples/generative/Widgets/CirclesGrid.hs diff --git a/.ghcid b/.ghcid index 0c291ab2..7f7bca10 100644 --- a/.ghcid +++ b/.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 diff --git a/examples/generative/GenerativeTypes.hs b/examples/generative/GenerativeTypes.hs new file mode 100644 index 00000000..19fd385f --- /dev/null +++ b/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) diff --git a/examples/generative/Main.hs b/examples/generative/Main.hs new file mode 100644 index 00000000..c1182ef2 --- /dev/null +++ b/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 + ] diff --git a/examples/generative/Widgets/CirclesGrid.hs b/examples/generative/Widgets/CirclesGrid.hs new file mode 100644 index 00000000..869cebac --- /dev/null +++ b/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 diff --git a/examples/todo/Main.hs b/examples/todo/Main.hs index b2fc75cc..77fba561 100644 --- a/examples/todo/Main.hs +++ b/examples/todo/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/examples/todo/TodoTypes.hs b/examples/todo/TodoTypes.hs index 8011e530..86fccda8 100644 --- a/examples/todo/TodoTypes.hs +++ b/examples/todo/TodoTypes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} diff --git a/package.yaml b/package.yaml index 0a516673..c4dc694f 100644 --- a/package.yaml +++ b/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 diff --git a/src/Monomer/Graphics/NanoVGRenderer.hs b/src/Monomer/Graphics/NanoVGRenderer.hs index 46c1ad0e..21f5d191 100644 --- a/src/Monomer/Graphics/NanoVGRenderer.hs +++ b/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 diff --git a/src/Monomer/Graphics/Types.hs b/src/Monomer/Graphics/Types.hs index 1c15ec29..c20ab48e 100644 --- a/src/Monomer/Graphics/Types.hs +++ b/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 diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs index d3816e3b..63190bc2 100644 --- a/src/Monomer/Main/Core.hs +++ b/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 diff --git a/tasks.md b/tasks.md index c62d6bf2..23010a1a 100644 --- a/tasks.md +++ b/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