some past changes

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)
 

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

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

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 ]

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
 

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
+class WeightedLexicon a d where
-    dic :: d -> String -> m a
+    dic :: d -> String -> WeightedList a

PL1.hs

@@ -17,9 +17,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)
+agrNPG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrPerson (cat x) (cat y) ∧ agrGender (cat x) (cat y)
-agrNCG = \(_,h,d) -> agrNumber (cat h) (cat d) ∧ agrCase (cat h) (cat d) ∧ agrGender (cat h) (cat d)
+agrNCG (_,x,y) = agrNumber (cat x) (cat y) ∧ agrCase (cat x) (cat y) ∧ agrGender (cat x) (cat y)
-agrC   = \(_,h,d) -> test ( agrCase<$>Identity (cat h)<*>Identity (cat d) )
+agrC   (_,x,y) = agrCase (cat x) (cat y)
 
---right, left, sgl :: Constraint Role IPITag
+right, left, sgl :: Constraint Role IPITag
-right  = \(_,h,d) -> h < d
+right (_,h,d) = h < d
-left   = \(_,h,d) -> d < h
+left  (_,h,d) = d < h
-sgl    = \(r,h,_) -> r ∉ roles 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 ]
+-- -- agrNPG', agrC' :: Constraint' (WeightedT []) Role IPITag
-alt2 f xs ys = or [ f x y | x <- xs , y <- ys ]
+-- 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)
+-- obligatoriness' (r,h,d) | h < d = all sat''' (pure h >>= clo rmdp)
-                        | d < h = all sat''' (pure d >>= rclo 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 ]

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]
 
@@ -48,3 +49,40 @@ showParse = concatMap shortStep
               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]

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
@@ -35,88 +29,35 @@ import Control.Monad.Plus
 import Base
 import Weighted
   
-  
+shift :: (WeightedLexicon κ δ) => δ -> String -> Parse τ κ -> WeightedList (Parse τ κ)
-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
 
-
+addHead, addDep :: (WeightedGrammar τ κ γ) => γ -> Parse τ κ -> WeightedList (Parse τ κ)
-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 κ))
+connect :: (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' ]
-
-                                                
-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 κ))
+step :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> Wordform -> Parse τ κ -> WeightedList (Parse τ κ)
-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 κ))
+steps :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
-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 κ))
+parses :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
-steps' d g = foldM (flip (step' d g)) mzero
+parses d g = steps d g
 
-parser :: (MonadPlus m, Lexicon m κ δ, Grammar m τ κ γ) => δ -> γ -> [Wordform] -> m (Parse τ κ)
+parse :: (WeightedLexicon κ δ, WeightedGrammar τ κ γ) => δ -> γ -> [Wordform] -> WeightedList (Parse τ κ)
-parser d g = steps d g -- |? (==1) . trees
+parse d g = parses d g |? (==1) . trees |? pass g . lastNode
-
-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 []
+-- parseA' :: (Lexicon WeightedList κ δ, Grammar' WeightedList τ κ γ) => δ -> γ -> String -> WeightedList (Parse τ (WeightedList κ))
+-- parseA' d g = parser' d g . words
+
 
 -- type WeightedList = StateT Int (WeightedT [])
 

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
 
 

Weighted.hs

@@ -17,8 +17,8 @@ inv (Weight w) = (Weight (1.0 - w))
                                    
 data Weighted a = Weighted Weight a
 
-bare :: Weighted a -> a
+unweighted :: Weighted a -> a
-bare (Weighted _ x) = x
+unweighted (Weighted _ x) = x
 
 weight :: Weighted a -> Weight
 weight (Weighted w _) = w 
@@ -35,6 +35,9 @@ instance Monad Weighted where
     (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 (map unweighted $ toList $ runWeightedT c)
-    foldr f z c = foldr f z (fmap bare $ runWeightedT c)
+    foldr f z c = foldr f z (fmap unweighted $ runWeightedT c)
-    -- foldr f z c = foldr (f . bare) z (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 []