{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-} {- FFI wrappers for benchmarking. -} #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) import Foreign hiding (unsafePerformIO) import Foreign.C.Types import Data.Graph.Planar import Data.Graph.Planar.Internal import Data.List(foldl') import qualified Data.Map as M import Data.Maybe(fromJust) import Data.CircularList(focus, fromList) import qualified Data.CircularList as CL import Data.Functor((<$>)) import qualified Data.Foldable as F import Control.Arrow(first,second) import Data.Sequence(Seq, (<|), (|>), (><), viewl, ViewL(..)) import qualified Data.Sequence as Seq import Control.Monad(ap,zipWithM_) import Data.Function(on) import Criterion.Main import Criterion.Config import Control.DeepSeq #include "bench_match_bud.h" -- ----------------------------------------------------------------------------- {- Until a better way can be found to calculate/pass these in, define these values globally. -} d :: Int d = 5 n :: Int n = 17 b :: Int b = 2 * (n-2) `div` (d-2) - 1 maxOutBuds :: Int maxOutBuds = (d-1) * b -- Each black attached to at least one "white" node. maxInBuds :: Int maxInBuds = maxOutBuds - d -- Will have d remaining outgoing buds. maxNodes :: Int maxNodes = b + maxOutBuds + maxInBuds + 1 -- outer maxEdges :: Int maxEdges = (d * (b+1)) {- * 2 `div` 2 -} + 2 * (maxOutBuds + maxInBuds) -- The "+1" is for the outer node; 2* is for half edges. Result will -- be a d-regular graph. -- ----------------------------------------------------------------------------- data CEdge = CE { fromNd :: CNode , toNd :: CNode , prevID :: CEdgeIndex , nextID :: CEdgeIndex , invID :: CEdgeIndex } deriving (Eq, Ord, Show, Read) nullCEdge :: CEdge nullCEdge = CE { fromNd = null_node , toNd = null_node , prevID = null_edge , nextID = null_edge , invID = null_edge } instance Storable CEdge where sizeOf _ = #{size EDGE} alignment _ = #{alignment EDGE} peek ptr = do from <- #{peek EDGE, start} ptr to <- #{peek EDGE, end} ptr prv <- #{peek EDGE, prev} ptr nxt <- #{peek EDGE, next} ptr inv <- #{peek EDGE, invers} ptr return $ CE from to prv nxt inv poke ptr (CE from to prv nxt inv) = do #{poke EDGE, start} ptr from #{poke EDGE, end} ptr to #{poke EDGE, prev} ptr prv #{poke EDGE, next} ptr nxt #{poke EDGE, invers} ptr inv fromEdge :: EdgeInfo a -> CEdge fromEdge ei = CE { fromNd = conNode $ _fromNode ei , toNd = conNode $ _toNode ei , prevID = conEdge $ _prevEdge ei , nextID = conEdge $ _nextEdge ei , invID = conEdge $ inverse ei } toEdge :: CEdge -> EdgeInfo () toEdge se = EInfo { _fromNode = conNode' $ fromNd se , _toNode = conNode' $ toNd se , _prevEdge = conEdge' $ prevID se , _nextEdge = conEdge' $ nextID se , inverse = conEdge' $ invID se , edgeInfo = () } -- ----------------------------------------------------------------------------- type Graph = PlanarGraph () () data CGraph = CG { numNodes :: CInt , nextNode :: CNode , firstEdge :: ForeignPtr CEdgeIndex , numEdges :: CInt , nextEdge :: CEdgeIndex , edges :: ForeignPtr CEdge } deriving (Eq, Show) instance Storable CGraph where sizeOf _ = #{size GRAPH} alignment _ = #{alignment GRAPH} peek ptr = do maxN <- #{peek GRAPH, numNodes} ptr nextN <- #{peek GRAPH, nextNode} ptr pN <- #{peek GRAPH, firstEdge} ptr fpN <- newForeignPtr finalizerFree pN maxE <- #{peek GRAPH, numEdges} ptr nextE <- #{peek GRAPH, nextEdge} ptr pE <- #{peek GRAPH, edges} ptr fpE <- newForeignPtr finalizerFree pE return $ CG maxN nextN fpN maxE nextE fpE poke ptr (CG maxN nextN fpN maxE nextE fpE) = do withForeignPtr fpN $ \ pN -> withForeignPtr fpE $ \ pE -> do #{poke GRAPH, numNodes} ptr maxN #{poke GRAPH, nextNode} ptr nextN #{poke GRAPH, firstEdge} ptr pN #{poke GRAPH, numEdges} ptr maxE #{poke GRAPH, nextEdge} ptr nextE #{poke GRAPH, edges} ptr pE -- The Graph needs to be compact. toCGraph :: Graph -> IO CGraph toCGraph gr = do fpNs <- mallocForeignPtrArray maxNodes withForeignPtr fpNs $ flip pokeArray ns' fpEs <- mallocForeignPtrArray maxEdges withForeignPtr fpEs $ flip pokeArray es' return $ CG (toCI maxNodes) (toCI numNs) fpNs (toCI maxEdges) (toCI numEs) fpEs where numNs = order gr ns = map (maybe ephemeral_edge conEdge . focus . outgoing) . M.elems $ _nodes gr ns' = ns ++ replicate (maxNodes - numNs) null_edge numEs = 2 * size gr -- Need factor of 2 for half-edges. es = map fromEdge . M.elems $ _edges gr es' = es ++ replicate (maxEdges - numEs) nullCEdge -- The CGraph does not need to be compact. fromCGraph :: CGraph -> IO Graph fromCGraph (CG _numN nextN fpNs _numE nextE fpEs) = do ns <- withForeignPtr fpNs $ peekArray (fromCI nextN) es <- withForeignPtr fpEs $ peekArray (fromCI nextE) return $ mkPG ns es where mkPG ns es = PG ns' es' where ns' = M.mapKeysMonotonic Node . M.fromDistinctAscList . map (second toNI) . filter ((null_edge/=) . snd) $ zip [minBound..] ns toNI fe = NInfo { outgoing = oes , nodeInfo = () } where oes | fe == ephemeral_edge = CL.empty | otherwise = fromList . eFrom $ conEdge' fe es' = M.mapKeysMonotonic Edge . M.fromDistinctAscList . map (second toEdge) . filter ((null_node/=) . fromNd . snd) $ zip [minBound..] es nxtEdge e = _nextEdge $ es' M.! e eFrom e = (:) e . takeWhile (/=e) $ iterate nxtEdge (nxtEdge e) -- ----------------------------------------------------------------------------- type Queue = Seq Node data DEQueue = DQ { maxSize :: CInt , startInd :: CInt , endInd :: CInt , queue :: ForeignPtr CNode } deriving (Eq, Show) instance Storable DEQueue where sizeOf _ = #{size DEQUEUE} alignment _ = #{alignment DEQUEUE} peek ptr = do ms <- #{peek DEQUEUE, qLen} ptr si <- #{peek DEQUEUE, startInd} ptr ei <- #{peek DEQUEUE, endInd} ptr pQ <- #{peek DEQUEUE, q} ptr fpQ <- newForeignPtr finalizerFree pQ return $ DQ ms si ei fpQ poke ptr (DQ ms si ei fpq) = withForeignPtr fpq $ \ pq -> do #{poke DEQUEUE, qLen} ptr ms #{poke DEQUEUE, startInd} ptr si #{poke DEQUEUE, endInd} ptr ei #{poke DEQUEUE, q} ptr pq toDEQ :: Int -> Queue -> IO DEQueue toDEQ ms q = do fpq <- mallocForeignPtrArray ms withForeignPtr fpq $ flip pokeArray qL return $ DQ (toCI ms) 0 (toCI $ qLen - 1) fpq where qLen = Seq.length q qL = map conNode (F.toList q) ++ replicate (ms - qLen) null_node fromDEQ :: DEQueue -> IO Queue fromDEQ (DQ ms si _ei fpq) = go <$> withForeignPtr fpq (peekArray (fromCI ms)) where go = Seq.fromList . map conNode' . takeWhile (/=null_node) . uncurry (flip (++)) . splitAt (fromCI si) -- ----------------------------------------------------------------------------- data DangD = DD { rootNode :: Maybe Node , mobile :: Graph , unmatchedIn :: Queue , unmatchedOut :: Queue } deriving (Eq, Show, Read) data CDangD = CD { root :: CNode , graph :: ForeignPtr CGraph , inBuds :: ForeignPtr DEQueue , outBuds :: ForeignPtr DEQueue } deriving (Eq, Show) instance Storable CDangD where sizeOf _ = #{size DANGD} alignment _ = #{alignment DANGD} peek ptr = do rn <- #{peek DANGD, rootNode} ptr pg <- #{peek DANGD, graph} ptr fpg <- newForeignPtr finalizerFree pg pib <- #{peek DANGD, inBuds} ptr fpi <- newForeignPtr finalizerFree pib pob <- #{peek DANGD, outBuds} ptr fpo <- newForeignPtr finalizerFree pob return $ CD rn fpg fpi fpo poke ptr (CD rn fpg fpIB fpOB) = withForeignPtr fpg $ \ pg -> withForeignPtr fpIB $ \ pIB -> withForeignPtr fpOB $ \ pOB -> do #{poke DANGD, rootNode} ptr rn #{poke DANGD, graph} ptr pg #{poke DANGD, inBuds} ptr pIB #{poke DANGD, outBuds} ptr pOB toCDangD :: DangD -> IO CDangD toCDangD (DD rn m ui uo) = do fpg <- mallocForeignPtr cg <- toCGraph m withForeignPtr fpg $ flip poke cg fpi <- mallocForeignPtr iq <- toDEQ maxInBuds ui withForeignPtr fpi $ flip poke iq fpo <- mallocForeignPtr oq <- toDEQ maxOutBuds uo withForeignPtr fpo $ flip poke oq return $ CD (maybe null_node conNode rn) fpg fpi fpo fromCDangD :: CDangD -> IO DangD fromCDangD (CD r fpg fpi fpo) = do cg <- withForeignPtr fpg peek g <- fromCGraph cg cib <- withForeignPtr fpi peek ib <- fromDEQ cib cob <- withForeignPtr fpo peek ob <- fromDEQ cob return $ DD mr g ib ob where mr | r == null_node = Nothing | otherwise = Just $ conNode' r -- ----------------------------------------------------------------------------- mkDangD :: Maybe Node -> Graph -> Queue -> Queue -> DangD mkDangD rn g ibs obs = DD { rootNode = nfunc <$> rn , mobile = g' , unmatchedIn = nfunc <$> ibs , unmatchedOut = nfunc <$> obs } where trv = traverseGraph breadthFirst g Nothing g' = renumberedTraversal trv nfunc = traversalRevNodeFn' trv ddl :: DangD ddl = mkDangD rn gr inBs outBs where rn = Just $ Node 0 gr = deserialise [(0,(),[(97,22,(),96),(0,22,(),1)]),(2,(),[(78,21,(),79),(77,19,(),76),(72,19,(),73),(74,6,(),75),(2,3,(),3)]),(3,(),[(3,2,(),2)]),(6,(),[(75,2,(),74),(49,16,(),48),(44,16,(),45),(46,10,(),47),(8,7,(),9)]),(7,(),[(9,6,(),8)]),(10,(),[(92,22,(),93),(47,6,(),46),(39,16,(),38),(36,16,(),37),(64,19,(),65)]),(16,(),[(67,19,(),66),(37,10,(),36),(38,10,(),39),(45,6,(),44),(48,6,(),49)]),(19,(),[(95,22,(),94),(65,10,(),64),(66,16,(),67),(73,2,(),72),(76,2,(),77)]),(21,(),[(79,2,(),78)]),(22,(),[(96,0,(),97),(80,23,(),81),(93,10,(),92),(94,19,(),95),(1,0,(),0)]),(23,(),[(81,22,(),80)])] inBs = Seq.fromList [Node 21] outBs = Seq.fromList [Node 23,Node 7,Node 3] ddr :: DangD ddr = mkDangD rn gr inBs outBs where rn = Nothing gr = deserialise [(0,(),[(25,6,(),24),(22,6,(),23),(2,2,(),3),(0,1,(),1),(8,5,(),9)]),(1,(),[(1,0,(),0)]),(2,(),[(3,0,(),2)]),(5,(),[(9,0,(),8)]),(6,(),[(26,10,(),27),(12,8,(),13),(10,7,(),11),(23,0,(),22),(24,0,(),25)]),(7,(),[(11,6,(),10)]),(8,(),[(13,6,(),12)]),(10,(),[(27,6,(),26)])] inBs = Seq.fromList [Node 10,Node 5] outBs = Seq.fromList [Node 8,Node 7,Node 2,Node 1] emptyDD :: DangD emptyDD = DD { rootNode = Nothing , mobile = empty , unmatchedIn = Seq.empty , unmatchedOut = Seq.empty } -- ----------------------------------------------------------------------------- foreign import ccall unsafe "printGraph" c_printGraph :: Ptr CGraph -> IO () -- ----------------------------------------------------------------------------- type CNode = CInt type CEdgeIndex = CInt null_node :: CNode null_node = #const NULL_NODE ephemeral_edge :: CEdgeIndex ephemeral_edge = #const EPHEMERAL_EDGE null_edge :: CEdgeIndex null_edge = #const NULL_EDGE conNode :: Node -> CNode conNode = fromIntegral . node conNode' :: CNode -> Node conNode' = Node . fromIntegral conEdge :: Edge -> CEdgeIndex conEdge = fromIntegral . edge conEdge' :: CEdgeIndex -> Edge conEdge' = Edge . fromIntegral toCI :: Int -> CInt toCI = fromIntegral fromCI :: CInt -> Int fromCI = fromIntegral