{-# LANGUAGE DoRec, ScopedTypeVariables, FlexibleContexts, TypeFamilies, ParallelListComp, TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes, UndecidableInstances, TypeOperators, NoMonomorphismRestriction #-}
module Language.KansasLava.Protocols.Patch
  -- (Patch, bus, ($$),
  -- emptyP,forwardP, backwardP,dupP,zipPatch,
  -- fstP,matrixDupP,matrixStackP,matrixZipPatch,
  -- fifo1, fifo2)
  where

import Language.KansasLava.Protocols.Enabled
import Language.KansasLava.Protocols.Types

import Language.KansasLava.Rep
import Language.KansasLava.Types
import Language.KansasLava.Utils
import Language.KansasLava.Signal
--import Language.KansasLava.Probes

import Data.Sized.Unsigned (U8)
import Data.Sized.Matrix as M

import qualified Data.ByteString.Lazy as B
import Control.Applicative
import Control.Monad.Fix

---------------------------------------------------------------------------
-- The Patch.
---------------------------------------------------------------------------

-- | A Patch is a data signal with an associated control signal. The 'lhs_in'
-- type parameter is the type of the data input, the 'rhs_out' type parameter is
-- the type of the data output. The 'rhs_in' is the type of the control input
-- (e.g. a 'ready' signal), and the 'lhs_out' is the type of the control output
-- (e.g. 'ack').
type Patch lhs_in 	   rhs_out
	   lhs_out         rhs_in
	= (lhs_in,rhs_in) -> (lhs_out,rhs_out)

---------------------------------------------------------------------------
-- Executing the Patch, monadic style.
---------------------------------------------------------------------------

-- | outputP produces a constant data output. The control inputs/outputs are
-- unit, so they contain no data.
outputP :: a -> Patch () a
		        () ()
outputP a = \ _ -> ((),a)


runP :: (Unit u1, Unit u2)
 	 => Patch u1   a
	 	  u2  () -> a
runP p = a
 where
   (_,a) = p (unit,unit)

execP :: Patch a b
 		   c d
 	  -> (a,d) -> (c,b)
execP = id


-- | A patch that passes through data and control.
emptyP :: Patch a  a
	         b  b
emptyP ~(a,b) = (b,a)

-- | Given a patch, add to the data and control inputs/outputs a second set of
-- signals that are passed-through. The signals of the argument patch to fstP
-- will appear as the first element of the pair in the resulting patch.
fstP :: Patch a   b
		  c   e -> Patch (a :> f) (b :> f)
				 (c :> g) (e :> g)
fstP p = p `stackP` emptyP

-- | Given a patch, add to the data and control inputs/outputs a second set of
-- signals that are passed-through. The signals of the argument patch to sndP
-- will appear as the second element of the pair in the resulting patch.
sndP :: Patch a   b
		  c   d -> Patch (f :> a) (f :> b)
				 (g :> c) (g :> d)
sndP p = emptyP `stackP` p

{-
-- | 'matrixSplicePatch' splices/inserts a patch into a matrix of signals at the position
-- given by index.  (Note:  The first position is index 0)
matrixSplicePatch :: (Size x, Integral x)
            => x
            -> Patch a   a
                     b   b -> Patch (Matrix x a) (Matrix x a)
                                    (Matrix x b) (Matrix x b)
matrixSplicePatch index p ~(mlhs_in, mrhs_in) = (mlhs_out, mrhs_out)
  where
    lhs_in = mlhs_in M.! index
    rhs_in = mrhs_in M.! index

    (lhs_out, rhs_out) = p (lhs_in, rhs_in)

    indexInt = (fromIntegral index) :: Int
    mlhs_out = M.matrix $ (take indexInt $ M.toList mrhs_in) ++ lhs_out:(drop (indexInt+1) $ M.toList mrhs_in)
    mrhs_out = M.matrix $ (take indexInt $ M.toList mlhs_in) ++ rhs_out:(drop (indexInt+1) $ M.toList mlhs_in)
-}

-- | Lift a function to a patch, applying the function to the data input.
forwardP :: (li -> ro)
	    -> Patch li ro
	             b  b
forwardP f1 ~(li,ri) = (ri,f1 li)

-- | Lift a function to a patch, applying the function to the control input.
backwardP :: (ri -> lo)
	    -> Patch a  a
	             lo ri
backwardP f2 ~(li,ri) = (f2 ri,li)

-- TODO: above or ??

infixr 3 `stackP`
-- | Given two patches, tuple their data/control inputs and outputs.
stackP :: Patch li1		ro1
               lo1    		ri1
      -> Patch li2		ro2
               lo2    		ri2
      -> Patch (li1 :> li2)			(ro1 :> ro2)
               (lo1 :> lo2)   			(ri1 :> ri2)
stackP p1 p2 inp = (lo1 :> lo2,ro1 :> ro2)
   where
	(li1 :> li2,ri1 :> ri2)	     = inp
	(lo1,ro1)		     = p1 (li1,ri1)
	(lo2,ro2)		     = p2 (li2,ri2)

-- | Given a homogeneous list (Matrix) of patches, combine them into a single
-- patch, collecting the data/control inputs/outputs into matrices.
matrixStackP :: (m ~ (Matrix x), Size x)
 	=> m (Patch li   ro
	   	    lo   ri)
	-> Patch (m li)         (m ro)
		 (m lo)         (m ri)
matrixStackP m inp = ( fmap (\ (l,_) -> l) m'
		    , fmap (\ (_,r) -> r) m'
		    )
   where
	(m_li,m_ri)	= inp
	m' = (\ p li ri -> p (li,ri)) <$> m <*> m_li <*> m_ri


-- | loopP is a fixpoint style combinator, for backedges.
loopP :: Patch (a :> b) (a :> c)
		   (d :> e) (d :> f)
	  -> Patch b c
		   e f
loopP g ~(b,f) = (e,c)
  where
    (d:>e,a:>c) = g (a:>b,d:>f)

openP :: Patch c (() :> c)
	           d (() :> d)
openP = forwardP (\ a -> (() :> a)) $$
	    backwardP (\ ~(_ :> a) -> a)
{-
swapP :: (a :> b) -> (b :> a)
assocP :: ((a :> b) :> c) -> (a :> b :> c)
unassocP :: (a :> b :> c) -> ((a :> b) :> c)
closeP :: (() :> b) -> b
copyP  :: a -> (a :> a) -- is DUP
-}

-------------------------------------------------------------------------------
-- maping a combinatorial circuit over a protocol.
-------------------------------------------------------------------------------

mapP :: forall a b c sig ack . (Rep a, Rep b, Clock c, sig ~ Signal c)
	 => (forall clk' . Signal clk' a -> Signal clk' b)
	 -> Patch (sig (Enabled a)) (sig (Enabled b))
	   	  (ack)		    (ack)
mapP = forwardP . mapEnabled

------------------------------------------------
-- Unit
------------------------------------------------

-- | An instance of the Unit type contains a value that carries no information.
class Unit unit where
  -- | The name of the specific value.
  unit :: unit


unUnit :: (Unit unit) => unit -> ()
unUnit _ = ()

instance Unit () where unit = ()
instance (Unit a,Unit b) => Unit (a,b) where unit = (unit,unit)
instance (Unit a,Unit b) => Unit (a :> b) where unit = (unit :> unit)
instance (Unit a,Size x) => Unit (Matrix x a) where unit = pure unit

------------------------------------------------
-- File I/O for Patches
------------------------------------------------

-- | 'rawReadP' reads a binary file into Patch, which will become the
-- lefthand side of a chain of patches.
rawReadP :: FilePath -> IO (Patch ()			[Maybe U8]
			          ()			())
rawReadP fileName = do
     fileContents <- B.readFile fileName
     return $ outputP $ map (Just . fromIntegral) $ B.unpack fileContents

-- | 'readPatch' reads an encoded file into Patch, which will become the
-- lefthand side of a chain of patches.
readP :: (Read a)
	  => FilePath -> IO (Patch ()	[Maybe a]
	                           ()	())
readP fileName = do
     fileContents <- readFile fileName
     return $ outputP $ map (Just . read) $ words $ fileContents

-- | 'rawWriteP' runs a complete circuit for the given
-- number of cycles, writing the result to a given file in binary format.
rawWriteP :: (Unit u1, Unit u2)
           => FilePath
	   -> Int
	   -> Patch u1 		[Maybe U8]
	 	    u2		()
	   -> IO ()
rawWriteP fileName n patch = do
  B.writeFile fileName $ B.pack [ fromIntegral x  | Just x <- take n $ runP patch ]

-- | 'writeP' runs a complete circuit for the given
-- number of cycles, writing the result to a given file in string format.
writeP :: (Show a, Unit u1, Unit u2)
	   => FilePath
	   -> Int
	   -> Patch u1 		[Maybe a]
	 	    u2	 	()
	   -> IO ()
writeP fileName n patch = do
  writeFile fileName $ unlines [ show x | Just x <- take n $ runP patch ]

{-
-- | 'compareP' compares the input to the contents of a file, if there
-- there a mismatch, it will print a message giving the element number that
-- failed.  If everything matches, it prints out a "Passed" message
compareP :: (Read a, Show a, Eq a, Unit u1, Unit u2)
             => FilePath
             -> Int
             -> Patch u1     [Maybe a]
                      u2     ()
             -> IO (Patch ()     [Maybe a]
                          ()     () )
compareP fileName n patch = do
     fileContents <- readFile fileName
     let expectedVals = map read $ words $ fileContents
     listCompareP expectedVals n patch

-- | 'listCompareP' compares the input to the contents of a list, if
-- there is a mismatch, it will print a message giving the element number
-- that failed.  If everything matches, it prints out a "Passed" message
listCompareP :: (Read a, Show a, Eq a, Unit u1, Unit u2)
             => [a]
             -> Int
             -> Patch u1     [Maybe a]
                      u2     ()
             -> IO (Patch ()     [Maybe a]
                          ()     () )
listCompareP expectedVals n patch = do
     let inp = runP patch
     let incomingVals = [ x | Just x <- take n $ inp ]
     putStr $ checkAgainstList 0 expectedVals incomingVals
     return $ outputP inp
  where
     checkAgainstList :: (Show a, Eq a) => Int -> [a] -> [a] -> String
     checkAgainstList elemNum []      _                = "Passed, quantity compared:  " ++ (show elemNum)
     checkAgainstList elemNum _       []               = "Passed, but some data in file was not reached, quantity compared:  " ++ (show elemNum)
     checkAgainstList elemNum (e:exs) (i:ins) | (e==i) = checkAgainstList (elemNum+1) exs ins
     checkAgainstList elemNum (e:_)   (i:_)            = "Failed:  Element " ++ (show (elemNum+1)) ++ ": \tExpected:  " ++ (show e) ++ " \tActual:  " ++ (show i)
-}

---------------------------------------------------------------------------
-- Functions that connect streams
---------------------------------------------------------------------------

-- | ($$) composes two patches serially, sharing a common control protocol. The
-- data output of the first patch is fed to the data input of the second
-- patch. The control output of the second patch is fed to the control input of
-- the first patch, and the control output of the first patch is fed to the
-- control input of the second patch.
infixr 5 $$
($$)  ::
  	 Patch li1 	o
	       lo1  	i
      -> Patch o 	ro2
	       i 	ri2
      -> Patch li1	ro2
	       lo1 	ri2
(p1 $$ p2) inp = (lhs_out1,rhs_out2)
   where
	(lhs_in,rhs_in)     = inp
	(lhs_out1,rhs_out1) = p1 (lhs_in,lhs_out2)
	(lhs_out2,rhs_out2) = p2 (rhs_out1,rhs_in)

-- | 'readyToAckBridge' converts from a ready interface to an ACK interface
-- by preemptively giving the ready signal, and holding the resulting data
-- from the device on the input side if no ACK is received by the device on
-- the output side.  If data is currently being held, then the ready signal
-- will not be given.  This bridge is fine for deep embedding (can be
-- represented in hardware).
readyToAckBridge :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)
    => Patch    (sig (Enabled a))           (sig (Enabled a))
                (sig Ready)                 (sig Ack)
readyToAckBridge ~(inp, ack_in0) = (toReady ready, out)
    where
        (in_en, in_val) = unpack inp
        ack_in = fromAck ack_in0

        captureData = in_en .&&. bitNot dataHeld .&&. bitNot ack_in

        dataHolder  = delay
                    $ cASE [ (captureData, in_val)
                           ] dataHolder

        dataHeld    = register False
                    $ cASE [ (captureData, high)
                           , (ack_in, low)
                           ] dataHeld

        out         = cASE [ (dataHeld, packEnabled dataHeld dataHolder)
                           ] inp

        ready       = bitNot dataHeld

-- | 'ackToReadyBridge' converts from a Ack interface to an Ready interface
-- by ANDing the ready signal from the receiving component with the input
-- enable from the sending component.  This may not be necessary at times
-- if the sending component ignores ACKs when no data is sent. This bridge
-- is fine for deep embedding (can be represented in hardware).
ackToReadyBridge :: (Rep a, Clock c, sig ~ Signal c)
    => Patch    (sig (Enabled a))           (sig (Enabled a))
                (sig Ack)                 (sig Ready)
ackToReadyBridge ~(inp, ready_in) = (toAck ack, out)
    where
        out = inp
        ack = (fromReady ready_in) .&&. (isEnabled inp)

---------------------------------------------------------------------------------
-- Functions that fork streams.
---------------------------------------------------------------------------------

-- | This duplicates the incomming datum.
-- This has the behavior that neither branch sees the value
-- until both can recieve it.

dupP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
         => Patch (sig (Enabled a))     (sig (Enabled a)  :> sig (Enabled a))
	          (sig Ack)             (sig Ack          :> sig Ack)

dupP ~(inp,ack1 :> ack2) = (toAck have_read,out1 :> out2)
  where
	have_read = (state .==. 0) .&&. isEnabled inp
	written1  = (state ./=. 0) .&&. fromAck ack1
	written2  = (state ./=. 0) .&&. fromAck ack2

	state :: sig X4
	state = register 0
	      $ cASE [ (have_read,	                pureS 1)
		     , (written1 .&&. written2,	        pureS 0)
		     , (written1 .&&. state .==. 1,	pureS 3)
		     , (written2 .&&. state .==. 1,	pureS 2)
		     , (written1 .&&. state .==. 2,	pureS 0)
		     , (written2 .&&. state .==. 3,	pureS 0)
		     ] state

	store :: sig a
	store = cASE [ (have_read,enabledVal inp)
		     ]
	      $ delay store

	out1 = packEnabled (state .==. 1 .||. state .==. 2) store
	out2 = packEnabled (state .==. 1 .||. state .==. 3) store

-- | This duplicate the incoming datam over many handshaken streams.
matrixDupP :: (Clock c, sig ~ Signal c, Rep a, Size x)
         => Patch (sig (Enabled a))     (Matrix x (sig (Enabled a)))
	          (sig Ack)             (Matrix x (sig Ack))
matrixDupP = ackToReadyBridge $$ matrixDupP' $$ matrixStackP (pure readyToAckBridge) where
 matrixDupP' ~(inp,readys) = (toReady go, pure out)
    where
	go = foldr1 (.&&.) $ map fromReady $ M.toList readys
	out = packEnabled (go .&&. isEnabled inp) (enabledVal inp)

-- | unzipP creates a patch that takes in an Enabled data pair, and produces a
-- pair of Enabled data outputs.
unzipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)
         => Patch (sig (Enabled (a,b)))     (sig (Enabled a) :> sig (Enabled b))
	          (sig Ack)                 (sig Ack       :> sig Ack)
