summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTillmannVogt <>2019-10-11 22:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-10-11 22:03:00 (GMT)
commitcfbd55a8b49a0348cc91140a6786561a8328d796 (patch)
tree1d20869b59a0c08d737391c3d9e597c01acf9a3a
version 1.01.0
-rw-r--r--LICENSE30
-rw-r--r--README.md0
-rw-r--r--Setup.hs2
-rw-r--r--intmap-graph.cabal29
-rw-r--r--src/Graph/IntMap.hs472
5 files changed, 533 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..02e7451
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Tillmann Vogt (c) 2019
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Author name here nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/README.md
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/intmap-graph.cabal b/intmap-graph.cabal
new file mode 100644
index 0000000..4002451
--- /dev/null
+++ b/intmap-graph.cabal
@@ -0,0 +1,29 @@
+name: intmap-graph
+version: 1.0
+Synopsis: A graph library that allows to explore edges after their type
+Description: It is easiest to explain this library with an example: A node has 300 outgoing edges, 100 red, 100 green, 100 blue. If you want to explore all green edges, most of the other graph libraries force you to look up all 300 edges and then filter after the property green. This means 300 O(log n) calls. With this library there is only one (log n) call necessary that gives a list of all green edges.
+homepage: https://github.com/tkvogt/intmap-graph#readme
+license: BSD3
+license-file: LICENSE
+author: Tillmann Vogt
+maintainer: tillk.vogt@gmail.com
+copyright: 2019 Tillmann Vogt
+category: Web
+build-type: Simple
+extra-source-files: README.md
+cabal-version: >=1.10
+
+library
+ hs-source-dirs: src
+ exposed-modules: Graph.IntMap
+ build-depends: base == 4.*
+ , containers
+ , text
+ , vector
+ , word8
+
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://github.com/tkvogt/intmap-graph
diff --git a/src/Graph/IntMap.hs b/src/Graph/IntMap.hs
new file mode 100644
index 0000000..97a50ac
--- /dev/null
+++ b/src/Graph/IntMap.hs
@@ -0,0 +1,472 @@
+{-# LANGUAGE Strict, StrictData, DeriveGeneric, AllowAmbiguousTypes #-}
+{-|
+Module : Graph.IntMap
+Copyright : (C) 2019 Tillmann Vogt
+
+License : BSD-style (see the file LICENSE)
+Maintainer : Tillmann Vogt <tillk.vogt@gmail.com>
+Stability : provisional
+Portability : POSIX
+
+-}
+module Graph.IntMap (
+ EdgeAttribute(..), Graph(..), ExtractNodeType(..),
+ Edge, Edge8(..),
+ -- * Construction
+ empty, fromLists, fromMaps,
+ insertNode, insertNodes,
+ insertEdge, insertEdges,
+ union,
+ -- * Traversal
+ mapNode, mapNodeWithKey,
+ -- * Deletion
+ deleteNode, deleteNodes,
+ deleteEdge, deleteEdges,
+ -- * Query
+ isNull, nodes, edges,
+ lookupNode, lookupEdge,
+ adjacentNodesByAttr, adjacentNodes,
+ parents, children,
+ -- * Bit Operations
+ buildWord64, extractFirstWord32, extractSecondWord32,
+ buildWord32, extractFirstWord24, extractSecondWord8,
+ -- * Displaying in hex for debugging
+ showHex, showHex32
+ ) where
+
+import Data.Bits((.&.), (.|.))
+import Data.Char (intToDigit)
+import qualified Data.IntMap as I
+import Data.IntMap(IntMap)
+import Data.Map(Map)
+import qualified Data.Map as Map
+import Data.Maybe(fromJust, isJust, isNothing, catMaybes, fromMaybe)
+import qualified Data.Set as Set
+import Data.Set(Set(..))
+import qualified Data.Vector.Unboxed as VU
+import Data.Word(Word8, Word32)
+import Foreign.Marshal.Alloc(allocaBytes)
+import Foreign.Ptr(castPtr, plusPtr)
+import Foreign.Storable(peek, pokeByteOff)
+import GHC.Generics
+import System.IO.Unsafe(unsafePerformIO)
+import Debug.Trace
+
+
+newtype Edge8 = Edge8 Word8
+-- ^ In Javascript there are only 32 bit integers.
+-- If we want to squeeze a node and an edge into this we use 24 bits for the node and 8 bits for the edge
+
+instance Show Edge8 where show (Edge8 e) = "Edge " ++ (showHex32 (fromIntegral e))
+
+type Node = Word32
+-- ^ Assuming that 24 bits (~16 million) is enough for Javascript UI graph code
+
+type Edge = (Node,Node)
+-- ^ A tuple of nodes
+
+-- | The edges are enumerated, because sometimes the edge attrs are not continuous
+-- and it is impossible to try all possible 32 bit attrs
+data Graph nl el = Graph {
+ outgoingNodes :: IntMap (Set Node), -- ^ A Graph of outgoing 32 bit nodeEdges with 24 bit nodes and 8 bit edges
+ incomingNodes :: IntMap (Set Node), -- ^ A Graph of incoming 32 bit nodeEdges with 24 bit nodes and 8 bit edges
+ nodeLabels :: IntMap nl, -- only the first 32 bits of the key are used
+ edgeLabels :: Map (Node, Node) el, -- the intmap-key of the edge from n0 to n1 is formed by n0 + n1*2^32
+ is32BitInt :: Bool,
+ showEdge :: Map Word8 el
+} deriving Generic
+
+-- | Convert a complex edge label to an attribute with 8 bits
+-- How to do this depends on which edges have to be filtered fast
+class EdgeAttribute el where
+ fastEdgeAttr :: el -> Word8 -- The key that is used for counting
+ edgeFromAttr :: Map Word8 el --
+ show_e :: Maybe el -> String
+ bases :: el -> [Edge8] -- the list of all attributes, so that we can compute all children and all parents
+ -- Only in the typeclass so that people do not forget to specify it
+ -- main attr of the arbitraryKeygraph
+ -- e.g. unicode leaves 10 bits of the 32 bits unused, that could be used for the
+ -- direction of the edge, if its a right or left edge in a binary tree, etc.
+
+-- | if a node label is complicated, specify a short string to understand its type
+class ExtractNodeType nl where
+ extractNodeType :: nl -> String
+
+instance (EdgeAttribute el, Eq el, Eq nl) => Eq (Graph nl el)
+ where (Graph o0 i0 n0 e0 b0 _) == (Graph o1 i1 n1 e1 b1 _) = b0 == b1 && o0 == o1 && i0 == i1 && n0 == n1 && e0 == e1
+
+
+instance (EdgeAttribute el, Show nl, ExtractNodeType nl, Show el, Enum nl) =>
+ Show (Graph nl el) where
+ show (Graph outgoingNodes incomingNodes nlGraph elGraph b showEdge) =
+ (if b then "32bit graph\n" else "64 bit graph\n") ++
+ "\noutgoing\ndigraph graphviz {\n" ++
+ concat (zipWith3 lines nodeOrigins0 edges0 nodeDests0) ++
+ "}\n" ++
+ "\nincoming\ndigraph graphviz {\n"++
+ concat (zipWith3 lines nodeOrigins1 edges1 nodeDests1) ++
+ "}\n\n nodes\n" ++ show nlGraph ++ "\n\n edges\n" ++ show elGraph
+ where
+ nodeOrigins0 = map (if b then extractFirstWord24 . fromIntegral
+ else extractFirstWord32 . fromIntegral)
+ (I.keys outgoingNodes)
+ edges0 = map (if b then extractSecondWord8 . fromIntegral
+ else fromIntegral . extractSecondWord32 . fromIntegral)
+ (I.keys outgoingNodes)
+ nodeDests0 = map Set.toList (I.elems outgoingNodes)
+
+ nodeOrigins1 = map (if b then extractFirstWord24 . fromIntegral
+ else extractFirstWord32 . fromIntegral)
+ (I.keys incomingNodes)
+ edges1 = map (if b then extractSecondWord8 . fromIntegral
+ else fromIntegral . extractSecondWord32 .fromIntegral)
+ (I.keys incomingNodes)
+ nodeDests1 = map Set.toList (I.elems incomingNodes)
+
+ lines or e dests = concat (map (line . f) dests) where f d = (or,e,d)
+ line (or, e, dest) = extr or ++ show or ++ " -> "++ extr dest ++ show dest ++" [ label = \"" ++
+ show_e (Map.lookup e showEdge) ++ "\" ];\n"
+ extr n = maybe "" extractNodeType (I.lookup (fromIntegral n) nlGraph)
+
+------------------------------------------------------------------------------------------
+
+-- | Generate an empty graph with 32 bit node-edges (24 bit for the node) that can be
+-- used with code that ghcjs compiled to javascript
+empty :: EdgeAttribute el => Graph nl el
+empty = Graph I.empty I.empty I.empty Map.empty True edgeFromAttr
+
+-- | Generate an empty graph with 64 bit node-edges, 32 bit for the node
+empty64 :: EdgeAttribute el => Graph nl el
+empty64 = Graph I.empty I.empty I.empty Map.empty False edgeFromAttr
+
+-- | Construct a graph from a list of nodes, undirected edges and directed edges,
+-- the bool has to be true it uses 32 bit integers, if false it uses 64 bit integers
+fromLists :: (EdgeAttribute el, Enum nl, Show nl, Show el) =>
+ Bool -> [(Node, nl)] -> [((Node, Node), el)] -> [((Node, Node), el)] -> Graph nl el
+fromLists b ns es esDir = -- Debug.Trace.trace ("fromLists"++ show (es,nls,els,elsd,ms)) $
+ ms
+ where ms = fromMaps b nls els elsd True
+ nls = I.fromList (map t ns)
+ els = Map.fromList es
+ elsd = Map.fromList esDir
+ t (k,v) = (fromIntegral k, v)
+
+
+-- | Construct a graph from a node map, undirected edges map and directed edges map, b = True means 32 bit integers
+fromMaps :: (EdgeAttribute el, Show nl, Show el, Enum nl) =>
+ Bool -> IntMap nl -> Map (Node,Node) el -> Map (Node,Node) el -> Bool -> Graph nl el
+fromMaps b nlabels elabels elabelsDir dir = -- Debug.Trace.trace ("fromMaps " ++ show newGraph )$
+ newGraph
+ where newGraph = Graph ograph igraph nlabels unionEdges b edgeFromAttr
+ ograph = insertNodeEdges b (es0 ++ esDir0) I.empty
+ igraph = insertNodeEdges b esDir1 I.empty
+ unionEdges = Map.union (Map.mapKeys ord elabels)
+ (Map.mapKeys ord elabelsDir)
+ es0 = (map triple (Map.toList elabels)) ++ (map rev (Map.toList elabels))
+ esDir0 = map triple (Map.toList elabelsDir)
+ esDir1 = if dir then map rev (Map.toList elabelsDir) else []
+ rev ((n0,n1),v) = ((n1,n0), [v])
+ triple ((n0,n1),v) = ((n0,n1), [v])
+
+ ord (n0,n1) | n0 <= n1 = (n0,n1)
+ | otherwise = (n1,n0)
+
+
+-- | Insert node with node label
+insertNode :: EdgeAttribute el => Node -> nl -> Graph nl el -> Graph nl el
+insertNode n nl graph = -- Debug.Trace.trace "insertNode" $
+ graph { nodeLabels = I.insert (fromIntegral n) nl (nodeLabels graph) }
+
+
+-- | Insert nodes with their label
+insertNodes :: EdgeAttribute el => [(Node, nl)] -> Graph nl el -> Graph nl el
+insertNodes nodes graph = foldr f graph nodes
+ where f (n, nl) g = insertNode n nl g
+
+
+-- | Inserting an edge
+-- If maybeIsBack is Nothing only one directed is edge from n0 to n1 is inserted
+-- If maybeIsBack is Just then a second directed edge from n1 to n0 is inserted
+-- isBack = True means an opposite directed edge that can be explored in both directions
+-- isBack = False means a undirected edge that also can be explored in both directions
+insertEdge :: EdgeAttribute el => Maybe Bool -> Edge -> el -> Graph nl el -> Graph nl el
+insertEdge maybeIsBack (n0, n1) elabel graph =
+ graph { outgoingNodes = newOutGraph,
+ incomingNodes = newInGraph,
+ edgeLabels = if n0 <= n1 then Map.insert (n0,n1) elabel (edgeLabels graph)
+ else Map.insert (n1,n0) elabel (edgeLabels graph) }
+ where newOutGraph | isNothing maybeIsBack = insertNodeEdge b ((n0, n1), [elabel]) (outgoingNodes graph)
+ | not (fromJust maybeIsBack) = insertNodeEdge b ((n0, n1), [elabel])
+ (insertNodeEdge b ((n1, n0), [elabel]) (outgoingNodes graph))
+ | otherwise = insertNodeEdge b ((n0, n1), [elabel]) (outgoingNodes graph)
+ newInGraph | isNothing maybeIsBack = incomingNodes graph
+ | not (fromJust maybeIsBack) = insertNodeEdge b ((n0, n1), [elabel])
+ (insertNodeEdge b ((n1, n0), [elabel]) (incomingNodes graph))
+ | otherwise = insertNodeEdge b ((n1, n0), [elabel]) (incomingNodes graph)
+ b = is32BitInt graph
+
+-- | Inserting an edge
+-- If maybeIsBack is Nothing only one directed is edge from n0 to n1 is inserted
+-- If maybeIsBack is Just then a second directed edge from n1 to n0 is inserted
+-- isBack = True means an opposite directed edge that can be explored in both directions
+-- isBack = False means a undirected edge that also can be explored in both directions
+insertEdges :: EdgeAttribute el => Maybe Bool -> [(Edge, el)] -> Graph nl el -> Graph nl el
+insertEdges maybeIsBack edges graph = foldr f graph edges
+ where f (e, el) g = insertEdge maybeIsBack e el g
+
+
+-- | Inserting node-edges
+insertNodeEdges :: EdgeAttribute el => Bool -> [((Node,Node),[el])] -> IntMap (Set Node) -> IntMap (Set Node)
+insertNodeEdges b es graph = -- Debug.Trace.trace "insertNodeEdges" $
+ foldr (insertNodeEdge b) graph es
+
+
+-- | Inserting a node edge.
+-- Exploring a graph is faster if a node and edge is combined into an 32/64 bit integer that points to a node
+insertNodeEdge :: EdgeAttribute el => Bool -> ((Node,Node),[el]) -> IntMap (Set Node) -> IntMap (Set Node)
+insertNodeEdge b ((n0, n1), edgeLs) g = -- Debug.Trace.trace ("insertNodeEdge (dir, e)"++ show (dir, e)) $
+ insertNodeEdgeAttr b e g
+ where e = ((n0, n1), overlay edgeLs)
+ overlay el = Edge8 (sum (map fastEdgeAttr el)) -- TODO handling several edges
+
+
+-- | An 8 bit value is computed from the edge and combined with the emanating node
+insertNodeEdgeAttr :: Bool -> ((Node,Node),Edge8) -> IntMap (Set Node) -> IntMap (Set Node)
+insertNodeEdgeAttr b ((n0, n1), Edge8 attr) graph =
+ -- Debug.Trace.trace ("insertNodeEdgeAttr(n0,n1,attr,imap)" ++ show (n0,n1,Edge8 attr, imap)) $
+ imap
+ where newValKey | b = fromIntegral (buildWord32 n0 attr)
+ | otherwise = fromIntegral (buildWord64 n0 (fromIntegral attr))
+ imap = I.insertWith Set.union newValKey (Set.singleton n1) graph
+
+
+-- | Makes a union over all components of the graph
+union (Graph og0 ig0 nlg0 elg0 b0 s)
+ (Graph og1 ig1 nlg1 elg1 b1 _)
+ | b0 /= b1 = error "cannot combine 32 bit wiht 62 bit graph"
+ | otherwise = -- Debug.Trace.trace ("\nunion\n" ++ show g) $
+ g
+ where g = Graph (I.union og0 og1) (I.union ig0 ig1) (I.union nlg0 nlg1) (Map.union elg0 elg1) b0 s
+
+----------------------------------------------------------------------------------------
+
+-- | Mapping a function over the node labels
+mapNode :: EdgeAttribute el => (nl0 -> nl1) -> Graph nl0 el -> Graph nl1 el
+mapNode f g = Graph (outgoingNodes g)
+ (incomingNodes g)
+ (I.map f (nodeLabels g))
+ (edgeLabels g) (is32BitInt g) (showEdge g)
+
+
+-- | Mapping a function over the node labels with node key
+mapNodeWithKey :: EdgeAttribute el => (I.Key -> nl0 -> nl1) -> Graph nl0 el -> Graph nl1 el
+mapNodeWithKey f g = Graph (outgoingNodes g)
+ (incomingNodes g)
+ (I.mapWithKey f (nodeLabels g))
+ (edgeLabels g) (is32BitInt g) (showEdge g)
+
+----------------------------------------------------------------------------------------
+
+-- | Delete node with its nodelabel and also all outgoing and incoming edges with their edgeLabels
+deleteNode :: (EdgeAttribute el, Show nl, Show el, Enum nl) => el -> Node -> Graph nl el -> Graph nl el
+deleteNode elabel n graph = graph { outgoingNodes = newOutGraph,
+ incomingNodes = newInGraph,
+ nodeLabels = I.delete (fromIntegral n) (nodeLabels graph),
+ edgeLabels = foldr Map.delete (edgeLabels graph) (map ord edgeLabelsToDelete) }
+ where newOutGraphOrigin = foldr I.delete (outgoingNodes graph) nodeEdges
+ newInGraphOrigin = foldr I.delete (incomingNodes graph) nodeEdges
+ newOutGraph = foldr deleten newOutGraphOrigin (map fromIntegral adjNEs)
+ newInGraph = foldr deleten newInGraphOrigin (map fromIntegral adjNEs)
+ deleten ne g = I.update delEmpty ne (I.adjust (Set.delete n) ne g)
+ adjNEs | b = concat $ map (\a -> map (\b -> buildWord32 a (fromIntegral b)) bs) adj
+ | otherwise = map fromIntegral $
+ concat $ map (\a -> map (\b -> buildWord64 a (fromIntegral b)) bs) adj
+ edgeLabelsToDelete = zip (repeat n) adj
+ adj = adjacentNodes graph n elabel
+ ord (n0,n1) | n0 <= n1 = (n0,n1)
+ | otherwise = (n1,n0)
+ nodeEdges | b = map fromIntegral (map (buildWord32 n) bs)
+ | otherwise = map fromIntegral (map (buildWord64 n) (map fromIntegral bs))
+ bs = map (\(Edge8 e) -> e) (bases elabel)
+ b = is32BitInt graph
+
+
+-- | Delete nodes with their label
+deleteNodes elabel graph nodes = foldr (deleteNode elabel) nodes graph
+
+
+delEmpty x | null x = Nothing
+ | otherwise = Just x
+
+
+-- | "deleteEdge (n0, n1) graph" deletes the edgelabel of (n0,n1) and the nodeEdge that points from n0 to n1
+-- If maybeIsBack is Just then a second directed edge from n1 to n0 is deleted
+-- isBack = True means an opposite directed edge that can be explored in both directions
+-- isBack = False means a undirected edge that also can be explored in both directions
+deleteEdge :: EdgeAttribute el => Maybe Bool -> Edge -> Graph nl el -> Graph nl el
+deleteEdge maybeIsBack (n0, n1) graph
+ | isNothing elabel = graph
+ | otherwise = -- Debug.Trace.trace ("deleteEdge "++ show (n0, n1, maybeIsBack)) $
+ graph { outgoingNodes = newOutGraph,
+ incomingNodes = newInGraph,
+ edgeLabels = Map.delete (if n0 <= n1 then (n0, n1) else (n1, n0)) (edgeLabels graph) }
+ where elabel = Map.lookup (if n0 <= n1 then (n0, n1) else (n1, n0)) (edgeLabels graph)
+
+ newOutGraph = ((I.update delEmpty ne0) . (I.update delEmpty ne1) .
+ (I.adjust (Set.delete n0) ne1) . (I.adjust (Set.delete n1) ne0)) (outgoingNodes graph)
+
+ newInGraph = ((I.update delEmpty ne0) . (I.update delEmpty ne1) .
+ (I.adjust (Set.delete n0) ne1) . (I.adjust (Set.delete n1) ne0)) (incomingNodes graph)
+
+ ne0 | is32BitInt graph = fromIntegral (buildWord32 n0 e8)
+ | otherwise = fromIntegral (buildWord64 n0 (fromIntegral e8))
+ ne1 | is32BitInt graph = fromIntegral (buildWord32 n1 e8)
+ | otherwise = fromIntegral (buildWord64 n1 (fromIntegral e8))
+ e8 = maybe 0 fastEdgeAttr elabel
+
+
+-- | Delete a list of (Node,Node) edges from the graph
+deleteEdges maybeIsBack graph edges = -- Debug.Trace.trace ("deleteEdges "++ show maybeIsBack) $
+ foldr (deleteEdge maybeIsBack) edges graph
+
+----------------------------------------------------------------------------------------
+
+-- | The nodelabel of the given node
+lookupNode :: (Show nl, EdgeAttribute el) => Node -> Graph nl el -> Maybe nl
+lookupNode n g = -- Debug.Trace.trace ("lookupNode(n,lu)" ++ show (n,lu)) $
+ lu
+ where lu = I.lookup (fromIntegral n) (nodeLabels g)
+
+
+-- | The edgelabel of the given edge of type (Node, Node)
+lookupEdge :: (EdgeAttribute el, Show el) => Edge -> Graph nl el -> Maybe el
+lookupEdge (n0, n1) g = -- Debug.Trace.trace ("lookupEdge(n0,n1,lu,edgeLabels g)"++ show (n0, n1, lu,edgeLabels g) ) $
+ lu
+ where lu | n0 <= n1 = Map.lookup (n0,n1) (edgeLabels g)
+ | otherwise = Map.lookup (n1,n0) (edgeLabels g)
+
+-----------------------------------------------------------------------------------------
+-- Query
+
+-- | Are the node-/edge-maps of the graph all empty?
+isNull (Graph ograph igraph nlgr elgr b _) = I.null ograph && I.null igraph && I.null nlgr && Map.null elgr
+
+-- | The word32 keys of the node labels
+nodes (Graph ograph igraph nlgr elgr b _) = I.keys nlgr
+
+-- | List of (Node, Node)
+edges (Graph ograph igraph nlgr elgr b _) = Map.keys elgr
+
+
+-- | The list of adjacent edges can be divided with 8 bit attributes and all edges with a certain attribute selected
+adjacentNodesByAttr :: EdgeAttribute el => Graph nl el -> Bool -> Node -> Edge8 -> VU.Vector Node
+adjacentNodesByAttr graph out node (Edge8 attr) = -- Debug.Trace.trace ("adjNByA(n,str,val)"++ show (node,Edge8 attr,val)) $
+ maybe VU.empty (VU.fromList . Set.toList) val
+ where
+ val = I.lookup key (if out then outgoingNodes graph else incomingNodes graph)
+ key | is32BitInt graph = fromIntegral (buildWord32 node attr)
+ | otherwise = fromIntegral (buildWord64 node (fromIntegral attr))
+
+
+-- | Looking at all incoming and outgoing edges we get all adjacent nodes
+adjacentNodes :: EdgeAttribute el => Graph nl el -> Node -> el -> [Node]
+adjacentNodes graph node someEdge = -- Debug.Trace.trace "adjacentNodes" $
+ VU.toList $
+ VU.concat $ (map (adjacentNodesByAttr graph True node) bs) ++
+ (map (adjacentNodesByAttr graph False node) bs)
+ where bs = bases someEdge
+
+
+-- | Following the outgoing edges
+children :: EdgeAttribute el => Graph nl el -> Node -> el -> VU.Vector Node
+children graph node someEdge = -- Debug.Trace.trace "children" $
+ VU.concat (map (adjacentNodesByAttr graph True node) bs)
+ where bs = bases someEdge
+
+
+-- | Following the incoming edges
+parents :: EdgeAttribute el => Graph nl el -> Node -> el -> VU.Vector Node
+parents graph node someEdge = -- Debug.Trace.trace "parents" $
+ VU.concat (map (adjacentNodesByAttr graph False node) bs)
+ where bs = bases someEdge
+
+-------------------------------------------------------------------------
+-- Bit Operations
+
+-- | Concatenate two Word32 to a Word (64 bit)
+{-# INLINE buildWord64 #-}
+buildWord64 :: Word32 -> Word32 -> Word
+buildWord64 w0 w1
+ = unsafePerformIO . allocaBytes 8 $ \p -> do
+ pokeByteOff p 0 w0
+ pokeByteOff p 4 w1
+ peek (castPtr p)
+
+
+-- | Extract the first 32 bit of a 64 bit word
+{-# INLINE extractFirstWord32 #-}
+extractFirstWord32 :: Word -> Word32
+extractFirstWord32 w
+ = unsafePerformIO . allocaBytes 4 $ \p -> do
+ pokeByteOff p 0 w
+ peek (castPtr p)
+
+
+-- | Extract the second 32 bit of a 64 bit word
+{-# INLINE extractSecondWord32 #-}
+extractSecondWord32 :: Word -> Word32
+extractSecondWord32 w
+ = unsafePerformIO . allocaBytes 4 $ \p -> do
+ pokeByteOff p 0 w
+ peek (castPtr (plusPtr p 4))
+
+--------------------------------------------------
+-- Javascript does not support 64 bit Ints, we have to use 32 bit
+
+-- | Nodes can use 24 bits, edges 8 bits
+buildWord32 :: Word32 -> Word8 -> Word32
+buildWord32 w0 w1
+ = unsafePerformIO . allocaBytes 4 $ \p -> do
+ pokeByteOff p 0 w0
+ pokeByteOff p 3 w1
+ peek (castPtr p)
+
+
+-- | Extract the first 24 bit of a 32 bit word
+{-# INLINE extractFirstWord24 #-}
+extractFirstWord24 :: Word32 -> Word32
+extractFirstWord24 w = w .&. 0xFFFFFF
+
+
+-- | Extract the last 8 bit of a 32 bit word
+{-# INLINE extractSecondWord8 #-}
+extractSecondWord8 :: Word32 -> Word8
+extractSecondWord8 w
+ = unsafePerformIO . allocaBytes 1 $ \p -> do
+ pokeByteOff p 0 w
+ peek (castPtr (plusPtr p 3))
+
+------------------------------------------------------------------
+-- Debugging
+
+-- | Display a 64 bit word so that we can see the bits better
+showHex :: Word -> String
+showHex n = showIt 16 n ""
+ where
+ showIt :: Int -> Word -> String -> String
+ showIt 0 _ r = r
+ showIt i x r = case quotRem x 16 of
+ (y, z) -> let c = intToDigit (fromIntegral z)
+ in c `seq` showIt (i-1) y (c:r)
+
+
+-- | Display a 32 bit word so that we can see the bits better
+showHex32 :: Word32 -> String
+showHex32 n = showIt 8 n ""
+ where
+ showIt :: Int -> Word32 -> String -> String
+ showIt 0 _ r = r
+ showIt i x r = case quotRem x 16 of
+ (y, z) -> let c = intToDigit (fromIntegral z)
+ in c `seq` showIt (i-1) y (c:r)
+