From 654b3f04e3399dbd1a6d2dba11581304fe3393bb Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 22 Jul 2019 20:49:51 +1200 Subject: [PATCH] Draft code for laying out CSS Speech Box Model. --- src/Main.hs | 1 + src/SSML.hs | 146 +++++++++++++++++++++++++++++++++++++++++++++++ src/StyleTree.hs | 28 +++++---- 3 files changed, 165 insertions(+), 10 deletions(-) create mode 100644 src/SSML.hs diff --git a/src/Main.hs b/src/Main.hs index a1cc3f8..afb651a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,6 +26,7 @@ import Data.Scientific (toRealFloat) import DefaultCSS import StyleTree +import qualified SSML main :: IO () main = do diff --git a/src/SSML.hs b/src/SSML.hs new file mode 100644 index 0000000..8f890b3 --- /dev/null +++ b/src/SSML.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +module SSML(styleToSSML) where +import Text.XML +import qualified Data.Text as Txt +import Data.Map +import qualified Data.Map as M +import Data.CSS.Syntax.Tokens (tokenize, Token(Dimension)) + +import Data.Char (isSpace) +import Data.Maybe (fromJust) +import Data.List (elemIndex) + +import StyleTree + +-------- +---- Basic conversion +-------- +styleToSSML' StyleTree {speak = False} = + Element (Name "blank" Nothing Nothing) empty [] +styleToSSML' self = buildEl0 "prosody" [ + ("volume", volume self), + ("rate", rate self), + ("pitch", serializePitch $ pitch self), + ("range", serializePitch $ range self) + ] $ buildEl0 "prosody" [ + ("volume", maybeAdjust $ volumeAdjust self), + ("rate", maybeAdjust $ rateAdjust self), + ("pitch", maybeAdjust $ pitchAdjust $ pitch self), + ("range", maybeAdjust $ pitchAdjust $ range self) + ] $ buildEl0 "emphasis" [("level", stress self)] $ + buildEl0 "say-as" [("interpret-as", speakAs self)] $ + buildEl0 "tts:style" [ + ("field", maybeBool (punctuation self) "punctuation" "punctuation"), + ("mode", maybeBool (punctuation self) "all" "none") + ] $ buildVoices (voice self) $ buildBox self + +serializePitch Inherit = Nothing +serializePitch (Pitch kw _) = Just kw +serializePitch (Absolute "khz" n) = serializePitch $ Absolute "hz" (1000 * n) +serializePitch (Absolute _ n) | n < 0 = Nothing + | otherwise = Just $ Txt.pack (show n ++ "hz") +serializePitch (Relative unit n) = Just $ relativeUnit unit n + +relativeUnit "khz" n = relativeUnit "hz" $ 1000 * n +relativeUnit unit n | n < 0 = Txt.pack (show n) `Txt.append` unit + | otherwise = Txt.pack ('+':show n) `Txt.append` unit + +maybeBool (Just True) truthy _ = Just truthy +maybeBool (Just False) _ falsy = Just falsy +maybeBool Nothing _ _ = Nothing + +maybeCast (Just n) = Just $ Txt.pack $ show n +maybeCast Nothing = Nothing + +maybeAdjust (Just (Unit' unit n)) = Just $ relativeUnit unit n +maybeAdjust Nothing = Nothing + +buildVoice (Voice name) children = buildEl "voice" [("name", Just name)] children +buildVoice (VoicePattern age gender variant) children = buildEl "voice" [ + ("age", maybeCast age), + ("gender", Just gender), + ("variant", maybeCast variant) + ] children + +buildVoices Nothing = buildEl "blank" [] +buildVoices (Just voice) = buildVoice voice + +-------- +---- CSS Speech Box Model +-------- +buildBox self = [ + buildBreak $ pauseBefore self, + buildCue $ cueBefore self, + buildBreak $ restBefore self, + NodeContent $ content self + ] ++ Prelude.map (NodeElement . styleToSSML') (children self) ++ [ + buildBreak $ restAfter self, + buildCue $ cueAfter self, + buildBreak $ pauseAfter self + ] + +buildBreak self = NodeElement $ buildEl "break" [ + ("strength", strength self), + ("time", time self) + ] [] +buildCue self = NodeElement $ + buildEl0 "prosody" [("volume", maybeAdjust $ cueVolume self)] $ + buildEl "audio" [("src", Just $ src self)] [] + +volumes = ["x-weak", "weak", "medium", "strong", "x-strong"] +maxBreak x@(Element _ a _) y@(Element _ b _) + | Just a' <- "strength" `M.lookup` a, Just b' <- "strength" `M.lookup` b, a' /= b' = + if fromJust (elemIndex a' volumes) > fromJust (elemIndex b' volumes) then x else y + | Just a' <- "time" `M.lookup` a, Just b' <- "time" `M.lookup` b, a' /= b' = + if toMS (tokenize a') > toMS (tokenize b') then x else y + | otherwise = x +toMS [Dimension _ n "s"] = cssFloat n * 1000 +toMS [Dimension _ n "ms"] = cssFloat n +toMS _ = 0 -- Should never happen. + +-------- +---- XML Output Utils +-------- +buildEl name attrs elChildren = + Element (Name name Nothing Nothing) (attrsFromList attrs) elChildren +buildEl0 name attrs child = buildEl name attrs [NodeElement child] + +attrsFromList ((name, Just value):attrs) = + insert (Name name Nothing Nothing) value $ attrsFromList attrs +attrsFromList ((_, Nothing):attrs) = attrsFromList attrs +attrsFromList [] = empty + +-------- +---- Tidyup +-------- +stripEmptyEls (Element name attrs elChildren) = + Element name attrs $ stripEmptyNodes elChildren +stripEmptyNodes (NodeElement el@(Element _ attrs elChildren ):nodes) + | M.null attrs = stripEmptyNodes (elChildren ++ nodes) + | otherwise = NodeElement (stripEmptyEls el) : stripEmptyNodes nodes +stripEmptyNodes (NodeContent txt : nodes) -- strip whitespace + | Txt.stripStart txt == "" = stripEmptyNodes nodes + | otherwise = NodeContent (collapseSpaces txt) : stripEmptyNodes nodes +stripEmptyNodes (node:nodes) = stripEmptyNodes nodes +stripEmptyNodes [] = [] + +collapseSpaces txt + | Txt.stripStart txt == "" = "" -- Avoids errors from head/tail tests. + | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces txt + | isSpace $ Txt.last txt = collapseSpaces (Txt.stripEnd txt) `Txt.append` " " + | otherwise = Txt.unwords $ Txt.words txt + +collapseBreaks :: Element -> Element +collapseBreaks (Element name attrs elChildren) = + Element name attrs $ collapseBreaks' elChildren +collapseBreaks' :: [Node] -> [Node] +collapseBreaks' ( + NodeElement a@(Element "break" _ _): + NodeElement b@(Element "break" _ _): + nodes + ) = NodeElement (maxBreak a b) : collapseBreaks' nodes +collapseBreaks' (NodeElement el:nodes) = NodeElement (collapseBreaks el) : collapseBreaks' nodes +collapseBreaks' (node:nodes) = node:collapseBreaks' nodes +collapseBreaks' [] = [] + +styleToSSML self = collapseBreaks $ stripEmptyEls $ buildEl0 "speak" [] $ styleToSSML' self diff --git a/src/StyleTree.hs b/src/StyleTree.hs index 31778e0..28df24b 100644 --- a/src/StyleTree.hs +++ b/src/StyleTree.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module StyleTree( - StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust + StyleTree(..), Pitch(..), Voice(..), Unit'(..), pitchAdjust, + Pause(..), Cue(..), cssFloat ) where import Data.CSS.Syntax.Tokens @@ -60,9 +61,9 @@ parsePause toks@[Dimension _ _ unit] | unit `elem` ["s", "ms"] = Just Pause { } parsePause _ = Nothing -data Cue = Cue {src :: Text, cueVolume :: Float} | NoCue -parseCue [Url source] = Just $ Cue source 0 -parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ cssFloat n +data Cue = Cue {src :: Text, cueVolume :: Maybe Unit'} | NoCue +parseCue [Url source] = Just $ Cue source Nothing +parseCue [Url source, Dimension _ n "dB"] = Just $ Cue source $ Just $ Unit' "dB" $ cssFloat n parseCue [Ident "none"] = Just NoCue parseCue _ = Nothing @@ -83,6 +84,8 @@ data StyleTree = StyleTree { pauseAfter :: Pause, restBefore :: Pause, restAfter :: Pause, + cueBefore :: Cue, + cueAfter :: Cue, children :: [StyleTree], content :: Text @@ -106,6 +109,8 @@ instance Style.PropertyParser StyleTree where pauseAfter = Pause Nothing Nothing, restBefore = Pause Nothing Nothing, restAfter = Pause Nothing Nothing, + cueBefore = NoCue, + cueAfter = NoCue, children = [], content = "" @@ -122,12 +127,12 @@ instance Style.PropertyParser StyleTree where shorthand _ "rest" v | Just _ <- parsePause v = [("rest-before", v), ("rest-after", v)] - --shorthand _ "cue" (a:b@(Dimension _ _ _):c) | Just _ <- parseCue [a, b], Just _ <- parseCue c = - -- [("cue-before", [a, b]), ("cue-after", c)] - --shorthand _ "cue" (a:b) | Just _ <- parseCue [a], Just _ <- parseCue b = - -- [("cue-before", [a]), ("cue-after", c)] - --shorthand _ "cue" v | Just _ <- parseCue v = - -- [("cue-before", v), ("cue-after", v)] + shorthand _ "cue" (a:b@(Dimension _ _ _):c) | Just _ <- parseCue [a, b], Just _ <- parseCue c = + [("cue-before", [a, b]), ("cue-after", c)] + shorthand _ "cue" (a:b) | Just _ <- parseCue [a], Just _ <- parseCue b = + [("cue-before", [a]), ("cue-after", b)] + shorthand _ "cue" v | Just _ <- parseCue v = + [("cue-before", v), ("cue-after", v)] shorthand self key value | Just _ <- Style.longhand self self key value = [(key, value)] | otherwise = [] @@ -173,6 +178,9 @@ instance Style.PropertyParser StyleTree where longhand _ self "rest-before" toks = parsePause toks >>= \val -> Just self {restBefore = val} longhand _ self "rest-after" toks = parsePause toks >>= \val -> Just self {restAfter = val} + longhand _ self "cue-before" toks = parseCue toks >>= \val -> Just self {cueBefore = val} + longhand _ self "cue-after" toks = parseCue toks >>= \val -> Just self {cueAfter = val} + longhand _ self _ [Ident "inherit"] = Just self longhand _ _ _ _ = Nothing -- 2.30.2