initial

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)
+

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))
+                  

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) [τ]

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 τ κ])
+

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

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

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 ]

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
+
+              

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)

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 :: 

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)

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
+                    

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
+

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
+
+