dawg 0.7.0 → 0.7.1

raw patch · 7 files changed

+444/−268 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/DAWG.hs +41/−34
• Data/DAWG/Internal.hs +86/−71
• Data/DAWG/Node.hs +120/−0
• Data/DAWG/Node/Specialized.hs +90/−0
• Data/DAWG/Static.hs +65/−108
• Data/DAWG/VMap.hs +39/−54
• dawg.cabal +3/−1

@@ -33,105 +33,110 @@ import Data.Binary (Binary, put, get) import qualified Control.Monad.State.Strict as S -import Data.DAWG.Internal (Id, Node, Graph)+import Data.DAWG.Internal (Graph) import qualified Data.DAWG.Internal as I import qualified Data.DAWG.VMap as V +import Data.DAWG.Node.Specialized hiding (Node)+import qualified Data.DAWG.Node.Specialized as N++type Node a = N.Node (Maybe a)+ type GraphM a b = S.State (Graph (Maybe a)) b  mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a) mkState f g = ((), f g)  -- | Leaf node with no children and 'Nothing' value.-insertLeaf :: Ord a => GraphM a Id +insertLeaf :: Ord a => GraphM a ID  insertLeaf = do-    i <- insertNode (I.Value Nothing)-    insertNode (I.Branch i V.empty)+    i <- insertNode (N.Leaf Nothing)+    insertNode (N.Branch i V.empty)  -- | Return node with the given identifier.-nodeBy :: Id -> GraphM a (Node (Maybe a))+nodeBy :: ID -> GraphM a (Node a) nodeBy i = I.nodeBy i <$> S.get  -- Evaluate the 'I.insert' function within the monad.-insertNode :: Ord a => Node (Maybe a) -> GraphM a Id+insertNode :: Ord a => Node a -> GraphM a ID insertNode = S.state . I.insert  -- Evaluate the 'I.delete' function within the monad.-deleteNode :: Ord a => Node (Maybe a) -> GraphM a ()+deleteNode :: Ord a => Node a -> GraphM a () deleteNode = S.state . mkState . I.delete  -- | Invariant: the identifier points to the 'Branch' node.-insertM :: Ord a => [Int] -> a -> Id -> GraphM a Id+insertM :: Ord a => [Int] -> a -> ID -> GraphM a ID insertM (x:xs) y i = do     n <- nodeBy i-    j <- case I.onSym x n of+    j <- case onSym x n of         Just j  -> return j         Nothing -> insertLeaf     k <- insertM xs y j     deleteNode n-    insertNode (I.subst x k n)+    insertNode (subst x k n) insertM [] y i = do     n <- nodeBy i-    w <- nodeBy (I.eps n)+    w <- nodeBy (N.eps n)     deleteNode w     deleteNode n-    j <- insertNode (I.Value $ Just y)-    insertNode (n { I.eps = j })+    j <- insertNode (N.Leaf $ Just y)+    insertNode (n { N.eps = j }) -insertWithM :: Ord a => (a -> a -> a) -> [Int] -> a -> Id -> GraphM a Id+insertWithM :: Ord a => (a -> a -> a) -> [Int] -> a -> ID -> GraphM a ID insertWithM f (x:xs) y i = do     n <- nodeBy i-    j <- case I.onSym x n of+    j <- case onSym x n of         Just j  -> return j         Nothing -> insertLeaf     k <- insertWithM f xs y j     deleteNode n-    insertNode (I.subst x k n)+    insertNode (subst x k n) insertWithM f [] y i = do     n <- nodeBy i-    w <- nodeBy (I.eps n)+    w <- nodeBy (N.eps n)     deleteNode w     deleteNode n-    let y'new = case I.unValue w of+    let y'new = case N.value w of             Just y' -> f y y'             Nothing -> y-    j <- insertNode (I.Value $ Just y'new)-    insertNode (n { I.eps = j })+    j <- insertNode (N.Leaf $ Just y'new)+    insertNode (n { N.eps = j }) -deleteM :: Ord a => [Int] -> Id -> GraphM a Id+deleteM :: Ord a => [Int] -> ID -> GraphM a ID deleteM (x:xs) i = do     n <- nodeBy i-    case I.onSym x n of+    case onSym x n of         Nothing -> return i         Just j  -> do             k <- deleteM xs j             deleteNode n-            insertNode (I.subst x k n)+            insertNode (subst x k n) deleteM [] i = do     n <- nodeBy i-    w <- nodeBy (I.eps n)+    w <- nodeBy (N.eps n)     deleteNode w     deleteNode n     j <- insertLeaf-    insertNode (n { I.eps = j })+    insertNode (n { N.eps = j })     -lookupM :: [Int] -> Id -> GraphM a (Maybe a)+lookupM :: [Int] -> ID -> GraphM a (Maybe a) lookupM [] i = do-    j <- I.eps <$> nodeBy i-    I.unValue <$> nodeBy j+    j <- N.eps <$> nodeBy i+    N.value <$> nodeBy j lookupM (x:xs) i = do     n <- nodeBy i-    case I.onSym x n of+    case onSym x n of         Just j  -> lookupM xs j         Nothing -> return Nothing -assocsAcc :: Graph (Maybe a) -> Id -> [([Int], a)]+assocsAcc :: Graph (Maybe a) -> ID -> [([Int], a)] assocsAcc g i =-    here w ++ concatMap there (I.edges n)+    here w ++ concatMap there (trans n)   where     n = I.nodeBy i g-    w = I.nodeBy (I.eps n) g-    here v = case I.unValue v of+    w = I.nodeBy (N.eps n) g+    here v = case N.value v of         Just x  -> [([], x)]         Nothing -> []     there (sym, j) = map (first (sym:)) (assocsAcc g j)@@ -141,7 +146,7 @@ -- symbol type. data DAWG a b = DAWG     { graph :: !(Graph (Maybe b))-    , root  :: !Id }+    , root  :: !ID }     deriving (Show, Eq, Ord)  instance (Ord b, Binary b) => Binary (DAWG a b) where@@ -166,6 +171,7 @@     let xs = map fromEnum xs'         (i, g) = S.runState (insertM xs y $ root d) (graph d)     in  DAWG g i+{-# INLINE insert #-} {-# SPECIALIZE insert :: Ord b => String -> b -> DAWG Char b -> DAWG Char b #-}  -- | Insert with a function, combining new value and old value.@@ -219,6 +225,7 @@ fromList xs =     let update t (x, v) = insert x v t     in  foldl' update empty xs+{-# INLINE fromList #-} {-# SPECIALIZE fromList :: Ord b => [(String, b)] -> DAWG Char b #-}  -- | Construct DAWG from the list of (word, value) pairs

@@ -1,19 +1,12 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DoAndIfThenElse #-}  -- | Internal representation of the "Data.DAWG" automaton.  Names in this -- module correspond to a graphical representation of automaton: nodes refer -- to states and edges refer to transitions.  module Data.DAWG.Internal-( --- * Node-  Node (..)-, Id-, edges-, onSym-, subst--- * Graph-, Graph (..)+( Graph (..) , empty , size , nodeBy@@ -23,65 +16,18 @@ ) where  import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, Get, put, get)+-- import Data.List (foldl')+import Data.Binary (Binary, put, get) import qualified Data.Map as M+-- import qualified Data.Tree as T import qualified Data.IntSet as IS import qualified Data.IntMap as IM--import qualified Data.DAWG.VMap as V---- | Node identifier.-type Id = Int---- | Two nodes (states) belong to the same equivalence class (and,--- consequently, they must be represented as one node in the graph)--- iff they are equal with respect to their values and outgoing--- edges.------ Since 'Value' nodes are distinguished from 'Branch' nodes, two values--- equal with respect to '==' function are always kept in one 'Value'--- node in the graph.  It doesn't change the fact that to all 'Branch'--- nodes one value is assigned through the epsilon transition.------ Invariant: the 'value' identifier always points to the 'Value' node.--- Edges in the 'edgeMap', on the other hand, point to 'Branch' nodes.-data Node a-    = Branch {-        -- | Epsilon transition.-          eps       :: {-# UNPACK #-} !Id-        -- | Map from alphabet symbols to 'Branch' node identifiers.-        , edgeMap   :: !(V.VMap Id) }-    | Value-        { unValue :: !a }-    deriving (Show, Eq, Ord)--instance Functor Node where-    fmap f (Value x) = Value (f x)-    fmap _ (Branch x y) = Branch x y--instance Binary a => Binary (Node a) where-    put Branch{..} = put (1 :: Int) >> put eps >> put edgeMap-    put Value{..}  = put (2 :: Int) >> put unValue-    get = do-        x <- get :: Get Int-        case x of-            1 -> Branch <$> get <*> get-            _ -> Value <$> get---- | List of non-epsilon edges outgoing from the 'Branch' node.-edges :: Node a -> [(Int, Id)]-edges (Branch _ es)     = V.toList es-edges (Value _)         = error "edges: value node"+-- import qualified Control.Monad.State.Strict as S --- | Identifier of the child determined by the given symbol.-onSym :: Int -> Node a -> Maybe Id-onSym x (Branch _ es) = V.lookup x es-onSym _ (Value _)     = error "onSym: value node"+import Data.DAWG.Node.Specialized hiding (Node)+import qualified Data.DAWG.Node.Specialized as N --- | Substitue the identifier of the child determined by the given symbol.-subst :: Int -> Id -> Node a -> Node a-subst x i (Branch w es) = Branch w (V.insert x i es)-subst _ _ (Value _)     = error "subst: value node"+type Node a = N.Node a  -- | A set of nodes.  To every node a unique identifier is assigned. -- Invariants: @@ -97,7 +43,7 @@ -- the memory footprint? data Graph a = Graph {     -- | Map from nodes to IDs.-      idMap     :: !(M.Map (Node a) Id)+      idMap     :: !(M.Map (Node a) ID)     -- | Set of free IDs.     , freeIDs   :: !IS.IntSet     -- | Map from IDs to nodes. @@ -127,15 +73,15 @@ size = M.size . idMap  -- | Node with the given identifier.-nodeBy :: Id -> Graph a -> Node a+nodeBy :: ID -> Graph a -> Node a nodeBy i g = nodeMap g IM.! i  -- | Retrieve the node identifier.-nodeID :: Ord a => Node a -> Graph a -> Id+nodeID :: Ord a => Node a -> Graph a -> ID nodeID n g = idMap g M.! n  -- | Add new graph node.-newNode :: Ord a => Node a -> Graph a -> (Id, Graph a)+newNode :: Ord a => Node a -> Graph a -> (ID, Graph a) newNode n Graph{..} =     (i, Graph idMap' freeIDs' nodeMap' ingoMap')   where@@ -147,7 +93,7 @@         else IS.deleteFindMin freeIDs  -- | Remove node from the graph.-remNode :: Ord a => Id -> Graph a -> Graph a+remNode :: Ord a => ID -> Graph a -> Graph a remNode i Graph{..} =     Graph idMap' freeIDs' nodeMap' ingoMap'   where@@ -158,12 +104,12 @@     n           = nodeMap IM.! i  -- | Increment the number of ingoing paths.-incIngo :: Id -> Graph a -> Graph a+incIngo :: ID -> Graph a -> Graph a incIngo i g = g { ingoMap = IM.insertWith' (+) i 1 (ingoMap g) }  -- | Decrement the number of ingoing paths and return -- the resulting number.-decIngo :: Id -> Graph a -> (Int, Graph a)+decIngo :: ID -> Graph a -> (Int, Graph a) decIngo i g =     let k = (ingoMap g IM.! i) - 1     in  (k, g { ingoMap = IM.insert i k (ingoMap g) })@@ -173,7 +119,7 @@ -- NOTE: Number of ingoing paths will not be changed for any descendants -- of the node, so the operation alone will not ensure that properties -- of the graph are preserved.-insert :: Ord a => Node a -> Graph a -> (Id, Graph a)+insert :: Ord a => Node a -> Graph a -> (ID, Graph a) insert n g = case M.lookup n (idMap g) of     Just i  -> (i, incIngo i g)     Nothing -> newNode n g@@ -190,3 +136,72 @@   where     i = nodeID n g     (num, g') = decIngo i g++-- -- | Construct a graph from a list of node/ID pairs and a root ID.+-- -- Identifiers must be consistent with edges outgoing from+-- -- individual nodes.+-- fromNodes :: Ord a => [(Node a, ID)] -> ID -> Graph a+-- fromNodes xs rootID = graph+--   where+--     graph = Graph+--         (M.fromList xs)+--         IS.empty+--         (IM.fromList $ map swap xs)+--         ( foldl' updIngo (IM.singleton rootID 1)+--             $ topSort graph rootID )+--     swap (x, y) = (y, x)+--     updIngo m i =+--         let n = nodeBy i graph+--             ingo = m IM.! i+--         in  foldl' (push ingo) m (edges n)+--     push x m j = IM.adjust (+x) j m+-- +-- postorder :: T.Tree a -> [a] -> [a]+-- postorder (T.Node a ts) = postorderF ts . (a :)+-- +-- postorderF :: T.Forest a -> [a] -> [a]+-- postorderF ts = foldr (.) id $ map postorder ts+-- +-- postOrd :: Graph a -> ID -> [ID]+-- postOrd g i = postorder (dfs g i) []+-- +-- -- | Topological sort given a root ID.+-- topSort :: Graph a -> ID -> [ID]+-- topSort g = reverse . postOrd g+-- +-- -- | Depth first search starting with given ID.+-- dfs :: Graph a -> ID -> T.Tree ID+-- dfs g = prune . generate g+-- +-- generate :: Graph a -> ID -> T.Tree ID+-- generate g i = T.Node i+--     ( T.Node (eps n) []+--     : map (generate g) (edges n) )+--   where+--     n = nodeBy i g+-- +-- type SetM a = S.State IS.IntSet a+-- +-- run :: SetM a -> a+-- run act = S.evalState act IS.empty+-- +-- contains :: ID -> SetM Bool+-- contains i = IS.member i <$> S.get+-- +-- include :: ID -> SetM ()+-- include i = S.modify (IS.insert i)+-- +-- prune :: T.Tree ID -> T.Tree ID+-- prune t = head $ run (chop [t])+-- +-- chop :: T.Forest ID -> SetM (T.Forest ID)+-- chop [] = return []+-- chop (T.Node v ts : us) = do+--     visited <- contains v+--     if visited then+--         chop us+--     else do+--         include v+--         as <- chop ts+--         bs <- chop us+--         return (T.Node v as : bs)

@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards #-}++-- | Internal representation of automata nodes.++module Data.DAWG.Node+(+-- * Basic types+  ID+, Sym+-- * Node+, Node (..)+, onSym+, trans+, edges+, subst+, toGeneric+-- * Edge+, Edge+, to+, label+, annotate+, labeled+) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow (second)+import Data.Binary (Binary, Get, put, get)+import Data.Vector.Unboxed (Unbox)++import qualified Data.DAWG.VMap as M+import qualified Data.DAWG.Node.Specialized as N++-- | Node identifier.+type ID = Int++-- | Internal representation of the transition symbol.+type Sym = Int++-- | Edge with label.+type Edge a = (ID, a)++-- | Destination ID.+to :: Edge a -> ID+to = fst+{-# INLINE to #-}++-- | Edge label.+label :: Edge a -> a+label = snd+{-# INLINE label #-}++-- | Annotate edge wit a new label.+annotate :: a -> Edge b -> Edge a+annotate x (i, _) = (i, x)+{-# INLINE annotate #-}++-- | Construct edge annotated with a given label.+labeled :: a -> ID -> Edge a+labeled x i = (i, x)+{-# INLINE labeled #-}++-- | Two nodes (states) belong to the same equivalence class (and,+-- consequently, they must be represented as one node in the graph)+-- iff they are equal with respect to their values and outgoing+-- edges.+--+-- Since 'Leaf' nodes are distinguished from 'Branch' nodes, two values+-- equal with respect to '==' function are always kept in one 'Leaf'+-- node in the graph.  It doesn't change the fact that to all 'Branch'+-- nodes one value is assigned through the epsilon transition.+--+-- Invariant: the 'eps' identifier always points to the 'Leaf' node.+-- Edges in the 'edgeMap', on the other hand, point to 'Branch' nodes.+data Node a b +    = Branch {+        -- | Epsilon transition.+          eps       :: {-# UNPACK #-} !ID+        -- | Labeled edges outgoing from the node.+        , edgeMap   :: !(M.VMap b) }+    | Leaf { value  :: !a }+    deriving (Show, Eq, Ord)++instance (Unbox b, Binary a, Binary b) => Binary (Node a b) where+    put Branch{..} = put (1 :: Int) >> put eps >> put edgeMap+    put Leaf{..}   = put (2 :: Int) >> put value+    get = do+        x <- get :: Get Int+        case x of+            1 -> Branch <$> get <*> get+            _ -> Leaf <$> get++-- | Transition function.+onSym :: Unbox b => Sym -> Node a b -> Maybe b+onSym x (Branch _ es)   = M.lookup x es+onSym _ (Leaf _)        = Nothing+{-# INLINE onSym #-}++-- | List of symbol/edge pairs outgoing from the node.+trans :: Unbox b => Node a b -> [(Sym, b)]+trans (Branch _ es)     = M.toList es+trans (Leaf _)          = []+{-# INLINE trans #-}++-- | List of outgoing edges.+edges :: Unbox b => Node a b -> [b]+edges = map snd . trans+{-# INLINE edges #-}++-- | Substitue edge determined by a given symbol.+subst :: Unbox b => Sym -> b -> Node a b -> Node a b+subst x e (Branch w es) = Branch w (M.insert x e es)+subst _ _ l             = l+{-# INLINE subst #-}++-- | Yield generic version of a specialized node.+toGeneric :: N.Node a -> Node a (Edge ())+toGeneric N.Leaf{..}    = Leaf value+toGeneric N.Branch{..}  = Branch eps (annEdges edgeMap) where+    annEdges = M.fromList . map annEdge . M.toList+    annEdge = second (labeled ())

@@ -0,0 +1,90 @@+{-# LANGUAGE RecordWildCards #-}++-- | Internal representation of automata nodes specialized to+-- a version with unlabeled edges.++module Data.DAWG.Node.Specialized+(+-- * Basic types+  ID+, Sym+-- * Node+, Node (..)+, onSym+, trans+, edges+, subst+, reIdent+) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow (second)+import Data.Binary (Binary, Get, put, get)++import qualified Data.DAWG.VMap as M++-- | Node identifier.+type ID = Int++-- | Internal representation of the transition symbol.+type Sym = Int++-- | Two nodes (states) belong to the same equivalence class (and,+-- consequently, they must be represented as one node in the graph)+-- iff they are equal with respect to their values and outgoing+-- edges.+--+-- Since 'Leaf' nodes are distinguished from 'Branch' nodes, two values+-- equal with respect to '==' function are always kept in one 'Leaf'+-- node in the graph.  It doesn't change the fact that to all 'Branch'+-- nodes one value is assigned through the epsilon transition.+--+-- Invariant: the 'eps' identifier always points to the 'Leaf' node.+-- Edges in the 'edgeMap', on the other hand, point to 'Branch' nodes.+data Node a+    = Branch {+        -- | Epsilon transition.+          eps       :: {-# UNPACK #-} !ID+        -- | Labeled edges outgoing from the node.+        , edgeMap   :: !(M.VMap ID) }+    | Leaf { value  :: !a }+    deriving (Show, Eq, Ord)++instance (Binary a) => Binary (Node a) where+    put Branch{..} = put (1 :: Int) >> put eps >> put edgeMap+    put Leaf{..}   = put (2 :: Int) >> put value+    get = do+        x <- get :: Get Int+        case x of+            1 -> Branch <$> get <*> get+            _ -> Leaf <$> get++-- | Transition function.+onSym :: Sym -> Node a -> Maybe ID+onSym x (Branch _ es)   = M.lookup x es+onSym _ (Leaf _)        = Nothing+{-# INLINE onSym #-}++-- | List of symbol/edge pairs outgoing from the node.+trans :: Node a -> [(Sym, ID)]+trans (Branch _ es)     = M.toList es+trans (Leaf _)          = []+{-# INLINE trans #-}++-- | List of outgoing edges.+edges :: Node a -> [ID]+edges = map snd . trans+{-# INLINE edges #-}++-- | Substitue edge determined by a given symbol.+subst :: Sym -> ID -> Node a -> Node a+subst x e (Branch w es) = Branch w (M.insert x e es)+subst _ _ l             = l+{-# INLINE subst #-}++-- | Assign new identifiers.+reIdent :: (ID -> ID) -> Node a -> Node a+reIdent _ (Leaf x)      = Leaf x+reIdent f (Branch e es) =+    let reEdges = M.fromList . map (second f) . M.toList+    in  Branch (f e) (reEdges es)

@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | The module implements /directed acyclic word graphs/ (DAWGs) internaly -- represented as /minimal acyclic deterministic finite-state automata/.@@ -38,95 +39,51 @@ , assocs , keys , elems+-- , thaw ) where  import Prelude hiding (lookup)-import Control.Applicative ((<$), (<$>), (<*>), (<|>))-import Control.Arrow (first, second)-import Data.Binary (Binary, put, get)+import Control.Applicative ((<$), (<$>), (<|>))+import Control.Arrow (first)+import Data.Binary (Binary) import Data.Vector.Binary () import Data.Vector.Unboxed (Unbox) import qualified Data.IntMap as M import qualified Data.Vector as V +import Data.DAWG.Node hiding (Node)+import qualified Data.DAWG.Node as N+import qualified Data.DAWG.Node.Specialized as NS import qualified Data.DAWG.VMap as VM import qualified Data.DAWG.Internal as I import qualified Data.DAWG as D --- | Node identifier.-type Id = Int---- | Internal representation of the transition symbol.-type Sym = Int---- | Edge with label.-type Edge a = (Id, a)--to :: Edge a -> Id-to = fst-{-# INLINE to #-}--label :: Edge a -> a-label = snd-{-# INLINE label #-}--annotate :: a -> Edge b -> Edge a-annotate x (i, _) = (i, x)-{-# INLINE annotate #-}--labeled :: a -> Id -> Edge a-labeled x i = (i, x)-{-# INLINE labeled #-}---- | State (node) of the automaton.-data Node a b = Node {-    -- | Value kept in the node.-      value     :: !a-    -- | Labeled edges outgoing from the node.-    , edgeMap   :: !(VM.VMap (Edge b)) }-    deriving (Show, Eq, Ord)--instance (Unbox b, Binary a, Binary b) => Binary (Node a b) where-    put Node{..} = put value >> put edgeMap-    get = Node <$> get <*> get---- | Transition function.-onSym :: Unbox b => Sym -> Node a b -> Maybe (Edge b)-onSym x (Node _ es) = VM.lookup x es-{-# INLINE onSym #-}---- List of symbol/edge pairs outgoing from the node.-trans :: Unbox b => Node a b -> [(Sym, Edge b)]-trans = VM.toList . edgeMap-{-# INLINE trans #-}---- | List of outgoing edges.-edges :: Unbox b => Node a b -> [Edge b]-edges = map snd . trans-{-# INLINE edges #-}---- | List children identifiers.-children :: Unbox b => Node a b -> [Id]-children = map to . edges-{-# INLINE children #-}+type Node a b = N.Node (Maybe a) (Edge b)  -- | @DAWG a b c@ constitutes an automaton with alphabet symbols of type /a/, -- node values of type /Maybe b/ and additional transition labels of type /c/. -- Root is stored on the first position of the array.-newtype DAWG a b c = DAWG { unDAWG :: V.Vector (Node (Maybe b) c) }+newtype DAWG a b c = DAWG { unDAWG :: V.Vector (Node b c) }+    deriving (Show, Eq, Ord, Binary)  -- | Empty DAWG. empty :: Unbox c => DAWG a b c-empty = DAWG $ V.singleton (Node Nothing VM.empty)+empty = DAWG $ V.fromList+    [ Branch 1 VM.empty+    , Leaf Nothing ]  -- | Number of states in the automaton. numStates :: DAWG a b c -> Int numStates = V.length . unDAWG  -- | Node with the given identifier.-nodeBy :: Id -> DAWG a b c -> Node (Maybe b) c+nodeBy :: ID -> DAWG a b c -> Node b c nodeBy i d = unDAWG d V.! i +-- | Value in leaf node with a given ID.+leafValue :: Node b c -> DAWG a b c -> Maybe b+leafValue n = value . nodeBy (eps n)+ -- | Find value associated with the key. lookup :: (Unbox c, Enum a) => [a] -> DAWG a b c -> Maybe b lookup xs' =@@ -134,8 +91,8 @@     in  lookup'I xs 0 {-# SPECIALIZE lookup :: Unbox c => String -> DAWG Char b c -> Maybe b #-} -lookup'I :: Unbox c => [Sym] -> Id -> DAWG a b c -> Maybe b-lookup'I []     i d = value (nodeBy i d)+lookup'I :: Unbox c => [Sym] -> ID -> DAWG a b c -> Maybe b+lookup'I []     i d = leafValue (nodeBy i d) d lookup'I (x:xs) i d = case onSym x (nodeBy i d) of     Just e  -> lookup'I xs (to e) d     Nothing -> Nothing@@ -145,12 +102,12 @@ assocs d = map (first (map toEnum)) (assocs'I 0 d) {-# SPECIALIZE assocs :: Unbox c => DAWG Char b c -> [(String, b)] #-} -assocs'I :: Unbox c => Id -> DAWG a b c -> [([Sym], b)]+assocs'I :: Unbox c => ID -> DAWG a b c -> [([Sym], b)] assocs'I i d =     here ++ concatMap there (trans n)   where     n = nodeBy i d-    here = case value n of+    here = case leafValue n d of         Just x  -> [([], x)]         Nothing -> []     there (x, e) = map (first (x:)) (assocs'I (to e) d)@@ -195,55 +152,44 @@ -- | Compute node weights and store corresponding values in transition labels. weigh :: Unbox c => DAWG a b c -> DAWG a b Weight weigh d = (DAWG . V.fromList)-    [ Node (value n) (apply ws (trans n))+    [ branch n (apply ws (trans n))     | i <- [0 .. numStates d - 1]     , let n  = nodeBy i d     , let ws = accum (children n) ]   where+    -- Branch with new edges.+    branch Branch{..} es    = Branch eps es+    branch Leaf{..}   _     = Leaf value     -- In nodeWeight node weights are memoized.     nodeWeight = ((V.!) . V.fromList) (map detWeight [0 .. numStates d - 1])     -- Determine weight of the node.-    detWeight i =-        let n = nodeBy i d-            js = children n-        in  add (value n) (map nodeWeight js)-    add w x = maybe 0 (const 1) w + sum x+    detWeight i = case nodeBy i d of+        Leaf w  -> maybe 0 (const 1) w+        n       -> sum . map nodeWeight $ allChildren n     -- Weight for subsequent edges.     accum = init . scanl (+) 0 . map nodeWeight     -- Apply weight to edges.      apply ws ts = VM.fromList         [ (x, annotate w e)         | (w, (x, e)) <- zip ws ts ]+    -- Plain children and epsilon child. +    allChildren n = eps n : children n+    -- IDs of plain children.+    children = map to . edges  -- | Construct immutable version of the automaton. freeze :: D.DAWG a b -> DAWG a b () freeze d = DAWG . V.fromList $-    map (stop . oldBy) (M.elems (inverse old2new))+    map (N.toGeneric . NS.reIdent newID . oldBy)+        (M.elems (inverse old2new))   where     -- Map from old to new identifiers.-    old2new :: M.IntMap Int     old2new = M.fromList $ (D.root d, 0) : zip (nodeIDs d) [1..]-    -- List of non-frozen branches' IDs without the root ID.-    nodeIDs = filter (/= D.root d) . branchIDs-    -- Make frozen node with new IDs from non-frozen node.-    stop    = Node <$> onEps <*> mkEdges . I.edgeMap-    -- Extract value following the epsilon transition.-    onEps   = I.unValue . oldBy . I.eps-    -- List of edges with new IDs.-    mkEdges = VM.fromList . map (second mkEdge) . VM.toList -    -- Make edge from old ID.-    mkEdge = labeled () . (old2new M.!)+    newID   = (M.!) old2new+    -- List of node IDs without the root ID.+    nodeIDs = filter (/= D.root d) . map fst . M.assocs . I.nodeMap . D.graph     -- Non-frozen node by given identifier.     oldBy i = I.nodeBy i (D.graph d)---- | Branch IDs in the non-frozen DAWG.-branchIDs :: D.DAWG a b -> [I.Id]-branchIDs-    = map fst . filter (isBranch . snd)-    . M.assocs . I.nodeMap . D.graph-  where-    isBranch (I.Branch _ _) = True-    isBranch _              = False          -- | Inverse of the map. inverse :: M.IntMap Int -> M.IntMap Int@@ -251,16 +197,28 @@     let swap (x, y) = (y, x)     in  M.fromList . map swap . M.toList --- -- | Yield a 'D.DAWG' version of the automaton.--- thaw :: DAWG a b -> D.DAWG a b+-- -- | Yield mutable version of the automaton.+-- thaw :: (Unbox c, Ord a) => DAWG a b c -> D.DAWG a b -- thaw d =---     D.DAWG graph 0+--     D.fromNodes nodes 0 --   where---     graph = I.Graph---         (Map.fromList $ zip nodes [0..])---         IS.empty---         (M.fromList   $ zip [0..] nodes)---         (+--     -- List of resulting nodes.+--     nodes = branchNodes ++ leafNodes+--     -- Branching nodes.+--     branchNodes =+--         [ +--     -- Number of states used to shift new value IDs.+--     n = numStates d+--     -- New identifiers for value nodes.+--     valIDs = foldl' updID GM.empty (values d)+--     -- Values in the automaton.+--     values = map value . V.toList . unDAWG+--     -- Update ID map.+--     updID m v = case GM.lookup v m of+--         Just i  -> m+--         Nothing -> +--             let j = GM.size m + n+--             in  j `seq` GM.insert v j  -- | Position in a set of all dictionary entries with respect -- to the lexicographic order.@@ -268,11 +226,11 @@ index xs = index'I (map fromEnum xs) 0 {-# SPECIALIZE index :: String -> DAWG Char b Weight -> Maybe Int #-} -index'I :: [Sym] -> Id -> DAWG a b Weight -> Maybe Int-index'I []     i d = 0 <$ value (nodeBy i d)+index'I :: [Sym] -> ID -> DAWG a b Weight -> Maybe Int+index'I []     i d = 0 <$ leafValue (nodeBy i d) d index'I (x:xs) i d = do     let n = nodeBy i d-        v = maybe 0 (const 1) (value n)+        v = maybe 0 (const 1) (leafValue n d)     e <- onSym x n     w <- index'I xs (to e) d     return (v + w + label e)@@ -289,18 +247,17 @@ byIndex ix d = map toEnum <$> byIndex'I ix 0 d {-# SPECIALIZE byIndex :: Int -> DAWG Char b Weight -> Maybe String #-} -byIndex'I :: Int -> Id -> DAWG a b Weight -> Maybe [Sym]+byIndex'I :: Int -> ID -> DAWG a b Weight -> Maybe [Sym] byIndex'I ix i d     | ix < 0    = Nothing     | otherwise = here <|> there   where     n = nodeBy i d-    v = maybe 0 (const 1) (value n)+    v = maybe 0 (const 1) (leafValue n d)     here-        | ix == 0   = [] <$ value (nodeBy i d)+        | ix == 0   = [] <$ leafValue (nodeBy i d) d         | otherwise = Nothing     there = do-        -- (x, e) <- VM.firstLL label (ix - v) (edgeMap n)         (x, e) <- VM.findLastLE cmp (edgeMap n)         xs <- byIndex'I (ix - v - label e) (to e) d         return (x:xs)

@@ -6,8 +6,8 @@ ( VMap (unVMap) , empty , lookup-, findLastLE , insert+, findLastLE , fromList , toList ) where@@ -39,70 +39,55 @@  -- | Lookup the symbol in the map. lookup :: Unbox a => Int -> VMap a -> Maybe a-lookup x (VMap v)-    | U.null v  = Nothing-    | otherwise = ST.runST $ do-        w <- U.unsafeThaw v-        fmap snd <$> search w x-  where-    search vec e =-        loop 0 (UM.length vec - 1)-      where-        loop !l !u-            | u <= l    = do-                e' <- UM.unsafeRead vec k-                return $ if e == fst e'-                    then (Just e')-                    else Nothing-            | otherwise = do-                e' <- UM.unsafeRead vec k-                case compare (fst e') e of-                    LT -> loop (k+1) u-                    EQ -> return (Just e')-                    GT -> loop l (k-1)-          where-            k = (u + l) `shiftR` 1--- lookup x = fmap snd . U.find ((==x) . fst) . unVMap+lookup x (VMap v) =+    case binarySearch (flip compare x . fst) v of+        Left k  -> snd <$> v U.!? k+        Right _ -> Nothing {-# INLINE lookup #-} --- | Find last map element which is not GT with respect to the--- given ordering function.+-- | Insert the symbol/value pair into the map.+insert :: Unbox a => Int -> a -> VMap a -> VMap a+insert x y (VMap v) = VMap $+    case binarySearch (flip compare x . fst) v of+        Left k  -> U.modify (\w -> UM.write w k (x, y)) v+        Right k ->+            let (v'L, v'R) = U.splitAt k v+            in  U.concat [v'L, U.singleton (x, y), v'R]+{-# INLINE insert #-}++-- | Given a vector sorted with respect to some underlying comparison+-- function, find last element which is not 'GT' with respect to the+-- comparison function. findLastLE :: Unbox a => (a -> Ordering) -> VMap a -> Maybe (Int, a)-findLastLE cmp (VMap v) = ST.runST $ do+findLastLE cmp (VMap v) =+    let k = binarySearch (cmp . snd) v+    in  v U.!? either id (\x -> x-1) k+{-# INLINE findLastLE #-}++-- | Given a vector of length @n@ strictly ascending with respect to a given+-- comparison function, find an index at which the given element could be+-- inserted while preserving sortedness.+-- The 'Left' result indicates, that the 'EQ' element has been found,+-- while the 'Right' result means otherwise.  Value of the 'Right'+-- result is in the [0,n] range.+binarySearch :: Unbox a => (a -> Ordering) -> U.Vector a -> Either Int Int+binarySearch cmp v = ST.runST $ do     w <- U.unsafeThaw v-    k <- search w-    return (v U.!? (k - 1))+    search w   where-    search vec =-        loop 0 (UM.length vec)+    search w =+        loop 0 (UM.length w)       where         loop !l !u-            | u <= l    = return l+            | u <= l    = return (Right l)             | otherwise = do                 let k = (u + l) `shiftR` 1-                x <- UM.unsafeRead vec k-                case cmp (snd x) of+                x <- UM.unsafeRead w k+                case cmp x of                     LT -> loop (k+1) u-                    EQ -> return (k+1)+                    EQ -> return (Left k)                     GT -> loop l     k--- firstLL f x vm = do---     k <-  U.findIndex ((>x) . f . snd) v---       <|> if n > 0 then Just n else Nothing---     return (v U.! (k - 1))---   where---     v = unVMap vm---     n = U.length v-{-# INLINE findLastLE #-}---- | Insert the symbol/value pair into the map.--- TODO: Optimize! Use the invariant, that VMap is--- kept in an ascending vector.-insert :: Unbox a => Int -> a -> VMap a -> VMap a-insert x y-    = VMap . U.fromList . M.toAscList-    . M.insert x y-    . M.fromList . U.toList . unVMap-{-# INLINE insert #-}+{-# INLINE binarySearch #-}  -- | Smart 'VMap' constructor which ensures that the underlying vector is -- strictly ascending with respect to 'fst' values.

@@ -1,5 +1,5 @@ name:               dawg-version:            0.7.0+version:            0.7.1 synopsis:           Directed acyclic word graphs description:     The library implements /directed acyclic word graphs/ (DAWGs) internaly@@ -31,6 +31,8 @@      exposed-modules:         Data.DAWG+      , Data.DAWG.Node+      , Data.DAWG.Node.Specialized       , Data.DAWG.Static       , Data.DAWG.Internal       , Data.DAWG.VMap