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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
----------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/05/09 09:28:44 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.3 $
--
-- 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 -> [SCat] -> MGrammar
convertGrammar grammar starts = newGrammar
where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
[ rule | NR rule <- chartLookup finalChart True ]
finalChart = tracePrt "RemoveErasing - nonerasing cats"
(prt . length . flip chartLookup False) $
buildChart keyof [newRules rulesByCat] $
tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
initialCats
initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
if null starts
then trace2 "RemoveErasing" "initialCatsBU" $
initialCatsBU rulesByCat
else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $
initialCatsTD rulesByCat starts
rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $
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
lins <- selectLins lins0 lbls
-- let lins = [ lin | lin@(Lin lbl _) <- lins0,
-- lbl `elem` lbls ]
let 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 = -- tracePrt "newName" (prtNewName profile newProfile) $
Name fun (profile `composeProfiles` newProfile)
guard $ all (not . null) argLbls
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
selectLins lins0 = mapM selectLbl
where selectLbl lbl = [ lin | lin@(Lin lbl' _) <- lins0, lbl == lbl' ]
prtNewName :: [Profile (SyntaxForest Fun)] -> [Profile (SyntaxForest Fun)] -> Name -> String
prtNewName p p' n = prt p ++ " .o. " ++ prt p' ++ " : " ++ prt n
initialCatsTD grammar starts =
[ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar,
start `elem` starts ]
initialCatsBU grammar
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
let Rule _ (Cnc lbls _ _) = head rules,
lbl <- lbls ]
|
