module Sound.DF.Graph where
import qualified Data.Graph.Inductive as G
import Data.List
import Data.Maybe
import Sound.DF.Node
nodes :: Node -> [Node]
nodes n =
case n of
S _ -> [n]
A _ i _ -> n : concatMap nodes i
R _ (Left _) -> [n]
R _ (Right (l, r)) -> n : (nodes l ++ nodes r)
P i _ -> n : nodes i
M l r -> n : (nodes l ++ nodes r)
label :: [(NodeID, Node)] -> Node -> NodeID
label ns n =
let r = find ((== n) . snd) ns
in maybe (error ("label: " ++ show n)) fst r
source :: [(NodeID, Node)] -> Node -> (NodeID, PortID)
source ns n =
case n of
S _ -> (label ns n, 0)
A _ _ [_] -> (label ns n, 0)
A _ _ _ -> error "non unary A"
R _ (Left _) -> (label ns n, 0)
R _ (Right (n', _)) -> source ns n'
P n' i -> (label ns n', i)
M l _ -> source ns l
type Edge = ((NodeID, PortID), (NodeID, PortID))
edges :: [(NodeID, Node)] -> Node -> [Edge]
edges ns r@(A _ is _) = let f i k = (source ns i, (label ns r, k))
in zipWith f is [0..]
edges ns r@(R _ (Right (_, rr))) = [(source ns rr, (label ns r, 0))]
edges _ (P _ _) = []
edges _ _ = []
analyse :: [Node] -> [((NodeID, Node), [Edge])]
analyse ns = let l_ns = zip [1..] ns
w_es (k, n) = ((k, n), edges l_ns n)
rem_p ((_, P _ _), _) = False
rem_p _ = True
rem_m ((_, M _ _), _) = False
rem_m _ = True
in filter rem_m (filter rem_p (map w_es l_ns))
mod_e :: Edge -> (NodeID, NodeID, (PortID, PortID))
mod_e ((l, lp), (r, rp)) = (l, r, (lp, rp))
graph :: Node -> G.Gr Node (PortID, PortID)
graph n =
let a = analyse (nub (nodes n))
ns = map fst a
es = concatMap (map mod_e . snd) a
in G.mkGraph ns es
tsort :: Node -> [Node]
tsort s =
let g = graph s
in map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)