daily pastebin goal
85%
SHARE
TWEET

Untitled

a guest Feb 23rd, 2018 57 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE RecordWildCards     #-}
  2. {-# LANGUAGE ScopedTypeVariables #-}
  3. module Main where
  4.  
  5. import           Control.Monad.Random.Class
  6. import           Control.Monad.Reader
  7. import           Data.Foldable              (for_)
  8. import           Graphics.Rendering.Cairo   hiding (x, y)
  9. import qualified Numeric.Noise.Perlin       as P
  10. import           System.Random
  11.  
  12. --
  13. -- Types
  14. --
  15. data Point2d a = Point2d { x :: a, y :: a }
  16.  
  17. --
  18. -- Utility Functions
  19. --
  20.  
  21. scaleRGB :: Double -> Double
  22. scaleRGB = (/255)
  23.  
  24. center :: Double -> Double -> Point2d Double
  25. center w h = Point2d (w/2) (h/2)
  26.  
  27. data Perlin2d = Perlin2d
  28.   { perlinOctaves     :: Int
  29.   , perlinScale       :: Double
  30.   , perlinPersistance :: Double
  31.   , perlinSeed        :: Double
  32.   , perlinPoint2d     :: Point2d Double
  33.   }
  34.  
  35. defaultPerlin2d :: Perlin2d
  36. defaultPerlin2d = Perlin2d 5 0.05 0.5 0 (Point2d 0 0)
  37.  
  38. perlin2d :: Perlin2d -> Double
  39. perlin2d Perlin2d{..} = P.noiseValue perlinNoise (x + perlinSeed, y + perlinSeed, perlinSeed)
  40.  where
  41.   Point2d{..} = perlinPoint2d
  42.   perlinNoise = P.perlin (round perlinSeed) perlinOctaves perlinScale perlinPersistance
  43.  
  44. distance :: Point2d Double -> Point2d Double -> Double
  45. distance from to = sqrt $ (toX - fromX) ** 2 + (toY - fromY) ** 2
  46.  where
  47.   Point2d{x = fromX, y = fromY} = from
  48.   Point2d{x = toX, y = toY} = to
  49.  
  50. genIntervals :: (Num a, Ord a, Random a) => a -> a -> IO [(a, a)]
  51. genIntervals intervalStart maxInterval = do
  52.   rand <- uniform [10, 10, 20, 20, 20, 40, 40, 80]
  53.   sep <- uniform [5, 5, 10, 10, 10, 20]
  54.  
  55.   let
  56.     intervalEnd = intervalStart + rand
  57.     nextIntervalStart = intervalEnd + sep
  58.  
  59.   if nextIntervalStart > maxInterval
  60.       then pure []
  61.       else do
  62.         tailIntervals <- genIntervals nextIntervalStart maxInterval
  63.         pure $ (intervalStart, intervalEnd) : tailIntervals
  64.  
  65. --
  66. -- Renderers
  67. --
  68. drawPoint2d :: Double -> Point2d Double -> Render ()
  69. drawPoint2d radius Point2d{..} = arc x y radius 0 (2 * pi)
  70.  
  71. white :: Double -> Render ()
  72. white = setSourceRGBA 1 1 1
  73.  
  74. black :: Double -> Render ()
  75. black = setSourceRGBA (scaleRGB 25) (scaleRGB 25) 0
  76.  
  77. red :: Double -> Render ()
  78. red = setSourceRGBA (scaleRGB 55) (scaleRGB 0) 0
  79.  
  80. fillWhite :: Double -> Render ()
  81. fillWhite alpha = white alpha *> fill
  82.  
  83. fillBlack :: Double -> Render ()
  84. fillBlack alpha = black alpha *> fill
  85.  
  86. fillRed :: Double -> Render ()
  87. fillRed alpha = red alpha *> fill
  88.  
  89. --
  90. -- Full Renderer
  91. --
  92. render :: Point2d Double -> Double -> Int -> Int -> Render ()
  93. render Point2d{ x = originX, y = originY } seed w h = do
  94.   intervals <- liftIO $ genIntervals 0 (fromIntegral w / 2.6)
  95.  
  96.   for_ intervals $ \(minDist, maxDist) -> do
  97.     alpha <- liftIO $ randomRIO (0.01,0.07)
  98.     fillColor <- liftIO $ uniform [fillBlack, fillBlack, fillRed]
  99.     for_ [0,1..fromIntegral h] $ \y ->
  100.       for_ [0,1..fromIntegral w] $ \x -> do
  101.         let
  102.           noise = 6 * perlin2d defaultPerlin2d { perlinSeed = seed, perlinPoint2d = Point2d x y, perlinScale = 0.01 }
  103.           noisyOrigin = Point2d (originX + 20 * noise) (originY + 20 * noise)
  104.           point2d = Point2d (x + noise) (y + noise)
  105.           dist = distance noisyOrigin point2d
  106.           drawPoint alphaScale = do
  107.             drawPoint2d 1 point2d
  108.             fillColor $ alphaScale * (2 * noise)
  109.  
  110.         when (dist > minDist && dist < maxDist) $ drawPoint alpha
  111.  
  112. --
  113. -- Main Program
  114. --
  115. main :: IO ()
  116. main = do
  117.   let
  118.     w = 1200
  119.     h = 1200
  120.     origin = center (fromIntegral w) (fromIntegral h)
  121.   surface <- createImageSurface FormatARGB32 w h
  122.   renderWith surface $ do
  123.     rectangle 0 0 (fromIntegral w) (fromIntegral h)
  124.     fillWhite 1
  125.     replicateM_ 2 $ do
  126.       seed :: Double <- liftIO $ randomRIO (0,100)
  127.       render origin seed w h
  128.  
  129.   surfaceWriteToPNG surface "test.png"
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top