unzipP = dupP $$
		stackP (forwardP $ mapEnabled (fst . unpack))
		      (forwardP $ mapEnabled (snd . unpack))

-- | matrixUnzipP is the generalization of unzipP to homogeneous matrices.
matrixUnzipP :: (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
         => Patch (sig (Enabled (Matrix x a)))    (Matrix x (sig (Enabled a)))
	          (sig Ack)          		  (Matrix x (sig Ack))
matrixUnzipP =
	matrixDupP $$
	matrixStackP (forAll $ \ x ->  forwardP (mapEnabled $ \ v -> v .!. pureS x))

-- | TODO: Andy write docs for this.
deMuxP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
  => Patch (sig (Enabled Bool)    :> sig (Enabled a)) 		  (sig (Enabled a) :> sig (Enabled a))
	   (sig Ack               :> sig Ack)		          (sig Ack	   :> sig Ack)
deMuxP = fe $$ matrixDeMuxP $$ be
  where
--	fe = fstP (forwardP ((unsigned)))
	fe = fstP (mapP (unsigned))
	be = backwardP (\ ~(b :> c) -> matrix [c,b]) $$
	     forwardP (\ m -> ((m M.! (1 :: X2)) :> (m M.! 0)))

-- | matrixDeMuxP is the generalization of deMuxP to a matrix of signals.
matrixDeMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
  => Patch (sig (Enabled x)    :> sig (Enabled a)) 		  (Matrix x (sig (Enabled a)))
	   (sig Ack            :> sig Ack)		          (Matrix x (sig Ack))
matrixDeMuxP = matrixDeMuxP' $$ matrixStackP (pure readyToAckBridge) where
 matrixDeMuxP' ~(ix :> inp, m_ready) = (toAck ackCond :> toAck ackIn,out)
    where
	-- set when ready to try go
	go = isEnabled ix .&&. isEnabled inp .&&. fromReady (pack m_ready .!. enabledVal ix)

	-- outputs
	ackCond = go
	ackIn   = go
	out     = forAll $ \ x -> packEnabled (go .&&. enabledVal ix .==. pureS x) (enabledVal inp)

---------------------------------------------------------------------------------
-- Functions that combine streams
---------------------------------------------------------------------------------

-- no unDup (requires some function / operation, use zipP).

-- | Combine two enabled data inputs into a single Enabled tupled data input.
zipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)
  => Patch (sig (Enabled a)  :> sig (Enabled b))	(sig (Enabled (a,b)))
	   (sig Ack          :> sig Ack)	  	(sig Ack)
