diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> main = defaultMain
diff --git a/hist-pl-fusion.cabal b/hist-pl-fusion.cabal
new file mode 100644
--- /dev/null
+++ b/hist-pl-fusion.cabal
@@ -0,0 +1,45 @@
+name:               hist-pl-fusion
+version:            0.3.0
+synopsis:           Merging historical dictionary with PoliMorf
+description:
+    The library provides functions for merging historical dictionary
+    with PoliMorf morphological dictionary.
+license:            BSD3
+license-file:       LICENSE
+cabal-version:      >= 1.6
+copyright:          Copyright (c) 2013 IPI PAN
+author:             Jakub Waszczuk
+maintainer:         waszczuk.kuba@gmail.com
+stability:          experimental
+category:           Natural Language Processing
+homepage:           https://github.com/kawu/hist-pl/tree/master/fusion
+build-type:         Simple
+
+library
+    hs-source-dirs:   src
+    build-depends:
+        base >= 4 && < 5
+      , containers
+      , text
+      , binary
+      , text-binary
+      , dawg >= 0.9 && < 0.10
+      , polimorf >= 0.7.1 && < 0.8
+      , hist-pl-lexicon >= 0.3 && < 0.4
+
+    exposed-modules:
+        NLP.HistPL.Fusion
+
+    ghc-options: -Wall
+
+source-repository head
+    type: git
+    location: https://github.com/kawu/hist-pl.git
+
+executable hist-pl-fuse
+    build-depends:
+        binary
+      , cmdargs
+    hs-source-dirs: src, tools
+    main-is: hist-pl-fuse.hs
+    ghc-options: -Wall -O2
diff --git a/src/NLP/HistPL/Fusion.hs b/src/NLP/HistPL/Fusion.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/HistPL/Fusion.hs
@@ -0,0 +1,387 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
+module NLP.HistPL.Fusion
+(
+-- * Rule
+  Rule (..)
+, apply
+, between
+
+-- * Basic types
+, UID
+, POS
+, Word
+, Base
+, IsBase
+
+-- * Dictionary
+-- ** Entry
+, Lex (..)
+, LexKey (..)
+, LexElem (..)
+, LexSet
+, mkLexSet
+, unLexSet
+-- ** Dictionary
+, Dict
+, BaseDict
+, FormDict
+, mkDict
+, unDict
+, revDict
+, lookup
+, entries
+-- ** Bilateral
+, Bila (..)
+, mkBila
+, withForm
+-- ** Historical
+, Hist
+, mkHist
+, HLex
+-- ** Contemporary
+, Poli
+, PLex
+, PLexSet
+, mkPoli
+
+-- * Correspondence
+, Corresp
+, buildCorresp
+-- ** Components
+, Core
+, Filter
+, Choice
+, byForms
+, posFilter
+, sumChoice
+
+-- * Fusion
+, Fused
+, FLex
+, Code (..)
+, extend
+, fuse
+) where
+
+import Prelude hiding (lookup)
+import Control.Applicative ((<$>), (<*>))
+import Control.Arrow (first)
+import Data.Binary (Binary, get, put)
+import Data.Text.Binary ()
+import qualified Data.Set as S
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Data.PoliMorf as P
+import qualified Data.DAWG.Static as D
+
+import qualified NLP.HistPL as H
+
+-- | A rule for translating a form into another form.
+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)
+
+instance Binary Rule where
+    put Rule{..} = put cut >> put suffix
+    get = Rule <$> get <*> get
+
+-- | Apply the rule.
+apply :: Rule -> T.Text -> T.Text
+apply r x = T.take (T.length x - cut r) x `T.append` suffix r
+
+-- | 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
+
+------------------------------------------------------------------------
+
+-- | Unique ID in historical dictionary.
+type UID = Int
+
+-- | Part of speech.
+type POS = T.Text
+
+-- | Base form.
+type Base = T.Text
+
+-- | Word form.
+type Word = T.Text
+
+-- | Is the word form a base form?
+type IsBase = Bool
+
+------------------------------------------------------------------------
+
+-- | A lexical entry.
+data Lex i a b = Lex
+    { lexKey    :: LexKey i
+    , lexElem   :: LexElem a b }
+    deriving (Show, Eq, Ord)
+
+-- | Transform entry into a list.
+listLex :: Lex i a b -> [(T.Text, i, a, T.Text, b)]
+listLex Lex{..} =
+    [ (key, uid, info, word, y)
+    | (word, y) <- M.assocs forms ]
+  where
+    LexKey{..}  = lexKey
+    LexElem{..} = lexElem
+
+-- | Lexical entry dictionary key.
+data LexKey i = LexKey
+    { key   :: T.Text
+    , uid   :: i }
+    deriving (Show, Eq, Ord)
+
+-- | Lexical entry info.
+data LexElem a b = LexElem
+    { info  :: a
+    , forms :: M.Map Word b }
+    deriving (Show, Eq, Ord)
+
+-- | A set of lexical entries in a map form.
+type LexSet i a b = M.Map (LexKey i) (LexElem a b) 
+
+-- | Make lexical set from a list of entries.
+mkLexSet :: Ord i => [Lex i a b] -> LexSet i a b
+mkLexSet = M.fromList . map ((,) <$> lexKey <*> lexElem)
+
+-- | List lexical entries.
+unLexSet :: LexSet i a b -> [Lex i a b]
+unLexSet = map (uncurry Lex) . M.toList
+
+------------------------------------------------------------------------
+
+type RuleEntry i a b = M.Map i (a, M.Map Rule b)
+
+-- | One-way dictionary parametrized over ID @i@, with info @a@ for every
+-- (key, i) pair and info @b@ for every (key, i, apply rule key) triple.
+type Dict i a b = D.DAWG Char () (M.Map i (a, M.Map Rule b))
+
+-- | Dictionary keys represent base forms and rules transform base forms to
+-- their corresponding word forms.  Info @a@ is assigned to every lexeme
+-- and info @b@ to every word form.
+type BaseDict i a b = Dict i a b
+
+-- | Dictionary keys represent word forms and rules transform word forms to
+-- their corresponding base forms.  Info @a@ is assigned to every lexeme
+-- and info @b@ to every word form.
+type FormDict i a b = Dict i a b
+
+-- | Decode dictionary entry.
+decode :: Ord i => T.Text -> RuleEntry i a b -> LexSet i a b
+decode key ruleEntry = mkLexSet
+    [ Lex
+        (LexKey key i)
+        (LexElem x $ M.fromList
+            [ (apply rule key, y)
+            | (rule, y) <- M.assocs ruleMap ])
+    | (i, (x, ruleMap)) <- M.assocs ruleEntry ]
+
+-- | Lookup the key in the dictionary.
+lookup :: Ord i => T.Text -> Dict i a b -> LexSet i a b
+lookup key dict = decode key $ case D.lookup (T.unpack key) dict of
+    Just m  -> m
+    Nothing -> M.empty
+
+-- | List dictionary lexical entries.
+entries :: Ord i => Dict i a b -> [Lex i a b]
+entries =
+    let f = unLexSet . uncurry decode . first T.pack 
+    in  concatMap f . D.assocs
+
+-- | Make dictionary from a list of (key, ID, key\/ID info, elem,
+-- key\/ID\/elem info) tuples.
+mkDict :: (Ord i, Ord a, Ord b) => [(T.Text, i, a, T.Text, b)] -> Dict i a b
+mkDict xs = D.fromListWith union $
+    [ ( T.unpack x
+      , M.singleton i
+        (a, M.singleton (between x y) b) )
+    | (x, i, a, y, b) <- xs ]
+  where
+    union = M.unionWith $ both const M.union
+    both f g (x, y) (x', y') = (f x x', g y y')
+
+-- | Transform dictionary back into the list of (key, ID, key\/ID info, elem,
+-- key\/ID\/elem info) tuples.
+unDict :: (Ord i, Ord a, Ord b) => Dict i a b -> [(T.Text, i, a, T.Text, b)]
+unDict = concatMap listLex . entries
+
+-- | Reverse the dictionary.
+revDict :: (Ord i, Ord a, Ord b) => Dict i a b -> Dict i a b
+revDict = 
+    let swap (base, i, x, form, y) = (form, i, x, base, y)
+    in  mkDict . map swap . unDict
+
+------------------------------------------------------------------------
+
+-- | Bilateral dictionary.
+data Bila i a b = Bila
+    { baseDict  :: BaseDict i a b
+    , formDict  :: FormDict i a b }
+    deriving (Show, Eq, Ord)
+
+instance (Ord i, Binary i, Binary a, Binary b) => Binary (Bila i a b) where
+    put Bila{..} = put baseDict >> put formDict
+    get = Bila <$> get <*> get
+
+-- | Make bilateral dictionary from a list of (base form, ID, additional
+-- lexeme info, word form, additional word form info) tuples.
+mkBila :: (Ord i, Ord a, Ord b) => [(Base, i, a, Word, b)] -> Bila i a b
+mkBila xs = Bila
+    { baseDict  = baseDict'
+    , formDict  = formDict' }
+  where
+    baseDict'   = mkDict xs
+    formDict'   = revDict baseDict'
+
+-- | Identify entries which contain given word form.
+withForm :: Ord i => Bila i a b -> Word -> LexSet i a b
+withForm Bila{..} word = M.unions
+    [ lookup base baseDict
+    | (_, lexElem) <- M.assocs (lookup word formDict)
+    , base <- M.keys (forms lexElem) ]
+
+------------------------------------------------------------------------
+
+-- | PoliMorf dictionary in a bilateral form.
+type Poli = Bila POS () ()
+
+-- | PoliMorf dictionary entry.
+type PLex = Lex POS () ()
+
+-- | Set of PoliMorf dictionary entries.
+type PLexSet = LexSet POS () ()
+
+-- | Make bilateral dictionary from PoliMorf.
+mkPoli :: [P.Entry] -> Poli
+mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)
+
+------------------------------------------------------------------------
+
+-- | Historical dictionary.
+type Hist = BaseDict UID (S.Set POS) IsBase
+
+-- | Historical dictionary entry.
+type HLex = Lex UID (S.Set POS) IsBase
+
+-- | Construct historical dictionary.
+mkHist :: [H.BinEntry] -> Hist
+mkHist xs = mkDict
+    [ ( H.keyForm key
+      , H.keyUid key
+      , S.fromList (H.pos entry)
+      , form
+      , isBase )
+    | binEntry <- xs
+    , let key = H.binKey binEntry
+    , let entry = H.lexEntry binEntry
+    , (form, isBase) <-
+        map (,True) (lemmas entry) ++
+        map (,False) (forms entry)
+    , oneWord form ]
+  where
+    lemmas = H.text . H.lemma
+    forms  = concatMap H.text . H.forms
+    oneWord = (==1) . length . T.words
+
+------------------------------------------------------------------------
+
+-- | A function which determines entries from a bilateral
+-- dictionary corresponing to a given historical lexeme.
+type Corresp = Poli -> HLex -> PLexSet
+
+-- | We provide three component types, `Core`, `Filter` and `Choice`, which
+-- can be combined together using the `buildCorresp` function to construct
+-- a `Corresp` function.  The first one, `Core`, is used to identify a list
+-- of potential sets of lexemes.  It is natural to define the core function
+-- in such a way because the task of determining corresponding lexemes can
+-- be usually divided into a set of smaller tasks of the same purpose.
+-- For example, we may want to identify `LexSet`s corresponding to individual
+-- word forms of the historical lexeme.
+type Core = Poli -> HLex -> [PLexSet]
+
+-- | Function which can be used to filter out lexemes which do not
+-- satisfy a particular predicate.  For example, we may want to filter
+-- out lexemes with incompatible POS value.
+type Filter = HLex -> PLex -> Bool
+
+-- | The final choice of lexemes.  Many different strategies can be used
+-- here -- sum of the sets, intersection, or voting.
+type Choice = [PLexSet] -> PLexSet
+
+-- | Identify `LexSet`s corresponding to individual word forms of the
+-- historical lexeme using the `withForm` function.
+byForms :: Core
+byForms bila Lex{..} =
+    [ withForm bila word
+    | word <- M.keys (forms lexElem) ]
+
+-- | Filter out lexemes with POS value incompatible with the
+-- set of POS values assigned to the historical lexeme.
+posFilter :: Filter
+posFilter h p = uid (lexKey p) `S.member` info (lexElem h)
+
+-- | Sum of sets of lexemes.
+sumChoice :: Choice
+sumChoice = M.unions
+
+-- | Build `Corresp` function form individual components.
+buildCorresp :: Core -> Filter -> Choice -> Corresp
+buildCorresp core filt choice bila hLex =
+    let filterSet = mkLexSet . filter (filt hLex) . unLexSet
+    in  choice . map filterSet . core bila $ hLex
+
+------------------------------------------------------------------------
+
+-- | Fused dictionary.
+type Fused = BaseDict UID () Code
+
+-- | Fused dictionary entry.
+type FLex = Lex UID () Code
+
+-- | Code of word form origin.
+data Code
+    = Orig  -- ^ original (was already present in `HLex`)
+    | Copy  -- ^ a copy (from corresponding lexeme)
+    deriving (Show, Eq, Ord)
+
+instance Binary Code where
+    put Orig = put '1'
+    put Copy = put '2'
+    get = get >>= \x -> return $ case x of
+        '1' -> Orig
+        '2' -> Copy
+        c   -> error $ "get: invalid Code value '" ++ [c] ++ "'"
+
+-- | Extend lexeme with forms from the set of lexemes.
+extend :: HLex -> PLexSet -> FLex
+extend hLex lexSet = subForms . M.fromList $
+    concatMap (fromElem Copy) (M.elems lexSet) ++
+    fromElem Orig (lexElem hLex)
+  where
+    subForms x = hLex { lexElem = LexElem () x }
+    fromElem code = map (,code) . (M.keys . forms)
+
+-- | Fuse the historical dictionary with bilateral contemporary
+-- dictionary using the given `Corresp` function to determine
+-- contemporary lexemes corresponding to individual lexemes
+-- from the historical dictionary.
+fuse :: Corresp -> Hist -> Poli -> Fused
+fuse corr hist bila = mkDict
+    [ (key, uid, (), word, code)
+    | hLex <- entries hist
+    , let Lex{..} = extend hLex (corr bila hLex)
+    , let LexKey{..} = lexKey
+    , (word, code) <- M.assocs (forms lexElem) ]
diff --git a/tools/hist-pl-fuse.hs b/tools/hist-pl-fuse.hs
new file mode 100644
--- /dev/null
+++ b/tools/hist-pl-fuse.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import           Control.Applicative ((<$>))
+import           System.Console.CmdArgs
+import           Data.Binary (encodeFile)
+
+import qualified Data.PoliMorf as P
+import qualified NLP.HistPL as H
+import qualified NLP.HistPL.Fusion as F
+
+data HistPL_Fuse = HistPL_Fuse
+    { histPath      :: FilePath
+    , poliPath      :: FilePath
+    , outPath       :: FilePath }
+  deriving (Data, Typeable, Show)
+
+histFuse :: HistPL_Fuse
+histFuse = HistPL_Fuse
+    { histPath = def &= typ "HistPL-Binary" &= argPos 0
+    , poliPath = def &= typ "PoliMorf" &= argPos 1
+    , outPath  = def &= typ "Output-Analysis-DAWG" &= argPos 2 }
+
+main :: IO ()
+main = exec =<< cmdArgs histFuse
+
+exec :: HistPL_Fuse -> IO ()
+exec HistPL_Fuse{..} = do
+    poli <- F.mkPoli . filter P.atomic <$> P.readPoliMorf poliPath
+    hist <- H.load histPath >>= \x -> case x of
+    	Nothing -> error "hist-pl-fuse: not a binary historical dictionary"
+	Just xs -> return $ F.mkHist xs
+    let dict = F.fuse corr hist poli
+    encodeFile outPath (F.revDict dict)
+  where
+    corr = F.buildCorresp F.byForms F.posFilter F.sumChoice