{-# 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.Functor
  ( -- * Tiles and their observations
    Tile ()
  , rasterize
  , rasterize'
  , toImage

    -- * Tile constructors
  , empty
  , color
  , cw
  , ccw
  , flipH
  , flipV
  , beside
  , rows
  , above
  , cols
  , behind
  , quad
  , quads
  , 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
  <> :: Color -> Color -> Color
(<>) = Color -> Color -> Color
over

instance Monoid Color where
  mempty :: Color
mempty = Double -> Double -> Double -> Double -> Color
Color 0 0 0 0

color :: Double -> Double -> Double -> Double -> Tile Color
color :: Double -> Double -> Double -> Double -> Tile Color
color r :: Double
r g :: Double
g b :: Double
b a :: Double
a = Color -> Tile Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Color -> Tile Color) -> Color -> Tile Color
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> Color
_rgba Double
r Double
g Double
b Double
a

------------------------------------------------------------------------------
-- | Extract the red channel from a 'Color'.
redChannel :: Color -> Double
redChannel :: Color -> Double
redChannel (Color r :: Double
r _ _ _) = Double
r

------------------------------------------------------------------------------
-- | Extract the green channel from a 'Color'.
greenChannel :: Color -> Double
greenChannel :: Color -> Double
greenChannel (Color _ g :: Double
g _ _) = Double
g

------------------------------------------------------------------------------
-- | Extract the blue channel from a 'Color'.
blueChannel :: Color -> Double
blueChannel :: Color -> Double
blueChannel (Color _ _ b :: Double
b _) = Double
b

------------------------------------------------------------------------------
-- | Extract the alpha channel from a 'Color'.
alphaChannel :: Color -> Double
alphaChannel :: Color -> Double
alphaChannel (Color _ _ _ a :: Double
a) = Double
a

------------------------------------------------------------------------------
-- | Inverts a 'Color' by negating each of its color channels, but leaving the
-- alpha alone.
invert :: Color -> Color
invert :: Color -> Color
invert (Color r :: Double
r g :: Double
g b :: Double
b a :: Double
a) = Double -> Double -> Double -> Double -> Color
Color (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
r) (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
g) (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b) Double
a


_rgba :: Double -> Double -> Double -> Double -> Color
_rgba :: Double -> Double -> Double -> Double -> Color
_rgba r :: Double
r g :: Double
g b :: Double
b a :: Double
a =
  Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
PixelRGBA8
    (Double -> Pixel8
bounded Double
r)
    (Double -> Pixel8
bounded Double
g)
    (Double -> Pixel8
bounded Double
b)
    (Double -> Pixel8
bounded Double
a)
  where
    bounded :: Double -> Word8
    bounded :: Double -> Pixel8
bounded x :: Double
x = Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Pixel8) -> Double -> Pixel8
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Pixel8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bounded Pixel8 => Pixel8
forall a. Bounded a => a
maxBound @Word8)

------------------------------------------------------------------------------
-- |
pattern Color :: Double -> Double -> Double -> Double -> Color
pattern $bColor :: Double -> Double -> Double -> Double -> Color
$mColor :: forall r.
Color
-> (Double -> Double -> Double -> Double -> r) -> (Void# -> r) -> r
Color r g b a <-
  PixelRGBA8
    (fromIntegral -> (/255) -> r)
    (fromIntegral -> (/255) -> g)
    (fromIntegral -> (/255) -> b)
    (fromIntegral -> (/255) -> a)
  where
    Color = Double -> Double -> Double -> Double -> Color
_rgba
{-# COMPLETE Color #-}

instance Semigroup a => Semigroup (Tile a) where
  <> :: Tile a -> Tile a -> Tile a
(<>) = (a -> a -> a) -> Tile a -> Tile a -> Tile a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => Monoid (Tile a) where
  mempty :: Tile a
mempty = a -> Tile a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty


newtype Tile a = Tile
  { Tile a -> Double -> Double -> a
runTile :: Double -> Double -> a
  }
  deriving stock (a -> Tile b -> Tile a
(a -> b) -> Tile a -> Tile b
(forall a b. (a -> b) -> Tile a -> Tile b)
-> (forall a b. a -> Tile b -> Tile a) -> Functor Tile
forall a b. a -> Tile b -> Tile a
forall a b. (a -> b) -> Tile a -> Tile b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Tile b -> Tile a
$c<$ :: forall a b. a -> Tile b -> Tile a
fmap :: (a -> b) -> Tile a -> Tile b
$cfmap :: forall a b. (a -> b) -> Tile a -> Tile b
Functor)
  deriving Functor Tile
a -> Tile a
Functor Tile =>
(forall a. a -> Tile a)
-> (forall a b. Tile (a -> b) -> Tile a -> Tile b)
-> (forall a b c. (a -> b -> c) -> Tile a -> Tile b -> Tile c)
-> (forall a b. Tile a -> Tile b -> Tile b)
-> (forall a b. Tile a -> Tile b -> Tile a)
-> Applicative Tile
Tile a -> Tile b -> Tile b
Tile a -> Tile b -> Tile a
Tile (a -> b) -> Tile a -> Tile b
(a -> b -> c) -> Tile a -> Tile b -> Tile c
forall a. a -> Tile a
forall a b. Tile a -> Tile b -> Tile a
forall a b. Tile a -> Tile b -> Tile b
forall a b. Tile (a -> b) -> Tile a -> Tile b
forall a b c. (a -> b -> c) -> Tile a -> Tile b -> Tile c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Tile a -> Tile b -> Tile a
$c<* :: forall a b. Tile a -> Tile b -> Tile a
*> :: Tile a -> Tile b -> Tile b
$c*> :: forall a b. Tile a -> Tile b -> Tile b
liftA2 :: (a -> b -> c) -> Tile a -> Tile b -> Tile c
$cliftA2 :: forall a b c. (a -> b -> c) -> Tile a -> Tile b -> Tile c
<*> :: Tile (a -> b) -> Tile a -> Tile b
$c<*> :: forall a b. Tile (a -> b) -> Tile a -> Tile b
pure :: a -> Tile a
$cpure :: forall a. a -> Tile a
$cp1Applicative :: Functor Tile
Applicative via (Compose ((->) Double) ((->) Double))

instance Show (Tile t) where
  show :: Tile t -> String
show _ = "<tile>"

instance Arbitrary a => Arbitrary (Tile a) where
  arbitrary :: Gen (Tile a)
arbitrary = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> Gen (Double -> Double -> a) -> Gen (Tile a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Double -> Double -> a)
forall a. Arbitrary a => Gen a
arbitrary

instance CoArbitrary PixelRGBA8 where
  coarbitrary :: Color -> Gen b -> Gen b
coarbitrary (Color r :: Double
r g :: Double
g b :: Double
b a :: Double
a) = (Double, Double, Double, Double) -> Gen b -> Gen b
forall a b. CoArbitrary a => a -> Gen b -> Gen b
coarbitrary (Double
r, Double
g, Double
b, Double
a)

instance Arbitrary PixelRGBA8 where
  arbitrary :: Gen Color
arbitrary = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
PixelRGBA8 (Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color)
-> Gen Pixel8 -> Gen (Pixel8 -> Pixel8 -> Pixel8 -> Color)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Pixel8
forall a. Arbitrary a => Gen a
arbitrary Gen (Pixel8 -> Pixel8 -> Pixel8 -> Color)
-> Gen Pixel8 -> Gen (Pixel8 -> Pixel8 -> Color)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pixel8
forall a. Arbitrary a => Gen a
arbitrary Gen (Pixel8 -> Pixel8 -> Color)
-> Gen Pixel8 -> Gen (Pixel8 -> Color)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pixel8
forall a. Arbitrary a => Gen a
arbitrary Gen (Pixel8 -> Color) -> Gen Pixel8 -> Gen Color
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Pixel8
forall a. Arbitrary a => Gen a
arbitrary

instance Monad Tile where
  Tile ma :: Double -> Double -> a
ma >>= :: Tile a -> (a -> Tile b) -> Tile b
>>= f :: a -> Tile b
f = (Double -> Double -> b) -> Tile b
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> b) -> Tile b)
-> (Double -> Double -> b) -> Tile b
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y -> Tile b -> Double -> Double -> b
forall a. Tile a -> Double -> Double -> a
runTile (a -> Tile b
f (Double -> Double -> a
ma Double
x Double
y)) Double
x Double
y

------------------------------------------------------------------------------
-- | Rotate a 'Tile' clockwise.
cw :: Tile a -> Tile a
cw :: Tile a -> Tile a
cw (Tile f :: Double -> Double -> a
f) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y -> Double -> Double -> a
f Double
y (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x)


------------------------------------------------------------------------------
-- | Rotate a 'Tile' counterclockwise.
ccw :: Tile a -> Tile a
ccw :: Tile a -> Tile a
ccw (Tile f :: Double -> Double -> a
f) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y -> Double -> Double -> a
f (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y) Double
x

_fromImage :: Image PixelRGBA8 -> Tile Color
_fromImage :: Image Color -> Tile Color
_fromImage img :: Image Color
img@(Image w :: Int
w h :: Int
h _) = (Double -> Double -> Color) -> Tile Color
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> Color) -> Tile Color)
-> (Double -> Double -> Color) -> Tile Color
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
  Image Color -> Int -> Int -> Color
forall a. Pixel a => Image a -> Int -> Int -> a
pixelAt
    Image Color
img
    (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w)))
    (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 a -> Tile a -> Tile a
beside :: Tile a -> Tile a -> Tile a
beside (Tile a :: Double -> Double -> a
a) (Tile b :: Double -> Double -> a
b) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
  case Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= 0.5 of
    False -> Double -> Double -> a
a (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x) Double
y
    True  -> Double -> Double -> a
b (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- 0.5)) Double
y


------------------------------------------------------------------------------
-- | Place the first 'Tile' above the second. Each 'Tile' will receive half of
-- the available height, but keep their full width.
above :: Tile a -> Tile a -> Tile a
above :: Tile a -> Tile a -> Tile a
above (Tile a :: Double -> Double -> a
a) (Tile b :: Double -> Double -> a
b) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
  case Double
y Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= 0.5 of
    False -> Double -> Double -> a
a Double
x (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
    True  -> Double -> Double -> a
b Double
x (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- 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 Color -> Tile Color -> Tile Color
behind :: Tile Color -> Tile Color -> Tile Color
behind = (Tile Color -> Tile Color -> Tile Color)
-> Tile Color -> Tile Color -> Tile Color
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Color -> Color -> Color) -> Tile Color -> Tile Color -> Tile Color
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Color -> Color -> Color
over)


------------------------------------------------------------------------------
-- | Mirror a 'Tile' horizontally.
flipH :: Tile a -> Tile a
flipH :: Tile a -> Tile a
flipH (Tile t :: Double -> Double -> a
t) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
  Double -> Double -> a
t (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
x) Double
y


------------------------------------------------------------------------------
-- | Mirror a 'Tile' vertically.
flipV :: Tile a -> Tile a
flipV :: Tile a -> Tile a
flipV (Tile t :: Double -> Double -> a
t) = (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
  Double -> Double -> a
t Double
x (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y)


------------------------------------------------------------------------------
-- | The empty, fully transparent 'Tile'.
empty :: Tile Color
empty :: Tile Color
empty = Color -> Tile Color
forall (f :: * -> *) a. Applicative f => a -> f a
pure Color
forall a. Monoid a => a
mempty


------------------------------------------------------------------------------
-- | Like 'above', but repeated. Every element in the list will take up
-- a proportional height of the resulting 'Tile'.
rows :: Monoid a => [Tile a] -> Tile a
rows :: [Tile a] -> Tile a
rows [] = Tile a
forall a. Monoid a => a
mempty
rows ts :: [Tile a]
ts =
  let n :: Int
n = [Tile a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tile a]
ts
   in (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
        let i :: Int
i = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y
         in Tile a -> Double -> Double -> a
forall a. Tile a -> Double -> Double -> a
runTile ([Tile a]
ts [Tile a] -> Int -> Tile a
forall a. [a] -> Int -> a
!! Int
i) Double
x Double
y


------------------------------------------------------------------------------
-- | Like 'beside', but repeated. Every element in the list will take up
-- a proportional width of the resulting 'Tile'.
cols :: Monoid a => [Tile a] -> Tile a
cols :: [Tile a] -> Tile a
cols [] = Tile a
forall a. Monoid a => a
mempty
cols ts :: [Tile a]
ts =
  let n :: Int
n = [Tile a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tile a]
ts
   in (Double -> Double -> a) -> Tile a
forall a. (Double -> Double -> a) -> Tile a
Tile ((Double -> Double -> a) -> Tile a)
-> (Double -> Double -> a) -> Tile a
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y ->
        let i :: Int
i = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x
         in Tile a -> Double -> Double -> a
forall a. Tile a -> Double -> Double -> a
runTile ([Tile a]
ts [Tile a] -> Int -> Tile a
forall a. [a] -> Int -> a
!! Int
i) Double
x Double
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 a -> Tile a -> Tile a -> Tile a -> Tile a
quad :: Tile a -> Tile a -> Tile a -> Tile a -> Tile a
quad a :: Tile a
a b :: Tile a
b c :: Tile a
c d :: Tile a
d = (Tile a
a Tile a -> Tile a -> Tile a
forall a. Tile a -> Tile a -> Tile a
`beside` Tile a
b) Tile a -> Tile a -> Tile a
forall a. Tile a -> Tile a -> Tile a
`above` (Tile a
c Tile a -> Tile a -> Tile a
forall a. Tile a -> Tile a -> Tile a
`beside` Tile a
d)

------------------------------------------------------------------------------
-- | Like `quad`, but constructs a 'Tile' of endomorphisms. The given function
-- is called one more time for each quadrant, starting clockwise from the
-- top-left.
quads :: (a -> a) -> Tile (a -> a)
quads :: (a -> a) -> Tile (a -> a)
quads f :: a -> a
f =
  Tile (a -> a)
-> Tile (a -> a) -> Tile (a -> a) -> Tile (a -> a) -> Tile (a -> a)
forall a. Tile a -> Tile a -> Tile a -> Tile a -> Tile a
quad
    ((a -> a) -> Tile (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id)
    ((a -> a) -> Tile (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
f)
    ((a -> a) -> Tile (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> a) -> Tile (a -> a)) -> (a -> a) -> Tile (a -> a)
forall a b. (a -> b) -> a -> b
$ a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)
    ((a -> a) -> Tile (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> a) -> Tile (a -> a)) -> (a -> a) -> Tile (a -> a)
forall a b. (a -> b) -> a -> b
$ a -> a
f (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)


------------------------------------------------------------------------------
-- | A 'quad' where the given 'Tile' is rotated via 'cw' once more per
-- quadrant.
swirl :: Tile a -> Tile a
swirl :: Tile a -> Tile a
swirl t :: Tile a
t = Tile a -> Tile a -> Tile a -> Tile a -> Tile a
forall a. Tile a -> Tile a -> Tile a -> Tile a -> Tile a
quad Tile a
t (Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
t) (Tile a -> Tile a
forall a. Tile a -> Tile a
ccw Tile a
t) (Tile a -> Tile a) -> Tile a -> Tile a
forall a b. (a -> b) -> a -> b
$ Tile a -> Tile a
forall a. Tile a -> Tile a
cw (Tile a -> Tile a) -> Tile a -> Tile a
forall a b. (a -> b) -> a -> b
$ Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
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 :: Monoid a => Tile a -> Tile a -> Tile a -> Tile a
nona :: Tile a -> Tile a -> Tile a -> Tile a
nona t :: Tile a
t tr :: Tile a
tr c :: Tile a
c =
  [Tile a] -> Tile a
forall a. Monoid a => [Tile a] -> Tile a
rows [ [Tile a] -> Tile a
forall a. Monoid a => [Tile a] -> Tile a
cols [ Tile a -> Tile a
forall a. Tile a -> Tile a
ccw Tile a
tr,      Tile a
t,         Tile a
tr    ]
       , [Tile a] -> Tile a
forall a. Monoid a => [Tile a] -> Tile a
cols [ Tile a -> Tile a
forall a. Tile a -> Tile a
ccw Tile a
t,       Tile a
c,         Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
t  ]
       , [Tile a] -> Tile a
forall a. Monoid a => [Tile a] -> Tile a
cols [ Tile a -> Tile a
forall a. Tile a -> Tile a
cw (Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
tr),  Tile a -> Tile a
forall a. Tile a -> Tile a
cw (Tile a -> Tile a) -> Tile a -> Tile a
forall a b. (a -> b) -> a -> b
$ Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
t, Tile a -> Tile a
forall a. Tile a -> Tile a
cw Tile a
tr ]
       ]

------------------------------------------------------------------------------
-- | Blends a 'Color' using standard alpha compositing.
over :: Color -> Color -> Color
over :: Color -> Color -> Color
over (PixelRGBA8 r1 :: Pixel8
r1 g1 :: Pixel8
g1 b1 :: Pixel8
b1 a1 :: Pixel8
a1) (PixelRGBA8 r2 :: Pixel8
r2 g2 :: Pixel8
g2 b2 :: Pixel8
b2 a2 :: Pixel8
a2) =
  let aa :: Double
aa = Pixel8 -> Double
norm Pixel8
a1
      ab :: Double
ab = Pixel8 -> Double
norm Pixel8
a2
      a' :: Double
a' = Double
aa Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
ab Double -> Double -> Double
forall a. Num a => a -> a -> a
* (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aa)
      norm :: Word8 -> Double
      norm :: Pixel8 -> Double
norm x :: Pixel8
x = Pixel8 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pixel8
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 255
      unnorm :: Double -> Word8
      unnorm :: Double -> Pixel8
unnorm x :: Double
x = Double -> Pixel8
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Pixel8) -> Double -> Pixel8
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* 255
      f :: Word8 -> Word8 -> Word8
      f :: Pixel8 -> Pixel8 -> Pixel8
f a :: Pixel8
a b :: Pixel8
b = Double -> Pixel8
unnorm (Double -> Pixel8) -> Double -> Pixel8
forall a b. (a -> b) -> a -> b
$ (Pixel8 -> Double
norm Pixel8
a Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
aa Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Pixel8 -> Double
norm Pixel8
b Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
ab Double -> Double -> Double
forall a. Num a => a -> a -> a
* (1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
aa)) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
a'
   in
  Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
PixelRGBA8 (Pixel8 -> Pixel8 -> Pixel8
f Pixel8
r1 Pixel8
r2) (Pixel8 -> Pixel8 -> Pixel8
f Pixel8
g1 Pixel8
g2) (Pixel8 -> Pixel8 -> Pixel8
f Pixel8
b1 Pixel8
b2) (Double -> Pixel8
unnorm Double
a')


------------------------------------------------------------------------------
-- | Copy the alpha channel from the first 'Color' and the color channels from
-- the second 'Color'.
mask :: Color -> Color -> Color
mask :: Color -> Color -> Color
mask (PixelRGBA8 _ _ _ a :: Pixel8
a) (PixelRGBA8 r :: Pixel8
r g :: Pixel8
g b :: Pixel8
b _) = Pixel8 -> Pixel8 -> Pixel8 -> Pixel8 -> Color
PixelRGBA8 Pixel8
r Pixel8
g Pixel8
b Pixel8
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 Color
    -> Image PixelRGBA8
toImage :: Int -> Int -> Tile Color -> Image Color
toImage w :: Int
w h :: Int
h (Tile t :: Double -> Double -> Color
t) = (Int -> Int -> Color) -> Int -> Int -> Image Color
forall px. Pixel px => (Int -> Int -> px) -> Int -> Int -> Image px
generateImage Int -> Int -> Color
f Int
w Int
h
  where
    coord :: Int -> Int -> Double
    coord :: Int -> Int -> Double
coord dx :: Int
dx x :: Int
x = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
    f :: Int -> Int -> PixelRGBA8
    f :: Int -> Int -> Color
f x :: Int
x y :: Int
y = Double -> Double -> Color
t (Int -> Int -> Double
coord Int
x Int
w) (Int -> Int -> Double
coord Int
y Int
h)


------------------------------------------------------------------------------
-- | The Haskell logo.
haskell :: Tile Color
haskell :: Tile Color
haskell =
  let Right (ImageRGBA8 img :: Image Color
img) = ByteString -> Either String DynamicImage
decodePng $(embedFile "static/haskell.png")
   in Image Color -> Tile Color
_fromImage Image Color
img

------------------------------------------------------------------------------
-- | Sandy.
sandy :: Tile Color
sandy :: Tile Color
sandy =
  let Right (ImageRGBA8 img :: Image Color
img) = ByteString -> Either String DynamicImage
decodePng $(embedFile "static/sandy.png")
   in Image Color -> Tile Color
_fromImage Image Color
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
    :: forall a
     . Int  -- ^ resulting width
    -> Int  -- ^ resulting heigeht
    -> Tile a
    -> Compose ZipList ZipList a  -- ^ the resulting "pixels" in row-major order
rasterize :: Int -> Int -> Tile a -> Compose ZipList ZipList a
rasterize w :: Int
w h :: Int
h (Tile t :: Double -> Double -> a
t) = [[a]] -> Compose ZipList ZipList a
forall a b. Coercible a b => a -> b
coerce ([[a]] -> Compose ZipList ZipList a)
-> [[a]] -> Compose ZipList ZipList a
forall a b. (a -> b) -> a -> b
$ do
  Int
y <- [0 .. (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)]
  [a] -> [[a]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> [[a]]) -> [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ do
    Int
x <- [0 .. (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)]
    a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> a
f Int
x Int
y

  where
    coord :: Int -> Int -> Double
    coord :: Int -> Int -> Double
coord dx :: Int
dx x :: Int
x = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
dx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x

    f :: Int -> Int -> a
    f :: Int -> Int -> a
f x :: Int
x y :: Int
y = Double -> Double -> a
t (Int -> Int -> Double
coord Int
x Int
w) (Int -> Int -> Double
coord Int
y Int
h)

------------------------------------------------------------------------------
-- | Like 'rasterize', but with a more convenient output type.
rasterize'
    :: Int  -- ^ resulting width
    -> Int  -- ^ resulting heigeht
    -> Tile a
    -> [[a]]  -- ^ the resulting "pixels" in row-major order
rasterize' :: Int -> Int -> Tile a -> [[a]]
rasterize' w :: Int
w h :: Int
h t :: Tile a
t = Compose ZipList ZipList a -> [[a]]
forall a b. Coercible a b => a -> b
coerce (Compose ZipList ZipList a -> [[a]])
-> Compose ZipList ZipList a -> [[a]]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Tile a -> Compose ZipList ZipList a
forall a. Int -> Int -> Tile a -> Compose ZipList ZipList a
rasterize Int
w Int
h Tile a
t