LineBounce.hs

{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
-- | A "living" module for short-lived experiments.
module Sketch where

import           Algorithms.Bezier                  (ControlPoint (..))
import           Algorithms.Chaikin
import           Algorithms.ConvexHull
import           Algorithms.General
import           Algorithms.PointGeneration
import           Algorithms.PoissonDiskSampling
import           Algorithms.RandomWalk
import           Algorithms.RectSubdivision
import           Algorithms.VectorField
import           Algorithms.VectorMath
import           Color
import           Control.Arrow
import           Control.Lens
import           Control.Monad.Loops
import           Control.Monad.Random
import           Control.Monad.Reader
import           Data.Fixed                         (mod')
import           Data.Foldable
import           Data.Graph
import           Data.List
import qualified Data.Map                           as M
import           Data.Maybe
import           Data.Ord
import qualified Data.Random                        as D
import           Data.Random.Distribution.Bernoulli
import qualified Data.Set                           as Set
import           Data.Traversable
import           Geometry
import           Graphics.Rendering.Cairo
import           Linear.Metric                      hiding (normalize)
import           Linear.V2
import           Linear.Vector
import           Perlin
import           Physics
import           Random
import           Render
import           Render.Lines
import           Render.Textures
import           System.Random.Shuffle
import           World

linen :: HSV
linen = HSV 30 0.04 0.99

charcoal :: HSV
charcoal = HSV 222 0.12 0.12

updateMover :: Mover -> Mover
updateMover = update . applyForce (V2 0.15 0) . applyGravity 1 (V2 0 0.05) . applyFriction 0.03

goMover :: LineSegment -> Mover -> Generate Mover
goMover segment mover = pure $ bounceSegment segment mover nextMover
 where
  nextMover = updateMover mover

genMover :: Generate Mover
genMover = do
  let
    genPositive = newMover
      <$> runRVar (D.uniform 1 20)
      <*> (V2 <$> runRVar (D.normal 0 5) <*> runRVar (D.normal 0 5))
    genNegative = Mover
      <$> (V2 <$> runRVar (D.normal 100 5) <*> runRVar (D.normal 100 5))
      <*> pure (V2 (-2) (-3))
      <*> pure zero
      <*> runRVar (D.uniform 1 20)

  join $ uniform [genPositive, genNegative]

renderSketch :: Generate ()
renderSketch = do
  fillScreenHsv linen

  cairo $ setLineWidth 0.2

  let
    lineSegment = LineSegment (V2 10 90) (V2 90 10)

  theMovers <- replicateM 1000 genMover

  moverss <- for theMovers $ \mover -> iterateMN 200 (goMover lineSegment) mover

  cairo $ do
    drawLineSegment lineSegment
    setSourceHsv charcoal *> stroke

  for_ (transpose moverss) $ \movers -> do
    fillScreenHsv linen
    for_ movers $ \mover -> do
      cairo $ do
        drawLineSegment lineSegment
        setSourceHsv charcoal *> stroke

        drawV2 (mass mover / 10) (location mover)
        setSourceHsv charcoal *> fill

    renderProgress

render :: IO ()
render = mainIOWith (\opts -> opts{ optWidth = 100, optHeight = 100 }) renderSketch