mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-10-26 19:49:50 +03:00
Add initial commit for generative example
This commit is contained in:
parent
ece7dc4dda
commit
4efe1ff892
2
.ghcid
2
.ghcid
@ -1,3 +1,3 @@
|
|||||||
--command "stack repl --main-is monomer:exe:monomer-exe"
|
--command "stack repl --main-is monomer:exe:generative"
|
||||||
--test ":main"
|
--test ":main"
|
||||||
--restart=package.yaml
|
--restart=package.yaml
|
||||||
|
29
examples/generative/GenerativeTypes.hs
Normal file
29
examples/generative/GenerativeTypes.hs
Normal file
@ -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)
|
52
examples/generative/Main.hs
Normal file
52
examples/generative/Main.hs
Normal file
@ -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
|
||||||
|
]
|
93
examples/generative/Widgets/CirclesGrid.hs
Normal file
93
examples/generative/Widgets/CirclesGrid.hs
Normal file
@ -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
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
@ -1,4 +1,3 @@
|
|||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
25
package.yaml
25
package.yaml
@ -77,14 +77,6 @@ executables:
|
|||||||
- lens
|
- lens
|
||||||
- monomer
|
- monomer
|
||||||
|
|
||||||
todo:
|
|
||||||
main: Main.hs
|
|
||||||
source-dirs: examples/todo
|
|
||||||
dependencies:
|
|
||||||
- lens
|
|
||||||
- monomer
|
|
||||||
- text-show
|
|
||||||
|
|
||||||
books:
|
books:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
source-dirs: examples/books
|
source-dirs: examples/books
|
||||||
@ -95,6 +87,15 @@ executables:
|
|||||||
- text-show
|
- text-show
|
||||||
- wreq
|
- wreq
|
||||||
|
|
||||||
|
generative:
|
||||||
|
main: Main.hs
|
||||||
|
source-dirs: examples/generative
|
||||||
|
dependencies:
|
||||||
|
- lens
|
||||||
|
- monomer
|
||||||
|
- random
|
||||||
|
- text-show
|
||||||
|
|
||||||
ticker:
|
ticker:
|
||||||
main: Main.hs
|
main: Main.hs
|
||||||
source-dirs: examples/ticker
|
source-dirs: examples/ticker
|
||||||
@ -107,6 +108,14 @@ executables:
|
|||||||
- websockets
|
- websockets
|
||||||
- wuss
|
- wuss
|
||||||
|
|
||||||
|
todo:
|
||||||
|
main: Main.hs
|
||||||
|
source-dirs: examples/todo
|
||||||
|
dependencies:
|
||||||
|
- lens
|
||||||
|
- monomer
|
||||||
|
- text-show
|
||||||
|
|
||||||
tests:
|
tests:
|
||||||
monomer-test:
|
monomer-test:
|
||||||
main: Spec.hs
|
main: Spec.hs
|
||||||
|
@ -58,6 +58,7 @@ data ImageReq = ImageReq {
|
|||||||
|
|
||||||
data Env = Env {
|
data Env = Env {
|
||||||
overlays :: Seq (IO ()),
|
overlays :: Seq (IO ()),
|
||||||
|
overlaysRaw :: Seq (IO ()),
|
||||||
validFonts :: Set Text,
|
validFonts :: Set Text,
|
||||||
imagesMap :: ImagesMap,
|
imagesMap :: ImagesMap,
|
||||||
addedImages :: Seq ImageReq
|
addedImages :: Seq ImageReq
|
||||||
@ -83,6 +84,7 @@ makeRenderer fonts dpr = do
|
|||||||
|
|
||||||
envRef <- newIORef $ Env {
|
envRef <- newIORef $ Env {
|
||||||
overlays = Seq.empty,
|
overlays = Seq.empty,
|
||||||
|
overlaysRaw = Seq.empty,
|
||||||
validFonts = validFonts,
|
validFonts = validFonts,
|
||||||
imagesMap = M.empty,
|
imagesMap = M.empty,
|
||||||
addedImages = Seq.empty
|
addedImages = Seq.empty
|
||||||
@ -130,6 +132,19 @@ newRenderer c dpr lock envRef = Renderer {..} where
|
|||||||
overlays = Seq.empty
|
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
|
-- Scissor
|
||||||
intersectScissor rect = do
|
intersectScissor rect = do
|
||||||
VG.intersectScissor c cx cy cw ch
|
VG.intersectScissor c cx cy cw ch
|
||||||
|
@ -162,6 +162,9 @@ data Renderer = Renderer {
|
|||||||
-- Overlays
|
-- Overlays
|
||||||
createOverlay :: IO () -> IO (),
|
createOverlay :: IO () -> IO (),
|
||||||
renderOverlays :: IO (),
|
renderOverlays :: IO (),
|
||||||
|
-- Raw overlays
|
||||||
|
createRawOverlay :: IO () -> IO (),
|
||||||
|
renderRawOverlays :: IO (),
|
||||||
-- Scissor
|
-- Scissor
|
||||||
intersectScissor :: Rect -> IO (),
|
intersectScissor :: Rect -> IO (),
|
||||||
-- Translation
|
-- Translation
|
||||||
|
@ -326,6 +326,8 @@ renderWidgets !window renderer clearColor wenv widgetRoot = do
|
|||||||
liftIO $ renderOverlays renderer
|
liftIO $ renderOverlays renderer
|
||||||
|
|
||||||
liftIO $ endFrame renderer
|
liftIO $ endFrame renderer
|
||||||
|
|
||||||
|
liftIO $ renderRawOverlays renderer
|
||||||
SDL.glSwapWindow window
|
SDL.glSwapWindow window
|
||||||
where
|
where
|
||||||
r = fromIntegral (clearColor ^. L.r) / 255
|
r = fromIntegral (clearColor ^. L.r) / 255
|
||||||
|
1
tasks.md
1
tasks.md
@ -593,7 +593,6 @@
|
|||||||
|
|
||||||
Next
|
Next
|
||||||
- Add examples
|
- Add examples
|
||||||
- OpenGL example
|
|
||||||
- Something of generative art (custom Widget example)
|
- Something of generative art (custom Widget example)
|
||||||
- Rename ListView -> SelectList
|
- Rename ListView -> SelectList
|
||||||
- Add support for multiple selection
|
- Add support for multiple selection
|
||||||
|
Loading…
Reference in New Issue
Block a user