pangaea.hs

{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import           Control.Monad.Random.Class
import           Control.Monad.Reader
import           Data.Foldable              (for_)
import           Graphics.Rendering.Cairo   hiding (x, y)
import qualified Numeric.Noise.Perlin       as P
import           System.Random

--
-- Types
--
data Point2d a = Point2d { x :: a, y :: a }

--
-- Utility Functions
--

scaleRGB :: Double -> Double
scaleRGB = (/255)

center :: Double -> Double -> Point2d Double
center w h = Point2d (w/2) (h/2)

data Perlin2d = Perlin2d
  { perlinOctaves     :: Int
  , perlinScale       :: Double
  , perlinPersistance :: Double
  , perlinSeed        :: Double
  , perlinPoint2d     :: Point2d Double
  }

defaultPerlin2d :: Perlin2d
defaultPerlin2d = Perlin2d 5 0.05 0.5 0 (Point2d 0 0)

perlin2d :: Perlin2d -> Double
perlin2d Perlin2d{..} = P.noiseValue perlinNoise (x + perlinSeed, y + perlinSeed, perlinSeed)
 where
  Point2d{..} = perlinPoint2d
  perlinNoise = P.perlin (round perlinSeed) perlinOctaves perlinScale perlinPersistance

distance :: Point2d Double -> Point2d Double -> Double
distance from to = sqrt $ (toX - fromX) ** 2 + (toY - fromY) ** 2
 where
  Point2d{x = fromX, y = fromY} = from
  Point2d{x = toX, y = toY} = to

genIntervals :: (Num a, Ord a, Random a) => a -> a -> IO [(a, a)]
genIntervals intervalStart maxInterval = do
  rand <- uniform [10, 10, 20, 20, 20, 40, 40, 80]
  sep <- uniform [5, 5, 10, 10, 10, 20]

  let
    intervalEnd = intervalStart + rand
    nextIntervalStart = intervalEnd + sep

  if nextIntervalStart > maxInterval
      then pure []
      else do
        tailIntervals <- genIntervals nextIntervalStart maxInterval
        pure $ (intervalStart, intervalEnd) : tailIntervals

--
-- Renderers
--
drawPoint2d :: Double -> Point2d Double -> Render ()
drawPoint2d radius Point2d{..} = arc x y radius 0 (2 * pi)

white :: Double -> Render ()
white = setSourceRGBA 1 1 1

black :: Double -> Render ()
black = setSourceRGBA (scaleRGB 25) (scaleRGB 25) 0

red :: Double -> Render ()
red = setSourceRGBA (scaleRGB 55) (scaleRGB 0) 0

fillWhite :: Double -> Render ()
fillWhite alpha = white alpha *> fill

fillBlack :: Double -> Render ()
fillBlack alpha = black alpha *> fill

fillRed :: Double -> Render ()
fillRed alpha = red alpha *> fill

--
-- Full Renderer
--
render :: Point2d Double -> Double -> Int -> Int -> Render ()
render Point2d{ x = originX, y = originY } seed w h = do
  intervals <- liftIO $ genIntervals 0 (fromIntegral w / 2.6)

  for_ intervals $ \(minDist, maxDist) -> do
    alpha <- liftIO $ randomRIO (0.01,0.07)
    fillColor <- liftIO $ uniform [fillBlack, fillBlack, fillRed]
    for_ [0,1..fromIntegral h] $ \y ->
      for_ [0,1..fromIntegral w] $ \x -> do
        let
          noise = 6 * perlin2d defaultPerlin2d { perlinSeed = seed, perlinPoint2d = Point2d x y, perlinScale = 0.01 }
          noisyOrigin = Point2d (originX + 20 * noise) (originY + 20 * noise)
          point2d = Point2d (x + noise) (y + noise)
          dist = distance noisyOrigin point2d
          drawPoint alphaScale = do
            drawPoint2d 1 point2d
            fillColor $ alphaScale * (2 * noise)

        when (dist > minDist && dist < maxDist) $ drawPoint alpha

--
-- Main Program
--
main :: IO ()
main = do
  let
    w = 1200
    h = 1200
    origin = center (fromIntegral w) (fromIntegral h)
  surface <- createImageSurface FormatARGB32 w h
  renderWith surface $ do
    rectangle 0 0 (fromIntegral w) (fromIntegral h)
    fillWhite 1
    replicateM_ 2 $ do
      seed :: Double <- liftIO $ randomRIO (0,100)
      render origin seed w h

  surfaceWriteToPNG surface "test.png"