module Types
( ColorSource(..)
, Coef(..)
, Options(..)
, defaultOpts
, SymmetryGroup(..)
, PreProcess(..)
, WPtype(..)
, Wallpaper(..)
, Rosette(..)
, Function(..)
, Recipe
, Invertible(..)
, BlackWhite(..)
) where
import Codec.Picture
import Data.Complex
import Data.Text (Text, toLower)
import Data.Yaml
type Recipe a = Complex a -> Complex a
data ColorSource a p
= Picture (Image p)
| Function (Complex a -> p)
data Coef a = Coef
{ nCoord :: Int
, mCoord :: Int
, anm :: Complex a
} deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (Complex a) where
parseJSON a@(Array _) = do
(r, i) <- parseJSON a
return $ r :+ i
parseJSON _ = fail "Expected Array for a Complex value."
instance FromJSON a => FromJSON (Coef a) where
parseJSON (Object v)
= Coef
<$> v .: "n"
<*> v .: "m"
<*> v .: "A(n,m)"
parseJSON _ = fail "Expected Object for Coef value."
data Options a = Options
{ width :: Int
, height :: Int
, repLength :: Int
, scale :: a
} deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (Options a) where
parseJSON (Object v)
= Options
<$> v .: "width"
<*> v .: "height"
<*> v .: "repeat-length"
<*> v .: "scale-factor"
parseJSON _ = fail "Expected Object for a Options value."
defaultOpts :: Options Double
defaultOpts = Options 750 750 150 0.5
data SymmetryGroup a
= P1 a a
| P2 a a
| CM a
| CMM a
| PM a
| PG a
| PMM a
| PMG a
| PGG a
| P4
| P4M
| P4G
| P3
| P31M
| P3M1
| P6
| P6M
| P111
| P211
| P1M1
| P11M
| P11G
| P2MM
| P2MG
deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (SymmetryGroup a) where
parseJSON (Object v) = do
(name :: Text) <- v .: "name"
case toLower name of
"p1" -> P1 <$> v .: "xi" <*> v .: "eta"
"p2" -> P2 <$> v .: "xi" <*> v .: "eta"
"cm" -> CM <$> v .: "b"
"cmm" -> CMM <$> v .: "b"
"pm" -> PM <$> v .: "L"
"pg" -> PG <$> v .: "L"
"pmm" -> PMM <$> v .: "L"
"pmg" -> PMG <$> v .: "L"
"pgg" -> PGG <$> v .: "L"
s -> parseGroup s
parseJSON (String s) = parseGroup s
parseJSON _ = fail "Group must be an object or String"
parseGroup :: Monad m => Text -> m (SymmetryGroup a)
parseGroup s = case toLower s of
"p4" -> pure P4
"p4m" -> pure P4M
"p4g" -> pure P4G
"p3" -> pure P3
"p31m" -> pure P31M
"p3m1" -> pure P3M1
"p6" -> pure P6
"p6m" -> pure P6M
"p111" -> pure P111
"p211" -> pure P211
"p1m1" -> pure P1M1
"p11m" -> pure P11M
"p11g" -> pure P11G
"p2mm" -> pure P2MM
"p2mg" -> pure P2MG
_ -> fail "Tried to parse an invalid group name."
data WPtype a
= Plain
| Morph a
| Blend (SymmetryGroup a)
deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (WPtype a) where
parseJSON (Object v) = do
(typ :: String) <- v .: "style"
case typ of
"plain" -> pure Plain
"morph" -> Morph <$> v .: "cutoff"
"blend" -> Blend <$> v .: "group"
_ -> fail "Tried to parse an invalide wallpaper type."
parseJSON _ = fail "Expected a String for the wallpaper type."
data PreProcess
= FlipHorizontal
| FlipVertical
| FlipBoth
| Invert
| AntiSymmHorizontal
| AntiSymmVertical
| None
deriving (Show, Eq)
instance FromJSON PreProcess where
parseJSON (String s) =
case toLower s of
"fliphorizontal" -> pure FlipHorizontal
"flipvertical" -> pure FlipVertical
"flipboth" -> pure FlipBoth
"invert" -> pure Invert
"antisymmvertical" -> pure AntiSymmVertical
"antisymmhorizontal" -> pure AntiSymmHorizontal
"none" -> pure None
_ -> fail "Invalid Pre-process type"
parseJSON _ = fail "Pre-process must be a String"
data Wallpaper a = Wallpaper
{ wpGroup :: SymmetryGroup a
, wpCoefs :: [Coef a]
, wpType :: WPtype a
, wpOptions :: Options a
, wpWheel :: Maybe FilePath
, wpProcess :: PreProcess
, wpPath :: FilePath
} deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (Wallpaper a) where
parseJSON (Object v)
= Wallpaper
<$> v .: "Group"
<*> v .: "Coefficients"
<*> v .:? "Type" .!= Plain
<*> v .: "Options"
<*> v .:? "Colorwheel-path" .!= Nothing
<*> v .:? "Pre-process" .!= None
<*> v .: "Output-path"
parseJSON _ = fail "Expected Object for Wallpaper value."
data Rosette a = Rosette
{ rsFoldSym :: Int
, rsMirror :: Bool
, rsCoefs :: [Coef a]
, rsOptions :: Options a
, rsWheel :: Maybe FilePath
, rsProcess :: PreProcess
, rsPath :: FilePath
} deriving (Show, Eq, Functor)
instance FromJSON a => FromJSON (Rosette a) where
parseJSON (Object v)
= Rosette
<$> v .: "P-fold"
<*> v .: "Mirror"
<*> v .: "Coefficients"
<*> v .: "Options"
<*> v .:? "Colorwheel-path" .!= Nothing
<*> v .:? "Pre-process" .!= None
<*> v .: "Output-path"
parseJSON _ = fail "Expected Object for Rosette value."
data Function a = Fn
{ fnOptions :: Options a
, fnWeel :: FilePath
, fnProcess :: PreProcess
, fnPath :: FilePath
} deriving (Show, Eq, Functor)
class BlackWhite a where
black :: a
white :: a
instance BlackWhite PixelRGBA8 where
black = PixelRGBA8 0 0 0 255
white = PixelRGBA8 255 255 255 255
instance BlackWhite PixelRGB8 where
black = PixelRGB8 0 0 0
white = PixelRGB8 255 255 255
instance BlackWhite PixelYCbCr8 where
black = PixelYCbCr8 0 0 0
white = PixelYCbCr8 255 255 255
instance BlackWhite Pixel8 where
black = 0
white = 255
instance BlackWhite PixelYA8 where
black = PixelYA8 0 255
white = PixelYA8 255 255
instance BlackWhite PixelCMYK8 where
black = PixelCMYK8 0 0 0 255
white = PixelCMYK8 0 0 0 0
class Invertible a where
invert :: a -> a
instance Invertible PixelRGBA8 where
invert (PixelRGBA8 r g b a) = PixelRGBA8 (255r) (255g) (255b) a
instance Invertible PixelRGB8 where
invert (PixelRGB8 r g b) = PixelRGB8 (255r) (255g) (255b)
instance Invertible PixelYCbCr8 where
invert (PixelYCbCr8 r g b) = PixelYCbCr8 (255r) (255g) (255b)
instance Invertible Pixel8 where
invert p = 255 p
instance Invertible PixelYA8 where
invert (PixelYA8 c a) = PixelYA8 (255c) a
instance Invertible PixelCMYK8 where
invert (PixelCMYK8 r g b a) = PixelCMYK8 (255r) (255g) (255b) a