module Control.Concurrent.CHP.Connect.TwoDim
(FourWay(..), wrappedGridFour, wrappedGridFour_,
FourWayDiag(..), EightWay, wrappedGridEight, wrappedGridEight_) where
import Control.Arrow
import Control.Concurrent.CHP
import Control.Concurrent.CHP.Connect
import Control.Monad
import Data.List
import Prelude hiding (abs)
data FourWay above below left right
= FourWay { above :: above, below :: below, left :: left, right :: right }
deriving (Eq)
data FourWayDiag aboveLeft belowRight aboveRight belowLeft
= FourWayDiag { aboveLeft :: aboveLeft, belowRight :: belowRight, aboveRight :: aboveRight, belowLeft :: belowLeft }
deriving (Eq)
type EightWay a b l r al br ar bl = (FourWay a b l r, FourWayDiag al br ar bl)
wrappedGridFour :: (Connectable above below, Connectable left right) =>
[[FourWay above below left right -> CHP a]] -> CHP [[a]]
wrappedGridFour ps
| length (nub $ map length ps) <= 1
= connectColumnsCycle (length (head ps)) $ map connectRowCycle ps
| otherwise
= error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGrid: Non-rectangular input "
++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps)
wrappedGridFour_ :: (Connectable above below, Connectable left right) =>
[[FourWay above below left right -> CHP a]] -> CHP ()
wrappedGridFour_ ps = wrappedGridFour ps >> return ()
wrappedGridEight :: (Connectable above below, Connectable left right,
Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) =>
[[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP [[a]]
wrappedGridEight ps
| length (nub $ map length ps) <= 1
= connectColumnsCycleDiag (length (head ps)) $ map connectRowCycleDiag ps
| otherwise
= error $ "Control.Concurrent.CHP.Connect.TwoDim.wrappedGridDiag: Non-rectangular input "
++ " height: " ++ show (length ps) ++ " widths: " ++ show (map length ps)
wrappedGridEight_ :: (Connectable above below, Connectable left right,
Connectable aboveLeft belowRight, Connectable belowLeft aboveRight) =>
[[EightWay above below left right aboveLeft belowRight aboveRight belowLeft -> CHP a]] -> CHP ()
wrappedGridEight_ ps = wrappedGridEight ps >> return ()
connectRowCycle :: Connectable left right =>
[FourWay above below left right -> CHP a] -> ([(above, below)] -> CHP [a])
connectRowCycle [] _ = return []
connectRowCycle allps abs = connect $
foldr connLR
(liftM (:[]) . last allps . uncurry (uncurry FourWay $ last abs))
(zip (init allps) (init abs))
connLR :: Connectable left right =>
(FourWay above below left right -> CHP a, (above, below))
-> ((left, right) -> CHP [a])
-> ((left, right) -> CHP [a])
connLR (p, (a, b)) q (l, r)
= liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r') <||> q (l', r)
connectColumnsCycle :: Connectable above below => Int -> [[(above, below)] -> CHP [a]] -> CHP [[a]]
connectColumnsCycle _ [] = return []
connectColumnsCycle n ps = connectList n $ foldl1 (connAB n) (map (liftM (:[]) .) ps)
connAB :: Connectable above below => Int -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a]) -> ([(above, below)] -> CHP [a])
connAB n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' -> p (zip (map fst abs) (map snd abs'))
<||> q (zip (map fst abs') (map snd abs))
connectColumnsCycleDiag :: (Connectable a b, Connectable bl ar, Connectable al br) =>
Int -> [[((a, b), FourWayDiag al br ar bl)] -> CHP [z]] -> CHP [[z]]
connectColumnsCycleDiag _ [] = return []
connectColumnsCycleDiag n ps = connectList n $ \abs ->
connectList n $ \leadingDiag -> connectList n $ \otherDiag ->
foldl1 (connABDiag n) (map (liftM (:[]) .) ps)
$ zip abs [FourWayDiag al br ar bl
| (_, ar) <- otherDiag
| (bl, _) <- shiftRight otherDiag
| (al, _) <- leadingDiag
| (_, br) <- shiftLeft leadingDiag]
shiftLeft, shiftRight :: [a] -> [a]
shiftLeft [] = []
shiftLeft xs = tail xs ++ [head xs]
shiftRight [] = []
shiftRight xs = last xs : init xs
connABDiag :: (Connectable above below, Connectable al br, Connectable bl ar) =>
Int -> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])
-> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])
-> ([((above, below), FourWayDiag al br ar bl)] -> CHP [a])
connABDiag n p q abs = liftM (uncurry (++)) $ connectList n $ \abs' ->
connectList n $ \leadingDiag -> connectList n $ \otherDiag ->
p [((a, b), FourWayDiag al br ar bl)
| ((a, _), _) <- abs
| (_, b) <- abs'
| (_, FourWayDiag al _ ar _) <- abs
| (bl, _) <- shiftRight otherDiag
| (_, br) <- shiftLeft leadingDiag
]
<||>
q [((a, b), FourWayDiag al br ar bl)
| ((_, b), _) <- abs
| (a, _) <- abs'
| (al, _) <- leadingDiag
| (_, ar) <- otherDiag
| (_, FourWayDiag _ br _ bl) <- abs
]
connectRowCycleDiag :: Connectable l r =>
[EightWay a b l r al br ar bl -> CHP z]
-> ([((a, b), FourWayDiag al br ar bl)] -> CHP [z])
connectRowCycleDiag [] _ = return []
connectRowCycleDiag allps abs = connect $
foldr connLRDiag
(\lr -> liftM (:[]) $ last allps $ first (($ lr) . uncurry . uncurry FourWay) (last abs))
(zip (init allps) (init abs))
connLRDiag :: Connectable l r =>
(EightWay a b l r al br ar bl -> CHP z, ((a, b), FourWayDiag al br ar bl))
-> ((l, r) -> CHP [z])
-> ((l, r) -> CHP [z])
connLRDiag (p, ((a, b), diag)) q (l, r)
= liftM (uncurry (:)) . connect $ \(l', r') -> p (FourWay a b l r', diag) <||> q (l', r)