summaryrefslogtreecommitdiff
path: root/MMSyn7h.hs
blob: c0d4ab0b3a255476152b5d93102d5e573403dd4e (plain)
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
-- |
-- Module      :  MMSyn7h
-- Copyright   :  (c) OleksandrZhabenko 2019-2020
-- License     :  MIT
--
-- Maintainer  :  olexandr543@yahoo.com
--
-- An additional program that is used with the mmsyn7ukr executable as a sound creator with the voice
-- given by the files in the current directory. It is very similar to the Main.hs of the mmsyn6ukr package.

--

module MMSyn7h where

import Control.Concurrent (myThreadId, killThread)
import Data.Char (isSpace, isControl)
import Data.Maybe (isJust, fromJust)
import System.IO
import System.Environment (getArgs)
import System.Process (readProcessWithExitCode)
import System.Directory (removeFile, listDirectory, getCurrentDirectory)
import Control.Exception (bracketOnError)
import EndOfExe (showE)
import Melodics.Ukrainian (convertToProperUkrainian, takeData)
import UkrainianLControl
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy as B
import Data.List (isSuffixOf)
import CaseBi (getBFst')
import System.Info (os)
import MMSyn7s (show7s)

-- | Function that proposes and creates if accepted the sound record with the new \"voice\". It plays the newly created file once. Then it can delete 
-- the sound files in the current directory while being executed if the entered text starts with \"0\". If you enter as a first command line argument \"-h\",
-- then the program prints informational message and is terminated (killed) successfully. If you specify as a first command line argument \"-v\", then
-- the program prints its version number and is also successfully terminated. If you specify something else, the first command line argument is being treated as
-- a name for the resulting file voiced. If you specify further command line arguments 
-- as a Ukrainian text, that contains only those sounds, which sound representations are in the current directory (you can create them by e. g. @mmsyn7ukr@ and @mmsyn7l@
-- programs in the same name packages), then the program will use only these sounds representations additionally to the default ones \"-.wav\",
-- \"0.wav\" and \"1.wav\" and produce the sounding for the text.
main7h :: IO ()
main7h = bracketOnError (do
  dir <- getCurrentDirectory
  putStrLn "You are now in the directory: " 
  putStrLn $ show dir
  putStrLn ""
  putStrLn "You could specify a name of the resulting file and then the control parameters for the output speech file as the second command line argument to the running program mmsyn7h! "
  putStrLn "See https://hackage.haskell.org/package/mmsyn6ukr-0.6.2.0/docs/UkrainianLControl.html#v:genControl for more information."
  putStr "You could specify e. g. \"o9-1\" or \"o5-1\" (and the most compressed audio in the .ogg format will be produced) or other option. "
  putStrLn "If you have not specified the name and the parameters and now would like to, please, terminate the running program and execute it again with the proper command line arguments. "
  putStrLn ""
  putStr "If you specified further command line arguments as a Ukrainian text, that contains only those sounds, which sound representations are in the current directory "
  putStr "(you can create them by e. g. mmsyn7ukr and mmsyn7l programs in the same name packages), then the program will use only these sounds representations "
  putStrLn "additionally to the default ones \"-.wav\", \"0.wav\" and \"1.wav\". See further: https://hackage.haskell.org/package/mmsyn7s"
  putStrLn ""
  args <- getArgs
  putStr "If you do not use the command line parameters \"-h\" or \"-v\", then you must have specified the file name for the resulting sound recording "
  putStrLn "(do NOT use '}' character and space or control characters!). "
  case (concat . take 1 $ args) of
    ""   -> error "Please, specify as a command line argument at least a name of the resulting file (without its extension)! "
    "-h" -> do
          putStrLn "Synopsis: "
          putStrLn "mmsyn7h fileName [control parameter (see: genControl from mmsyn6ukr package)] [a Ukrainian text being one line to be voiced]  OR"
          putStrLn "mmsyn7h -h    OR"
          putStrLn "mmsyn7h -v"
          putStr "If \"-h\" is specified, then you will see this message. If \"-v\" is specified, then you will see the version of the package mmsyn7h. "
          putStrLn "If something else is specified then the program runs further. "
          threadId <- myThreadId
          killThread threadId
          let nameSF = ""
          return (args, nameSF)
    "-v" -> do
          putStrLn "mmsyn7h version 0.5.0.0."
          threadId <- myThreadId
          killThread threadId
          let nameSF = ""
          return (args, nameSF)
    nameOfSoundFile    -> do
          let nameSF = filter (\x -> not (isSpace x) && not (isControl x) && x /= '}') nameOfSoundFile
          putStrLn ""
          return (args, nameSF)) (\(args, nameSF) -> do
            putStr "Notice, there was (may be) CmdLineArgument exception. To avoid it, please, specify the command line argument (if needed) in the form \"ABC\""
            putStrLn $ " where A is either a letter \'f\', \'o\', \'w\' or a digit and B and C are both digits! The exception (may be) arose from the command line arguments " 
              ++ show args ++ " for the file: " ++ show nameSF ++ ". Please, check also whether the SoX was installed with the support for needed codec.") (\(args, nameSF) -> do 
                let arg = drop 1 . take 2 $ args
                if (not . null . drop 2 $ args)
                  then do
                    putStrLn ""
                    putStr "The resulting file will be played just after it is created by the program. "
                    putStrLn ""
                    let xs = unwords . drop 2 $ args
                        ws = snd . genControl . concat $ arg
                        ys = take (nSymbols (if null arg then [] else fst . genControl . head $ arg)) xs
                    withBinaryFile (nameSF ++ ".raw") AppendMode (appendS16LEFileList (convertToProperUkrainian ys, show7s xs))
                    putStrLn "The .raw file was created by the program. It will be processed further. "
                    let ts = fromJust (showE "sox") in do
                      _ <- readProcessWithExitCode ts (case fst ws of 
                             "" -> ["-r22050","-c1","-L","-esigned-integer","-b16", nameSF ++ ".raw", nameSF ++ snd ws]
                             _  -> ["-r22050","-c1","-L","-esigned-integer","-b16", nameSF ++ ".raw", fst ws, nameSF ++ snd ws]) ""
                      removeFile $ nameSF ++ ".raw"
                      if take 5 os == "mingw" 
                        then do 
                          _ <- readProcessWithExitCode (fromJust . showE $ "sox") [nameSF ++ snd ws, "-t", "waveaudio", "-d"] ""
                          return ()
                        else if isJust . showE $ "play" 
                               then do
                                 _ <- readProcessWithExitCode (fromJust . showE $ "play") [nameSF ++ snd ws] ""
                                 return ()
                               else error "SoX play is not installed properly in the system. Please, install it properly and execute the program again."
                else do 
                  putStrLn ""
                  putStr "The resulting file will be played just after it is created by the program. To remove all the created sound files from the directory, "
                  putStrLn "please, specify now the first character in the input as \"0\". Otherwise, the program will not remove any records (if they are not overwritten). "
                  putStrLn ""
                  putStrLn "Now enter the Ukrainian text."
                  putStrLn ""
                  xs <- getContents
                  if take 1 xs == "0" then do
                    let ys = take (nSymbols (if null arg then [] else fst . genControl . head $ arg)) (drop 1 xs)
                    withBinaryFile (nameSF ++ ".raw") AppendMode (appendS16LEFile (convertToProperUkrainian ys))
                    putStrLn "The .raw file was created by the program. It will be processed further. "
                    let ts = fromJust (showE "sox") in do
                      let ws = snd . genControl . concat $ arg
                      _ <- readProcessWithExitCode ts ["-r22050","-c1","-L","-esigned-integer","-b16", nameSF ++ ".raw", 
                             fst ws, nameSF ++ snd ws] ""
                      removeFile $ nameSF ++ ".raw"
                      if take 5 os == "mingw" 
                        then do 
                          _ <- readProcessWithExitCode (fromJust . showE $ "sox") [nameSF ++ snd ws, "-t", "waveaudio", "-d"] ""
                          cleanCreatedSoundFs
                        else if isJust . showE $ "play" 
                               then do
                                 _ <- readProcessWithExitCode (fromJust . showE $ "play") [nameSF ++ snd ws] ""
                                 cleanCreatedSoundFs
                               else error "SoX play is not installed properly in the system. Please, install it properly and execute the program again."
                  else do 
                    let ws = snd . genControl . concat $ arg
                        ys = take (nSymbols (if null arg then [] else fst . genControl . head $ arg)) xs
                    withBinaryFile (nameSF ++ ".raw") AppendMode (appendS16LEFile (convertToProperUkrainian ys))
                    putStrLn "The .raw file was created by the program. It will be processed further. "
                    let ts = fromJust (showE "sox") in do
                      _ <- readProcessWithExitCode ts (case fst ws of 
                             "" -> ["-r22050","-c1","-L","-esigned-integer","-b16", nameSF ++ ".raw", nameSF ++ snd ws]
                             _  -> ["-r22050","-c1","-L","-esigned-integer","-b16", nameSF ++ ".raw", fst ws, nameSF ++ snd ws]) ""
                      removeFile $ nameSF ++ ".raw"
                      if take 5 os == "mingw" 
                        then do 
                          _ <- readProcessWithExitCode (fromJust . showE $ "sox") [nameSF ++ snd ws, "-t", "waveaudio", "-d"] ""
                          cleanCreatedSoundFs
                        else if isJust . showE $ "play" 
                               then do
                                 _ <- readProcessWithExitCode (fromJust . showE $ "play") [nameSF ++ snd ws] ""
                                 cleanCreatedSoundFs
                               else error "SoX play is not installed properly in the system. Please, install it properly and execute the program again.")

-- | The function that actually produces a .raw file. The mapping table is given in the @Map.txt@ file, but the sound duration differs.
appendS16LEFile ::  V.Vector String -> Handle -> IO ()
appendS16LEFile xs hdl | not (V.null xs) = 
  do
    dataList <- (V.mapM takeData . V.fromList) ["-.wav", "0.wav", "1.wav", "A.wav", "B.wav", "C.wav", "D.wav", "E.wav", "F.wav", "G.wav", "H.wav", 
        "I.wav", "J.wav", "K.wav", "L.wav", "M.wav", "N.wav", "O.wav", "P.wav", "Q.wav", "R.wav", 
          "S.wav", "T.wav", "U.wav", "V.wav", "W.wav", "X.wav", "Y.wav", "Z.wav", "a.wav", "b.wav", "c.wav", 
            "d.wav", "e.wav", "f.wav"]
    V.mapM_ (\u -> 
      if V.all (\z -> B.length z > 0) dataList 
        then let rs =  tail . dropWhile (/= ' ') . takeWhile (/= '}') . show $ hdl in do
          hClose hdl
          closedHdl <- hIsClosed hdl
          if closedHdl 
            then B.appendFile rs $ dataList V.! getBFst' (0, V.fromList [("-", 0), ("0", 1), ("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)]) u
            else error "File is not closed!"
        else error "Data sound file is not read!") xs
    hClose hdl
                       | otherwise = return ()

-- | The function that actually produces a .raw file. The mapping table is that one given in the @Map.txt@ file but not all sounds and files are present.
-- The @[String]@ parameter is a sorted list of Ukrainian sounds to be used (for example, it can be obtained with @mmsyn7s@ executable from the same name package).
appendS16LEFileList :: (V.Vector String, [String]) -> Handle -> IO ()
appendS16LEFileList (xs, yss) hdl | not (V.null xs) && not (null yss) = 
  do
    let intrm = map (getBFst' ("0.wav", V.fromList . zip ["а","б","в","г","д","дж","дз","е","ж","з","и","й","к","л","м","н","о","п","р","с",
                       "сь","т","у","ф","х","ц","ць","ч","ш","ь","і","ґ"] $ ["A.wav", "B.wav", "C.wav", "D.wav", "E.wav", "F.wav", "G.wav", "H.wav", 
                         "I.wav", "J.wav", "K.wav", "L.wav", "M.wav", "N.wav", "O.wav", "P.wav", "Q.wav", "R.wav", 
                           "S.wav", "T.wav", "U.wav", "V.wav", "W.wav", "X.wav", "Y.wav", "Z.wav", "a.wav", "b.wav", "c.wav", 
                             "d.wav", "e.wav", "f.wav"])) yss
    dataList <- (V.mapM takeData . V.fromList) (["-.wav", "0.wav", "1.wav"] ++ intrm)
    V.mapM_ (\u -> 
      if V.all (\z -> B.length z > 0) dataList 
        then let rs =  tail . dropWhile (/= ' ') . takeWhile (/= '}') . show $ hdl in do
          hClose hdl
          closedHdl <- hIsClosed hdl
          if closedHdl 
            then B.appendFile rs $ dataList V.! getBFst' (0, V.fromList $ [("-", 0), ("0", 1), ("1", 2)] ++ zip yss [3..]) u
            else error "File is not closed!"
        else error "Data sound file is not read!") xs
    hClose hdl
                                  | otherwise = return ()

-- | Function that removes all the sounds with ".raw", ".wav", ".ogg", ".flac" extensions in the current directory. It is used for 
-- the security reasons.
cleanCreatedSoundFs :: IO ()
cleanCreatedSoundFs = do
  dirCs <- listDirectory "."
  let remFs = concatMap (\ys -> filter (\zs -> ys `isSuffixOf` zs) dirCs) [".raw", ".wav", ".ogg", ".flac"] in mapM_ removeFile remFs