diff --git a/Math/Topology/CubeCmplx/DPTrace.hs b/Math/Topology/CubeCmplx/DPTrace.hs new file mode 100644 --- /dev/null +++ b/Math/Topology/CubeCmplx/DPTrace.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} + +-- | Module : Math.Topology.CubeCmplx.DPTrace +-- Copyright : 2014 Michael Misamore +-- License : BSD-style +-- Maintainer : m.misamore@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Model directed process traces in a directed cubical framework. +-- +module Math.Topology.CubeCmplx.DPTrace ( + + -- * Resource requests + ResId, ReqType(..), ResReq, + + -- * Process Traces + PID, PTrace, pTrace, pTraces, + + -- * Modeling contention problems + 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 + +-- Resource Requests -- + +-- | Type for resource IDs. +type ResId = Int + +-- | Classical acquire/release notation. +data ReqType = P | V deriving (Show, Eq) + +-- | Resource request consists of acquiring/releasing a given resource. +type ResReq = (ReqType, ResId) + +-- | Valid list of resource requests. +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) + +-- | Construct empty list of resource requests. +reqEmpty :: ResReqs +reqEmpty = ResReqs [] M.empty + +-- | Given a resource request, add to list of resource requests +-- if permissible. +(<+>) :: 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) + +-- | Fold up list of resource requests, validating pair counts. +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 + + +-- Process Traces -- + +-- | Type for process IDs. +type PID = Int + +-- | Process trace is Process ID together with valid list of requests. +data PTrace = PTrace { ptId :: !PID, ptReqs :: !ResReqs } deriving (Show,Eq) + +-- | Attempt to build valid process trace from ID and list of requests. +pTrace :: PID -> [ResReq] -> Maybe PTrace +pTrace id rs = do rss <- reqList rs + return $ PTrace id rss + +-- | Attempt to build list of process traces with default process IDs +-- from list of lists of requests. +pTraces :: [[ResReq]] -> Maybe [PTrace] +pTraces = sequence . map (uncurry pTrace) . zip [1..] + +-- | Given a process trace, output list of associated resource request points +-- ordered by time. +ptPts :: PTrace -> [ReqPt] +ptPts pt = zipWith3 reqPt (repeat $ ptId pt) rs [1..] + where rs = reqs . ptReqs $ pt + +-- | Given a process trace, output list of lists of associated resource +-- request points grouped by resource id. +ptPtGrps :: PTrace -> [[ReqPt]] +ptPtGrps pt = groupBy ((==) `on` rpResId) . + sortBy (comparing rpResId) $ ptPts pt + + +-- Resource request points -- + +-- | Resource request points labeled by requesting process and time. +data ReqPt = ReqPt { pid :: !PID, res :: !ResReq, t :: !T } deriving (Eq) + +-- | Pretty print resource request points. +instance Show ReqPt where show p = show (pid p, res p, t p) + +-- | Ordered by time. +instance Ord ReqPt where p1 <= p2 = (t p1) <= (t p2) + +-- | Construct a resource request point from a triple. +reqPt :: PID -> ResReq -> T -> ReqPt +reqPt p r t = ReqPt p r t + +-- | Fetch resource id for a resource request point. +rpResId :: ReqPt -> ResId +rpResId = snd . res + + +-- Resource Traces -- + +-- | Resource trace: process, resource, and list of consumption intervals. +data ResTrace = ResTrace { rtPid :: PID, rtResId :: ResId, ivls :: [[T]] } +instance Show ResTrace where show rt = show (rtPid rt, rtResId rt, ivls rt) + +-- | Given a process trace, output associated list of resource traces +-- for that process. +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 + +-- | Given a list of process traces, output associated flattened list of +-- all associated resource traces. +ptsResTraces :: [PTrace] -> [ResTrace] +ptsResTraces = concatMap ptResTraces + +-- | Group list of resource traces by resource id. +rtGrpRes :: [ResTrace] -> [[ResTrace]] +rtGrpRes rts = groupBy ((==) `on` rtResId) . sortBy (comparing rtResId) $ rts + + +-- Resource Competitions -- + +-- | Competition for a given resource. +type ResComp = [(PID, [[T]])] + +-- | Given a list of process traces, get associated list of resource +-- competitions. In each, two or more processes compete for the same +-- resource. +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) + +-- | Given a resource competition and an ambient dimension n, determine the +-- maximal vertex spans it could generate in an ambient complex of dim n. +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 + + +-- Modeling Contention Problems -- + +-- | Given a list of process traces, determine a minimal vertex span suitable +-- for modeling a resource contention problem. +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 + +-- | Given a list of process traces, calculate associated list of +-- "forbidden regions" which represent resource contention. These regions +-- may overlap to form more complex regions. +ptsForbRegs :: [PTrace] -> [VertSpan] +ptsForbRegs pts = concatMap (rcVertSpans n) . resComps $ pts + where n = vsDim $ ptsAmbReg pts + +-- | Given a list of process traces, represent the associated resource +-- contention problem by a finite directed cubical complex. The ordering +-- of the coordinates is the same as the ordering of the processes in +-- the list. +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) + diff --git a/Math/Topology/CubeCmplx/DirCubeCmplx.hs b/Math/Topology/CubeCmplx/DirCubeCmplx.hs --- a/Math/Topology/CubeCmplx/DirCubeCmplx.hs +++ b/Math/Topology/CubeCmplx/DirCubeCmplx.hs @@ -24,7 +24,8 @@ -- * Cells CubeCell, minVert, maxVert, cell, cellUnsafe, cellDim, cellVertsUnsafe, - cellVerts, spanTopCells, vertToCell, inSpan, vInSpan, inBdry, spanBdryCells, + cellVerts, spanTopCells, vertToCell, inSpan, isTopCell, vInSpan, inBdry, + spanBdryCells, -- * Substructures nCubes, nCubeVerts, nCubeCells, nCubeProperCells, nCubeBdry, nCubeKSkels, @@ -35,9 +36,10 @@ genToNonGen, nonGenToGen, -- * Directed Cubical Complexes - CubeCmplx, cells, cmplxEmpty, cmplxNull, cmplxSize, cmplxApply, vsCmplx, - cmplxDelCell, cmplxDelCells, cmplxAddCells, cmplxUnions, cmplxFilter, - cmplxHullUnsafe, cmplxFilterSpan, cmplxFilterSpans, cellNhd, + CubeCmplx, cells, cmplxEmpty, cmplxNull, cmplxSize, cmplxApply, cmplxVertOp, + vsCmplx, cmplxDelCell, cmplxDelCells, cmplxDelVsInt, cmplxAddCells, + cmplxUnions, cmplxFilter, cmplxHullUnsafe, cmplxFilterSpan, cmplxFilterSpans, + cellNhd, -- * Example complexes swissFlag, sqPairFwd, sqPairBack, torus3d, genusTwo3d, @@ -50,6 +52,7 @@ import Data.Int (Int8) import Data.Maybe (fromJust) import Data.List (transpose, groupBy, sortBy) +import qualified Data.Foldable as F (all, any) import Data.Ord (comparing) import Data.Function (on) import Control.Monad (liftM, guard) @@ -332,6 +335,10 @@ inSpan :: CubeCell -> VertSpan -> Bool inSpan c vs = (vsFst vs `vLT` minVert c) && (maxVert c `vLT` vsSnd vs) +-- | Test whether a cubical cell would be a top-cell if added to a complex +isTopCell :: CubeCell -> CubeCmplx -> Bool +isTopCell c cx = F.all (==False) . S.map (isPropSubCell c) $ cells cx + -- | Test whether a vertex belongs to a given vertex span. vInSpan :: Vertex -> VertSpan -> Bool vInSpan v vs = (vertToCell v) `inSpan` vs @@ -522,6 +529,15 @@ cmplxApply :: CubeCmplx -> (CubeCell -> S.HashSet CubeCell) -> CubeCmplx cmplxApply cx f = CubeCmplx . S.unions . map f . S.toList $ cells cx +-- | Given a complex and a vertex of the same ambient dimension, translate +-- every cell of the complex by the vertex via the given operation. +-- Typical operation is to add (1,...,1) to force nonzero coordinates +-- without affecting the topology. +cmplxVertOp :: CubeCmplx -> Vertex -> (Vertex -> Vertex -> Vertex) -> CubeCmplx +cmplxVertOp cx v op + = CubeCmplx . S.map (\c -> cellVertsUnsafe (minVert c `op` v) + (maxVert c `op` v)) $ cells cx + -- | Basic means of constructing cubical complexes via vertex spans. vsCmplx :: VertSpan -> CubeCmplx vsCmplx vs = CubeCmplx { cells = S.fromList $ spanTopCells vs } @@ -530,9 +546,22 @@ cmplxDelCell :: CubeCmplx -> CubeCell -> CubeCmplx cmplxDelCell cx c = CubeCmplx { cells = S.delete c (cells cx) } --- | Given a list of cells to delete from a complex, delete them if present. +-- | Given a set of cells to delete from a complex, delete them if present. cmplxDelCells :: CubeCmplx -> S.HashSet CubeCell -> CubeCmplx cmplxDelCells cx cs = CubeCmplx { cells = S.difference (cells cx) cs } + +-- | Given a vertex span and a complex, delete all top-cells belonging to the +-- span and replace them with the boundaries of these top-cells that belong +-- to the span's boundary. This "punches a hole" in the complex. +cmplxDelVsInt :: CubeCmplx -> VertSpan -> CubeCmplx +cmplxDelVsInt cx vs = cmplxAddCells delCmplx newCells + where delCells = cells . cmplxFilter (flip inSpan vs) $ cx + dbCells = S.fromList . concatMap bdry . S.toList $ delCells + vbCells = S.fromList . concat $ spanBdryCells vs + potCells = S.filter (\c -> F.any (==True) . + S.map (isSubCell c) $ vbCells) $ dbCells + delCmplx = cmplxDelCells cx delCells + newCells = S.filter (flip isTopCell delCmplx) potCells -- | Given a set of cells to insert into a complex, insert them all. cmplxAddCells :: CubeCmplx -> S.HashSet CubeCell -> CubeCmplx diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -2,7 +2,9 @@ import Math.Topology.CubeCmplx.DirCubeCmplx import Math.Topology.CubeCmplx.CornerReduce +import Math.Topology.CubeCmplx.DPTrace import qualified Data.HashSet as S (size) +import Data.Maybe (fromJust) import Test.QuickCheck import Test.QuickCheck.Gen (unGen, Gen) import System.Random (mkStdGen) @@ -47,6 +49,9 @@ rList (arbitrary :: Gen CubeCmplx) n fuzz_cmplxReduce n = map (flip cmplxReduce []) $ rList (arbitrary :: Gen CubeCmplx) n +fuzz_cmplxDelVsInt n = map (uncurry cmplxDelVsInt) $ + zip (rList (arbitrary :: Gen CubeCmplx) n) + (rList (arbitrary :: Gen VertSpan) n) -- Example tests -- eg_sqPairBack = (S.size $ cells (uncurry cmplxReduce $ sqPairBack)) == 15 @@ -55,5 +60,8 @@ eg_torus3d = (S.size $ cells (uncurry cmplxReduce $ torus3d)) == 8 eg_genusTwo3d = (S.size $ cells (uncurry cmplxReduce $ genusTwo3d)) == 11 ---main = print $ fuzz_vsFatten 10 +-- Represent the classic swiss flag complex as a process trace problem +eg_swissFlag_pt = (fst $ swissFlag) == + ptsCmplx [fromJust $ pTrace 1 [(P,1),(P,2),(V,2),(V,1)], + fromJust $ pTrace 2 [(P,2),(P,1),(V,1),(V,2)]] diff --git a/directed-cubical.cabal b/directed-cubical.cabal --- a/directed-cubical.cabal +++ b/directed-cubical.cabal @@ -1,5 +1,5 @@ name: directed-cubical -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Finite Directed Cubical Complexes and associated algorithms description: Finite Directed Cubical Complexes and associated algorithms license: BSD3 @@ -27,7 +27,8 @@ library exposed-modules: Math.Topology.CubeCmplx.CornerReduce, - Math.Topology.CubeCmplx.DirCubeCmplx + Math.Topology.CubeCmplx.DirCubeCmplx, + Math.Topology.CubeCmplx.DPTrace -- other-modules: build-depends: base ==4.6.*, vector ==0.10.*,