FPGAmodel

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}
--
-- Author: Ivan
-- File: LUT.hs
-- Data: 2014-05-02


module LUT where

import CLaSH.Prelude
import Control.Monad.Identity
import qualified Data.Foldable as F
import qualified Data.Traversable as Tr

-- simple mux
mux :: Bit -> a -> a -> a
mux sel d_0 d_1 = if sel == H then d_1 else d_0

-- generic mux: Select -> (An, Bn) -> On
muxV :: (KnownNat n) => Bit -> Vec (n + n) a -> Vec n a
muxV wire sram  = vzipWith (mux wire) sram_0 sram_1
    where
    (sram_0, sram_1) = vsplitI sram

-- generic mux: Select -> (An, Bn) -> On
muxVS :: (KnownNat n) => Signal Bit -> Vec (n + n) (Signal Bit) -> Vec n (Signal Bit)
muxVS wire sram  = vzipWith (muxS wire) sram_0 sram_1
    where
    (sram_0, sram_1) = vsplitI sram

--- lut4 (16SRAM, 4 inputs, 1 output)
lut4 :: Vec (2^4) a -> Vec 4 Bit -> Vec 1 a
lut4 sram args = muxD $ muxC $ muxB $ muxA sram
    where
    (wire_a, wire_b, wire_c, wire_d) =
       (args ! 0, args ! 1, args ! 2, args ! 3)
    muxA = muxV wire_a
    muxB = muxV wire_b
    muxC = muxV wire_c
    muxD = muxV wire_d


lut4S :: Vec (2^4) (Signal Bit) -> Vec 4 (Signal Bit) -> Vec 1 (Signal Bit)
lut4S sram args = muxD $ muxC $ muxB $ muxA sram
    where
    {-(wire_a, wire_b, wire_c, wire_d) = unpack $ pack args :: (Signal Bit, Signal Bit, Signal Bit, Signal Bit)-}
    (wire_a, wire_b, wire_c, wire_d) =
       (args ! 0, args ! 1, args ! 2, args ! 3)
    {-mux' = muxVS-}
    muxA = muxVS wire_a
    muxB = muxVS wire_b
    muxC = muxVS wire_c
    muxD = muxVS wire_d



-- simple dff (data, clk, clr)
dff :: Signal Bit -> Signal Bit
dff = register L

-- simple signal (synchronized) mux
muxS :: Signal Bit -> Signal Bit -> Signal Bit -> Signal Bit
muxS sel d_0 d_1 = mux <$> sel <*> d_0 <*> d_1

-- logicBlock
logicBlock :: Vec 17 (Signal Bit) -> Vec 4 (Signal Bit) -> Signal Bit
logicBlock sram args = 
        let lut_out = vhead $ lut4S lut_sram_cells args
            dff_out = dff lut_out
        in muxS select_sram_cell dff_out lut_out
    where
    select_sram_cell = vhead sram
    lut_sram_cells = vtail sram

-- 17 sram cells
sram17 :: Signal Bit -> Vec 17 (Signal Bit)
sram17 = window

-- prog block
logicBlockProg row col ena = sram17 $ prog_data <$> row <*> col <*> ena
    where
    prog_data r c e = if r == H && c == H && e == H then H else L

-- logicCell (lb with SRAM)
logicCell :: Signal Bit -> Signal Bit -> Signal Bit -> Signal (Unsigned 4) -> Signal Bit
logicCell row col ena args = logicBlock sram args'
    where
    args' = unpack $ toBV <$> args
    sram = logicBlockProg row col ena

-- switchBoxBlock ::

mux9To1 :: Vec 9 Bit -> Vec 4 Bit -> Bit
mux9To1 inputs sel = inputs ! toInteger n
        where n = fromBV sel :: Unsigned 4

mux9To1S :: Applicative f => f (Vec 9 Bit) -> f (Vec 4 Bit) -> f Bit
mux9To1S inputs sel = mux9To1 <$> inputs <*> sel

{-
type SwbMuxRam n a = Vec n a

data SwitchBoxRam n a = SwitchBoxRam {
        swbRamTop :: SwbMuxRam n a,
        swbRamBottom :: SwbMuxRam n a,
        swbRamLeft :: SwbMuxRam n a,
        swbRamRight :: SwbMuxRam n a,
        swbRamLout :: a
    }
-}
{-deriveLift ''SwbMuxRam-}
{-deriveLift ''SwitchBoxRam-}


{-splitSram swb_sram = lRam :> rRam :> tRam :> bRam :> Nil-}
    {-where-}
    {-sp = vsplitI *** vsplitI-}
    {-((lRam, rRam), (tRam, bRam)) = (sp *** sp) $ sp $ vsplitI swb_sram-}
    {-(hRam, vRam) = vsplitI swb_sram-}
    {-(lRam, rRam) = vsplitI hRam-}
    {-(tRam, bRam) = vsplitI vRam-}
    -- (tRam, bRam)) = (\(x,y) -> (vsplitI x , vsplitI y)) (hRam, vRam)

