dawg 0.7.1 → 0.8
raw patch · 15 files changed
+1032/−748 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Data.DAWG: DAWG :: !(Graph (Maybe b)) -> !ID -> DAWG a b
- Data.DAWG: graph :: DAWG a b -> !(Graph (Maybe b))
- Data.DAWG: instance (Ord b, Binary b) => Binary (DAWG a b)
- Data.DAWG: instance Eq b => Eq (DAWG a b)
- Data.DAWG: instance Ord b => Ord (DAWG a b)
- Data.DAWG: instance Show b => Show (DAWG a b)
- Data.DAWG: root :: DAWG a b -> !ID
- Data.DAWG.Internal: Graph :: !(Map (Node a) ID) -> !IntSet -> !(IntMap (Node a)) -> !(IntMap Int) -> Graph a
- Data.DAWG.Internal: data Graph a
- Data.DAWG.Internal: delete :: Ord a => Node a -> Graph a -> Graph a
- Data.DAWG.Internal: empty :: Graph a
- Data.DAWG.Internal: freeIDs :: Graph a -> !IntSet
- Data.DAWG.Internal: idMap :: Graph a -> !(Map (Node a) ID)
- Data.DAWG.Internal: ingoMap :: Graph a -> !(IntMap Int)
- Data.DAWG.Internal: insert :: Ord a => Node a -> Graph a -> (ID, Graph a)
- Data.DAWG.Internal: instance (Ord a, Binary a) => Binary (Graph a)
- Data.DAWG.Internal: instance Eq a => Eq (Graph a)
- Data.DAWG.Internal: instance Ord a => Ord (Graph a)
- Data.DAWG.Internal: instance Show a => Show (Graph a)
- Data.DAWG.Internal: nodeBy :: ID -> Graph a -> Node a
- Data.DAWG.Internal: nodeID :: Ord a => Node a -> Graph a -> ID
- Data.DAWG.Internal: nodeMap :: Graph a -> !(IntMap (Node a))
- Data.DAWG.Internal: size :: Graph a -> Int
- Data.DAWG.Node: Branch :: {-# UNPACK #-} !ID -> !(VMap b) -> Node a b
- Data.DAWG.Node: Leaf :: !a -> Node a b
- Data.DAWG.Node: annotate :: a -> Edge b -> Edge a
- Data.DAWG.Node: data Node a b
- Data.DAWG.Node: edgeMap :: Node a b -> !(VMap b)
- Data.DAWG.Node: edges :: Unbox b => Node a b -> [b]
- Data.DAWG.Node: eps :: Node a b -> {-# UNPACK #-} !ID
- Data.DAWG.Node: instance (Eq a, Eq b, Unbox b) => Eq (Node a b)
- Data.DAWG.Node: instance (Ord a, Ord b, Unbox b) => Ord (Node a b)
- Data.DAWG.Node: instance (Show a, Show b, Unbox b) => Show (Node a b)
- Data.DAWG.Node: instance (Unbox b, Binary a, Binary b) => Binary (Node a b)
- Data.DAWG.Node: label :: Edge a -> a
- Data.DAWG.Node: labeled :: a -> ID -> Edge a
- Data.DAWG.Node: onSym :: Unbox b => Sym -> Node a b -> Maybe b
- Data.DAWG.Node: subst :: Unbox b => Sym -> b -> Node a b -> Node a b
- Data.DAWG.Node: to :: Edge a -> ID
- Data.DAWG.Node: toGeneric :: Node a -> Node a (Edge ())
- Data.DAWG.Node: trans :: Unbox b => Node a b -> [(Sym, b)]
- Data.DAWG.Node: type Edge a = (ID, a)
- Data.DAWG.Node: type ID = Int
- Data.DAWG.Node: type Sym = Int
- Data.DAWG.Node: value :: Node a b -> !a
- Data.DAWG.Node.Specialized: Branch :: {-# UNPACK #-} !ID -> !(VMap ID) -> Node a
- Data.DAWG.Node.Specialized: Leaf :: !a -> Node a
- Data.DAWG.Node.Specialized: data Node a
- Data.DAWG.Node.Specialized: edgeMap :: Node a -> !(VMap ID)
- Data.DAWG.Node.Specialized: edges :: Node a -> [ID]
- Data.DAWG.Node.Specialized: eps :: Node a -> {-# UNPACK #-} !ID
- Data.DAWG.Node.Specialized: instance Binary a => Binary (Node a)
- Data.DAWG.Node.Specialized: instance Eq a => Eq (Node a)
- Data.DAWG.Node.Specialized: instance Ord a => Ord (Node a)
- Data.DAWG.Node.Specialized: instance Show a => Show (Node a)
- Data.DAWG.Node.Specialized: onSym :: Sym -> Node a -> Maybe ID
- Data.DAWG.Node.Specialized: reIdent :: (ID -> ID) -> Node a -> Node a
- Data.DAWG.Node.Specialized: subst :: Sym -> ID -> Node a -> Node a
- Data.DAWG.Node.Specialized: trans :: Node a -> [(Sym, ID)]
- Data.DAWG.Node.Specialized: type ID = Int
- Data.DAWG.Node.Specialized: type Sym = Int
- Data.DAWG.Node.Specialized: value :: Node a -> !a
- Data.DAWG.Static: DAWG :: Vector (Node b c) -> DAWG a b c
- Data.DAWG.Static: instance (Binary b, Binary c, Unbox c) => Binary (DAWG a b c)
- Data.DAWG.Static: instance (Eq b, Eq c, Unbox c) => Eq (DAWG a b c)
- Data.DAWG.Static: instance (Ord b, Ord c, Unbox c) => Ord (DAWG a b c)
- Data.DAWG.Static: instance (Show b, Show c, Unbox c) => Show (DAWG a b c)
- Data.DAWG.Static: newtype DAWG a b c
- Data.DAWG.Static: unDAWG :: DAWG a b c -> Vector (Node b c)
- Data.DAWG.VMap: data VMap a
- Data.DAWG.VMap: empty :: Unbox a => VMap a
- Data.DAWG.VMap: findLastLE :: Unbox a => (a -> Ordering) -> VMap a -> Maybe (Int, a)
- Data.DAWG.VMap: fromList :: Unbox a => [(Int, a)] -> VMap a
- Data.DAWG.VMap: insert :: Unbox a => Int -> a -> VMap a -> VMap a
- Data.DAWG.VMap: instance (Binary a, Unbox a) => Binary (VMap a)
- Data.DAWG.VMap: instance (Eq a, Unbox a) => Eq (VMap a)
- Data.DAWG.VMap: instance (Ord a, Unbox a) => Ord (VMap a)
- Data.DAWG.VMap: instance (Show a, Unbox a) => Show (VMap a)
- Data.DAWG.VMap: lookup :: Unbox a => Int -> VMap a -> Maybe a
- Data.DAWG.VMap: toList :: Unbox a => VMap a -> [(Int, a)]
+ Data.DAWG: class (Ord (Node t a), Trans t) => MkNode t a
+ Data.DAWG.Static: data DAWG t a b c
+ Data.DAWG.Static: instance (Binary t, Binary b, Binary c, Unbox b) => Binary (DAWG t a b c)
+ Data.DAWG.Static: instance (Eq b, Eq c, Unbox b) => Eq (DAWG Trans a b c)
+ Data.DAWG.Static: instance (Ord b, Ord c, Unbox b) => Ord (DAWG Trans a b c)
+ Data.DAWG.Static: instance (Show t, Show b, Show c, Unbox b) => Show (DAWG t a b c)
+ Data.DAWG.Trans: byIndex :: Trans t => Int -> t -> Maybe (Sym, ID)
+ Data.DAWG.Trans: class Trans t
+ Data.DAWG.Trans: empty :: Trans t => t
+ Data.DAWG.Trans: fromList :: Trans t => [(Sym, ID)] -> t
+ Data.DAWG.Trans: index :: Trans t => Sym -> t -> Maybe Int
+ Data.DAWG.Trans: insert :: Trans t => Sym -> ID -> t -> t
+ Data.DAWG.Trans: lookup :: Trans t => Sym -> t -> Maybe ID
+ Data.DAWG.Trans: toList :: Trans t => t -> [(Sym, ID)]
+ Data.DAWG.Trans.Map: data Trans
+ Data.DAWG.Trans.Map: instance Binary Trans
+ Data.DAWG.Trans.Map: instance Eq Trans
+ Data.DAWG.Trans.Map: instance Ord Trans
+ Data.DAWG.Trans.Map: instance Show Trans
+ Data.DAWG.Trans.Map: instance Trans Trans
+ Data.DAWG.Trans.Vector: data Trans
+ Data.DAWG.Trans.Vector: instance Binary Trans
+ Data.DAWG.Trans.Vector: instance Eq Trans
+ Data.DAWG.Trans.Vector: instance Ord Trans
+ Data.DAWG.Trans.Vector: instance Show Trans
+ Data.DAWG.Trans.Vector: instance Trans Trans
+ Data.DAWG.Types: type ID = Int
+ Data.DAWG.Types: type Sym = Int
- Data.DAWG: assocs :: Enum a => DAWG a b -> [([a], b)]
+ Data.DAWG: assocs :: (Enum a, MkNode t b) => DAWG t a b -> [([a], b)]
- Data.DAWG: data DAWG a b
+ Data.DAWG: data DAWG t a b
- Data.DAWG: delete :: (Enum a, Ord b) => [a] -> DAWG a b -> DAWG a b
+ Data.DAWG: delete :: (Enum a, MkNode t b) => [a] -> DAWG t a b -> DAWG t a b
- Data.DAWG: elems :: DAWG a b -> [b]
+ Data.DAWG: elems :: MkNode t b => DAWG t a b -> [b]
- Data.DAWG: empty :: Ord b => DAWG a b
+ Data.DAWG: empty :: MkNode t b => DAWG t a b
- Data.DAWG: fromLang :: Enum a => [[a]] -> DAWG a ()
+ Data.DAWG: fromLang :: (Enum a, MkNode t ()) => [[a]] -> DAWG t a ()
- Data.DAWG: fromList :: (Enum a, Ord b) => [([a], b)] -> DAWG a b
+ Data.DAWG: fromList :: (Enum a, MkNode t b) => [([a], b)] -> DAWG t a b
- Data.DAWG: fromListWith :: (Enum a, Ord b) => (b -> b -> b) -> [([a], b)] -> DAWG a b
+ Data.DAWG: fromListWith :: (Enum a, MkNode t b) => (b -> b -> b) -> [([a], b)] -> DAWG t a b
- Data.DAWG: insert :: (Enum a, Ord b) => [a] -> b -> DAWG a b -> DAWG a b
+ Data.DAWG: insert :: (Enum a, MkNode t b) => [a] -> b -> DAWG t a b -> DAWG t a b
- Data.DAWG: insertWith :: (Enum a, Ord b) => (b -> b -> b) -> [a] -> b -> DAWG a b -> DAWG a b
+ Data.DAWG: insertWith :: (Enum a, MkNode t b) => (b -> b -> b) -> [a] -> b -> DAWG t a b -> DAWG t a b
- Data.DAWG: keys :: Enum a => DAWG a b -> [[a]]
+ Data.DAWG: keys :: (Enum a, MkNode t b) => DAWG t a b -> [[a]]
- Data.DAWG: lookup :: Enum a => [a] -> DAWG a b -> Maybe b
+ Data.DAWG: lookup :: (Enum a, MkNode t b) => [a] -> DAWG t a b -> Maybe b
- Data.DAWG: numStates :: DAWG a b -> Int
+ Data.DAWG: numStates :: DAWG t a b -> Int
- Data.DAWG.Static: assocs :: (Enum a, Unbox c) => DAWG a b c -> [([a], b)]
+ Data.DAWG.Static: assocs :: (Enum a, Trans t, Unbox b) => DAWG t a b c -> [([a], c)]
- Data.DAWG.Static: byIndex :: Enum a => Int -> DAWG a b Weight -> Maybe [a]
+ Data.DAWG.Static: byIndex :: (Enum a, Trans t) => Int -> DAWG t a Weight c -> Maybe [a]
- Data.DAWG.Static: elems :: Unbox c => DAWG a b c -> [b]
+ Data.DAWG.Static: elems :: (Trans t, Unbox b) => DAWG t a b c -> [c]
- Data.DAWG.Static: empty :: Unbox c => DAWG a b c
+ Data.DAWG.Static: empty :: (Trans t, Unbox b) => DAWG t a b c
- Data.DAWG.Static: freeze :: DAWG a b -> DAWG a b ()
+ Data.DAWG.Static: freeze :: Trans t => DAWG t a b -> DAWG t a () b
- Data.DAWG.Static: fromLang :: Enum a => [[a]] -> DAWG a () ()
+ Data.DAWG.Static: fromLang :: (Enum a, MkNode t ()) => [[a]] -> DAWG t a () ()
- Data.DAWG.Static: fromList :: (Enum a, Ord b) => [([a], b)] -> DAWG a b ()
+ Data.DAWG.Static: fromList :: (Enum a, MkNode t b) => [([a], b)] -> DAWG t a () b
- Data.DAWG.Static: fromListWith :: (Enum a, Ord b) => (b -> b -> b) -> [([a], b)] -> DAWG a b ()
+ Data.DAWG.Static: fromListWith :: (Enum a, MkNode t b) => (b -> b -> b) -> [([a], b)] -> DAWG t a () b
- Data.DAWG.Static: hash :: Enum a => [a] -> DAWG a b Weight -> Maybe Int
+ Data.DAWG.Static: hash :: (Enum a, Trans t) => [a] -> DAWG t a Weight c -> Maybe Int
- Data.DAWG.Static: index :: Enum a => [a] -> DAWG a b Weight -> Maybe Int
+ Data.DAWG.Static: index :: (Enum a, Trans t) => [a] -> DAWG t a Weight c -> Maybe Int
- Data.DAWG.Static: keys :: (Unbox c, Enum a) => DAWG a b c -> [[a]]
+ Data.DAWG.Static: keys :: (Enum a, Trans t, Unbox b) => DAWG t a b c -> [[a]]
- Data.DAWG.Static: lookup :: (Unbox c, Enum a) => [a] -> DAWG a b c -> Maybe b
+ Data.DAWG.Static: lookup :: (Enum a, Trans t, Unbox b) => [a] -> DAWG t a b c -> Maybe c
- Data.DAWG.Static: numStates :: DAWG a b c -> Int
+ Data.DAWG.Static: numStates :: DAWG t a b c -> Int
- Data.DAWG.Static: unHash :: Enum a => Int -> DAWG a b Weight -> Maybe [a]
+ Data.DAWG.Static: unHash :: (Enum a, Trans t) => Int -> DAWG t a Weight c -> Maybe [a]
- Data.DAWG.Static: weigh :: Unbox c => DAWG a b c -> DAWG a b Weight
+ Data.DAWG.Static: weigh :: Trans t => DAWG t a b c -> DAWG t a Weight c
Files
- Data/DAWG.hs +13/−217
- Data/DAWG/Graph.hs +208/−0
- Data/DAWG/HashMap.hs +110/−0
- Data/DAWG/Internal.hs +243/−181
- Data/DAWG/Node.hs +69/−75
- Data/DAWG/Node/Specialized.hs +0/−90
- Data/DAWG/Static.hs +112/−79
- Data/DAWG/Trans.hs +26/−0
- Data/DAWG/Trans/Hashed.hs +63/−0
- Data/DAWG/Trans/Map.hs +45/−0
- Data/DAWG/Trans/Vector.hs +58/−0
- Data/DAWG/Types.hs +12/−0
- Data/DAWG/Util.hs +58/−0
- Data/DAWG/VMap.hs +0/−101
- dawg.cabal +15/−5
Data/DAWG.hs view
@@ -2,11 +2,22 @@ -- represented as /minimal acyclic deterministic finite-state automata/. -- The implementation provides fast insert and delete operations -- which can be used to build the DAWG structure incrementaly.+--+-- Transition backend has to be specified by a type signature. You can import+-- the desired transition type and define your own dictionary construction+-- function.+--+-- > import Data.DAWG+-- > import Data.DAWG.Trans.Map (Trans)+-- >+-- > mkDict :: (Enum a, Ord b) => [([a], b)] -> DAWG Trans a b+-- > mkDict = fromList module Data.DAWG ( -- * DAWG type- DAWG (..)+ DAWG+, MkNode -- * Query , numStates , lookup@@ -27,219 +38,4 @@ ) where import Prelude hiding (lookup)-import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first)-import Data.List (foldl')-import Data.Binary (Binary, put, get)-import qualified Control.Monad.State.Strict as S--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 = do- i <- insertNode (N.Leaf Nothing)- insertNode (N.Branch i V.empty)---- | Return node with the given identifier.-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 a -> GraphM a ID-insertNode = S.state . I.insert---- Evaluate the 'I.delete' function within the monad.-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 (x:xs) y i = do- n <- nodeBy i- j <- case onSym x n of- Just j -> return j- Nothing -> insertLeaf- k <- insertM xs y j- deleteNode n- insertNode (subst x k n)-insertM [] y i = do- n <- nodeBy i- w <- nodeBy (N.eps n)- deleteNode w- deleteNode n- j <- insertNode (N.Leaf $ Just y)- insertNode (n { N.eps = j })--insertWithM :: Ord a => (a -> a -> a) -> [Int] -> a -> ID -> GraphM a ID-insertWithM f (x:xs) y i = do- n <- nodeBy i- j <- case onSym x n of- Just j -> return j- Nothing -> insertLeaf- k <- insertWithM f xs y j- deleteNode n- insertNode (subst x k n)-insertWithM f [] y i = do- n <- nodeBy i- w <- nodeBy (N.eps n)- deleteNode w- deleteNode n- let y'new = case N.value w of- Just y' -> f y y'- Nothing -> y- j <- insertNode (N.Leaf $ Just y'new)- insertNode (n { N.eps = j })--deleteM :: Ord a => [Int] -> ID -> GraphM a ID-deleteM (x:xs) i = do- n <- nodeBy i- case onSym x n of- Nothing -> return i- Just j -> do- k <- deleteM xs j- deleteNode n- insertNode (subst x k n)-deleteM [] i = do- n <- nodeBy i- w <- nodeBy (N.eps n)- deleteNode w- deleteNode n- j <- insertLeaf- insertNode (n { N.eps = j })- -lookupM :: [Int] -> ID -> GraphM a (Maybe a)-lookupM [] i = do- j <- N.eps <$> nodeBy i- N.value <$> nodeBy j-lookupM (x:xs) i = do- n <- nodeBy i- case onSym x n of- Just j -> lookupM xs j- Nothing -> return Nothing--assocsAcc :: Graph (Maybe a) -> ID -> [([Int], a)]-assocsAcc g i =- here w ++ concatMap there (trans n)- where- n = I.nodeBy i g- 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)---- | A 'I.Graph' with one root from which all other graph nodes should--- be accesible. Parameter @a@ is a phantom parameter which represents--- symbol type.-data DAWG a b = DAWG- { graph :: !(Graph (Maybe b))- , root :: !ID }- deriving (Show, Eq, Ord)--instance (Ord b, Binary b) => Binary (DAWG a b) where- put d = do- put (graph d)- put (root d)- get = DAWG <$> get <*> get---- | Empty DAWG.-empty :: Ord b => DAWG a b-empty = - let (i, g) = S.runState insertLeaf I.empty- in DAWG g i---- | Number of states in the underlying graph.-numStates :: DAWG a b -> Int-numStates = I.size . graph---- | Insert the (key, value) pair into the DAWG.-insert :: (Enum a, Ord b) => [a] -> b -> DAWG a b -> DAWG a b-insert xs' y d =- 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.--- 'insertWith' f key value d will insert the pair (key, value) into d if--- key does not exist in the DAWG. If the key does exist, the function--- will insert the pair (key, f new_value old_value).-insertWith- :: (Enum a, Ord b) => (b -> b -> b)- -> [a] -> b -> DAWG a b -> DAWG a b-insertWith f xs' y d =- let xs = map fromEnum xs'- (i, g) = S.runState (insertWithM f xs y $ root d) (graph d)- in DAWG g i-{-# SPECIALIZE insertWith- :: Ord b => (b -> b -> b) -> String -> b- -> DAWG Char b -> DAWG Char b #-}---- | Delete the key from the DAWG.-delete :: (Enum a, Ord b) => [a] -> DAWG a b -> DAWG a b-delete xs' d =- let xs = map fromEnum xs'- (i, g) = S.runState (deleteM xs $ root d) (graph d)- in DAWG g i-{-# SPECIALIZE delete :: Ord b => String -> DAWG Char b -> DAWG Char b #-}---- | Find value associated with the key.-lookup :: Enum a => [a] -> DAWG a b -> Maybe b-lookup xs' d =- let xs = map fromEnum xs'- in S.evalState (lookupM xs $ root d) (graph d)-{-# SPECIALIZE lookup :: String -> DAWG Char b -> Maybe b #-}---- | Return all key/value pairs in the DAWG in ascending key order.-assocs :: Enum a => DAWG a b -> [([a], b)]-assocs- = map (first (map toEnum))- . (assocsAcc <$> graph <*> root)-{-# SPECIALIZE assocs :: DAWG Char b -> [(String, b)] #-}---- | Return all keys of the DAWG in ascending order.-keys :: Enum a => DAWG a b -> [[a]]-keys = map fst . assocs-{-# SPECIALIZE keys :: DAWG Char b -> [String] #-}---- | Return all elements of the DAWG in the ascending order of their keys.-elems :: DAWG a b -> [b]-elems = map snd . (assocsAcc <$> graph <*> root)---- | Construct DAWG from the list of (word, value) pairs.-fromList :: (Enum a, Ord b) => [([a], b)] -> DAWG a b-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--- with a combining function. The combining function is--- applied strictly.-fromListWith :: (Enum a, Ord b) => (b -> b -> b) -> [([a], b)] -> DAWG a b-fromListWith f xs =- let update t (x, v) = insertWith f x v t- in foldl' update empty xs-{-# SPECIALIZE fromListWith :: Ord b => (b -> b -> b)- -> [(String, b)] -> DAWG Char b #-}---- | Make DAWG from the list of words. Annotate each word with--- the @()@ value.-fromLang :: Enum a => [[a]] -> DAWG a ()-fromLang xs = fromList [(x, ()) | x <- xs]-{-# SPECIALIZE fromLang :: [String] -> DAWG Char () #-}+import Data.DAWG.Internal
+ Data/DAWG/Graph.hs view
@@ -0,0 +1,208 @@+{-# 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.Graph+( Graph (..)+, empty+, size+, nodeBy+, insert+, delete+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, put, get)+import qualified Data.IntSet as S+import qualified Data.IntMap as M++import Data.DAWG.HashMap (Hash)+import qualified Data.DAWG.HashMap as H++type ID = Int++-- | A set of nodes. To every node a unique identifier is assigned.+-- Invariants: +--+-- * freeIDs \\intersection occupiedIDs = \\emptySet,+--+-- * freeIDs \\sum occupiedIDs =+-- {0, 1, ..., |freeIDs \\sum occupiedIDs| - 1},+--+-- where occupiedIDs = elemSet idMap.+--+-- TODO: Is it possible to merge 'freeIDs' with 'ingoMap' to reduce+-- the memory footprint?+data Graph n = Graph {+ -- | Map from nodes to IDs with hash values interpreted+ -- as keys and (node, ID) pairs interpreted as map elements.+ idMap :: !(H.HashMap n ID)+ -- | Set of free IDs.+ , freeIDs :: !S.IntSet+ -- | Map from IDs to nodes. + , nodeMap :: !(M.IntMap n)+ -- | Number of ingoing paths (different paths from the root+ -- to the given node) for each node ID in the graph.+ -- The number of ingoing paths can be also interpreted as+ -- a number of occurences of the node in a tree representation+ -- of the graph.+ , ingoMap :: !(M.IntMap Int) }+ deriving (Show, Eq, Ord)++instance (Ord n, Binary n) => Binary (Graph n) where+ put Graph{..} = do+ put idMap+ put freeIDs+ put nodeMap+ put ingoMap+ get = Graph <$> get <*> get <*> get <*> get++-- | Empty graph.+empty :: Graph n+empty = Graph H.empty S.empty M.empty M.empty++-- | Size of the graph (number of nodes).+size :: Graph n -> Int+size = H.size . idMap++-- | Node with the given identifier.+nodeBy :: ID -> Graph n -> n+nodeBy i g = nodeMap g M.! i++-- | Retrieve identifier of a node assuming that the node+-- is present in the graph. If the assumption is not+-- safisfied, the returned identifier may be incorrect.+nodeID'Unsafe :: Hash n => n -> Graph n -> ID+nodeID'Unsafe n g = H.lookupUnsafe n (idMap g)++-- | Add new graph node (assuming that it is not already a member+-- of the graph).+newNode :: Hash n => n -> Graph n -> (ID, Graph n)+newNode n Graph{..} =+ (i, Graph idMap' freeIDs' nodeMap' ingoMap')+ where+ idMap' = H.insertUnsafe n i idMap+ nodeMap' = M.insert i n nodeMap+ ingoMap' = M.insert i 1 ingoMap+ (i, freeIDs') = if S.null freeIDs+ then (H.size idMap, freeIDs)+ else S.deleteFindMin freeIDs++-- | Remove node from the graph (assuming that it is a member+-- of the graph).+remNode :: Hash n => ID -> Graph n -> Graph n+remNode i Graph{..} =+ Graph idMap' freeIDs' nodeMap' ingoMap'+ where+ idMap' = H.deleteUnsafe n idMap+ nodeMap' = M.delete i nodeMap+ ingoMap' = M.delete i ingoMap+ freeIDs' = S.insert i freeIDs+ n = nodeMap M.! i++-- | Increment the number of ingoing paths.+incIngo :: ID -> Graph n -> Graph n+incIngo i g = g { ingoMap = M.insertWith' (+) i 1 (ingoMap g) }++-- | Decrement the number of ingoing paths and return+-- the resulting number.+decIngo :: ID -> Graph n -> (Int, Graph n)+decIngo i g =+ let k = (ingoMap g M.! i) - 1+ in (k, g { ingoMap = M.insert i k (ingoMap g) })++-- | Insert node into the graph. If the node was already a member+-- of the graph, just increase the number of ingoing paths.+-- 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 :: Hash n => n -> Graph n -> (ID, Graph n)+insert n g = case H.lookup n (idMap g) of+ Just i -> (i, incIngo i g)+ Nothing -> newNode n g++-- | Delete node from the graph. If the node was present in the graph+-- at multiple positions, just decrease the number of ingoing paths.+-- Function crashes if the node is not a member of the graph. +-- NOTE: The function does not delete descendant nodes which may become+-- inaccesible nor does it change the number of ingoing paths for any+-- descendant of the node.+delete :: Hash n => n -> Graph n -> Graph n+delete n g = if num == 0+ then remNode i g'+ else g'+ where+ i = nodeID'Unsafe 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)
+ Data/DAWG/HashMap.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE RecordWildCards #-}++-- | A map from hashable keys to values.++module Data.DAWG.HashMap+( Hash (..)+, HashMap (..)+, empty+, lookup+, insertUnsafe+, lookupUnsafe+, deleteUnsafe+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, Get, put, get)+import qualified Data.Map as M+import qualified Data.IntMap as I++fromJust :: Maybe a -> a+fromJust (Just x) = x+fromJust Nothing = error "fromJust: Nothing"+{-# INLINE fromJust #-}++-- | Class for types which provide hash values.+class Ord a => Hash a where+ hash :: a -> Int++-- | Value in a HashMap.+data Value a b+ = Single !a !b+ | Multi !(M.Map a b)+ deriving (Show, Eq, Ord)++instance (Ord a, Binary a, Binary b) => Binary (Value a b) where+ put (Single x y) = put (1 :: Int) >> put x >> put y+ put (Multi m) = put (2 :: Int) >> put m+ get = do+ x <- get :: Get Int+ case x of+ 1 -> Single <$> get <*> get+ _ -> Multi <$> get++-- | Find element associated to a value key.+find :: Ord a => a -> Value a b -> Maybe b+find x (Single x' y) = if x == x'+ then Just y+ else Nothing+find x (Multi m) = M.lookup x m++-- | Assumption: element is a member of the 'Value'. +findUnsafe :: Ord a => a -> Value a b -> Maybe b+findUnsafe _ (Single _ y) = Just y -- unsafe+findUnsafe x (Multi m) = M.lookup x m++-- | Convert map into a 'Single' form if possible.+trySingle :: Ord a => M.Map a b -> Value a b+trySingle m = if M.size m == 1+ then (uncurry Single) (M.findMin m)+ else Multi m++-- | Insert element into a value.+embed :: Ord a => a -> b -> Value a b -> Value a b+embed x y (Single x' y') = Multi $ M.fromList [(x, y), (x', y')]+embed x y (Multi m) = Multi $ M.insert x y m++-- | Delete element from a value. Return 'Nothing' if the resultant+-- value is empty.+ejectUnsafe :: Ord a => a -> Value a b -> Maybe (Value a b)+ejectUnsafe _ (Single _ _) = Nothing -- unsafe+ejectUnsafe x (Multi m) = (Just . trySingle) (M.delete x m)++-- | A map from /a/ keys to /b/ elements where keys instantiate the+-- 'Hash' type class. Key/element pairs are kept in 'Value' objects+-- which takes care of potential hash collisions.+data HashMap a b = HashMap+ { size :: {-# UNPACK #-} !Int+ , hashMap :: !(I.IntMap (Value a b)) }+ deriving (Show, Eq, Ord)++instance (Ord a, Binary a, Binary b) => Binary (HashMap a b) where+ put HashMap{..} = put size >> put hashMap+ get = HashMap <$> get <*> get++-- | Empty map.+empty :: HashMap a b+empty = HashMap 0 I.empty++-- | Lookup element in the map.+lookup :: Hash a => a -> HashMap a b -> Maybe b+lookup x (HashMap _ m) = I.lookup (hash x) m >>= find x++-- | Assumption: element is present in the map.+lookupUnsafe :: Hash a => a -> HashMap a b -> b+lookupUnsafe x (HashMap _ m) = fromJust (I.lookup (hash x) m >>= findUnsafe x)++-- | Insert a new element. The function doesn't check+-- if the element was already present in the map.+insertUnsafe :: Hash a => a -> b -> HashMap a b -> HashMap a b+insertUnsafe x y (HashMap n m) =+ let i = hash x+ f (Just v) = embed x y v+ f Nothing = Single x y+ in HashMap (n + 1) $ I.alter (Just . f) i m++-- | Assumption: element is present in the map.+deleteUnsafe :: Hash a => a -> HashMap a b -> HashMap a b+deleteUnsafe x (HashMap n m) =+ HashMap (n - 1) $ I.update (ejectUnsafe x) (hash x) m
Data/DAWG/Internal.hs view
@@ -1,207 +1,269 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} --- | 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.+-- | The module implements /directed acyclic word graphs/ (DAWGs) internaly+-- represented as /minimal acyclic deterministic finite-state automata/.+-- The implementation provides fast insert and delete operations+-- which can be used to build the DAWG structure incrementaly. module Data.DAWG.Internal-( Graph (..)+(+-- * DAWG type+ DAWG (..)+, MkNode+-- * Query+, numStates+, lookup+-- * Construction , empty-, size-, nodeBy-, nodeID+, fromList+, fromListWith+, fromLang+-- ** Insertion , insert+, insertWith+-- ** Deletion , delete+-- * Conversion+, assocs+, keys+, elems ) where +import Prelude hiding (lookup) import Control.Applicative ((<$>), (<*>))--- import Data.List (foldl')+import Control.Arrow (first)+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 Control.Monad.State.Strict as S+import qualified Data.Vector.Unboxed as U+import qualified Control.Monad.State.Strict as S -import Data.DAWG.Node.Specialized hiding (Node)-import qualified Data.DAWG.Node.Specialized as N+import Data.DAWG.Types+import Data.DAWG.Graph (Graph)+import Data.DAWG.Trans (Trans)+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Node as N+import qualified Data.DAWG.Graph as G -type Node a = N.Node a+type Node t a = N.Node t () a --- | A set of nodes. To every node a unique identifier is assigned.--- Invariants: ------ * freeIDs \\intersection occupiedIDs = \\emptySet,------ * freeIDs \\sum occupiedIDs =--- {0, 1, ..., |freeIDs \\sum occupiedIDs| - 1},------ where occupiedIDs = elemSet idMap.------ TODO: Is it possible to merge 'freeIDs' with 'ingoMap' to reduce--- the memory footprint?-data Graph a = Graph {- -- | Map from nodes to IDs.- idMap :: !(M.Map (Node a) ID)- -- | Set of free IDs.- , freeIDs :: !IS.IntSet- -- | Map from IDs to nodes. - , nodeMap :: !(IM.IntMap (Node a))- -- | Number of ingoing paths (different paths from the root- -- to the given node) for each node ID in the graph.- -- The number of ingoing paths can be also interpreted as- -- a number of occurences of the node in a tree representation- -- of the graph.- , ingoMap :: !(IM.IntMap Int) }- deriving (Show, Eq, Ord)+-- | Is /t/ a valid transition map within the context of+-- /a/-valued automata nodes? All transition implementations+-- provided by the library are instances of this class.+class (Ord (Node t a), Trans t) => MkNode t a where+instance (Ord (Node t a), Trans t) => MkNode t a where -instance (Ord a, Binary a) => Binary (Graph a) where- put Graph{..} = do- put idMap- put freeIDs- put nodeMap- put ingoMap- get = Graph <$> get <*> get <*> get <*> get+type GraphM t a b = S.State (Graph (Node t a)) b --- | Empty graph.-empty :: Graph a-empty = Graph M.empty IS.empty IM.empty IM.empty+mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a)+mkState f g = ((), f g) --- | Size of the graph (number of nodes).-size :: Graph a -> Int-size = M.size . idMap+-- | Leaf node with no children and 'Nothing' value.+insertLeaf :: MkNode t a => GraphM t a ID+insertLeaf = do+ i <- insertNode (N.Leaf Nothing)+ insertNode (N.Branch i T.empty U.empty) --- | Node with the given identifier.-nodeBy :: ID -> Graph a -> Node a-nodeBy i g = nodeMap g IM.! i+-- | Return node with the given identifier.+nodeBy :: ID -> GraphM t a (Node t a)+nodeBy i = G.nodeBy i <$> S.get --- | Retrieve the node identifier.-nodeID :: Ord a => Node a -> Graph a -> ID-nodeID n g = idMap g M.! n+-- Evaluate the 'G.insert' function within the monad.+insertNode :: MkNode t a => Node t a -> GraphM t a ID+insertNode = S.state . G.insert --- | Add new graph node.-newNode :: Ord a => Node a -> Graph a -> (ID, Graph a)-newNode n Graph{..} =- (i, Graph idMap' freeIDs' nodeMap' ingoMap')- where- idMap' = M.insert n i idMap- nodeMap' = IM.insert i n nodeMap- ingoMap' = IM.insert i 1 ingoMap- (i, freeIDs') = if IS.null freeIDs- then (M.size idMap, freeIDs)- else IS.deleteFindMin freeIDs+-- Evaluate the 'G.delete' function within the monad.+deleteNode :: MkNode t a => Node t a -> GraphM t a ()+deleteNode = S.state . mkState . G.delete --- | Remove node from the graph.-remNode :: Ord a => ID -> Graph a -> Graph a-remNode i Graph{..} =- Graph idMap' freeIDs' nodeMap' ingoMap'+-- | Invariant: the identifier points to the 'Branch' node.+insertM :: MkNode t a => [Sym] -> a -> ID -> GraphM t a ID+insertM (x:xs) y i = do+ n <- nodeBy i+ j <- case N.onSym x n of+ Just j -> return j+ Nothing -> insertLeaf+ k <- insertM xs y j+ deleteNode n+ insertNode (N.insert x k n)+insertM [] y i = do+ n <- nodeBy i+ w <- nodeBy (N.eps n)+ deleteNode w+ deleteNode n+ j <- insertNode (N.Leaf $ Just y)+ insertNode (n { N.eps = j })++insertWithM+ :: MkNode t a => (a -> a -> a)+ -> [Sym] -> a -> ID -> GraphM t a ID+insertWithM f (x:xs) y i = do+ n <- nodeBy i+ j <- case N.onSym x n of+ Just j -> return j+ Nothing -> insertLeaf+ k <- insertWithM f xs y j+ deleteNode n+ insertNode (N.insert x k n)+insertWithM f [] y i = do+ n <- nodeBy i+ w <- nodeBy (N.eps n)+ deleteNode w+ deleteNode n+ let y'new = case N.value w of+ Just y' -> f y y'+ Nothing -> y+ j <- insertNode (N.Leaf $ Just y'new)+ insertNode (n { N.eps = j })++deleteM :: MkNode t a => [Sym] -> ID -> GraphM t a ID+deleteM (x:xs) i = do+ n <- nodeBy i+ case N.onSym x n of+ Nothing -> return i+ Just j -> do+ k <- deleteM xs j+ deleteNode n+ insertNode (N.insert x k n)+deleteM [] i = do+ n <- nodeBy i+ w <- nodeBy (N.eps n)+ deleteNode w+ deleteNode n+ j <- insertLeaf+ insertNode (n { N.eps = j })+ +lookupM :: Trans t => [Sym] -> ID -> GraphM t a (Maybe a)+lookupM [] i = do+ j <- N.eps <$> nodeBy i+ N.value <$> nodeBy j+lookupM (x:xs) i = do+ n <- nodeBy i+ case N.onSym x n of+ Just j -> lookupM xs j+ Nothing -> return Nothing++assocsAcc :: Trans t => Graph (Node t a) -> ID -> [([Sym], a)]+assocsAcc g i =+ here w ++ concatMap there (N.edges n) where- idMap' = M.delete n idMap- nodeMap' = IM.delete i nodeMap- ingoMap' = IM.delete i ingoMap- freeIDs' = IS.insert i freeIDs- n = nodeMap IM.! i+ n = G.nodeBy i g+ w = G.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) --- | Increment the number of ingoing paths.-incIngo :: ID -> Graph a -> Graph a-incIngo i g = g { ingoMap = IM.insertWith' (+) i 1 (ingoMap g) }+-- | A directed acyclic word graph with phantom type @a@ representing+-- type of alphabet elements.+data DAWG t a b = DAWG+ { graph :: !(Graph (Node t b))+ , root :: !ID }+ deriving (Show) --- | Decrement the number of ingoing paths and return--- the resulting number.-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) })+instance (MkNode t b, Binary t, Binary b) => Binary (DAWG t a b) where+ put d = do+ put (graph d)+ put (root d)+ get = DAWG <$> get <*> get --- | Insert node into the graph. If the node was already a member--- of the graph, just increase the number of ingoing paths.--- 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 n g = case M.lookup n (idMap g) of- Just i -> (i, incIngo i g)- Nothing -> newNode n g+-- | Empty DAWG.+empty :: (MkNode t b) => DAWG t a b+empty = + let (i, g) = S.runState insertLeaf G.empty+ in DAWG g i --- | Delete node from the graph. If the node was present in the graph--- at multiple positions, just decrease the number of ingoing paths.--- NOTE: The function does not delete descendant nodes which may become--- inaccesible nor does it change the number of ingoing paths for any--- descendant of the node.-delete :: Ord a => Node a -> Graph a -> Graph a-delete n g = if num == 0- then remNode i g'- else g'- where- i = nodeID n g- (num, g') = decIngo i g+-- | Number of states in the underlying graph.+numStates :: DAWG t a b -> Int+numStates = G.size . graph --- -- | 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)+-- | Insert the (key, value) pair into the DAWG.+insert :: (Enum a, MkNode t b) => [a] -> b -> DAWG t a b -> DAWG t a b+insert xs' y d =+ let xs = map fromEnum xs'+ (i, g) = S.runState (insertM xs y $ root d) (graph d)+ in DAWG g i+{-# INLINE insert #-}+{-# SPECIALIZE insert+ :: (MkNode t b) => String -> b+ -> DAWG t Char b -> DAWG t Char b #-}++-- | Insert with a function, combining new value and old value.+-- 'insertWith' f key value d will insert the pair (key, value) into d if+-- key does not exist in the DAWG. If the key does exist, the function+-- will insert the pair (key, f new_value old_value).+insertWith+ :: (Enum a, MkNode t b) => (b -> b -> b)+ -> [a] -> b -> DAWG t a b -> DAWG t a b+insertWith f xs' y d =+ let xs = map fromEnum xs'+ (i, g) = S.runState (insertWithM f xs y $ root d) (graph d)+ in DAWG g i+{-# SPECIALIZE insertWith+ :: MkNode t b => (b -> b -> b) -> String -> b+ -> DAWG t Char b -> DAWG t Char b #-}++-- | Delete the key from the DAWG.+delete :: (Enum a, MkNode t b) => [a] -> DAWG t a b -> DAWG t a b+delete xs' d =+ let xs = map fromEnum xs'+ (i, g) = S.runState (deleteM xs $ root d) (graph d)+ in DAWG g i+{-# SPECIALIZE delete+ :: MkNode t b => String+ -> DAWG t Char b -> DAWG t Char b #-}++-- | Find value associated with the key.+lookup :: (Enum a, MkNode t b) => [a] -> DAWG t a b -> Maybe b+lookup xs' d =+ let xs = map fromEnum xs'+ in S.evalState (lookupM xs $ root d) (graph d)+{-# SPECIALIZE lookup+ :: MkNode t b => String+ -> DAWG t Char b -> Maybe b #-}++-- | Return all key/value pairs in the DAWG in ascending key order.+assocs :: (Enum a, MkNode t b) => DAWG t a b -> [([a], b)]+assocs+ = map (first (map toEnum))+ . (assocsAcc <$> graph <*> root)+{-# SPECIALIZE assocs :: MkNode t b => DAWG t Char b -> [(String, b)] #-}++-- | Return all keys of the DAWG in ascending order.+keys :: (Enum a, MkNode t b) => DAWG t a b -> [[a]]+keys = map fst . assocs+{-# SPECIALIZE keys :: MkNode t b => DAWG t Char b -> [String] #-}++-- | Return all elements of the DAWG in the ascending order of their keys.+elems :: MkNode t b => DAWG t a b -> [b]+elems = map snd . (assocsAcc <$> graph <*> root)++-- | Construct DAWG from the list of (word, value) pairs.+fromList :: (Enum a, MkNode t b) => [([a], b)] -> DAWG t a b+fromList xs =+ let update t (x, v) = insert x v t+ in foldl' update empty xs+{-# INLINE fromList #-}+{-# SPECIALIZE fromList+ :: MkNode t b => [(String, b)] -> DAWG t Char b #-}++-- | Construct DAWG from the list of (word, value) pairs+-- with a combining function. The combining function is+-- applied strictly.+fromListWith+ :: (Enum a, MkNode t b) => (b -> b -> b)+ -> [([a], b)] -> DAWG t a b+fromListWith f xs =+ let update t (x, v) = insertWith f x v t+ in foldl' update empty xs+{-# SPECIALIZE fromListWith+ :: MkNode t b => (b -> b -> b)+ -> [(String, b)] -> DAWG t Char b #-}++-- | Make DAWG from the list of words. Annotate each word with+-- the @()@ value.+fromLang :: (Enum a, MkNode t ()) => [[a]] -> DAWG t a ()+fromLang xs = fromList [(x, ()) | x <- xs]+{-# SPECIALIZE fromLang :: MkNode t () => [String] -> DAWG t Char () #-}
Data/DAWG/Node.hs view
@@ -1,63 +1,35 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-} -- | Internal representation of automata nodes. module Data.DAWG.Node-(--- * Basic types- ID-, Sym--- * Node-, Node (..)+( Node (..) , onSym-, trans+, onSym' , edges-, subst-, toGeneric--- * Edge-, Edge-, to-, label-, annotate-, labeled+, children+, insert+, reID ) 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 #-}+import Data.Vector.Binary ()+import qualified Data.Vector.Unboxed as U --- | Construct edge annotated with a given label.-labeled :: a -> ID -> Edge a-labeled x i = (i, x)-{-# INLINE labeled #-}+import Data.DAWG.Types+import Data.DAWG.Util (combine)+import Data.DAWG.Trans (Trans)+import Data.DAWG.HashMap (Hash, hash)+import qualified Data.DAWG.Trans.Hashed as H+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Trans.Vector as TV+import qualified Data.DAWG.Trans.Map as TM -- | Two nodes (states) belong to the same equivalence class (and, -- consequently, they must be represented as one node in the graph)@@ -71,50 +43,72 @@ -- -- 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 +data Node t 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)+ -- | Transition map (outgoing edges).+ , transMap :: !(H.Hashed t)+ -- | Labels corresponding to individual edges.+ , labelVect :: !(U.Vector a) }+ | Leaf { value :: !(Maybe b) }+ deriving (Show) -instance (Unbox b, Binary a, Binary b) => Binary (Node a b) where- put Branch{..} = put (1 :: Int) >> put eps >> put edgeMap+deriving instance (Eq a, Eq b, U.Unbox a) => Eq (Node TV.Trans a b)+deriving instance (Ord a, Ord b, U.Unbox a) => Ord (Node TV.Trans a b)+deriving instance (Eq a, Eq b, U.Unbox a) => Eq (Node TM.Trans a b)+deriving instance (Ord a, Ord b, U.Unbox a) => Ord (Node TM.Trans a b)++instance (Trans t, Ord (Node t a b)) => Hash (Node t a b) where+ hash Branch{..} = combine eps (H.hash transMap)+ hash Leaf{..} = case value of+ Just _ -> (-1)+ Nothing -> (-2)++instance (U.Unbox a, Binary t, Binary a, Binary b) => Binary (Node t a b) where+ put Branch{..} = put (1 :: Int) >> put eps >> put transMap >> put labelVect put Leaf{..} = put (2 :: Int) >> put value get = do x <- get :: Get Int case x of- 1 -> Branch <$> get <*> get+ 1 -> Branch <$> get <*> get <*> get _ -> Leaf <$> get -- | Transition function.-onSym :: Unbox b => Sym -> Node a b -> Maybe b-onSym x (Branch _ es) = M.lookup x es+onSym :: Trans t => Sym -> Node t a b -> Maybe ID+onSym x (Branch _ t _) = T.lookup x t 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 #-}+-- | Transition function.+onSym' :: (Trans t, U.Unbox a) => Sym -> Node t a b -> Maybe (ID, a)+onSym' x (Branch _ t ls) = do+ k <- T.index x t+ (,) <$> (snd <$> T.byIndex k t)+ <*> ls U.!? k+onSym' _ (Leaf _) = Nothing+{-# INLINE onSym' #-} --- | List of outgoing edges.-edges :: Unbox b => Node a b -> [b]-edges = map snd . trans+-- | List of symbol/edge pairs outgoing from the node.+edges :: Trans t => Node t a b -> [(Sym, ID)]+edges (Branch _ t _) = T.toList t+edges (Leaf _) = [] {-# INLINE edges #-} +-- | List of children identifiers.+children :: Trans t => Node t a b -> [ID]+children = map snd . edges+{-# INLINE children #-}+ -- | 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 #-}+insert :: Trans t => Sym -> ID -> Node t a b -> Node t a b+insert x i (Branch w t ls) = Branch w (T.insert x i t) ls+insert _ _ l = l+{-# INLINE insert #-} --- | 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 ())+-- | Assign new identifiers.+reID :: Trans t => (ID -> ID) -> Node t a b -> Node t a b+reID _ (Leaf x) = Leaf x+reID f (Branch e t ls) =+ let reTrans = T.fromList . map (second f) . T.toList+ in Branch (f e) (reTrans t) ls
− Data/DAWG/Node/Specialized.hs
@@ -1,90 +0,0 @@-{-# 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)
Data/DAWG/Static.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} -- | The module implements /directed acyclic word graphs/ (DAWGs) internaly -- represented as /minimal acyclic deterministic finite-state automata/.@@ -12,11 +16,21 @@ -- 'hash' and 'unHash' functions, -- -- * Doesn't provide insert/delete family of operations.+--+-- Transition backend has to be specified by a type signature. You can import+-- the desired transition type and define your own dictionary construction+-- function.+--+-- > import Data.DAWG.Static+-- > import Data.DAWG.Trans.Map (Trans)+-- >+-- > mkDict :: (Enum a, Ord b) => [([a], b)] -> DAWG Trans a Weight b+-- > mkDict = weigh . fromList module Data.DAWG.Static ( -- * DAWG type- DAWG (..)+ DAWG -- * Query , lookup , numStates@@ -45,104 +59,126 @@ import Prelude hiding (lookup) import Control.Applicative ((<$), (<$>), (<|>)) import Control.Arrow (first)-import Data.Binary (Binary)+import Data.Binary (Binary, put, get) import Data.Vector.Binary () import Data.Vector.Unboxed (Unbox) import qualified Data.IntMap as M import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U -import Data.DAWG.Node hiding (Node)+import Data.DAWG.Types+import Data.DAWG.Trans (Trans)+import Data.DAWG.Node (Node)+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Trans.Vector as VT 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+import qualified Data.DAWG.Graph as G+import qualified Data.DAWG.Internal as D+import qualified Data.DAWG.Util as Util -type Node a b = N.Node (Maybe a) (Edge b)+-- | @DAWG t a b c@ constitutes an automaton with alphabet symbols of type /a/,+-- transition labels of type /b/ and node values of type /Maybe c/, implemented+-- on top of the 'T.Trans' /t/ backend. All nodes are stored in a 'V.Vector'+-- with positions of nodes corresponding to their 'ID's.+newtype DAWG t a b c = DAWG { unDAWG :: V.Vector (Node t b c) }+ deriving (Show) --- | @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 b c) }- deriving (Show, Eq, Ord, Binary)+deriving instance (Eq b, Eq c, Unbox b) => Eq (DAWG VT.Trans a b c)+deriving instance (Ord b, Ord c, Unbox b) => Ord (DAWG VT.Trans a b c) +instance (Binary t, Binary b, Binary c, Unbox b) => Binary (DAWG t a b c) where+ put = put . unDAWG+ get = DAWG <$> get+ -- | Empty DAWG.-empty :: Unbox c => DAWG a b c+empty :: (Trans t, Unbox b) => DAWG t a b c empty = DAWG $ V.fromList- [ Branch 1 VM.empty- , Leaf Nothing ]+ [ N.Branch 1 T.empty U.empty+ , N.Leaf Nothing ] -- | Number of states in the automaton.-numStates :: DAWG a b c -> Int+numStates :: DAWG t a b c -> Int numStates = V.length . unDAWG -- | Node with the given identifier.-nodeBy :: ID -> DAWG a b c -> Node b c+nodeBy :: ID -> DAWG t a b c -> Node t 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)+leafValue :: Node t b c -> DAWG t a b c -> Maybe c+leafValue n = N.value . nodeBy (N.eps n) -- | Find value associated with the key.-lookup :: (Unbox c, Enum a) => [a] -> DAWG a b c -> Maybe b+lookup :: (Enum a, Trans t, Unbox b) => [a] -> DAWG t a b c -> Maybe c lookup xs' = let xs = map fromEnum xs' in lookup'I xs 0-{-# SPECIALIZE lookup :: Unbox c => String -> DAWG Char b c -> Maybe b #-}+{-# SPECIALIZE lookup+ :: (Trans t, Unbox b) => String+ -> DAWG t Char b c -> Maybe c #-} -lookup'I :: Unbox c => [Sym] -> ID -> DAWG a b c -> Maybe b+lookup'I :: (Trans t, Unbox b) => [Sym] -> ID -> DAWG t a b c -> Maybe c 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+lookup'I (x:xs) i d = case N.onSym x (nodeBy i d) of+ Just j -> lookup'I xs j d Nothing -> Nothing -- | Return all key/value pairs in the DAWG in ascending key order.-assocs :: (Enum a, Unbox c) => DAWG a b c -> [([a], b)]+assocs :: (Enum a, Trans t, Unbox b) => DAWG t a b c -> [([a], c)] assocs d = map (first (map toEnum)) (assocs'I 0 d)-{-# SPECIALIZE assocs :: Unbox c => DAWG Char b c -> [(String, b)] #-}+{-# SPECIALIZE assocs+ :: (Trans t, Unbox b)+ => DAWG t Char b c -> [(String, c)] #-} -assocs'I :: Unbox c => ID -> DAWG a b c -> [([Sym], b)]+assocs'I :: (Trans t, Unbox b) => ID -> DAWG t a b c -> [([Sym], c)] assocs'I i d =- here ++ concatMap there (trans n)+ here ++ concatMap there (N.edges n) where n = nodeBy i d here = case leafValue n d of Just x -> [([], x)] Nothing -> []- there (x, e) = map (first (x:)) (assocs'I (to e) d)+ there (x, j) = map (first (x:)) (assocs'I j d) -- | Return all keys of the DAWG in ascending order.-keys :: (Unbox c, Enum a) => DAWG a b c -> [[a]]+keys :: (Enum a, Trans t, Unbox b) => DAWG t a b c -> [[a]] keys = map fst . assocs-{-# SPECIALIZE keys :: Unbox c => DAWG Char b c -> [String] #-}+{-# SPECIALIZE keys :: (Trans t, Unbox b) => DAWG t Char b c -> [String] #-} -- | Return all elements of the DAWG in the ascending order of their keys.-elems :: Unbox c => DAWG a b c -> [b]+elems :: (Trans t, Unbox b) => DAWG t a b c -> [c] elems = map snd . assocs'I 0 -- | Construct 'DAWG' from the list of (word, value) pairs. -- First a 'D.DAWG' is created and then it is frozen using -- the 'freeze' function.-fromList :: (Enum a, Ord b) => [([a], b)] -> DAWG a b ()+fromList+ :: (Enum a, D.MkNode t b)+ => [([a], b)] -> DAWG t a () b fromList = freeze . D.fromList-{-# SPECIALIZE fromList :: Ord b => [(String, b)] -> DAWG Char b () #-}+{-# SPECIALIZE fromList+ :: D.MkNode t b => [(String, b)] -> DAWG t Char () b #-} -- | Construct DAWG from the list of (word, value) pairs -- with a combining function. The combining function is -- applied strictly. First a 'D.DAWG' is created and then -- it is frozen using the 'freeze' function.-fromListWith :: (Enum a, Ord b) => (b -> b -> b) -> [([a], b)] -> DAWG a b ()+fromListWith+ :: (Enum a, D.MkNode t b)+ => (b -> b -> b) -> [([a], b)] -> DAWG t a () b fromListWith f = freeze . D.fromListWith f-{-# SPECIALIZE fromListWith :: Ord b => (b -> b -> b)- -> [(String, b)] -> DAWG Char b () #-}+{-# SPECIALIZE fromListWith+ :: D.MkNode t b => (b -> b -> b)+ -> [(String, b)] -> DAWG t Char () b #-} -- | Make DAWG from the list of words. Annotate each word with -- the @()@ value. First a 'D.DAWG' is created and then it is frozen -- using the 'freeze' function.-fromLang :: Enum a => [[a]] -> DAWG a () ()+fromLang + :: (Enum a, D.MkNode t ())+ => [[a]] -> DAWG t a () () fromLang = freeze . D.fromLang-{-# SPECIALIZE fromLang :: [String] -> DAWG Char () () #-}+{-# SPECIALIZE fromLang :: D.MkNode t () => [String] -> DAWG t Char () () #-} -- | Weight of a node corresponds to the number of final states -- reachable from the node. Weight of an edge is a sum of weights@@ -150,46 +186,40 @@ type Weight = Int -- | Compute node weights and store corresponding values in transition labels.-weigh :: Unbox c => DAWG a b c -> DAWG a b Weight+weigh :: Trans t => DAWG t a b c -> DAWG t a Weight c weigh d = (DAWG . V.fromList)- [ branch n (apply ws (trans n))+ [ branch n ws | i <- [0 .. numStates d - 1] , let n = nodeBy i d- , let ws = accum (children n) ]+ , let ws = accum (N.children n) ] where- -- Branch with new edges.- branch Branch{..} es = Branch eps es- branch Leaf{..} _ = Leaf value+ -- Branch with new weights.+ branch N.Branch{..} ws = N.Branch eps transMap ws+ branch N.Leaf{..} _ = N.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 = 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 ]+ N.Leaf w -> maybe 0 (const 1) w+ n -> sum . map nodeWeight $ allChildren n+ -- Weights for subsequent edges.+ accum = U.fromList . init . scanl (+) 0 . map nodeWeight -- Plain children and epsilon child. - allChildren n = eps n : children n- -- IDs of plain children.- children = map to . edges+ allChildren n = N.eps n : N.children n -- | Construct immutable version of the automaton.-freeze :: D.DAWG a b -> DAWG a b ()+freeze :: Trans t => D.DAWG t a b -> DAWG t a () b freeze d = DAWG . V.fromList $- map (N.toGeneric . NS.reIdent newID . oldBy)+ map (N.reID newID . oldBy) (M.elems (inverse old2new)) where -- Map from old to new identifiers. old2new = M.fromList $ (D.root d, 0) : zip (nodeIDs d) [1..] newID = (M.!) old2new -- List of node IDs without the root ID.- nodeIDs = filter (/= D.root d) . map fst . M.assocs . I.nodeMap . D.graph+ nodeIDs = filter (/= D.root d) . map fst . M.assocs . G.nodeMap . D.graph -- Non-frozen node by given identifier.- oldBy i = I.nodeBy i (D.graph d)+ oldBy i = G.nodeBy i (D.graph d) -- | Inverse of the map. inverse :: M.IntMap Int -> M.IntMap Int@@ -198,7 +228,7 @@ in M.fromList . map swap . M.toList -- -- | Yield mutable version of the automaton.--- thaw :: (Unbox c, Ord a) => DAWG a b c -> D.DAWG a b+-- thaw :: (Unbox b, Ord a) => DAWG a b c -> D.DAWG a b -- thaw d = -- D.fromNodes nodes 0 -- where@@ -222,48 +252,51 @@ -- | Position in a set of all dictionary entries with respect -- to the lexicographic order.-index :: Enum a => [a] -> DAWG a b Weight -> Maybe Int+index :: (Enum a, Trans t) => [a] -> DAWG t a Weight c -> Maybe Int index xs = index'I (map fromEnum xs) 0-{-# SPECIALIZE index :: String -> DAWG Char b Weight -> Maybe Int #-}+{-# SPECIALIZE index+ :: Trans t => String -> DAWG t Char Weight c -> Maybe Int #-} -index'I :: [Sym] -> ID -> DAWG a b Weight -> Maybe Int+index'I :: Trans t => [Sym] -> ID -> DAWG t a Weight c -> 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) (leafValue n d)- e <- onSym x n- w <- index'I xs (to e) d- return (v + w + label e)+ u = maybe 0 (const 1) (leafValue n d)+ (j, v) <- N.onSym' x n+ w <- index'I xs j d+ return (u + v + w) -- | Perfect hashing function for dictionary entries. -- A synonym for the 'index' function.-hash :: Enum a => [a] -> DAWG a b Weight -> Maybe Int+hash :: (Enum a, Trans t) => [a] -> DAWG t a Weight c -> Maybe Int hash = index {-# INLINE hash #-} -- | Find dictionary entry given its index with respect to the -- lexicographic order.-byIndex :: Enum a => Int -> DAWG a b Weight -> Maybe [a]+byIndex :: (Enum a, Trans t) => Int -> DAWG t a Weight c -> Maybe [a] byIndex ix d = map toEnum <$> byIndex'I ix 0 d-{-# SPECIALIZE byIndex :: Int -> DAWG Char b Weight -> Maybe String #-}+{-# SPECIALIZE byIndex+ :: Trans t => Int -> DAWG t Char Weight c -> Maybe String #-} -byIndex'I :: Int -> ID -> DAWG a b Weight -> Maybe [Sym]+byIndex'I :: Trans t => Int -> ID -> DAWG t a Weight c -> Maybe [Sym] byIndex'I ix i d | ix < 0 = Nothing | otherwise = here <|> there where n = nodeBy i d- v = maybe 0 (const 1) (leafValue n d)+ u = maybe 0 (const 1) (leafValue n d) here | ix == 0 = [] <$ leafValue (nodeBy i d) d | otherwise = Nothing there = do- (x, e) <- VM.findLastLE cmp (edgeMap n)- xs <- byIndex'I (ix - v - label e) (to e) d+ (k, w) <- Util.findLastLE cmp (N.labelVect n)+ (x, j) <- T.byIndex k (N.transMap n)+ xs <- byIndex'I (ix - u - w) j d return (x:xs)- cmp e = compare (label e) (ix - v)+ cmp w = compare w (ix - u) -- | Inverse of the 'hash' function and a synonym for the 'byIndex' function.-unHash :: Enum a => Int -> DAWG a b Weight -> Maybe [a]+unHash :: (Enum a, Trans t) => Int -> DAWG t a Weight c -> Maybe [a] unHash = byIndex {-# INLINE unHash #-}
+ Data/DAWG/Trans.hs view
@@ -0,0 +1,26 @@+-- | The module provides an abstraction over transition maps from+-- alphabet symbols to node identifiers.++module Data.DAWG.Trans+( Trans (..)+) where++import Data.DAWG.Types++-- | Abstraction over transition maps from alphabet symbols to+-- node identifiers.+class Trans t where+ -- | Empty transition map.+ empty :: t+ -- | Lookup sybol in the map.+ lookup :: Sym -> t -> Maybe ID+ -- | Find index of the symbol.+ index :: Sym -> t -> Maybe Int+ -- | Select a (symbol, ID) pair by index of its position in the map.+ byIndex :: Int -> t -> Maybe (Sym, ID)+ -- | Insert element to the transition map.+ insert :: Sym -> ID -> t -> t+ -- | Construct transition map from a list.+ fromList :: [(Sym, ID)] -> t+ -- | Translate transition map into a list.+ toList :: t -> [(Sym, ID)]
+ Data/DAWG/Trans/Hashed.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Transition map with a hash.++module Data.DAWG.Trans.Hashed+( Hashed (..)+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Data.DAWG.Util (combine)+import Data.Binary (Binary, put, get)+import Data.DAWG.Trans+import qualified Data.DAWG.Trans.Map as M+import qualified Data.DAWG.Trans.Vector as V++-- | Hash of a transition map is a sum of element-wise hashes.+-- Hash for a given element @(Sym, ID)@ is equal to @combine Sym ID@.+data Hashed t = Hashed+ { hash :: {-# UNPACK #-} !Int+ , trans :: !t }+ deriving (Show)++instance Binary t => Binary (Hashed t) where+ put Hashed{..} = put hash >> put trans+ get = Hashed <$> get <*> get++instance Trans t => Trans (Hashed t) where+ empty = Hashed 0 empty+ {-# INLINE empty #-} ++ lookup x = lookup x . trans+ {-# INLINE lookup #-} ++ index x = index x . trans+ {-# INLINE index #-} ++ byIndex i = byIndex i . trans+ {-# INLINE byIndex #-} ++ insert x y (Hashed h t) = Hashed+ (h - h' + combine x y)+ (insert x y t)+ where+ h' = case lookup x t of+ Just y' -> combine x y'+ Nothing -> 0+ {-# INLINE insert #-}++ fromList xs = Hashed + (sum $ map (uncurry combine) xs)+ (fromList xs)+ {-# INLINE fromList #-}++ toList = toList . trans+ {-# INLINE toList #-}++deriving instance Eq (Hashed M.Trans)+deriving instance Ord (Hashed M.Trans)+deriving instance Eq (Hashed V.Trans)+deriving instance Ord (Hashed V.Trans)
+ Data/DAWG/Trans/Map.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Implementation of a transition map build on top of the "M.Map" container.++module Data.DAWG.Trans.Map+( Trans (unTrans)+) where++import Prelude hiding (lookup)+import Data.Binary (Binary)+import qualified Data.Map as M++import Data.DAWG.Types+import qualified Data.DAWG.Trans as C++-- | A vector of distinct key/value pairs strictly ascending with respect+-- to key values.+newtype Trans = Trans { unTrans :: M.Map Sym ID }+ deriving (Show, Eq, Ord, Binary)++instance C.Trans Trans where+ empty = Trans M.empty+ {-# INLINE empty #-}++ lookup x = M.lookup x . unTrans+ {-# INLINE lookup #-}++ index x = M.lookupIndex x . unTrans+ {-# INLINE index #-}++ byIndex i (Trans m) =+ let n = M.size m+ in if i >= 0 && i < n+ then Just (M.elemAt i m)+ else Nothing+ {-# INLINE byIndex #-}++ insert x y (Trans m) = Trans (M.insert x y m)+ {-# INLINE insert #-}++ fromList = Trans . M.fromList+ {-# INLINE fromList #-}++ toList = M.toList . unTrans+ {-# INLINE toList #-}
+ Data/DAWG/Trans/Vector.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | A vector representation of a transition map. Memory efficient, but the+-- insert operation is /O(n)/ with respect to the number of transitions.+-- In particular, complexity of the insert operation can make the construction+-- of a large-alphabet dictionary intractable.++module Data.DAWG.Trans.Vector+( Trans (unTrans)+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>))+import Data.Binary (Binary)+import Data.Vector.Binary ()+import qualified Data.IntMap as M+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM++import Data.DAWG.Types+import Data.DAWG.Util+import qualified Data.DAWG.Trans as C++-- | A vector of distinct key/value pairs strictly ascending with respect+-- to key values.+newtype Trans = Trans { unTrans :: U.Vector (Sym, ID) }+ deriving (Show, Eq, Ord, Binary)++instance C.Trans Trans where+ empty = Trans U.empty+ {-# INLINE empty #-}++ lookup x m = do+ k <- C.index x m+ snd <$> C.byIndex k m+ {-# INLINE lookup #-}++ index x (Trans v)+ = either Just (const Nothing) $+ binarySearch (flip compare x . fst) v+ {-# INLINE index #-}++ byIndex k (Trans v) = v U.!? k+ {-# INLINE byIndex #-}++ insert x y (Trans v) = Trans $+ 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 #-}++ fromList = Trans . U.fromList . M.toAscList . M.fromList+ {-# INLINE fromList #-}++ toList = U.toList . unTrans+ {-# INLINE toList #-}
+ Data/DAWG/Types.hs view
@@ -0,0 +1,12 @@+-- | Basic types used throughout the library.++module Data.DAWG.Types+( ID+, Sym+) where++-- | Node identifier.+type ID = Int++-- | Internal representation of an alphabet element.+type Sym = Int
+ Data/DAWG/Util.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TupleSections #-}++-- | Utility functions.++module Data.DAWG.Util+( binarySearch+, findLastLE+, combine+) where++import Control.Applicative ((<$>))+import Data.Bits (shiftR, xor)+import Data.Vector.Unboxed (Unbox)+import qualified Control.Monad.ST as ST+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM++-- | 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+ search w+ where+ search w =+ loop 0 (UM.length w)+ where+ loop !l !u+ | u <= l = return (Right l)+ | otherwise = do+ let k = (u + l) `shiftR` 1+ x <- UM.unsafeRead w k+ case cmp x of+ LT -> loop (k+1) u+ EQ -> return (Left k)+ GT -> loop l k+{-# INLINE binarySearch #-}++-- | 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) -> U.Vector a -> Maybe (Int, a)+findLastLE cmp v =+ let k' = binarySearch cmp v+ k = either id (\x -> x-1) k'+ in (k,) <$> v U.!? k+{-# INLINE findLastLE #-}++-- | Combine two given hash values. 'combine' has zero as a left+-- identity.+combine :: Int -> Int -> Int+combine h1 h2 = (h1 * 16777619) `xor` h2+{-# INLINE combine #-}
− Data/DAWG/VMap.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- | A vector representation of 'M.Map'.--module Data.DAWG.VMap-( VMap (unVMap)-, empty-, lookup-, insert-, findLastLE-, fromList-, toList-) where--import Prelude hiding (lookup)-import Control.Applicative ((<$>))-import Data.Bits (shiftR)-import Data.Binary (Binary, put, get)-import Data.Vector.Binary ()-import Data.Vector.Unboxed (Unbox)-import qualified Control.Monad.ST as ST-import qualified Data.Map as M-import qualified Data.Vector.Unboxed as U-import qualified Data.Vector.Unboxed.Mutable as UM---- | A strictly ascending vector of distinct elements with respect--- to 'fst' values.-newtype VMap a = VMap { unVMap :: U.Vector (Int, a) }- deriving (Show, Eq, Ord)--instance (Binary a, Unbox a) => Binary (VMap a) where- put v = put (unVMap v)- get = VMap <$> get---- | Empty map.-empty :: Unbox a => VMap a-empty = VMap U.empty-{-# INLINE empty #-}---- | Lookup the symbol in the map.-lookup :: Unbox a => Int -> VMap a -> Maybe a-lookup x (VMap v) =- case binarySearch (flip compare x . fst) v of- Left k -> snd <$> v U.!? k- Right _ -> Nothing-{-# INLINE lookup #-}---- | 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) =- 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- search w- where- search w =- loop 0 (UM.length w)- where- loop !l !u- | u <= l = return (Right l)- | otherwise = do- let k = (u + l) `shiftR` 1- x <- UM.unsafeRead w k- case cmp x of- LT -> loop (k+1) u- EQ -> return (Left k)- GT -> loop l k-{-# INLINE binarySearch #-}---- | Smart 'VMap' constructor which ensures that the underlying vector is--- strictly ascending with respect to 'fst' values.-fromList :: Unbox a => [(Int, a)] -> VMap a-fromList = VMap . U.fromList . M.toAscList . M.fromList-{-# INLINE fromList #-}---- | Convert the 'VMap' to a list of ascending symbol/value pairs.-toList :: Unbox a => VMap a -> [(Int, a)]-toList = U.toList . unVMap-{-# INLINE toList #-}
dawg.cabal view
@@ -1,5 +1,5 @@ name: dawg-version: 0.7.1+version: 0.8 synopsis: Directed acyclic word graphs description: The library implements /directed acyclic word graphs/ (DAWGs) internaly@@ -9,6 +9,8 @@ can be used to build the automaton on-the-fly. The automaton from the "Data.DAWG.Static" module has lower memory footprint and provides static hashing functionality.+ Both automata versions work in combination with different implementations+ of transition maps provided by the "Data.DAWG.Trans" modules' hierarchy. license: BSD3 license-file: LICENSE cabal-version: >= 1.6@@ -31,13 +33,21 @@ exposed-modules: Data.DAWG- , Data.DAWG.Node- , Data.DAWG.Node.Specialized+ , Data.DAWG.Types , Data.DAWG.Static+ , Data.DAWG.Trans+ , Data.DAWG.Trans.Vector+ , Data.DAWG.Trans.Map++ other-modules:+ Data.DAWG.Node+ , Data.DAWG.Graph , Data.DAWG.Internal- , Data.DAWG.VMap+ , Data.DAWG.Util+ , Data.DAWG.HashMap+ , Data.DAWG.Trans.Hashed - ghc-options: -Wall -O2+ ghc-options: -Wall -O2 -auto source-repository head type: git