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"
|
||||
--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 ScopedTypeVariables #-}
|
||||
|
||||
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
|
25
package.yaml
25
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user