splitSwbSram :: Vec 32 Bit -> Vec 8 (Vec 4 Bit)
splitSwbSram = fromBV

splitSwbSramS :: Functor f => f (Vec 32 Bit) -> f (Vec 8 (Vec 4 Bit))
splitSwbSramS = fmap splitSwbSram

data SwitchBoxSides a = SwitchBoxSides 
    { swbLeft :: a
    , swbRight :: a
    , swbTop :: a
    , swbBottom :: a
    }
    deriving(Functor)


deriveLift ''SwitchBoxSides

instance Pack (SwitchBoxSides a) where
    type SignalP (SwitchBoxSides a) = SwitchBoxSides (Signal a)
    pack (SwitchBoxSides l r t b) = SwitchBoxSides <$> l <*> r <*> t <*> b
    unpack ss = SwitchBoxSides l r t b
        where
        l = fmap swbLeft ss
        r = fmap swbRight ss
        t = fmap swbTop ss
        b = fmap swbBottom ss

{-instance (-}
    {-KnownNat (BitSize a), -}
    {-KnownNat (2 * (BitSize a)), -}
    {-BitVector a-}
    {-) => BitVector (SwitchBoxSides a) where-}
    {-type BitSize (SwitchBoxSides a) = ((BitSize a) + (BitSize a)) + ((BitSize a) + (BitSize a))-}
    {-toBV (SwitchBoxSides l r t b) = ((toBV l) <++> (toBV r)) <++> ((toBV t) <++> (toBV b))-}
    {-fromBV vec = SwitchBoxSides (fromBV l) (fromBV r) (fromBV t) (fromBV b)-}
        {-where-}
        {-((l,r),(t,b)) = (\(x, y) -> ((vsplitI x),(vsplitI y))) $ vsplitI vec-}

{-
instance (
    KnownNat (BitSize a),
    KnownNat (n * (BitSize a)),
    KnownNat (4*n), 
    KnownNat n,
    KnownNat (2*n), 
    (n+n) ~ (2*n), 
    ((n+n) + (n + n)) ~ (n+n+n+n), 
    (n+n+n+n) ~ (4*n), 
    BitVector a,
    (((n * BitSize a)
                       + ((n * BitSize a) + ((n * BitSize a) + (n * BitSize a))))
                      ~ (4 * (n * BitSize a)) ),
    (((((2 * n) + n) + n) * BitSize a)
                      ~ (4 * (n * BitSize a)))
    ) => BitVector (SwitchBoxSides (Vec n a)) where
  type BitSize (SwitchBoxSides (Vec n a)) = 4 * ( n * BitSize a)
  toBV (SwitchBoxSides l r t b) = (toBV l) <++> (toBV r) <++> (toBV t) <++> (toBV b)
  fromBV vec = SwitchBoxSides l r t b
    where
    ((l,r),(t,b)) = (\(x, y) -> ((vsplitI x),(vsplitI y))) $ vsplitI $ fromBV vec
-}

swbMux :: Bit -> Vec 8 Bit -> Vec 8 Bit -> Vec 2 Bit
swbMux lout inputs sram = out0 :> out1 :> Nil
    where
    inputs_vec' = lout :> inputs
    (sram0, sram1) = vsplitI sram
    out0 = mux9To1 inputs_vec' sram0
    out1 = mux9To1 inputs_vec' sram1


swbMuxS = liftA3 swbMux

-- | LogicBlockOutput -> swb inputs (R,L,T,B) -> swb sram (R,L,T,B) -> swb outputs (R,L,T,B)
swbMuxs :: Bit -> Vec 4 (Vec 2 Bit) -> Vec 32 Bit -> Vec 4 (Vec 2 Bit)
swbMuxs lout inputs sram = vmap (swbMux lout inputs') sram' where 
    inputs' = vconcat inputs
    sram' = vunconcatI sram

switchBoxBlock :: Signal (Vec (17+32) Bit) -> Signal (Vec 4 (Vec 2 Bit)) -> Signal (Vec 4 (Vec 2 Bit))
switchBoxBlock sram inputs = outputs
    where
    (sram_lb, sram_swb) = unpack $ vsplitI <$> sram
    lb_out = logicBlock (unpack sram_lb) (unpack lb_args)
    lb_args = liftA2 (<++>) rIn rOut
    
    outputs = liftA3 swbMuxs lb_out inputs sram_swb

    rIn = (! 0) <$> inputs
    rOut = (! 0) <$> outputs

    {-(loutSram, lSram, rSram, tSram, bSram) = splitSram sram_swb-}
    {-(loutSram, swbRamVec) = splitSram sram_swb-}

topEntity = switchBoxBlock
{-topEntity :: Signal Bit -> Signal Bit -> Signal Bit -> Signal (Unsigned 4) -> Signal Bit-}
{-topEntity = logicCell-}