Commit d6ce9d072596950e884e2c184c3695b19f6fa82e - Fountain

+6

-6

doc/Definition-of-Fountain.md less more

380	380
381	381	Goal ::= "a" { "bb" } "c" \| "a" { "bbb" } "c";
382	382	<=== abbbbbbbbbc
383		???> Multiple pre-conditions
	383	???> Multiple
384	384
385	385	Tests for Generation
386	386	--------------------

396	396	unlike parsing, we need some guidance of which one to pick.
397	397
398	398	Goal ::= "f" \| "o";
399		???> No pre-condition
	399	???> Multiple
400	400
401	401	Goal ::= "f" \| <. a = 0 .> "o";
402		???> No pre-condition
	402	???> Multiple
403	403
404	404	Goal ::= (<. a = 0 .> "f") \| "o";
405		???> No pre-condition
	405	???> Multiple
406	406
407	407	But if all choices of the Alt have constraints, we are able to select the one
408	408	that fulfills the constraints.

418	418	that is an ambiguous situation, and (in normal operation) it is an error.
419	419
420	420	Goal ::= <. a = 0 .> "f" \| <. a = 1 .> "o";
421		???> Multiple pre-conditions
	421	???> Multiple
422	422
423	423	Goal ::= <. a = 0 .> (<. a = 0 .> "f" \| <. a = 1 .> "o") (<. a = 1 .> "a" \| <. a = 0 .> "z");
424	424	===> fz

582	582	\| "ooooo" <. a += 5 .> <. a <= n .> Item<a, n>
583	583	\| "xxxxxxx" <. a += 7 .> <. a <= n .> Item<a, n>;
584	584	<=== n=6
585		???> No pre-condition
	585	???> Multiple
586	586
587	587	The alternation processed as ordered choice, above, can also be
588	588	processed with nondeterministic choice. In this case, the process

+3

-1

src/Language/Fountain/Constraint.hs less more

12	12	\| ConVal a
13	13	deriving (Show, Ord, Eq)
14	14
15		data Constraint a = Unify Variable (ConExpr a)
	15	data Constraint a = Identity
	16	\| Unify Variable (ConExpr a)
16	17	\| Inc Variable (ConExpr a)
17	18	\| Dec Variable (ConExpr a)
18	19	\| GreaterThan Variable (ConExpr a)

29	30	depictConExpr (ConVar v) = depictVar v
30	31	depictConExpr (ConVal i) = show i
31	32
	33	depictConstraint Identity = "T"
32	34	depictConstraint (Unify v e) = (depictVar v) ++ " = " ++ (depictConExpr e)
33	35	depictConstraint (Inc v e) = (depictVar v) ++ " += " ++ (depictConExpr e)
34	36	depictConstraint (Dec v e) = (depictVar v) ++ " -= " ++ (depictConExpr e)

+15

-32

src/Language/Fountain/Generator.hs less more

3	3
4	4	module Language.Fountain.Generator (constructState, generateFrom, obtainResult) where
5	5
6		import Data.Maybe (mapMaybe)
7	6	import System.Random (StdGen, mkStdGen)
8	7
9	8	import Language.Fountain.Randomness (shuffle)

37	36	genTerminal :: Char -> GenState -> GenState
38	37	genTerminal c state@Generating{ text=text } = state{ text=(c:text) }
39	38
40		--
41		-- Alt choices need preconditions during generation because
42		-- we need some guidance of which one to pick.
43		--
44		getPreCondition :: Expr -> Maybe (Constraint Value)
45		getPreCondition (Seq (x:_)) = getPreCondition x
46		getPreCondition (Constraint c) = Just c
47		getPreCondition _ = Nothing
48
49		missingPreConditions choices =
50		mapMaybe (\x -> case getPreCondition x of
51		Just _ -> Nothing
52		Nothing -> Just x
53		) choices
54
55		getApplicableChoices store choices =
	39	getApplicableChoices state choices =
56	40	let
57	41	preConditionedChoices = map (\x -> (getPreCondition x, x)) choices
58		isApplicableChoice (Just c, _) = can $ applyConstraint c store
59		isApplicableChoice _ = False
	42	isApplicableChoice (c, _) = can $ applyGenConstraint c state
