obrebski/fdp2
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

some past changes

Browse Source
This commit is contained in:
Tomasz Obrębski 2017-03-16 09:03:46 +01:00
parent e2914d0ae8
commit ac0169cf20
11 changed files with 180 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Base.hs
View File

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

43
FDP.hs Normal file
View File

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

6
FDP1.hs
View File

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

7
G1.hs
View File

@ -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 ]

37
Grammar.hs
View File

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

9
Lexicon.hs
View File

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

86
PL1.hs
View File

@ -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)
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 ]
@ -167,7 +145,7 @@ obligatoriness (r,h,d) | h < d = all sat'' (pure h >>= clo 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 ]

40
Parse.hs
View File

@ -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]

85
ParserW.hs
View File

@ -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 :: (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 [])

2
PoliMorf.hs
View File

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

15
Weighted.hs
View File

@ -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
@ -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 (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 []