git @ Cat's Eye Technologies Fountain / 751068d
Coalesce adjacent constraints to `Both`s during preprocessing. Chris Pressey 1 year, 5 months ago
3 changed file(s) with 37 addition(s) and 10 deletion(s). Raw diff Collapse all Expand all
+0
-1
README.md less more
7171 ### Semantics
7272
7373 * Params on top-level Goal mean those values must be provided from environment.
74 * Combine two sequenced constraints into a "both" constraint internally.
7574
7675 ### Implementation
7776
+5
-0
doc/Tests-for-fountain.md less more
9898 <. c = 0 .> { "c" <. c += 1 .> } <. c = n .>
9999 ;
100100 ===> Goal ::= (<. a = 0 .> {("a" <. a += 1 .>)} {("b" <. b += 1 .>)} {("c" <. c += 1 .>)});
101
102 Coalescing constraints.
103
104 Goal ::= <. a = 0 .> <. b = 0 .> { "a" <. a += 1 .> } <. a > b .>;
105 ===> Goal ::= (<. && a = 0, b = 0 .> {("a" <. a += 1 .>)});
+32
-9
src/Language/Fountain/Preprocessor.hs less more
99 preprocessGrammar (Grammar productions) =
1010 let
1111 productions' = map (\(term, formals, expr) -> (term, formals, preprocessExpr expr)) productions
12 productions'' = map (\(term, formals, expr) -> (term, formals, eliminateSingleAlts expr)) productions'
1312 in
14 Grammar productions''
13 Grammar productions'
1514
16 preprocessExpr :: Expr -> Expr
17 preprocessExpr (Seq exprs) = Seq (preprocessSeq exprs) where
15 preprocessExpr = eliminateSingleAlts . coalesceConstraints . decorateLoops
16
17
18 --
19 -- Coalesce constraints
20 --
21
22 coalesceConstraints (Seq exprs) = Seq (cc exprs)
23 coalesceConstraints (Alt exprs) = Alt (map coalesceConstraints exprs)
24 coalesceConstraints (Loop expr cs) = Loop (coalesceConstraints expr) cs -- cs should be empty here actually, because decorateLoops comes later
25 coalesceConstraints other = other
26
27 cc :: [Expr] -> [Expr]
28 cc [] = []
29 cc (Constraint c1:Constraint c2:rest) =
30 cc ((Constraint $ Both c1 c2):rest)
31 cc (other:rest) = other:(cc rest)
32
33 --
34 -- Copy any constraints that immediately follow a loop, into the loop itself.
35 --
36 decorateLoops :: Expr -> Expr
37 decorateLoops (Seq exprs) = Seq (preprocessSeq exprs) where
1838 preprocessSeq [] = []
1939 preprocessSeq ((Loop expr _):rest) =
2040 let
21 expr' = preprocessExpr expr
41 expr' = decorateLoops expr
2242 (constraints, rest') = absorbConstraints rest
2343 in
2444 (Loop expr' constraints):(preprocessSeq rest')
2545 preprocessSeq (expr:rest) =
26 (preprocessExpr expr):(preprocessSeq rest)
46 (decorateLoops expr):(preprocessSeq rest)
2747 absorbConstraints :: [Expr] -> ([Constraint], [Expr])
2848 absorbConstraints exprs =
2949 let
3656 extractConstraint (Constraint c) = c
3757 in
3858 (constraints', exprs')
39 preprocessExpr (Alt exprs) = Alt (map preprocessExpr exprs)
40 preprocessExpr (Loop expr _) = error "Cannot preprocess Loop that is not in Seq"
41 preprocessExpr other = other
59 decorateLoops (Alt exprs) = Alt (map decorateLoops exprs)
60 decorateLoops (Loop expr _) = error "Cannot preprocess Loop that is not in Seq"
61 decorateLoops other = other
4262
63 --
64 -- Any Alt with only a single child can be replaced by that single child.
65 --
4366 eliminateSingleAlts (Alt [expr]) = eliminateSingleAlts expr
4467 eliminateSingleAlts (Alt exprs) = Alt $ map (eliminateSingleAlts) exprs
4568 eliminateSingleAlts (Seq exprs) = Seq $ map (eliminateSingleAlts) exprs