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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
---------------------------------------------------------------------
-- |
-- Maintainer : PL
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/08/08 09:01:25 $
-- > CVS $Author: peb $
-- > CVS $Revision: 1.5 $
--
-- Definitions of ranges, and operations on ranges
-----------------------------------------------------------------------------
module GF.Parsing.MCFG.Range
( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange,
LinRec, RangeRec,
makeRangeRec, rangeRestRec, rangeRestrictRule,
projection, unifyRec, substArgRec
) where
-- Haskell
import Data.List
import Control.Monad
-- GF modules
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.Utilities
import GF.Infra.Print
import GF.Data.Assoc ((?))
import GF.Data.Utilities (updateNthM)
------------------------------------------------------------
-- ranges as single pairs
data Range = Range (Int, Int)
| EmptyRange
deriving (Eq, Ord, Show)
makeRange :: (Int, Int) -> Range
concatRange :: Range -> Range -> [Range]
rangeEdge :: a -> Range -> Edge a
edgeRange :: Edge a -> Range
minRange :: Range -> Int
maxRange :: Range -> Int
makeRange = Range
concatRange EmptyRange rng = return rng
concatRange rng EmptyRange = return rng
concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j']
rangeEdge a (Range(i,j)) = Edge i j a
edgeRange (Edge i j _) = Range (i,j)
minRange (Range rho) = fst rho
maxRange (Range rho) = snd rho
instance Print Range where
prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")"
prt (EmptyRange) = "(?)"
{-- Types --------------------------------------------------------------------
Linearization- and Range records implemented as lists
-----------------------------------------------------------------------------}
type LinRec c l t = [Lin c l t]
type RangeRec l = [(l, Range)]
{-- Functions ----------------------------------------------------------------
Concatenation : Concatenation of Ranges, Symbols and Linearizations
and records of Linearizations
Record transformation : Makes a Range record from a fully instantiated
Linearization record
Record projection : Given a label, returns the corresponding Range
Range restriction : Range restriction of Tokens, Symbols,
Linearizations and Records given a list of Tokens
Record replacment : Substitute a record for another in a list of Range
records
Argument substitution : Substitution of a Cat c to a Tok Range, where
Range is the cover of c
Note: The argument is still a Symbol c Range
Subsumation : Checks if a Range record subsumes another Range
record
Record unification : Unification of two Range records
-----------------------------------------------------------------------------}
--- Concatenation ------------------------------------------------------------
concSymbols :: [Symbol c Range] -> [[Symbol c Range]]
concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng'
concSymbols (Tok rng'':toks)
concSymbols (sym:syms) = do syms' <- concSymbols syms
return (sym:syms')
concSymbols [] = return []
concLin :: Lin c l Range -> [Lin c l Range]
concLin (Lin lbl syms) = do syms' <- concSymbols syms
return (Lin lbl syms')
concLinRec :: LinRec c l Range -> [LinRec c l Range]
concLinRec = mapM concLin
--- Record transformation ----------------------------------------------------
makeRangeRec :: LinRec c l Range -> RangeRec l
makeRangeRec lins = map convLin lins
where convLin (Lin lbl [Tok rng]) = (lbl, rng)
convLin (Lin lbl []) = (lbl, EmptyRange)
convLin _ = error "makeRangeRec"
--- Record projection --------------------------------------------------------
projection :: Ord l => l -> RangeRec l -> [Range]
projection l rec = maybe (fail "projection") return $ lookup l rec
--- Range restriction --------------------------------------------------------
rangeRestTok :: Ord t => Input t -> t -> [Range]
rangeRestTok toks tok = do rng <- inputToken toks ? tok
return (makeRange rng)
rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range]
rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok
return (Tok rng)
rangeRestSym _ (Cat c) = return (Cat c)
rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range]
rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms
concLin (Lin lbl syms')
-- return (Lin lbl syms')
rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
rangeRestRec toks = mapM (rangeRestLin toks)
rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range]
rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $
rangeRestRec toks lins
--- Argument substitution ----------------------------------------------------
substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range
-> Symbol (c, l, Int) Range
substArgSymbol i rec tok@(Tok rng) = tok
substArgSymbol i rec cat@(Cat (c, l, j))
| i==j = maybe err Tok $ lookup l rec
| otherwise = cat
where err = error "substArg: Label not in range-record"
substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range
-> [Lin c l Range]
substArgLin i rec (Lin lbl syms) =
concLin (Lin lbl (map (substArgSymbol i rec) syms))
substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range
-> [LinRec c l Range]
substArgRec i rec lins = mapM (substArgLin i rec) lins
-- Record unification & replacment ---------------------------------------------------------
unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]]
unifyRec recs i rec = updateNthM update i recs
where update rec' = guard (subsumes rec' rec) >> return rec
-- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec
-- return $ replaceRec recs i rec
replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
replaceRec recs i rec = before ++ (rec : after)
where (before, _ : after) = splitAt i recs
subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
subsumes rec rec' = and [r `elem` rec' | r <- rec]
-- subsumes rec rec' = all (`elem` rec') rec
{-
--- Record unification -------------------------------------------------------
unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]]
unifyRangeRecs recs recs' = zipWithM unify recs recs'
where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l]
unify rec [] = return rec
unify [] rec = return rec
unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2)
= case compare l1 l2 of
LT -> do rec3 <- unify rec1 rec2'
return (p1:rec3)
GT -> do rec3 <- unify rec1' rec2
return (p2:rec3)
EQ -> do guard (r1 == r2)
rec3 <- unify rec1 rec2
return (p1:rec3)
-}
|
