dawg 0.9 → 0.10

raw patch · 27 files changed

+1418/−1303 lines, 27 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

- Data.DAWG.Static: hash :: Enum a => [a] -> DAWG a Weight c -> Maybe Int

- Data.DAWG.Static: unHash :: Enum a => Int -> DAWG a Weight c -> Maybe [a]

+ Data.DAWG.Static: size :: DAWG a Weight c -> Int

+ Data.DAWG.Static: submap :: (Enum a, Unbox b) => [a] -> DAWG a b c -> DAWG a b c

Files

Data/DAWG/Dynamic.hs +0/−238
Data/DAWG/Dynamic/Internal.hs +0/−27
Data/DAWG/Dynamic/Node.hs +0/−80
Data/DAWG/Graph.hs +0/−213
Data/DAWG/HashMap.hs +0/−110
Data/DAWG/Static.hs +0/−274
Data/DAWG/Static/Node.hs +0/−98
Data/DAWG/Trans.hs +0/−26
Data/DAWG/Trans/Hashed.hs +0/−63
Data/DAWG/Trans/Map.hs +0/−45
Data/DAWG/Trans/Vector.hs +0/−58
Data/DAWG/Types.hs +0/−12
Data/DAWG/Util.hs +0/−58
dawg.cabal +3/−1
src/Data/DAWG/Dynamic.hs +275/−0
src/Data/DAWG/Dynamic/Internal.hs +27/−0
src/Data/DAWG/Dynamic/Node.hs +80/−0
src/Data/DAWG/Graph.hs +213/−0
src/Data/DAWG/HashMap.hs +110/−0
src/Data/DAWG/Static.hs +350/−0
src/Data/DAWG/Static/Node.hs +98/−0
src/Data/DAWG/Trans.hs +26/−0
src/Data/DAWG/Trans/Hashed.hs +63/−0
src/Data/DAWG/Trans/Map.hs +45/−0
src/Data/DAWG/Trans/Vector.hs +58/−0
src/Data/DAWG/Types.hs +12/−0
src/Data/DAWG/Util.hs +58/−0

− Data/DAWG/Dynamic.hs

