• API
• FAQ
• Tools
• Archive
daily pastebin goal
43%
SHARE
TWEET

# Untitled

a guest Feb 23rd, 2018 58 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.
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.

Top