zipP ~(in1 :> in2, outReady) = (toAck ack :> toAck ack, out)
    where
	try = isEnabled in1 .&&. isEnabled in2
	ack = try .&&. fromAck outReady

	out = packEnabled try (pack (enabledVal in1, enabledVal in2))

-- | Extension of zipP to homogeneous matrices.
matrixZipP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
         => Patch (Matrix x (sig (Enabled a)))	(sig (Enabled (Matrix x a)))
	          (Matrix x (sig Ack))		(sig Ack)
matrixZipP ~(mIn, outReady) = (mAcks, out)
   where
	try    = foldr1 (.&&.) (map isEnabled $ M.toList mIn)

	mAcks = fmap toAck $ pure (try .&&. fromAck outReady)
	mIn'  = fmap enabledVal mIn
	out   = packEnabled try (pack mIn' :: sig (Matrix x a))

-- | 'muxP' chooses a the 2nd or 3rd value, based on the Boolean value.
muxP :: (Clock c, sig ~ Signal c, Rep a)
  => Patch (sig (Enabled Bool) :> sig (Enabled a)  :> sig (Enabled a))	(sig (Enabled a))
	   (sig Ack            :> sig Ack          :> sig Ack)	  	(sig Ack)

muxP = fe $$ matrixMuxP
   where
	fe = forwardP (\ ~(a :> b :> c) -> (mapEnabled (unsigned) a :> matrix [c,b])) $$
	     backwardP (\ ~(a :> m) -> (a :> (m M.! (1 :: X2)) :> (m M.! 0)))


-- | 'matrixMuxP' chooses the n-th value, based on the index value.
matrixMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)
  => Patch (sig (Enabled x)    :> Matrix x (sig (Enabled a)))		(sig (Enabled a))
	   (sig Ack            :> Matrix x (sig Ack))		  	(sig Ack)
