Flip.hs

{-# LANGUAGE OverloadedStrings, DeriveGeneric, DeriveAnyClass, TemplateHaskell #-}
module Data.Comic.Flip (
   Segment(..), ScheduledSegment(..)
 , FrameSplice(..), TextType(..)
 , OnScreen(..), Box(..)
 , RelPosition(..), Font(..), blackRGBA, whiteRGBA
 , TextLayout(..), HAlignment(..), VAlignment(..)
 , osStart, osEnd
 , fsWhen, fsDepth, fsBackground, fsFont, fsTxt, fsTxtType, fsTextLayout, fsWhere
 , tlHorizontal, tlVertical, tlShrink
 , sDuration, sSplice
 ) where

import Control.Applicative
import Control.DeepSeq
import Control.Lens
import Control.Monad
import qualified Data.Aeson as JS
import Data.Aeson (ToJSON(..), FromJSON(..), (.:))
import Data.Comic.Types
import Data.Foldable
import Data.Hashable (Hashable(hashWithSalt))
import Data.Hashable.Orphans ()
import Data.SortedList hiding (map)
import qualified Data.SortedList as Sorted
import Data.Text (Text)
import Data.Time
import Data.UUID (UUID)
import GHC.Generics (Generic)

type StartTime = Float
type EndTime = Float

data OnScreen =
    OnScreen
    { _osStart :: {-# UNPACK #-} !StartTime
    , _osEnd :: {-# UNPACK #-} !EndTime
    }
  deriving (Read, Show, Eq, Ord, Generic, NFData)

makeLenses ''OnScreen

instance Hashable OnScreen where
  hashWithSalt s (OnScreen strt end) = hashWithSalt s (strt, end)

data Box =
    Box
    { _bTl :: {-# UNPACK #-} !RelPosition
    , _bBr :: {-# UNPACK #-} !RelPosition
    }
  deriving (Read, Show, Eq, Ord, Generic, NFData)

instance Hashable Box where
  hashWithSalt s (Box tl br) = hashWithSalt s (tl, br)

data HAlignment =
    HALeft
  | HACenter
  | HARight
  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)

instance ToJSON HAlignment where
  toJSON HALeft = JS.String "left"
  toJSON HACenter = JS.String "center"
  toJSON HARight = JS.String "right"

instance FromJSON HAlignment where
  parseJSON (JS.String "left") = pure HALeft
  parseJSON (JS.String "center") = pure HACenter
  parseJSON (JS.String "right") = pure HARight
  parseJSON _ = mzero

data VAlignment =
    VATop
  | VACenter
  | VABottom
  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)

instance ToJSON VAlignment where
  toJSON VATop = JS.String "top"
  toJSON VACenter = JS.String "center"
  toJSON VABottom = JS.String "bottom"

instance FromJSON VAlignment where
  parseJSON (JS.String "top") = pure VATop
  parseJSON (JS.String "center") = pure VACenter
  parseJSON (JS.String "bottom") = pure VABottom
  parseJSON _ = mzero

data TextLayout =
    TextLayout
    { _tlHorizontal :: !HAlignment
    , _tlVertical :: !VAlignment
    , _tlShrink :: !Bool
    }
  deriving (Read, Show, Eq, Ord, Generic, NFData, Hashable)

makeLenses ''TextLayout

data TextType =
    TxtStatic
  | TxtScroll
  | TxtSpeech
  | TxtBreaking
  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)

instance ToJSON TextType where
    toJSON TxtStatic = JS.String "static"
    toJSON TxtScroll = JS.String "scroll"
    toJSON TxtSpeech = JS.String "speech"
    toJSON TxtBreaking = JS.String "breaking"

instance FromJSON TextType where
    parseJSON (JS.String "static") = return TxtStatic
    parseJSON (JS.String "scroll") = return TxtScroll
    parseJSON (JS.String "speech") = return TxtSpeech
    parseJSON (JS.String "breaking") = return TxtBreaking
    parseJSON _ = mzero

data FrameSplice =
    FSBackground
    { _fsWhen :: {-# UNPACK #-} !OnScreen
    , _fsDepth :: {-# UNPACK #-} !Int
    , _fsBackground :: {-# UNPACK #-} !ImageName
    }
  | FSText
    { _fsWhen :: {-# UNPACK #-} !OnScreen
    , _fsWhere :: {-# UNPACK #-} !Box
    , _fsTxt :: {-# UNPACK #-} !Text
    , _fsFont :: {-# UNPACK #-} !Font
    , _fsTxtType :: !TextType
    , _fsTextLayout :: !TextLayout
    }
   deriving (Read, Show, Eq, Ord, Generic, NFData)

makeLenses ''FrameSplice

instance Hashable FrameSplice where
  hashWithSalt s (FSBackground o d i) = hashWithSalt s (o, d, i)
  hashWithSalt s (FSText o w t f tt a) =
    hashWithSalt s (o, w, t, f, tt, a)

instance ToJSON FrameSplice where
    toJSON (FSBackground (OnScreen strt end) d img) =
      JS.object $
        [ ("start", toJSON strt), ("end", toJSON end)
        , ("depth", toJSON d)
        , ("panel", toJSON img)
        ]
    toJSON (FSText (OnScreen strt end) (Box tl br) txt (Font fn fs c) tt (TextLayout h v s)) =
      JS.object $
        [ ("start", toJSON strt), ("end", toJSON end)
        , ("tl", toJSON tl), ("br", toJSON br)
        , ("font", toJSON fn), ("size", toJSON fs), ("color", toJSON c)
        , ("txt", toJSON txt)
        , ("txt_type", toJSON tt)
        , ("align", toJSON h), ("valign", toJSON v), ("shrink_fit", toJSON s)
        ]

instance FromJSON FrameSplice where
    parseJSON (JS.Object v) =
          (FSBackground <$> (OnScreen <$> v .: "start" <*> v .: "end")
                        <*> v .: "depth"
                        <*> v .: "panel")
      <|> (FSText <$> (OnScreen <$> v .: "start" <*> v .: "end")
                  <*> (Box <$> v .: "tl" <*> v .: "br")
                  <*> v .: "txt"
                  <*> (Font <$>  v .: "font" <*> v .: "size" <*> v .: "color")
                  <*> v .: "txt_type"
                  <*> (TextLayout <$> v .: "align" <*> v .: "valign" <*> v .: "shrink_fit"))
    parseJSON _ = mzero

data Segment =
    Segment
    { _sDuration :: !DiffTime
      -- ^ This is how long, ideally, the segment would air for.
    , _sSplice :: SortedList FrameSplice
      -- ^ The actual stage directions for playing the content.
      --   Times are [0, 1] of the Duration.
      --   We keep sorting for a stable Ord instance.
    }
  deriving (Show, Eq, Ord, Generic, NFData)

makeLenses ''Segment

instance Semigroup Segment where
  (<>) a b = mconcat [a, b]

instance Monoid Segment where
  mempty = Segment 0 mempty
  mappend a b = mconcat [a, b]
  mconcat os =
    let totTime = fromRational . toRational  . foldl (\a s -> a + _sDuration s) 0 $ os
     in Segment (fromRational . toRational $ totTime)
                (snd . foldl (\(c, fs) s ->
                   let sdur = fromRational . toRational $ s ^. sDuration
                       timePrev = c+sdur
                       segPercent = sdur / totTime
                    in (timePrev
                       ,fs `mappend` (Sorted.map (\f ->
                          -- We rescale the [0-1] time range into the percent that this
                          -- Segment forms of the overal, and shift it into position.
                          ((f & fsWhen.osStart %~ (\st -> (st*sdur+c)/totTime))
                              & fsWhen.osEnd %~ (\se -> (se*sdur+c)/totTime))) (_sSplice $ s))
                        )) (0, mempty) $ os)

instance Hashable Segment where
  hashWithSalt s (Segment dur spl) =
    hashWithSalt s (dur, spl)

instance ToJSON Segment where
    toJSON (Segment dur splcs) =
      JS.object $
        [ ("duration", toJSON (realToFrac dur::Float))
        , ("splices", toJSON . toList $ splcs)
        ]

instance FromJSON Segment where
    parseJSON (JS.Object v) =
      Segment <$> ((realToFrac::Float -> DiffTime) <$> v .: "duration")
              <*> (toSortedList <$> v .: "splices")
    parseJSON _ = mzero

data ScheduledSegment =
    ScheduledSegment
    { _ssSegment :: {-# UNPACK #-} !Segment
    , _ssSegID :: {-# UNPACK #-} !UUID
    , _ssPlayTill :: !DiffTime
      -- ^ This is how long in the future this segment should end,
      --   from the time it is transmited to the client.
    }
  deriving (Show, Eq, Ord, Generic, NFData)

instance ToJSON ScheduledSegment where
    toJSON (ScheduledSegment seg segid till) =
      JS.object
        [ ("till", toJSON (realToFrac till::Float))
        , ("id", toJSON segid)
        , ("segment", toJSON seg)
        ]

instance FromJSON ScheduledSegment where
    parseJSON (JS.Object v) =
        ScheduledSegment <$> v .: "segment"
                         <*> v .: "id"
                         <*> ((realToFrac::Float -> DiffTime) <$> v .: "till")
    parseJSON _ = mzero