morfette (empty) → 0.2
raw patch · 34 files changed
+2251/−0 lines, 34 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, binary, bytestring, containers, directory, filepath, haskell98, mtl, pretty, utf8-string
Files
- GramLab/Binomial.hs +60/−0
- GramLab/Commands.hs +54/−0
- GramLab/Data/Assoc.hs +29/−0
- GramLab/Data/CommonSubstrings.hs +61/−0
- GramLab/Data/Diff/EditList.hs +10/−0
- GramLab/Data/Diff/EditListRev.hs +14/−0
- GramLab/Data/Diff/EditTree.hs +52/−0
- GramLab/Data/LCS/SimpleMemo.hs +139/−0
- GramLab/Data/StringLike.hs +56/−0
- GramLab/FeatureSet.hs +56/−0
- GramLab/Intern.hs +59/−0
- GramLab/Morfette/BinaryInstances.hs +28/−0
- GramLab/Morfette/Config.hs +19/−0
- GramLab/Morfette/Evaluation.hs +78/−0
- GramLab/Morfette/Features/Common.hs +51/−0
- GramLab/Morfette/LZipper.hs +48/−0
- GramLab/Morfette/Lang/Conf.hs +84/−0
- GramLab/Morfette/MWE.hs +44/−0
- GramLab/Morfette/Models.hs +143/−0
- GramLab/Morfette/Settings/Defaults.hs +15/−0
- GramLab/Morfette/Token.hs +31/−0
- GramLab/Morfette/Utils.hs +255/−0
- GramLab/Perceptron/IntModel.hs +72/−0
- GramLab/Perceptron/Model.hs +177/−0
- GramLab/Perceptron/Multiclass.hs +160/−0
- GramLab/Perceptron/Vector.hs +76/−0
- GramLab/Utils.hs +98/−0
- LICENSE +26/−0
- Lemma.hs +42/−0
- Main.hs +14/−0
- POS.hs +41/−0
- README +115/−0
- Setup.lhs +8/−0
- morfette.cabal +36/−0
+ GramLab/Binomial.hs view
@@ -0,0 +1,60 @@+module GramLab.Binomial (binomialTest)+where+import qualified Data.List as List+import Debug.Trace+import Test.QuickCheck+-- | Calculates the two-sided p-value for n trials and c successes with probability 0.5+binomialTest n c | c > n = error "GramLab.Binomial.binomialTest c greater than n"+binomialTest n c = 1 `min` (2 * if c >= n `div` 2 + then binomialTestGreater n 0.5 c + else binomialTestGreater n 0.5 (n-c))+-- | Calculates the one-sided p-value for n trials and c successes with probability p+binomialTestGreater :: Integer -> Double -> Integer -> Double+binomialTestGreater n p c = sum $ fmap (\(pr1,pr2,pw1,pw2) -> fromIntegral (pr1 `div` pr2) * pw1 * pw2) $+ List.zip4 (products1 n c)+ (products2 n c)+ (powers1 p n c)+ (powers2 p n c)+divv a b | trace (show (a,b)) False = undefined+divv a b = a `div` b ++-- | +spec_products1 n c = fmap (\x -> product [x+1..n]) [c..n]+--products1 :: Int -> Int -> [Int]+products1 n c | c == n = [1]+ | c+1 == n = [n,1] --+ | otherwise = let x:xs = products1 n (c+1) in ((1+c)*x):x:xs++-- | +spec_products2 n c = fmap (\x -> product [1..n-x]) [c..n]+--products2 :: Int -> Int -> [Int]+products2 n c | c == n = [1]+ | otherwise = let x:xs = products2 n (c+1) in ((n-c)*x):x:xs++-- | +spec_powers1 p n c = fmap (p^) [c..n]+--powers1 :: Double -> Int -> Int -> [Double]+powers1 p n c = reverse (powers1' [p^c] p n c)+powers1' (x:xs) p n c | n == c = x:xs+ | otherwise = powers1' ((p*x):x:xs) p n (c+1)++-- | +spec_powers2 p n c = fmap (\x -> (1-p)^(n-x)) [c..n]+--powers2 :: Double -> Int -> Int -> [Double]+powers2 p n c | n == c = [1]+ | otherwise = let x:xs = powers2 p n (c+1) in (1-p)*x:x:xs++prop_products1 :: (Integer,Integer) -> Property+prop_products1 (n,c) = n > 0 && c > 0 && n >= c ==> spec_products1 n c == products1 n c++prop_products2 :: (Integer,Integer) -> Property+prop_products2 (n,c) = n > 0 && c > 0 && n >= c ==> spec_products2 n c == products2 n c++epsilon = 1.0e-15++prop_powers1 :: (Double,Integer,Integer) -> Property+prop_powers1 (p,n,c) = p >= 0 && p <= 1 && n > 0 && c > 0 && n >= c + ==> all (<epsilon) (zipWith (\a b -> abs (a-b)) (spec_powers1 p n c) (powers1 p n c))+prop_powers2 :: (Double,Integer,Integer) -> Property+prop_powers2 (p,n,c) = p >= 0 && p <= 1 && n > 0 && c > 0 && n >= c + ==> all (<epsilon) (zipWith (\a b -> abs (a-b)) (spec_powers2 p n c) (powers2 p n c))
+ GramLab/Commands.hs view
@@ -0,0 +1,54 @@+module GramLab.Commands ( Command+ , CommandName+ , Help+ , CommandSpec (..)+ , module System.Console.GetOpt+ , defaultMain+)+where+import Text.PrettyPrint(renderStyle,render,nest,vcat,hsep,style,Mode(..),mode,text,(<>),($$),($+$),(<+>))+import System.Console.GetOpt+import System+import System.IO (stderr)+import System.IO.UTF8 (hPutStr)+import qualified Data.List as List+++type Command a = ([a] -> [String] -> IO ())+type CLArgName = String+type CommandName = String+type Help = String+data CommandSpec a = CommandSpec (Command a)+ Help + [OptDescr a]+ [CLArgName]++defaultMain commands header = do+ args <- getArgs+ let theUsage = usage commands header+ case args of+ [] -> theUsage []+ command:opts -> case List.lookup command commands of+ Nothing -> theUsage ["Invalid command: " ++ command]+ Just spec -> runCommand theUsage spec opts++runCommand theUsage (CommandSpec command help optDesc argnames) args = + case getOpt Permute optDesc args of+ (o,n,[] ) -> command o n+ (_,_,errs) -> theUsage errs+++usage commands header errs = hPutStr stderr . render + $ vcat (List.map text errs)+ $$ usageMsg commands header++usageMsg commands header = + text header+ $+$ (vcat (List.map commandUsage commands))++commandUsage (name , CommandSpec command help optionDesc args) = + text name <> text ":"+ $$ (nest 10 (text help))+ $$ (text name <+> text "[OPTION...]" <+> hsep (map text args))+ <+> (nest 10 (text $ usageInfo "" optionDesc))+
+ GramLab/Data/Assoc.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module GramLab.Data.Assoc ( Assoc + , fromAssoc+ )+where++import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.List as List++++class (Ord k) => Assoc assoc k v | assoc -> k v where+ toList :: assoc -> [(k,v)]+ fromList :: [(k,v)] -> assoc+ fromAssoc :: (Assoc assoc2 k v) => assoc -> assoc2+ fromAssoc = fromList . toList++instance (Ord k) => Assoc [(k,v)] k v where+ toList = id + fromList = id++instance Assoc (IntMap.IntMap v) Int v where+ toList = IntMap.toAscList+ fromList = IntMap.fromList++instance (Ord k) => Assoc (Map.Map k v) k v where+ toList = Map.toAscList+ fromList = Map.fromList
+ GramLab/Data/CommonSubstrings.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE NoMonomorphismRestriction#-} +module GramLab.Data.CommonSubstrings ( lcs+ , lcsFiltering+ , commonSubstrings+ , substrings+ , toMap+ , CommonSubstring+ , Indices+ )++where++import Data.List+import qualified Data.Map as Map+import Data.Ord+import Data.Char+import qualified GramLab.Data.StringLike as S+++type Indices = ([Int],[Int])+commonSubstrings :: (Ord s, Ord a, S.StringLike s a) => s -> s -> Map.Map s Indices+commonSubstrings xs ys = Map.intersectionWith (,) ((toMap . substrings) xs)+ ((toMap . substrings) ys)++commonSubstringsWith equiv xs ys = [ (x,y,i_x,i_y) | (x,i_x) <- (Map.toList . toMap . substrings) xs+ , (y,i_y) <- (Map.toList . toMap . substrings) ys+ , x `equiv` y ]+collapseVowels [] = []+collapseVowels [x] = [x]+collapseVowels (x:y:xs) | vowel x && vowel y = '@':collapseVowels xs+ | vowel x = '@':collapseVowels (y:xs)+ | otherwise = x :collapseVowels (y:xs)+ where vowel x = x `elem` "ieaou"++equiv xs ys = collapseVowels xs == collapseVowels ys++type CommonSubstring s = (s,Indices)++longest :: (Ord s, Ord a, S.StringLike s a) => Map.Map s Indices -> [CommonSubstring s]+longest = sortBy (flip (comparing (S.length . fst))) . Map.toList++lcs :: (Ord a, Ord s, S.StringLike s a, Monad m) =>+ s -> s -> m (CommonSubstring s)+lcs = lcsFiltering (const True)+lcsFiltering :: (Ord s, Ord a, S.StringLike s a, Monad m) => + (CommonSubstring s -> Bool) + -> s + -> s + -> m (CommonSubstring s)+lcsFiltering f xs ys = case longest (Map.filterWithKey (curry f) (commonSubstrings xs ys)) of+ [] -> fail "lcsFiltering: no common strings"+ (x:_) -> return x++substrings :: (Enum b, Num b,Ord a, S.StringLike s a) => s -> [(s, b)]+substrings xs = [ (S.fromString $ map fst suffix, snd . head $ suffix) + | prefix <- tail $ inits' (zip (S.toString xs) [0..])+ , suffix <- init $ tails prefix ]+inits' = reverse . map reverse . tails . reverse++toMap :: (Ord k) => [(k,v)] -> Map.Map k [v]+toMap = foldr (\(k,v) z -> Map.insertWith (++) k [v] z) Map.empty
+ GramLab/Data/Diff/EditList.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module GramLab.Data.Diff.EditList ( make+ , apply+ , check+ , EditList+ )+where+import GramLab.Data.LCS.SimpleMemo (ses, check, apply, EditScript(..)) +type EditList a = EditScript a+make = ses
+ GramLab/Data/Diff/EditListRev.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module GramLab.Data.Diff.EditListRev ( make+ , apply+ , check+ , EditListRev(ELR)+ , SES.Edit(..)+ )+where+import qualified GramLab.Data.LCS.SimpleMemo as SES+newtype EditListRev a = ELR { un :: SES.EditScript a } deriving (Eq,Ord,Show,Read)+make w w' = ELR $ SES.ses (reverse w) (reverse w')+apply s w = reverse (SES.apply (un s) (reverse w))+check s w = SES.check (un s) (reverse w)+
+ GramLab/Data/Diff/EditTree.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module GramLab.Data.Diff.EditTree ( make+ , apply+ , check+ , split3+ , EditTree(..)+ )+where++import GramLab.Data.CommonSubstrings +import qualified GramLab.Data.StringLike as S+import Data.Maybe (fromMaybe)+import Debug.Trace++make = editTree++data EditTree s a = Split !Int !Int (EditTree s a) (EditTree s a)+ | Replace s s+ deriving (Eq,Ord,Show,Read)+editTree w w' = case lcsi w w' of+ Nothing -> Replace w w'+ Just (i_w,i_w_end,i_w',i_w'_end) -> + let (w_prefix, w_root, w_suffix) = split3 w i_w i_w_end+ (w'_prefix,w'_root, w'_suffix) = split3 w' i_w' i_w'_end+ in Split i_w i_w_end+ (editTree w_prefix w'_prefix)+ (editTree w_suffix w'_suffix)++lcsi w w' = fmap f (lcs w w') + where f (str,(i_w:_,i_w':_)) = (i_w,i_w_end,i_w',i_w'_end)+ where i_w_end = S.length w - i_w - len+ i_w'_end = S.length w' - i_w' - len+ len = S.length str++apply (Replace s s') w = s'+apply (Split i i_end lt rt) w = (apply lt pre) `S.append` root `S.append` (apply rt suf)+ where (pre,root,suf) = split3 w i i_end+ ++split3 w i i_end = let (prefix, rest) = S.splitAt i w + (suffix_r, root_r) = S.splitAt i_end (S.reverse rest)+ in (prefix,(S.reverse root_r),(S.reverse suffix_r))+++check (Replace s s') w = s == w+check (Split i j lt rt) w = len >= i + && len >= j + && check lt w_pre + && check rt w_suf+ where len = S.length w + (w_pre,w_root,w_suf) = split3 w i j+
+ GramLab/Data/LCS/SimpleMemo.hs view
@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------+-- Memoized version of Simple.hs [1] but still simple stupid and slow. +-- foldlcs lcs and ses adapted from Gauche's util.lcs module [2]+-- [1] http://urchin.earth.li/darcs/ian/lcs/Data/List/LCS/Simple.hs+{-# OPTIONS -fglasgow-exts #-}+-- [2] http://www.shiro.dreamhost.com/scheme/gauche/memo.html+module GramLab.Data.LCS.SimpleMemo ( Edit (Ins,Del)+ , EditScript+ , lcs+ , ses + , apply+ , check+ ) +where++import Control.Monad.State+import qualified Data.Map as Map+import Data.Typeable+import Prelude hiding (lookup)+import Maybe (catMaybes)+import Debug.Trace+data Edit a = Ins a Int+ | Del a Int deriving (Eq,Ord,Show,Read,Typeable)+type EditScript a = [Edit a]++-- |The 'lcs' function takes two lists and returns a list with a longest+-- common subsequence of the two.+lcs :: (Ord a, Eq a) => [a] -> [a] -> [a]+lcs xs ys = map (\(x,_,_) -> x) (snd (lcsWithPositions xs ys))++-- |The 'ses' function takes two lists and returns the shortest edit script+-- which would change the first list into the second+ses :: (Ord a, Eq a) => [a] -> [a] -> EditScript a+ses as bs =+ reverse changes+ where aOnly a ((aPos,bPos),zs) = ((aPos+1,bPos),(Del a aPos) : zs)+ bOnly b ((aPos,bPos),zs) = ((aPos,bPos+1),(Ins b aPos) : zs)+ both c ((aPos,bPos),zs) = ((aPos+1,bPos+1),zs)+ (_,changes) = foldlcs aOnly bOnly both ((0,0),[]) as bs++-- |The 'apply' function takes an edit script and a sequence and applies the+-- changes encoded in the script to the sequence.+-- The following holds: apply (ses xs ys) xs == ys+apply :: EditScript a -> [a] -> [a]+apply s xs = concat $ applyIns s $ applyDel s xs++foldlcs aOnly bOnly both seed a b =+ loop common seed a 0 b 0+ where fold f z xs = foldl (\z x -> f x z) z xs+ (len,common) = lcsWithPositions a b+ loop common seed a aPos b bPos + | null common = fold bOnly (fold aOnly seed a) b+ | otherwise = + let ((e,aOff,bOff):commonTail) = common+ aSkip = aOff - aPos+ bSkip = bOff - bPos+ (aHead,aTail) = splitAt aSkip a+ (bHead,bTail) = splitAt bSkip b+ in loop commonTail+ (both e (fold bOnly (fold aOnly seed aHead) bHead))+ (tail aTail)+ (aOff + 1)+ (tail bTail)+ (bOff + 1)++type PosSpec a = (a,Int,Int)+type LCSMemoTable a = Map.Map ((Int,[a]),(Int,[a])) (Int,[PosSpec a]) ++lcsWithPositions :: (Ord a) => [a] -> [a] -> (Int,[PosSpec a])+lcsWithPositions xs ys = evalState (lcs_memo (0,xs) (0,ys)) Map.empty ++lcs_memo :: (Ord a) => (Int,[a]) -> (Int,[a]) -> State (LCSMemoTable a) (Int,[PosSpec a])+lcs_memo xs ys = do+ d <- get+ case Map.lookup (xs,ys) d of+ Nothing -> do+ r <- lcs' lcs_memo xs ys+ modify (Map.insert (xs,ys) r)+ return r+ Just r -> return r+ +lcs' rec (px,x:xs) (py,y:ys)+ | x == y = do + (len,zs) <- rec (px+1,xs) (py+1,ys)+ return (len + 1, (x,px,py):zs)+ | otherwise = do + r1@(l1, _) <- rec (px, x:xs) (py+1,ys)+ r2@(l2, _) <- rec (px+1,xs) (py, y:ys)+ if l1 >= l2 then return r1 else return r2+lcs' _ (_,[]) _ = return (0, [])+lcs' _ _ (_,[]) = return (0, [])+++pos (Del _ i) = i+pos (Ins _ i) = i+isIns (Ins _ _) = True+isIns (Del _ _) = False+isInsAt j (Ins _ i) = i == j+isInsAt _ _ = False+applyDel s xs = + applyDel' 0 s' xs+ where s' = filter (not . isIns) s+applyIns s xs =+ applyIns' 0 s' xs+ where s' = filter isIns s++applyDel' i (e@(Del _ j):es) (x:xs)+ | i == j = [] : applyDel' (i+1) es xs+ | otherwise = [x] : applyDel' (i+1) (e:es) xs+applyDel' i [] xs = map (:[]) xs+applyDel' i es [] = []++applyIns' i es (x:xs) = (insertions ++ x) : applyIns' (i+1) es xs+ where insertions = insertionsAt i es+applyIns' i es [] = [insertionsAt i es]++insertionsAt i es = concatMap (\(Ins c j) -> if j == i then [c] else []) es++check es xs = check' 0 es xs+--check' i es xs | trace (show (i,es,xs)) False = undefined+check' i (e@(Del c j):es) (x:xs) + | i == j = c == x && check' (i+1) es xs + | otherwise = check' (i+1) (e:es) xs+check' i (e@(Ins c j):es) (x:xs)+ | i == j = check' (i+1) (dropWhile (isInsAt i) es) xs+ | otherwise = check' (i+1) (e:es) xs+check' i [] xs = True+check' i (Del {}:_) [] = False+check' i (Ins {}:es) [] = check' (i+1) es [] ++++testset = [ ("carbon","cabron"),("otreum","rirom"),("evita","pabita")+ , ("abcabba","cbabac"),("caballo","lacayo"),("dijeran","decir")+ , ("joroba","jodieron"),("alzheimer","heimat"),("argentina","argentaria")+ , ("morir","murieron"),("ordenadores","computadoras"),("toalla","oatmeal")+ ]+runtest = mapM_ print $ map (\(a,b) -> ((a,b),"=>",(apply (ses a b) a) == b)) testset+
+ GramLab/Data/StringLike.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module GramLab.Data.StringLike (StringLike(..))+where+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import qualified Data.List as List+import Data.Word+import Prelude hiding (length,null,tail,init,splitAt,reverse,map,foldl,foldr)+import qualified Prelude as P+import Codec.Binary.UTF8.String+class StringLike seq a | seq -> a where+ toString :: seq -> [a]+ fromString :: [a] -> seq+ length :: seq -> Int+ length = P.length . toString+ null :: seq -> Bool+ null = P.null . toString+ tail :: seq -> seq + tail = fromString . P.tail . toString+ init :: seq -> seq+ init = fromString . P.init . toString+ tails :: seq -> [seq]+ tails = P.map fromString . List.tails . toString+ inits :: seq -> [seq]+ inits = P.map fromString . List.inits . toString+ splitAt :: Int -> seq -> (seq,seq)+ splitAt i w = let (w',w'') = P.splitAt i (toString w) in (fromString w', fromString w'')+ reverse :: seq -> seq+ reverse = fromString . P.reverse . toString+ append :: seq -> seq -> seq+ append w w' = fromString (toString w ++ toString w')+ cons :: a -> seq -> seq+ cons x xs = fromString $ x: toString xs+ uncons :: seq -> Maybe (a,seq)+ uncons xs = case toString xs of+ (x:xs) -> Just (x,fromString xs)+ _ -> Nothing+ map :: (a -> a) -> seq -> seq+ map f = fromString . map f . toString++instance StringLike [a] a where+ toString = id+ fromString = id++instance StringLike B.ByteString Char where+ toString = decode . B.unpack+ fromString = B.pack . encode+ null = B.null+ append = B.append+++instance StringLike L.ByteString Char where+ toString = decode . L.unpack+ fromString = L.pack . encode+ null = L.null+ append = L.append
+ GramLab/FeatureSet.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE NoMonomorphismRestriction + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleContexts + , FlexibleInstances + #-} +module GramLab.FeatureSet ( Feature (..)+ , FeatureSet+ , toFeatureSet+ )+where+import GramLab.Intern+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List+import qualified GramLab.Utils as Utils+import Data.Maybe+import Data.Ord (comparing)++data Feature sym num = Sym sym+ | Set [sym]+ | Num num+ | Null+ deriving (Show,Read,Eq,Ord)++class FeatureSet coll key sym num | coll -> key sym num where+ toFeatureSet :: (Ord key,Ord sym,Real num) => + coll -> State (Table (key,Maybe sym)) (IntMap.IntMap num)++instance FeatureSet [Feature sym num] Int sym num where+ toFeatureSet = listToFeatureSet+instance FeatureSet [(key,Feature sym num)] key sym num where+ toFeatureSet = assocListToFeatureSet+instance FeatureSet (Map.Map key (Feature sym num)) key sym num where+ toFeatureSet = mapToFeatureSet+++{-# SPECIALIZE INLINE assocListToFeatureSet ::+ [(Int, Feature String Double)]+ -> State (Table (Int, Maybe String)) (IntMap.IntMap Double) #-}+assocListToFeatureSet = liftM (IntMap.fromList . concat) + . mapM (uncurry realFeature) +mapToFeatureSet = assocListToFeatureSet . Map.toList +listToFeatureSet = assocListToFeatureSet . Utils.index++{-# SPECIALIZE INLINE realFeature :: + Int+ -> Feature String Double + -> State (Table (Int, Maybe String)) [(Int, Double)] #-}+realFeature k Null = return []+realFeature k (Sym s) = intern (k,Just s) >>= \i -> return $ [(i,1)]+realFeature k (Num n) = intern (k,Nothing) >>= \i -> return $ [(i,n)]+realFeature k (Set ss) = mapM intern (zip (repeat k) (map Just (Utils.uniq ss))) + >>= \is -> return $ zip is (repeat 1)
+ GramLab/Intern.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NoMonomorphismRestriction#-} + +module GramLab.Intern ( Table(..) + , initial + , intern + , internMany + , unintern + , uninternMany + , maybeIntern + , maybeInternMany + , module Control.Monad.State + ) +where +import Prelude hiding (mapM) +import qualified Data.Map as Map +import Control.Monad.State hiding (mapM) +import Data.Traversable (mapM) + +data Table a = T !Int (Map.Map a Int) deriving (Eq,Read,Show) + + + +initial = (T 0 Map.empty) + +intern :: (Ord k) => k -> State (Table k) Int +intern s = do + (T i m) <- get + case Map.lookup s m of + Nothing -> do + put (T (i+1) (Map.insert s i m)) + return i + Just j -> return j + +internWith hget s = do + (T i m) <- get + case Map.lookup s m of + Nothing -> do + put (T (i+1) (Map.insert s i m)) + return i + Just j -> return j + + + +internMany = mapM intern + + +-- only read existing entries in state +maybeIntern s = do + (T i m) <- get + return $ Map.lookup s m + +maybeInternMany = mapM maybeIntern + + +unintern i = do + m <- get + return $ case Map.lookup i m of { Just x -> x } + +uninternMany = mapM unintern
+ GramLab/Morfette/BinaryInstances.hs view
@@ -0,0 +1,28 @@+module GramLab.Morfette.BinaryInstances +where+import GramLab.Data.Diff.EditListRev+import GramLab.Data.Diff.EditTree +import Data.Binary+import Control.Monad (liftM,liftM2,liftM3,liftM4)+instance Binary a => Binary (Edit a) where+ put (Ins c i) = put (0::Word8) >> put c >> put i+ put (Del c i) = put (1::Word8) >> put c >> put i+ get = do + tag <- get+ case tag::Word8 of+ 0 -> liftM2 Ins get get+ 1 -> liftM2 Del get get++instance Binary s => Binary (EditTree s a) where+ put (Replace xs ys) = put (0::Word8) >> put xs >> put ys+ put (Split i j lt rt) = put (1::Word8) >> put i >> put j + >> put lt >> put rt+ get = do+ tag <- get+ case tag::Word8 of+ 0 -> liftM2 Replace get get+ 1 -> liftM4 Split get get get get++instance Binary a => Binary (EditListRev a) where+ put (ELR x) = put x+ get = liftM ELR get
+ GramLab/Morfette/Config.hs view
@@ -0,0 +1,19 @@+module GramLab.Morfette.Config ( Config(..) + , defaults + )+where +import GramLab.Perceptron.Model+ ++data Config = Config { lemmaConfig :: TrainSettings+ , posConfig :: TrainSettings } deriving (Show,Read) + +defaults = Config { lemmaConfig = TrainSettings { iter = 50+ , rate = 0.1 + , occurTh = 40+ , entropyTh = 0.0 } + , posConfig = TrainSettings { iter = 60 + , rate = 0.1+ , occurTh = 40+ , entropyTh = 0.0 } }+
+ GramLab/Morfette/Evaluation.hs view
@@ -0,0 +1,78 @@+module GramLab.Morfette.Evaluation ( accuracy+ , tokenAccuracy+ , sentenceAccuracy+ , showAccuracy+ )+where+import GramLab.Morfette.Token+import Data.Maybe+import GramLab.Utils (lowercase)+import Text.Printf+import GramLab.Binomial+++data Accuracy = Acc { lemmaAcc :: AccBL+ , posAcc :: AccBL + , jointAcc :: AccBL }++data AccBL = AccBL { test :: [Bool]+ , baseline :: Maybe [Bool] }++data Experiment = Ex { trials :: Integer+ , successes :: Integer } deriving (Show)+++rer hi lo = ((1-lo)-(1-hi))/(1-lo)++significance :: [Bool] -> [Bool] -> Experiment+significance test baseline = Ex { trials = fromIntegral $ countTrue $ zipWith (/=) test baseline+ , successes = fromIntegral $ countTrue $ zipWith (>) test baseline }+countTrue = sum . map fromEnum+pvalue ex = binomialTest (trials ex) (successes ex)++++tokenAccuracy :: [Token] -> [Token] -> Maybe [Token] -> Accuracy+tokenAccuracy xs ys bl = accuracy (id,id,id) (map tokToPair xs) + (map tokToPair ys) + (fmap (map tokToPair) bl)++sentenceAccuracy :: [[Token]] -> [[Token]] -> Maybe [[Token]] -> Accuracy+sentenceAccuracy xs ys bl = accuracy (map,map,map) (map (map tokToPair) xs) + (map (map tokToPair) ys) + (fmap (map (map tokToPair)) bl)+tokToPair (form,lemma,pos) = (lowercase $ fromMaybe form lemma,pos)+++accuracy (g,h,i) gold test mbl = Acc { lemmaAcc = AccBL (correct (g fst) test) (fmap (correct (g fst)) mbl)+ , posAcc = AccBL (correct (h snd) test) (fmap (correct (h snd)) mbl)+ , jointAcc = AccBL (correct (i id) test) (fmap (correct (i id)) mbl) }+ where correct f ys = zipWith (\x y -> f x == f y) gold ys++++++showAccuracy acc = unlines [ "Lemma acc: " ++ (showAcc . lemmaAcc) acc+ , "POS acc: " ++ (showAcc . posAcc ) acc + , "Joint acc: " ++ (showAcc . jointAcc) acc ]+++showAcc (AccBL t mbl) = case mbl of+ Just bl -> let acc_bl = (length bl, countTrue bl)+ acc_bl_pc = (fromIntegral (snd acc_bl)/(fromIntegral (fst acc_bl)))::Double+ ex = significance t bl+ in printf "%05.2f%% (%d / %d) %+.2f%%, %.2f%% RER, %d different, %d better, p-value: %g"+ (acc_t_pc * 100)+ (snd acc_t) + (fst acc_t) + (acc_t_pc * 100 - acc_bl_pc * 100)+ (rer acc_t_pc acc_bl_pc * 100)+ (trials ex)+ (successes ex)+ (pvalue ex) + Nothing -> printf "%.2f%% (%d / %d)" (100*acc_t_pc) (snd acc_t) (fst acc_t) + where acc_t = (length t, countTrue t)+ acc_t_pc = (fromIntegral (snd acc_t)/(fromIntegral (fst acc_t)))++
+ GramLab/Morfette/Features/Common.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module GramLab.Morfette.Features.Common ( spellingSpec+ , prefixes+ , suffixes+ , lowercase+ , mapSym+ , mapNum+ , getSome+ , module GramLab.Morfette.Models+ , module GramLab.Morfette.Settings.Defaults+ , module GramLab.Morfette.LZipper+ , module GramLab.FeatureSet+ , module GramLab.Morfette.Lang.Conf+ )++where+import GramLab.Morfette.Token +import GramLab.Morfette.LZipper(LZipper)+import GramLab.FeatureSet(FeatureSet)+import Data.Char+import Data.List+import GramLab.FeatureSet+import GramLab.Utils (padRight)+import Data.Binary+import Control.Monad (liftM,liftM2)+import GramLab.Morfette.Settings.Defaults+import GramLab.Morfette.Models+import GramLab.Morfette.LZipper+import GramLab.FeatureSet+import GramLab.Morfette.Lang.Conf++mapSym f (Sym s) = Sym (f s)+mapSym _ x = x+mapNum f (Num n) = Num (f n)+mapNum _ x = x++lowercase = map toLower++suffixes size = padRight Null size . map Sym . take size . drop 1 . reverse . tails+prefixes size = padRight Null size . map Sym . take size . drop 1 . inits+bigrams [] = []+bigrams xs = zipWith ((. return) . (:)) xs (tail xs)+getSome size xs = take size . padRight Nothing size . map Just $ xs+spellingSpec x = map head . group . map collapse $ x++collapse c | isAlpha c && isUpper c = 'X'+ | isAlpha c && isLower c = 'x'+ | isDigit c = '0'+ | c == '-' = '-'+ | c == '_' = '_'+ | otherwise = '*'
+ GramLab/Morfette/LZipper.hs view
@@ -0,0 +1,48 @@+module GramLab.Morfette.LZipper ( LZipper+ , focus+ , left+ , right+ , reset+ , fromList+ , modify+ , slide+ , slideWith+ , slideWith1+ , atEnd )+where+import Data.Maybe+import Debug.Trace++data LZipper a b c = LZ [a] (Maybe b) [c] deriving (Show,Eq,Ord)+left (LZ xs _ _) = xs+focus (LZ _ x _) = x+right (LZ _ _ ys) = ys++fromList [] = LZ [] Nothing [] +fromList (x:xs) = LZ [] (Just x) xs++modify :: (b -> c) -> LZipper a b d -> LZipper a c d+--modify f z@(LZ xs x ys) | trace (show (z,(LZ xs (fmap f x) ys))) False = undefined +modify f (LZ xs x ys) = LZ xs (fmap f x) ys++slide :: LZipper t t c -> LZipper t c c+slide = slideWith id id++slideWith1 :: (c -> b) -> LZipper t t c -> LZipper t b c+slideWith1 = slideWith id++slideWith :: (t -> a) -> (c -> b) -> LZipper a t c -> LZipper a b c+slideWith f g (LZ xs Nothing []) = LZ xs Nothing []+slideWith f g (LZ lxs (Just x) rxs) =+ case rxs of+ y:ys -> LZ (f x:lxs) (Just (g y)) ys+ [] -> LZ (f x:lxs) Nothing []++atEnd = isNothing . focus++reset (LZ [] (Just y) ys) = LZ [] (Just y) ys+reset (LZ [] Nothing []) = LZ [] Nothing []+reset (LZ xs (Just y) ys) = LZ [] (Just z) (zs++[y]++ys)+ where z:zs = reverse xs +reset (LZ xs Nothing []) = LZ [] (Just z) zs+ where z:zs = reverse xs
+ GramLab/Morfette/Lang/Conf.hs view
@@ -0,0 +1,84 @@+module GramLab.Morfette.Lang.Conf ( Lexicon+ , Conf(..)+ , Lang + , makeConf+ , emptyLexicon+ , saveConf+ , readConf+ , toksToLexicon+ , parseLexicon+ , splitPOS+ )+where+import qualified Data.Map as Map+import Data.Binary hiding (decode)+import qualified Data.Binary as Binary (decode)+import qualified Data.ByteString.Lazy as BS+import Data.Maybe (catMaybes)+import GramLab.Utils (padRight,splitWith,splitInto,lowercase)+import GramLab.Morfette.Token++type Lang = String+type Lexicon = Map.Map String [(String, String, Double)]+data Conf = Conf { dictLex :: Lexicon+ , trainLex :: Lexicon + , lang :: Lang } deriving (Eq)++instance Binary Conf where+ put (Conf x y z) = put x >> put y >> put z+ get = do+ x <- get+ y <- get+ z <- get+ return (Conf x y z)++emptyLexicon = Map.empty++makeConf = Conf++saveConf :: FilePath -> Conf -> IO ()++saveConf path lex = do+ BS.writeFile path (encode lex)++readConf :: FilePath -> IO Conf+readConf path = do+ txt <- BS.readFile path+ return (Binary.decode txt)++toksToLexicon :: [Token] -> Lexicon+toksToLexicon xs = + Map.map + (\ys -> let ms = Map.fromListWith (+) + . map (\x -> (x,1))+ $ ys+ size = fromIntegral $ Map.size ms+ in map (\((lemma,pos),count) + -> (lemma,pos,fromIntegral count/size))+ . Map.toList + $ ms)+ . foldr (\(form,lemma,pos) m -> + Map.insertWith (++) form [(lemma,pos)] m) Map.empty + . catMaybes $ flip map xs $ \x ->+ case x of+ (form, Just lemma, Just pos) -> + Just (lowercase form, lowercase lemma,lowercase pos)+ _ -> Nothing++parseLexicon text = Map.fromList . map parseEntry . lines $ text+ +parseEntry :: String -> (String, [(String, String, Double)])+parseEntry line = + let (form:pairs) = words line + len = fromIntegral $ length pairs+ in (form,(map (\ [lemma,pos] + -> (lowercase lemma,lowercase pos,1/len)) + (splitInto 2 pairs)))+++splitPOS :: Lang -> String -> [String]+splitPOS "tr" = splitWith (=='+')+splitPOS "pl" = splitWith (==':')+splitPOS "cy" = splitWith (=='-')+splitPOS "ga" = splitWith (=='-')+splitPOS _ = map return
+ GramLab/Morfette/MWE.hs view
@@ -0,0 +1,44 @@+module GramLab.Morfette.MWE ( detectMwes+ , mweSet+ , saveMwes+ , loadMwes + )+where+import GramLab.Utils (join,splitWith,lowercase)+import GramLab.Morfette.Token+import qualified Data.List as List+import qualified Data.Map as Map+import Data.Ord (comparing)+import Data.Char+import Data.Binary+import qualified Data.ByteString.Lazy as BS++mweSep = '_'++mweSet :: [Token] -> [[String]]+mweSet toks = List.sortBy (flip (comparing length))+ . map fst+ . filter ((> 1) . snd)+ . Map.toList+ . Map.fromListWith (+)+ . map (\x -> (x,1)) + . map (splitWith (==mweSep))+ . filter common+ . map tokenForm $ toks+ where common = all (\c -> isLower c || c `elem` [mweSep,'-'])++detectMwes :: [[String]] -> [String] -> [String]+detectMwes mwes [] = []+detectMwes mwes (x:xs) = case List.find (`List.isPrefixOf` xs') mwes of+ Nothing -> x:detectMwes mwes xs+ Just mwe -> let len = length mwe + in join [mweSep] (take len (x:xs)) : drop len (x:xs)+ where xs' = map lowercase (x:xs) ++saveMwes path mwes = do+ BS.writeFile path (encode mwes)+ +loadMwes path = do+ s <- BS.readFile path+ return $ decode s+
+ GramLab/Morfette/Models.hs view
@@ -0,0 +1,143 @@+module GramLab.Morfette.Models ( train+ , trainFun+ , predict + , predictPipeline+ , toModelFun+ , mkPreprune+ , FeatureSpec (..)+ , Smth(..)+ , Tok+ )+where+import GramLab.Morfette.LZipper+import qualified Data.Map as Map+import Data.Map ((!))+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Dynamic+import GramLab.FeatureSet+import qualified GramLab.Perceptron.Model as M+import Data.Traversable (forM)+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe)+import Debug.Trace+import Data.Binary+import Control.Monad (liftM)+import GramLab.Utils (uniq)++data Smth a = Str { str :: String } | ES { es :: a } deriving (Eq,Ord,Show,Read)+instance Binary a => Binary (Smth a) where+ put (Str s) = put (0::Word8) >> put s+ put (ES s) = put (1::Word8) >> put s+ get = do+ tag <- get+ case tag::Word8 of+ 0 -> liftM Str get+ 1 -> liftM ES get++type ProbDist a = [(a,Double)]++type Tok a = [Smth a]+type Model a = LZipper [Smth a] [Smth a] [Smth a] -> ProbDist (Smth a)+beamSearch :: + Int -- beam size+ -> [Model a]+ -> ProbDist (LZipper (Tok a) (Tok a) (Tok a)) + -- prob dist over sequence of "tokens in context" (as lzippers)+ -> ProbDist [Tok a] -- prob dist over sequences of "tokens"+beamSearch n cfs pzs =+ if any (atEnd . fst) pzs + -- of any lzipper at end then get then return tokens+ then flip map pzs $ \(z,p) -> (map id (reverse (left z)),p)+ else -- otherwise apply each classifier in turn in the lzipper seq,+ -- prune, adjust probs+ let f pzs' model = prune n + . flip concatMap pzs'+ $ \(z,p) -> + flip map (model $ z) + $ \(c,c_p) -> + (modify (\x -> x ++ [c]) z,p*c_p)+ in beamSearch n cfs . map (\(z,p) -> (slide z,p)) $! (foldl f pzs cfs)++-- pruning and prepruning++prune :: Int -> ProbDist a -> ProbDist a+prune n = take n . sortBy (flip (comparing snd))+collectUntil cond f z [] = []+collectUntil cond f z (x:xs) = let z' = (f $! x) $! z + in if cond x z' then []+ else x: collectUntil cond f z' xs+mkPreprune th = collectUntil (\x z -> th > snd x / z) ((+) . snd) 0++data FeatureSpec a = + FS { label :: Tok a -> Smth a+ , features :: LZipper (Tok a) (Tok a) (Tok a) -> [Feature String Double] + , preprune :: ProbDist (Smth a) -> ProbDist (Smth a)+ , check :: LZipper (Tok a) (Tok a) (Tok a) -> Smth a -> Bool + , trainSettings :: M.TrainSettings }++trainFun :: (Ord a,Show a) => [FeatureSpec a] -> [[Tok a]] -> [Model a]+trainFun fspecs sents = + let ms = train fspecs sents+ in (zipWith toModelFun fspecs ms) + +train :: (Ord a) => + [FeatureSpec a] + -> [[Tok a]] + -> [M.Model (Label a) Int String Double]+train fspecs sents = + flip map fspecs+ $ \fs -> let yxs = concatMap (sentToExamples fs) $ sents+ ys = uniq . map fst $ yxs+ zs = concat [ take (length s) + . iterate slide + . fromList+ $ s + | s <- sents ]+ yss = [ [ y | y <- ys , check fs z y ] + | z <- zs ]+ in M.train (trainSettings fs) yss yxs++toModelFun :: (Ord a,Show a) => + FeatureSpec a + -> (M.Model (Label a) Int String Double) + -> Model a+toModelFun fs m = + let ys = Map.keys . M.classMap . M.modelData $ m+ in+ \ z -> case filter (check fs z) ys of+ [] -> error "GramLab.Morfette.Models.toModelFun: unexpected []"+ y:ys' -> + preprune fs + . M.distribution m (y:ys')+ . features fs + $ z + +predict :: Int -> [Model a] -> [[Tok a]] -> [[Tok a]]+predict beamSize models sents = map predictOne sents+ where predictOne s = fst + . head + . beamSearch beamSize models + $ [(fromList s,1)]++predictPipeline :: Int -> [Model a] -> [[Tok a]] -> [[Tok a]]+predictPipeline beamSize models sents = map predictOne sents+ where predictOne s = foldl (\s1 m -> fst . head . beamSearch beamSize [m] + $ [(fromList s1,1)]) s models+ ++type Label a = Smth a+sentToExamples :: FeatureSpec a + -> [Tok a] + -> [(Label a,[Feature String Double])]+sentToExamples fs xs = slideThru f (fromList xs)+ where f z = + ( label fs + . fromMaybe+ (error "GramLab.Morfette.Models.sentToExample:fromMaybe")+ . focus + $ z+ , features fs z)+ +slideThru f z | atEnd z = []+slideThru f z = f z:slideThru f (slide z)
+ GramLab/Morfette/Settings/Defaults.hs view
@@ -0,0 +1,15 @@+module GramLab.Morfette.Settings.Defaults ( posTrainSettings+ , lemmaTrainSettings+ )+where +import GramLab.Perceptron.Model++lemmaTrainSettings = TrainSettings { iter = 10+ , rate = 0.1+ , occurTh = 40+ , entropyTh = 0.0 }+posTrainSettings = TrainSettings { iter = 20+ , rate = 0.1+ , occurTh = 40+ , entropyTh = 0.0 }+
+ GramLab/Morfette/Token.hs view
@@ -0,0 +1,31 @@+module GramLab.Morfette.Token ( Token+ , Sentence+ , tokenForm+ , tokenLemma+ , tokenPOS+ , parseToken+ , nullToken+ , isNullToken + )+ +where+++type Token = (String,Maybe String,Maybe String)+type Sentence = [Token]++tokenForm (form,_,_) = form+tokenLemma (_,lemma,_) = lemma+tokenPOS (_,_,pos) = pos++parseToken line =+ case words line of + form:lemma:pos:_ -> (form,Just lemma,Just pos)+ [form,lemma] -> (form,Just lemma,Nothing)+ [form] -> (form,Nothing,Nothing)+ otherwise -> nullToken++nullToken = ("",Nothing,Nothing)+isNullToken ("",Nothing,Nothing) = True+isNullToken _ = False+
+ GramLab/Morfette/Utils.hs view
@@ -0,0 +1,255 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+module GramLab.Morfette.Utils ( train+ , predict+ , Flag(..)+ , morfette+ )+where+import Prelude hiding (print,getContents,putStrLn,putStr,writeFile,readFile)+import System.IO (stderr,stdout)+import System.IO.UTF8+import GramLab.Commands+import qualified GramLab.Morfette.Models as Models+import GramLab.Morfette.Models (Smth(..))+import qualified Data.Set as Set+import qualified Data.Map as Map+import Control.Monad hiding (join)+import GramLab.Utils (padRight,splitWith,splitInto,join,tokenize,lowercase)+import qualified GramLab.Perceptron.Model as M+import GramLab.Morfette.Token+import GramLab.Morfette.LZipper+import GramLab.Morfette.MWE+import Data.Maybe+import System.Directory+import System.FilePath+import Text.Printf+import qualified Data.List as List+import Data.Char+import GramLab.Morfette.Lang.Conf+import GramLab.Morfette.BinaryInstances+import Data.Binary+import qualified Data.ByteString.Lazy as B+import qualified GramLab.Morfette.Config as C+import GramLab.Morfette.Evaluation+import GramLab.Morfette.Settings.Defaults++data Flag = ModelPrefix String+ | Eval+ | BeamSize Int + | IgnoreCase+ | DictFile FilePath+ | BaselineFile FilePath+ | Lang Lang+ | Gaussian Double+ | Tokenize + | IgnorePunct+ | IgnorePOS String+ | Pipeline+ | EntropyTh Double+ | IterPOS Int+ | IterLemma Int+ deriving Eq++morfette fs fspecs = defaultMain (commands fs fspecs) "Usage: morfette command [OPTION...] [ARG...]"++commands fs fspecs = [+ ("train" , CommandSpec (train fs fspecs)+ "train models"+ [ Option [] ["dict-file"] + (ReqArg DictFile "PATH")+ "path to optional dictionary"+ , Option [] ["language-configuration"] + (ReqArg Lang "es|pl|tr|..")+ "language configuration"+ , Option [] ["iter-pos"] + (ReqArg (IterPOS . read) "NUM")+ "iterations for POS model"+ , Option [] ["iter-lemma"] + (ReqArg (IterLemma . read) "NUM")+ "iterations for Lemma model"+ ] + [ "TRAIN-FILE", "MODEL-DIR" ])+ + , ("predict" , CommandSpec (predict fs fspecs)+ "predict postags and lemmas using saved model data"+ [ Option [] ["beam"] + (ReqArg (BeamSize . read) "+INT")+ "beam size to use"+ , Option [] ["tokenize"] + (NoArg Tokenize)+ "tokenize input"+ ] + [ "MODEL-DIR" ] )+ , ("eval" , CommandSpec eval + "evaluate morpho-tagging and lemmatization results"+ [ Option [] ["ignore-case"] + (NoArg IgnoreCase)+ "ignore case for evaluation"+ , Option [] ["baseline-file"] + (ReqArg BaselineFile "PATH")+ "path to baseline results"+ , Option [] ["dict-file"] + (ReqArg DictFile "PATH")+ "path to optional dictionary"+ , Option [] ["ignore-punctuation"] + (NoArg IgnorePunct)+ "ignore punctuation for evaluation"+ , Option [] ["ignore-pos"] + (ReqArg IgnorePOS "POS-prefix")+ "ignore POS starting with POS-prefix for evaluation"+ ]+ ["TRAIN-FILE","GOLD-FILE","TEST-FILE"])+ ]+++predict (_,format) fspecs flags [modelprefix] = do+ hPutStrLn stderr $ "Loading models from " ++ (modelFile modelprefix)+ ms <- fmap decode (B.readFile (modelFile modelprefix))+ ms == ms `seq` return ()+ when True $ do+ mwes <- loadMwes (mweFile modelprefix)+ lex <- readConf (confFile modelprefix)+ txt <- getContents+ let models = zipWith Models.toModelFun (map ($lex) fspecs) ms+ defaultBeamSize = 3+ n = case [f | BeamSize f <- flags ] + of { [f] -> f ; _ -> defaultBeamSize }+ f = if Pipeline `elem` flags + then Models.predictPipeline+ else Models.predict+ putStr . unlines + . map format + . f n models + . toksToForms + . getToks flags mwes+ $ txt++confFile dir = dir </> "conf.model"+mweFile dir = dir </> "mwe.model" +modelFile dir = dir </> "models.model"+defaultGaussianPrior = 1++train (prepr,_) fspecs flags [dat,modeldir] = do+ toks <- fmap (map parseToken . lines) (readFile dat)+ dict <- getDict flags + let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }+ lex = Conf { dictLex = dict+ , trainLex = toksToLexicon toks+ , lang = langConf }+ mwes = mweSet toks+ g = case [f | EntropyTh f <- flags ] of + [] -> M.entropyTh posTrainSettings + [f] -> f + i_p = case [f | IterPOS f <- flags ] of + [] -> M.iter posTrainSettings + [f] -> f + i_l = case [f | IterLemma f <- flags ] of + [] -> M.iter lemmaTrainSettings + [f] -> f + sentences = toksToSentences prepr toks+ createDirectoryIfMissing True modeldir+ let models = Models.train (map (\(i,fs) -> + let fs' = fs lex+ ts = Models.trainSettings fs'+ in fs' { Models.trainSettings = + ts { M.entropyTh = g + , M.iter = i+ } })+ $ zip [i_p,i_l] fspecs) + $ sentences+ B.writeFile (modelFile modeldir) (encode models)+ saveConf (confFile modeldir) lex+ saveMwes (mweFile modeldir) mwes++toksToSentences :: (Token -> Models.Tok a) -> [Token] -> [[Models.Tok a]]+toksToSentences f toks = map (map f) $ splitWith isNullToken toks++toksToForms :: [Token] -> [[Models.Tok a]]+toksToForms toks = map (map (\ (f,_,_) ->[Str f])) + . splitWith isNullToken + $ toks++parseSents :: String -> [[Models.Tok a]]+parseSents = splitWith null . map (map Str) . map words . lines++getDict :: [Flag] -> IO Lexicon+getDict flags = do+ case [f | DictFile f <- flags ] of+ [f] -> do + text <- readFile f+ return (parseLexicon text)+ [] -> return emptyLexicon++getToks :: [Flag] -> [[String]] -> String -> [Token]+getToks flags mwes text = + let f = if Tokenize `elem` flags + then concatMap (detectMwes mwes) + . List.intersperse [""] + . map tokenize + else id+ in map parseToken . f . lines $ text+ ++formatTriple (form,lemma,pos) = unwords . map (padRight ' ' 12) $ [form,lemma,pos] +formatToken (f,ml,mp) = unwords [f,fromMaybe "" ml,fromMaybe "" mp]++getEval flags trainf goldf testf = do+ let uncase = if IgnoreCase `elem` flags then+ map (\(form,lemma,pos) -> (lowercase form,fmap lowercase lemma, fmap lowercase pos))+ else id+ ignore = case [f | IgnorePOS f <- flags ] of+ [] -> const False+ xs -> (\(_,_,mpos) -> case mpos of+ Nothing -> False + Just pos -> any (`List.isPrefixOf` pos) xs)+ isPunct = if IgnorePunct `elem` flags then (\t@(form,_,_) -> + (not . isNullToken) t && all isPunctuation form) else const False+ keep tok = (not . ignore) tok && (not . isPunct) tok+ train <- fmap uncase (getTokens trainf)+ gold <- fmap uncase (getTokens goldf)+ test <- fmap uncase (getTokens testf)+ baseline <- case [f | BaselineFile f <- flags ] of + [] -> return Nothing+ [f] -> fmap (Just . uncase) (getTokens f)+ let keeps = map keep gold+ return ( train+ , filterZip keeps gold+ , filterZip keeps test+ , fmap (filterZip keeps) baseline )+ where getTokens f = fmap (map parseToken . lines) (readFile f)+-- FIXME its breaks sentence accuracy somehow...++eval flags [trainf,goldf,testf] = do+ dict <- getDict flags+ (train,gold,test,baseline) <- fmap (\ (tr, g, t, b) -> (tr,toks g, toks t, fmap toks b)) (getEval flags trainf goldf testf)+ let seen = Set.fromList (map tokenForm train)+ isUnseen (form,_,_) = not (form `Set.member` seen)+ isUnseenInDict (form,_,_) = not (lowercase form `Map.member` dict)+ isUnseenBoth x = isUnseen x && isUnseenInDict x+ all_acc = tokenAccuracy gold test baseline+ unseen_acc = tokenAccuracy (filter isUnseen gold) (filter isUnseen test) + (fmap (filter isUnseen) baseline)+ seen_acc = tokenAccuracy (filter (not . isUnseen) gold) (filter (not . isUnseen) test)+ (fmap (filter (not . isUnseen)) baseline)+ unseen_ratio = 100 * fromIntegral (length (filter isUnseen test)) / fromIntegral (length test)+ unseen_train_and_dict_acc = tokenAccuracy (filter isUnseenBoth gold)+ (filter isUnseenBoth test)+ (fmap (filter isUnseenBoth) baseline)+ sent_acc = sentenceAccuracy (sents gold) (sents test) (fmap sents baseline)+ goldlemma g= map (lowercase . tokenLemma) g+ uniquePOS = fromIntegral $ Set.size $ Set.fromList $ map tokenPOS gold+ putStrLn $ "Unseen word ratio: " ++ printf "%4.2f" (unseen_ratio::Double)+ putStrLn $ "Token accuracy all:\n" ++ showAccuracy all_acc+ putStrLn $ "Token accuracy seen:\n" ++ showAccuracy seen_acc+ putStrLn $ "Token accuracy unseen:\n" ++ showAccuracy unseen_acc+ when (Map.size dict > 0) + (putStrLn $ "Token accuracy unseen train+dict:\n" ++ showAccuracy unseen_train_and_dict_acc)+-- FIXME Sentence accuracy is broken+-- putStrLn $ "Sentence accuracy:\n" ++ showAccuracy sent_acc+ where toks xs = filter (not . isNullToken) xs+ sents xs = splitWith isNullToken xs+ +filterZip :: [Bool] -> [a] -> [a]+filterZip xs ys = catMaybes $ zipWith (\b x -> if b then Just x else Nothing) xs ys+ +
+ GramLab/Perceptron/IntModel.hs view
@@ -0,0 +1,72 @@+module GramLab.Perceptron.IntModel ( IntModel+ , train+ , evalAll+ , TrainSettings(..)+ )++where+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as BS+import GramLab.Utils (padRight)+import Data.List (sortBy)+import Data.Ord (comparing)+import System.IO (stderr,hPutStrLn)+import Control.Monad (ap,liftM2)+import Data.Ix (inRange)+++import qualified GramLab.Perceptron.Multiclass as P++data TrainSettings = TrainSettings { iter :: Int+ , rate :: Double+ , occurTh :: Int+ , entropyTh :: Double+ } deriving (Eq,Show,Read)++instance B.Binary TrainSettings where+ put (TrainSettings a b c d) = B.put a >> B.put b >> B.put c >> B.put d+ get = return TrainSettings `ap` B.get `ap` B.get `ap` B.get `ap` B.get++data IntModel = IntModel { modelLabels :: IntSet.IntSet + , modelWeights :: P.Model } + deriving (Show,Eq)++train :: TrainSettings -> [[Int]] -> [(Int,[(Int,Double)])] -> IntModel +-- For compatibility, examples have label first, feature second+train s yss examples = model+ where examples' = [ (y,[ (i,realToFrac v) | (i,v) <- x ]) | (y,x) <- examples ]+ labels = map fst examples'+ featids = concatMap (map fst . snd) examples'+ weights = P.train (occurTh s) + (entropyTh s) + (realToFrac $ rate s) + (iter s) + (lo,hi)+ yss+ . map swap + $ examples' + model = IntModel { modelLabels = IntSet.fromList (map fst examples')+ , modelWeights = weights+ }+ (lo,hi) = ((minimum labels,minimum featids)+ ,(maximum labels,maximum featids)) :: ((Int,Int),(Int,Int))+ swap (x,y) = (y,x)++evalAll :: IntModel -> [Int] -> [(Int,Double)] -> [(Int,Double)]+evalAll m ys fs = + let ((_,lo),(_,hi)) = P.bounds . modelWeights $ m+ fs' = filter (\(k,_) -> inRange (lo,hi) k) fs+ in map (\(i,v) -> (i,realToFrac v)) + . P.distribution (modelWeights m) ys+ $ [ (i,realToFrac v) | (i,v) <- fs' ]+instance B.Binary IntModel where+ put (IntModel ls ws) = B.put ls >> B.put ws+ get = do + ls <- B.get + ls == ls `seq` return ()+ ws <- B.get+ ws == ws `seq` return ()+ return $ IntModel ls ws+
+ GramLab/Perceptron/Model.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE FlexibleContexts , BangPatterns #-}+module GramLab.Perceptron.Model ( train+ , distribution+ , classify+ , save+ , load+ , I.TrainSettings(..)+ , Model(..)+ , ModelData(..)+ , dump+ , dumpMapping+ , DumpMode(..)+ )+where+import qualified GramLab.Perceptron.IntModel as I+import qualified Data.ByteString.Lazy as BS+import qualified Data.Binary as B+import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.Map ((!))+import Data.List (foldl')+import Data.Maybe (catMaybes)++import Data.Char (isAlphaNum)+import GramLab.Intern+import GramLab.Data.Assoc+import GramLab.FeatureSet+import System.IO+import Debug.Trace++type Example label features = (label,features)+data ModelData lab key sym num = + ModelData { featureMap :: Table (key,Maybe sym) + , settings :: I.TrainSettings + , classMap :: Map.Map lab Int+ , inverseClassMap :: IntMap.IntMap lab+ } deriving (Eq,Show)+data Model lab key sym num = Model { model :: I.IntModel+ , modelData :: ModelData lab key sym num }+ deriving (Eq,Show)++invertMap = Map.foldWithKey (\k v m' -> IntMap.insert v k m') IntMap.empty+maxValues = IntMap.unionsWith max++train :: (FeatureSet b key sym Double, Ord key, Ord sym, Ord a) =>+ I.TrainSettings + -> [[a]]+ -> [(a, b)] + -> Model a key sym num+train p yss examples = + Model { model = m + , modelData = + ModelData { featureMap = fm + , settings = p + , classMap = cm+ , inverseClassMap = invertMap cm+ }}+ where m = I.train p (map (map (cm !)) yss) samples+ (ys,xs) = unzip examples+ (ys',T _ cm) = flip runState initial $ mapM intern ys+ (featsets,fm) = runState (mapM toFeatureSet xs) initial+ samples = zipWith (\l fs -> (l,IntMap.toList fs)) + ys'+ featsets++pruneSingletonLabels :: (Ord y) => [(y,a)] -> [(y,a)]+pruneSingletonLabels yxs = + let counts = foldl' f Map.empty yxs+ f !z (!y,_) = Map.insertWith' (+) y 1 z+ in catMaybes [ if counts ! y > 1 then Just (y,x) else Nothing + | (y,x) <- yxs ]+++pruneSingletonFeats :: (Ord y) => + [(y, [Feature String Double])] + -> [(y, [Feature String Double])]+pruneSingletonFeats yxs =+ let counts = foldl' f Map.empty yxs+ f !cxy (_,!x) = + foldl' (\z i -> case i of+ Null -> z+ Num _ -> z+ Sym s -> Map.insertWith' (+) s 1 z+ Set ss -> + foldl' (\z s -> Map.insertWith' (+) s 1 z)+ z+ ss)+ cxy + x+ in [ (y,[ case f of+ Null -> Null+ Num n -> Num n+ Sym s -> if counts ! s > 1 then Sym s else Null+ Set ss -> Set (filter (\s -> counts ! s > 1) ss)+ | f <- x ]) + | (y,x) <- yxs ]++data DumpMode = Write FilePath | Read FilePath | Skip deriving (Show,Read)+dump h examples = dumpMapping h Skip examples+++dumpMapping h dm examples = do + (cm,fm) <- case dm of+ Read p -> do+ s <- BS.readFile p+ return (B.decode s)+ _ -> return (initial,initial)+ let (ks,xs) = unzip examples+ (labels,cm') = runState (mapM intern ks) cm+ (featsets,fm') = runState (mapM toFeatureSet xs) fm+ sm = maxValues featsets+ samples = zipWith (\l fs -> (l,IntMap.toList fs)) + labels + featsets+ format (l,fs) = unwords (show l + : map (\(f,v) -> show f ++ ":" ++ show v) fs)+ mapM_ (hPutStrLn h . format) samples+ case dm of+ Write p -> BS.writeFile p (B.encode (cm',fm'))+ _ -> return ()+++distribution m ys fs = fromAssoc $ map (\(k,v) -> (origClass k,v)) dist+ where dist = I.evalAll (model m) (map (cm!) ys) s+ cm = classMap . modelData $ m+ s = IntMap.toList feats+ feats = evalState (toFeatureSet fs) (featureMap . modelData $ m)+ origClass k = + case IntMap.lookup k (inverseClassMap . modelData $ m) + of Just k' -> k' + Nothing -> error + $ "GramLab.Perceptron.Model.distribution: "+ ++ "key not found: " ++ show k ++classify m ys = fst . head . distribution m ys++instance (Ord a, B.Binary a) => B.Binary (Table a) where+ put (T i m) = B.put i >> B.put m+ get = liftM2 T B.get B.get++instance (Ord lab, Ord key, Ord sym,+ B.Binary lab, + B.Binary key, + B.Binary sym, + B.Binary num) => B.Binary (ModelData lab key sym num) where+ put (ModelData fm s cm icm) = do+ B.put fm + B.put s + B.put cm+ B.put icm+ get = do + fm <- B.get+ fm == fm `seq` return ()+ s <- B.get + s == s `seq` return ()+ cm <- B.get + cm == cm `seq` return ()+ icm <- B.get+ icm == icm `seq` return ()+ return $ ModelData fm s cm icm++instance (Ord lab, Ord key, Ord sym,+ B.Binary lab, + B.Binary key, + B.Binary sym, + B.Binary num) => B.Binary (Model lab key sym num) where+ put (Model x y) = B.put x >> B.put y+ get = do + x <- B.get+ x == x `seq` return ()+ y <- B.get + y == y `seq` return ()+ return $ Model x y++save path m = BS.writeFile path (B.encode m)+load path = fmap B.decode $ BS.readFile path +
+ GramLab/Perceptron/Multiclass.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE BangPatterns , FlexibleContexts #-}+module GramLab.Perceptron.Multiclass + ( Model+ , bounds+ , train+ , decode+ , distribution+ )+where++import Data.Array.ST+import qualified Data.Array.Unboxed as A+import Control.Monad.ST+import Data.STRef+import Control.Monad+import GramLab.Perceptron.Vector+import System.IO+import Data.List (foldl',sort)+import Prelude hiding (sum,product)+import qualified Data.Binary as B+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Map ((!))+import Data.Maybe (isJust,fromMaybe)+import GramLab.Utils (uniq)+import Text.Printf (printf)+import Debug.Trace ++newtype Model = MC { weights :: DenseVector (Y,I)+ } deriving (Eq,Show)++bounds = A.bounds . weights++instance B.Binary Model where+ put (MC m) = do+ let (lo,hi) = A.bounds m+ xs = filter (\(_,e) -> e /= 0.0) . A.assocs $ m+ B.put (lo,hi)+ B.put xs+ get = do+ (lo,hi) <- B.get+ xs <- B.get+ xs == xs `seq` return ()+ return $ MC (A.accumArray (+) 0 (lo,hi) $ xs)++type Y = Int+type X = [(I,Float)]+type I = Int++{-# INLINE phi #-}+phi :: X -> Y -> (X,Y)+phi x y = (x,y)++{-# INLINE decode #-}+decode :: Model -> [Y] -> X -> Y+decode (MC w) ys x = snd . maximum + $ [ (w`dot`phi x y,y) | y <- ys ]++{-# INLINE decode_ #-}+decode_ :: (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I)) + -> [Y]+ -> X+ -> ST s Y+decode_ w ys x = fmap (snd . maximum) + $ mapM (\y -> do { r <- w`dot_`phi x y ; return (r,y) } )+ $ ys+++{-# INLINE softmax #-}+{-# SPECIALIZE softmax :: [Float] -> [Float] #-}+softmax x = + let !x_max = maximum x+ !a = foldl' (+) 0 . map (\ !x_i -> exp $ x_i - x_max) $ x+ in [ exp $ x_i - x_max - log a | !x_i <- x ]++{-# INLINE distribution #-}+distribution :: Model -> [Y] -> X -> [(Y, Float)]+distribution (MC w) ys x = + let swap (!x,!y) = (y,x)+ fxs = map ((w`dot`) . phi x) ys+ in reverse . map swap . sort $ zip (softmax fxs) ys++iter :: Float+ -> [[Y]]+ -> [(X, Y)]+ -> (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I))+ -> ST s ()+iter rate yss ss (c,params,params_a) = do+ for_ (zip yss ss) $ \ (ys',(x,y)) -> do+ params' <- unsafeFreeze params+ let y'= decode (MC params') ys' x+ phi_xy = phi x y+ phi_xy' = phi x y'+ when (y' /= y) $ do + params `plus_` (phi_xy `scale` rate)+ params `plus_` (phi_xy' `scale` (rate * (-1)))+ c' <- readSTRef c+ params_a `plus_` (phi_xy `scale` (rate * fromIntegral c'))+ params_a `plus_` (phi_xy' `scale` (rate * (-1) * fromIntegral c'))+ modifySTRef c (+1)++train :: Int + -> Double+ -> Float+ -> Int+ -> ((Y,I), (Y,I))+ -> [[Y]]+ -> [(X, Y)]+ -> Model+train th1 th2 rate epochs bounds yss xys = MC m+ where m = runSTUArray $ do+ trace (show bounds) () `seq` return ()+ params <- newArray bounds 0+ params_a <- newArray bounds 0+ c <- newSTRef 1+ for_ [1..epochs] $ + \i -> do iter rate yss xys (c,params,params_a)+ corr <- fmap sum + . flip mapM (zip yss xys)+ $ \(ys,(x,y)) -> do + y'<- decode_ (c,params,params_a) ys x + return . fromEnum $ y' /= y+ let err :: Double+ err = fromIntegral corr / + fromIntegral (length xys)+ runLogger + $ hPutStrLn stderr+ $ printf "Iteration %d: error: %2.4f" i err + finalParams (c, params, params_a)+ return params++finalParams :: (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I))+ -> ST s ()+finalParams (c,params,params_a) = do+ (l,u) <- getBounds params+ c' <- fmap fromIntegral (readSTRef c)+ for_ (range (l,u)) $ \i -> do+ e <- readArray params i+ e_a <- readArray params_a i+ writeArray params i (e - (e_a * (1/c')))++{-# NOINLINE runLogger #-}+runLogger f = unsafeIOToST f++m `at` i = Map.findWithDefault 0 i m+ +counts_x :: [(X,Y)] -> (Map.Map (I,Y) Int+ ,Map.Map I Int+ ,Map.Map Y Int)+counts_x xys = foldl' f (Map.empty,Map.empty,Map.empty) xys+ where f (!cxy,!cx,!cy) (!x,!y) = + ( foldl' (\z (i,_) -> Map.insertWith' (+) (i,y) 1 z) cxy x+ , foldl' (\z (i,_) -> Map.insertWith' (+) i 1 z) cx x+ , Map.insertWith' (+) y 1 cy )++sum :: (Num n) => [n] -> n+{-# SPECIALIZE INLINE sum :: [Double] -> Double #-}+{-# SPECIALIZE INLINE sum :: [Float] -> Float #-}+sum = foldl' (+) 0
+ GramLab/Perceptron/Vector.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts, BangPatterns #-}+module GramLab.Perceptron.Vector + ( SparseVector+ , DenseVector+ , DenseVectorST+ , for_+ , plus_+ , scale+ , dot + , dot_+ , unsafeDot+ )+where++import Data.Array.ST+import Data.Array.Unboxed (UArray,bounds,(!))+import Control.Monad.ST+import Data.STRef+import GHC.Arr (unsafeIndex)+import Data.Array.Base (unsafeAt)++type SparseVector y i = ([(i,Float)],y)+type DenseVectorST s i = STUArray s i Float+type DenseVector i = UArray i Float+++{-# INLINE for_ #-}+for_ xs f = mapM_ f xs+++{-# SPECIALIZE plus_ :: DenseVectorST s (Int,Int) + -> SparseVector Int Int -> ST s () #-}+plus_ :: (Show (y,i),Ix (y,i)) => + DenseVectorST s (y,i) + -> SparseVector y i -> ST s ()+plus_ w (v,y) = do+ for_ v $ \(i,vi) -> do+ wi <- readArray w (y,i) + writeArray w (y,i) (wi + vi)++{-# SPECIALIZE scale :: SparseVector Int Int + -> Float + -> SparseVector Int Int #-}+scale :: (Ix i) => SparseVector y i -> Float -> SparseVector y i+scale (v,y) n = (map (\(i,vi) -> (i,vi*n)) v,y)++{-# INLINE dot #-}+{-# SPECIALIZE dot :: DenseVector (Int,Int) + -> ([(Int,Float)],Int)-> Float #-}+dot :: (Ix (y,i)) => DenseVector (y,i) -> ([(i,Float)],y) -> Float+dot w (x,!y) = go 0 x+ where go !s [] = s+ go !s ((!i,!xi):x) = go (s + (w ! (y,i)) * xi) x++{-# INLINE dot_ #-}+dot_ :: (STRef s Int, DenseVectorST s (Int,Int), DenseVectorST s (Int,Int)) + -> ([(Int,Float)],Int)+ -> ST s Float+dot_ (c,params,params_a) (x,y) = do+ c' <- fmap fromIntegral (readSTRef c)+ let go !s [] = return s+ go !s ((i,xi):x) = do+ e <- readArray params (y,i)+ e_a <- readArray params_a (y,i)+ go (s + (e - (e_a * (1/c'))) * xi) x+ go 0 x++{-# INLINE unsafeDot #-}+{-# SPECIALIZE unsafeDot :: DenseVector (Int,Int) + -> ([(Int,Float)],Int)-> Float #-}+unsafeDot :: (Ix (y,i)) => DenseVector (y,i) -> ([(i,Float)],y) -> Float+unsafeDot w (x,!y) = go 0 x+ where bs = bounds w+ go !s [] = s+ go !s ((!i,!xi):x) = go (s + unsafeAt w (unsafeIndex bs (y,i)) * xi) x+
+ GramLab/Utils.hs view
@@ -0,0 +1,98 @@+module GramLab.Utils ( join+ , splitOn+ , splitWith+ , splitInto+ , padLeft+ , padRight+ , makeList + , lowercase+ , uppercase+ , at+ , distribute+ , distributeOver+ , cumulDifference+ , index+ , unfoldrM+ , tokenize+ , uniq+ )+ +where+import Data.List+import Data.Char+import qualified Data.Map as Map+import Data.Set(Set)+import qualified Data.Set as Set+import qualified Data.Traversable as T+import qualified Control.Monad.State as S+import Control.Monad (liftM)+import Debug.Trace+-- Lists/Strings+join :: [a] -> [[a]] -> [a]+join sep xs = concat $ intersperse sep xs++splitOn :: (Eq a) => a -> [a] -> [[a]]+splitOn = splitWith . (==)++splitWith :: (a -> Bool) -> [a] -> [[a]]+splitWith f s = case dropWhile f s of+ [] -> []+ s' -> w : splitWith f s''+ where (w, s'') = break f s'++splitInto :: Int -> [a] -> [[a]]+splitInto size [] = []+splitInto size xs = let (ws,ys) = splitAt size xs+ in ws:splitInto size ys++padLeft :: a -> Int -> [a] -> [a]+padLeft pad size xs = reverse $ padRight pad size $ reverse xs++padRight :: a -> Int -> [a] -> [a]+padRight pad size xs = take size (xs ++ (repeat pad))++lowercase :: String -> String+--lowercase xs | trace xs False = undefined+lowercase xs = map toLower xs++uppercase :: String -> String+uppercase = map toUpper ++makeList size elt = take size (repeat elt)++at err m k = case Map.lookup k m of+ Nothing -> error (err k)+ Just x -> x++distributeOver :: Int -> [t] -> [[t]]+distributeOver i = distribute ([],(replicate i []))++distribute (xs,ys) [] = xs ++ ys+distribute (xs,[]) zs = distribute ([],xs) zs+distribute (xs,y:ys) (z:zs) = distribute ((z:y):xs,ys) zs++cumulDifference :: (Ord a) => [Set a] -> [Set a]+cumulDifference = snd . mapAccumL (\z x -> (z `Set.union` x, x `Set.difference` z)) Set.empty ++index xs = S.evalState (T.mapM count xs) 0+ where count a = do+ i <- S.get+ S.put (i+1)+ return (i,a)+unfoldrM f b = do + result <- f b+ case result of+ Just (a,new_b) -> liftM (a:) (unfoldrM f new_b)+ Nothing -> return []++sepPunct :: String -> [String]+sepPunct xs = let (before,rest) = span isPunctuation xs+ (after,this) = span isPunctuation (reverse rest)+ in filter (not . null) [before,reverse this,reverse after]+tokenize :: String -> [String]+tokenize = concatMap sepPunct . words+++uniq :: (Ord a) => [a] -> [a]+{-# SPECIALIZE INLINE uniq :: [String] -> [String] #-}+uniq = Set.toList . Set.fromList
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2010, Grzegorz Chrupala+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+HOLDER 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.
+ Lemma.hs view
@@ -0,0 +1,42 @@+module Lemma (featureSpec,apply,make)+where+import qualified Data.Map as Map+import GramLab.Morfette.Features.Common+import qualified GramLab.Data.Diff.EditTree as E+import Debug.Trace+import Data.Maybe (fromMaybe)+featureSpec global = FS { label = theLabel+ , features = theFeatures global+ , preprune = mkPreprune 0.3+ , check = theCheck + , trainSettings = lemmaTrainSettings }++theCheck z (ES s) = E.check s (prepare (getForm (fromMaybe (error "Lemma.featureSpec.check: Nothing") + (focus z))))+theLabel (Str form:Str pos:Str lemma:_) = make form lemma+theLabel (Str _ :Str pos:ES s:_) = ES s+theLabel other = error $ "Lemma.theLabel: match failed with " ++ show other++getForm = str . head++maxSuffix = 7+maxPrefix = 5++prepare = lowercase++theFeatures global tic = focusFeatures (focus tic)+ where focusFeatures (Just (Str form:Str label:_)) = [ Sym $ low form, Sym $ label+ , Sym $ spellingSpec form+ , lexmap (low form)+ ]+ ++ prefixes maxPrefix (low form)+ ++ suffixes maxSuffix (low form)+ focusFeatures other = error $ "Lemma.theFeatures: " ++ show other+ low = lowercase+ lexmap w = Set $ map (\(l,p,c) -> show $ make w l) $ Map.findWithDefault [] w (dictLex global)++decode str = case reads str of+ [(s,"")] -> s+ other -> error ("Lemma.decode: no parse: " ++ str)+apply s str = E.apply s (prepare str)+make form lemma = ES $ E.make (prepare form) (prepare lemma)
+ Main.hs view
@@ -0,0 +1,14 @@++import GramLab.Utils (splitWith,join,lowercase)++import qualified POS as P +import qualified Lemma as L+import GramLab.Morfette.Models+import GramLab.Morfette.Utils (morfette)++main = morfette (prep,format) [P.featureSpec,L.featureSpec]+++format toks = unlines . map (\ [Str f,Str p,ES s] -> unwords [f,L.apply s (lowercase f),p]) $ toks++prep (f,Just l, Just p) = [Str f,Str p, L.make f l]
+ POS.hs view
@@ -0,0 +1,41 @@+module POS (featureSpec)+where+import GramLab.Morfette.Features.Common+import qualified GramLab.Data.Diff.EditTree as E+import qualified Data.Map as Map+import Lemma (apply)+featureSpec global = FS { label = (!!1)+ , features = theFeatures global+ , preprune = mkPreprune 0.3+ , check = \_ _ -> True + , trainSettings = posTrainSettings }++leftCtx = 2+rightCtx = 1++maxSuffix = 7+maxPrefix = 5+++theFeatures global tic = let prev = getSome leftCtx (left tic)+ in+ concatMap leftFeatures prev+ ++ [Sym $ concat $ map getpos prev] -- concat prefix of previous poslabels+ ++ focusFeatures (focus tic)+ ++ concatMap rightFeatures (getSome rightCtx (right tic))+ where leftFeatures (Just (Str form:Str label:ES script:_)) + = [ Sym $ label + , Sym $ apply script (low form)+ , Sym $ low form ]+ leftFeatures Nothing = [Null , Null , Null]+ focusFeatures (Just (Str form:_)) = [ Sym $ low form + , Sym $ spellingSpec form + , lexmap (low form) ]+ ++ prefixes maxPrefix (low form)+ ++ suffixes maxSuffix (low form)+ rightFeatures (Just (Str form:_)) = [Sym (low form),lexmap (low form)]+ rightFeatures Nothing = [Null, Null]+ low = lowercase+ lexmap w = Set $ map (\(l,p,c) -> p) $ Map.findWithDefault [] w (dictLex global)+ getpos Nothing = ""+ getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)
+ README view
@@ -0,0 +1,115 @@+=INTRODUCTION=++Morfette is a tool for supervised learning of inflectional+morphology. Given a corpus of sentences annotated with lemmas +and morphological labels, and optionally a lexicon, morfette +learns how to morphologically analyse new sentences.++In the learning stage Morfette fits two separate logistic regression+models: one for morphological tagging and one for lemmatization. The+predictions of the models are combined dynamically and produce a +globally plausible sequence of morphological-tag - lemma pairs for +a sentence.++In Morfette lemmatization is cast as a classification task where a +a lemmatization class corresponds to the specification of the edit +operations which are needed to transform the inflected word form into+the corresponding lemma.++The basic approach is described in (Chrupala et al 2008 and Chrupala 2008). +The current version of Morfette uses an averaged perceptron to +fit the models, rather than Maximum Entropy training. The lemmatization +classes are Edit-Tree-based as described in (Chrupala 2008).++=LICENSE= +The source code in the src directory is licensed under+the BSD license.++=INSTALLATION=+Pre-built binaries are available from the project website. +If they don't work on your system you will+need to build from source, using the GHC Haskell compiler. Build+instructions are in [INSTALL]++=USAGE=+Usage: morfette command [OPTION...] [ARG...]+train: train models+train [OPTION...] TRAIN-FILE MODEL-DIR + --dict-file=PATH path to optional dictionary+ --language-configuration=es|pl|tr|.. language configuration+ --class-entropy-prune-threshold=NUM class prune threshold++predict: predict postags and lemmas using saved model data+predict [OPTION...] MODEL-DIR + --beam=+INT beam size to use+ --tokenize tokenize input++eval: evaluate morpho-tagging and lemmatization results+eval [OPTION...] TRAIN-FILE GOLD-FILE TEST-FILE + --ignore-case ignore case for evaluation+ --baseline-file=PATH path to baseline results+ --dict-file=PATH path to optional dictionary+ --ignore-punctuation ignore punctuation for evaluation+ --ignore-pos=POS-prefix ignore POS starting with POS-prefix for evaluation+++=EXAMPLE USAGE=+To train a new model:+morfette train --dict-file=DICT TRAINING-FILE MODEL-DIR++To use the model in MODEL-DIR to analyze new data:+morfette predict MODEL-DIR < TEST-DATA > ANALYZED-TEST-DATA++=DATA FORMAT=+Morfette expects both training and testing data to be tokenized and+split into sentences. The format of training data look like this:++Gómez Gómez np0000p+sostiene sostener vmip3s0+que que cs+la el da0fs0+propuesta propuesta ncfs000+no no rn+cambiará cambiar vmif3s0+. . Fp++La el da0fs0+propuesta propuesta ncfs000+será ser vsif3s0+la el da0fs0+misma mismo pi0fs000+++There is one token per line, with three columns separated by spaces or+tabs. The columns contain word form, lemma and morphological tag+respectively. Sentences are separated by an empty line. Text should be+encoded in UTF-8.++Test data format is similar, except only the first column is needed:++Gómez+sostiene+que+la+propuesta+no+cambiará+.++La+propuesta+será+la+misma+++=References=+[1] Grzegorz Chrupala, Georgiana Dinu and Josef van Genabith. 2008.+ Learning Morphology with Morfette. In Proceedings of LREC 2008.+ http://www.lrec-conf.org/proceedings/lrec2008/pdf/594_paper.pdf++[2] Grzegorz Chrupala. 2008. Towards a Machine-Learning Architecture+ for Lexical Functional Grammar Parsing. Chapter 6. PhD+ dissertation, Dublin City+ University. + http://www.lsv.uni-saarland.de/personalPages/gchrupala/papers/phd.pdf
+ Setup.lhs view
@@ -0,0 +1,8 @@+#! /usr/bin/env runhaskell++> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ morfette.cabal view
@@ -0,0 +1,36 @@+Name: morfette+Version: 0.2+Synopsis: Morfette: tool for supervised learning of morphology+Description: Morfette is a tool for supervised learning of inflectional+ morphology. Given a corpus of sentences annotated with lemmas + and morphological labels, and optionally a lexicon, morfette + learns how to morphologically analyse new sentences.+License: BSD3+License-file: LICENSE+Author: Grzegorz Chrupała+Maintainer: Grzegorz Chrupała <gchrupala@lsv.uni-saarland.de>+build-type: Simple+category: Natural Language Processing+Extra-source-files: README++Executable: morfette+Main-Is: Main.hs+Other-Modules: GramLab.Commands, GramLab.Morfette.LZipper, + GramLab.Data.LCS.SimpleMemo, GramLab.Data.Diff.EditListRev,+ GramLab.Data.Diff.EditList, GramLab.Data.StringLike,+ GramLab.Data.CommonSubstrings, GramLab.Data.Diff.EditTree, + GramLab.Morfette.BinaryInstances, + GramLab.Morfette.Token, GramLab.Binomial, + GramLab.Perceptron.Vector, GramLab.Data.Assoc,+ GramLab.Intern, GramLab.Utils, GramLab.Perceptron.Multiclass,+ GramLab.Perceptron.IntModel, GramLab.Morfette.Evaluation,+ GramLab.Morfette.Lang.Conf, GramLab.Morfette.MWE,+ GramLab.FeatureSet, GramLab.Perceptron.Model, + GramLab.Morfette.Config, GramLab.Morfette.Models, + GramLab.Morfette.Settings.Defaults, + GramLab.Morfette.Features.Common, + Lemma, POS, GramLab.Morfette.Utils+Build-depends: base >=3 && <=4 , containers, array, QuickCheck, mtl, + directory, filepath, haskell98, pretty,+ utf8-string, bytestring, binary+cc-options: -Wall