5outh · May 8, 2018 23:22 · Apr 23, 2018 · Apr 23, 2018
diff --git a/Sketch.hs b/Sketch.hs
@@ -0,0 +1,71 @@
+module Sketch where
+
+import Data.Space2d
+-- (Other imports omitted)
+
+-- | Generate a unit vector space given a size
+randomSpace2d :: Rational -> Generate (Space2d (V2 Double))
+randomSpace2d size = do
+  (w, h) <- getSize
+  let
+    xs = [0,size..w]
+    ys = [0,size..h]
+    indices = V2 <$> xs <*> ys
+
+  list <- for indices $ \index -> do
+    theta <- randomAngle
+    pure (index, angle theta ^* 3)
+
+  pure $ Space2d.fromList size list
+
+times :: Int -> (a -> a) -> (a -> a)
+times n f = foldl' (.) id $ replicate n f
+
+stepThrough :: Space2d (V2 Double) -> V2 Double -> Maybe (V2 Double)
+stepThrough space v = M.lookup index (getSpace2d space)
+ where
+  index = V2
+    (nearestMultipleOf (spaceSize space) (toRational $ v ^. _x))
+    (nearestMultipleOf (spaceSize space) (toRational $ v ^. _y))
+
+pathThrough :: Int -> Space2d (V2 Double) -> V2 Double -> [V2 Double]
+pathThrough maxSteps space v = go maxSteps v []
+ where
+  go 0 _ acc = acc
+  go n currentPoint acc = case stepThrough space currentPoint of
+    Nothing  -> acc
+    Just vec -> go (pred n) (currentPoint + vec) ((currentPoint + vec):acc)
+
+renderSketch :: Generate ()
+renderSketch = do
+  fillScreenHsv linen
+
+  cairo $ setLineWidth 0.2
+  cairo $ setLineJoin LineJoinRound
+
+  space <- randomSpace2d (1 % 2)
+
+  center <- getCenterPoint
+  let
+    centerCircle = Circle 25 center
+
+  boundingRect <- scaleRect 0.5 <$> getBoundingRect
+
+  points <- generatePoisson boundingRect 1 30
+
+  let
+    smoothedSpace = times 15 (spaceFilter average) space
+
+  p <- randomPoint
+
+  for_ points $ \point -> do
+    cairo $ setLineWidth $ distance p point / 500
+
+    cairo $ do
+      let
+        path = pathThrough 10 smoothedSpace point
+      drawPath (chaikinN 5 path)
+      setSourceHsv charcoal *> stroke
+
+render :: IO ()
+render = mainIOWith (\opts -> opts{ optWidth = 10 * 10, optHeight = 10 * 10 }) renderSketch
diff --git a/Space2d.hs b/Space2d.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveFunctor       #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.Space2d where
+
+import           Algorithms.VectorMath
+import           Data.List
+import qualified Data.Map.Strict       as M
+import           Data.Maybe
+import           Linear.V2
+
+data Space2d a = Space2d
+  { spaceSize  :: Rational
+  , getSpace2d :: M.Map (V2 Rational) a
+  } deriving (Functor)
+
+fromList :: Rational -> [(V2 Rational, a)] -> Space2d a
+fromList size = Space2d size . M.fromList
+
+-- | Shim so we don't have to redefine all of the Map operations
+liftMap :: (M.Map (V2 Rational) a -> M.Map (V2 Rational) a) -> Space2d a -> Space2d a
+liftMap f (Space2d size m) = Space2d size (f m)
+
+neighborIndices :: V2 Rational -> Space2d a -> [V2 Rational]
+neighborIndices v (Space2d size _) =
+  [ v + V2 0 (-size)
+  , v + V2 0 size
+  , v + V2 size (-size)
+  , v + V2 size 0
+  , v + V2 size size
+  , v + V2 (-size) (-size)
+  , v + V2 (-size) 0
+  , v + V2 (-size) size
+  ]
+
+average :: (Num a, Fractional a) => [a] -> a
+average xs = sum xs / genericLength xs
+
+smoothSpace2d :: (Num a, Fractional a) => Space2d a -> Space2d a
+smoothSpace2d = spaceFilter average
+
+spaceFilter :: ([a] -> a) -> Space2d a -> Space2d a
+spaceFilter f space = liftMap (M.mapWithKey smooth) space
+ where
+  smooth k v = f $ mapMaybe (`M.lookup` getSpace2d space) (neighborIndices k space)
+
+nearestMultipleOf :: Rational -> Rational -> Rational
+nearestMultipleOf size n = fromIntegral (round (n / size)) * size
No results found