matrixMuxP  ~(~(cond :> m),ack) = ((toAck ackCond :> fmap toAck m_acks),out)
   where
	-- set when conditional value on cond port
 	try = isEnabled cond

	-- only respond/ack when you are ready to go, the correct lane, and have input
	gos :: Matrix x (sig Bool)
	gos = forEach m $ \ x inp -> try
				.&&. (enabledVal cond .==. pureS x)
				.&&. isEnabled inp

	ackCond = foldr1 (.||.) $ M.toList m_acks
	m_acks = fmap (\ g -> g .&&. fromAck ack) gos

	out = cASE (zip (M.toList gos) (M.toList m))	-- only one can ever be true
		   disabledS

---------------------------------------------------------------------------------
-- Trivial FIFOs
---------------------------------------------------------------------------------

-- (There are larger FIFO's in the Kansas Lava Cores package.)

-- | FIFO with depth 1.
fifo1 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
      => Patch (sig (Enabled a)) 	(sig (Enabled a))
	       (sig Ack)		(sig Ack)
fifo1 ~(inp,ack) = (toAck have_read, out)
   where
	have_read = (state .==. 0) .&&. isEnabled inp
	written   = (state .==. 1) .&&. fromAck ack

	state :: sig X2
	state = register 0
	      $ cASE [ (have_read,	pureS 1)
		     , (written,	pureS 0)
		     ] state


	store :: sig a
	store = delay
	      $ cASE [ (have_read,enabledVal inp)
		     ]
	       store

	out = packEnabled (state .==. 1) store

-- | FIFO with depth 2.
fifo2 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
    => Patch (sig (Enabled a)) 	 (sig (Enabled a))
             (sig Ack)         (sig Ack)
fifo2 = ackToReadyBridge $$ fifo2' where
 fifo2' ~(inp,ack) = (toReady ready, out)
    where
        dataIncoming = isEnabled inp

        dataOutRead = (state ./=. 0) .&&. fromAck ack

        -- State:
        --   0 = First empty, second empty
        --   1 = First full, second empty
        --   2 = First empty, second full
        --   3 = First full, second full, read second store
        --   4 = First full, second full, read first store
        state :: sig X5
        state = register 0
              $ cASE [ ((state.==.0) .&&. dataIncoming,                  1)
                     , ((state.==.1) .&&. dataIncoming .&&. dataOutRead, 2)
                     , ((state.==.1) .&&. dataIncoming,                  4)
                     , ((state.==.1) .&&. dataOutRead,                   0)
                     , ((state.==.2) .&&. dataIncoming .&&. dataOutRead, 1)
                     , ((state.==.2) .&&. dataIncoming,                  3)
                     , ((state.==.2) .&&. dataOutRead,                   0)
                     , ((state.==.3) .&&. dataOutRead,                   1)
                     , ((state.==.4) .&&. dataOutRead,                   2)
                     ] state

        fstStore :: sig a
        fstStore = cASE [ (((state.==.0) .||. (state.==.2)) .&&. dataIncoming, enabledVal inp)
                        ]
                 $ delay fstStore

        sndStore :: sig a
        sndStore = cASE [ ((state.==.1) .&&. dataIncoming, enabledVal inp)
                        ]
                 $ delay sndStore

        ready = (state ./=. 3) .&&. (state ./=. 4)

        outval = cASE [ (((state.==.2) .||. (state.==.3)), sndStore)
                      ] fstStore

        out = packEnabled (state ./=. 0) outval


---------------------------------------------------------------------------------
-- Retiming
---------------------------------------------------------------------------------

-- | 'matrixToElementsP' turns a matrix into a sequences of elements from the array, in ascending order.
matrixToElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
         => Patch (sig (Enabled (Matrix x a)))	(sig (Enabled a))
	          (sig Ack)			(sig Ack)
matrixToElementsP =
	   openP
	$$ stackP
		 (cycleP (coord :: Matrix x x))
		 (matrixUnzipP)
	$$ matrixMuxP

-- | 'matrixFromElementsP' turns a sequence of elements (in ascending order) into a matrix.
-- ascending order.
matrixFromElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
         => Patch (sig (Enabled a)) (sig (Enabled (Matrix x a)))
	          (sig Ack)	    (sig Ack)
matrixFromElementsP =
	   openP
	$$ fstP (cycleP (coord :: Matrix x x))
	$$ matrixDeMuxP
	$$ matrixZipP

---------------------------------------------------------------------------------
-- Other stuff
---------------------------------------------------------------------------------

-- | globalClockP forces the handshaking to use the CLK clock. Which is useful for testing.
globalClockP :: (clk ~ CLK, sig ~ Signal clk) =>
	Patch (sig a)		(sig a)
	      (sig b)           (sig b)
globalClockP ~(li,ri) = (ri,li)

-- | cycleP cycles through a constant list (actually a matrix) of values.
-- Generates an async ROM on hardware.
cycleP :: forall a c ix sig .
        ( Size ix
        , Rep a
        , Rep ix
        , Num ix
        , Clock c
	, sig ~ Signal c
        )
	=> Matrix ix a
	-> Patch ()		(sig (Enabled a))
	         ()		(sig Ack)
cycleP m ~(_,ack) = ((),out)
  where
	ix :: sig ix
	ix = register 0
	   $ cASE [ (fromAck ack, loopingIncS ix) ]
		  ix

	out = packEnabled high
            $ funMap (\ x -> return (m M.! x))
		     ix

constP :: forall a c ix sig .
        ( Size ix
        , Rep a
        , Rep ix
        , Num ix
        , Clock c
	, sig ~ Signal c
        )
	=> Matrix ix a
	-> Patch ()	(sig (Enabled a))
	         ()	(sig Ack)
constP m ~(_,ackOut) = ((),out)
  where
	ix :: sig ix
	ix = register 0
	   $ cASE [ (fromAck ackOut, loopingIncS ix) ]
		  ix

	st :: sig Bool
	st = register False
	   $ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]
		  st

	out :: sig (Enabled a)
	out = mux st
		(packEnabled high $ funMap (\ x -> return (m M.! x)) ix
                , disabledS
		)


