1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/04/21 16:21:53 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.2 $
--
-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
-----------------------------------------------------------------------------
module GF.Conversion.RemoveErasing
(convertGrammar) where
import GF.System.Tracing
import GF.Infra.Print
import Control.Monad
import Data.List (mapAccumL)
import Data.Maybe (mapMaybe)
import GF.Formalism.Utilities
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Conversion.Types
import GF.Data.Assoc
import GF.Data.SortedList
import GF.Data.GeneralDeduction
convertGrammar :: EGrammar -> MGrammar
convertGrammar grammar
= tracePrt "RemoveErasing - nr. nonerasing rules" (prt . length) $
traceCalcFirst finalChart $
trace2 "RemoveErasing - nr. nonerasing cats" (prt $ length $ chartLookup finalChart False) $
trace2 "RemoveErasing - nr. initial ne-cats" (prt $ length initialCats) $
trace2 "RemoveErasing - nr. erasing rules" (prt $ length grammar) $
newGrammar
where newGrammar = [ rule | NR rule <- chartLookup finalChart True ]
finalChart = buildChart keyof [newRules rulesByCat] initialCats
initialCats = initialCatsBU rulesByCat
rulesByCat = accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
data Item r c = NR r | NC c deriving (Eq, Ord, Show)
keyof (NR _) = True
keyof (NC _) = False
newRules grammar chart (NR (Rule (Abs _ cats _) _))
= [ NC cat | cat@(MCat _ lbls) <- cats, not (null lbls) ]
newRules grammar chart (NC newCat@(MCat cat lbls))
= do Rule (Abs _ args (Name fun profile)) (Cnc _ _ lins0) <- grammar ? cat
let lins = [ lin | lin@(Lin lbl _) <- lins0,
lbl `elem` lbls ]
argsInLin = listAssoc $
map (\((n,c),l) -> (n, MCat c l)) $
groupPairs $ nubsort $
[ ((nr, cat), lbl) |
Lin _ lin <- lins,
Cat (cat, lbl, nr) <- lin ]
newArgs = mapMaybe (lookupAssoc argsInLin) [0 .. length args-1]
argLbls = [ lbls | MCat _ lbls <- newArgs ]
newLins = [ Lin lbl newLin | Lin lbl lin <- lins,
let newLin = map (mapSymbol cnvCat id) lin ]
cnvCat (cat, lbl, nr) = (mcat, lbl, nr')
where Just mcat = lookupAssoc argsInLin nr
Unify [nr'] = newProfile !! nr
nonEmptyCat (Cat (MCat _ [], _, _)) = False
nonEmptyCat _ = True
newProfile = snd $ mapAccumL accumProf 0 $
map (lookupAssoc argsInLin) [0 .. length args-1]
accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
newName = Name fun (newProfile `composeProfiles` profile)
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
initialCatsBU grammar
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
let Rule _ (Cnc lbls _ _) = head rules,
lbl <- lbls ]
|