60	43	in
61	44	filter (isApplicableChoice) preConditionedChoices
	45
	46	applyGenConstraint :: Constraint Value -> Store Value -> Maybe (Store Value)
	47	applyGenConstraint (Lookahead _) store = Just store
	48	applyGenConstraint other store = applyConstraint other store
62	49
63	50	scramble :: [a] -> GenState -> ([a], GenState)
64	51	scramble choices state@Generating{ prng=prng } =

101	88	-- We look at all the choices; each should start with a pre-condition
102	89	-- determining whether we can select it; and we should narrow down our
103	90	-- choices based on that.
104		case missingPreConditions choices of
105		missing@(_:_) ->
106		error ("No pre-condition present on these Alt choices: " ++ (depictExprs missing))
107		[] ->
108		genAlt state (getApplicableChoices store choices)
109		where
110		genAlt _st [] = Left "no more choices"
111		-- we ignore the constraint here because it will be found and applied when we descend into e
112		genAlt st [(_, e)] = gen g st e
113		genAlt _st other =
114		error ("Multiple pre-conditions are satisfied in Alt: " ++ (depictExprs (map (snd) other)))
	91	genAlt state (getApplicableChoices store choices)
	92	where
	93	genAlt _st [] = Left "no more choices"
	94	-- we ignore the constraint here because it will be found and applied when we descend into e
	95	genAlt st [(_, e)] = gen g st e
	96	genAlt _st other =
	97	error ("Multiple pre-conditions are satisfied in Alt: " ++ (depictExprs (map (snd) other)))
115	98
116	99
117	100	gen _g _state (Loop _ []) = error "No postconditions defined for this Loop"

131	114	Nothing -> genLoop st' e
132	115	checkLimit [] st = Just st
133	116	checkLimit (c:cs) st =
134		case applyConstraint c st of
	117	case applyGenConstraint c st of
135	118	Nothing -> Nothing
136	119	Just st' -> checkLimit cs st'
137	120

151	134	Left x
152	135
153	136	gen _g st@Generating{ store=store } (Constraint cstr) =
154		case applyConstraint cstr store of
	137	case applyGenConstraint cstr store of
