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
|
module GF.NewParsing.MCFG.Range where
-- Haskell
import List
import Monad
-- GF modules
import GF.Formalism.GCFG
import GF.Formalism.MCFG
import GF.Formalism.Utilities
import GF.Infra.Print
import GF.Data.Assoc ((?))
------------------------------------------------------------
-- 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
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
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)
--- 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
return (Lin lbl syms')
rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
rangeRestRec toks = mapM (rangeRestLin toks)
-- Record replacment ---------------------------------------------------------
-- ineffektiv!!
replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
replaceRec recs i rec = (fst tup) ++ [rec] ++ (tail $ snd tup)
where tup = splitAt i recs
--- Argument substitution ----------------------------------------------------
substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range
-> Symbol (c, l, Int) Range
substArgSymbol i rec (Tok rng) = (Tok rng)
substArgSymbol i rec (Cat (c, l, j))
| i==j = maybe (Cat (c, l, j)) Tok $ lookup l rec
| otherwise = (Cat (c, l, j))
substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range
-> Lin c l Range
substArgLin i rec (Lin lbl syms) =
(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 = map (substArgLin i rec) lins
--- Subsumation -------------------------------------------------------------
-- "rec' subsumes rec?"
subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
subsumes rec rec' = and [elem r rec' | r <- 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)
|
