You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
116 lines
4.2 KiB
116 lines
4.2 KiB
{-# LANGUAGE OverloadedStrings #-}
|
|
module Board where
|
|
|
|
import Raylib.Types (Vector2(..), Color(..))
|
|
import Data.Aeson
|
|
import Data.Aeson.Types
|
|
|
|
newtype BoardColor = BoardColor { unBoardColor :: Color } deriving Show
|
|
newtype Point = Point { unPoint :: Vector2 } deriving Show
|
|
|
|
data Path = Path { path'points :: [Point]
|
|
, path'thickness :: Float
|
|
, path'color :: BoardColor
|
|
} deriving Show
|
|
|
|
data BackgroundPattern = BGPatternPlain { bg'fillColor :: BoardColor }
|
|
| BGPatternDots { bg'fillColor :: BoardColor
|
|
, bg'drawColor :: BoardColor
|
|
, bg'hSpacing :: Int
|
|
, bg'vSpacing :: Int
|
|
, bg'thickness :: Float
|
|
}
|
|
| BGPatternGrid { bg'fillColor :: BoardColor
|
|
, bg'drawColor :: BoardColor
|
|
, bg'hSpacing :: Int
|
|
, bg'vSpacing :: Int
|
|
, bg'thickness :: Float
|
|
}
|
|
deriving Show
|
|
|
|
data Board = Board { boardTitle :: String
|
|
, boardBackground :: BackgroundPattern
|
|
, boardPaths :: [Path]
|
|
} deriving Show
|
|
|
|
instance ToJSON BoardColor where
|
|
toJSON (BoardColor c) =
|
|
object [ "r" .= color'r c, "g" .= color'g c, "b" .= color'b c, "a" .= color'a c ]
|
|
|
|
instance FromJSON BoardColor where
|
|
parseJSON = withObject "color" $ \o -> do
|
|
c <- Color <$> o .: "r"
|
|
<*> o .: "g"
|
|
<*> o .: "b"
|
|
<*> o .: "a"
|
|
return $ BoardColor c
|
|
|
|
instance ToJSON Point where
|
|
toJSON (Point v) =
|
|
object [ "x" .= vector2'x v, "y" .= vector2'y v ]
|
|
|
|
instance FromJSON Point where
|
|
parseJSON = withObject "point" $ \o -> do
|
|
v2 <- Vector2 <$> o .: "x"
|
|
<*> o .: "y"
|
|
return $ Point v2
|
|
|
|
instance ToJSON Path where
|
|
toJSON (Path pts thk clr) =
|
|
object [ "points" .= pts
|
|
, "thickness" .= thk
|
|
, "color" .= clr
|
|
]
|
|
|
|
instance FromJSON Path where
|
|
parseJSON = withObject "path" $ \o ->
|
|
Path <$> o .: "thickness"
|
|
<*> o .: "color"
|
|
<*> o .: "points"
|
|
|
|
instance ToJSON BackgroundPattern where
|
|
toJSON (BGPatternPlain fc) =
|
|
object [ "type" .= ("plain" :: String), "fillColor" .= fc ]
|
|
toJSON (BGPatternDots fc dc hs vs th) =
|
|
object [ "type" .= ("dots" :: String)
|
|
, "fillColor" .= fc
|
|
, "drawColor" .= dc
|
|
, "hSpacing" .= hs
|
|
, "vSpacing" .= vs
|
|
, "thickness" .= th
|
|
]
|
|
toJSON (BGPatternGrid fc dc hs vs th) =
|
|
object [ "type" .= ("grid" :: String)
|
|
, "fillColor" .= fc
|
|
, "drawColor" .= dc
|
|
, "hSpacing" .= hs
|
|
, "vSpacing" .= vs
|
|
, "thickness" .= th
|
|
]
|
|
|
|
instance FromJSON BackgroundPattern where
|
|
parseJSON = withObject "backgroundPattern" $ \o -> do
|
|
pType <- (o .: "type" :: Parser String)
|
|
case pType of
|
|
"plain" -> BGPatternPlain <$> o .: "fillColor"
|
|
"grid" -> BGPatternGrid <$> o .: "fillColor"
|
|
<*> o .: "drawColor"
|
|
<*> o .: "hSpacing"
|
|
<*> o .: "vSpacing"
|
|
<*> o .: "thickness"
|
|
"dots" -> BGPatternDots <$> o .: "fillColor"
|
|
<*> o .: "drawColor"
|
|
<*> o .: "hSpacing"
|
|
<*> o .: "vSpacing"
|
|
<*> o .: "thickness"
|
|
x -> error $ "Unknown background type: " ++ x
|
|
|
|
instance ToJSON Board where
|
|
toJSON (Board t b p) = object ["title" .= t , "background" .= b, "paths" .= p]
|
|
|
|
instance FromJSON Board where
|
|
parseJSON = withObject "board" $ \o ->
|
|
Board <$> o .: "title"
|
|
<*> o .: "background"
|
|
<*> o .: "paths"
|
|
|