packages feed

dawg-ord (empty) → 0.2

raw patch · 15 files changed

+1343/−0 lines, 15 filesdep +basedep +binarydep +containerssetup-changed

Dependencies added: base, binary, containers, mtl, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, IPI PAN+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ dawg-ord.cabal view
@@ -0,0 +1,57 @@+name:               dawg-ord+version:            0.2+synopsis:           Directed acyclic word graphs+description:+    The library implements /directed acyclic word graphs/ (DAWGs)+    internally represented as /minimal acyclic deterministic+    finite-state automata/.+    .+    The library allows to build DAWGs from words over any alphabet+    providing an `Ord` instance.+    It also provides a fast insert operation which can be used to+    build DAWGs on-the-fly.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2015 Jakub Waszczuk+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Data, Data Structures+homepage:           https://github.com/kawu/dawg-ord+build-type:         Simple++library+    hs-source-dirs: src+    build-depends:+        base            >= 4 && < 5+      , containers      >= 0.4.1 && < 0.6+      , binary+      , vector+      -- , vector-binary+      , mtl+      , transformers++    exposed-modules:+        Data.DAWG.Gen.Types+      , Data.DAWG.Int.Dynamic+      , Data.DAWG.Ord.Dynamic+--       , Data.DAWG.Ord.Static++    other-modules:+        Data.DAWG.Int.Dynamic.Internal+      , Data.DAWG.Int.Dynamic.Node+      -- , Data.DAWG.Int.Static.Node+      , Data.DAWG.Gen.Graph+      , Data.DAWG.Gen.Trans+      , Data.DAWG.Gen.Trans.Vector+      , Data.DAWG.Gen.Trans.Map+      , Data.DAWG.Gen.Trans.Hashed+      , Data.DAWG.Gen.HashMap+      , Data.DAWG.Gen.Util++    ghc-options: -Wall++source-repository head+    type: git+    location: https://github.com/kawu/dawg-ord.git
+ src/Data/DAWG/Gen/Graph.hs view
@@ -0,0 +1,216 @@+{-# 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.Gen.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.Gen.Types (ID)+import           Data.DAWG.Gen.HashMap (Hash)+import qualified Data.DAWG.Gen.HashMap as H+++-- | 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.+nodeIDUnsafe :: Hash n => n -> Graph n -> ID+nodeIDUnsafe 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 = nodeIDUnsafe 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/Gen/HashMap.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE RecordWildCards #-}+++-- | A map from hashable keys to values.+++module Data.DAWG.Gen.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+++---------------------------------------------------------------+-- Hash Class+---------------------------------------------------------------+++-- | Class for types which provide hash values.+class Ord a => Hash a where+    hash    :: a -> Int++instance Hash Int where+    hash = id++instance Hash Bool where+    hash b = hash $ if b then 1 :: Int else 0++instance Hash a => Hash (Maybe a) where+    hash (Just x)+        | h < 0     = h+        | otherwise = h + 1+        where h = hash x+    hash Nothing    = 0++++---------------------------------------------------------------+-- HashMap Values+---------------------------------------------------------------+++-- | Value in a HashMap.+data Value a b+    = Single !a !b+    | Multi  !(M.Map a b)+    deriving (Show, Eq, Ord)+++-- | Value Binary instance.+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+++-- | Unsafe `find` version.+-- 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 a regular map into a hash value (and 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 (key, valye) pair into a hash 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.  It is unsafe because, if the value is+-- `Single`, it assumes that it contains the given key.+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)+++---------------------------------------------------------------+-- HashMap+---------------------------------------------------------------+++-- | 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+++-- | Unsafe version of `lookup`.+-- 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 is already present in the map.+-- Q: What's the unsafe element?  If the only unsafety here is+-- that the HashMap size is incremented anyway, maybe it would be+-- better to make it safe?+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+++---------------------------------------------------------------+-- Utils+---------------------------------------------------------------+++-- | A custom version of `fromJust`.+fromJust :: Maybe a -> a+fromJust (Just x)   = x+fromJust Nothing    = error "fromJust: Nothing"+{-# INLINE fromJust #-}
+ src/Data/DAWG/Gen/Trans.hs view
@@ -0,0 +1,29 @@+-- | The module provides an abstraction over transition maps from+-- alphabet symbols to node identifiers.+++module Data.DAWG.Gen.Trans+( Trans (..)+) where+++import Data.DAWG.Gen.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/Gen/Trans/Hashed.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+++-- | Transition map with a hash.+++module Data.DAWG.Gen.Trans.Hashed+( Hashed (..)+) where+++import           Prelude hiding (lookup)+import           Control.Applicative ((<$>), (<*>))+import           Data.DAWG.Gen.Util (combine)+import           Data.Binary (Binary, put, get)+import           Data.DAWG.Gen.Trans+import qualified Data.DAWG.Gen.Trans.Map as M+import qualified Data.DAWG.Gen.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/Gen/Trans/Map.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+++-- | Implementation of a transition map build on top of the "M.Map" container.+++module Data.DAWG.Gen.Trans.Map+( Trans (unTrans)+) where+++import Prelude hiding (lookup)+import Data.Binary (Binary)+import qualified Data.Map as M++import Data.DAWG.Gen.Types+import qualified Data.DAWG.Gen.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/Gen/Trans/Vector.hs view
@@ -0,0 +1,63 @@+{-# 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.Gen.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.Gen.Types+import Data.DAWG.Gen.Util+import qualified Data.DAWG.Gen.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/Gen/Types.hs view
@@ -0,0 +1,16 @@+-- | Basic types used throughout the library.++module Data.DAWG.Gen.Types+( ID+, Sym+, Val+) where++-- | Node identifier.+type ID = Int++-- | Internal representation of an alphabet element.+type Sym = Int++-- | Internal representation of an automaton value.+type Val = Int
+ src/Data/DAWG/Gen/Util.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TupleSections #-}++-- | Utility functions.++module Data.DAWG.Gen.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 #-}
+ src/Data/DAWG/Int/Dynamic.hs view
@@ -0,0 +1,286 @@+{-# 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.Int.Dynamic+(+-- * DAWG type+  DAWG (root)++-- * Query+, member+, numStates+, numEdges++-- * Traversal+, accept+, edges+, follow++-- * Construction+, empty+, fromList+-- ** Insertion+, insert+-- ** Deletion+-- , delete++-- * Conversion+, keys+) where+++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.Gen.Types+import           Data.DAWG.Gen.Graph (Graph)+import qualified Data.DAWG.Gen.Trans as T+import qualified Data.DAWG.Gen.Graph as G+import           Data.DAWG.Int.Dynamic.Internal+import qualified Data.DAWG.Int.Dynamic.Node as N+++------------------------------------------------------------+-- State monad over the underlying graph+------------------------------------------------------------+++type GraphM = S.State (Graph N.Node)+++-- | A utility function to run in cooperation with `S.state`.+mkState :: (Graph a -> Graph a) -> Graph a -> ((), Graph a)+mkState f g = ((), f g)+++-- | Return node with the given identifier.+nodeBy :: ID -> GraphM N.Node+nodeBy i = G.nodeBy i <$> S.get+++-- Evaluate the 'G.insert' function within the monad.+insertNode :: N.Node -> GraphM ID+insertNode = S.state . G.insert+++-- | Leaf node with no children and 'Nothing' value.+insertLeaf :: GraphM ID+insertLeaf = insertNode $ N.Node False T.empty+    -- i <- insertNode (N.Leaf Nothing)+    -- insertNode (N.Branch i T.empty)+++-- Evaluate the 'G.delete' function within the monad.+deleteNode ::  N.Node -> GraphM ()+deleteNode = S.state . mkState . G.delete+++-- | Invariant: the identifier points to the 'Branch' node.+-- TODO: which identifier?+insertM :: [Sym] -> ID -> GraphM ID+insertM (x:xs) i = do+    n <- nodeBy i+    j <- case N.onSym x n of+        Just j  -> return j+        Nothing -> insertLeaf+    k <- insertM xs j+    deleteNode n+    insertNode (N.insert x k n)+insertM [] i = do+    n <- nodeBy i+    deleteNode n+    insertNode (n { N.accept = True })+++-- deleteM :: [Sym] -> ID -> GraphM 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+--     deleteNode n+--     insertNode (n { N.value = Nothing })+++-- -- | Follow the path from the given identifier.+-- followPath :: [Sym] -> ID -> MaybeT GraphM ID+-- followPath (x:xs) i = do+--     n <- lift $ nodeBy i+--     j <- liftMaybe $ N.onSym x n+--     followPath xs j+-- followPath [] i = return i+++-- | Follow the path from the given identifier.+followPath' :: [Sym] -> ID -> GraphM (Maybe ID)+followPath' (x:xs) i = do+    n <- nodeBy i+    case N.onSym x n of+         Nothing -> return Nothing+         Just j  -> followPath' xs j+followPath' [] i = return $ Just i+++memberM :: [Sym] -> ID -> GraphM Bool+memberM xs i = do+    mj <- followPath' xs i+    case mj of+         Nothing    -> return False+         Just j     -> N.accept <$> nodeBy j+++-- memberM :: [Sym] -> ID -> GraphM Bool+-- memberM xs i = fmap justTrue . runMaybeT $ do+--     j <- followPath xs i+--     lift $ N.accept <$> nodeBy j+--   where+--     justTrue (Just True) = True+--     justTrue _           = False+++------------------------------------------------------------+-- The proper DAWG interface+------------------------------------------------------------+++-- | Return all (key, value) pairs in ascending key order in the+-- sub-DAWG determined by the given node ID.+subPairs :: Graph N.Node -> ID -> [[Sym]]+subPairs g i =+    here n ++ concatMap there (N.edges n)+  where+    n = G.nodeBy i g+    here v = [[] | N.accept v]+--     here v = if N.accept v+--         then [[]]+--         else []+    there (sym, j) = map (sym:) (subPairs g j)+++-- | Empty DAWG.+empty :: DAWG a+empty =+    let (i, g) = S.runState insertLeaf G.empty+    in  DAWG g i+++-- | Number of states in the automaton.+numStates :: DAWG a -> Int+numStates = G.size . graph+++-- | Number of edges in the automaton.+numEdges :: DAWG a -> Int+numEdges = sum . map (length . N.edges) . G.nodes . graph+++-- | Insert the (key, value) pair into the DAWG.+insert :: Enum a => [a] -> DAWG a -> DAWG a+insert xs' d =+    let xs = map fromEnum xs'+        (i, g) = S.runState (insertM xs $ root d) (graph d)+    in  DAWG g i+{-# INLINE insert #-}+++-- -- | Delete the key from the DAWG.+-- delete :: Enum a => [a] -> DAWG a -> DAWG a+-- delete xs' d =+--     let xs = map fromEnum xs'+--         (i, g) = S.runState (deleteM xs $ root d) (graph d)+--     in  DAWG g i+-- {-# SPECIALIZE delete :: String -> DAWG Char -> DAWG Char #-}+++-- | Find value associated with the key.+member :: Enum a => [a] -> DAWG a -> Bool+member xs' d =+    let xs = map fromEnum xs'+    in  S.evalState (memberM xs $ root d) (graph d)+{-# SPECIALIZE member :: String -> DAWG Char -> Bool #-}+++-- -- | 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.+keys :: Enum a => DAWG a -> [[a]]+keys+    = map (map toEnum)+    . (subPairs <$> graph <*> root)+{-# SPECIALIZE keys :: DAWG Char -> [String] #-}+++-- | Construct DAWG from the list of (word, value) pairs.+fromList :: Enum a => [[a]] -> DAWG a+fromList xs =+    let update t x = insert x t+    in  foldl' update empty xs+{-# SPECIALIZE fromList :: [String] -> DAWG Char #-}+++------------------------------------------------------------+-- Traversal+------------------------------------------------------------+++-- | A list of outgoing edges.+edges :: Enum a => ID -> DAWG a -> [(a, ID)]+edges i+    = map (first toEnum)+    . N.edges . G.nodeBy i+    . graph+{-# SPECIALIZE edges :: ID -> DAWG Char -> [(Char, ID)] #-}+{-# SPECIALIZE edges :: ID -> DAWG Int  -> [(Int, ID)]  #-}+++-- | Value stored in the given state.+accept :: ID -> DAWG a -> Bool+accept i = N.accept . G.nodeBy i . graph+++-- -- | Follow the given transition from the given state.+-- follow :: Enum a => ID -> a -> DAWG a -> Maybe ID+-- follow i x DAWG{..} = flip S.evalState graph $ runMaybeT $+--     followPath [fromEnum x] i+++-- | Follow the given transition from the given state.+follow :: Enum a => ID -> a -> DAWG a -> Maybe ID+follow i x DAWG{..} = flip S.evalState graph $+    followPath' [fromEnum x] i+++------------------------------------------------------------+-- Misc+------------------------------------------------------------+++-- liftMaybe :: Monad m => Maybe a -> MaybeT m a+-- liftMaybe = MaybeT . return+-- {-# INLINE liftMaybe #-}
+ src/Data/DAWG/Int/Dynamic/Internal.hs view
@@ -0,0 +1,30 @@+-- | The module exports internal representation of dynamic DAWG.+++module Data.DAWG.Int.Dynamic.Internal+(+-- * DAWG type+  DAWG (..)+) where+++-- import Control.Applicative ((<$>), (<*>))+-- import Data.Binary (Binary, put, get)++import           Data.DAWG.Gen.Types+import           Data.DAWG.Gen.Graph (Graph)+import qualified Data.DAWG.Int.Dynamic.Node as N+++-- | A directed acyclic word graph with phantom type @a@+-- representing the type of alphabet elements.+data DAWG a = DAWG+    { graph :: !(Graph N.Node)+    , root  :: !ID }+    deriving (Show, Eq, Ord)++-- instance Binary (DAWG a) where+--     put d = do+--         put (graph d)+--         put (root d)+--     get = DAWG <$> get <*> get
+ src/Data/DAWG/Int/Dynamic/Node.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE RecordWildCards #-}+++-- | Internal representation of dynamic automata nodes.+++module Data.DAWG.Int.Dynamic.Node+( Node(..)+, onSym+, edges+, children+, insert+) where+++-- import Control.Applicative ((<$>), (<*>))+-- import Data.Binary (Binary, put, get)++import Data.DAWG.Gen.Types+import Data.DAWG.Gen.Util (combine)+import Data.DAWG.Gen.HashMap (Hash, hash)+import Data.DAWG.Gen.Trans.Map (Trans)+import qualified Data.DAWG.Gen.Trans as T+import qualified Data.DAWG.Gen.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.+data Node = Node {+    -- | Accepting state or no?+      accept    :: !Bool+    -- | Transition map (outgoing edges).+    , transMap :: !(H.Hashed Trans)+    } deriving (Show, Eq, Ord)++instance Hash Node where+    hash Node{..} = combine (hash accept) (H.hash transMap)++-- instance Binary Node where+--     put Node{..} = put accept >> put transMap+--     get = Node <$> get <*> get+++-- | Transition function.+onSym :: Sym -> Node -> Maybe ID+onSym x (Node _ t)    = T.lookup x t+{-# INLINE onSym #-}+++-- | List of symbol/edge pairs outgoing from the node.+edges :: Node -> [(Sym, ID)]+edges (Node _ t)  = T.toList t+{-# INLINE edges #-}+++-- | List of children identifiers.+children :: Node -> [ID]+children = map snd . edges+{-# INLINE children #-}+++-- | Substitue edge determined by a given symbol.+insert :: Sym -> ID -> Node -> Node+insert x i (Node a t) = Node a (T.insert x i t)+{-# INLINE insert #-}
+ src/Data/DAWG/Ord/Dynamic.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards #-}+++-- | The simplified version of `Data.DAWG.Ord.Dynamic` adapted to+-- keys and values with `Ord` instances.+++module Data.DAWG.Ord.Dynamic+(+-- * DAWG type+  DAWG+, root++-- * Query+, member+, numStates+, numEdges++-- * Traversal+, accept+, edges+, follow++-- * Construction+, empty+, fromList+-- ** Insertion+, insert++-- * Conversion+, keys+) where+++import           Data.List (foldl')+import           Control.Arrow (first)+import qualified Control.Monad.State.Strict as S++import           Data.Maybe (fromMaybe)+import qualified Data.Map.Strict as M++import           Data.DAWG.Gen.Types+import qualified Data.DAWG.Int.Dynamic as D+++------------------------------------------------------------+-- DAWG+------------------------------------------------------------+++-- | A directed acyclic word graph with type @a@ representing the+-- type of alphabet elements.+data DAWG a = DAWG+    { intDAWG   :: D.DAWG Sym+    , symMap    :: M.Map a Int+    , symMapR   :: M.Map Int a+    } deriving (Show, Eq, Ord)+++-- | Root of the DAWG.+root :: DAWG a -> ID+root = D.root . intDAWG+++------------------------------------------------------------+-- State monad over the underlying DAWG+------------------------------------------------------------+++-- | DAWG monad.+type DM a = S.State (DAWG a)+++-- | Register new key in the underlying automaton.+-- TODO: We could optimize it.+addSym :: Ord a => a -> DM a Int+addSym x = S.state $ \dawg@DAWG{..} ->+    let y = fromMaybe (M.size symMap) (M.lookup x symMap)+--     let y = case M.lookup x symMap of+--             Nothing -> M.size symMap+--             Just k  -> k+    in  (y, dawg+            { symMap  = M.insert x y symMap+            , symMapR = M.insert y x symMapR })+++-- | Register new key in the underlying automaton.+addKey :: Ord a => [a] -> DM a [Int]+addKey = mapM addSym+++-- | Run the DAGW monad.+runDM :: DM a c -> DAWG a -> (c, DAWG a)+runDM = S.runState+++------------------------------------------------------------+-- The proper DAWG interface+------------------------------------------------------------+++-- | Empty DAWG.+empty :: DAWG a+empty = DAWG D.empty M.empty M.empty+++-- | Number of states in the automaton.+numStates :: DAWG a -> Int+numStates = D.numStates . intDAWG+++-- | Number of edges in the automaton.+numEdges :: DAWG a -> Int+numEdges = D.numEdges . intDAWG+++-- | Insert the (key, value) pair into the DAWG.+insert :: (Ord a) => [a] -> DAWG a -> DAWG a+insert xs0 dag0 = snd $ flip runDM dag0 $ do+    xs <- addKey xs0+    S.modify $ \dag -> dag+        {intDAWG = D.insert xs (intDAWG dag)}+++-- -- | 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+--     :: (Ord a, Ord b) => (b -> b -> b)+--     -> [a] -> b -> DAWG a b -> DAWG a b+-- insertWith f xs y dag =+--     let y' = lookup xs dag+--     in  insert xs (f y y') dag+++-- -- | 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.+member :: (Ord a) => [a] -> DAWG a -> Bool+member xs0 DAWG{..} = justTrue $ do+    xs <- mapM (`M.lookup` symMap) xs0+    return $ D.member xs intDAWG+++-- | Return all key/value pairs in the DAWG in ascending key order.+keys :: DAWG a -> [[a]]+keys DAWG{..} =+    [ decodeKey xs+    | xs <- D.keys intDAWG ]+  where+    decodeKey = map decodeSym+    decodeSym x = symMapR M.! x+++-- | Construct DAWG from the list of (word, value) pairs.+fromList :: (Ord a) => [[a]] -> DAWG a+fromList xs =+    let update t x = insert x t+    in  foldl' update empty xs+++------------------------------------------------------------+-- Traversal+------------------------------------------------------------+++-- | Value stored in the given node.+accept :: ID -> DAWG a -> Bool+accept i DAWG{..} = D.accept i intDAWG+++-- | A list of outgoing edges.+edges :: ID -> DAWG a -> [(a, ID)]+edges i DAWG{..} = map+    (first (symMapR M.!))+    (D.edges i intDAWG)+++-- | Follow the given transition from the given state.+follow :: Ord a => ID -> a -> DAWG a -> Maybe ID+follow i x DAWG{..} = do+    y <- M.lookup x symMap+    D.follow i y intDAWG+++------------------------------------------------------------+-- Misc+------------------------------------------------------------+++-- | Is it `Just True`?+justTrue :: Maybe Bool -> Bool+justTrue (Just True) = True+justTrue _           = False