From ac0169cf20aff285f5cd16f22d74e605ba28e0bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tomasz=20Obr=C4=99bski?= Date: Thu, 16 Mar 2017 09:03:46 +0100 Subject: [PATCH] some past changes --- Base.hs | 3 +- FDP.hs | 43 ++++++++++++++++++++++++++ FDP1.hs | 6 ++-- G1.hs | 7 ++--- Grammar.hs | 37 ++++++++++++++++------ Lexicon.hs | 9 ++++-- PL1.hs | 88 ++++++++++++++++++++--------------------------------- Parse.hs | 42 +++++++++++++++++++++++-- ParserW.hs | 85 ++++++++------------------------------------------- PoliMorf.hs | 2 +- Weighted.hs | 15 ++++++--- 11 files changed, 180 insertions(+), 157 deletions(-) create mode 100644 FDP.hs diff --git a/Base.hs b/Base.hs index bc81c1a..bb04e7b 100644 --- a/Base.hs +++ b/Base.hs @@ -1,12 +1,13 @@ module Base ( Ind, Wordform, - Arc (Head,Dep) + Arc (Head,Dep,Root) ) where type Ind = Int type Wordform = String data Arc τ = Head { role :: τ, dst :: Ind } | Dep { role :: τ, dst :: Ind } + | Root deriving (Show,Eq,Ord) diff --git a/FDP.hs b/FDP.hs new file mode 100644 index 0000000..d976efb --- /dev/null +++ b/FDP.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Main ( + module ParserW, + module Parse, + module Step, + module G1, + module PoliMorf, + module Data.ADTTag.IPITag.PoliMorf, + module PL1, + main + ) where + + +import ParserW +import Parse +import Step +import G1 +import Data.ADTTag.IPITag.PoliMorf +import PoliMorf +import PL1 +import Weighted + +import Control.Applicative + +instance Show (WeightedList IPITag) where + show = show . runWeightedT + +main = do + input <- words <$> getLine + pm <- readPoliMorfForms input "pm.tsv" + let WeightedT allparses = parse pm pl1 input :: WeightedList (Parse Role IPITag) + parselist = zip [1..] allparses + putStrLn $ "### PARSES: " ++ show (length parselist) + sequence_ $ map (\(n,Weighted w p) -> do + putStrLn $ "### " ++ show n ++ "#" ++ show w + -- putStrLn $ show p + sequence_ $ map (putStrLn . show) (conll input p) + ) parselist + + -- putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . unweighted . snd) parselist)) + diff --git a/FDP1.hs b/FDP1.hs index 05523c7..faabe67 100644 --- a/FDP1.hs +++ b/FDP1.hs @@ -27,10 +27,10 @@ instance Show (WeightedList IPITag) where main = do pm <- readPoliMorfHead1 200000 "pm.sorted.uniq.tsv" - let l = length (parse' pm pl1' "dom" :: WeightedList (Parse Role (WeightedList IPITag))) + let l = length (parse pm pl1 "dom" :: WeightedList (Parse Role IPITag)) putStrLn $ "READY (" ++ show l ++ ")" input <- getLine - let WeightedT parses = parseA' pm pl1' input :: WeightedList (Parse Role (WeightedList IPITag)) + let WeightedT parses = parseA pm pl1 input :: WeightedList (Parse Role IPITag) parselist = zip [1..] parses -- sequence_ $ map (\(n,p) -> do -- putStrLn $ "*** [" ++ show n ++ "] ***" @@ -38,5 +38,5 @@ main = do -- ) parselist putStrLn $ "PARSES: " ++ show (length parselist) - putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . bare . snd) parselist)) + putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . unweighted . snd) parselist)) diff --git a/G1.hs b/G1.hs index e646e03..526d295 100644 --- a/G1.hs +++ b/G1.hs @@ -2,9 +2,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MonadComprehensions #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE FlexibleContexts #-} - module G1 ( module Grammar, G1 (G1), @@ -28,9 +25,9 @@ import Weighted import Prelude.Unicode -- import Data.Foldable -data G1 τ κ = G1 { links :: WeightedT [] (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] } +data G1 τ κ = G1 { links :: WeightedList (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] } -instance (Eq τ) => Grammar (WeightedT []) τ κ (G1 τ κ) where +instance (Eq τ) => WeightedGrammar τ κ (G1 τ κ) where link g h d = [ (r, gcs g ++ cs) | LINK r p q cs <- links g, p h, q d ] -- sat :: G1 τ κ -> Node τ κ -> Bool -- sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p (cat n), r <- rs ] diff --git a/Grammar.hs b/Grammar.hs index 02af8df..22ff197 100644 --- a/Grammar.hs +++ b/Grammar.hs @@ -10,34 +10,51 @@ import Data.List -- import Data.Monoid -- import Control.Monad.Unicode import Node --- import Weighted +import Weighted type Constraint τ κ = (τ, Node τ κ, Node τ κ) -> Bool -class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where +-- class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where - heads :: γ -> Node τ κ -> m (τ, Node τ κ) +-- heads :: γ -> Node τ κ -> m (τ, Node τ κ) +-- heads g n = [ (r,h) | h <- visible g n, +-- (r,cs) <- link g (cat h) (cat n), +-- all ($ (r,h,n)) cs ] + +-- deps :: γ -> Node τ κ -> m (τ, Node τ κ) +-- deps g n = [ (r,d) | d <- visible g n, +-- (r,cs) <- link g (cat n) (cat d), +-- all ($ (r,n,d)) cs ] + +-- visible :: γ -> Node τ κ -> m (Node τ κ) +-- visible _ = mfromList . lv + +-- pass :: γ -> Node τ κ -> Bool +-- pass = const . const True + +-- link :: γ -> κ -> κ -> m (τ, [Constraint τ κ]) + +class (Eq τ) => WeightedGrammar τ κ γ where + + heads :: γ -> Node τ κ -> WeightedList (τ, Node τ κ) heads g n = [ (r,h) | h <- visible g n, (r,cs) <- link g (cat h) (cat n), all ($ (r,h,n)) cs ] - deps :: γ -> Node τ κ -> m (τ, Node τ κ) + deps :: γ -> Node τ κ -> WeightedList (τ, Node τ κ) deps g n = [ (r,d) | d <- visible g n, (r,cs) <- link g (cat n) (cat d), all ($ (r,n,d)) cs ] - visible :: γ -> Node τ κ -> m (Node τ κ) + visible :: γ -> Node τ κ -> WeightedList (Node τ κ) visible _ = mfromList . lv - -- sat :: Grammar m τ κ γ => γ -> Node τ κ -> Bool - -- sat = const . const True - pass :: γ -> Node τ κ -> Bool pass = const . const True - -- pass g n = sat g n --all (sat g) ((preds<>pure) n) - link :: γ -> κ -> κ -> m (τ, [Constraint τ κ]) + link :: γ -> κ -> κ -> WeightedList (τ, [Constraint τ κ]) +-- type WeightedGrammar = Grammar WeightedList type Constraint' m τ κ = (τ, Node τ (m κ), Node τ (m κ)) -> Bool diff --git a/Lexicon.hs b/Lexicon.hs index 04dec9c..c46ec09 100644 --- a/Lexicon.hs +++ b/Lexicon.hs @@ -1,10 +1,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} -module Lexicon (Lexicon,dic) +module Lexicon (WeightedLexicon,dic) where import Control.Monad.Plus +import Weighted +-- class (MonadPlus m) => Lexicon m a d where +-- dic :: d -> String -> m a -class (MonadPlus m) => Lexicon m a d where - dic :: d -> String -> m a +class WeightedLexicon a d where + dic :: d -> String -> WeightedList a diff --git a/PL1.hs b/PL1.hs index d5b9be0..794b46b 100644 --- a/PL1.hs +++ b/PL1.hs @@ -16,9 +16,6 @@ import Control.Monad.Identity data Role = Subj | Cmpl | Mod | Poss | Prep | PCmpl | CCmpl | Coord | Conj | Num | Det deriving (Show,Eq,Ord) - - - ppron = ppron12 ∪ ppron3 n = subst ∪ ger @@ -43,14 +40,14 @@ n'' = subst ∪ ppron12 ∪ ppron3 agrNPG, agrC :: Constraint Role IPITag -agrNPG = \(_,h,d) -> agrNumber (cat h) (cat d) ∧ agrPerson (cat h) (cat d) ∧ agrGender (cat h) (cat d) -agrNCG = \(_,h,d) -> agrNumber (cat h) (cat d) ∧ agrCase (cat h) (cat d) ∧ agrGender (cat h) (cat d) -agrC = \(_,h,d) -> test ( agrCase<$>Identity (cat h)<*>Identity (cat d) ) +agrNPG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrPerson (cat x) (cat y) ∧ agrGender (cat x) (cat y) +agrNCG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrCase (cat x) (cat y) ∧ agrGender (cat x) (cat y) +agrC (_,x,y) = agrCase (cat x) (cat y) ---right, left, sgl :: Constraint Role IPITag -right = \(_,h,d) -> h < d -left = \(_,h,d) -> d < h -sgl = \(r,h,_) -> r ∉ roles h +right, left, sgl :: Constraint Role IPITag +right (_,h,d) = h < d +left (_,h,d) = d < h +sgl (r,h,_) = r ∉ roles h coord = nominalCoord \/ verbalCoord \/ adjectivalCoord @@ -60,7 +57,7 @@ verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumb adjectivalCoord (_,h,d) = adjectival (cat d) ∧ or [ adjectival (cat h₂) - -- && agrNPG (undefined,h₂,d) + -- && agrNPG (h₂,d) ∧ agrNumber (cat d) (cat h₂) ∧ agrCase (cat d) (cat h₂) ∧ agrGender (cat d) (cat h₂) @@ -73,9 +70,9 @@ adjectivalCoord (_,h,d) = adjectival (cat d) -coord' = nominalCoord' -- \/ verbalCoord' \/ adjectivalCoord' +-- coord' = nominalCoord' -- \/ verbalCoord' \/ adjectivalCoord' -nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h₂) ∧ (alt2 agrCase) (cat d) (cat h₂) | h₂ <- lhdBy Coord h] +-- nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h₂) ∧ (alt2 agrCase) (cat d) (cat h₂) | h₂ <- lhdBy Coord h] -- verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumber (cat d) (cat h₂) | h₂ <- lhdBy Coord h ] @@ -92,28 +89,28 @@ nominalCoord' (_,h,d) = (alt nominal) (cat d) ∧ or [ (alt nominal) (cat h -- amb f (r,Node i₁ cs₁ h₁ ds₁,Node i₂ cs₂ h₂ ds₂) = or [ c (r,Node i₁ c₁ h,Node t c₂) | c₁ <- cs₁, c₂ <- cs₂ ] -right' = \(_,h,d) -> h < d -left' = \(_,h,d) -> d < h - --- agrNPG', agrC' :: Constraint' (WeightedT []) Role IPITag -agrNPG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrPerson) (cat h) (cat d) ∧ (alt2 agrGender) (cat h) (cat d) -agrNCG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrCase (cat h) (cat d)) ∧ (alt2 agrGender) (cat h) (cat d) --- agrNCG'' = amb argNCG -agrC' = \(_,h,d) -> (alt2 agrCase) (cat h) (cat d) - -agrC''' :: Constraint' (WeightedT []) Role IPITag -agrC''' = \(_,h,d) -> test ( agrCase<$>(cat h)<*>(cat d) ) - -test :: (Foldable m) => m Bool -> Bool -test = foldl (∨) False - --- right', left', sgl' :: Constraint' (WeightedT []) Role IPITag -- right' = \(_,h,d) -> h < d -- left' = \(_,h,d) -> d < h --- sgl' = \(r,h,_) -> r ∉ roles h -alt f xs = or [ f x | x <- xs ] -alt2 f xs ys = or [ f x y | x <- xs , y <- ys ] +-- -- agrNPG', agrC' :: Constraint' (WeightedT []) Role IPITag +-- agrNPG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrPerson) (cat h) (cat d) ∧ (alt2 agrGender) (cat h) (cat d) +-- agrNCG' = \(_,h,d) -> (alt2 agrNumber) (cat h) (cat d) ∧ (alt2 agrCase (cat h) (cat d)) ∧ (alt2 agrGender) (cat h) (cat d) +-- -- agrNCG'' = amb argNCG +-- agrC' = \(_,h,d) -> (alt2 agrCase) (cat h) (cat d) + +-- agrC''' :: Constraint' (WeightedT []) Role IPITag +-- agrC''' = \(_,h,d) -> test ( agrCase<$>(cat h)<*>(cat d) ) + +-- test :: (Foldable m) => m Bool -> Bool +-- test = foldl (∨) False + +-- -- right', left', sgl' :: Constraint' (WeightedT []) Role IPITag +-- -- right' = \(_,h,d) -> h < d +-- -- left' = \(_,h,d) -> d < h +-- -- sgl' = \(r,h,_) -> r ∉ roles h + +-- alt f xs = or [ f x | x <- xs ] +-- alt2 f xs ys = or [ f x y | x <- xs , y <- ys ] pl1 = G1 { links = @@ -134,25 +131,6 @@ pl1 = G1 { links = obl = [OBL prep [PCmpl]] } -pl1' = G1' { links' = - WeightedT $ concat - [ - [ LINK' Subj v' (n ∩ nom) [agrNPG',sgl,d] #w | (d,w) <- [(left',0.8),(right',0.2)] ], - [ LINK' Cmpl v' cmpl'' [d] #w | (d,w) <- [(left',0.3),(right',0.7)] ], - [ LINK' Mod n adjectival [agrNCG'] #1 ], - [ LINK' Prep n' prep [d] #w | (d,w) <- [(left',0.1),(right',0.8)] ], - [ LINK' Prep v' prep [] #1 ], - [ LINK' PCmpl prep n [agrC',right'] #1 ], - [ LINK' PCmpl prep (ppron ∩ akc) [agrC',right'] #1 ], - [ LINK' Coord x conj [right'] #1 ], - [ LINK' CCmpl conj x [right',coord'] #1 ] - ], - gcs' = [obligatoriness'], - -- sat = saturated, - obl' = [OBL prep [PCmpl]] - } - - -- saturated :: Grammar -> Node Role IPITag -> Bool -- sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p n, r <- rs ] @@ -160,14 +138,14 @@ pl1' = G1' { links' = -- obligatoriness = const True ---obligatoriness :: (Eq τ) => Constraint τ κ +-- obligatoriness :: (Eq τ) => Constraint τ κ obligatoriness (r,h,d) | h < d = all sat'' (pure h >>= clo rmdp) | d < h = all sat'' (pure d >>= rclo rmdp) sat'' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, p (cat n), r <- rs ] -obligatoriness' (r,h,d) | h < d = all sat''' (pure h >>= clo rmdp) - | d < h = all sat''' (pure d >>= rclo rmdp) +-- obligatoriness' (r,h,d) | h < d = all sat''' (pure h >>= clo rmdp) +-- | d < h = all sat''' (pure d >>= rclo rmdp) -sat''' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, (alt p) (cat n), r <- rs ] +-- sat''' n = and [ r ∈ (roles n) | OBL p rs <- obl pl1, (alt p) (cat n), r <- rs ] diff --git a/Parse.hs b/Parse.hs index 988c9ca..3f02035 100644 --- a/Parse.hs +++ b/Parse.hs @@ -1,4 +1,4 @@ -module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps) +module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps,arcs) where -- import Data.List (intercalate) @@ -6,6 +6,7 @@ import Base import Step import Data.List +import GHC.Exts type Parse τ c = [Step τ c] @@ -47,4 +48,41 @@ showParse = concatMap shortStep showArc (Head r i) = show r ++ ":" ++ show i showArc (Dep r i) = show r ++ ":" ++ show i - + + + + +-- arclist :: Parse τ κ -> [(Int,Arc τ)] +-- arclist p = concatMap stepArcs p +-- where +-- indexes = [1..(length p)] +-- stepArcs (Step i _ hs ds) = [(i,Head t j) | Head t j <- hs ] ++ [(j,Head t i) | Dep t j <- ds ] +-- complete [] _ = [] +-- complete (i:is) (a@(i',_):as) | i == i' = a : complete is as +-- | otherwise = (i,Root) : complete is (a:as) + +arclist :: Parse τ κ -> [(Int,Arc τ)] +arclist p = complete indexes $ sortWith (\(i,_)->i) $ concatMap stepArcs p + where + indexes = [1..(length p)] + stepArcs (Step i _ hs ds) = [(i,Head t j) | Head t j <- hs ] ++ [(j,Head t i) | Dep t j <- ds ] + complete [] _ = [] + complete (i:is) (a@(i',_):as) | i == i' = a : complete is as + | otherwise = (i,Root) : complete is (a:as) + complete (i:is) [] = (i,Root) : complete is [] + + +conll :: [String] -> Parse τ κ -> [Conll τ κ] +conll words parse = let steps = reverse parse + arcs = arclist parse + in + conll' words steps arcs + where + conll' [] [] [] = [] + conll' (w:ws) (Step _ c _ _ : ss) ((i,a):as) = Conll i w c a : conll' ws ss as + + +data Conll τ κ = Conll Int String κ (Arc τ) +instance (Show τ, Show κ) => Show (Conll τ κ) where + show (Conll i w c Root) = intercalate "\t" [show i,w,show c,"0","Root"] + show (Conll i w c (Head t j)) = intercalate "\t" [show i,w,show c,show j,show t] diff --git a/ParserW.hs b/ParserW.hs index 7a2b19c..bbb89da 100644 --- a/ParserW.hs +++ b/ParserW.hs @@ -5,15 +5,9 @@ module ParserW ( module Parse, WeightedList, step, + parses, parse, - parseA, - parse', - parseA', - -- parseSel, - -- selectSize, shift, - shift', - -- shifts, connect, addHead, addDep) where @@ -34,89 +28,36 @@ import Control.Monad.Trans.Class import Control.Monad.Plus import Base import Weighted - -shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> m (Parse τ κ) +shift :: (WeightedLexicon κ δ) => δ -> String -> Parse τ κ -> WeightedList (Parse τ κ) shift d w p = [ p << Step (nextId p) c [] [] | c <- dic d w ] where nextId [] = 1 nextId (Step i _ _ _:_) = i + 1 - -shift' :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ (m κ) -> m (Parse τ (m κ)) -shift' d w p = return $ p << Step (nextId p) (dic d w) [] [] - where - nextId [] = 1 - nextId (Step i _ _ _:_) = i + 1 - - - --- shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> StateT Int m (Parse τ κ) --- shift d w p = do nextId <- get --- c <- lift (dic d w) --- let ret = p << Step nextId c [] [] --- modify (+ 1) --- return ret - --- where - -- nextId [] = 1 - -- nextId (Step i _ _ _:_) = i + 1 - - --- shifts :: (MonadPlus m) => [String] -> Parse -> m Parse --- shifts (s:ss) p = shift s p >>= shifts ss --- shifts [] p = return p - - -addHead, addDep :: (MonadPlus m, Grammar m τ κ γ) => γ -> Parse τ κ -> m (Parse τ κ) +addHead, addDep :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ) addHead g p = [ p +-> Head r (ind v') | let v = lastNode p, headless v, (r,v') <- heads g v ] addDep g p = [ p +<- Dep r (ind v') | let v = lastNode p, (r,v') <- deps g v, headless v' ] - -addHead', addDep' :: (MonadPlus m, Grammar' m τ κ γ) => γ -> Parse τ (m κ) -> m (Parse τ (m κ)) -addHead' g p = [ p +-> Head r (ind v') | let v = lastNode p, headless v, (r,v') <- heads' g v ] -addDep' g p = [ p +<- Dep r (ind v') | let v = lastNode p, (r,v') <- deps' g v, headless v' ] - -connect :: (MonadPlus m, Grammar m τ κ γ) => γ -> Parse τ κ -> m (Parse τ κ) +connect :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ) connect g = (addDep g >=> connect g) <> addHead g <> return -connect' :: (MonadPlus m, Grammar' m τ κ γ) => γ -> Parse τ (m κ) -> m (Parse τ (m κ)) -connect' g = (addDep' g >=> connect' g) <> addHead' g <> return - - -step :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> m (Parse τ κ) +step :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> WeightedList (Parse τ κ) step d g w = shift d w >=> connect g |? (<= 4) . trees -step' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> Wordform -> Parse τ (m κ) -> m (Parse τ (m κ)) -step' d g w = shift' d w >=> connect' g |? (<= 4) . trees - -steps :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ κ) +steps :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ) steps d g = foldM (flip (step d g)) mzero -steps' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ (m κ)) -steps' d g = foldM (flip (step' d g)) mzero +parses :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ) +parses d g = steps d g -parser :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ κ) -parser d g = steps d g -- |? (==1) . trees - -parser' :: (MonadPlus m, Lexicon m κ δ, Grammar' m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ (m κ)) -parser' d g = steps' d g -- |? (==1) . trees --- parser = steps |? pass.lastNode - --- parse :: (Lexicon WeightedList κ δ, Grammar WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ κ) -parse d g = (parser d g |? (==1) . trees |? pass g . lastNode) . words - -parse' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ)) -parse' d g = (parser' d g |? (==1) . trees) . words - -parseA :: (Lexicon WeightedList κ δ, Grammar WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ κ) -parseA d g = parser d g . words - -parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ)) -parseA' d g = parser' d g . words +parse :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ) +parse d g = parses d g |? (==1) . trees |? pass g . lastNode -type WeightedList = WeightedT [] +-- parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ)) +-- parseA' d g = parser' d g . words + -- type WeightedList = StateT Int (WeightedT []) diff --git a/PoliMorf.hs b/PoliMorf.hs index 67b8fd1..4841db4 100644 --- a/PoliMorf.hs +++ b/PoliMorf.hs @@ -11,7 +11,7 @@ import Lexicon import Data.ADTTag.IPITag import qualified Data.ADTTag.IPITag.PoliMorf as PM -instance (MonadPlus m) => Lexicon m IPITag PM.Dic where +instance WeightedLexicon IPITag PM.Dic where dic = PM.dic diff --git a/Weighted.hs b/Weighted.hs index 2f88ada..1b9a306 100644 --- a/Weighted.hs +++ b/Weighted.hs @@ -17,8 +17,8 @@ inv (Weight w) = (Weight (1.0 - w)) data Weighted a = Weighted Weight a -bare :: Weighted a -> a -bare (Weighted _ x) = x +unweighted :: Weighted a -> a +unweighted (Weighted _ x) = x weight :: Weighted a -> Weight weight (Weighted w _) = w @@ -34,6 +34,9 @@ instance Monad Weighted where return = pure (Weighted w x) >>= f = let (Weighted w' y) = f x in Weighted (w<>w') y + + + instance (Show a) => Show (Weighted a) where show (Weighted (Weight w) x) = show x ++ "#" ++ show w @@ -63,9 +66,9 @@ instance Alternative m => Alternative (WeightedT m) where x <|> y = WeightedT ( runWeightedT x <|> runWeightedT y ) instance (MonadPlus m, Foldable m) => Foldable (WeightedT m) where - -- foldr f z c = foldr f z (map bare $ toList $ runWeightedT c) - foldr f z c = foldr f z (fmap bare $ runWeightedT c) - -- foldr f z c = foldr (f . bare) z (runWeightedT c) + -- foldr f z c = foldr f z (map unweighted $ toList $ runWeightedT c) + foldr f z c = foldr f z (fmap unweighted $ runWeightedT c) + -- foldr f z c = foldr (f . unweighted) z (runWeightedT c) instance Monad m => Monad (WeightedT m) where return = WeightedT . return . return @@ -86,3 +89,5 @@ instance (Alternative m, Monad m) => MonadPlus (WeightedT m) -- (WeightedT x)= WeightedT $ sequenceA x + +type WeightedList = WeightedT []