@@ -1,238 +0,0 @@--- | 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.Dynamic-(--- * DAWG type-  DAWG--- * Query-, numStates-, numEdges-, lookup--- * Construction-, empty-, fromList-, fromListWith-, fromLang--- ** Insertion-, insert-, insertWith--- ** Deletion-, delete--- * Conversion-, assocs-, keys-, elems-) where--import Prelude hiding (lookup)-import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first)-import Data.List (foldl')-import qualified Control.Monad.State.Strict as S--import Data.DAWG.Types-import Data.DAWG.Graph (Graph)-import Data.DAWG.Dynamic.Internal-import qualified Data.DAWG.Trans as T-import qualified Data.DAWG.Graph as G-import qualified Data.DAWG.Dynamic.Node as N--type GraphM a b = S.State (Graph (N.Node a)) b--mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a)-mkState f g = ((), f g)---- | Return node with the given identifier.-nodeBy :: ID -> GraphM a (N.Node a)-nodeBy i = G.nodeBy i <$> S.get---- Evaluate the 'G.insert' function within the monad.-insertNode :: Ord a => N.Node a -> GraphM a ID-insertNode = S.state . G.insert---- | 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 T.empty)---- Evaluate the 'G.delete' function within the monad.-deleteNode :: Ord a => N.Node a -> GraphM a ()-deleteNode = S.state . mkState . G.delete---- | Invariant: the identifier points to the 'Branch' node.-insertM :: Ord a => [Sym] -> a -> ID -> GraphM 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-    :: Ord a => (a -> a -> a)-    -> [Sym] -> a -> ID -> GraphM 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 :: Ord a => [Sym] -> ID -> GraphM 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 :: [Sym] -> 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 N.onSym x n of-        Just j  -> lookupM xs j-        Nothing -> return Nothing--assocsAcc :: Graph (N.Node a) -> ID -> [([Sym], a)]-assocsAcc g i =-    here w ++ concatMap there (N.edges n)-  where-    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)---- | Empty DAWG.-empty :: Ord b => DAWG a b-empty = -    let (i, g) = S.runState insertLeaf G.empty-    in  DAWG g i---- | Number of states in the automaton.-numStates :: DAWG a b -> Int-numStates = G.size . graph---- | Number of edges in the automaton.-numEdges :: DAWG a b -> Int-numEdges = sum . map (length . N.edges) . G.nodes . 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, Ord b) => [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 :: Ord b => String -> DAWG Char b -> Maybe b #-}---- | Return all key/value pairs in the DAWG in ascending key order.-assocs :: (Enum a, Ord b) => DAWG a b -> [([a], b)]-assocs-    = map (first (map toEnum))-    . (assocsAcc <$> graph <*> root)-{-# SPECIALIZE assocs :: Ord b => DAWG Char b -> [(String, b)] #-}---- | Return all keys of the DAWG in ascending order.-keys :: (Enum a, Ord b) => DAWG a b -> [[a]]-keys = map fst . assocs-{-# SPECIALIZE keys :: Ord b => DAWG Char b -> [String] #-}---- | Return all elements of the DAWG in the ascending order of their keys.-elems :: Ord b => 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 () #-}

− Data/DAWG/Dynamic/Internal.hs

@@ -1,27 +0,0 @@--- | The module exports internal representation of dynamic DAWG.--module Data.DAWG.Dynamic.Internal-(--- * DAWG type-  DAWG (..)-) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, put, get)--import Data.DAWG.Types-import Data.DAWG.Graph (Graph)-import qualified Data.DAWG.Dynamic.Node as N---- | A directed acyclic word graph with phantom type @a@ representing--- type of alphabet elements.-data DAWG a b = DAWG-    { graph :: !(Graph (N.Node 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

− Data/DAWG/Dynamic/Node.hs

@@ -1,80 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Internal representation of dynamic automata nodes.--module Data.DAWG.Dynamic.Node-( Node(..)-, onSym-, edges-, children-, insert-) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, Get, put, get)--import Data.DAWG.Types-import Data.DAWG.Util (combine)-import Data.DAWG.HashMap (Hash, hash)-import Data.DAWG.Trans.Map (Trans)-import qualified Data.DAWG.Trans as T-import qualified Data.DAWG.Trans.Hashed as H---- | 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-        -- | Transition map (outgoing edges).-        , transMap  :: !(H.Hashed Trans) }-    | Leaf { value  :: !(Maybe a) }-    deriving (Show, Eq, Ord)--instance Ord a => Hash (Node a) where-    hash Branch{..} = combine eps (H.hash transMap)-    hash Leaf{..}   = case value of-    	Just _	-> (-1)-	Nothing	-> (-2)--instance Binary a => Binary (Node a) where-    put Branch{..} = put (1 :: Int) >> put eps >> put transMap-    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 _ t)    = T.lookup x t-onSym _ (Leaf _)        = Nothing-{-# INLINE onSym #-}---- | List of symbol/edge pairs outgoing from the node.-edges :: Node a -> [(Sym, ID)]-edges (Branch _ t)  = T.toList t-edges (Leaf _)      = []-{-# INLINE edges #-}---- | List of children identifiers.-children :: Node a -> [ID]-children = map snd . edges-{-# INLINE children #-}---- | Substitue edge determined by a given symbol.-insert :: Sym -> ID -> Node a -> Node a-insert x i (Branch w t) = Branch w (T.insert x i t)-insert _ _ l            = l-{-# INLINE insert #-}

− Data/DAWG/Graph.hs

@@ -1,213 +0,0 @@-{-# 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-, nodes-, 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---- | List of graph nodes.-nodes :: Graph n -> [n]-nodes = M.elems . nodeMap---- | 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

@@ -1,110 +0,0 @@-{-# 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/Static.hs

@@ -1,274 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | The module implements /directed acyclic word graphs/ (DAWGs) internaly--- represented as /minimal acyclic deterministic finite-state automata/.------ In comparison to "Data.DAWG.Dynamic" module the automaton implemented here:------   * Keeps all nodes in one array and therefore uses less memory,------   * When 'weigh'ed, it can be used to perform static hashing with---     'hash' and 'unHash' functions,------   * Doesn't provide insert/delete family of operations.--module Data.DAWG.Static-(--- * DAWG type-  DAWG--- * Query-, lookup-, numStates-, numEdges--- * Index-, index-, byIndex--- * Hash-, hash-, unHash--- * Construction-, empty-, fromList-, fromListWith-, fromLang-, freeze--- * Weight-, Weight-, weigh--- * Conversion-, assocs-, keys-, elems--- , thaw-) where--import Prelude hiding (lookup)-import Control.Applicative ((<$), (<$>), (<|>))-import Control.Arrow (first)-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.Types-import qualified Data.DAWG.Util as Util-import qualified Data.DAWG.Trans as T-import qualified Data.DAWG.Static.Node as N-import qualified Data.DAWG.Graph as G-import qualified Data.DAWG.Dynamic as D-import qualified Data.DAWG.Dynamic.Internal as D---- | @DAWG a b c@ constitutes an automaton with alphabet symbols of type /a/,--- transition labels of type /b/ and node values of type /Maybe c/.--- All nodes are stored in a 'V.Vector' with positions of nodes corresponding--- to their 'ID's.-newtype DAWG a b c = DAWG { unDAWG :: V.Vector (N.Node b c) }-    deriving (Show, Eq, Ord)--instance (Binary b, Binary c, Unbox b) => Binary (DAWG a b c) where-    put = put . unDAWG-    get = DAWG <$> get---- | Empty DAWG.-empty :: Unbox b => DAWG a b c-empty = DAWG $ V.fromList-    [ N.Branch 1 T.empty U.empty-    , N.Leaf Nothing ]---- | Number of states in the automaton.-numStates :: DAWG a b c -> Int-numStates = V.length . unDAWG---- | Number of edges in the automaton.-numEdges :: DAWG a b c -> Int-numEdges = sum . map (length . N.edges) . V.toList . unDAWG---- | Node with the given identifier.-nodeBy :: ID -> DAWG a b c -> N.Node b c-nodeBy i d = unDAWG d V.! i---- | Value in leaf node with a given ID.-leafValue :: N.Node b c -> DAWG a b c -> Maybe c-leafValue n = N.value . nodeBy (N.eps n)---- | Find value associated with the key.-lookup :: (Enum a, Unbox b) => [a] -> DAWG a b c -> Maybe c-lookup xs' =-    let xs = map fromEnum xs'-    in  lookup'I xs 0-{-# SPECIALIZE lookup :: Unbox b => String -> DAWG Char b c -> Maybe c #-}--lookup'I :: Unbox b => [Sym] -> ID -> DAWG a b c -> Maybe c-lookup'I []     i d = leafValue (nodeBy i d) 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 b) => DAWG a b c -> [([a], c)]-assocs d = map (first (map toEnum)) (assocs'I 0 d)-{-# SPECIALIZE assocs :: Unbox b => DAWG Char b c -> [(String, c)] #-}--assocs'I :: Unbox b => ID -> DAWG a b c -> [([Sym], c)]-assocs'I i d =-    here ++ concatMap there (N.edges n)-  where-    n = nodeBy i d-    here = case leafValue n d of-        Just x  -> [([], x)]-        Nothing -> []-    there (x, j) = map (first (x:)) (assocs'I j d)---- | Return all keys of the DAWG in ascending order.-keys :: (Enum a, Unbox b) => DAWG a b c -> [[a]]-keys = map fst . assocs-{-# SPECIALIZE keys :: Unbox b => DAWG Char b c -> [String] #-}---- | Return all elements of the DAWG in the ascending order of their keys.-elems :: Unbox b => DAWG 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 = freeze . D.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. 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 f = freeze . D.fromListWith f-{-# 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.  First a 'D.DAWG' is created and then it is frozen--- using the 'freeze' function.-fromLang :: Enum a => [[a]] -> DAWG a () ()-fromLang = freeze . D.fromLang-{-# SPECIALIZE fromLang :: [String] -> DAWG 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--- of preceding nodes outgoing from the same parent node.-type Weight = Int---- | Compute node weights and store corresponding values in transition labels.-weigh :: DAWG a b c -> DAWG a Weight c-weigh d = (DAWG . V.fromList)-    [ branch n ws-    | i <- [0 .. numStates d - 1]-    , let n  = nodeBy i d-    , let ws = accum (N.children n) ]-  where-    -- 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-        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 = N.eps n : N.children n---- | Construct immutable version of the automaton.-freeze :: D.DAWG a b -> DAWG a () b-freeze d = DAWG . V.fromList $-    map (N.fromDyn 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 . G.nodeMap . D.graph-    -- Non-frozen node by given identifier.-    oldBy i = G.nodeBy i (D.graph d)-        --- | Inverse of the map.-inverse :: M.IntMap Int -> M.IntMap Int-inverse =-    let swap (x, y) = (y, x)-    in  M.fromList . map swap . M.toList---- -- | Yield mutable version of the automaton.--- thaw :: (Unbox b, Ord a) => DAWG a b c -> D.DAWG a b--- thaw d =---     D.fromNodes nodes 0---   where---     -- 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.-index :: Enum a => [a] -> DAWG a Weight c -> Maybe Int-index xs = index'I (map fromEnum xs) 0-{-# SPECIALIZE index :: String -> DAWG Char Weight c -> Maybe Int #-}--index'I :: [Sym] -> ID -> DAWG 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-        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 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 Weight c -> Maybe [a]-byIndex ix d = map toEnum <$> byIndex'I ix 0 d-{-# SPECIALIZE byIndex :: Int -> DAWG Char Weight c -> Maybe String #-}--byIndex'I :: Int -> ID -> DAWG a Weight c -> Maybe [Sym]-byIndex'I ix i d-    | ix < 0    = Nothing-    | otherwise = here <|> there-  where-    n = nodeBy i d-    u = maybe 0 (const 1) (leafValue n d)-    here-        | ix == 0   = [] <$ leafValue (nodeBy i d) d-        | otherwise = Nothing-    there = do-        (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 w = compare w (ix - u)---- | Inverse of the 'hash' function and a synonym for the 'byIndex' function.-unHash :: Enum a => Int -> DAWG a Weight c -> Maybe [a]-unHash = byIndex-{-# INLINE unHash #-}

− Data/DAWG/Static/Node.hs

@@ -1,98 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Internal representation of static automata nodes.--module Data.DAWG.Static.Node-( Node(..)-, onSym-, onSym'-, edges-, children-, insert-, fromDyn-) where--import Control.Arrow (second)-import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, Get, put, get)-import Data.Vector.Binary ()-import qualified Data.Vector.Unboxed as U--import Data.DAWG.Types-import Data.DAWG.Trans.Vector (Trans)-import qualified Data.DAWG.Trans as T-import qualified Data.DAWG.Dynamic.Node as D---- | 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-        -- | Transition map (outgoing edges).-        , transMap  :: !Trans-        -- | Labels corresponding to individual edges.-        , labelVect :: !(U.Vector a) }-    | Leaf { value  :: !(Maybe b) }-    deriving (Show, Eq, Ord)--instance (U.Unbox a, Binary a, Binary b) => Binary (Node 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 <*> get-            _ -> Leaf <$> get---- | Transition function.-onSym :: Sym -> Node a b -> Maybe ID-onSym x (Branch _ t _)  = T.lookup x t-onSym _ (Leaf _)        = Nothing-{-# INLINE onSym #-}---- | Transition function.-onSym' :: U.Unbox a => Sym -> Node 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 symbol/edge pairs outgoing from the node.-edges :: Node a b -> [(Sym, ID)]-edges (Branch _ t _)    = T.toList t-edges (Leaf _)          = []-{-# INLINE edges #-}---- | List of children identifiers.-children :: Node a b -> [ID]-children = map snd . edges-{-# INLINE children #-}---- | Substitue edge determined by a given symbol.-insert :: Sym -> ID -> Node a b -> Node a b-insert x i (Branch w t ls)  = Branch w (T.insert x i t) ls-insert _ _ l                = l-{-# INLINE insert #-}---- | Make "static" node from a "dynamic" node.-fromDyn-    :: (ID -> ID)   -- ^ Assign new IDs -    -> D.Node b     -- ^ "Dynamic" node-    -> Node () b    -- ^ "Static" node-fromDyn _ (D.Leaf x)        = Leaf x-fromDyn f (D.Branch e t)    =-    let reTrans = T.fromList . map (second f) . T.toList-    in  Branch (f e) (reTrans t) U.empty

− Data/DAWG/Trans.hs

@@ -1,26 +0,0 @@--- | 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

@@ -1,63 +0,0 @@-{-# 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

@@ -1,45 +0,0 @@-{-# 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

@@ -1,58 +0,0 @@-{-# 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

@@ -1,12 +0,0 @@--- | 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

@@ -1,58 +0,0 @@-{-# 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 #-}

dawg.cabal view

@@ -1,5 +1,5 @@ name:               dawg-version:            0.9+version:            0.10 synopsis:           Directed acyclic word graphs description:     The library implements /directed acyclic word graphs/ (DAWGs) internaly@@ -21,6 +21,7 @@ build-type:         Simple  library+    hs-source-dirs: src     build-depends:         base >= 4 && < 5       , containers >= 0.4.1 && < 0.6@@ -28,6 +29,7 @@       , vector       , vector-binary       , mtl+      , transformers      exposed-modules:         Data.DAWG.Dynamic

+ src/Data/DAWG/Dynamic.hs view

@@ -0,0 +1,275 @@+{-# LANGUAGE RecordWildCards #-}+++-- | 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.Dynamic+(+-- * DAWG type+  DAWG++-- * Query+, lookup+, numStates+, numEdges++-- * Construction+, empty+, fromList+, fromListWith+, fromLang+-- ** Insertion+, insert+, insertWith+-- ** Deletion+, delete++-- * Conversion+, assocs+, keys+, elems+) where+++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first)+import Data.List (foldl')+import qualified Control.Monad.State.Strict as S+import           Control.Monad.Trans.Maybe+import           Control.Monad.Trans.Class++import Data.DAWG.Types+import Data.DAWG.Graph (Graph)+import Data.DAWG.Dynamic.Internal+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Graph as G+import qualified Data.DAWG.Dynamic.Node as N+++type GraphM a = S.State (Graph (N.Node a))++mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a)+mkState f g = ((), f g)++-- | Return node with the given identifier.+nodeBy :: ID -> GraphM a (N.Node a)+nodeBy i = G.nodeBy i <$> S.get++-- Evaluate the 'G.insert' function within the monad.+insertNode :: Ord a => N.Node a -> GraphM a ID+insertNode = S.state . G.insert++-- | 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 T.empty)++-- Evaluate the 'G.delete' function within the monad.+deleteNode :: Ord a => N.Node a -> GraphM a ()+deleteNode = S.state . mkState . G.delete++-- | Invariant: the identifier points to the 'Branch' node.+insertM :: Ord a => [Sym] -> a -> ID -> GraphM 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+    :: Ord a => (a -> a -> a)+    -> [Sym] -> a -> ID -> GraphM 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 :: Ord a => [Sym] -> ID -> GraphM 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 })++-- | Follow the path from the given identifier.+follow :: [Sym] -> ID -> MaybeT (GraphM a) ID+follow (x:xs) i = do+    n <- lift $ nodeBy i+    j <- liftMaybe $ N.onSym x n+    follow xs j+follow [] i = return i+    +lookupM :: [Sym] -> ID -> GraphM a (Maybe a)+lookupM xs i = runMaybeT $ do+    j <- follow xs i+    k <- lift $ N.eps <$> nodeBy j+    MaybeT $ N.value <$> nodeBy k++-- | Return all (key, value) pairs in ascending key order in the+-- sub-DAWG determined by the given node ID.+subPairs :: Graph (N.Node a) -> ID -> [([Sym], a)]+subPairs g i =+    here w ++ concatMap there (N.edges n)+  where+    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:)) (subPairs g j)++-- | Empty DAWG.+empty :: Ord b => DAWG a b+empty = +    let (i, g) = S.runState insertLeaf G.empty+    in  DAWG g i++-- | Number of states in the automaton.+numStates :: DAWG a b -> Int+numStates = G.size . graph++-- | Number of edges in the automaton.+numEdges :: DAWG a b -> Int+numEdges = sum . map (length . N.edges) . G.nodes . 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 #-}++-- | 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, Ord b) => [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 :: Ord b => String -> DAWG Char b -> Maybe b #-}++-- -- | Find all (key, value) pairs such that key is prefixed+-- -- with the given string.+-- withPrefix :: (Enum a, Ord b) => [a] -> DAWG a b -> [([a], b)]+-- withPrefix xs DAWG{..}+--     = map (first $ (xs ++) . map toEnum)+--     $ maybe [] (subPairs graph)+--     $ flip S.evalState graph $ runMaybeT+--     $ follow (map fromEnum xs) root+-- {-# SPECIALIZE withPrefix+--     :: Ord b => String -> DAWG Char b+--     -> [(String, b)] #-}++-- | Return all key/value pairs in the DAWG in ascending key order.+assocs :: (Enum a, Ord b) => DAWG a b -> [([a], b)]+assocs+    = map (first (map toEnum))+    . (subPairs <$> graph <*> root)+{-# SPECIALIZE assocs :: Ord b => DAWG Char b -> [(String, b)] #-}++-- | Return all keys of the DAWG in ascending order.+keys :: (Enum a, Ord b) => DAWG a b -> [[a]]+keys = map fst . assocs+{-# SPECIALIZE keys :: Ord b => DAWG Char b -> [String] #-}++-- | Return all elements of the DAWG in the ascending order of their keys.+elems :: Ord b => DAWG a b -> [b]+elems = map snd . (subPairs <$> 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 #-}++-- | 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 () #-}+++----------------+-- Misc+----------------+++liftMaybe :: Monad m => Maybe a -> MaybeT m a+liftMaybe = MaybeT . return+{-# INLINE liftMaybe #-}

+ src/Data/DAWG/Dynamic/Internal.hs view

@@ -0,0 +1,27 @@+-- | The module exports internal representation of dynamic DAWG.++module Data.DAWG.Dynamic.Internal+(+-- * DAWG type+  DAWG (..)+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, put, get)++import Data.DAWG.Types+import Data.DAWG.Graph (Graph)+import qualified Data.DAWG.Dynamic.Node as N++-- | A directed acyclic word graph with phantom type @a@ representing+-- type of alphabet elements.+data DAWG a b = DAWG+    { graph :: !(Graph (N.Node 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

+ src/Data/DAWG/Dynamic/Node.hs view

@@ -0,0 +1,80 @@+{-# LANGUAGE RecordWildCards #-}++-- | Internal representation of dynamic automata nodes.++module Data.DAWG.Dynamic.Node+( Node(..)+, onSym+, edges+, children+, insert+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, Get, put, get)++import Data.DAWG.Types+import Data.DAWG.Util (combine)+import Data.DAWG.HashMap (Hash, hash)+import Data.DAWG.Trans.Map (Trans)+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Trans.Hashed as H++-- | 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+        -- | Transition map (outgoing edges).+        , transMap  :: !(H.Hashed Trans) }+    | Leaf { value  :: !(Maybe a) }+    deriving (Show, Eq, Ord)++instance Ord a => Hash (Node a) where+    hash Branch{..} = combine eps (H.hash transMap)+    hash Leaf{..}   = case value of+    	Just _	-> (-1)+	Nothing	-> (-2)++instance Binary a => Binary (Node a) where+    put Branch{..} = put (1 :: Int) >> put eps >> put transMap+    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 _ t)    = T.lookup x t+onSym _ (Leaf _)        = Nothing+{-# INLINE onSym #-}++-- | List of symbol/edge pairs outgoing from the node.+edges :: Node a -> [(Sym, ID)]+edges (Branch _ t)  = T.toList t+edges (Leaf _)      = []+{-# INLINE edges #-}++-- | List of children identifiers.+children :: Node a -> [ID]+children = map snd . edges+{-# INLINE children #-}++-- | Substitue edge determined by a given symbol.+insert :: Sym -> ID -> Node a -> Node a+insert x i (Branch w t) = Branch w (T.insert x i t)+insert _ _ l            = l+{-# INLINE insert #-}

+ src/Data/DAWG/Graph.hs view

@@ -0,0 +1,213 @@+{-# 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+, nodes+, 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++-- | List of graph nodes.+nodes :: Graph n -> [n]+nodes = M.elems . nodeMap++-- | 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)

+ src/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

+ src/Data/DAWG/Static.hs view

@@ -0,0 +1,350 @@+{-# LANGUAGE RecordWildCards #-}+++-- | The module implements /directed acyclic word graphs/ (DAWGs) internaly+-- represented as /minimal acyclic deterministic finite-state automata/.+--+-- In comparison to "Data.DAWG.Dynamic" module the automaton implemented here:+--+--   * Keeps all nodes in one array and therefore uses less memory,+--+--   * When 'weigh'ed, it can be used to perform static hashing with+--     'index' and 'byIndex' functions,+--+--   * Doesn't provide insert/delete family of operations.+++module Data.DAWG.Static+(+-- * DAWG type+  DAWG++-- * Query+, lookup+, submap+, numStates+, numEdges++-- * Weight+, Weight+, weigh+, size+, index+, byIndex++-- * Construction+, empty+, fromList+, fromListWith+, fromLang++-- * Conversion+, assocs+, keys+, elems+, freeze+-- , thaw+) where+++import Prelude hiding (lookup)+import Control.Applicative ((<$), (<$>), (<*>), (<|>))+import Control.Arrow (first)+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.Types+import qualified Data.DAWG.Util as Util+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Static.Node as N+import qualified Data.DAWG.Graph as G+import qualified Data.DAWG.Dynamic as D+import qualified Data.DAWG.Dynamic.Internal as D+++-- | @DAWG a b c@ constitutes an automaton with alphabet symbols of type /a/,+-- transition labels of type /b/ and node values of type /Maybe c/.+-- All nodes are stored in a 'V.Vector' with positions of nodes corresponding+-- to their 'ID's.+--+data DAWG a b c = DAWG+    { unDAWG :: V.Vector (N.Node b c)+    -- | The actual DAWG root has the 0 ID.  Thanks to the 'root' attribute,+    -- we can represent a submap of the DAWG.+    , root   :: ID+    } deriving (Show, Eq, Ord)++instance (Binary b, Binary c, Unbox b) => Binary (DAWG a b c) where+    put DAWG{..} = put unDAWG >> put root+    get = DAWG <$> get <*> get+++-- | Empty DAWG.+empty :: Unbox b => DAWG a b c+empty = flip DAWG 0 $ V.fromList+    [ N.Branch 1 T.empty U.empty+    , N.Leaf Nothing ]+++-- | Return the sub-DAWG containing all keys beginning with a prefix.+-- The in-memory representation of the resultant DAWG is the same as of+-- the original one, only the pointer to the DAWG root will be different.+submap :: (Enum a, Unbox b) => [a] -> DAWG a b c -> DAWG a b c+submap xs d = case follow (map fromEnum xs) (root d) d of+    Just i  -> DAWG (unDAWG d) i +    Nothing -> empty+{-# SPECIALIZE submap :: Unbox b => String -> DAWG Char b c -> DAWG Char b c #-}+++-- | Number of states in the automaton.+-- TODO: The function ignores the `root` value, it won't work properly+-- after using the `submap` function.+numStates :: DAWG a b c -> Int+numStates = V.length . unDAWG+++-- | Number of edges in the automaton.+-- TODO: The function ignores the `root` value, it won't work properly+-- after using the `submap` function.+numEdges :: DAWG a b c -> Int+numEdges = sum . map (length . N.edges) . V.toList . unDAWG+++-- | Node with the given identifier.+nodeBy :: ID -> DAWG a b c -> N.Node b c+nodeBy i d = unDAWG d V.! i+++-- | Value in leaf node with a given ID.+leafValue :: N.Node b c -> DAWG a b c -> Maybe c+leafValue n = N.value . nodeBy (N.eps n)+++-- | Follow the path from the given identifier.+follow :: Unbox b => [Sym] -> ID -> DAWG a b c -> Maybe ID+follow (x:xs) i d = do+    j <- N.onSym x (nodeBy i d)+    follow xs j d+follow [] i _ = Just i+++-- | Find value associated with the key.+lookup :: (Enum a, Unbox b) => [a] -> DAWG a b c -> Maybe c+lookup xs d = lookup'I (map fromEnum xs) (root d) d+{-# SPECIALIZE lookup :: Unbox b => String -> DAWG Char b c -> Maybe c #-}+++lookup'I :: Unbox b => [Sym] -> ID -> DAWG a b c -> Maybe c+lookup'I xs i d = do+    j <- follow xs i d+    leafValue (nodeBy j d) d+++-- -- | Find all (key, value) pairs such that key is prefixed+-- -- with the given string.+-- withPrefix :: (Enum a, Unbox b) => [a] -> DAWG a b c -> [([a], c)]+-- withPrefix xs d = maybe [] id $ do+--     i <- follow (map fromEnum xs) 0 d+--     let prepare = (xs ++) . map toEnum+--     return $ map (first prepare) (subPairs i d)+-- {-# SPECIALIZE withPrefix+--     :: Unbox b => String -> DAWG Char b c+--     -> [(String, c)] #-}+++-- | Return all (key, value) pairs in ascending key order in the+-- sub-DAWG determined by the given node ID.+subPairs :: Unbox b => ID -> DAWG a b c -> [([Sym], c)]+subPairs i d =+    here ++ concatMap there (N.edges n)+  where+    n = nodeBy i d+    here = case leafValue n d of+        Just x  -> [([], x)]+        Nothing -> []+    there (x, j) = map (first (x:)) (subPairs j d)+++-- | Return all (key, value) pairs in the DAWG in ascending key order.+assocs :: (Enum a, Unbox b) => DAWG a b c -> [([a], c)]+assocs d = map (first (map toEnum)) (subPairs (root d) d)+{-# SPECIALIZE assocs :: Unbox b => DAWG Char b c -> [(String, c)] #-}+++-- | Return all keys of the DAWG in ascending order.+keys :: (Enum a, Unbox b) => DAWG a b c -> [[a]]+keys = map fst . assocs+{-# SPECIALIZE keys :: Unbox b => DAWG Char b c -> [String] #-}+++-- | Return all elements of the DAWG in the ascending order of their keys.+elems :: Unbox b => DAWG a b c -> [c]+elems d = map snd $ subPairs (root d) d+++-- | 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 = freeze . D.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. 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 f = freeze . D.fromListWith f+{-# 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.  First a 'D.DAWG' is created and then it is frozen+-- using the 'freeze' function.+fromLang :: Enum a => [[a]] -> DAWG a () ()+fromLang = freeze . D.fromLang+{-# SPECIALIZE fromLang :: [String] -> DAWG 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+-- of preceding nodes outgoing from the same parent node.+type Weight = Int+++-- | Compute node weights and store corresponding values in transition labels.+-- Be aware, that the entire DAWG will be weighted, even when (because of the use of+-- the `submap` function) only a part of the DAWG is currently selected.+weigh :: DAWG a b c -> DAWG a Weight c+weigh d = flip DAWG (root d) $ V.fromList+    [ branch n ws+    | i <- [0 .. numStates d - 1]+    , let n  = nodeBy i d+    , let ws = accum (N.children n) ]+  where+    -- 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+        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 = N.eps n : N.children n+++-- | Construct immutable version of the automaton.+freeze :: D.DAWG a b -> DAWG a () b+freeze d = flip DAWG 0 . V.fromList $+    map (N.fromDyn newID . oldBy)+        (M.elems (inverse old2new))+  where+    -- Map from old to new identifiers.  The root identifier is mapped to 0.+    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 . G.nodeMap . D.graph+    -- Non-frozen node by given identifier.+    oldBy i = G.nodeBy i (D.graph d)+        ++-- | Inverse of the map.+inverse :: M.IntMap Int -> M.IntMap Int+inverse =+    let swap (x, y) = (y, x)+    in  M.fromList . map swap . M.toList+++-- -- | Yield mutable version of the automaton.+-- thaw :: (Unbox b, Ord a) => DAWG a b c -> D.DAWG a b+-- thaw d =+--     D.fromNodes nodes 0+--   where+--     -- 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+++-- | A number of distinct (key, value) pairs in the weighted DAWG.+size :: DAWG a Weight c -> Int+size d = size'I (root d) d+++size'I :: ID -> DAWG a Weight c -> Int+size'I i d = add $ do+    x <- case N.edges n of+        [] -> Nothing+        xs -> Just (fst $ last xs)+    (j, v) <- N.onSym' x n+    return $ v + size'I j d+  where+    n = nodeBy i d+    u = maybe 0 (const 1) (leafValue n d)+    add m = u + maybe 0 id m+++-- | Position in a set of all dictionary entries with respect+-- to the lexicographic order.+index :: Enum a => [a] -> DAWG a Weight c -> Maybe Int+index xs d = index'I (map fromEnum xs) (root d) d+{-# SPECIALIZE index :: String -> DAWG Char Weight c -> Maybe Int #-}+++index'I :: [Sym] -> ID -> DAWG 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+        u = maybe 0 (const 1) (leafValue n d)+    (j, v) <- N.onSym' x n+    w <- index'I xs j d+    return (u + v + w)+++-- | Find dictionary entry given its index with respect to the+-- lexicographic order.+byIndex :: Enum a => Int -> DAWG a Weight c -> Maybe [a]+byIndex ix d = map toEnum <$> byIndex'I ix (root d) d+{-# SPECIALIZE byIndex :: Int -> DAWG Char Weight c -> Maybe String #-}+++byIndex'I :: Int -> ID -> DAWG a Weight c -> Maybe [Sym]+byIndex'I ix i d+    | ix < 0    = Nothing+    | otherwise = here <|> there+  where+    n = nodeBy i d+    u = maybe 0 (const 1) (leafValue n d)+    here+        | ix == 0   = [] <$ leafValue (nodeBy i d) d+        | otherwise = Nothing+    there = do+        (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 w = compare w (ix - u)

+ src/Data/DAWG/Static/Node.hs view

@@ -0,0 +1,98 @@+{-# LANGUAGE RecordWildCards #-}++-- | Internal representation of static automata nodes.++module Data.DAWG.Static.Node+( Node(..)+, onSym+, onSym'+, edges+, children+, insert+, fromDyn+) where++import Control.Arrow (second)+import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, Get, put, get)+import Data.Vector.Binary ()+import qualified Data.Vector.Unboxed as U++import Data.DAWG.Types+import Data.DAWG.Trans.Vector (Trans)+import qualified Data.DAWG.Trans as T+import qualified Data.DAWG.Dynamic.Node as D++-- | 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+        -- | Transition map (outgoing edges).+        , transMap  :: !Trans+        -- | Labels corresponding to individual edges.+        , labelVect :: !(U.Vector a) }+    | Leaf { value  :: !(Maybe b) }+    deriving (Show, Eq, Ord)++instance (U.Unbox a, Binary a, Binary b) => Binary (Node 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 <*> get+            _ -> Leaf <$> get++-- | Transition function.+onSym :: Sym -> Node a b -> Maybe ID+onSym x (Branch _ t _)  = T.lookup x t+onSym _ (Leaf _)        = Nothing+{-# INLINE onSym #-}++-- | Transition function.+onSym' :: U.Unbox a => Sym -> Node 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 symbol/edge pairs outgoing from the node.+edges :: Node a b -> [(Sym, ID)]+edges (Branch _ t _)    = T.toList t+edges (Leaf _)          = []+{-# INLINE edges #-}++-- | List of children identifiers.+children :: Node a b -> [ID]+children = map snd . edges+{-# INLINE children #-}++-- | Substitue edge determined by a given symbol.+insert :: Sym -> ID -> Node a b -> Node a b+insert x i (Branch w t ls)  = Branch w (T.insert x i t) ls+insert _ _ l                = l+{-# INLINE insert #-}++-- | Make "static" node from a "dynamic" node.+fromDyn+    :: (ID -> ID)   -- ^ Assign new IDs +    -> D.Node b     -- ^ "Dynamic" node+    -> Node () b    -- ^ "Static" node+fromDyn _ (D.Leaf x)        = Leaf x+fromDyn f (D.Branch e t)    =+    let reTrans = T.fromList . map (second f) . T.toList+    in  Branch (f e) (reTrans t) U.empty

+ src/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)]

+ src/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)

+ src/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 #-}

+ src/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 #-}

+ src/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

+ src/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 #-}