{-# LANGUAGE OverloadedStrings #-}
module MiniLight.FigureDSL where

import Control.Monad
import qualified Data.Config.Font as Font
import qualified Data.Cache as Cache
import qualified Data.Text as T
import Data.Word (Word8)
import MiniLight
import qualified SDL
import qualified SDL.Vect as Vect
import SDL.Font (Font)
import Foreign.Lua

data FigureDSL
  = Empty
  | Translate (Vect.V2 Int) FigureDSL
  | Clip (Vect.V2 Int) (Vect.V2 Int) FigureDSL
  | Picture FilePath
  | Text (Vect.V4 Word8) T.Text
  deriving (Int -> FigureDSL -> ShowS
[FigureDSL] -> ShowS
FigureDSL -> String
(Int -> FigureDSL -> ShowS)
-> (FigureDSL -> String)
-> ([FigureDSL] -> ShowS)
-> Show FigureDSL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FigureDSL] -> ShowS
$cshowList :: [FigureDSL] -> ShowS
show :: FigureDSL -> String
$cshow :: FigureDSL -> String
showsPrec :: Int -> FigureDSL -> ShowS
$cshowsPrec :: Int -> FigureDSL -> ShowS
Show, ReadPrec [FigureDSL]
ReadPrec FigureDSL
Int -> ReadS FigureDSL
ReadS [FigureDSL]
(Int -> ReadS FigureDSL)
-> ReadS [FigureDSL]
-> ReadPrec FigureDSL
-> ReadPrec [FigureDSL]
-> Read FigureDSL
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FigureDSL]
$creadListPrec :: ReadPrec [FigureDSL]
readPrec :: ReadPrec FigureDSL
$creadPrec :: ReadPrec FigureDSL
readList :: ReadS [FigureDSL]
$creadList :: ReadS [FigureDSL]
readsPrec :: Int -> ReadS FigureDSL
$creadsPrec :: Int -> ReadS FigureDSL
Read)

instance Peekable FigureDSL where
  peek :: StackIndex -> Lua FigureDSL
peek = (String -> FigureDSL) -> Lua String -> Lua FigureDSL
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> FigureDSL
forall a. Read a => String -> a
read (Lua String -> Lua FigureDSL)
-> (StackIndex -> Lua String) -> StackIndex -> Lua FigureDSL
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackIndex -> Lua String
forall a. Peekable a => StackIndex -> Lua a
peek

instance Pushable FigureDSL where
  push :: FigureDSL -> Lua ()
push = String -> Lua ()
forall a. Pushable a => a -> Lua ()
push (String -> Lua ()) -> (FigureDSL -> String) -> FigureDSL -> Lua ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FigureDSL -> String
forall a. Show a => a -> String
show

construct
  :: Cache.CacheRegistry Font
  -> Cache.CacheRegistry Figure
  -> FigureDSL
  -> MiniLight (Maybe Figure)
construct :: CacheRegistry Font
-> CacheRegistry Figure -> FigureDSL -> MiniLight (Maybe Figure)
construct tc :: CacheRegistry Font
tc fc :: CacheRegistry Figure
fc = FigureDSL -> MiniLight (Maybe Figure)
go
 where
  go :: FigureDSL -> MiniLight (Maybe Figure)
go dsl :: FigureDSL
dsl = case FigureDSL
dsl of
    Empty           -> Maybe Figure -> MiniLight (Maybe Figure)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Figure -> MiniLight (Maybe Figure))
-> Maybe Figure -> MiniLight (Maybe Figure)
forall a b. (a -> b) -> a -> b
$ Figure -> Maybe Figure
forall a. a -> Maybe a
Just Figure
emptyFigure
    Translate p :: V2 Int
p fig :: FigureDSL
fig -> (Maybe Figure -> Maybe Figure)
-> MiniLight (Maybe Figure) -> MiniLight (Maybe Figure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Figure -> Figure) -> Maybe Figure -> Maybe Figure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r
translate V2 Int
p)) (MiniLight (Maybe Figure) -> MiniLight (Maybe Figure))
-> MiniLight (Maybe Figure) -> MiniLight (Maybe Figure)
forall a b. (a -> b) -> a -> b
$ FigureDSL -> MiniLight (Maybe Figure)
go FigureDSL
fig
    Clip p :: V2 Int
p q :: V2 Int
q fig :: FigureDSL
fig    -> (Maybe Figure -> Maybe Figure)
-> MiniLight (Maybe Figure) -> MiniLight (Maybe Figure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Figure -> Figure) -> Maybe Figure -> Maybe Figure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rectangle Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => Rectangle Int -> r -> r
clip (Point V2 Int -> V2 Int -> Rectangle Int
forall a. Point V2 a -> V2 a -> Rectangle a
SDL.Rectangle (V2 Int -> Point V2 Int
forall (f :: * -> *) a. f a -> Point f a
Vect.P V2 Int
p) V2 Int
q))) (MiniLight (Maybe Figure) -> MiniLight (Maybe Figure))
-> MiniLight (Maybe Figure) -> MiniLight (Maybe Figure)
forall a b. (a -> b) -> a -> b
$ FigureDSL -> MiniLight (Maybe Figure)
go FigureDSL
fig
    Picture path :: String
path ->
      (Figure -> Maybe Figure)
-> LightT LightEnv IO Figure -> MiniLight (Maybe Figure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Figure -> Maybe Figure
forall a. a -> Maybe a
Just (LightT LightEnv IO Figure -> MiniLight (Maybe Figure))
-> LightT LightEnv IO Figure -> MiniLight (Maybe Figure)
forall a b. (a -> b) -> a -> b
$ (Text -> LightT LightEnv IO Figure)
-> Text -> CacheRegistry Figure -> LightT LightEnv IO Figure
forall (m :: * -> *) v.
MonadIO m =>
(Text -> m v) -> Text -> CacheRegistry v -> m v
Cache.getOrCreate (String -> LightT LightEnv IO Figure
forall r (m :: * -> *). Rendering r m => String -> m r
picture (String -> LightT LightEnv IO Figure)
-> (Text -> String) -> Text -> LightT LightEnv IO Figure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (String -> Text
T.pack String
path) CacheRegistry Figure
fc
    Text color :: V4 Word8
color t :: Text
t -> do
      Font
font <- (Text -> LightT LightEnv IO Font)
-> Text -> CacheRegistry Font -> LightT LightEnv IO Font
forall (m :: * -> *) v.
MonadIO m =>
(Text -> m v) -> Text -> CacheRegistry v -> m v
Cache.getOrCreate
        ( \name :: Text
name -> Config -> LightT LightEnv IO Font
Font.loadFontFrom
          (Config -> LightT LightEnv IO Font)
-> Config -> LightT LightEnv IO Font
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Int -> V4 Word8 -> Config
Font.Config (Text -> FontStyle -> FontDescriptor
FontDescriptor Text
name (Bool -> Bool -> FontStyle
FontStyle Bool
False Bool
False)) 24 0
        )
        "IPAGothic"
        CacheRegistry Font
tc
      (Figure -> Maybe Figure)
-> LightT LightEnv IO Figure -> MiniLight (Maybe Figure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Figure -> Maybe Figure
forall a. a -> Maybe a
Just (LightT LightEnv IO Figure -> MiniLight (Maybe Figure))
-> LightT LightEnv IO Figure -> MiniLight (Maybe Figure)
forall a b. (a -> b) -> a -> b
$ Font -> V4 Word8 -> Text -> LightT LightEnv IO Figure
forall r (m :: * -> *).
Rendering r m =>
Font -> V4 Word8 -> Text -> m r
text Font
font V4 Word8
color Text
t