module Math.Topology.CubeCmplx.DPTrace (
ResId, ReqType(..), ResReq,
PID, PTrace, pTrace, pTraces,
ptsAmbReg, ptsForbRegs, ptsCmplx
) where
import Data.Function (on)
import Data.List (sort, groupBy, sortBy, transpose, (\\))
import Data.Ord (comparing)
import Data.Maybe (fromJust, catMaybes)
import Control.Arrow ((***))
import Control.Monad (guard)
import qualified Data.IntMap.Strict as M
(IntMap, empty, null, filter, lookup, insert, adjust)
import Math.Topology.CubeCmplx.DirCubeCmplx
type ResId = Int
data ReqType = P | V deriving (Show, Eq)
type ResReq = (ReqType, ResId)
data ResReqs = ResReqs { reqs :: ![ResReq], parity :: !(M.IntMap Bool) }
instance Eq ResReqs where r1 == r2 = (reqs r1) == (reqs r2)
instance Show ResReqs where show rs = show (reqs rs)
reqEmpty :: ResReqs
reqEmpty = ResReqs [] M.empty
(<+>) :: ResReq -> ResReqs -> Maybe ResReqs
r@(t,i) <+> rs = case M.lookup i pty of
Nothing -> if t == V
then Just $ ResReqs (r : reqs rs)
(M.insert i True pty)
else Nothing
Just False -> if t == V then addElt else Nothing
Just True -> if t == P then addElt else Nothing
where pty = parity rs
addElt = Just $ ResReqs (r : reqs rs) (M.adjust not i pty)
reqList :: [ResReq] -> Maybe ResReqs
reqList rs = do rss <- bld rs
guard (M.null . M.filter (== True) $ parity rss)
return rss
where bld rs = foldr step (Just reqEmpty) rs
step r (Just rs) = r <+> rs
step r _ = Nothing
type PID = Int
data PTrace = PTrace { ptId :: !PID, ptReqs :: !ResReqs } deriving (Show,Eq)
pTrace :: PID -> [ResReq] -> Maybe PTrace
pTrace id rs = do rss <- reqList rs
return $ PTrace id rss
pTraces :: [[ResReq]] -> Maybe [PTrace]
pTraces = sequence . map (uncurry pTrace) . zip [1..]
ptPts :: PTrace -> [ReqPt]
ptPts pt = zipWith3 reqPt (repeat $ ptId pt) rs [1..]
where rs = reqs . ptReqs $ pt
ptPtGrps :: PTrace -> [[ReqPt]]
ptPtGrps pt = groupBy ((==) `on` rpResId) .
sortBy (comparing rpResId) $ ptPts pt
data ReqPt = ReqPt { pid :: !PID, res :: !ResReq, t :: !T } deriving (Eq)
instance Show ReqPt where show p = show (pid p, res p, t p)
instance Ord ReqPt where p1 <= p2 = (t p1) <= (t p2)
reqPt :: PID -> ResReq -> T -> ReqPt
reqPt p r t = ReqPt p r t
rpResId :: ReqPt -> ResId
rpResId = snd . res
data ResTrace = ResTrace { rtPid :: PID, rtResId :: ResId, ivls :: [[T]] }
instance Show ResTrace where show rt = show (rtPid rt, rtResId rt, ivls rt)
ptResTraces :: PTrace -> [ResTrace]
ptResTraces pt = zipWith3 ResTrace (repeat (ptId pt)) (map rid idgrps)
(map pairUp idgrps)
where idgrps = ptPtGrps pt
sg g = sortBy (comparing t) g
ts g = map t (sg g)
pairUp g = pairUp' (ts g) where
pairUp' (a:b:rs) = [[a,b]] ++ pairUp' rs
pairUp' [] = []
rid g = rpResId $ head g
ptsResTraces :: [PTrace] -> [ResTrace]
ptsResTraces = concatMap ptResTraces
rtGrpRes :: [ResTrace] -> [[ResTrace]]
rtGrpRes rts = groupBy ((==) `on` rtResId) . sortBy (comparing rtResId) $ rts
type ResComp = [(PID, [[T]])]
resComps :: [PTrace] -> [ResComp]
resComps pts = map ts . filter ((>1).length) $ rts
where rts = rtGrpRes . ptsResTraces $ pts
ts g = zip (map rtPid g) (map ivls g)
rcVertSpans :: Int -> ResComp -> [VertSpan]
rcVertSpans n rc = zipWith vsCoordsUnsafe
(map (map head) $ sequence mins)
(map (map last) $ sequence maxes)
where pids = map fst rc
opids = [1..n] \\ pids
minOs = zip opids (repeat [[0]])
maxOs = zip opids (repeat [[maxBound :: T]])
mins = map snd . sortBy (comparing fst) $ rc ++ minOs
maxes = map snd . sortBy (comparing fst) $ rc ++ maxOs
ptsAmbReg :: [PTrace] -> VertSpan
ptsAmbReg pts = uncurry vsCoordsUnsafe . unzip $ map bds pts
where coords = map t . ptPts
bds = ((+(1)) *** (+1)) .
foldr (\k (m,n) -> (min k m, max k n))
(maxBound :: T, minBound :: T) . coords
ptsForbRegs :: [PTrace] -> [VertSpan]
ptsForbRegs pts = concatMap (rcVertSpans n) . resComps $ pts
where n = vsDim $ ptsAmbReg pts
ptsCmplx :: [PTrace] -> CubeCmplx
ptsCmplx pts = cmplxVertOp cx (vertexUnsafe $ replicate (vsDim reg) 1) vAdd
where reg = ptsAmbReg pts
cx = foldr (flip cmplxDelVsInt) (vsCmplx reg) (ptsForbRegs pts)