diff --git a/nerf.cabal b/nerf.cabal
--- a/nerf.cabal
+++ b/nerf.cabal
@@ -1,5 +1,5 @@
 name:               nerf
-version:            0.5.0
+version:            0.5.1
 synopsis:           Nerf, the named entity recognition tool based on linear-chain CRFs
 description:
     The package provides the named entity recognition (NER) tool divided into a
@@ -47,7 +47,8 @@
       , tokenize            == 0.1.3
       , mtl                 >= 2.1      && < 2.2
       , network             >= 2.3      && < 2.4
-      , cmdargs
+      , cmdargs             >= 0.10     && < 0.11
+      , IntervalMap         >= 0.3      && < 0.4
 
     exposed-modules:
         NLP.Nerf
@@ -74,7 +75,7 @@
   hs-source-dirs: src, tools
   build-depends:
     filepath            >= 1.3      && < 1.4,
-    directory           >= 1.2      && < 1.3,
+    directory           >= 1.1      && < 1.3,
     temporary           >= 1.1      && < 1.2
   main-is: nerf.hs
   ghc-options: -Wall -O2 -threaded -rtsopts
diff --git a/src/NLP/Nerf.hs b/src/NLP/Nerf.hs
--- a/src/NLP/Nerf.hs
+++ b/src/NLP/Nerf.hs
@@ -26,7 +26,7 @@
 import qualified Data.CRF.Chain1 as CRF
 
 import NLP.Nerf.Types
-import NLP.Nerf.Tokenize (tokenize, moveNEs)
+import NLP.Nerf.Tokenize (tokenize, sync)
 import NLP.Nerf.Schema (SchemaConf, Schema, fromConf, schematize)
 
 -- | A Nerf consists of the observation schema configuration and the CRF model.
@@ -50,7 +50,7 @@
 -- | Tokenize sentence with the Nerf tokenizer.
 reTokenize :: N.NeForest NE Word -> N.NeForest NE Word
 reTokenize ft = 
-    moveNEs ft ((doTok . leaves) ft)
+    sync ft ((doTok . leaves) ft)
   where 
     doTok  = map T.pack . tokenize . intercalate " "  . map T.unpack
     leaves = concatMap $ foldMap (either (const []) (:[]))
diff --git a/src/NLP/Nerf/Tokenize.hs b/src/NLP/Nerf/Tokenize.hs
--- a/src/NLP/Nerf/Tokenize.hs
+++ b/src/NLP/Nerf/Tokenize.hs
@@ -1,20 +1,23 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 
+
 -- | The module implements the tokenization used within Nerf
 -- and some other tokenization-related stuff.
 
+
 module NLP.Nerf.Tokenize
 (
 -- * Tokenization
   tokenize
 -- * Synchronization
 , Word (..)
-, moveNEs
+, sync
 ) where
 
-import Control.Monad ((>=>))
-import Data.Foldable (foldMap)
+
+import           Control.Arrow (second)
+import           Control.Monad ((>=>))
 import qualified Data.Char as Char
 import qualified Data.List as L
 import qualified Data.Tree as T
@@ -22,13 +25,16 @@
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LazyText
 import qualified NLP.Tokenize as Tok
+import qualified Data.IntervalMap.Strict as I
 
-import Data.Named.Tree (NeForest, NeTree, groupForestLeaves)
+import           Data.Named.Tree (NeForest, NeTree)
 
----------------------------
--- Tokenization definition.
----------------------------
 
+-------------------------------------
+-- Tokenization definition
+-------------------------------------
+
+
 -- | Default tokenizator.
 defaultTokenizer :: Tok.Tokenizer
 defaultTokenizer
@@ -36,115 +42,142 @@
     >=> Tok.uris
     >=> Tok.punctuation
 
+
 -- | Tokenize sentence using the default tokenizer.
 tokenize :: String -> [String]
 tokenize = Tok.run defaultTokenizer
 
----------------------------------------------------------------
--- Synchronizing named entities with new sentence tokenization.
----------------------------------------------------------------
 
