diff --git a/Data/PoliMorf.hs b/Data/PoliMorf.hs
--- a/Data/PoliMorf.hs
+++ b/Data/PoliMorf.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE BangPatterns #-}
 
@@ -8,35 +9,45 @@
 
 module Data.PoliMorf
 ( 
--- * Types
+-- * Core types
   Form
 , Base
 , Tag
 , Cat
 , Entry (..)
+, atomic
 
 -- * Parsing
 , readPoliMorf
 , parsePoliMorf
 
 -- * Merging
+, Rule (..)
+, apply
+, toBase
+, mkRuleMap
 , BaseMap
 , mkBaseMap
+, FormMap
+, mkFormMap
 , RelCode (..)
+, mergeWith
 , merge
 ) where
 
 import Control.Applicative ((<$>), (<*>))
 import Data.Maybe (catMaybes)
 import Data.Monoid (mappend)
-import Data.List (foldl')
 import Data.Binary (Binary, get, put)
-import qualified Data.Map as M
 import qualified Data.Set as S
+import qualified Data.Map as M
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
 import qualified Data.Text.Lazy.IO as L
+import qualified Data.DAWG as D
 
+import Debug.Trace (trace)
+
 -- | A form.
 type Form = T.Text
 
@@ -57,6 +68,15 @@
     , cat  :: !Cat }
     deriving (Eq, Ord, Show, Read)
 
+-- | Is the entry an atomic one?  More precisely, we treat all negative
+-- forms starting with ''nie'' and all superlatives starting with ''naj''
+-- as non-atomic entries.
+atomic :: Entry -> Bool
+atomic x
+    | "sup" `T.isInfixOf` tag x && "naj" `T.isPrefixOf` form x = False
+    | "neg" `T.isInfixOf` tag x && "nie" `T.isPrefixOf` form x = False
+    | otherwise = True
+
 -- | Read the PoliMorf from the file.
 readPoliMorf :: FilePath -> IO [Entry]
 readPoliMorf path = parsePoliMorf <$> L.readFile path
@@ -71,25 +91,74 @@
     [_form, _base, _tag, _cat] -> Entry _form _base _tag _cat
     _   -> error $ "parsePoliRow: invalid row \"" ++ L.unpack row ++ "\""
 
+-- | A rule for translating a form into another one.
+data Rule = Rule {
+    -- | Number of characters to cut from the end of the form.
+      cut       :: !Int
+    -- | A suffix to paste.
+    , suffix    :: !T.Text }
+    deriving (Show, Eq, Ord)
+
+-- | Apply the rule.
+apply :: Rule -> T.Text -> T.Text
+apply r x = T.take (T.length x - cut r) x `T.append` suffix r
+
+-- | Determine the rule needed to translate the form into its base form.
+toBase :: Entry -> Maybe Rule
+toBase x
+    | "sup" `T.isInfixOf` tag x && "naj" `T.isPrefixOf` form x = Nothing
+    | "neg" `T.isInfixOf` tag x && "nie" `T.isPrefixOf` form x = Nothing
+    | otherwise =
+        let k = lcp (form x) (base x)
+        in  Just $ Rule (T.length (form x) - k) (T.drop k (base x))
+  where
+    lcp a b = case T.commonPrefixes a b of
+        Just (c, _, _)  -> T.length c
+        Nothing         -> trace (show (form x, base x)) 0
+
+-- | Make a rule to translate between two strings.
+between :: T.Text -> T.Text -> Rule
+between source dest =
+    let k = lcp source dest
+    in  Rule (T.length source - k) (T.drop k dest)
+  where
+    lcp a b = case T.commonPrefixes a b of
+        Just (c, _, _)  -> T.length c
+        Nothing         -> 0
+
 -- | A map from forms to their possible base forms (there may be many since
 -- the form may be a member of multiple lexemes).
-type BaseMap = M.Map Form (S.Set Base)
+type BaseMap = D.DAWG (S.Set Rule)
 
--- | Make the base map from the list of entries.
+-- | A map from base forms to all their potential forms.
+type FormMap = D.DAWG (S.Set Rule)
+
+-- | Make a rule map from a list of entries.
+mkRuleMap :: [(T.Text, T.Text)] -> D.DAWG (S.Set Rule)
+mkRuleMap xs = D.fromListWith S.union $
+    [ ( T.unpack x
+      , S.singleton (between x y) )
+    | (x, y) <- xs ]
+
+-- | Make a 'BaseMap' from a list of entries.
 mkBaseMap :: [Entry] -> BaseMap
-mkBaseMap = M.fromListWith S.union . map ((,) <$> form <*> S.singleton . base)
+mkBaseMap = mkRuleMap . map ((,) <$> form <*> base)
 
+-- | Make a 'FormMap' from a list of entries.
+mkFormMap :: [Entry] -> FormMap
+mkFormMap = mkRuleMap . map ((,) <$> base <*> form)
+
 -- | Reliability information: how did we assign a particular label to
 -- a particular word form.
 data RelCode
-    = Exact     -- ^ Label assigned in a direct manner
+    = ByForm    -- ^ Based on labels of other forms within the same lexeme
     | ByBase    -- ^ Label assigned based on a lemma label  
-    | ByForm    -- ^ Based on labels of other forms within the same lexeme
+    | Exact     -- ^ Label assigned in a direct manner
     deriving (Eq, Ord, Show, Read)
 
 instance Binary RelCode where
     put Exact   = put '1'
-    put ByBase = put '2'
+    put ByBase  = put '2'
     put ByForm  = put '3'
     get = get >>= \x -> return $ case x of
         '1' -> Exact
