module Lava.Combinators (module Lava.Combinators)
where
import Control.Monad.State
import Lava.Netlist
infixr 5 >->
infixr 5 >|>
infixr 5 >=>
infixr 5 ->-
(->-) :: (a -> Out b) -> (b -> Out c) -> a -> Out c
(->-) circuit1 circuit2 input1
= do input2 <- circuit1 input1
circuit2 input2
(>->) :: (a -> Out b) -> (b -> Out c) -> a -> Out c
(>->) circuit1 circuit2 input1
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
intermediateResult <- circuit1 input1
r <- circuit2 intermediateResult
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
when (l1 l0 >= 2) $
put state{layout = Beside (aW+bW, aH `max` bH) aTile bTile : lrest}
return r
(>=>) :: (a -> Out b) -> (b -> Out c) -> a -> Out c
(>=>) circuit1 circuit2 input1
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
intermediateResult <- circuit1 input1
r <- circuit2 intermediateResult
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
vGap = (aH bH) `div` 2
bTile' = Below (bW, bH+vGap) (Space (0, vGap)) bTile
when (l1 l0 >= 2) $
put state{layout = Beside (aW+bW, aH `max` bH) aTile bTile' : lrest}
return r
(>|>) :: (a -> Out b) -> (b -> Out c) -> a -> Out c
(>|>) circuit1 circuit2 input1
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
intermediateResult <- circuit1 input1
r <- circuit2 intermediateResult
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
when (l1 l0 >= 2) $
put state{layout = Overlay (aW `max` bW, aH `max` bH) aTile bTile : lrest}
return r
condShift :: (Int -> Bool, Int -> Int)
-> (Int -> Bool, Int -> Int)
-> Out ()
condShift xshift yshift
= do netlist <- get
l <- popLayout
pushLayout (ConditionalShift (CondShiftFn xshift yshift) l)
hRepN :: Int -> (a -> Out a) -> a -> Out a
hRepN 1 circuit = circuit
hRepN n circuit
= circuit >-> (hRepN (n1) circuit)
par2 :: (a -> Out c) -> (b -> Out d) -> (a, b) -> Out (c, d)
par2 circuit1 circuit2 (a, b)
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
c <- circuit1 a
d <- circuit2 b
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
when (l1 l0 >= 2) $
put state{layout = Below (aW `max` bW, aH+bH) aTile bTile : lrest}
return (c, d)
maP :: (a -> Out b) -> [a] -> Out [b]
maP circuit [] = return []
maP circuit (x:xs)
= do (y, ys) <- par2 circuit (maP circuit) (x, xs)
return (y:ys)
mapPair :: ((a, a) -> Out a) -> [a] -> Out [a]
mapPair circuit l | odd (length l)
= do r <- (chopPair >-> maP circuit) (init l)
return (r ++ [last l])
mapPair circuit l = (chopPair >-> maP circuit) l
hpar2 :: (a -> Out c) -> (b -> Out d) -> (a, b) -> Out (c, d)
hpar2 circuit1 circuit2 (a, b)
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
c <- circuit1 a
d <- circuit2 b
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
when (l1 l0 >= 2) $
put state{layout = Beside (aW + bW, aH `max` bH) aTile bTile : lrest}
return (c, d)
hmaP :: (a -> Out b) -> [a] -> Out [b]
hmaP circuit [] = return []
hmaP circuit (x:xs)
= do (y, ys) <- hpar2 circuit (hmaP circuit) (x, xs)
return (y:ys)
par2Overlay :: (a -> Out c) -> (b -> Out d) -> (a, b) -> Out (c, d)
par2Overlay circuit1 circuit2 (a, b)
= do preState <- get
let l0 = length (layout preState)
incrementLayoutNesting
c <- circuit1 a
d <- circuit2 b
decrementLayoutNesting
state <- get
let l = layout state
l1 = length l
bTile:aTile:lrest = l
(aW, aH) = sizeOfLayout aTile
(bW, bH) = sizeOfLayout bTile
when (l1 l0 >= 2) $
put state{layout = Overlay (aW `max` bW, aH `max` bH) aTile bTile : lrest}
return (c, d)
par3Overlay :: (a -> Out ao) -> (b -> Out bo) -> (c -> Out co)
-> (a, b, c)
-> Out (ao, bo, co)
par3Overlay circuit1 circuit2 circuit3 (a, b, c)
= do ((ao,bo),co) <- par2Overlay (par2Overlay circuit1 circuit2) circuit3
((a,b), c)
return (ao, bo, co)
hpar :: [a -> Out b] -> [a] -> Out [b]
hpar [] [] = return []
hpar (c:cs) (i:is)
= do (x,y) <- hpar2 c (hpar cs) (i, is)
return (x:y)
hparN :: Int -> (a -> Out b) -> [a] -> Out [b]
hparN n circuit = hpar (replicate n circuit)
fork2 :: a -> Out (a, a)
fork2 a = return (a, a)
listToPair :: [a] -> Out (a, a)
listToPair [a, b] = return (a, b)
listToPair other
= error ("listToPair called with a list of length " ++ show (length other))
pairToList :: (a, a) -> Out [a]
pairToList (a, b) = return [a, b]
ziP :: ([a], [b]) -> Out [(a,b)]
ziP (a,b) = return (zip a b)
unziP :: [(a,b)] -> Out ([a], [b])
unziP list = return (unzip list)
zipList :: [[a]] -> Out [[a]]
zipList [[], _] = return []
zipList [_, []] = return []
zipList [a:as, b:bs]
= do rest <- zipList [as, bs]
return ([a,b] : rest)
unzipList :: [[a]] -> Out [[a]]
unzipList list = return [map fstListPair list, map sndListPair list]
fstListPair :: [a] -> a
fstListPair [a, _] = a
sndListPair :: [a] -> a
sndListPair [_, b] = b
pair :: [a] -> Out [[a]]
pair [] = return []
pair lst | odd (length lst)
= error ("pair given odd length list of size " ++ show (length lst))
pair (a:b:rest)
= do rest <- pair rest
return ([a,b]:rest)
unpair :: [[a]] -> Out [a]
unpair list = return (concat list)
halveListToPair :: [a] -> ([a], [a])
halveListToPair l
= (take n l, drop n l)
where
n = length l `div` 2
halve :: [a] -> Out ([a], [a])
halve l = return (halveListToPair l)
unhalve :: ([a], [a]) -> Out [a]
unhalve (a, b) = return (a ++ b)
halveList :: [a] -> Out [[a]]
halveList l
= return [take n l, drop n l]
where
n = length l `div` 2
unhalveList :: [[a]] -> Out [a]
unhalveList [a, b] = return (a ++ b)
chop :: Int -> [a] -> Out [[a]]
chop n [] = return []
chop n l | length l < n = return [l]
chop n l
= do rest <- chop n (drop n l)
return ((take n l) : rest)
chopPair :: [a] -> Out [(a, a)]
chopPair = chop 2 >-> maP listToPair
concaT :: [[a]] -> Out [a]
concaT list = return (concat list)
fstList :: ([a] -> Out [a]) -> [a] -> Out [a]
fstList f = halve >-> fsT f >-> unhalve
sndList :: ([a] -> Out [a]) -> [a] -> Out [a]
sndList f = halve >-> snD f >-> unhalve
fsT :: (a -> Out b) -> (a, c) -> Out (b, c)
fsT f (a, b)
= do c <- f a
return (c, b)
snD :: (b -> Out c) -> (a, b) -> Out (a, c)
snD f (a, b)
= do c <- f b
return (a, c)
projectFst :: (a, b) -> Out a
projectFst (a, b) = return a
projectSnd :: (a, b) -> Out b
projectSnd (a, b) = return b
reversE :: [a] -> Out [a]
reversE list = return (reverse list)