From e2914d0ae84ca16ea9b14daf9fbe181360370032 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tomasz=20Obr=C4=99bski?= Date: Sat, 14 Jan 2017 16:13:50 +0100 Subject: [PATCH] initial --- Base.hs | 12 +++ FDP1.hs | 42 +++++++++ G1.hs | 55 ++++++++++++ Grammar.hs | 66 ++++++++++++++ Lexicon.hs | 10 +++ Node.hs | 116 +++++++++++++++++++++++++ PL1.hs | 173 +++++++++++++++++++++++++++++++++++++ Parse.hs | 50 +++++++++++ ParserW.hs | 245 ++++++++++++++++++++++++++++++++++++++++++++++++++++ PoliMorf.hs | 27 ++++++ Role.hs | 14 +++ Step.hs | 20 +++++ Toolbox.hs | 66 ++++++++++++++ Weighted.hs | 88 +++++++++++++++++++ 14 files changed, 984 insertions(+) create mode 100644 Base.hs create mode 100644 FDP1.hs create mode 100644 G1.hs create mode 100644 Grammar.hs create mode 100644 Lexicon.hs create mode 100644 Node.hs create mode 100644 PL1.hs create mode 100644 Parse.hs create mode 100644 ParserW.hs create mode 100644 PoliMorf.hs create mode 100644 Role.hs create mode 100644 Step.hs create mode 100644 Toolbox.hs create mode 100644 Weighted.hs diff --git a/Base.hs b/Base.hs new file mode 100644 index 0000000..bc81c1a --- /dev/null +++ b/Base.hs @@ -0,0 +1,12 @@ +module Base ( + Ind, + Wordform, + Arc (Head,Dep) + ) where + +type Ind = Int +type Wordform = String +data Arc τ = Head { role :: τ, dst :: Ind } + | Dep { role :: τ, dst :: Ind } + deriving (Show,Eq,Ord) + diff --git a/FDP1.hs b/FDP1.hs new file mode 100644 index 0000000..05523c7 --- /dev/null +++ b/FDP1.hs @@ -0,0 +1,42 @@ +{-# 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 + +instance Show (WeightedList IPITag) where + show = show . runWeightedT + +main = do + pm <- readPoliMorfHead1 200000 "pm.sorted.uniq.tsv" + let l = length (parse' pm pl1' "dom" :: WeightedList (Parse Role (WeightedList IPITag))) + putStrLn $ "READY (" ++ show l ++ ")" + input <- getLine + let WeightedT parses = parseA' pm pl1' input :: WeightedList (Parse Role (WeightedList IPITag)) + parselist = zip [1..] parses + -- sequence_ $ map (\(n,p) -> do + -- putStrLn $ "*** [" ++ show n ++ "] ***" + -- putStrLn $ show p + -- ) parselist + + putStrLn $ "PARSES: " ++ show (length parselist) + putStrLn $ "COMPLE: " ++ show (length (filter ((== 1) . trees . bare . snd) parselist)) + diff --git a/G1.hs b/G1.hs new file mode 100644 index 0000000..e646e03 --- /dev/null +++ b/G1.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonadComprehensions #-} + +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE FlexibleContexts #-} + +module G1 ( + module Grammar, + G1 (G1), + G1' (G1'), + links, + links', + gcs, + obl, + gcs', + obl', + LINK (LINK), + LINK' (LINK'), + OBL (OBL), + )where + +import Control.Monad.Plus +import Control.Monad.Trans.State +import Grammar +import Node +import Weighted +import Prelude.Unicode +-- import Data.Foldable + +data G1 τ κ = G1 { links :: WeightedT [] (LINK τ κ), gcs :: [Constraint τ κ], obl :: [OBL τ κ] } + +instance (Eq τ) => Grammar (WeightedT []) τ κ (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 ] + -- pass :: Grammar (WeightedT []) τ κ x => x -> Node τ κ -> Bool + -- pass g n = and [ sat g x | x <- preds n ] + pass g = all (sat g) . (pure <> preds) + where + sat g n = and [ r ∈ (roles n) | OBL p rs <- obl g, p (cat n), r <- rs ] + +data G1' τ κ = G1' { links' :: WeightedT [] (LINK' τ κ), gcs' :: [Constraint' (WeightedT []) τ κ], obl' :: [OBL τ κ] } + +instance (Eq τ) => Grammar' (WeightedT []) τ κ (G1' τ κ) where + link' g hs ds = [ (r, gcs' g ++ cs) | LINK' r p q cs <- links' g, any p hs, any q ds ] + -- sat' g n = and [ r ∈ (roles n) | OBL p rs <- obl' g, c <- (cat n), p c, r <- rs ] + + +-- instance (Eq τ, Eq κ) => Grammar (StateT Int (WeightedT [])) τ κ (G1 τ κ) where +-- link g h d = [ (r, gcs g ++ cs) | f <- links g, LINK r p q cs ← evalState f, p h, q d ] + +data LINK τ κ = LINK τ (κ -> Bool) (κ -> Bool) [Constraint τ κ] +data LINK' τ κ = LINK' τ (κ -> Bool) (κ -> Bool) [Constraint' (WeightedT []) τ κ] +data OBL τ κ = OBL (κ -> Bool) [τ] diff --git a/Grammar.hs b/Grammar.hs new file mode 100644 index 0000000..02af8df --- /dev/null +++ b/Grammar.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Grammar where + +import Control.Monad +import Control.Monad.Plus +import Control.Applicative +import Data.List +-- import Data.Monoid +-- import Control.Monad.Unicode +import Node +-- import Weighted + +type Constraint τ κ = (τ, Node τ κ, Node τ κ) -> Bool + +class (MonadPlus m, Eq τ {- , Eq κ -}) => Grammar m τ κ γ where + + 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 + + -- 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 τ κ]) + + +type Constraint' m τ κ = (τ, Node τ (m κ), Node τ (m κ)) -> Bool + +class (MonadPlus m, Eq τ) => Grammar' m τ κ γ where + + heads' :: γ -> Node τ (m κ) -> m (τ, Node τ (m κ)) + 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 κ) -> m (τ, Node τ (m κ)) + 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 κ) -> m (Node τ (m κ)) + visible' _ = mfromList . lv + + sat' :: γ -> Node τ (m κ) -> Bool + sat' = const . const True + + pass' :: γ -> Node τ (m κ) -> Bool + pass' = const . const True + + link' :: γ -> m κ -> m κ -> m (τ, [Constraint' m τ κ]) + diff --git a/Lexicon.hs b/Lexicon.hs new file mode 100644 index 0000000..04dec9c --- /dev/null +++ b/Lexicon.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Lexicon (Lexicon,dic) + where + +import Control.Monad.Plus + + +class (MonadPlus m) => Lexicon m a d where + dic :: d -> String -> m a diff --git a/Node.hs b/Node.hs new file mode 100644 index 0000000..e32a00f --- /dev/null +++ b/Node.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE FlexibleContexts #-} + +module Node + (Node (Node), + module Toolbox, + module Step, + dArcs,hArc,ind, cat, + cats, + preds,succs, + lng,rng,ng,ldp,rdp,dp,lhd,rhd,hd,lmdp,rmdp,lv,le, + lhdBy, + up,down,root,roots, + roles,leftRoles,rightRoles, + headless, + lastNode) + where + + +import Control.Monad +-- import Data.Monoid +import Data.List (intercalate,intersperse,find) +import Data.Maybe (maybeToList) +import Toolbox +import Step +import Parse +import Base + +data Node τ κ = Node {past :: [Step τ κ], future :: [Step τ κ]} -- deriving (Eq) +instance {- (Eq τ, Eq κ) => -} Eq (Node τ κ) where + n₁ == n₂ = (ind n₁) == (ind n₂) +instance {- (Eq τ, Eq κ) => -} Ord (Node τ κ) where + compare n₁ n₂ = compare (ind n₁) (ind n₂) + +ind :: Node τ κ -> Ind +ind (Node (Step i _ _ _ : _) _) = i + +cat :: Node τ κ -> κ +cat (Node (Step _ c _ _ : _) _) = c + +cats = map cat + +hArc, dArcs :: Node τ κ -> [Arc τ] +hArc (Node (Step _ _ h _ : _) _) = h +dArcs (Node (Step _ _ _ d : _) _) = d + +lastNode :: Parse τ κ -> Node τ κ +lastNode p = Node p [] + + +lng, rng :: Node τ κ -> [Node τ κ] + +lng (Node (s:s':p) q) = return (Node (s':p) (s:q)) +lng _ = mzero + +rng (Node p (s:q)) = return (Node (s:p) q) +rng _ = mzero + +ng, preds, succs :: Node τ κ -> [Node τ κ] +ng = lng <> rng + + +preds (Node (s:s':p) q) = let prev = (Node (s':p) (s:q)) in (Node (s':p) (s:q)) : preds prev +preds _ = [] +-- preds = clo lng +succs = clo rng + +lhd, rhd, hd, ldp, rdp, dp, le, lv, lmdp, rmdp, down, up, root, roots :: (Ord (Node τ κ)) => Node τ κ -> [Node τ κ] + +ldp n = [ n' | n' <- preds n, Dep _ i <- dArcs n, ind n' == i ] +rdp n = [ n' | n' <- succs n, Head _ i <- hArc n', ind n == i ] +dp = ldp <> rdp + +lhd v = [ v' | Head _ i <- hArc v, v' <- preds v, ind v' == i ] +rhd v = [ v' | v' <- succs v, Dep _ i <- dArcs v', ind v == i ] +hd = lhd <> rhd + +ldpBy,rdpBy,dpBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ] +ldpBy r n = [ n' | n' <- preds n, Dep r i <- dArcs n, ind n' == i ] +rdpBy r n = [ n' | n' <- succs n, Head r i <- hArc n', ind n == i ] +dpBy r = ldpBy r <> rdpBy r + +lhdBy,rhdBy,hdBy :: (Ord (Node τ κ)) => τ -> Node τ κ -> [Node τ κ] +lhdBy r n = [ n' | n' <- preds n, Head r i <- hArc n , ind n' == i ] +rhdBy r n = [ n' | n' <- succs n, Dep r i <- dArcs n', ind n == i ] +hdBy r = lhdBy r <> rhdBy r + + +le = mrclo lmdp + +lmdp = just minimum . ldp +rmdp = just maximum . rdp + +lv = mrclo lmdp >=> lng >=> rclo lhd + +down = clo dp +up = clo hd + +root = mrclo hd +roots = (filter headless) . preds + +headless :: (Ord (Node τ κ)) => Node τ κ -> Bool +headless = null . hd +-- roots = preds |? headless + +roles, leftRoles, rightRoles :: Node τ κ -> [τ] +roles = leftRoles <> rightRoles +leftRoles v = [ r | Dep r _ <- dArcs v ] +rightRoles v = [ r | v' <- succs v, Head r i <- hArc v', i==ind v ] + + +instance (Show τ, Show κ) => Show (Node τ κ) where + show (Node p q) = showSteps p ++ " @ " ++ showStepsRev q ++ "\n" + where + showStepsRev = intercalate " * " . map show + showSteps = showStepsRev . reverse diff --git a/PL1.hs b/PL1.hs new file mode 100644 index 0000000..d5b9be0 --- /dev/null +++ b/PL1.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE MonadComprehensions #-} + +module PL1 where + +import G1 +import Data.ADTTag +import Data.ADTTag.IPITag +import Control.Applicative +import Node +import Algebra.Lattice +import Prelude.Unicode +import Weighted +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 + +nominal = n ∪ ppron +verbal = fin ∪ praet +adjectival = adj ∪ pact ∪ ppas +adverbial = adv ∪ pcon ∪ pant + +cmpl'' = n ∩ (gen ∪ dat ∪ acc ∪ inst ∪ prep) + +x = nominal ∪ verbal ∪ adjectival ∪ adverbial + +v' = fin ∪ praet +n' = subst ∪ ger + +adj'' = adj ∪ pact ∪ ppas + +adv'' = adv ∪ pcon ∪ pant + +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) ) + +--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 + +nominalCoord (_,h,d) = nominal (cat d) ∧ or [ nominal (cat h₂) ∧ 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 ] + +adjectivalCoord (_,h,d) = adjectival (cat d) + ∧ or [ adjectival (cat h₂) + -- && agrNPG (undefined,h₂,d) + ∧ agrNumber (cat d) (cat h₂) + ∧ agrCase (cat d) (cat h₂) + ∧ agrGender (cat d) (cat h₂) + | h₂ <- lhdBy Coord h + ] + + + + + + + +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] + +-- verbalCoord (_,h,d) = verbal (cat d) ∧ or [ verbal (cat h₂) ∧ agrNumber (cat d) (cat h₂) | h₂ <- lhdBy Coord h ] + +-- adjectivalCoord (_,h,d) = adjectival (cat d) +-- ∧ or [ adjectival (cat h₂) +-- -- && agrNPG (undefined,h₂,d) +-- ∧ agrNumber (cat d) (cat h₂) +-- ∧ agrCase (cat d) (cat h₂) +-- ∧ agrGender (cat d) (cat h₂) +-- | h₂ <- lhdBy Coord 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 ] + + +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]] + } + +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 ] + + + +-- obligatoriness = const True +--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) + +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 new file mode 100644 index 0000000..988c9ca --- /dev/null +++ b/Parse.hs @@ -0,0 +1,50 @@ +module Parse -- (Step (Step),Parse,Ind,Arc,(+<-),(+->),(<<),nextId,size,len,trees,ep,eps) + where + +-- import Data.List (intercalate) +import Base +import Step + +import Data.List + +type Parse τ c = [Step τ c] + +ep = [] +eps = [ep] + +infixl 4 <<, +->, +<- +(<<) :: Parse τ κ -> Step τ κ -> Parse τ κ +p << s = s : p + +addNode = (<<) + +(+->),(+<-) :: Parse τ κ -> Arc τ -> Parse τ κ +(Step i c [] d : p) +-> a = Step i c [a] d : p +(Step i c h d : p) +<- a = Step i c h (a:d) : p + +linkHead = (+->) +linkDep = (+<-) + +nextId :: Parse τ κ -> Ind +nextId [] = 1 +nextId (Step i _ _ _:_) = i + 1 + +len :: Parse τ κ -> Int +len p = length p + +size :: Parse τ κ -> Int +size p = sum (map stepSize p) where stepSize (Step _ _ h ds) = length (h ++ ds) + +trees :: Parse τ κ -> Int +trees p = len p - size p + + +showParse :: (Show τ, Show κ) => Parse τ κ -> String +showParse = concatMap shortStep + where + shortStep (Step i c h ds) = "<" ++ show i ++ "|" ++ showArcs h ++ "|" ++ showArcs ds ++ ">" + showArcs = intercalate "," . map showArc + showArc (Head r i) = show r ++ ":" ++ show i + showArc (Dep r i) = show r ++ ":" ++ show i + + diff --git a/ParserW.hs b/ParserW.hs new file mode 100644 index 0000000..7a2b19c --- /dev/null +++ b/ParserW.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE FlexibleContexts #-} + +module ParserW ( + module Parse, + WeightedList, + step, + parse, + parseA, + parse', + parseA', + -- parseSel, + -- selectSize, + shift, + shift', + -- shifts, + connect, + addHead, + addDep) where + +import Lexicon +import Grammar +import Parse +import Node + +import Data.List +import Data.Maybe +import Data.Sequence +import Data.Foldable +import Toolbox +import Control.Monad +import Control.Monad.Trans.State +import Control.Monad.Trans.Class +import Control.Monad.Plus +import Base +import Weighted + + +shift :: (MonadPlus m, Lexicon m κ δ) => δ -> String -> Parse τ κ -> m (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 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 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 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 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 + +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 + + +type WeightedList = WeightedT [] + +-- type WeightedList = StateT Int (WeightedT []) + +-- LEXER I PARSER ODDZIELNIE + +-- step :: (Ind,String) -> [Step] +-- step (i,w) = [ Step i c [] [] | c <- dic w ] + +-- steps :: [(Ind,String)] -> [[Step]] +-- steps [] = [[]] +-- _steps ((i,w):t) = [ Step i c [] [] : ss | c <- dic w, ss <- _steps t ] + +-- _lexer = words >>> zip [1..] >>> _steps + +-- -- lexer3 s = map (Node []) (stes s) + +-- -- back = (lng >=> back) pure +-- _parser = connect >=> (rng >=> _parser) pure + +-- -- --parser'' ws = shifts ws ep >>= back >>= pa + +-- _parse = _lexer >=> _parser + + + + + + + + + +-- shift :: (MonadPlus m) => Wordform -> Parse -> m Parse +-- shift w p = [ p << Step (nextId p) c [] [] | c <- mfromList (dic w) ] +-- 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) => Parse -> m Parse +-- addHead p = [ p +-> Arc r (ind v') | let v = lastNode p, headless v, (r,v') <- mfromList (heads v) ] +-- addDep p = [ p +<- Arc r (ind v') | let v = lastNode p, (r,v') <- mfromList (deps v), headless v' ] + +-- connect :: (MonadPlus m) => Parse -> m Parse +-- connect = (addDep >=> connect) <> addHead <> return + +-- step :: (MonadPlus m) => Wordform -> Parse -> m Parse +-- step w = shift w >=> connect + +-- steps :: (MonadPlus m) => [Wordform] -> m Parse +-- steps = foldM (flip step) mzero + +-- parser :: (MonadPlus m) => [Wordform] -> m Parse +-- parser = steps |? pass.lastNode |? (==1).trees + +-- parse :: String-> [Parse] +-- parse = parser . words + + + +-- stepSel :: (Parse -> [Parse]) -> Wordform -> Parse -> [Parse] +-- stepSel s w = (shift w >=> connect >=> s) + +-- stepsSel :: (Parse -> [Parse]) -> [Wordform] -> [Parse] +-- stepsSel s = foldM (flip (stepSel s)) [] + +-- parserSel :: (Parse -> [Parse]) -> [Wordform] -> [Parse] +-- parserSel s = stepsSel s >=> selectWith (pass.lastNode) >=> selectSize (==1) + +-- parseSel :: (Parse -> [Parse]) -> String-> [Parse] +-- parseSel s = parserSel s . words + + + + + + + + +-- EXTENSIONS + +-- type Selector = Parse -> [Parse] + +-- sAny :: (Parse -> [Parse]) +-- sAny v = pure v + +-- selectWith :: (Parse -> Bool) -> (Parse -> [Parse]) +-- selectWith f v = if f v then [v] else [] + +-- selectSize :: (Int -> Bool) -> (Parse -> [Parse]) +-- selectSize f = selectWith (f . trees) +-- sForestSize f p = if f (trees p) then [p] else [] + +-- shift' :: (Ind,Word) -> Parse -> [Parse] +-- shift' (i,w) p = [ p << (i,c) | c <- dic w] + +-- addHead', addDep' :: Parse -> [Parse] +-- addHead' n = [ n +-> (r,ind n') | headless n, (r,n') <- heads' n ] +-- addDep' n = [ n +<- (r,ind n') | (r,n') <- deps' n, headless n' ] + +-- connect' :: Parse -> [Parse] +-- -- connect = ((addDep <> addHead) >=> connect) <> pure +-- connect' = addDep' <> addHead' <> pure + +-- step' :: (Parse -> [Parse]) -> (Ind,Word) -> Parse -> [Parse] +-- step' s w = shift' w >=> connect >=> s + +-- step'''' w = shift' w >=> connect + +-- stepS s w = step'''' w >=> s + +-- parser' s = foldM (flip (stepS s)) ep >=> accept' +-- parse' s = words >>> zip [1..] >>> parser' s + +-- parserRL s = foldrM ((step' s)) ep >=> accept' +-- parseRL s = words >>> zip [1..] >>> parserRL s + +-- type Filter = [Parse] -> [Parse] + + +-- -- takeWith :: (Parse -> Bool) -> ([Parse] -> [Parse]) +-- -- takeWith f = filter f + +-- -- takeBestN = mapM (sForestSize) diff --git a/PoliMorf.hs b/PoliMorf.hs new file mode 100644 index 0000000..67b8fd1 --- /dev/null +++ b/PoliMorf.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module PoliMorf ( + module Data.ADTTag.IPITag, + module PM -- Data.ADTTag.IPITag.PoliMorf + ) where + +import Control.Monad.Plus +import Lexicon +import Data.ADTTag.IPITag +import qualified Data.ADTTag.IPITag.PoliMorf as PM + +instance (MonadPlus m) => Lexicon m IPITag PM.Dic where + dic = PM.dic + + + +-- data SynTag = SUBST' Name1 +-- | FIN' +-- | PREP' Prep +-- deriving (Show,Eq,Ord) + +-- data Name1 = Common | Proper + +-- data Prep = PrepPod | PrepDo | PrepNa | PrepW | PrepPrzez | PrepPod +-- syn :: diff --git a/Role.hs b/Role.hs new file mode 100644 index 0000000..d2f1cf1 --- /dev/null +++ b/Role.hs @@ -0,0 +1,14 @@ +module Role where + +data Role = Subj + | Cmpl + | Mod + | Poss + | Prep + | PCmpl + | CCmpl + | Coord + | Conj + | Num + | Det + deriving (Show,Eq,Ord) diff --git a/Step.hs b/Step.hs new file mode 100644 index 0000000..de4f5db --- /dev/null +++ b/Step.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Step (Step (Step)) + where + +import Data.List (intercalate) +import Base + +data Step τ κ = Step Ind κ [Arc τ] [Arc τ] deriving (Eq,Ord,Show) + + +-- dst :: Arc +-- instance Show Step where +-- show (Step i c h d) = show i ++ "." ++ show c ++ showHead h ++ showDeps d +-- where showHead [] = "" +-- showHead [a] = "(" ++ showArc a ++ ")" +-- showDeps [] = "" +-- showDeps ds = "[" ++ intercalate " " (map showArc ds) ++ "]" +-- showArc (r,i) = show r ++ ":" ++ show i + diff --git a/Toolbox.hs b/Toolbox.hs new file mode 100644 index 0000000..7745bc7 --- /dev/null +++ b/Toolbox.hs @@ -0,0 +1,66 @@ +module Toolbox + ( -- Applicative + pure, + + -- Monad + (>>=), (>=>), + + -- local + (<>), + (),(|?), + clo, rclo, mclo, mrclo, + just + ) + where + + +import Control.Monad ((>>=),(>=>),MonadPlus(mplus,mzero),mfilter) +import Control.Applicative (pure) + +import Data.Foldable + +-- OR + +infixr 6 <> +(<>) :: (MonadPlus m) => (a -> m b) -> (a -> m b) -> (a -> m b) +(f <> g) x = f x `mplus` g x + +-- SHORT CIRCUIT OR + +infixr 6 +() :: (MonadPlus m, Foldable m) => (a -> m b) -> (a -> m b) -> (a -> m b) +(f g) x = let fx = f x in if null fx then g x else fx + +-- VALUE FILTER + +infixl 4 |? +(|?) :: (MonadPlus m) => (a -> m b) -> (b -> Bool) -> (a -> m b) +f |? g = mfilter g . f + + + +clo,mclo,rclo,mrclo:: (MonadPlus m, Foldable m) => (a -> m a) -> a -> m a +clo f = f >=> ( pure <> clo f ) +rclo f = pure <> clo f +mrclo f = (f >=> mrclo f) pure +mclo f = f >=> mrclo f + + +-- INPUT: Function f returning element of a list or fails if list empty +-- OUTPUT: Function returning the list containing the f value or empty list +-- ex: the maximum, the head, the last, e.t.c + +-- the :: ([a] -> b) -> ([a] -> [b]) +-- (the f) [] = [] +-- (the f) xs = [f xs] + +just :: ([a] -> b) -> ([a] -> [b]) +(just f) [] = [] +(just f) xs = [f xs] + +its :: (a->b) -> ([a]->b) +its f = f.head + +their :: (a->b) -> ([a]->[b]) +their = map + diff --git a/Weighted.hs b/Weighted.hs new file mode 100644 index 0000000..2f88ada --- /dev/null +++ b/Weighted.hs @@ -0,0 +1,88 @@ +module Weighted + where + +import Control.Applicative +import Control.Monad +import Data.Foldable +import Data.Monoid + +newtype Weight = Weight Float deriving (Show,Eq,Ord) + +instance Monoid Weight where + mempty = Weight 1 + Weight w `mappend` Weight w' = Weight (w * w') + +inv :: Weight -> Weight +inv (Weight w) = (Weight (1.0 - w)) + +data Weighted a = Weighted Weight a + +bare :: Weighted a -> a +bare (Weighted _ x) = x + +weight :: Weighted a -> Weight +weight (Weighted w _) = w + +instance Functor Weighted where + fmap f (Weighted w x) = Weighted w (f x) + +instance Applicative Weighted where + pure = Weighted mempty + Weighted w f <*> Weighted w' x = Weighted (w <> w') (f x) + +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 + +infix 9 # +x#w = Weighted (Weight w) x + +instance Eq (Weighted a) where + Weighted w1 _ == Weighted w2 _ = w1 == w2 + +instance Ord (Weighted a) where + Weighted w1 _ <= Weighted w2 _ = w1 <= w2 + + + +newtype WeightedT m a = WeightedT { runWeightedT :: m (Weighted a) } + +instance Functor m => Functor (WeightedT m) where + f `fmap` x = WeightedT (liftA f `fmap` runWeightedT x) + +instance Applicative m => Applicative (WeightedT m) where + pure = WeightedT . pure . pure + f <*> x = WeightedT (liftA2 (<*>) (runWeightedT f) (runWeightedT x)) + +instance Alternative m => Alternative (WeightedT m) where + empty = WeightedT empty + 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) + +instance Monad m => Monad (WeightedT m) where + return = WeightedT . return . return + x >>= f = WeightedT $ do + Weighted w a <- runWeightedT x + Weighted w' b <- runWeightedT (f a) + return (Weighted (w<>w') b) + +instance (Alternative m, Monad m) => MonadPlus (WeightedT m) + +-- instance (MonadPlus m, Traversable m) => Traversable (WeightedT m) where +-- traverse f xs = return $ traverse (liftM f) (runWeightedT xs) + + -- traverse f xs | null xs = pure mzero + -- | otherwise = foldr (\x v -> mplus <$> f x <*> v) (pure mzero) xs + + + -- (WeightedT x)= WeightedT $ sequenceA x + +