@@ -97,63 +166,82 @@
         '3' -> ByForm
         c   -> error $ "get: invalid RelCode code '" ++ [c] ++ "'"
 
--- | Merge the 'BaseMap' with the dictionary resource which maps forms to
--- sets of labels.  Every label is assigned a 'RelCode' which tells what
--- is the relation between the label and the form.  There are three
--- kinds of labels:
+-- | Merge the 'BaseMap' with the dictionary resource which maps forms to sets
+-- of labels.  Every label is assigned a 'RelCode' which tells what is the
+-- relation between the label and the form. It is a generalized version
+-- of the 'merge' function with additional function @f x y y'label@ which
+-- can be used to determine the resultant set of labels for the form @x@
+-- given ,,similar'' form @y@ and its original label @y'label@.
+-- There are three kinds of labels:
 -- 'Exact' labels assigned in a direct manner, 'ByBase' labels assigned
 -- to all forms which have a base form with a label in the input dictionary,
 -- and 'ByForm' labels assigned to all forms which have a related form from the
 -- same lexeme with a label in the input dictionary.
---
--- This function is far from being memory efficient right now.  If you plan to
--- run it with respect to the entire PoliMorf dictionary you should do it
--- on a machine with an abundance of available memory.
-merge
-    :: Ord a => BaseMap
-    -> M.Map Form (S.Set a)
-    -> M.Map Form (M.Map a RelCode)
-merge poli dict0 = M.fromList
+mergeWith
+    :: Ord a
+    => (String -> String -> a -> a)
+    -> BaseMap
+    -> D.DAWG (S.Set a)
+    -> D.DAWG (M.Map a RelCode)
+mergeWith f poli dict0 = D.fromList
     [ (x, combine x)
     | x <- keys ]
   where
     -- Keys in the output dictionary.
-    keys = S.toList (M.keysSet poli `S.union` M.keysSet dict0)
+    keys = join (D.keys poli) (D.keys dict0)
 
     -- Combining function.
-    combine x = (M.unionsWith min . catMaybes)
-        [ label Exact  <$> M.lookup x dict0 
-        , label ByBase <$> M.lookup x dict1
-        , label ByForm <$> M.lookup x dict2 ]
+    combine x = (M.unionsWith max . catMaybes)
+        [ label Exact  <$> D.lookup x dict0 
+        , label ByBase <$> D.lookup x dict1
+        , label ByForm <$> D.lookup x dict2 ]
 
     label :: Ord a => RelCode -> S.Set a -> M.Map a RelCode
     label code s = M.fromList [(x, code) | x <- S.toList s]
 
     -- Extended to all base forms of dict0 keys.
-    dict1 = fromListWith mappend
-        [ (lemma, x)
-        | (_form, x) <- M.assocs dict0
+    dict1 = D.fromListWith mappend
+        [ (lemma, f'Set lemma _form x)
+        | (_form, x) <- D.assocs dict0
         , lemma <- elemsOn poli _form ]
 
     -- Extended to all forms of dict0 keys.
-    dict2 = fromListWith mappend
-        [ (form', x)
-        | (_form, x) <- M.assocs dict0
+    dict2 = D.fromListWith mappend
+        [ (form', f'Set form' _form x)
+        | (_form, x) <- D.assocs dict0
         , lemma <- elemsOn poli _form
         , form' <- elemsOn ilop lemma ]
 
     -- Inverse poli dictionary.
-    ilop = fromListWith mappend
-        [ (lemma, S.singleton _form)
-        | (_form, lemmas) <- M.assocs poli
-        , lemma <- S.toList lemmas ]
+    ilop = mkRuleMap
+        [ (base'Text, form'Text)
+        | (form'String, rules) <- D.assocs poli
+        , rule <- S.toList rules
+        , let form'Text = T.pack form'String
+        , let base'Text = apply rule form'Text ]
+    
+    -- Merge to ascending lists.
+    join (x:xs) (y:ys)
+        | x < y     = x : join xs (y:ys)
+        | x > y     = y : join (x:xs) ys
+        | otherwise = x : join xs ys
+    join xs []  = xs
+    join [] ys  = ys
 
-elemsOn :: (Ord a, Ord b) => M.Map a (S.Set b) -> a -> [b]
-elemsOn m x = case x `M.lookup` m of
-    Just s  -> S.toList s
-    Nothing -> []
+    -- Version of f function working on label sets.
+    f'Set v w = S.fromList . map (f v w) . S.toList
 
-fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> M.Map k a
-fromListWith f xs =
-    let update m (!k, !x) = M.insertWith' f k x m
-    in  foldl' update M.empty xs
+-- | A specialized version of the 'mergeWith' function which doesn't
+-- change labels in the resultant 'D.DAWG'.
+merge
+    :: Ord a => BaseMap
+    -> D.DAWG (S.Set a)
+    -> D.DAWG (M.Map a RelCode)
+merge = mergeWith $ \_ _ x -> x
+
+elemsOn :: D.DAWG (S.Set Rule) -> String -> [String]
+elemsOn m x = case x `D.lookup` m of
+    Just s  ->
+        [ T.unpack . apply rule . T.pack $ x
+        | rule <- S.toList s ]
+    Nothing -> []
diff --git a/polimorf.cabal b/polimorf.cabal
--- a/polimorf.cabal
+++ b/polimorf.cabal
@@ -1,5 +1,5 @@
 name:               polimorf
-version:            0.4.1
+version:            0.5.0
 synopsis:           Working with the PoliMorf dictionary
 description:
     The library provides functionality for manipulating PoliMorf, the
@@ -23,6 +23,7 @@
       , containers
       , text
       , binary
+      , dawg >= 0.5 && < 0.6
 
     exposed-modules:
         Data.PoliMorf