RoundSea.hs

module Scenes.RoundSea
  ( scene
  ) where

import Control.Monad.Reader
import Data.Colour.RGBSpace.HSV
import Data.Maybe
import Data.RVar
import Data.Random.Distribution.Normal
import Data.Random.Distribution.Uniform
import qualified Data.Vector as V
import Graphics.Rendering.Cairo
import Linear
import Math.Noise
import System.Random
import System.Random.Shuffle

import Components.CirclePack
import Components.Watercolor
import Compositing
import Coords
import Core
import Draw
import Element
import Geom
import Geom.Ellipse
import Patterns.Grid
import Patterns.RoundSea
import Patterns.Sparkles
import Traits.Meta
import Traits.Position as Pos
import Traits.Rotation as Rot
import Warp
import Wiggle

scene :: Generate (Render ())
scene = do
  solidLayer <- solid $ hsv (0 :: Double) 0 1
  sweepCount :: Int <- sampleRVar $ uniform 3 8
  sweeps <- sequence $ map (const sweep) [1 .. sweepCount]
  bg1' <- bg1
  World {width, height, ..} <- asks world
  border <- sampleRVar $ uniform 5 30
  return $ do
    solidLayer
    bg1'
    foldr1 (>>) sweeps
    renderElement
      Element
      { elementSrc =
          fromJust $
          contour $
          V.fromList [V2 0 0, V2 width 0, V2 width height, V2 0 height]
      , elementRule = drawRule (Stroke border) $ hsv (0 :: Double) 0 1
      }

bg1 :: Generate (Render ())
bg1 = do
  gridPoints <- grid gridCfgDefault
  let dots = map (\center -> Circle center 2) gridPoints
  noise' <- asks noise
  World {width, height, ..} <- asks world
  noiseOffsets <- sampleRVar $ uniform 1 15
  let mover d = Pos.translate delta d
        where
          delta = circumPoint (Circle (V2 0 0) noiseOffsets) phase
          phase = noiseVal * 2 * pi
          noiseVal = fromJust $ getValue noise' (x / width, y / height, 0.4)
          (V2 x y) = centroid d
  let dots' = map (mover) dots
  dots'' <-
    runRand $
    sequence $ map (warp warpCfgDefault . fromJust . estimateEllipse 20) dots'
  let elements =
        map
          (\dot ->
             Element
             { elementSrc = dot
             , elementRule =
                 drawRule Fill (hsv (0 :: Double) 0 0, 0.1 :: Double)
             })
          dots''
  seaPoints <-
    roundSeaSpawnPoints
      roundSeaCfgDefault
      {roundSeaPredicate = const $ \(V2 x y) -> y > height / 2}
  textureCircleSize <- sampleRVar $ uniform 20 100
  textureCircleOpacity :: Double <- sampleRVar $ uniform 0 0.01
  let textureElements =
        map
          (\p ->
             Element
             { elementSrc = Circle p textureCircleSize
             , elementRule =
                 drawRule Fill (hsv (0 :: Double) 0 0, textureCircleOpacity)
             })
          seaPoints
  return $ do foldr1 (>>) $ map (renderElement) $ elements ++ textureElements

bg :: Generate (Render ())
bg = do
  gridPoints <- grid gridCfgDefault
  let dots = map (\center -> Circle center 2) gridPoints
  noise' <- asks noise
  World {width, height, ..} <- asks world
  noiseOffsets <- sampleRVar $ uniform 1 15
  let mover d = Pos.translate delta d
        where
          delta = circumPoint (Circle (V2 0 0) noiseOffsets) phase
          phase = noiseVal * 2 * pi
          noiseVal = fromJust $ getValue noise' (x / width, y / height, 0.4)
          (V2 x y) = centroid d
  let dots' = map (mover) dots
  dots'' <-
    runRand $
    sequence $ map (warp warpCfgDefault . fromJust . estimateEllipse 20) dots'
  let elements =
        map
          (\dot ->
             Element
             { elementSrc = dot
             , elementRule =
                 drawRule Fill (hsv (0 :: Double) 0 0, 0.1 :: Double)
             })
          dots''
  seaPoints <-
    roundSeaSpawnPoints
      roundSeaCfgDefault
      {roundSeaPredicate = const $ \(V2 x y) -> y > height / 2}
  textureCircleSize <- sampleRVar $ uniform 20 100
  textureCircleOpacity :: Double <- sampleRVar $ uniform 0 0.1
  let textureElements =
        map
          (\p ->
             Element
             { elementSrc = Circle p textureCircleSize
             , elementRule =
                 drawRule Fill (hsv (0 :: Double) 0 0, textureCircleOpacity)
             })
          seaPoints
  return $ do foldr1 (>>) $ map (renderElement) $ elements ++ textureElements

