{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ADD.Tiles.Basic
( -- * Tiles and their observations
Tile ()
, rasterize
, rasterize'
, toImage
-- * Tile constructors
, empty
, color
, cw
, ccw
, flipH
, flipV
, beside
, rows
, above
, cols
, behind
, quad
, swirl
, nona
-- * Special tiles
, haskell
, sandy
-- * Colors and their observations
, Color
, redChannel
, greenChannel
, blueChannel
, alphaChannel
-- * Color constructors
, pattern Color
, invert
, mask
, over
) where
import Codec.Picture.Png
import Codec.Picture.Types
import Control.Applicative hiding (empty)
import Data.Coerce
import Data.FileEmbed
import Data.Functor.Compose
import Data.Word
import Test.QuickCheck hiding (label)
------------------------------------------------------------------------------
type Color = PixelRGBA8
instance Semigroup Color where
(<>) = over
instance Monoid Color where
mempty = Color 0 0 0 0
color :: Double -> Double -> Double -> Double -> Tile
color r g b a = Tile $ const $ const $ _rgba r g b a
------------------------------------------------------------------------------
-- | Extract the red channel from a 'Color'.
redChannel :: Color -> Double
redChannel (Color r _ _ _) = r
------------------------------------------------------------------------------
-- | Extract the green channel from a 'Color'.
greenChannel :: Color -> Double
greenChannel (Color _ g _ _) = g
------------------------------------------------------------------------------
-- | Extract the blue channel from a 'Color'.
blueChannel :: Color -> Double
blueChannel (Color _ _ b _) = b
------------------------------------------------------------------------------
-- | Extract the alpha channel from a 'Color'.
alphaChannel :: Color -> Double
alphaChannel (Color _ _ _ a) = a
------------------------------------------------------------------------------
-- | Inverts a 'Color' by negating each of its color channels, but leaving the
-- alpha alone.
invert :: Color -> Color
invert (Color r g b a) = Color (1 - r) (1 - g) (1 - b) a
_rgba :: Double -> Double -> Double -> Double -> Color
_rgba r g b a =
PixelRGBA8
(bounded r)
(bounded g)
(bounded b)
(bounded a)
where
bounded :: Double -> Word8
bounded x = round $ x * fromIntegral (maxBound @Word8)
------------------------------------------------------------------------------
-- |
pattern Color :: Double -> Double -> Double -> Double -> Color
pattern Color r g b a <-
PixelRGBA8
(fromIntegral -> (/255) -> r)
(fromIntegral -> (/255) -> g)
(fromIntegral -> (/255) -> b)
(fromIntegral -> (/255) -> a)
where
Color = _rgba
{-# COMPLETE Color #-}
instance Semigroup Tile where
(<>) = behind
instance Monoid Tile where
mempty = mempty
newtype Tile = Tile
{ runTile :: Double -> Double -> Color
}
instance Show Tile where
show _ = "<tile>"
instance Arbitrary Tile where
arbitrary = Tile <$> arbitrary
instance CoArbitrary PixelRGBA8 where
coarbitrary (Color r g b a) = coarbitrary (r, g, b, a)
instance Arbitrary PixelRGBA8 where
arbitrary = PixelRGBA8 <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
------------------------------------------------------------------------------
-- | Rotate a 'Tile' clockwise.
cw :: Tile -> Tile
cw (Tile f) = Tile $ \x y -> f y (1 - x)
------------------------------------------------------------------------------
-- | Rotate a 'Tile' counterclockwise.
ccw :: Tile -> Tile
ccw (Tile f) = Tile $ \x y -> f (1 - y) x
_fromImage :: Image PixelRGBA8 -> Tile
_fromImage img@(Image w h _) = Tile $ \x y ->
pixelAt
img
(max 0 (min (w - 1) (floor $ x * fromIntegral w)))
(max 0 (min (h - 1) (floor $ y * fromIntegral h)))
------------------------------------------------------------------------------
-- | Place the first 'Tile' to the left of the second. Each 'Tile' will receive
-- half of the available width, but keep their full height.
beside :: Tile -> Tile -> Tile
beside (Tile a) (Tile b) = Tile $ \x y ->
case x >= 0.5 of
False -> a (2 * x) y
True -> b (2 * (x - 0.5)) y
------------------------------------------------------------------------------
-- | Place the first 'Tile' above the second. Each 'Tile' will receive half of
-- the available height, but keep their full width.
above :: Tile -> Tile -> Tile
above (Tile a) (Tile b) = Tile $ \x y ->
case y >= 0.5 of
False -> a x (2 * y)
True -> b x (2 * (y - 0.5))
------------------------------------------------------------------------------
-- | Place the first 'Tile' behind the second. The result of this operation is
-- for transparent or semi-transparent pixels in the second argument to be
-- blended via 'over' with those in the first.
behind :: Tile -> Tile -> Tile
behind (Tile a) (Tile b) = Tile $ \x y -> flip over (a x y) (b x y)
------------------------------------------------------------------------------
-- | Mirror a 'Tile' horizontally.
flipH :: Tile -> Tile
flipH (Tile t) = Tile $ \x y ->
t (1 - x) y
------------------------------------------------------------------------------
-- | Mirror a 'Tile' vertically.
flipV :: Tile -> Tile
flipV (Tile t) = Tile $ \x y ->
t x (1 - y)
------------------------------------------------------------------------------
-- | The empty, fully transparent 'Tile'.
empty :: Tile
empty = mempty
------------------------------------------------------------------------------
-- | Like 'above', but repeated. Every element in the list will take up
-- a proportional height of the resulting 'Tile'.
rows :: [Tile] -> Tile
rows [] = mempty
rows ts =
let n = length ts
in Tile $ \x y ->
let i = floor $ fromIntegral n * y
in runTile (ts !! i) x y
------------------------------------------------------------------------------
-- | Like 'beside', but repeated. Every element in the list will take up
-- a proportional width of the resulting 'Tile'.
cols :: [Tile] -> Tile
cols [] = mempty
cols ts =
let n = length ts
in Tile $ \x y ->
let i = floor $ fromIntegral n * x
in runTile (ts !! i) x y
------------------------------------------------------------------------------
-- | Place four 'Tile's in the four quadrants. The first argument is the
-- top-left; the second is the top-right; third: bottom left; fourth: bottom
-- right.
quad :: Tile -> Tile -> Tile -> Tile -> Tile
quad a b c d = (a `beside` b) `above` (c `beside` d)
------------------------------------------------------------------------------
-- | A 'quad' where the given 'Tile' is rotated via 'cw' once more per
-- quadrant.
swirl :: Tile -> Tile
swirl t = quad t (cw t) (ccw t) $ cw $ cw t
------------------------------------------------------------------------------
-- | Puts a frame around a 'Tile'. The first argument is the straight-edge
-- border for the top of the frame. The second argument should be for the
-- top-right corner. The third argument is the 'Tile' that should be framed.
nona :: Tile -> Tile -> Tile -> Tile
nona t tr c =
rows [ cols [ ccw tr, t, tr ]
, cols [ ccw t, c, cw t ]
, cols [ cw (cw tr), cw $ cw t, cw tr ]
]
------------------------------------------------------------------------------
-- | Blends a 'Color' using standard alpha compositing.
over :: Color -> Color -> Color
over (PixelRGBA8 r1 g1 b1 a1) (PixelRGBA8 r2 g2 b2 a2) =
let aa = norm a1
ab = norm a2
a' = aa + ab * (1 - aa)
norm :: Word8 -> Double
norm x = fromIntegral x / 255
unnorm :: Double -> Word8
unnorm x = round $ x * 255
f :: Word8 -> Word8 -> Word8
f a b = unnorm $ (norm a * aa + norm b * ab * (1 - aa)) / a'
in
PixelRGBA8 (f r1 r2) (f g1 g2) (f b1 b2) (unnorm a')
------------------------------------------------------------------------------
-- | Copy the alpha channel from the first 'Color' and the color channels from
-- the second 'Color'.
mask :: Color -> Color -> Color
mask (PixelRGBA8 _ _ _ a) (PixelRGBA8 r g b _) = PixelRGBA8 r g b a
--------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- | Like 'rasterize', but into a format that can be directly saved to disk as
-- an image.
toImage
:: Int -- ^ resulting width
-> Int -- ^ resulting height
-> Tile
-> Image PixelRGBA8
toImage w h (Tile t) = generateImage f w h
where
coord :: Int -> Int -> Double
coord dx x = fromIntegral dx / fromIntegral x
f :: Int -> Int -> PixelRGBA8
f x y = t (coord x w) (coord y h)
------------------------------------------------------------------------------
-- | The Haskell logo.
haskell :: Tile
haskell =
let Right (ImageRGBA8 img) = decodePng $(embedFile "static/haskell.png")
in _fromImage img
------------------------------------------------------------------------------
-- | Sandy.
sandy :: Tile
sandy =
let Right (ImageRGBA8 img) = decodePng $(embedFile "static/sandy.png")
in _fromImage img
------------------------------------------------------------------------------
-- | Rasterize a 'Tile' down into a row-major representation of its constituent
-- "pixels". For a version that emits a list of lists directly, see 'rasterize''.
rasterize
:: Int -- ^ resulting width
-> Int -- ^ resulting heigeht
-> Tile
-> Compose ZipList ZipList Color -- ^ the resulting "pixels" in row-major order
rasterize w h (Tile t) = coerce $ do
y <- [0 .. (h - 1)]
pure $ do
x <- [0 .. (w - 1)]
pure $ f x y
where
coord :: Int -> Int -> Double
coord dx x = fromIntegral dx / fromIntegral x
f :: Int -> Int -> Color
f x y = t (coord x w) (coord y h)
------------------------------------------------------------------------------
-- | Like 'rasterize', but with a more convenient output type.
rasterize'
:: Int -- ^ resulting width
-> Int -- ^ resulting heigeht
-> Tile
-> [[Color]] -- ^ the resulting "pixels" in row-major order
rasterize' w h t = coerce $ rasterize w h t