dawg (empty) → 0.1.0

raw patch · 6 files changed

+387/−0 lines, 6 filesdep +basedep +binarydep +containerssetup-changed

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

Files

Data/DAWG.hs +104/−0
Data/DAWG/Graph.hs +167/−0
Data/DAWG/VMap.hs +51/−0
LICENSE +26/−0
Setup.lhs +4/−0
dawg.cabal +35/−0

+ Data/DAWG.hs view

@@ -0,0 +1,104 @@+-- | The module provides implementation of /directed acyclic word graphs/+-- (DAWGs) also known as /minimal acyclic finite-state automata/.+-- The implementation provides fast insert and (TODO:)delete operations+-- which can be used to build the DAWG structure incrementaly.++module Data.DAWG+( DAWG (..)+, empty+, size+, insert+, lookup+, fromList+, fromLang+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Data.List (foldl')+import Data.Binary (Binary, put, get)+import qualified Control.Monad.State.Strict as S++import Data.DAWG.Graph (Id, Node, Graph)+import qualified Data.DAWG.Graph as G++type GraphM a b = S.State (Graph 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 (Node a)+nodeBy i = G.nodeBy i <$> S.get++-- Evaluate the 'G.insert' function within the monad.+insertNode :: Ord a => Node a -> GraphM a Id+insertNode = S.state . G.insert++-- Evaluate the 'G.delete' function within the monad.+deleteNode :: Ord a => Node a -> GraphM a ()+deleteNode = S.state . mkState . G.delete++insertM :: Ord a => String -> a -> Id -> GraphM a Id+insertM [] y i = do+    n <- nodeBy i+    deleteNode n+    insertNode (n { G.value = Just y })+insertM (x:xs) y i = do+    n <- nodeBy i+    j <- case G.onChar x n of+        Just j  -> return j+        Nothing -> insertNode G.leaf+    k <- insertM xs y j+    deleteNode n+    insertNode (G.subst x k n)+    +lookupM :: String -> Id -> GraphM a (Maybe a)+lookupM [] i = G.value <$> nodeBy i+lookupM (x:xs) i = do+    n <- nodeBy i+    case G.onChar x n of+        Just j  -> lookupM xs j+        Nothing -> return Nothing++-- | A 'G.Graph' with one root from which all other graph nodes should+-- be accesible.+data DAWG a = DAWG+    { graph :: !(Graph a)+    , root  :: !Id }+    deriving (Show, Eq, Ord)++instance (Binary a, Ord a) => Binary (DAWG a) where+    put d = do+        put (graph d)+        put (root d)+    get = DAWG <$> get <*> get++-- | Empty DAWG.+empty :: DAWG a+empty = DAWG G.empty 0++-- | DAWG size (number of nodes).+size :: DAWG a -> Int+size = G.size . graph++-- | Insert the (key, value) pair into the DAWG.+insert :: Ord a => String -> a -> DAWG a -> DAWG a+insert xs y d =+    let (i, g) = S.runState (insertM xs y $ root d) (graph d)+    in  DAWG g i++-- | Find value associated with the key.+lookup :: String -> DAWG a -> Maybe a+lookup xs d = S.evalState (lookupM xs $ root d) (graph d)++-- | Construct DAWG from the list of (word, value) pairs.+fromList :: (Ord a) => [(String, a)] -> DAWG a+fromList xs =+    let update t (x, v) = insert x v t+    in  foldl' update empty xs++-- | Make DAWG from the list of words.  Annotate each word with+-- the @()@ value.+fromLang :: [String] -> DAWG ()+fromLang xs = fromList [(x, ()) | x <- xs]

+ Data/DAWG/Graph.hs view

@@ -0,0 +1,167 @@+{-# LANGUAGE RecordWildCards #-}++-- | The module provides a /directed acyclic graph/ (DAG) implementation+-- where all equivalent nodes (i.e. roots of DAGs equal with respect to+-- the '==' function) are compressed to one node with unique identifier.+-- It can be alternatively thought of as a+-- /minimal acyclic finite-state automata/.++module Data.DAWG.Graph+( +-- * Node+  Node (..)+, Id+, leaf+, onChar+, subst+-- * Graph+, Graph (..)+, empty+, size+, nodeBy+, nodeID+, insert+, delete+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, put, get)+import qualified Data.Map.Strict as M+import qualified Data.IntSet as IS+import qualified Data.IntMap.Strict as IM++import qualified Data.DAWG.VMap as V++-- | Node identifier.+type Id = Int++-- | Two nodes (states) belong to the same equivalence class (and,+-- consequently, they must be represented as one node in the graph)+-- iff they are equal with respect to their values and outgoing+-- edges.+data Node a = Node+    { value :: Maybe a+    , edges :: V.VMap Id }+    deriving (Show, Eq, Ord)++instance Binary a => Binary (Node a) where+    put Node{..} = put value >> put edges+    get = Node <$> get <*> get++-- | Leaf node with no children and 'Nothing' value.+leaf :: Node a+leaf = Node+    { value = Nothing+    , edges = V.empty }++-- | Child identifier found by following the given character.+onChar :: Char -> Node a -> Maybe Id+onChar x n = V.lookup x (edges n)++-- | Substitue the identifier of the child determined by the given+-- character.+subst :: Char -> Id -> Node a -> Node a+subst x i n = n { edges = V.insert x i (edges n) }++-- | 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 save some memory?+data Graph a = Graph {+    -- | Map from nodes to IDs.+      idMap     :: !(M.Map (Node a) Id)+    -- | Set of free IDs.+    , freeIDs   :: !IS.IntSet+    -- | Equivalence class represented by given ID and size of the class. +    , nodeMap   :: !(IM.IntMap (Node a))+    -- | Number of ingoing edges.+    , ingoMap   :: !(IM.IntMap Int) }+    deriving (Show, Eq, Ord)++instance (Binary a, Ord a) => Binary (Graph a) where+    put Graph{..} = do+    	put idMap+	put freeIDs+	put nodeMap+	put ingoMap+    get = Graph <$> get <*> get <*> get <*> get++-- | Empty graph.+empty :: Graph a+empty = Graph+    (M.singleton leaf 0)+    IS.empty+    (IM.singleton 0 leaf)+    (IM.singleton 0 1)++-- | Size of the graph (number of nodes).+size :: Graph a -> Int+size = M.size . idMap++-- | Node with the given identifier.+nodeBy :: Id -> Graph a -> Node a+nodeBy i g = nodeMap g IM.! i++-- | Retrive the node identifier.+nodeID :: Ord a => Node a -> Graph a -> Id+nodeID n g = idMap g M.! n++-- | Add new graph node.+newNode :: Ord a => Node a -> Graph a -> (Id, Graph a)+newNode n Graph{..} =+    (i, Graph idMap' freeIDs' nodeMap' ingoMap')+  where+    idMap'      = M.insert  n i idMap+    nodeMap'    = IM.insert i n nodeMap+    ingoMap'    = IM.insert i 1 ingoMap+    (i, freeIDs') = if IS.null freeIDs+        then (M.size idMap, freeIDs)+        else IS.deleteFindMin freeIDs++-- | Remove node from the graph.+remNode :: Ord a => Id -> Graph a -> Graph a+remNode i Graph{..} =+    Graph idMap' freeIDs' nodeMap' ingoMap'+  where+    idMap'      = M.delete  n idMap+    nodeMap'    = IM.delete i nodeMap+    ingoMap'    = IM.delete i ingoMap+    freeIDs'    = IS.insert i freeIDs+    n           = nodeMap IM.! i++-- | Increment the number of ingoing edges.+incIngo :: Id -> Graph a -> Graph a+incIngo i g = g { ingoMap = IM.adjust (+1) i (ingoMap g) }++-- | Descrement the number of ingoing edges and return+-- the resulting number.+decIngo :: Id -> Graph a -> (Int, Graph a)+decIngo i g =+    let k = (ingoMap g IM.! i) - 1+    in  (k, g { ingoMap = IM.insert i k (ingoMap g) })++-- | Insert node into the graph.  If the node was already a member+-- of the graph, just increase the number of ingoing edges.+insert :: Ord a => Node a -> Graph a -> (Id, Graph a)+insert n g = case M.lookup n (idMap g) of+    Just i  -> (i, incIngo i g)+    Nothing -> newNode n g++-- | Delete node from the graph.  If the node was present in the graph+-- at multiple positions, just decrease the number of ingoing edges.+-- NOTE: The function does not delete descendant nodes which may become+-- inaccesible.+delete :: Ord a => Node a -> Graph a -> Graph a+delete n g = if num == 0+    then remNode i g'+    else g'+  where+    i = nodeID n g+    (num, g') = decIngo i g

+ Data/DAWG/VMap.hs view

@@ -0,0 +1,51 @@+-- | A vector representation of 'M.Map'.++module Data.DAWG.VMap+( VMap (unVMap)+, mkVMap+, empty+, lookup+, insert+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>))+import Data.Binary (Binary, put, get)+import Data.Vector.Binary ()+import qualified Data.Map as M+import qualified Data.Vector.Unboxed as U++-- | A strictly ascending vector of distinct elements with respect+-- to 'fst' values.+newtype VMap a = VMap { unVMap :: U.Vector (Char, a) }+    deriving (Show, Eq, Ord)++instance (Binary a, U.Unbox a) => Binary (VMap a) where+    put v = put (unVMap v)+    get = VMap <$> get++-- | Smart VMap constructor which ensures that the underlying vector is+-- strictly ascending with respect to 'fst' values.+mkVMap :: U.Unbox a => [(Char, a)] -> VMap a+mkVMap = VMap . U.fromList . M.toAscList  . M.fromList +{-# INLINE mkVMap #-}++-- | Empty map.+empty :: U.Unbox a => VMap a+empty = VMap U.empty+{-# INLINE empty #-}++-- | Lookup the character in the map.+lookup :: U.Unbox a => Char -> VMap a -> Maybe a+lookup x = fmap snd . U.find ((==x) . fst) . unVMap+{-# INLINE lookup #-}++-- | Insert the (character, value) pair into the map.+-- TODO: Optimize!  Use the invariant, that VMap is+-- kept in an ascending vector.+insert :: U.Unbox a => Char -> a -> VMap a -> VMap a+insert x y+    = VMap . U.fromList . M.toAscList+    . M.insert x y+    . M.fromList . U.toList . unVMap+{-# INLINE insert #-}

+ 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.cabal view

@@ -0,0 +1,35 @@+name:               dawg+version:            0.1.0+synopsis:           DAWG+description:+    Directed acyclic word graphs.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2012 IPI PAN+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Data, Data Structures+homepage:           https://github.com/kawu/dawg+build-type:         Simple++library+    build-depends:+        base >= 4 && < 5+      , containers >= 0.5 && < 0.6+      , binary+      , vector+      , vector-binary+      , mtl++    exposed-modules:+        Data.DAWG+      , Data.DAWG.Graph+      , Data.DAWG.VMap++    ghc-options: -Wall++source-repository head+    type: git+    location: https://github.com/kawu/dawg.git