-- prependP appends constant list (matrix) before
-- a stream of handshaken values.

prependP :: forall a c ix sig .
        ( Size ix
        , Rep a
        , Rep ix
        , Num ix
        , Clock c
	, sig ~ Signal c
        )
	=> Matrix ix a
	-> Patch (sig (Enabled a))	(sig (Enabled a))
	         (sig Ack)		(sig Ack)
prependP m ~(inp,ackOut) = (ackIn,out)
  where
	ix :: sig ix
	ix = register 0
	   $ cASE [ (fromAck ackOut, loopingIncS ix) ]
		  ix

	st :: sig Bool
	st = register False
	   $ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]
		  st

	ackIn :: sig Ack
	ackIn = mux st
		( toAck low -- do not acccept anything until header has been sent
		, ackOut
		)
	out :: sig (Enabled a)
	out = mux st
		( packEnabled high $ funMap (\ x -> return (m M.! x)) ix
		, inp
		)

---------------------------------------------------
-- These are patch order swappers : re-wiring only
{- To be finished

exp2Stack :: Patch ((a :> b) :> c)	(a :> b :> c)
	           ((d :> e) :> f)	(d :> e :> f)
exp2Stack = forwardP (\ ((a :> b) :>  c) -> (a :> b :> c)) $$
	    backwardP (\ (a :> b :> c) -> ((a :> b) :> c))

con2Stack :: Patch (a :> b :> c)	((a :> b) :> c)
	           (d :> e :> f)	((d :> e) :> f)
con2Stack = forwardP (\ (a :> b :> c) -> ((a :> b) :> c)) $$
	    backwardP (\ ((a :> b) :>  c) -> (a :> b :> c))

swapPatch :: Patch (a :> b)	(b :> a)
	           (c :> d)	(d :> c)
swapPatch = forwardP (\ (a :> b) -> (b :> a)) $$
	    backwardP (\ (b :> a) -> (a :> b))
-}
----------------------------------------------------


