Skip to content

Instantly share code, notes, and snippets.

@5outh
Last active Apr 11, 2018
Embed
What would you like to do?
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment