{-# 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
  <> :: 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 :: Double -> Double -> Double -> Double -> Tile
color r :: Double
r g :: Double
g b :: Double
b a :: Double
a = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
forall a b. (a -> b) -> a -> b
$ (Double -> Color) -> Double -> Double -> Color
forall a b. a -> b -> a
const ((Double -> Color) -> Double -> Double -> Color)
-> (Double -> Color) -> Double -> Double -> Color
forall a b. (a -> b) -> a -> b
$ Color -> Double -> Color
forall a b. a -> b -> a
const (Color -> Double -> Color) -> Color -> Double -> 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 Tile where
  <> :: Tile -> Tile -> Tile
(<>) = Tile -> Tile -> Tile
behind

instance Monoid Tile where
  mempty :: Tile
mempty = Tile
forall a. Monoid a => a
mempty


newtype Tile = Tile
  { Tile -> Double -> Double -> Color
runTile :: Double -> Double -> Color
  }

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

instance Arbitrary Tile where
  arbitrary :: Gen Tile
arbitrary = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> Gen (Double -> Double -> Color) -> Gen Tile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Double -> Double -> Color)
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

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


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

_fromImage :: Image PixelRGBA8 -> Tile
_fromImage :: Image Color -> Tile
_fromImage img :: Image Color
img@(Image w :: Int
w h :: Int
h _) = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
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 -> Tile -> Tile
beside :: Tile -> Tile -> Tile
beside (Tile a :: Double -> Double -> Color
a) (Tile b :: Double -> Double -> Color
b) = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
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 -> Color
a (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x) Double
y
    True  -> Double -> Double -> Color
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 -> Tile -> Tile
above :: Tile -> Tile -> Tile
above (Tile a :: Double -> Double -> Color
a) (Tile b :: Double -> Double -> Color
b) = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
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 -> Color
a Double
x (2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y)
    True  -> Double -> Double -> Color
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 -> Tile -> Tile
behind :: Tile -> Tile -> Tile
behind (Tile a :: Double -> Double -> Color
a) (Tile b :: Double -> Double -> Color
b) = (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
forall a b. (a -> b) -> a -> b
$ \x :: Double
x y :: Double
y -> (Color -> Color -> Color) -> Color -> Color -> Color
forall a b c. (a -> b -> c) -> b -> a -> c
flip Color -> Color -> Color
over (Double -> Double -> Color
a Double
x Double
y) (Double -> Double -> Color
b Double
x Double
y)


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


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


------------------------------------------------------------------------------
-- | The empty, fully transparent 'Tile'.
empty :: Tile
empty :: Tile
empty = Tile
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 :: [Tile] -> Tile
rows :: [Tile] -> Tile
rows [] = Tile
forall a. Monoid a => a
mempty
rows ts :: [Tile]
ts =
  let n :: Int
n = [Tile] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tile]
ts
   in (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
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 -> Double -> Double -> Color
runTile ([Tile]
ts [Tile] -> Int -> Tile
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 :: [Tile] -> Tile
cols :: [Tile] -> Tile
cols [] = Tile
forall a. Monoid a => a
mempty
cols ts :: [Tile]
ts =
  let n :: Int
n = [Tile] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tile]
ts
   in (Double -> Double -> Color) -> Tile
Tile ((Double -> Double -> Color) -> Tile)
-> (Double -> Double -> Color) -> Tile
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 -> Double -> Double -> Color
runTile ([Tile]
ts [Tile] -> Int -> Tile
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 -> Tile -> Tile -> Tile -> Tile
quad :: Tile -> Tile -> Tile -> Tile -> Tile
quad a :: Tile
a b :: Tile
b c :: Tile
c d :: Tile
d = (Tile
a Tile -> Tile -> Tile
`beside` Tile
b) Tile -> Tile -> Tile
`above` (Tile
c Tile -> Tile -> Tile
`beside` Tile
d)


------------------------------------------------------------------------------
-- | A 'quad' where the given 'Tile' is rotated via 'cw' once more per
-- quadrant.
swirl :: Tile -> Tile
swirl :: Tile -> Tile
swirl t :: Tile
t = Tile -> Tile -> Tile -> Tile -> Tile
quad Tile
t (Tile -> Tile
cw Tile
t) (Tile -> Tile
ccw Tile
t) (Tile -> Tile) -> Tile -> Tile
forall a b. (a -> b) -> a -> b
$ Tile -> Tile
cw (Tile -> Tile) -> Tile -> Tile
forall a b. (a -> b) -> a -> b
$ Tile -> Tile
cw Tile
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 :: Tile -> Tile -> Tile -> Tile
nona t :: Tile
t tr :: Tile
tr c :: Tile
c =
  [Tile] -> Tile
rows [ [Tile] -> Tile
cols [ Tile -> Tile
ccw Tile
tr,      Tile
t,         Tile
tr    ]
       , [Tile] -> Tile
cols [ Tile -> Tile
ccw Tile
t,       Tile
c,         Tile -> Tile
cw Tile
t  ]
       , [Tile] -> Tile
cols [ Tile -> Tile
cw (Tile -> Tile
cw Tile
tr),  Tile -> Tile
cw (Tile -> Tile) -> Tile -> Tile
forall a b. (a -> b) -> a -> b
$ Tile -> Tile
cw Tile
t, Tile -> Tile
cw Tile
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
    -> Image PixelRGBA8
toImage :: Int -> Int -> Tile -> 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
haskell :: Tile
haskell =
  let Right (ImageRGBA8 img :: Image Color
img) = ByteString -> Either String DynamicImage
decodePng $(embedFile "static/haskell.png")
   in Image Color -> Tile
_fromImage Image Color
img

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

------------------------------------------------------------------------------
-- | 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' :: Int -> Int -> Tile -> [[Color]]
rasterize' w :: Int
w h :: Int
h t :: Tile
t = Compose ZipList ZipList Color -> [[Color]]
forall a b. Coercible a b => a -> b
coerce (Compose ZipList ZipList Color -> [[Color]])
-> Compose ZipList ZipList Color -> [[Color]]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Tile -> Compose ZipList ZipList Color
rasterize Int
w Int
h Tile
t