-
Notifications
You must be signed in to change notification settings - Fork 1
/
Sound.hs
76 lines (69 loc) · 2.01 KB
/
Sound.hs
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
module Sound where
import System.IO
import System.Process
import System.Exit
import Control.Concurrent
data PlayerCommand =
Load String String |
Play |
Stop |
Seek Int Int Int |
SetLoop Int Int |
EnableLoop |
DisableLoop |
TicksPerBeat Int |
EnableCapture |
DisableCapture |
Execute Int Int Int Int |
CutAll |
Exit |
Crash
deriving (Eq, Show)
data Blub = Blub deriving (Show)
newSoundController :: IO (PlayerCommand -> IO (), IO Double, IO [Blub])
newSoundController = do
(Just out, Just inn, Nothing, _) <- createProcess (proc "./sound" [])
{ std_in = CreatePipe
, std_out = CreatePipe }
lock <- newMVar ()
return
( \cmd -> withMVar lock $ \_ -> do
hPutStrLn out (encodeCommand cmd)
hFlush out
, withMVar lock $ \_ -> do
hPutStrLn out "tell"
hFlush out
line <- hGetLine inn
case reads line of
[(beat, "")] -> return beat
_ -> do
hPutStrLn stderr (concat ["CORE bad tell response (", line, ")"])
exitFailure
, return [Blub, Blub, Blub] )
encodeCommand :: PlayerCommand -> String
encodeCommand c = case c of
Load p1 p2 -> unwords ["load", p1, p2]
Play -> "play"
Stop -> "stop"
Seek whole num denom ->
unwords ["seek", show whole, show num ++ "/" ++ show denom]
SetLoop l0 l1 -> unwords ["set-loop", show l0, show l1]
EnableLoop -> "enable-loop"
DisableLoop -> "disable-loop"
TicksPerBeat n -> unwords ["ticks-per-beat", show n]
EnableCapture -> "enable-capture"
DisableCapture -> "disable-capture"
Execute ty ch arg1 arg2 ->
unwords ["execute", show ty, show ch, show arg1, show arg2]
CutAll -> "cut-all"
Exit -> "exit"
Crash -> "crash"
newPlayer :: (PlayerCommand -> IO ()) -> IO (Either Int Int -> IO ())
newPlayer dispatch = return $ \eith -> do
_ <- forkIO $ do
case eith of
Right note -> dispatch (Execute 9 0 note 127)
Left note -> dispatch (Execute 8 0 note 127)
threadDelay 1000000
--dispatch (Execute 8 0 note 127)
return ()