{-# LANGUAGE Arrows, FlexibleContexts #-}

module RMCA.Layer.Board ( boardSF
                        ) where

import FRP.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Layer.Layer
import RMCA.Semantics

-- The state of the board is described by the list of the playheads
-- and the different actions onto the board.
boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
               (Event ([PlayHead], [Note]))
boardAction = proc ((board, Layer { relPitch    = rp
                                  , strength    = s
                                  },ph), ebno) ->
  arr $ fmap (uncurry5 advanceHeads)
  -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
  --returnA -< traceShow e e

boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
boardSF = proc (board, l, ph, t) -> do
  ebno <- layerMetronome -< (t, l)
  boardAction -< ((board, l, ph), ebno)

{-
-- We need the list of initial playheads
boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
boardSF iph = proc (board, l@Layer { relPitch = rp
                                   , strength = s
                                   }, t) -> do
  ebno <- layerMetronome -< (t,l)
  boardSF' iph -< ((board, l), ebno)
  where
    boardSF' :: [PlayHead] -> SF ((Board, Layer), Event BeatNo) (Event [Note])
    boardSF' ph = dSwitch (boardAction ph >>> arr splitE >>> arr swap)
                  (\nph -> second notYet >>> boardSF' nph)


{-
boardSetup :: Board
           -> ReactiveFieldReadWrite IO Tempo
           -> ReactiveFieldReadWrite IO Layer
           -> ReactiveFieldReadWrite IO [Note]
           -> IO ()
boardSetup board tempoRV layerRV outBoardRV = do
  layer <- reactiveValueRead layerRV
  tempo <- reactiveValueRead tempoRV
  (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)
  let inRV =  pairRW layerRV tempoRV
  clock <- mkClockRV 10
  inRV =:> inBoard
  clock ^:> inRV
  reactiveValueOnCanRead outBoard
    (reactiveValueRead outBoard >>= reactiveValueWrite outBoardRV . event [] id)
  putStrLn "Board started."
  n <- newEmptyMVar
  takeMVar n
  return ()
-}
-}