module Sound.SC3.Cairo.Scope.Shell where
import Data.IORef
import Data.List
import Data.Maybe
import Data.List.Split
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.UI.Gtk as G
import qualified Graphics.UI.Gtk.Gdk.Events as E
import Sound.OSC.FD
import Sound.SC3.FD
type Render_F st = Shell st -> st -> C.Render st
type Interact_F st = UDP -> Shell st -> st -> IO st
type Bracket_F st = (Interact_F st,Interact_F st)
type SC3_F st = Interact_F st
type Key_F st = Char -> st -> st
data Shell st = Shell {sh_gr :: Int
,sh_nc :: Int
,sh_nf :: Int
,sh_b :: Int
,sh_ix :: Int
,sh_data :: [[Double]]
,sh_bracket :: Bracket_F st
,sh_sc3 :: SC3_F st
,sh_render :: Render_F st
,sh_key :: Key_F st
,sh_delay :: Int
}
sh_bracket_nil :: Bracket_F st
sh_bracket_nil =
let no_op _ _ st = return st
in (no_op,no_op)
sh_sc3_nil :: SC3_F st
sh_sc3_nil _ _ st = return st
sh_monitor_bus :: Transport t => Shell st -> t -> IO ()
sh_monitor_bus sh fd = do
let b = fromIntegral (sh_b sh)
ix = fromIntegral (sh_ix sh)
i = in' (sh_nc sh) AR ix
r = recordBuf AR b 0 1 0 1 Loop 1 DoNothing i
s = synthdef "sh_monitor_bus" r
_ <- async fd (d_recv s)
_ <- async fd (b_alloc (sh_b sh) (sh_nf sh) (sh_nc sh))
send fd (g_new [(sh_gr sh,AddToTail,0)])
send fd (s_new "sh_monitor_bus" (1) AddToTail (sh_gr sh) [])
deinterleave :: Int -> [a] -> [[a]]
deinterleave nc l =
case nc of
1 -> [l]
_ -> transpose (chunksOf nc l)
sh_std_sc3 :: Transport t => Shell st -> t -> IO (Shell st)
sh_std_sc3 sh fd = do
let b = sh_b sh
nf = sh_nf sh
nc = sh_nc sh
send fd (b_getn b [(0,nf * nc)])
r <- waitDatum fd "/b_setn"
let d = case r of
_:Int32 0:Int32 _:xs -> mapMaybe datum_floating xs
_ -> []
return (sh {sh_data = deinterleave nc d})
sh_on_close :: UDP -> Shell b -> b -> IO b
sh_on_close fd sh st = do
let (_,c_f) = sh_bracket sh
send fd (n_free [3])
c_f fd sh st
sh_keypress_f :: G.WidgetClass w =>
w -> IORef st -> UDP -> Shell st -> E.Event -> IO Bool
sh_keypress_f w r fd sh e = do
let kv = E.eventKeyVal e
nm = E.eventKeyName e
case nm of
"Escape" -> do st <- readIORef r
_ <- sh_on_close fd sh st
G.widgetDestroy w
_ -> case G.keyToChar kv of
Just c -> modifyIORef r (sh_key sh c)
_ -> return ()
return True
sh_update_f :: G.WidgetClass w =>
w -> C.Surface -> IORef st -> UDP -> Shell st -> IO Bool
sh_update_f c s r fd sh = do
w <- G.widgetGetDrawWindow c
bd <- readIORef r
sh' <- sh_std_sc3 sh fd
bd' <- sh_sc3 sh' fd sh' bd >>= C.renderWith s . sh_render sh' sh'
C.surfaceFlush s
_ <- G.renderWithDrawable w (C.setSourceSurface s 0 0 >> C.paint)
writeIORef r bd'
return True
sc3_fd :: IO UDP
sc3_fd = openUDP "127.0.0.1" 57110
shell :: Shell st -> st -> IO ()
shell sh i_st = do
let n = sh_nf sh
n' = fromIntegral n
(i_f,_) = sh_bracket sh
fd <- sc3_fd
st <- i_f fd sh i_st
sh_monitor_bus sh fd
r <- newIORef st
s <- C.createImageSurface C.FormatARGB32 n n
C.renderWith s (do C.rectangle 0 0 n' n'
C.setSourceRGBA 0 0 0 1
C.fill)
_ <- G.initGUI
w <- G.windowNew
c <- G.drawingAreaNew
G.windowSetResizable w False
G.widgetSetSizeRequest w n n
_ <- G.onKeyPress w (sh_keypress_f w r fd sh)
_ <- G.onDestroy w G.mainQuit
_ <- G.onExpose c (const (sh_update_f c s r fd sh))
_ <- G.timeoutAdd (G.widgetQueueDraw w >> return True) (sh_delay sh)
G.set w [G.containerChild G.:= c]
G.widgetShowAll w
G.mainGUI
sh_default :: Int -> Render_F st -> Key_F st -> Shell st
sh_default nc r k = Shell 3 nc 512 10 0 [] sh_bracket_nil sh_sc3_nil r k 15