data MergePlan = PriorityMerge		-- ^ The first element always has priority
	       | RoundRobinMerge	-- ^ Turn about, can be slower

mergeP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)
 => MergePlan
 -> Patch ((sig (Enabled a)) :> (sig (Enabled a)))    (sig (Enabled a))
	   ((sig Ack)         :> (sig Ack))            (sig Ack)

mergeP plan = fe $$ matrixMergeP plan
  where
	fe = forwardP (\ ~(b :> c) -> (matrix [b,c])) $$
	     backwardP (\ ~m -> ( (m M.! (0 :: X2)) :> (m M.! (1 :: X2))))


matrixMergeP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)
  => MergePlan
  -> Patch (Matrix x (sig (Enabled a)))		(sig (Enabled a))
	   (Matrix x (sig Ack))		  	(sig Ack)
matrixMergeP plan ~(mInp, ackOut) = (mAckInp, out)
 where
   isEs :: sig (Matrix x Bool)
   isEs = pack (fmap isEnabled mInp)

   -- Value to consider selecting.
   inpIndex :: sig x
   inpIndex = case plan of
		PriorityMerge   -> cASE (zip (map isEnabled $ M.toList mInp) (map pureS [0..])) (pureS 0)
		RoundRobinMerge -> let reg = register 0 (mux ((isEs .!. reg) .&&. bitNot (fromAck ackOut))
								-- stop looking if found enable
								-- an no ack
							     (loopingIncS reg,reg)) in reg

   mAckInp = forEach mInp $ \ x _inp -> toAck $ ((pureS x) .==. inpIndex) .&&. (fromAck ackOut)
   out = (pack mInp) .!. inpIndex