+-------------------------------------
+-- Word
+-------------------------------------
+
+
 -- | A class of objects which can be converted to `String`.
 class Word a where
     word :: a -> String
 
+
 instance Word String where
     word = id
 
+
 instance Word Text.Text where
     word = Text.unpack
 
+
 instance Word LazyText.Text where
     word = LazyText.unpack
 
+
 essence :: Word a => a -> Int
 essence = length . filter (not . Char.isSpace) . word
 {-# INLINE essence #-}
 
--- | Syncronization between two sentences.  Each (xs, ys) pair represents
--- tokens from the two input sentences which corresponds to each other.
-type Sync a b = [([a], [b])]
 
--- | Synchronize two tokenizations of the sentence.
-sync :: (Word a, Word b) => [a] -> [b] -> Sync a b
-sync = sync' 0
+-------------------------------------
+-- Grouping leaves
+-------------------------------------
 
-sync' :: (Word a, Word b) => Int -> [a] -> [b] -> Sync a b
-sync' r (x:xs) (y:ys)
-    | n + r == m    = ([x], [y])    : sync' 0       xs    ys
-    | n + r  < m    = join x        $ sync' (n + r) xs (y:ys)
-    | otherwise     = swap . join y $ sync' (m - r) ys (x:xs)
-  where
-    n = essence x
-    m = essence y
-    join l ((ls, rs) : ps)  = (l:ls, rs) : ps
-    join _ []               = error "sync'.join: bad arguments"
-    swap ((ls, rs) : ps)    = (rs, ls) : swap ps
-    swap []                 = []
-sync' 0 [] [] = []
-sync' _ _  _  = error "sync': bad arguments"
 
--- | Match the `Sync` with the given list, return the matching result
--- (snd elements of the `Sync` list) and the rest of the `Sync` list.
-match :: (Word a, Word b) => [a] -> Sync a b -> ([b], Sync a b)
-match xs ss =
-    let (sl, sr) = splitAcc isMatch 0 ss
-    in  (concatMap snd sl, sr)
-  where
-    n = sum (map essence xs)
-    isMatch r (ys, _)
-        | m + r < n     = (m + r, False)
-        | m + r == n    = (m + r, True)
-        | otherwise     = error "match.isMatch: no match"
-      where
-        m = sum (map essence ys)
-
--- | Split the list with the help of the accumulating function.
-splitAcc :: (acc -> a -> (acc, Bool)) -> acc -> [a] -> ([a], [a])
-splitAcc _ _ [] = ([], [])
-splitAcc f acc (x:xs)
-    | cond      = ([x], xs)
-    | otherwise = join x (splitAcc f acc' xs)
-  where
-    (acc', cond) = f acc x
-    join y (ys, zs) = (y:ys, zs)
-
--- | List forest leaves.
-leaves :: NeForest a b -> [b]
-leaves = concatMap $ foldMap (either (const []) (:[]))
-
 unGroupLeaves :: NeForest a [b] -> NeForest a b
 unGroupLeaves = concatMap unGroupLeavesT
 
+
 unGroupLeavesT :: NeTree a [b] -> [NeTree a b]
 unGroupLeavesT (T.Node (Left v) xs)     =
     [T.Node (Left v) (unGroupLeaves xs)]
 unGroupLeavesT (T.Node (Right vs) _)   =
     [T.Node (Right v) [] | v <- vs]
 
-substGroups :: (Word b, Word c) => NeForest a [b] -> Sync b c -> NeForest a [c]
-substGroups fs ss = snd $ L.mapAccumL substGroupsT ss fs
 
-substGroupsT
-    :: (Word b, Word c)
-    => Sync b c -> NeTree a [b]
-    -> (Sync b c, NeTree a [c])
-substGroupsT =
-    Tr.mapAccumL f
+---------------------------------------------------------------
+-- Identifying ranges
+---------------------------------------------------------------
+
+
+type Range = I.Interval Int
+
+
+-- | Range computation step.
+ranged :: Word a => Int -> a -> (Int, (Range, a))
+ranged p w =
+    (q, (i, w))
   where
-    f s (Left v)  = (s, Left v)
-    f s (Right v) =
-        let (v', s') = match v s
-        in  (s', Right v')
+    q = p + essence w
+    i = I.IntervalCO p q
 
--- | Synchronize named entities with tokenization represented
--- by the second function argument.  Of course, both arguments
--- should relate to the same sentence.
-moveNEs :: (Word b, Word c) => NeForest a b -> [c] -> NeForest a c
-moveNEs ft ys
-    = unGroupLeaves
-    $ substGroups
-        (groupForestLeaves true ft)
-        (sync (leaves ft) ys)
+
+-- | Compute ranges of individual tokens.
+rangedList :: Word a => [a] -> [(Range, a)]
+rangedList = snd . L.mapAccumL ranged 0
+
+
+-- | Compute ranges of individual tokens.
+rangedForest :: Word b => NeForest a b -> NeForest a (Range, b)
+rangedForest = 
+    snd . L.mapAccumL (Tr.mapAccumL f) 0
   where
-    true _ _ = True
+    f acc (Left x)  = (acc, Left x)
+    f acc (Right x) =
+        let (acc', y) = ranged acc x
+        in  (acc', Right y)
+        
+
+---------------------------------------------------------------
+-- Synchronizing named entities with new sentence tokenization
+---------------------------------------------------------------
+
+
+-- | Replace leaves in the NE forest with corresponding tokens.
+replaceToks
+    :: I.IntervalMap Int c
+    -> NeForest a (Range, b)
+    -> ( I.IntervalMap Int c
+       , NeForest a (Range, c) )
+replaceToks ivMap nes
+    = second unGroupLeaves
+    $ L.mapAccumL (Tr.mapAccumL replace) ivMap nes
+  where
+    replace im (Left x) = (im, Left x)
+    replace im (Right (ran, _)) =
+        let rsXs = I.intersecting im ran
+            im'  = L.foldl' (flip I.delete) im (map fst rsXs)
+        in  (im', Right rsXs)
+
+
+-- | Lift the first range of a tree to the top.
+liftRange :: NeTree a (Range, b) -> (Range, NeTree a b)
+liftRange (T.Node (Left v) xs) =
+    (ran, T.Node (Left v) (map snd ys))
+  where
+    ys = map liftRange xs
+    ran = maybeHead $ map fst ys
+    maybeHead (x:_) = x
+    maybeHead []    = error "liftRange: invalid NE tree"
+liftRange (T.Node (Right (ran, v)) _) = (ran, T.Node (Right v) [])
+
+
+-- | Synchronize the list of NE trees with the new tokenization.
+sync
+    :: (Word b, Word c)
+    => NeForest a b     -- ^ NE forest
+    -> [c]              -- ^ New tokenization
+    -> NeForest a c     -- ^ Resulting NE forest
+sync nes0 xs0
+    = map snd . I.toList . I.fromList
+    $ map (second mkLeaf) (I.toList ivMap')
+    ++ map liftRange nes'
+  where
+    -- Interval map of the new tokenization
+    ivMap = I.fromList $ rangedList xs0
+    -- NE non-leaf trees with ranges
+    nes = filter internal $ rangedForest nes0
+    -- Replace tokens...
+    (ivMap', nes') = replaceToks ivMap nes
+    -- Is it an internal node?
+    internal x = case T.rootLabel x of
+        Left _  -> True
+        Right _ -> False
+    -- Make a leaf tree
+    mkLeaf x = T.Node (Right x) []
diff --git a/src/NLP/Nerf/XCES.hs b/src/NLP/Nerf/XCES.hs
--- a/src/NLP/Nerf/XCES.hs
+++ b/src/NLP/Nerf/XCES.hs
@@ -340,7 +340,7 @@
 -- nerSent :: Nerf.Nerf -> Sent [] -> Sent Ann
 nerSent :: (String -> NeForest NE Word) -> Sent [] -> Sent Ann
 nerSent nerFun s@Sent{..} = s
-    { sentCon = Ann $ Tok.moveNEs
+    { sentCon = Ann $ Tok.sync
         (nerFun $ restoreOrigSent sentCon)
         sentCon }