-- | Faust signal processing block diagram model.
module Sound.DF.Uniform.Faust where

import qualified Data.Graph.Inductive as G {- fgl -}
import Data.Maybe {- base -}
import Data.List {- base -}
import qualified Data.List.Split as S {- split -}
import Data.Typeable {- base -}
import Sound.OSC {- hosc -}
import System.Process {- process -}
import Text.Printf {- base -}

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

-- * Block diagram data type

-- | The /write/ and /read/ 'Id's, and the wire type.
type Rec_Id = (Id,Id,TypeRep)

-- | Block diagram.
data BD = Constant (Maybe Id) K
        | Prim (Maybe Id) String [TypeRep] (Maybe TypeRep)
        | Par BD BD
        | Seq BD BD
        | Split BD BD
        | Rec (Maybe [Rec_Id]) BD BD
          deriving (Eq,Show)

instance Num BD where
    p + q = (p ~. q) ~:> (ty_add p q)
    p - q = (p ~. q) ~:> (ty_sub p q)
    p * q = (p ~. q) ~:> (ty_mul p q)
    abs = ty_uop bd_ty_uniform i_abs r_abs
    negate = ty_uop bd_ty_uniform i_negate r_negate
    signum = undefined
    fromInteger = i_constant . fromInteger

instance Fractional BD where
    p / q = (p ~. q) ~:> (ty_div p q)
    fromRational = r_constant . fromRational

-- * Identifiers

-- | Read identifier.
bd_id :: BD -> Maybe Id
bd_id bd =
    case bd of
      Constant k _ -> k
      Prim k _ _ _ -> k
      _ -> Nothing

-- | Erroring 'bd_id'.
bd_req_id :: BD -> Id
bd_req_id = fromMaybe (error "bd_req_id") . bd_id

-- * Pretty printing

-- | Pretty printer for 'BD'.
bd_pp :: BD -> String
bd_pp bd =
    case bd of
      Constant _ n -> show n
      Prim _ nm _ _ -> nm
      Par _ _ -> ","
      Seq _ _ -> ":"
      Split _ _ -> "<:"
      Rec _ _ _ -> "~"

-- * Diagram types and signature

-- | Diagram type signature, ie. 'port_ty' at 'ports'.
bd_signature :: BD -> ([TypeRep],[TypeRep])
bd_signature = let f = map port_ty in bimap f f . ports

-- | Type of /output/ ports of 'BD'.
bd_ty :: BD -> [TypeRep]
bd_ty = map port_ty . snd . ports

-- | Type of /uniform/ output ports of 'BD'.
bd_ty_uniform :: BD -> Maybe TypeRep
bd_ty_uniform bd =
    case nub (bd_ty bd) of
      [t] -> Just t
      _ -> Nothing

-- | Type of /singular/ output port of 'BD'.
bd_ty1 :: BD -> Maybe TypeRep
bd_ty1 bd =
    let (_,op) = ports bd
    in case op of
      [Output_Port (Constant _ n)] -> Just (typeOf n)
      [Output_Port (Prim _ _ _ (Just o))] -> Just o
      _ -> Nothing

-- * Operator synonyms

infixl 4 `rec`, ~~
infixl 3 `Par`, ~.
infixl 2 `Seq`, ~:
infixl 1 `split`, ~<:
infixl 1 `merge`, ~:>

-- | Faust uses single tilde, which is reserved by "GHC.Exts".
(~~) :: BD -> BD -> BD
(~~) = rec

-- | Faust uses comma, which is reserved by "Data.Tuple", and indeed
-- @~,@ is not legal either.
(~.) :: BD -> BD -> BD
(~.) = Par

-- | Faust uses ':', which is reserved by "Data.List".
(~:) :: BD -> BD -> BD
(~:) = Seq

-- | Faust uses '<:', which is legal, however see '~:>'.
(~<:) :: BD -> BD -> BD
(~<:) = split

