wholepixels 1.0 → 1.1
raw patch · 5 files changed
+146/−132 lines, 5 files
Files
- CHANGELOG.rst +5/−0
- src/WholePixels/Color.hs +25/−22
- src/WholePixels/Geometry.hs +29/−28
- src/WholePixels/Random.hs +86/−81
- wholepixels.cabal +1/−1
CHANGELOG.rst view
@@ -1,4 +1,9 @@ +1.1 (2019-06-26)+================++* Make ormolu-friendly+ 1.0 (2019-06-25) ================
src/WholePixels/Color.hs view
@@ -2,16 +2,20 @@ import Relude -data HSV = HSV- { hsvHue :: Double- , hsvSaturation :: Double- , hsvValue :: Double- } deriving (Show, Read, Eq, Ord)+data HSV+ = HSV+ { hsvHue :: Double+ , hsvSaturation :: Double+ , hsvValue :: Double+ }+ deriving (Show, Read, Eq, Ord) -data WithAlpha color = WithAlpha- { waColor :: color- , waAlpha :: Double- } deriving (Show, Read, Eq, Ord)+data WithAlpha color+ = WithAlpha+ { waColor :: color+ , waAlpha :: Double+ }+ deriving (Show, Read, Eq, Ord) white :: HSV white = HSV 0 0 1@@ -101,29 +105,28 @@ orange = HSV 17 0.89 0.90 fixHue :: Double -> Double-fixHue h | h >= 0 && h < 360 = h-fixHue h | h >= 360 = fixHue $ h - 360-fixHue h = fixHue $ h + 360+fixHue h = h - 360 * fromIntegral (floor @Double @Int h `div` 360) complementary :: HSV -> HSV complementary (HSV h s v) = HSV (fixHue $ h + 180) s v splitComplementary :: HSV -> (HSV, HSV) splitComplementary (HSV h s v) =- (HSV (fixHue $ h + 150) s v, HSV (fixHue $ h + 210) s v)+ (HSV (fixHue $ h + 150) s v, HSV (fixHue $ h + 210) s v) splitTriangle :: HSV -> (HSV, HSV) splitTriangle (HSV h s v) =- (HSV (fixHue $ h + 120) s v, HSV (fixHue $ h + 240) s v)+ (HSV (fixHue $ h + 120) s v, HSV (fixHue $ h + 240) s v) analogous :: HSV -> [HSV] analogous (HSV h s v) =- map- (\dh -> HSV (fixHue $ h + dh) s v)- [0, 30 .. 360]--data Palette = Palette- { baseColor :: !HSV- , colors :: ![HSV]- } deriving (Show, Eq)+ map+ (\dh -> HSV (fixHue $ h + dh) s v)+ [0, 30.. 360] +data Palette+ = Palette+ { baseColor :: !HSV+ , colors :: ![HSV]+ }+ deriving (Show, Eq)
src/WholePixels/Geometry.hs view
@@ -4,8 +4,8 @@ fitGrid :: (Double, Double) -> Int -> ((Int, Int), Double) fitGrid (canvas_w, canvas_h) desired_size =- ((bool swap id (canvas_w > canvas_h) (grid_min, grid_max)), cell_size)- where+ ((bool swap id (canvas_w > canvas_h) (grid_min, grid_max)), cell_size)+ where canvas_max = max canvas_w canvas_h canvas_min = min canvas_w canvas_h grid_min = desired_size@@ -22,17 +22,19 @@ divf x y = x / fromIntegral y angularNeighborhood :: Double -> Double -> Double -> Double-angularNeighborhood center size a = exp (- ((a - center) / size) ^ (2 :: Int))+angularNeighborhood center size a = exp (-((a - center) / size) ^ (2 :: Int)) lerp :: Double -> Double -> Double -> Double lerp a x0 x1 = a * x1 + (1 - a) * x0 data Direction = R | D | L | U- deriving (Show, Eq, Ord, Enum, Bounded)+ deriving (Show, Eq, Ord, Enum, Bounded) -data Rect = Rect- { rx, ry, rw, rh :: !Double- } deriving (Show, Eq)+data Rect+ = Rect+ { rx, ry, rw, rh :: !Double+ }+ deriving (Show, Eq) unitRect :: Rect unitRect = Rect (-1.0) (-1.0) 2.0 2.0@@ -48,10 +50,10 @@ hsplitMod :: (Double -> Double) -> Rect -> [Rect] hsplitMod modh r =- [ r { rh = h' }- , r { rh = rh r - h', ry = ry r + h' }- ]- where+ [ r {rh = h'}+ , r {rh = rh r - h', ry = ry r + h'}+ ]+ where h' = modh $ rh r vsplit :: Rect -> [Rect]@@ -65,10 +67,10 @@ vsplitMod :: (Double -> Double) -> Rect -> [Rect] vsplitMod modw r =- [ r { rw = w' }- , r { rw = rw r - w', rx = rx r + w' }- ]- where+ [ r {rw = w'}+ , r {rw = rw r - w', rx = rx r + w'}+ ]+ where w' = modw $ rw r goldenRatio :: Double@@ -76,30 +78,29 @@ opposite :: Direction -> Direction opposite = \case- R -> L- D -> U- L -> R- U -> D+ R -> L+ D -> U+ L -> R+ U -> D -data CellSpec = Y | N +data CellSpec = Y | N data GridSpec = GridSpec [[CellSpec]] rectangularGridSpec :: Int -> Int -> GridSpec rectangularGridSpec colCount rowCount =- GridSpec (replicate rowCount (replicate colCount Y))+ GridSpec (replicate rowCount (replicate colCount Y)) tesselate :: Int -> GridSpec -> GridSpec tesselate n (GridSpec rows) = GridSpec (concatMap f rows)- where+ where f row = dup (concatMap dup row) dup x = replicate n x calculateCellSize :: (Double, Double) -> GridSpec -> Double calculateCellSize (w, h) (GridSpec gs) =- let colCount = case gs of- (row : _) -> length row- _ -> 0- rowCount = length gs- in min (w / fromIntegral colCount) (h / fromIntegral rowCount)-+ let colCount = case gs of+ (row : _) -> length row+ _ -> 0+ rowCount = length gs+ in min (w / fromIntegral colCount) (h / fromIntegral rowCount)
src/WholePixels/Random.hs view
@@ -1,137 +1,142 @@ module WholePixels.Random where -import Relude import Control.Monad.Random-import WholePixels.Geometry-import WholePixels.Color+import Relude import qualified System.Random.Shuffle+import WholePixels.Color+import WholePixels.Geometry disturbedSequence :: MonadRandom m => [Double] -> Double -> m [Double] disturbedSequence xs amp = do- dxs <- replicateM (length xs) $ getRandomR (-amp, amp)- pure $ zipWith (+) xs dxs+ dxs <- replicateM (length xs) $ getRandomR (-amp, amp)+ pure $ zipWith (+) xs dxs filterRandomly :: MonadRandom m => Double -> [a] -> m [a] filterRandomly probability xs = do- ps <- replicateM (length xs) $ getRandomR (0, 1)- pure [x | (x, p) <- zip xs ps, p < probability]+ ps <- replicateM (length xs) $ getRandomR (0, 1)+ pure [x | (x, p) <- zip xs ps, p < probability] coinToss :: MonadRandom m => m Bool coinToss = uniform [False, True] genGrid :: MonadRandom m => Int -> Int -> m a -> m [(Int, Int, a)] genGrid colCount rowCount genElement =- genGridWithBoundaries colCount rowCount (const genElement)+ genGridWithBoundaries colCount rowCount (const genElement) genGridWithBoundaries :: MonadRandom m => Int -> Int -> ([Direction] -> m a) -> m [(Int, Int, a)] genGridWithBoundaries colCount rowCount genElement = do- let numberGrid = [(x, y) | y <- [0 .. rowCount - 1], x <- [0 .. colCount - 1]]- forM numberGrid $ \(x, y) -> do- let dirs = [ R | x == 0] <> [ D | y == 0] <> [ L | x == colCount - 1] <> [ U | y == rowCount - 1]- (x, y,) <$> genElement dirs+ let numberGrid = [(x, y) | y <- [0.. rowCount - 1], x <- [0.. colCount - 1]]+ forM numberGrid $ \(x, y) -> do+ let dirs = [R | x == 0] <> [D | y == 0] <> [L | x == colCount - 1] <> [U | y == rowCount - 1]+ (x,y,) <$> genElement dirs genGrid' :: MonadRandom m => GridSpec -> ([Direction] -> m a) -> m [(Int, Int, a)] genGrid' (GridSpec gridSpec) genElement = do- let rowCount = length gridSpec- colCount = case gridSpec of- [] -> 0- (row : _) -> length row- numberedGrid :: [(Int, Int, CellSpec)]- numberedGrid = concat $ zipWith+ let rowCount = length gridSpec+ colCount = case gridSpec of+ [] -> 0+ (row : _) -> length row+ numberedGrid :: [(Int, Int, CellSpec)]+ numberedGrid =+ concat $+ zipWith (\j row -> map (\(i, c) -> (i, j, c)) row)- [0..rowCount]- (map- (zip [0..colCount])- gridSpec)- fmap catMaybes . forM numberedGrid $ \(x, y, c) -> do- let dirs = [ R | x == 0] <> [ D | y == 0] <> [ L | x == colCount - 1] <> [ U | y == rowCount - 1]- case c of- N -> pure Nothing- Y -> (Just . (x, y,)) <$> genElement dirs+ [0.. rowCount]+ ( map+ (zip [0.. colCount])+ gridSpec+ )+ fmap catMaybes . forM numberedGrid $ \(x, y, c) -> do+ let dirs = [R | x == 0] <> [D | y == 0] <> [L | x == colCount - 1] <> [U | y == rowCount - 1]+ case c of+ N -> pure Nothing+ Y -> (Just . (x,y,)) <$> genElement dirs probably :: MonadRandom m => Double -> a -> m (Maybe a) probably probability thing = do- x <- getRandomR (0, 1)- pure $- if x < probability- then Just thing- else Nothing+ x <- getRandomR (0, 1)+ pure $+ if x < probability+ then Just thing+ else Nothing shuffleM :: MonadRandom m => [a] -> m [a] shuffleM = System.Random.Shuffle.shuffleM data PaletteStrategy- = Analogous- | Complementary- | SplitComplementary- | Triangle+ = Analogous+ | Complementary+ | SplitComplementary+ | Triangle genPalette :: MonadRandom m => m Palette genPalette = do- strategy <- uniform [Analogous, Complementary, SplitComplementary, Triangle]- genPaletteWithStrategy strategy+ strategy <- uniform [Analogous, Complementary, SplitComplementary, Triangle]+ genPaletteWithStrategy strategy genPaletteWithStrategy :: MonadRandom m => PaletteStrategy -> m Palette genPaletteWithStrategy strategy = do- baseHue <- getRandomR (0, 360)- baseSaturation <- getRandomR (0, 1)- baseValue <- getRandomR (0, 0.5)- bgToFgHueDifference <- uniform [180, 0, 30, 120, 240]- let baseColor = HSV baseHue baseSaturation baseValue- c = HSV (fixHue $ baseHue + bgToFgHueDifference) 1 1- colors = case strategy of- Analogous -> take 4 $ analogous c- Complementary -> take 3 (analogous c) <> [complementary c]- SplitComplementary ->- let (c1, c2) = splitComplementary c- in [c, c1, c2]- Triangle ->- let (c1, c2) = splitTriangle c- in [c, c1, c2]- pure $ Palette {..}+ baseHue <- getRandomR (0, 360)+ baseSaturation <- getRandomR (0, 1)+ baseValue <- getRandomR (0, 0.5)+ bgToFgHueDifference <- uniform [180, 0, 30, 120, 240]+ let baseColor = HSV baseHue baseSaturation baseValue+ c = HSV (fixHue $ baseHue + bgToFgHueDifference) 1 1+ colors = case strategy of+ Analogous -> take 4 $ analogous c+ Complementary -> take 3 (analogous c) <> [complementary c]+ SplitComplementary ->+ let (c1, c2) = splitComplementary c+ in [c, c1, c2]+ Triangle ->+ let (c1, c2) = splitTriangle c+ in [c, c1, c2]+ pure $ Palette {..} genMonochromePaletteForColor :: MonadRandom m => HSV -> m Palette genMonochromePaletteForColor baseColor@(HSV bh bs bv) = do- let colors = [HSV bh bs v | v <- [bv + 0.15, bv + 0.2 .. 1]]- pure $ Palette {..}+ let colors = [HSV bh bs v | v <- [bv + 0.15, bv + 0.2.. 1]]+ pure $ Palette {..} genMonochromePalette :: MonadRandom m => Double -> m Palette genMonochromePalette maxSaturation = do- hue <- getRandomR (0, 360)- saturation <- getRandomR (0.0, maxSaturation)- baseValue <- getRandomR (0, 0.5)- let baseColor = HSV hue saturation baseValue- colors = [HSV hue saturation v | v <- [baseValue + 0.15, baseValue + 0.2 .. 1]]- pure $ Palette {..}+ hue <- getRandomR (0, 360)+ saturation <- getRandomR (0.0, maxSaturation)+ baseValue <- getRandomR (0, 0.5)+ let baseColor = HSV hue saturation baseValue+ colors = [HSV hue saturation v | v <- [baseValue + 0.15, baseValue + 0.2.. 1]]+ pure $ Palette {..} genColor' :: MonadRandom m => Palette -> m HSV genColor' pal = genColor pal 0.5 1.0 genColor :: MonadRandom m => Palette -> Double -> Double -> m HSV genColor Palette {..} expected sigma2 = do- let colorCount = length (baseColor : take 10 colors)- colorPositions = take colorCount [0.0, (1.0 / fromIntegral colorCount) ..]- weights = map- (\p -> toRational $ 1000.0 * exp (- (p - expected) * (p - expected) / sigma2))- colorPositions- weighted $ zip (baseColor : colors) weights+ let colorCount = length (baseColor : take 10 colors)+ colorPositions = take colorCount [0.0, (1.0 / fromIntegral colorCount)..]+ weights =+ map+ (\p -> toRational $ 1000.0 * exp (-(p - expected) * (p - expected) / sigma2))+ colorPositions+ weighted $ zip (baseColor : colors) weights genRectSubdivision :: forall m. MonadRandom m => Int -> Rect -> m [Rect] genRectSubdivision depth r = foldr (>=>) pure (replicate depth step) [r]- where+ where step :: [Rect] -> m [Rect] step rs = concat <$> mapM go rs go :: Rect -> m [Rect] go r' = do- let hbonusWeight = if rh r' > rw r' then 15 else 0- vbonusWeight = if rw r' > rh r' then 15 else 0- f <- weighted- [ (pure . pure, 3)- , (pure . hsplit, 1 + hbonusWeight)- , (pure . hsplitGolden, 3 + hbonusWeight)- , (pure . hsplitReverseGolden, 3 + hbonusWeight)- , (pure . vsplit, 1 + vbonusWeight)- , (pure . vsplitGolden, 3 + vbonusWeight)- , (pure . vsplitReverseGolden, 3 + vbonusWeight)- ]- f r'+ let hbonusWeight = if rh r' > rw r' then 15 else 0+ vbonusWeight = if rw r' > rh r' then 15 else 0+ f <-+ weighted+ [ (pure . pure, 3)+ , (pure . hsplit, 1 + hbonusWeight)+ , (pure . hsplitGolden, 3 + hbonusWeight)+ , (pure . hsplitReverseGolden, 3 + hbonusWeight)+ , (pure . vsplit, 1 + vbonusWeight)+ , (pure . vsplitGolden, 3 + vbonusWeight)+ , (pure . vsplitReverseGolden, 3 + vbonusWeight)+ ]+ f r'
wholepixels.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: wholepixels-version: 1.0+version: 1.1 description: A library for making generative art with Haskell and Cairo author: WholePixels maintainer: wholepixels@protonmail.com