155	138	Just store' ->
156	139	-- TODO st{ trace=(("OK " ++ depictConstraint cstr):trace), store=store' }
157	140	Right $ st{ store=store' }

+11

-1

src/Language/Fountain/Grammar.hs less more

8	8	Production(Production, ntname, params, backtrackMode, constituents),
9	9	Grammar(Grammar),
10	10	depictExpr, depictExprs, depictProduction, depictGrammar, depictVars,
11		startSymbol, productionExpr, productionParams, getFormals, mergeGrammars
	11	startSymbol, productionExpr, productionParams, getFormals, mergeGrammars,
	12	getPreCondition
12	13	) where
13	14
14	15	import Data.List (intercalate)

94	95
95	96	mergeGrammars :: Grammar -> Grammar -> Grammar
96	97	mergeGrammars (Grammar ps1) (Grammar ps2) = Grammar $ ps1 ++ ps2
	98
	99	--
	100	-- Alt choices heed preconditions to prevent unnecessary backtracking.
	101	--
	102	getPreCondition :: Expr -> Constraint Value
	103	getPreCondition (Seq (x:_)) = getPreCondition x
	104	getPreCondition (Constraint c) = c
	105	getPreCondition (Terminal c) = Lookahead s where s = [c]
	106	getPreCondition _ = Identity

+19

-45

src/Language/Fountain/Parser.hs less more

2	2	-- SPDX-License-Identifier: LicenseRef-BSD-2-Clause-X-Fountain
3	3
4	4	module Language.Fountain.Parser (constructState, parseFrom, obtainResult) where
5
6		import Data.Maybe (mapMaybe)
7	5
8	6	import Language.Fountain.Value
9	7	import Language.Fountain.Constraint

32	30	expectTerminal _tc (Parsing [] _a) =
33	31	Left "end of string"
34	32
35		--
36		-- Alt choices need preconditions during parsing because it helps
37		-- efficiency by preventing unnecessary backtracking. But note that
38		-- we need a more refined notion in parsing than in generation,
39		-- because a terminal counts as a precondition.
40		--
41		getPreCondition :: Expr -> Maybe (Constraint Value)
42		getPreCondition (Seq (x:_)) = getPreCondition x
43		getPreCondition (Constraint c) = Just c
44		getPreCondition (Terminal c) = Just $ Lookahead s where s = [c]
45		getPreCondition _ = Nothing
46
47		missingPreConditions choices =
48		mapMaybe (\x -> case getPreCondition x of
49		Just _ -> Nothing
50		Nothing -> Just x
51		) choices
52
53	33	getApplicableChoices state choices =
54	34	let
55	35	preConditionedChoices = map (\x -> (getPreCondition x, x)) choices
56		isApplicableChoice (Just c, _) = can $ applyParseConstraint c state
57		isApplicableChoice _ = False
	36	isApplicableChoice (c, _) = can $ applyParseConstraint c state
58	37	in
59	38	filter (isApplicableChoice) preConditionedChoices
	39
	40	applyParseConstraint :: Constraint Value -> ParseState -> ParseResult
	41	applyParseConstraint (Lookahead s) state@(Parsing (c:_) _) =
	42	if s == [c] then (Right state) else (Left "lookahead failed")
	43	applyParseConstraint (Lookahead _) _ = Left "lookahead failed"
	44	applyParseConstraint other (Parsing s store) =
	45	case applyConstraint other store of
	46	Just store' ->
	47	Right $ Parsing s store'
	48	Nothing ->
	49	Left "constraint failed"
60	50
61	51	--
62	52	-- Parser

83	73
84	74	-- Hello, Mrs Non-Backtracking Alternation!
85	75	parse g state (Alt Nothing choices) =
86		case missingPreConditions choices of
87		missing@(_:_) ->
88		error ("No pre-condition present on these Alt choices: " ++ (depictExprs missing))
89		[] ->
90		parseAlt state (getApplicableChoices state choices)
91		where
92		parseAlt _st [] = Left "no more choices"
93		-- we ignore the constraint here because it will be found and applied when we descend into e
94		parseAlt st [(_, e)] = parse g st e
95		parseAlt (Parsing _str store) other =
96		error ("Multiple pre-conditions are satisfied in Alt: " ++ (depictExprs (map (snd) other)) ++ ", with state: " ++ show store)
	76	parseAlt state (getApplicableChoices state choices)
	77	where
	78	parseAlt _st [] = Left "no more choices"
	79	-- we ignore the constraint here because it will be found and applied when we descend into e
	80	parseAlt st [(_, e)] = parse g st e
	81	parseAlt (Parsing _str store) other =
	82	error ("Multiple pre-conditions are satisfied in Alt: " ++ (depictExprs (map (snd) other)) ++ ", with state: " ++ show store)
97	83
98	84	parse g state (Loop l []) = parseLoop state l where
99	85	parseLoop st e =

123	109
124	110	parse _g state (Constraint cstr) = applyParseConstraint cstr state
125	111
126
127		applyParseConstraint :: Constraint Value -> ParseState -> ParseResult
128		applyParseConstraint (Lookahead s) state@(Parsing (c:_) _) =
129		if s == [c] then (Right state) else (Left "lookahead failed")
130		applyParseConstraint (Lookahead _) _ = Left "lookahead failed"
131		applyParseConstraint other (Parsing s store) =
132		case applyConstraint other store of
133		Just store' ->
134		Right $ Parsing s store'
135		Nothing ->
136		Left "constraint failed"
137
138	112	--
139	113	-- Usage interface
140	114	--

+1

-0

src/Language/Fountain/Unify.hs less more

22	22	-- (by unification, causing the constraint to become true.)
23	23	--
24	24	applyConstraint :: Constraint Value -> Store Value -> Maybe (Store Value)
	25	applyConstraint Identity st = Just st
25	26	applyConstraint (Unify v (ConVal x)) st =
26	27	case fetch v st of
27	28	Just value ->