module Sound.DF.Uniform.UDF where
import qualified Data.Graph.Inductive as G
import qualified Data.Graph.Inductive.Dot as G
import Data.Maybe
import Data.List
import Data.Typeable
import Sound.OSC
import System.Directory
import System.Environment
import System.FilePath
import System.Process
import Text.Printf
import qualified Sound.DF.Uniform.LL.Audition as L
import Sound.DF.Uniform.LL.CGen
import Sound.DF.Uniform.LL.Dot
import Sound.DF.Uniform.LL.K
import Sound.DF.Uniform.LL.UId
data R_Id = R_Id Id deriving (Eq,Show)
from_r_id :: R_Id -> Id
from_r_id (R_Id n) = n
data UDF = UDF_K {udf_k :: K}
| UDF_A {udf_a :: Vec Float}
| UDF_R R_Id (Either K (UDF,UDF))
| UDF_P String TypeRep [UDF]
| UDF_MRG UDF UDF
deriving(Eq,Show)
udf_concise :: UDF -> String
udf_concise n =
case n of
UDF_K k -> k_concise k
UDF_A v -> vec_concise v
UDF_R _ (Left i) -> printf "recRd:%s" (k_concise i)
UDF_R _ (Right _) -> "recWr"
UDF_P nm ty _ -> printf "%s:%s" nm (show ty)
UDF_MRG l r -> printf "mrg(%s,%s)" (show l) (show r)
udf_k' :: UDF -> Maybe K
udf_k' n =
case n of
UDF_K x -> Just x
_ -> Nothing
udf_elem :: UDF -> [UDF]
udf_elem n =
case n of
UDF_K _ -> [n]
UDF_A _ -> [n]
UDF_P _ _ i -> n : concatMap udf_elem i
UDF_R _ (Left _) -> [n]
UDF_R _ (Right (l,r)) -> n : (udf_elem l ++ udf_elem r)
UDF_MRG l r -> n : (udf_elem l ++ udf_elem r)
udf_typeOf :: UDF -> TypeRep
udf_typeOf df =
case df of
UDF_K k -> k_typeOf k
UDF_A _ -> vec_float_t
UDF_P _ t _ -> t
UDF_R _ (Left k) -> k_typeOf k
UDF_R _ (Right (n,_)) -> udf_typeOf n
UDF_MRG n _ -> udf_typeOf n
udf_traverse :: (st -> UDF -> (st,UDF)) -> st -> UDF -> (st,UDF)
udf_traverse f st udf =
case udf of
UDF_K _ -> f st udf
UDF_A _ -> f st udf
UDF_P nm ty i ->
let (st',i') = mapAccumL f st i
in f st' (UDF_P nm ty i')
UDF_R _ (Left _) -> f st udf
UDF_R r (Right (p,q)) ->
let (st',p') = f st p
(st'',q') = f st' q
in f st'' (UDF_R r (Right (p',q')))
UDF_MRG p q ->
let (st',p') = f st p
(st'',q') = f st' q
in f st'' (UDF_MRG p' q')
type Port_Index = Int
type Node = (Id,UDF)
data Edge_Ty = Normal_Edge
| Rec_Wr_Edge Id
| Rec_Rd_Edge Id
| Implicit_Edge Int
edge_ty_concise :: Edge_Ty -> String
edge_ty_concise e =
case e of
Normal_Edge -> "normal"
Rec_Rd_Edge _ -> "recRd"
Rec_Wr_Edge _ -> "recWr"
Implicit_Edge _ -> "implicit"
instance Show Edge_Ty where show = edge_ty_concise
type Edge = (Id,Id,(Port_Index,Edge_Ty))
type Graph = ([Node],[Edge])
type Analysis = [(Node,[Edge])]
node_id :: Node -> Id
node_id = fst
node_udf :: Node -> UDF
node_udf = snd
label :: [Node] -> UDF -> Id
label ns n =
let r = find ((== n) . node_udf) ns
in maybe (error ("label: " ++ show n)) node_id r
source :: [Node] -> UDF -> Id
source ns n =
case n of
UDF_K _ -> label ns n
UDF_A _ -> label ns n
UDF_P _ _ _ -> label ns n
UDF_R _ (Left _) -> label ns n
UDF_R _ (Right (n',_)) -> source ns n'
UDF_MRG l _ -> source ns l
udf_edge_ty :: UDF -> Edge_Ty
udf_edge_ty u =
case u of
UDF_R (R_Id k) (Left _) -> Rec_Rd_Edge k
UDF_R (R_Id _) (Right (n,_)) -> udf_edge_ty n
_ -> Normal_Edge
edges :: [Node] -> UDF -> [Edge]
edges ns u =
case u of
UDF_P _ _ is ->
let f i k = (source ns i,label ns u,(k,udf_edge_ty i))
in zipWith f is [0..]
UDF_R (R_Id k) (Right (_,r)) ->
[(source ns r,label ns u,(0,Rec_Wr_Edge k))]
_ -> []
match_rec :: R_Id -> Node -> Bool
match_rec x n =
case n of
(_,UDF_R y (Right _)) -> x == y
_ -> False
implicit_edge :: [Node] -> Node -> Maybe Edge
implicit_edge n nd =
case nd of
(i,UDF_R d (Left _)) ->
let (j,_) = fromMaybe
(error (show ("implicit_edge",nd)))
(find (match_rec d) n)
in Just (j,i,(0,Implicit_Edge 1))
_ -> Nothing
is_k_node :: Node -> Bool
is_k_node (_,udf) =
case udf of
UDF_K _ -> True
_ -> False
is_orphan_edge :: [Node] -> Edge -> Bool
is_orphan_edge n (i,j,_) =
let k = map fst n
in i `notElem` k || j `notElem` k
vgraph_impl :: Graph -> Graph
vgraph_impl (n,e) =
let n' = filter (not . is_k_node) n
e' = mapMaybe (implicit_edge n) n
e'' = filter (not . is_orphan_edge n') (e ++ e')
in (n',e'')
find_in_edge_m :: [Edge] -> (Id,Port_Index) -> Maybe Edge
find_in_edge_m e (r,p) =
let f (_,r',(p',_)) = r == r' && p == p'
in find f e
find_in_edge :: [Edge] -> (Id,Port_Index) -> Edge
find_in_edge e rp =
let err = error (show ("find_in_edge",e,rp))
in fromMaybe err (find_in_edge_m e rp)
solve_rec_edge :: Int -> [Edge] -> (Id,Port_Index) -> (Int,Id)
solve_rec_edge d e rp =
case find_in_edge e rp of
(l,_,(_,Rec_Wr_Edge _)) ->
case find_in_edge_m e (l,0) of
Just (l',_,(_,Implicit_Edge _)) -> solve_rec_edge (d + 1) e (l',0)
_ -> (d,l)
(l,_,(_,_)) -> solve_rec_edge (d + 1) e (l,0)
implicit_edge' :: [Edge] -> Edge -> Maybe Edge
implicit_edge' es e =
let (l,r,(p,ty)) = e
in case ty of
Rec_Rd_Edge _ ->
let (d,l') = solve_rec_edge 1 es (l,0)
in Just (l',r,(p,Implicit_Edge d))
Rec_Wr_Edge _ -> Nothing
Implicit_Edge _ -> Nothing
Normal_Edge -> Just e
is_rec_node :: Node -> Bool
is_rec_node (_,udf) =
case udf of
UDF_R _ _ -> True
_ -> False
vgraph_direct :: Graph -> Graph
vgraph_direct (n,e) =
let n' = filter (not . is_rec_node) n
e' = mapMaybe (implicit_edge' e) e
in (n',e')
analyse :: [UDF] -> Analysis
analyse ns =
let l_ns = zip [1..] ns
w_es (k,n) = ((k,n),edges l_ns n)
rem_m ((_,n),_) =
case n of
UDF_MRG _ _ -> False
_ -> True
in filter rem_m (map w_es l_ns)
graph :: UDF -> Graph
graph n =
let a = analyse (nub (udf_elem n))
(ns,es) = unzip a
in (ns,concat es)
type Gr = G.Gr UDF (Port_Index,Edge_Ty)
type Gr' = G.Gr String (Port_Index,Edge_Ty)
udf_gr :: Graph -> Gr
udf_gr (n,e) = G.mkGraph n e
udf_gr' :: Graph -> Gr'
udf_gr' (n,e) = G.mkGraph (map (fmap udf_concise) n) e
tsort :: UDF -> [UDF]
tsort u =
let g = udf_gr (graph u)
in map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)
node_vars :: Node -> [Var]
node_vars (k,df) =
case df of
UDF_K i -> [k_var k Std_Var i]
UDF_A i -> [buffer_var k i]
UDF_R (R_Id j) (Left i) ->
[k_var j Rec_Var i
,k_var k Std_Var i]
UDF_R (R_Id _) (Right (n,_)) ->
[(Std_Var,udf_typeOf n,k,Nothing)]
UDF_P _ ty _ ->
if ty == nil_t
then []
else [(Std_Var,ty,k,Nothing)]
UDF_MRG _ _ -> error "node_vars_n: MRG"
node_c_call :: (Node,[Edge]) -> Maybe C_Call
node_c_call ((k,n),es) =
let fc p q = Just (Nothing,p,q)
in case (n,es) of
(UDF_K _,[]) -> Nothing
(UDF_A _,[]) -> Nothing
(UDF_R (R_Id j) (Left _),[]) ->
fc "df_rec_r" [(Std_Var,k),(Rec_Var,j)]
(UDF_R (R_Id j) (Right _),[(s,_,_)]) ->
fc "df_rec_w" [(Rec_Var,j),(Std_Var,s)]
(UDF_P a t _,_) ->
let o_l = if t /= nil_t
then [(Std_Var,k)]
else []
i_l = map (\(l,_,_) -> (Std_Var,l)) es
in fc a (o_l ++ i_l)
_ -> error ("node_c_call: " ++ show (n,es))
k_nodes :: [Node] -> [(Id,K)]
k_nodes ns =
let ks = filter (isJust . udf_k' . node_udf) ns
in map (fmap udf_k) ks
udf_instructions :: UDF -> Instructions
udf_instructions n =
let a = analyse (tsort n)
ns = map fst a
ks = k_nodes ns
vs = concatMap node_vars ns
cc = mapMaybe node_c_call a
in (ks,vs,cc)
udf_dl_gen :: FilePath -> (Host,FilePath) -> UDF -> IO ()
udf_dl_gen fn hd = dl_gen fn hd . udf_instructions
dot_ar :: [UDF] -> [Either Int K]
dot_ar =
let f (i,u) = case u of
UDF_K k -> Right k
_ -> Left i
in map f . zip [0..]
dot_node :: Node -> String
dot_node (k,u) =
case u of
UDF_K _ -> error "dot_node: UDF_K"
UDF_A v -> dot_rec' k (vec_concise v) [] vec_float_t
UDF_P nm ty i -> dot_rec' k nm (dot_ar i) ty
UDF_R _ (Left c) -> dot_rec' k (udf_concise u) [Right c] (k_typeOf c)
UDF_R _ (Right (u',_)) -> dot_rec' k (udf_concise u) (dot_ar [u']) (udf_typeOf u')
UDF_MRG _ _ -> error "dot_node: MRG"
edge_ty_colour :: Edge_Ty -> String
edge_ty_colour ty =
case ty of
Normal_Edge -> "black"
Rec_Rd_Edge _ -> "orange"
Rec_Wr_Edge _ -> "purple"
Implicit_Edge _ -> "red"
dot_edge :: Edge -> String
dot_edge (j,k,(p,ty)) =
let a = [("color",edge_ty_colour ty)]
in printf "%d:o_0 -> %d:i_%d %s" j k p (dot_attr a)
dot_graph :: Graph -> [String]
dot_graph (n,e) =
concat [["digraph Anonymous {"
,"graph [splines=false];"]
,map dot_node n
,map dot_edge e
,["}"]]
dot_draw :: String -> IO ()
dot_draw s = do
t <- getTemporaryDirectory
v <- fmap (fromMaybe "dotty") (lookupEnv "DOTVIEWER")
let fn = t </> "udf" <.> "dot"
writeFile fn s
_ <- rawSystem v [fn]
return ()
draw :: UDF -> IO ()
draw = dot_draw . unlines . dot_graph . vgraph_direct . vgraph_impl . graph
draw' :: UDF -> IO ()
draw' = dot_draw . unlines . dot_graph . vgraph_impl . graph
gr_dot :: UDF -> String
gr_dot = G.showDot . G.fglToDot . udf_gr' . vgraph_direct . vgraph_impl . graph
gr_dot' :: UDF -> String
gr_dot' = G.showDot . G.fglToDot . udf_gr' . vgraph_impl . graph
gr_draw :: UDF -> IO ()
gr_draw = dot_draw . gr_dot
gr_draw' :: UDF -> IO ()
gr_draw' = dot_draw . gr_dot'
audition :: [Message] -> UDF -> IO ()
audition is n = L.audition_rju is (udf_instructions n)
audition_sc3 :: [Message] -> UDF -> IO ()
audition_sc3 is n = L.audition_sc3 is (udf_instructions n)
audition_text :: Int -> UDF -> IO ()
audition_text nf n = L.audition_text nf (udf_instructions n)