~alcinnz/rhapsode

ref: 122e09743f367de47db4e6efc56fb5a79082c91e rhapsode/src/SSML.hs -rw-r--r-- 5.7 KiB
122e0974 — Adrian Cochrane Style <aside>. 5 years ago
                                                                                
654b3f04 Adrian Cochrane
2adc7fb2 Adrian Cochrane
654b3f04 Adrian Cochrane
5b9b03db Adrian Cochrane
654b3f04 Adrian Cochrane
5b9b03db Adrian Cochrane
654b3f04 Adrian Cochrane
5b9b03db Adrian Cochrane
654b3f04 Adrian Cochrane
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
{-# 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
    ] ++ Prelude.map (NodeContent . value) (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 NoCue = NodeElement $ buildEl "blank" [] []
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 a : NodeContent b : nodes) =
    stripEmptyNodes (NodeContent (Txt.append a b) : 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 == "" = "" -- Avoids errors from head/tail tests.
    | isSpace $ Txt.head txt = " " `Txt.append` collapseSpaces (Txt.stripStart 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