---------------------------------------------------------------------------
-- FabricPatch, the IO version of Patch
---------------------------------------------------------------------------

type FabricPatch fab
           lhs_in 	   rhs_out
	   lhs_out         rhs_in
	= (lhs_in,rhs_in) -> fab (lhs_out,rhs_out)

patchF :: (MonadFix fab)
            => Patch a b
                     c d -> FabricPatch fab a b
                                            c d
patchF patch inp = return (patch inp)

infixr 4 |$|
(|$|) :: (MonadFix fab)
      => FabricPatch fab a b
                         d e
      -> FabricPatch fab b c
                         e f
      -> FabricPatch fab a c
                         d f
f1 |$| f2 = \ ~(lhs_in,rhs_in) -> do
	rec ~(lhs_out1,rhs_out1) <- f1 (lhs_in,lhs_out2)
	    ~(lhs_out2,rhs_out2) <- f2 (rhs_out1,rhs_in)
        return (lhs_out1,rhs_out2)

runF :: (MonadFix fab)
 	 => FabricPatch fab  ()   a
	 	             ()   () -> fab a
runF p = do
   ~(_,a) <- p ((),())
   return a

buildF :: (MonadFix fab)
       => ((a,d) -> fab (c,b))
       -> FabricPatch fab a b
                          c d
buildF = id


-- | A fabric patch that passes through data and control.
emptyF :: (MonadFix fab)
       => FabricPatch
                fab a  a
	            b  b
emptyF = patchF emptyP

infixr 3 `stackF`
-- | Given two fabric patches, tuple their data/control inputs and outputs.
stackF :: (MonadFix fab)
       => FabricPatch fab
               li1		ro1
               lo1    		ri1
      -> FabricPatch fab
               li2		ro2
               lo2    		ri2
      -> FabricPatch fab
               (li1 :> li2)			(ro1 :> ro2)
               (lo1 :> lo2)   			(ri1 :> ri2)
stackF p1 p2 ~(li1 :> li2,ri1 :> ri2) = do
	(lo1,ro1)		     <- p1 (li1,ri1)
	(lo2,ro2)		     <- p2 (li2,ri2)
        return $ (lo1 :> lo2,ro1 :> ro2)

{-
f1 |$ f2 = f1 |$| fabricPatch f2
f1 $| f2 = fabricPatch f1 |$| f2
-}