morfette 0.3.1 → 0.3.2
raw patch · 58 files changed
+2017/−2173 lines, 58 filesdep ~QuickCheckdep ~base
Dependency ranges changed: QuickCheck, base
Files
- GramLab/Binomial.hs +0/−60
- GramLab/Commands.hs +0/−54
- GramLab/Data/Assoc.hs +0/−29
- GramLab/Data/CommonSubstrings.hs +0/−61
- GramLab/Data/Diff/EditList.hs +0/−10
- GramLab/Data/Diff/EditListRev.hs +0/−14
- GramLab/Data/Diff/EditTree.hs +0/−52
- GramLab/Data/LCS/SimpleMemo.hs +0/−139
- GramLab/Data/StringLike.hs +0/−56
- GramLab/FeatureSet.hs +0/−56
- GramLab/Intern.hs +0/−59
- GramLab/Morfette/BinaryInstances.hs +0/−28
- GramLab/Morfette/Config.hs +0/−19
- GramLab/Morfette/Evaluation.hs +0/−78
- GramLab/Morfette/Features/Common.hs +0/−51
- GramLab/Morfette/LZipper.hs +0/−48
- GramLab/Morfette/Lang/Conf.hs +0/−82
- GramLab/Morfette/MWE.hs +0/−44
- GramLab/Morfette/Models.hs +0/−144
- GramLab/Morfette/Settings/Defaults.hs +0/−15
- GramLab/Morfette/Token.hs +0/−31
- GramLab/Morfette/Utils.hs +0/−332
- GramLab/Perceptron/IntModel.hs +0/−72
- GramLab/Perceptron/Model.hs +0/−184
- GramLab/Perceptron/Multiclass.hs +0/−171
- GramLab/Perceptron/Vector.hs +0/−74
- GramLab/Utils.hs +0/−98
- Lemma.hs +0/−42
- Main.hs +0/−16
- Makefile +23/−7
- POS.hs +0/−41
- morfette.cabal +5/−6
- src/GramLab/Binomial.hs +60/−0
- src/GramLab/Commands.hs +54/−0
- src/GramLab/Data/Assoc.hs +29/−0
- src/GramLab/Data/CommonSubstrings.hs +61/−0
- src/GramLab/Data/Diff/EditTree.hs +64/−0
- src/GramLab/Data/StringLike.hs +56/−0
- src/GramLab/FeatureSet.hs +56/−0
- src/GramLab/Intern.hs +59/−0
- src/GramLab/Morfette/Config.hs +19/−0
- src/GramLab/Morfette/Evaluation.hs +78/−0
- src/GramLab/Morfette/Features/Common.hs +51/−0
- src/GramLab/Morfette/LZipper.hs +48/−0
- src/GramLab/Morfette/Lang/Conf.hs +82/−0
- src/GramLab/Morfette/MWE.hs +44/−0
- src/GramLab/Morfette/Models.hs +144/−0
- src/GramLab/Morfette/Settings/Defaults.hs +15/−0
- src/GramLab/Morfette/Token.hs +31/−0
- src/GramLab/Morfette/Utils.hs +340/−0
- src/GramLab/Perceptron/IntModel.hs +72/−0
- src/GramLab/Perceptron/Model.hs +184/−0
- src/GramLab/Perceptron/Multiclass.hs +171/−0
- src/GramLab/Perceptron/Vector.hs +74/−0
- src/GramLab/Utils.hs +98/−0
- src/Lemma.hs +42/−0
- src/Main.hs +16/−0
- src/POS.hs +41/−0
− GramLab/Binomial.hs
@@ -1,60 +0,0 @@-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
@@ -1,54 +0,0 @@-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
@@ -1,29 +0,0 @@-{-# 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
@@ -1,61 +0,0 @@-{-# 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
@@ -1,10 +0,0 @@-{-# 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
@@ -1,14 +0,0 @@-{-# 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
@@ -1,52 +0,0 @@-{-# 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
@@ -1,139 +0,0 @@--------------------------------------------------------------------------------- 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
@@ -1,56 +0,0 @@-{-# 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
@@ -1,56 +0,0 @@-{-# 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
@@ -1,59 +0,0 @@-{-# 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
@@ -1,28 +0,0 @@-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
@@ -1,19 +0,0 @@-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
@@ -1,78 +0,0 @@-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
@@ -1,51 +0,0 @@-{-# 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
@@ -1,48 +0,0 @@-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
@@ -1,82 +0,0 @@-module GramLab.Morfette.Lang.Conf ( Lexicon- , Conf(..)- , Lang - , makeConf- , emptyLexicon- , saveConf- , readConf- , parseLexicon- , splitPOS- )-where-import qualified Data.Map as Map-import qualified Data.Set as Set-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-import Debug.Trace-import qualified Control.Monad.State as S- -type Lang = String-type Lexicon = Map.Map String [(String, String)]-data Conf = Conf { dictLex :: Lexicon- , lang :: Lang } deriving (Eq)--instance Binary Conf where- put (Conf x y) = put x >> put y- get = do- x <- get- y <- get- return (Conf x y)--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)--parseLexicon :: Maybe (Set.Set String) -> String -> Lexicon -parseLexicon toks = - Map.fromListWith (++)- . flip S.evalState Map.empty - . mapM (\(f,(l,p)) -> do- f' <- atomize f- l' <- atomize l- p' <- atomize p- return (f',[(l',p')]))- . maybe id (\d -> filter (\(w,_) -> w `Set.member`d)) toks- . concatMap parseEntry - . lines --parseEntry :: String -> [(String,(String, String))]-parseEntry line = - let (form:pairs) = words line - in [ lemma == lemma && pos == pos `seq` (form,(lemma,lowercase pos))- | [lemma,pos] <- splitInto 2 $ pairs ]----splitPOS :: Lang -> String -> [String]-splitPOS "tr" = splitWith (=='+')-splitPOS "pl" = splitWith (==':')-splitPOS "cy" = splitWith (=='-')-splitPOS "ga" = splitWith (=='-')-splitPOS _ = map return--atomize str = do- d <- S.get- case Map.lookup str d of- Nothing -> do S.put (Map.insert str str d)- return str- Just str' -> return str'
− GramLab/Morfette/MWE.hs
@@ -1,44 +0,0 @@-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
@@ -1,144 +0,0 @@-module GramLab.Morfette.Models ( train- , trainFun- , predict - , predictPipeline- , toModelFun- , mkPreprune- , sentToExamples- , 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,Show 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
@@ -1,15 +0,0 @@-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
@@ -1,31 +0,0 @@-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
@@ -1,332 +0,0 @@-{-# 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 qualified Data.IntMap as IntMap-import Control.Monad hiding (join)-import GramLab.Utils (padRight,splitWith,splitOn- ,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-import GramLab.Intern (Table(..),intern,initial,runState,evalState)-import GramLab.FeatureSet (toFeatureSet,FeatureSet)-import Debug.Trace--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- | ModelId String- 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" ])- , ("extract-features", CommandSpec (extractFeatures fs fspecs)- "extract features"- [ Option [] ["dict-file"] - (ReqArg DictFile "PATH")- "path to optional dictionary"- , Option [] ["model-id"]- (ReqArg ModelId "pos|lemma")- "model id (`pos' or `lemma')"- ]- [ "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"-classMapFile dir = dir </> "classmap.model"-featMapFile dir = dir </> "featmap.model"--defaultGaussianPrior = 1--extractFeatures :: (Ord a,Binary a,Show a) =>- (Token -> Models.Tok a, t)- -> [Conf -> Models.FeatureSpec a]- -> [Flag]- -> [FilePath]- -> IO ()-extractFeatures (prepr,fmt) [fspos,fslem] flags [modeldir] = do- dict <- getDict flags Nothing- -- dict == dict `seq` return ()- let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }- lex = Conf { dictLex = dict- , lang = langConf }- fs = case [f | ModelId f <- flags ] of- ["pos"] -> fspos lex- ["lemma"] -> fslem lex- [] -> fspos lex- other -> error $ "GramLab.Morfette.Utils.extractFeatures: " - ++ "invalid option value: " ++ show other- toks <- fmap (map parseToken . lines) getContents- let ws = filter (not . null) . map tokenForm $ toks- (xm,ym,xys) = convertFeatures- . map swap- . concatMap (Models.sentToExamples fs)- . toksToSentences prepr - $ toks - putStr . unlines - . map format- . zip ws- $ xys- B.writeFile (classMapFile modeldir) . encode $ ym- B.writeFile (featMapFile modeldir) . encode $ xm--format :: (String,(IntMap.IntMap Double,Int)) -> String-format (w,(x,y)) = unwords (w:show y : [ show i ++ ":" ++ show n - | (i,n) <- IntMap.toList x ])-parse :: String -> (String,(IntMap.IntMap Double,Int))-parse s = case words s of- (w:y:x) -> (w,( IntMap.fromList [ (read i,read xi) - | ixi <- x- , let [i,xi] = splitOn ':' ixi- ]- , read y ))-swap (y,x) = (x,y)--convertFeatures xys = - let (xs,ys) = unzip xys- (xs',xm) = flip runState initial . mapM toFeatureSet $ xs- (ys',ym) = flip runState initial . mapM intern $ ys- in (xm,ym,zip xs' ys')---train :: (Ord a, Show a, Binary a) =>- (Token -> Models.Tok a, t)- -> [Conf -> Models.FeatureSpec a]- -> [Flag]- -> [FilePath]- -> IO ()-train (prepr,_) fspecs flags [dat,modeldir] = do- toks <- fmap (map parseToken . lines) (readFile dat)- let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ]- dict <- getDict flags Nothing- let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }- lex = Conf { dictLex = dict- , 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] -> Maybe (Set.Set String) -> IO Lexicon-getDict flags tokSet = do- case [f | DictFile f <- flags ] of- [f] -> do - d <- fmap (parseLexicon tokSet) $ readFile f- return d- [] -> 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- (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)- dict <- getDict flags . Just $ seen- let 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
@@ -1,72 +0,0 @@-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 Data.Array.Unboxed--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 -> UArray (Int,Int) Bool- -> [(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 ]- examples'' = map swap examples'- labels = map fst examples'- featids = concatMap (map fst . snd) examples'- weights = examples'' == examples'' `seq` P.train (realToFrac $ rate s) - (iter s) - (lo,hi)- yss- $ examples'' - model = IntModel { modelLabels = IntSet.fromList labels- , 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
@@ -1,184 +0,0 @@-{-# 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 qualified Data.IntSet as IntSet-import Data.Array.Unboxed hiding ((!))-import Data.List (foldl')-import Data.Maybe (catMaybes)-import GramLab.Utils (uniq)-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 yss' samples- (ys,xs) = unzip examples- yss' = accumArray (flip const) False ((0,lo),(length yss-1,hi))- . concatMap (\(i,js) -> [ ((i,cm!j),True) | j <- js ])- $ zip [0..] yss- (lo,hi) = (minimum yset,maximum yset)- yset = IntSet.toList . IntSet.fromList $ ys'- (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
@@ -1,171 +0,0 @@-{-# 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 Data.Map ((!))-import qualified Data.Set as Set-import qualified Data.IntSet as IntSet-import Data.Bits-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' :: (Float, DenseVector (Y,I), DenseVector (Y,I)) - -> [Y]- -> X- -> Y-decode' w ys x = snd . maximum - $ [ (w`dot'`phi x y,y) | 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- -> A.UArray (Int,Int) Bool- -> [(X, Y)]- -> (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I))- -> ST s ()-iter rate yss ss (c,params,params_a) = do- let ((_,lo),(_,hi)) = A.bounds yss- ys = [lo..hi]- for_ (zip [0..] ss) $ \ (i,(x,y)) -> do- params' <- unsafeFreeze params- let ys' = [ y | y <- ys , yss A.! (i,y) ] - 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 :: Float- -> Int- -> ((Y,I), (Y,I))- -> A.UArray (Int,Int) Bool- -> [(X, Y)]- -> Model-train 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- let ixys = zip [0..] xys- ((_,lo),(_,hi)) = A.bounds yss- ys = [lo..hi]- for_ [1..epochs] $ - \i -> do iter rate yss xys (c,params,params_a)- c' <- readSTRef c- params' <- unsafeFreeze params- params_a' <- unsafeFreeze params_a- let w = (fromIntegral c',params',params_a')- corr = sum - . map (\(j,(x,y)) -> - let s = [ y | y <- ys - , yss A.!(j,y)]- in fromEnum - $ y /= decode' w s x)- $ ixys- 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
@@ -1,74 +0,0 @@-{-# 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' :: (Float,DenseVector (Int,Int),DenseVector (Int,Int)) - -> ([(Int,Float)],Int)- -> Float-dot' (!c,params,params_a) (x,!y) = go 0 x- where go !s [] = s- go !s ((!i,!xi):x) = - let e = params ! (y,i)- e_a = params_a ! (y,i)- in go (s + (e - (e_a * (1/c))) * xi) 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
@@ -1,98 +0,0 @@-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
− Lemma.hs
@@ -1,42 +0,0 @@-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 (show . make w . fst) $ 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
@@ -1,16 +0,0 @@--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 = unlines . map (\ [Str f,Str p,ES s] -> - unwords [f,L.apply s . lowercase $ f,p]) - --prep (f,Just l, Just p) = [Str f,Str p, L.make f l]
Makefile view
@@ -1,8 +1,11 @@ defaults: all +++ #program name-MORFETTE=../src/dist/build/morfette/morfette+MORFETTE=dist/build/morfette/morfette #parameters for training and eval@@ -10,15 +13,15 @@ # for french TYPE can be either ftb4 or ftbmax TYPE=ftb4-TRAINDATADIR=../DATA/+TRAINDATADIR=DATA/ PREF=${TRAINDATADIR}/${TYPE} TRAINSET=${PREF}/ftb_1.pos.utf8.morpheteready DEVSET=${PREF}/ftb_2.pos.utf8.morpheteready GOLDSET=${PREF}/ftb_3.pos.utf8.morpheteready LEXICON=${TRAINDATADIR}/lexicon/lexicon.ftb4.4morfette.csv-ITERPOS=5-ITERLEMMA=2+ITERPOS=10+ITERLEMMA=3 MODELNAME=${PREF}/${TYPE}.${ITERPOS}x${ITERLEMMA}.model all: configure build@@ -27,15 +30,28 @@ check: train eval_dev ++# note that if you want to install in your own home directory+# add a --prefix=DIRTOINSTALL option right after the --user+# as in +# runghc Setup.lhs configure --user --prefix=/home/foo/bar+# the install target will then install the morfette compiled binary+# in /home/foo/bar/bin (bin must exist)+ configure: runghc Setup.lhs configure --user + build: configure runghc Setup.lhs build -install:+install: configure build runghc Setup.lhs install + +install_home:+ + clean: runghc Setup.lhs clean @@ -50,8 +66,8 @@ eval_dev:- ${MORFETTE} predict ${MODELNAME} < ${DEVSET} > ${DEVSET}.tagged- ${MORFETTE} eval --ignore-case ${TRAINSET} ${DEVSET} ${DEVSET}.tagged |\+ #${MORFETTE} predict ${MODELNAME} < ${DEVSET} > ${DEVSET}.tagged+ ${MORFETTE} eval --ignore-case /dev/null ${DEVSET} ${DEVSET}.tagged |\ tee ${DEVSET}.tagged.result.${TYPE}.${ITERPOS}x${ITERLEMMA}.model
− POS.hs
@@ -1,41 +0,0 @@-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 snd $ Map.findWithDefault [] w (dictLex global)- getpos Nothing = ""- getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)
morfette.cabal view
@@ -1,5 +1,5 @@ Name: morfette-Version: 0.3.1+Version: 0.3.2 Homepage: http://sites.google.com/site/morfetteweb/ Synopsis: A tool for supervised learning of morphology Description: Morfette is a tool for supervised learning of inflectional@@ -15,12 +15,11 @@ Extra-source-files: README, INSTALL, Makefile Executable: morfette+hs-source-dirs: src 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.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,@@ -31,7 +30,7 @@ GramLab.Morfette.Settings.Defaults, GramLab.Morfette.Features.Common, Lemma, POS, GramLab.Morfette.Utils-Build-depends: base >=3 && <=4 , containers, array, QuickCheck, mtl, +Build-depends: base >=3 && <=5 , containers, array, mtl, directory, filepath, haskell98, pretty,- utf8-string, bytestring, binary+ utf8-string, bytestring, binary, QuickCheck >= 2.3 cc-options: -Wall
+ src/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))
+ src/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))+
+ src/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
+ src/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
+ src/GramLab/Data/Diff/EditTree.hs view
@@ -0,0 +1,64 @@+{-# 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+import Data.Binary+import Control.Monad (liftM2,liftM4)++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+++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
+ src/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
+ src/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)
+ src/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
+ src/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 } }+
+ src/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)))++
+ src/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 = '*'
+ src/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
+ src/GramLab/Morfette/Lang/Conf.hs view
@@ -0,0 +1,82 @@+module GramLab.Morfette.Lang.Conf ( Lexicon+ , Conf(..)+ , Lang + , makeConf+ , emptyLexicon+ , saveConf+ , readConf+ , parseLexicon+ , splitPOS+ )+where+import qualified Data.Map as Map+import qualified Data.Set as Set+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+import Debug.Trace+import qualified Control.Monad.State as S+ +type Lang = String+type Lexicon = Map.Map String [(String, String)]+data Conf = Conf { dictLex :: Lexicon+ , lang :: Lang } deriving (Eq)++instance Binary Conf where+ put (Conf x y) = put x >> put y+ get = do+ x <- get+ y <- get+ return (Conf x y)++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)++parseLexicon :: Maybe (Set.Set String) -> String -> Lexicon +parseLexicon toks = + Map.fromListWith (++)+ . flip S.evalState Map.empty + . mapM (\(f,(l,p)) -> do+ f' <- atomize f+ l' <- atomize l+ p' <- atomize p+ return (f',[(l',p')]))+ . maybe id (\d -> filter (\(w,_) -> w `Set.member`d)) toks+ . concatMap parseEntry + . lines ++parseEntry :: String -> [(String,(String, String))]+parseEntry line = + let (form:pairs) = words line + in [ lemma == lemma && pos == pos `seq` (form,(lemma,lowercase pos))+ | [lemma,pos] <- splitInto 2 $ pairs ]++++splitPOS :: Lang -> String -> [String]+splitPOS "tr" = splitWith (=='+')+splitPOS "pl" = splitWith (==':')+splitPOS "cy" = splitWith (=='-')+splitPOS "ga" = splitWith (=='-')+splitPOS _ = map return++atomize str = do+ d <- S.get+ case Map.lookup str d of+ Nothing -> do S.put (Map.insert str str d)+ return str+ Just str' -> return str'
+ src/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+
+ src/GramLab/Morfette/Models.hs view
@@ -0,0 +1,144 @@+module GramLab.Morfette.Models ( train+ , trainFun+ , predict + , predictPipeline+ , toModelFun+ , mkPreprune+ , sentToExamples+ , 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,Show 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)
+ src/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 }+
+ src/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+
+ src/GramLab/Morfette/Utils.hs view
@@ -0,0 +1,340 @@+{-# 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,stdin,hSetBinaryMode)+import System.IO.UTF8 hiding (getContents,print,putStr,putStrLn)+import qualified System.IO.UTF8 as 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 qualified Data.IntMap as IntMap+import Control.Monad hiding (join)+import GramLab.Utils (padRight,splitWith,splitOn+ ,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 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+import GramLab.Intern (Table(..),intern,initial,runState,evalState)+import GramLab.FeatureSet (toFeatureSet,FeatureSet)+import Debug.Trace++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+ | ModelId String+ 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" ])+ , ("extract-features", CommandSpec (extractFeatures fs fspecs)+ "extract features"+ [ Option [] ["dict-file"] + (ReqArg DictFile "PATH")+ "path to optional dictionary"+ , Option [] ["model-id"]+ (ReqArg ModelId "pos|lemma")+ "model id (`pos' or `lemma')"+ ]+ [ "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"+classMapFile dir = dir </> "classmap.model"+featMapFile dir = dir </> "featmap.model"++defaultGaussianPrior = 1++extractFeatures :: (Ord a,Binary a,Show a) =>+ (Token -> Models.Tok a, t)+ -> [Conf -> Models.FeatureSpec a]+ -> [Flag]+ -> [FilePath]+ -> IO ()+extractFeatures (prepr,fmt) [fspos,fslem] flags [modeldir] = do+ dict <- getDict flags Nothing+ -- dict == dict `seq` return ()+ let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }+ lex = Conf { dictLex = dict+ , lang = langConf }+ fs = case [f | ModelId f <- flags ] of+ ["pos"] -> fspos lex+ ["lemma"] -> fslem lex+ [] -> fspos lex+ other -> error $ "GramLab.Morfette.Utils.extractFeatures: " + ++ "invalid option value: " ++ show other+ toks <- fmap (map parseToken . lines) getContents+ let ws = filter (not . null) . map tokenForm $ toks+ (xm,ym,xys) = convertFeatures+ . map swap+ . concatMap (Models.sentToExamples fs)+ . toksToSentences prepr + $ toks + putStr . unlines + . map format+ . zip ws+ $ xys+ B.writeFile (classMapFile modeldir) . encode $ ym+ B.writeFile (featMapFile modeldir) . encode $ xm++format :: (String,(IntMap.IntMap Double,Int)) -> String+format (w,(x,y)) = unwords (w:show y : [ show i ++ ":" ++ show n + | (i,n) <- IntMap.toList x ])+parse :: String -> (String,(IntMap.IntMap Double,Int))+parse s = case words s of+ (w:y:x) -> (w,( IntMap.fromList [ (read i,read xi) + | ixi <- x+ , let [i,xi] = splitOn ':' ixi+ ]+ , read y ))+swap (y,x) = (x,y)++convertFeatures xys = + let (xs,ys) = unzip xys+ (xs',xm) = flip runState initial . mapM toFeatureSet $ xs+ (ys',ym) = flip runState initial . mapM intern $ ys+ in (xm,ym,zip xs' ys')+++train :: (Ord a, Show a, Binary a) =>+ (Token -> Models.Tok a, t)+ -> [Conf -> Models.FeatureSpec a]+ -> [Flag]+ -> [FilePath]+ -> IO ()+train (prepr,_) fspecs flags [dat,modeldir] = do+ toks <- fmap (map parseToken . lines) (readFile dat)+ let tokSet = Set.fromList [ s | t@(s,_,_) <- toks ]+ dict <- getDict flags Nothing+ let langConf = case [f | Lang f <- flags ] of { [] -> "xx" ; [f] -> f }+ lex = Conf { dictLex = dict+ , 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] -> Maybe (Set.Set String) -> IO Lexicon+getDict flags tokSet = do+ case [f | DictFile f <- flags ] of+ [f] -> do + d <- fmap (parseLexicon tokSet) $ readFile f+ return d+ [] -> 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+ (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)+ dict <- getDict flags . Just $ seen+ let 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+ ++getContents :: IO String+getContents = hSetBinaryMode stdin True >> UTF8.getContents+ +putStr :: String -> IO ()+putStr s = hSetBinaryMode stdout True >> UTF8.putStr s++putStrLn :: String -> IO ()+putStrLn s = hSetBinaryMode stdout True >> UTF8.putStrLn s
+ src/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 Data.Array.Unboxed++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 -> UArray (Int,Int) Bool+ -> [(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 ]+ examples'' = map swap examples'+ labels = map fst examples'+ featids = concatMap (map fst . snd) examples'+ weights = examples'' == examples'' `seq` P.train (realToFrac $ rate s) + (iter s) + (lo,hi)+ yss+ $ examples'' + model = IntModel { modelLabels = IntSet.fromList labels+ , 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+
+ src/GramLab/Perceptron/Model.hs view
@@ -0,0 +1,184 @@+{-# 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 qualified Data.IntSet as IntSet+import Data.Array.Unboxed hiding ((!))+import Data.List (foldl')+import Data.Maybe (catMaybes)+import GramLab.Utils (uniq)+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 yss' samples+ (ys,xs) = unzip examples+ yss' = accumArray (flip const) False ((0,lo),(length yss-1,hi))+ . concatMap (\(i,js) -> [ ((i,cm!j),True) | j <- js ])+ $ zip [0..] yss+ (lo,hi) = (minimum yset,maximum yset)+ yset = IntSet.toList . IntSet.fromList $ ys'+ (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 +
+ src/GramLab/Perceptron/Multiclass.hs view
@@ -0,0 +1,171 @@+{-# 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 Data.Map ((!))+import qualified Data.Set as Set+import qualified Data.IntSet as IntSet+import Data.Bits+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' :: (Float, DenseVector (Y,I), DenseVector (Y,I)) + -> [Y]+ -> X+ -> Y+decode' w ys x = snd . maximum + $ [ (w`dot'`phi x y,y) | 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+ -> A.UArray (Int,Int) Bool+ -> [(X, Y)]+ -> (STRef s Int, DenseVectorST s (Y,I), DenseVectorST s (Y,I))+ -> ST s ()+iter rate yss ss (c,params,params_a) = do+ let ((_,lo),(_,hi)) = A.bounds yss+ ys = [lo..hi]+ for_ (zip [0..] ss) $ \ (i,(x,y)) -> do+ params' <- unsafeFreeze params+ let ys' = [ y | y <- ys , yss A.! (i,y) ] + 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 :: Float+ -> Int+ -> ((Y,I), (Y,I))+ -> A.UArray (Int,Int) Bool+ -> [(X, Y)]+ -> Model+train 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+ let ixys = zip [0..] xys+ ((_,lo),(_,hi)) = A.bounds yss+ ys = [lo..hi]+ for_ [1..epochs] $ + \i -> do iter rate yss xys (c,params,params_a)+ c' <- readSTRef c+ params' <- unsafeFreeze params+ params_a' <- unsafeFreeze params_a+ let w = (fromIntegral c',params',params_a')+ corr = sum + . map (\(j,(x,y)) -> + let s = [ y | y <- ys + , yss A.!(j,y)]+ in fromEnum + $ y /= decode' w s x)+ $ ixys+ 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
+ src/GramLab/Perceptron/Vector.hs view
@@ -0,0 +1,74 @@+{-# 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' :: (Float,DenseVector (Int,Int),DenseVector (Int,Int)) + -> ([(Int,Float)],Int)+ -> Float+dot' (!c,params,params_a) (x,!y) = go 0 x+ where go !s [] = s+ go !s ((!i,!xi):x) = + let e = params ! (y,i)+ e_a = params_a ! (y,i)+ in go (s + (e - (e_a * (1/c))) * xi) 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+
+ src/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
+ src/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 (show . make w . fst) $ 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)
+ src/Main.hs view
@@ -0,0 +1,16 @@++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 = unlines . map (\ [Str f,Str p,ES s] -> + unwords [f,L.apply s . lowercase $ f,p]) + ++prep (f,Just l, Just p) = [Str f,Str p, L.make f l]
+ src/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 snd $ Map.findWithDefault [] w (dictLex global)+ getpos Nothing = ""+ getpos (Just (Str form:Str label:_)) = head (splitPOS (lang global) label)