sweep :: Generate (Render ())
sweep = do
  World {width, height, ..} <- asks world
  seaPoints <-
    roundSeaSpawnPoints
      roundSeaCfgDefault
      {roundSeaPredicate = const $ \(V2 x y) -> y > height / 2}
  baseHue :: Double <- sampleRVar $ uniform 0 360
  elements <- sequence $ map (treeRing baseHue) seaPoints
  clusterCount :: Int <- sampleRVar $ uniform 1 4
  clusters <- sequence $ map (const cluster) [1 .. clusterCount]
  rngSeed :: Int <- sampleRVar $ uniform 0 700
  let elements' = shuffle' elements (length elements) $ mkStdGen rngSeed
  let clusters' = foldr1 (>>) $ map (renderElement) $ concat clusters
  let circles = foldr1 (>>) $ map (renderElement) $ concat elements'
  return $ alphaMatte clusters' circles

cluster :: Generate [Element]
cluster = do
  let color = hsv 1 1 1
  circles <-
    circlePack
      CirclePackCfg
      { circlePackTries = 800
      , circlePackSize = const $ uniform 20 100
      , circlePackSpacing = const $ const $ \s -> s < 10
      , circlePackCenters = randomPoint
      }
  dashCount :: Int <- sampleRVar $ uniform 300 600
  let locationSampler = runRand $ sparkle $ V.fromList circles
  dashes <-
    sequence $ map (const $ waveDash 10 locationSampler) [1 .. dashCount]
  elements <- sequence $ map (spreadDash color) dashes
  return $ concat elements
  --return $
  --  map
  --    (\circ -> Element {elementSrc = circ, elementRule = drawRule Fill color})
  --    circles

noiseWarpCircle :: Ellipse -> Generate Contour
noiseWarpCircle e = do
  World {width, height, ..} <- asks world
  let (V2 x y) = centroid e
  depth :: Int <-
    asks noise >>=
    return .
    (+ 1) .
    abs . round . (* 8) . fromJust . (flip getValue) (x / width, y / height, 0)
  runRand $
    warp
      WarpCfg
      { warpDepth = depth
      , warpWiggleCfg =
          wiggleCfgDefault {yDist = normal 0 3, xDist = normal 0 3}
      } $
    fromJust $ estimateEllipse 10 e

waveDash :: Double -> Generate (V2 Double) -> Generate Contour
waveDash size locationSampler = do
  (V2 x1 y1) <- locationSampler
  let p1 = V2 (x1 - (size / 2)) y1
  let p2 = V2 (x1 + (size / 2)) y1
  let height = size / 20.0
  let base =
        fromJust . contour $
        V.fromList [p1, p2, slideY p2 height, slideX p1 height]
  return base

spreadDash :: RGB Double -> Contour -> Generate [Element]
spreadDash color c = do
  splotchSpread :: Double <- sampleRVar $ normal 0 5 >>= return . (+ 1) . abs
  let (V2 x y) = (toVertices c) V.! 0
  World {width, height, ..} <- asks world
  noiseRot <-
    asks noise >>=
    return .
    (* 2) . (* pi) . fromJust . (flip getValue) (x / width, y / height, 0)
  let wiggleVar = normal 0 splotchSpread
  let waterCfg =
        watercolorCfgDefault
        { watercolorWarpCfg =
            const
              warpCfgDefault
              { warpWiggleCfg =
                  WiggleCfg
                  { xDist = wiggleVar
                  , yDist = wiggleVar
                  , wiggleHint = Just $ const $ \(V2 x y) -> V2 x (y / 5.0)
                  }
              , warpDepth = 1
              }
        , watercolorAnchor = False
        , watercolorLayers = 30
        }
  splotches <- runRand $ watercolor waterCfg c
  return $
    map
      (\s ->
         Element
         { elementSrc = Rot.rotate noiseRot s
         , elementRule = drawRule Fill (color, 0.03 :: Double)
         })
      splotches

treeRing :: Double -> V2 Double -> Generate [Element]
treeRing baseHue center = do
  size <- sampleRVar $ uniform 10 80
  ringCount :: Int <- sampleRVar $ uniform 2 5
  sequence $ map (const $ ring baseHue center size) [1 .. ringCount]

ring :: Double -> V2 Double -> Double -> Generate Element
ring baseHue center trunkSize = do
  proportion <- sampleRVar $ normal 0.5 0.3
  let size = (abs proportion) * trunkSize
  let path = Circle center size
  path' <- noiseWarpCircle path
  hue :: Double <- sampleRVar $ normal baseHue 15
  let color = hsv hue 1 1
  return $
    Element
    {elementSrc = path', elementRule = drawRule Fill (color, 0.8 :: Double)}