-- | Faust uses ':>', however ':' is not allowed as a prefix.
--
-- > draw (graph (par_l [1,2,3,4] ~:> i_mul))
-- > draw (graph (par_l [1,2,3] ~:> i_negate))
(~:>) :: BD -> BD -> BD
(~:>) = merge

-- * Fold and traverse

-- | Fold over 'BD', signature as 'foldl'.
bd_foldl :: (t -> BD -> t) -> t -> BD -> t
bd_foldl f st bd =
    let g p q = f (bd_foldl f (bd_foldl f st p) q) bd
    in case bd of
         Constant _ _ -> f st bd
         Prim _ _ _ _ -> f st bd
         Par p q -> g p q
         Seq p q -> g p q
         Split p q -> g p q
         Rec _ p q -> g p q

-- | Traversal with state, signature as 'mapAccumL'.
bd_traverse :: (st -> BD -> (st,BD)) -> st -> BD -> (st,BD)
bd_traverse f st bd =
    let g j t p q = let (t',p') = bd_traverse f t p
                        (t'',q') = bd_traverse f t' q
                    in f t'' (j p' q')
    in case bd of
         Constant _ _ -> f st bd
         Prim _ _ _ _ -> f st bd
         Par p q -> g Par st p q
         Seq p q -> g Seq st p q
         Split p q -> g Split st p q
         Rec k p q -> g (Rec k) st p q

-- * Introduce node identifiers

-- | 'Rec' nodes introduce identifiers for each backward arc.  /k/ is
-- the initial 'Id', /n/ the number of arcs, and /ty/ the arc types.
--
-- > rec_ids 5 2 [int32_t,float_t] == [(5,6,int32_t),(7,8,float_t)]
rec_ids :: Id -> Int -> [TypeRep] -> [Rec_Id]
rec_ids k n ty =
    let k' = k + (n * 2) - 1
        (p,q) = unzip (adjacent [k .. k'])
    in zip3 p q ty

-- | Set identifiers at 'Constant', 'Prim', and 'Rec' nodes.
bd_set_id :: BD -> (Id,BD)
bd_set_id =
    let f k bd =
            case bd of
              Constant _ n -> (k + 1,Constant (Just k) n)
              Prim _ nm i o -> (k + 1,Prim (Just k) nm i o)
              Rec _ p q -> let n = out_degree q
                               k' = rec_ids k n (bd_ty q)
                           in (k + (n * 2),Rec (Just k') p q)
              _ -> (k,bd)
    in bd_traverse f 0

-- * Degree

-- | Node degree as /(input,output)/ pair.
type Degree = (Int,Int)

-- | 'Degree' of block diagram 'BD'.
degree :: BD -> Degree
degree bd =
    case bd of
      Constant _ _ -> (0,1)
      Prim _ _ i o -> (length i,maybe 0 (const 1) o)
      Par p q -> (in_degree p + in_degree q,out_degree p + out_degree q)
      Seq p q ->
          let (ip,op) = degree p
              (iq,oq) = degree q
          in case op `compare` iq of
               EQ -> (ip,oq)
               GT -> (ip,oq + op - iq)
               LT -> (ip + iq - op,oq)
      Split p q -> (in_degree p,out_degree q)
      Rec _ p q -> (in_degree p - out_degree q,out_degree p)

-- | 'fst' of 'degree'.
in_degree :: BD -> Int
in_degree = fst . degree

-- | 'snd' of 'degree'.
out_degree :: BD -> Int
out_degree = snd . degree

-- * Ports

-- | The index of an 'Input_Port', all outputs are unary.
type Port_Index = Int

-- | Port (input or output) at block diagram.
data Port = Input_Port {port_bd :: BD, port_index :: Port_Index}
          | Output_Port {port_bd :: BD}
            deriving (Eq,Show)

-- | The left and right /outer/ ports of a block diagram.
ports :: BD -> ([Port],[Port])
ports bd =
    case bd of
      Constant _ _ -> ([],[Output_Port bd])
      Prim _ _ i o -> (map (Input_Port bd) [0 .. length i - 1]
                      ,maybe [] (const [Output_Port bd]) o)
      Par p q -> let (ip,op) = ports p
                     (iq,oq) = ports q
                 in (ip ++ iq,op ++ oq)
      Seq p q ->
          let (_,opk) = degree p
              (iqk,_) = degree q
              (ip,op) = ports p
              (iq,oq) = ports q
          in case opk `compare` iqk of
               EQ -> (ip,oq)
               GT -> (ip,oq ++ (drop iqk op))
               LT -> (ip ++ (drop opk iq),oq)
      Split p q -> let (ip,_) = ports p
                       (_,oq) = ports q
                   in (ip,oq)
      Rec _ p q -> let (ip,op) = ports p
                       k = out_degree q
                   in (drop k ip,op)

-- | Type of 'Port'.
port_ty :: Port -> TypeRep
port_ty p =
    case p of
      Output_Port (Constant _ n) -> typeOf n
      Input_Port (Prim _ _ i _) k -> i !! k
      Output_Port (Prim _ _ _ (Just o)) -> o
      _ -> undefined

-- * Wires

-- | Enumeration of wire types.
data Wire_Ty = Normal -- ^ Normal forward edge.
             | Backward Rec_Id  -- ^ Backward edge.
             | Implicit_Normal -- ^ Implicit wire from /recRd/ to node.
             | Implicit_Rec -- ^ Implicit wire from node to /recWr/.
             | Implicit_Backward -- ^ Implicit wire from /recWr/ to /recRd/.
               deriving (Eq,Show)

-- | A 'Wire' runs between two 'Ports'.
type Wire = (Port,Port,Wire_Ty)

-- | Set of 'Normal' wires between 'Port's.
normal_wires :: [Port] -> [Port] -> [Wire]
normal_wires = let f p q = (p,q,Normal) in zipWith f

-- | Set of 'Backward' wires between 'Port's.
rec_back_wires :: [Rec_Id] -> [Port] -> [Port] -> [Wire]
rec_back_wires = let f k p q = (p,q,Backward k) in zipWith3 f

-- | Immediate internal wires of a block diagram.
wires_immed :: BD -> [Wire]
wires_immed bd =
    case bd of
      Constant _ _ -> []
      Prim _ _ _ _ -> []
      Par _ _ -> []
      Seq p q -> let (_,op) = ports p
                     (iq,_) = ports q
                 in normal_wires op iq
      Split p q -> let (_,op) = ports p
                       (iq,_) = ports q
                   in normal_wires (cycle op) iq
      Rec (Just k) p q ->
          let (ip,op) = ports p
              (iq,oq) = ports q
          in rec_back_wires k oq ip ++ normal_wires op iq
      Rec Nothing _ _ -> error "wires_immed"

-- | Internal wires of a block diagram.
wires :: BD -> [Wire]
wires = bd_foldl (\st r -> st ++ wires_immed r) []

-- * Coherence

-- | A wire coheres if the 'port_ty' of the left and right hand sides
-- are equal.
wire_coheres :: Wire -> Bool
wire_coheres (p,q,_) = port_ty p == port_ty q

-- | The set of non-coherent wires at diagram.
bd_non_coherent :: BD -> [Wire]
bd_non_coherent = filter (not . wire_coheres) . wires

-- | Coherence predicate, ie. is 'bd_non_coherent' empty.
bd_is_coherent :: BD -> Bool
bd_is_coherent = null . bd_non_coherent

-- * Graph

-- | Primitive block diagram elements.
data Node = N_Constant {n_constant_id :: Id
                       ,n_constant_k :: K}
          | N_Prim {n_prim_id :: Either Id (Id,Id)
                   ,n_prim_name :: String
                   ,n_prim_in_degree :: Int
                   ,n_prim_ty :: Maybe TypeRep}
            deriving (Eq)

-- | Extract the current /actual/ node /id/ from 'n_prim_id'.
actual_id :: Either Id (Id,Id) -> Id
actual_id = either id fst

-- | Output type of 'Node', if out degree non-zero.
node_ty :: Node -> Maybe TypeRep
node_ty n =
    case n of
      N_Constant _ k -> Just (k_typeOf k)
      N_Prim _ _ _ ty -> ty

-- | Either 'n_constant_id' or 'actual_id' of 'n_prim_id'.
node_id :: Node -> Id
node_id n =
    case n of
      N_Constant k _ -> k
      N_Prim k _ _ _ -> actual_id k

-- | Pair 'Node' 'Id' with node.
node_lift_id :: Node -> (Id,Node)
node_lift_id n = (node_id n,n)

-- | Pretty printer, and 'Show' instance.
node_pp :: Node -> String
node_pp n =
    case n of
      N_Constant _ k -> k_concise k
      N_Prim _ nm _ _ -> nm

instance Show Node where show = node_pp

-- | Primitive edge, left hand 'Id', right hand side 'Id', right hand
-- 'Port_Index' and edge /type/.
type Edge = (Id,Id,(Port_Index,Wire_Ty))

-- | A graph is a list of 'Node' and a list of 'Edge's.
type Graph = ([Node],[Edge])

-- | Is 'Wire_Ty' of 'Edge' 'Implicit_Backward'.
edge_is_implicit_backward :: Edge -> Bool
edge_is_implicit_backward (_,_,(_,ty)) = ty == Implicit_Backward

-- | Implicit /rec/ nodes.
rec_nodes :: [Rec_Id] -> [Node]
rec_nodes =
    let f (i,j,ty) = [N_Prim (Right (i,i)) "df_rec_w" 1 (Just ty)
                     ,N_Prim (Right (j,i)) "df_rec_r" 1 (Just ty)]
    in concatMap f

-- | Collect all primitive nodes at a block diagram.
nodes :: Bool -> BD -> [Node]
nodes impl bd =
    let f = nodes impl
    in case bd of
         Constant (Just k) n -> [N_Constant k n]
         Constant _ _ -> error "nodes"
         Prim (Just k) nm i o -> [N_Prim (Left k) nm (length i) o]
         Prim _ _ _ _ -> error "nodes"
         Par p q -> f p ++ f q
         Seq p q -> f p ++ f q
         Split p q -> f p ++ f q
         Rec (Just k) p q -> f p ++ f q ++ if impl then rec_nodes k else []
         Rec _ _ _ -> error "nodes"

-- | A backward 'Wire' will introduce three /implicit/ edges, a
-- 'Normal' wire introduces one 'Normal' edge.
wire_to_edges :: Bool -> Wire -> [Edge]
wire_to_edges impl w =
    case w of
      (Output_Port p,Input_Port q qn,Backward (k0,k1,ty)) ->
          if impl
          then [(bd_req_id p,k0,(0,Implicit_Rec))
               ,(k1,bd_req_id q,(qn,Implicit_Normal))
               ,(k0,k1,(0,Implicit_Backward))]
          else [(bd_req_id p,bd_req_id q,(qn,Backward (k0,k1,ty)))]
      (Output_Port p,Input_Port q qn,Normal) ->
          [(bd_req_id p,bd_req_id q,(qn,Normal))]
      _ -> error (show ("wire_to_edges",w))

-- | 'concatMap' of 'wire_to_edges'.
wires_to_edges :: Bool -> [Wire] -> [Edge]
wires_to_edges impl = concatMap (wire_to_edges impl)

-- | 'wires_to_edges' of 'wires'.
edges :: Bool -> BD -> [Edge]
edges impl = wires_to_edges impl . wires

-- | Construct 'Graph' of block diagram, either with or without
-- /implicit/ edges.
graph' :: Bool -> BD -> Graph
graph' impl bd =
    let (_,bd') = bd_set_id bd
        n = nub (nodes impl bd')
        w = wires bd'
        e = wires_to_edges impl w
    in case filter (not . wire_coheres) w of
         [] -> (n,e)
         w' -> error (show ("graph': incoherent",w'))

-- | Construct 'Graph' of block diagram without /implicit/ edges.
-- This graph will include backward arcs if the graph contains /rec/s.
graph :: BD -> Graph
graph = graph' False

-- * Gr

-- | FGL graph of 'BD'.
type Gr = G.Gr Node (Port_Index,Wire_Ty)

-- | Transform 'BD' to 'Gr'.
gr :: BD -> Gr
gr bd =
    let (n,e) = graph' True bd
        n' = map node_lift_id n
        e' = filter (not . edge_is_implicit_backward) e
    in G.mkGraph n' e'

-- | Topological sort of nodes (via 'gr').
tsort :: BD -> Graph
tsort bd =
    let g = gr bd
    in (map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)
       ,G.labEdges g)

-- | Make @dot@ rendering of graph at 'Node'.
gr_dot :: BD -> String
gr_dot = G.graphviz' . gr

-- | 'draw_dot' of 'gr_dot'.
gr_draw :: BD -> IO ()
gr_draw = draw_dot . gr_dot

-- * Drawing

-- | Dot description of 'Node'.
dot_node :: Node -> String
dot_node nd =
    case nd of
      N_Constant k c -> dot_rec' k (k_concise c) [] (k_typeOf c)
      N_Prim k nm i o -> dot_rec (actual_id k) nm (dot_rec_ar i) o

-- | Wires are coloured according to type.
wire_colour :: Wire_Ty -> String
wire_colour w =
    case w of
      Normal -> "black"
      Backward _ -> "red"
      Implicit_Normal -> "grey"
      Implicit_Rec -> "blue"
      Implicit_Backward -> "red"

-- | Dot description of 'Edge'.
dot_edge :: Edge -> String
dot_edge (p,q,(k,d)) =
    let c = wire_colour d
    in printf "%d:o_0 -> %d:i_%d %s;" p q k (dot_attr [("color",c)])

-- | Dot description of 'Graph'.
dot_graph :: Graph -> [String]
dot_graph (n,e) =
    concat [["digraph Anonymous {"
            ,"graph [splines=false];"]
           ,map dot_node n
           ,map dot_edge e
           ,["}"]]

-- | Draw dot graph.
draw_dot :: String -> IO ()
draw_dot d = do
  writeFile "/tmp/faust.dot" d
  _ <- system "dotty /tmp/faust.dot"
  return ()

-- | 'draw_dot' of 'dot_graph'.
draw :: Graph -> IO ()
draw = draw_dot . unlines . dot_graph

-- * Composition

-- | Fold of 'Par'.
--
-- > degree (par_l [1,2,3,4]) == (0,4)
-- > draw (graph (par_l [1,2,3,4] ~:> i_mul))
par_l :: [BD] -> BD
par_l = foldr1 Par

-- | Type-directed sum.
--
-- > draw (graph (bd_sum [1,2,3,4]))
bd_sum :: [BD] -> BD
bd_sum l =
    case l of
      [] -> error "bd_sum"
      [d] -> d
      p:q:l' -> bd_sum (((p ~. q) ~: (ty_add p q)) : l')

-- | Predicate to determine if /p/ can be /split/ onto /q/.
split_r :: BD -> BD -> Bool
split_r p q =
    let (i,j) = in_degree q `divMod` out_degree p
    in i >= 1 && j == 0

-- | /split/ if diagrams cohere.
split_m :: BD -> BD -> Maybe BD
split_m p q =
    if split_r p q
    then Just (Split p q)
    else Nothing

-- | /split/ if diagrams cohere, else 'error'.  Synonym of '~<:'.
split :: BD -> BD -> BD
split p = fromMaybe (error "split") . split_m p

-- | If merge is legal, the number of in-edges per port at /q/.
--
-- > merge_degree (par_l [1,2,3]) i_negate == Just 3
-- > merge_degree (par_l [1,2,3,4]) i_mul == Just 2
merge_degree :: BD -> BD -> Maybe Int
merge_degree p q =
    let (i,j) = out_degree p `divMod` in_degree q
    in if i > 1 && j == 0 then Just i else Nothing

-- | /merge/ if diagrams cohere.
--
-- > merge_m (par_l [1,2,3]) i_negate
-- > merge_m (par_l [1,2,3,4]) i_mul
merge_m :: BD -> BD -> Maybe BD
merge_m p q =
    case merge_degree p q of
      Just n ->
          let (_,op) = ports p
              (iq,_) = degree q
              op' = map port_bd op
              p' = if iq == 1
                   then [op']
                   else transpose (S.chunksOf n op')
          in Just (Seq (par_l (map bd_sum p')) q)
      _ -> Nothing

-- | /merge/ if diagrams cohere, else 'error'.  Synonym of '~:>'.
merge :: BD -> BD -> BD
merge p = fromMaybe (error "merge") . merge_m p

-- | Predicate to determine if /p/ can be /rec/ onto /q/.
rec_r :: BD -> BD -> Bool
rec_r p q = out_degree p >= in_degree q && in_degree p >= out_degree q

-- | /rec/ if diagrams cohere.
rec_m :: BD -> BD -> Maybe BD
rec_m p q =
    if rec_r p q
    then Just (Rec Nothing p q)
    else Nothing

-- | /rec/ if diagrams cohere, else 'error'.  Synonym of '~~'.
rec :: BD -> BD -> BD
rec p = fromMaybe (error "rec") . rec_m p

-- * Constants

-- | Integer constant.
i_constant :: Int -> BD
i_constant = Constant Nothing . I . fromIntegral

-- | Real constant.
r_constant :: Float -> BD
r_constant = Constant Nothing . F

-- * Primitives

-- | Construct uniform /type/ primitive diagram.
u_prim :: TypeRep -> String -> Int -> BD
u_prim ty nm i = Prim Nothing nm (replicate i ty) (Just ty)

-- | 'u_prim' of 'int32_t'.
i_prim :: String -> Int -> BD
i_prim = u_prim int32_t

-- | 'u_prim' of 'float_t'.
r_prim :: String -> Int -> BD
r_prim = u_prim float_t

-- | Adddition, ie. '+' of 'Num'.
--
-- > (1 ~. 2) ~: i_add
-- > (1 :: BD) + 2
i_add,r_add :: BD
i_add = i_prim "df_add" 2
r_add = r_prim "df_add" 2

-- | Subtraction, ie. '-' of 'Num'.
i_sub,r_sub :: BD
i_sub = i_prim "df_sub" 2
r_sub = r_prim "df_sub" 2

-- | Multiplication, ie. '*' of 'Num'.
i_mul,r_mul :: BD
i_mul = i_prim "df_mul" 2
r_mul = r_prim "df_mul" 2

-- | Division, ie. 'div' of 'Integral'.
i_div :: BD
i_div = i_prim "df_div" 2

-- | Division, ie. '/' of 'Fractional'.
r_div :: BD
r_div = r_prim "df_div" 2

-- | Absolute value, ie. 'abs' of 'Num'.
i_abs,r_abs :: BD
i_abs = i_prim "df_abs" 1
r_abs = r_prim "df_abs" 1

-- | Negation, ie. 'negate' of 'Num'.
i_negate,r_negate :: BD
i_negate = i_prim "df_negate" 1
r_negate = r_prim "df_negate" 1

-- | Identity diagram.
i_identity, r_identity :: BD
i_identity = u_prim int32_t "df_identity" 1
r_identity = u_prim float_t "df_identity" 1

-- | Coerce 'float_t' to 'int32_t'.
float_to_int32 :: BD
float_to_int32 = Prim Nothing "df_float_to_int32" [float_t] (Just int32_t)

-- | Coerce 'int32_t' to 'float_t'.
int32_to_float :: BD
int32_to_float = Prim Nothing "df_int32_to_float" [int32_t] (Just float_t)

-- | 'int32_to_float' and then scale to be in (-1,1).
i32_to_normal_f32 :: BD
i32_to_normal_f32 = (int32_to_float ~. 2147483647.0) ~: r_div

-- | Single channel output.
--
-- > degree out1 == (1,0)
-- > bd_signature out1 == ([float_t],[])
out1 :: BD
out1 = Prim Nothing "df_out1" [float_t] Nothing

-- * Type following primitives

-- | Type following unary operator.
ty_uop :: (BD -> Maybe TypeRep) -> t -> t -> BD -> t
ty_uop ty f g p =
    let p' = ty p
    in if p' == Just int32_t
       then f
       else if p' == Just float_t
            then g
            else error "ty_uop"

-- | Type following binary operator.
ty_binop :: (BD -> Maybe TypeRep) -> t -> t -> BD -> BD -> t
ty_binop ty f g p q =
    let p' = ty p
        q' = ty q
    in if p' == Just int32_t && q' == Just int32_t
       then f
       else if p' == Just float_t && q' == Just float_t
            then g
            else error "ty_binop"

-- | Type following math operator, uniform types.
--
-- > 1.0 `ty_add` 2.0 == r_add
-- > (1 ~. 2) `ty_add` (3 ~. 4) == i_add
-- > 1.0 `ty_add` 2 == _|_
-- > draw (graph ((1 ~. 2) - (3 ~. 4)))
ty_add,ty_sub,ty_mul,ty_div :: BD -> BD -> BD
ty_add = ty_binop bd_ty_uniform i_add r_add
ty_sub = ty_binop bd_ty_uniform i_sub r_sub
ty_mul = ty_binop bd_ty_uniform i_mul r_mul
ty_div = ty_binop bd_ty_uniform i_div r_div

-- | Type following math operator, singular types.
--
-- > 1.0 `ty_add1` 2.0 == r_add
-- > 1.0 `ty_add1` 2 == _|_
ty_add1,ty_mul1,ty_div1 :: BD -> BD -> BD
ty_add1 = ty_binop bd_ty1 i_add r_add
ty_mul1 = ty_binop bd_ty1 i_mul r_mul
ty_div1 = ty_binop bd_ty1 i_div r_div

-- * Code Gen

-- | List of constants for CGen.
cg_k :: [Node] -> [(Id,K)]
cg_k =
    let f n = case n of
                N_Constant k c -> Just (k,c)
                _ -> Nothing
    in mapMaybe f

-- | 'Var' of 'Node'.
cg_node_var :: Node -> Maybe Var
cg_node_var n =
    case n of
      N_Constant k c -> Just (k_var k Std_Var c)
      N_Prim k _ _ (Just ty) ->
          case k of
            Left k' -> Just (Std_Var,ty,k',Nothing)
            Right (k',k'') ->
                if k' == k''
                then Just (Rec_Var,ty,k',Just (Left 0))
                else Just (Std_Var,ty,k',Nothing)
      N_Prim _ _ _ Nothing -> Nothing

-- | Output reference for 'Node'.
node_output :: Node -> Maybe (Var_Ty,Id)
node_output n =
    case n of
      N_Prim _ _ _ Nothing -> Nothing
      N_Constant k _ -> Just (Std_Var,k)
      N_Prim (Right (k,_)) "df_rec_r" _ _ -> Just (Std_Var,k)
      N_Prim (Right (k,_)) "df_rec_w" _ _ -> Just (Rec_Var,k)
      N_Prim (Right _) _ _ _ -> error "node_output: Right"
      N_Prim (Left k) _ _ _ -> Just (Std_Var,k)

-- | Input references for 'Node'.
node_inputs :: [Edge] -> Node -> [(Var_Ty,Id)]
node_inputs e n =
    let f k (_,k',_) = k == k'
        g (k,_,(p,_)) = (p,k)
        i = sort (map g (filter (f (node_id n)) e))
    in case n of
         N_Prim (Right (_,k)) "df_rec_r" _ _ -> [(Rec_Var,k)]
         _ -> zip (repeat Std_Var) (map snd i)

-- | 'C_Call' of 'Node'.
cg_node_c_call :: [Edge] -> Node -> Maybe C_Call
cg_node_c_call e n =
    case n of
      N_Constant _ _ -> Nothing
      N_Prim _ nm _ _ -> let i = node_inputs e n
                             i' = case node_output n of
                                    Just o -> o : i
                                    Nothing -> i
                         in Just (Nothing,nm,i')

-- | Generate CGen 'Instructions' for 'BD'.
bd_instructions :: BD -> Instructions
bd_instructions bd =
    let (n,e) = tsort bd
    in (cg_k n
       ,mapMaybe cg_node_var n
       ,mapMaybe (cg_node_c_call e) n)

-- * Audition

-- | Audition graph after sending initialisation messages.
audition :: [Message] -> BD -> IO ()
audition is bd = L.audition is (bd_instructions bd)

-- * Figures from /Quick Reference/

-- | Figure illustrating '~.'.
--
-- > degree fig_3_2 == (2,2)
-- > draw (graph fig_3_2)
fig_3_2 :: BD
fig_3_2 = 10.0 ~. r_mul

-- | Figure illustrating '~:'.
--
-- > degree fig_3_3 == (4,1)
-- > bd_signature fig_3_3
-- > draw (graph fig_3_3)
fig_3_3 :: BD
fig_3_3 = (r_mul ~. r_div) ~: r_add

-- | Figure illustrating '~<:'.
--
-- > degree fig_3_4 == (0,3)
-- > draw (graph fig_3_4)
fig_3_4 :: BD
fig_3_4 = (10.0 ~. 20.0) ~<: (par_l [r_add,r_mul,r_div])

-- | Figure illustrating '~:>'.
--
-- > degree fig_3_5 == (0,1)
-- > draw (graph fig_3_5)
fig_3_5 :: BD
fig_3_5 = par_l [10,20,30,40] ~:> i_mul

-- | Figure illustrating '~~'.
--
-- > degree fig_3_6 == (0,1)
-- > draw (graph fig_3_6)
fig_3_6 :: BD
fig_3_6 =
    let p = 12345 ~: i_add
        q = 1103515245 ~: i_mul
    in p ~~ q

-- | Variant generating audible graph.
--
-- > draw (graph fig_3_6')
-- > gr_draw fig_3_6'
-- > audition [] fig_3_6'
fig_3_6' :: BD
fig_3_6' = fig_3_6 ~: i32_to_normal_f32 ~: (0.1 ~: r_mul) ~: out1

-- | A counter, illustrating /identity/ diagram.
--
-- > draw (graph (i_counter ~: i_negate))
-- > gr_draw (i_counter ~: i_negate)
i_counter :: BD
i_counter = (1 ~: i_add) ~~ i_identity

-- * List

-- | Adjacent elements of list.
--
-- > adjacent [1..4] == [(1,2),(3,4)]
adjacent :: [t] -> [(t,t)]
adjacent l =
    case l of
      [] -> []
      p:q:l' -> (p,q) : adjacent l'
      _ -> error "adjacent"

-- * Tuple

-- | Bimap at tuple.
--
-- > bimap abs negate (-1,1) == (1,-1)
bimap :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)
bimap f g (p,q) = (f p,g q)