% 
% The following is taken from the last DCG standard draft by Paulo Moura
%
%   ISO/IEC DTR 13211-3:2006 Definite clause grammar rules
%   Editor: Paulo Moura pmoura@di.ubi.pt May 28, 2010
%

%
% 11 Reference implementations
% 
% The reference implementations provided is this section do not preclude
% alternative or optimized implementations.
% 
% 11.1 Grammar-rule translator
% 
% This section provides a reference implementation for a translator of
% grammar rules into Prolog clauses as specified in the ISO/IEC
% 13211-1 Prolog standard.  The main idea is to translate grammar rules
% into clauses by adding two extra arguments to each grammar rule
% non-terminal, following the logical expansion of grammar rules,
% described in the previous section.  The first extra argument is
% used for the input list of terminals.  The second extra argument is
% used for the list of terminals in the input list not consumed by the
% grammar rule.  This is a straight-forward solution.  Nevertheless,
% compliance with this TR does not imply this specific translation,
% only compliance with the logical expansion, as specified in clause 10.
% 
% This translator includes error-checking code that ensures that both
% the input grammar rule and the resulting clause are valid.  In
% addition, this translator attempts to simplify the resulting clauses
% by removing redundant calls to true/0 and by folding unifications. 
% In some cases, the resulting clauses could be further optimized. 
% Other optimizations can be easily plugged in, by modifying or ex-
% tending the dcg simplify/4 predicate.  However, implementers must be
% careful to delay output unifications in the presence of goals with
% side-effects such as cuts or input/output operations, ensuring the
% steadfastness of the generated clauses.
% 
% Translating a grammar-rule non-terminal may result in a conflict
% with a built-in predicate.  The behavior of the Prolog processor in
% this case is implementation dependent.  However, if the Prolog
% processor raises an error for this case, it shall the same error
% generated when an attempt is made to redefine a built-in predicate.
% 

% converts a grammar rule into a normal clause:

dcg_rule(Rule, Clause) :-
        dcg_rule(Rule, S0, S, Expansion),
        dcg_simplify(Expansion, S0, S, Clause).

dcg_rule((RHead --> _), _, _, _) :-
        var(RHead),
        throw(instantiation_error).
dcg_rule((RHead, _ --> _), _, _, _) :-
        var(RHead),
        throw(instantiation_error).
dcg_rule((_, Terminals --> _), _, _, _) :-
        var(Terminals),
        throw(instantiation_error).
dcg_rule((NonTerminal, Terminals --> GRBody), S0, S, (Head :- Body)) :-
        !,
        dcg_non_terminal(NonTerminal, S0, S, Head),
        dcg_body(GRBody, S0, S1, Goal1),
        dcg_terminals(Terminals, S, S1, Goal2),
        Body = (Goal1, Goal2).
dcg_rule((NonTerminal --> GRBody), S0, S, (Head :- Body)) :-
        !,
        dcg_non_terminal(NonTerminal, S0, S, Head),
        dcg_body(GRBody, S0, S, Body).
dcg_rule(Term, _, _, _) :-
        throw(type_error(grammar_rule, Term)).

% translates a grammar goal non-terminal:
dcg_non_terminal(NonTerminal, _, _, _) :-
        \+ callable(NonTerminal),
        throw(type_error(callable, NonTerminal)).
dcg_non_terminal(NonTerminal, S0, S, Goal) :-
        NonTerminal =.. NonTerminalUniv,
        append(NonTerminalUniv, [S0, S], GoalUniv),
        Goal =.. GoalUniv.

% translates a list of terminals:
dcg_terminals(Terminals, _, _, _) :-
        \+ is_proper_list(Terminals),
        throw(type_error(list, Terminals)).
dcg_terminals(Terminals, S0, S, S0 = List) :-
        append(Terminals, S, List).
% translates a grammar rule body:
dcg_body(Var, S0, S, phrase(Var, S0, S)) :-
        var(Var),
        !.
dcg_body((GRIf -> GRThen), S0, S, (If -> Then)) :-
        !,
        dcg_body(GRIf, S0, S1, If),
        dcg_body(GRThen, S1, S, Then).
dcg_body((GREither; GROr), S0, S, (Either; Or)) :-
        !,
        dcg_body(GREither, S0, S, Either),
        dcg_body(GROr, S0, S, Or).
dcg_body((GRFirst, GRSecond), S0, S, (First, Second)) :-
        !,
        dcg_body(GRFirst, S0, S1, First),
        dcg_body(GRSecond, S1, S, Second).
dcg_body(!, S0, S, (!, S0 = S)) :-
        !.
dcg_body({}, S0, S, (S0 = S)) :-
        !.
dcg_body({Goal}, S0, S, (call(Goal), S0 = S)) :-
        var(Goal),
        !.
dcg_body({Goal}, _, _, _) :-
        \+ callable(Goal),
        throw(type_error(callable, Goal)).
dcg_body({Goal}, S0, S, (Goal, S0 = S)) :-
        !.
dcg_body(\+ GRBody, S0, S, (\+ Goal, S0 = S)) :-
        !,
        dcg_body(GRBody, S0, S, Goal).
dcg_body([], S0, S, (S0=S)) :-
        !.
dcg_body([T| Ts], S0, S, Goal) :-
        !,
        dcg_terminals([T| Ts], S0, S, Goal).
dcg_body(NonTerminal, S0, S, Goal) :-
        dcg_non_terminal(NonTerminal, S0, S, Goal).

% simplifies the resulting clause:
dcg_simplify((Head :- Body), _, _, Clause) :-
        dcg_conjunctions(Body, Flatted),
        dcg_fold_left(Flatted, FoldedLeft),
        dcg_fold_pairs(FoldedLeft, FoldedPairs),
        ( FoldedPairs == true ->
            Clause = Head
        ;   Clause = (Head :- FoldedPairs)
        ).

% removes redundant calls to true/0 and flattens conjunction of goals:
dcg_conjunctions((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :-
        !,
        dcg_conjunctions(Goal1, SGoal1),
        dcg_conjunctions(Goal2, SGoal2).
dcg_conjunctions((Goal1; Goal2), (SGoal1; SGoal2)) :-
        !,
        dcg_conjunctions(Goal1, SGoal1),
        dcg_conjunctions(Goal2, SGoal2).
dcg_conjunctions(((Goal1, Goal2), Goal3), Body) :-
        !,
        dcg_conjunctions((Goal1, (Goal2, Goal3)), Body).
dcg_conjunctions((true, Goal), Body) :-
        !,
        dcg_conjunctions(Goal, Body).
dcg_conjunctions((Goal, true), Body) :-
        !,
        dcg_conjunctions(Goal, Body).
dcg_conjunctions((Goal1, Goal2), (Goal1, Goal3)) :-
        !,
        dcg_conjunctions(Goal2, Goal3).
dcg_conjunctions(\+ Goal, \+ SGoal) :-
        !,
        dcg_conjunctions(Goal, SGoal).
dcg_conjunctions(Goal, Goal).

% folds left unifications:
dcg_fold_left((Term1 = Term2), true) :-
        !,
        Term1 = Term2.
dcg_fold_left(((Term1 = Term2), Goal), Folded) :-
        !,
        Term1 = Term2,
        dcg_fold_left(Goal, Folded).
dcg_fold_left(Goal, Goal).

% folds pairs of consecutive unifications (T1 = T2, T2 = T3):
dcg_fold_pairs((Goal1 -> Goal2), (SGoal1 -> SGoal2)) :-
        !,
        dcg_fold_pairs(Goal1, SGoal1),
        dcg_fold_pairs(Goal2, SGoal2).
dcg_fold_pairs((Goal1; Goal2), (SGoal1; SGoal2)) :-
        !,
        dcg_fold_pairs(Goal1, SGoal1),
        dcg_fold_pairs(Goal2, SGoal2).
dcg_fold_pairs(((T1 = T2a), (T2b = T3)), (T1 = T3)) :-
        T2a == T2b,
        !.
dcg_fold_pairs(((T1 = T2a), (T2b = T3), Goal), ((T1 = T3), Goal2)) :-
        T2a == T2b,
        !,
        dcg_fold_pairs(Goal, Goal2).
dcg_fold_pairs((Goal1, Goal2), (Goal1, Goal3)) :-
        !,
        dcg_fold_pairs(Goal2, Goal3).
dcg_fold_pairs(\+ Goal, \+ SGoal) :-
        !,
        dcg_fold_pairs(Goal, SGoal).
dcg_fold_pairs(Goal, Goal).


% 
% 11.1.1 Extended version for Prolog compilers with encapsulation mechanisms
% 
% Assuming that the infix operator :/2 is used for calling
% predicates inside an encapsulation unit, the following clause would
% allow translation of grammar rule bodies that explicitly use
% non-terminals from another encapsulation unit:
% 
% 
% dcg_body(Unit:GRBody, S0, S, Unit:Goal) :-
%         !,
%         dcg_body(GRBody, S0, S, Goal).


% One possible problem with this clause is that any existence errors
% when executing the goal Unit:Goal will most likely be expressed in
% terms of the expanded predicates and not in terms of the original
% grammar rule non-terminals.  In order to more easily report errors at
% the same abstraction level as grammar rules, the following alternative
% clause may be used:
% 
% dcg_body(Unit:GRBody, S0, S, Unit:phrase(GRBody, S0, S)) :-
%         !,
%         dcg_body(GRBody, S0, S, _). % ensure that GRBody is valid


% 
% 11.2 phrase/3
% 
% This section provides a reference implementation in Prolog of the
% built-in predicate phrase/3.  It includes the necessary clauses for
% error handling, as specified in section 8.1.1.3.  For the
% reference implementation of phrase/2 see section 8.1.1.4.
% 

phrase(GRBody, S0, S) :-
        var(GRBody),
        throw(error(instantiation_error, phrase(GRBody, S0, S))).
phrase(GRBody, S0, S) :-
        \+ callable(GRBody),
        throw(error(type_error(callable, GRBody), phrase(GRBody, S0, S))).
phrase(GRBody, S0, S) :-
        nonvar(S0),
        \+ is_list(S0),
        throw(error(type_error(list, S0), phrase(GRBody, S0, S))).
phrase(GRBody, S0, S) :-
        nonvar(S),
        \+ is_list(S),
        throw(error(type_error(list, S), phrase(GRBody, S0, S))).
phrase(GRBody, S0, S) :-
        dcg_body(GRBody, TS0, TS, Goal),
        TS0 = S0, TS = S,
        call(Goal).

end_of_file.

% 
% The predicate dcg body/4 is part of the grammar rule translator
% reference implementation, defined in section 11.1.  An alternative,
% informal implementation of phrase/3 using a meta-interpreter is
% presented in the Annex A.
% 

% 11.3 Auxiliary predicates used on the reference implementations

% The following auxiliary predicates are used on the reference implementations:

append([], List, List).
append([Head| Tail], List, [Head| Tail2]) :-
append(Tail, List, Tail2).

callable(Term) :-
        nonvar(Term),
        functor(Term, Functor, _),
        atom(Functor).

is_list([]) :-
        !.
is_list([_| Tail]) :-
        is_list(Tail).

is_proper_list(List) :-
        List == [], !.
is_proper_list([_| Tail]) :-
        nonvar(Tail),
        is_proper_list(Tail).

% 
% 12 Test-cases for the reference implementations
% 12.1 Built-in predicates and user-defined hook predicates
% 

% built-in predicates:
gr_pred_test(phrase(_, _,_), [built_in, static]).
gr_pred_test(phrase(_, _), [built_in, static]).

% simple test predicate:
test_gr_preds :-
        write('Testing existence of built-in predicates'), nl,
        write('and user-defined hook predicates...'), nl, nl,
        gr_pred_test(Pred, ExpectedProps),
        functor(Pred, Functor, Arity),
        write('Testing predicate '), write(Functor/Arity), nl,
        write(' Expected properties: '), write(ExpectedProps), nl,
        findall(Prop, predicate_property(Pred, Prop), ActualProps),
        write(' Actual properties: '), write(ActualProps), nl,
        fail.
test_gr_preds.


% 12.2 phrase/2-3 built-in predicate tests
% Tests needed!


% 
% 12.3 Grammar-rule translator tests
% Know any hard to translate grammar rules?  Contribute them!  When
% checking compliance of a particular grammar rule translator, results
% of the tests in this section must be compliant with the logical
% expansion of grammar rules, as specified in section 10.
% 

% terminal tests with list notation:
gr_tr_test(101, (p --> []), success).
gr_tr_test(102, (p --> [b]), success).
gr_tr_test(103, (p --> [abc, xyz]), success).
gr_tr_test(104, (p --> [abc | xyz]), error).
gr_tr_test(105, (p --> [[], {}, 3, 3.2, a(b)]), success).
gr_tr_test(106, (p --> [_]), success).

% terminal tests with string notation:
gr_tr_test(151, (p --> "b"), success).
gr_tr_test(152, (p --> "abc", "q"), success).
gr_tr_test(153, (p --> "abc" ; "q"), success).

% simple non-terminal tests:
gr_tr_test(201, (p --> b), success).
gr_tr_test(202, (p --> 3), error).
gr_tr_test(203, (p(X) --> b(X)), success).

% conjunction tests:
gr_tr_test(301, (p --> b, c), success).
gr_tr_test(311, (p --> true, c), success).
gr_tr_test(312, (p --> fail, c), success).
gr_tr_test(313, (p(X) --> call(X), c), success).

% disjunction tests:
gr_tr_test(351, (p --> b ; c), success).
gr_tr_test(352, (p --> q ; []), success).
gr_tr_test(353, (p --> [a] ; [b]), success).

% if-then-else tests:
gr_tr_test(401, (p --> b -> c), success).
gr_tr_test(411, (p --> b -> c; d), success).
gr_tr_test(421, (p --> b -> c1, c2 ; d), success).
gr_tr_test(422, (p --> b -> c ; d1, d2), success).
gr_tr_test(431, (p --> b1, b2 -> c ; d), success).
gr_tr_test(441, (p --> [x] -> [] ; q), success).

% negation tests:
gr_tr_test(451, (p --> \+ b, c), success).
gr_tr_test(452, (p --> b, \+ c, d), success).

% cut tests:
gr_tr_test(501, (p --> !, [a]), success).
gr_tr_test(502, (p --> b, !, c, d), success).
gr_tr_test(503, (p --> b, !, c ; d), success).
gr_tr_test(504, (p --> [a], !, {fail}), success).
gr_tr_test(505, (p(a), [X] --> !, [X, a], q), success).
gr_tr_test(506, (p --> a, ! ; b), success).

% {}/1 tests:
gr_tr_test(601, (p --> {b}), success).
gr_tr_test(602, (p --> {3}), error).
gr_tr_test(603, (p --> {c,d}), success).
gr_tr_test(604, (p --> '{}'((c,d))), success).
gr_tr_test(605, (p --> {a}, {b}, {c}), success).
gr_tr_test(606, (p --> {q} -> [a] ; [b]), success).
gr_tr_test(607, (p --> {q} -> [] ; b), success).
gr_tr_test(608, (p --> [foo], {write(x)}, [bar]), success).
gr_tr_test(609, (p --> [foo], {write(hello)},{nl}), success).
gr_tr_test(610, (p --> [foo], {write(hello), nl}), success).

% "metacall" tests:
gr_tr_test(701, (p --> X), success).
gr_tr_test(702, (p --> _), success).

% non-terminals corresponding to "graphic" characters
% or built-in operators/predicates:
gr_tr_test(801, ('[' --> b, c), success).
gr_tr_test(802, ('=' --> b, c), success).

% pushback tests:
gr_tr_test(901, (p, [t] --> b, c), success).
gr_tr_test(902, (p, [t] --> b, [t]), success).
gr_tr_test(903, (p, [t] --> b, [s, t]), success).
gr_tr_test(904, (p, [t] --> b, [s], [t]), success).
gr_tr_test(905, (p(X), [X] --> [X]), success).
gr_tr_test(906, (p(X, Y), [X, Y] --> [X, Y]), success).
gr_tr_test(907, (p(a), [X] --> !, [X, a], q), success).
gr_tr_test(908, (p, [a,b] --> [foo], {write(hello), nl}), success).
gr_tr_test(909, (p, [t1], [t2] --> b, c), error).
gr_tr_test(910, (p, b --> b), error).
gr_tr_test(911, ([t], p --> b), error).
gr_tr_test(911, ([t1], p, [t2] --> b), error).

% simple expand_term/2 test predicate:
test_gr_tr :-
        write('Testing expand_term/2 predicate...'), nl, nl,
        gr_tr_test(N, GR, Result),
        write(N), write(': '), writeq(GR), write(' --- '),
        write(Result), write(' expected'), nl,
        ( catch(
		expand_term(GR, Clause),
		Error,
		(write(' error: '), write(Error), nl, fail)) ->
	    write(' '), writeq(Clause)
        ;   write(' expansion failed!')
        ),
        nl, nl,
        fail.
test_gr_tr.

% simple predicate for dumping test grammar rules into a file:
% (restricted to rules whose expansion is expected to succeed)
create_gr_file :-
        write('Creating grammar rules file "gr.pl" ...'),
        open('gr.pl', write, Stream),
        ( gr_tr_test(N, GR, success),
        write(Stream, '% '), write(Stream, N),
        write(Stream, ':'), nl(Stream),
        write_canonical(Stream, GR), write(Stream, '.'),
        nl(Stream), fail
        ; close(Stream)
        ),
        write(' created.'), nl.


% 
% A phrase/3 meta-interpreter
% 
% Note that this alternative reference implementation makes it simple to
% report existence errors at the same abstraction level as grammar rules.
% 

phrase(GRBody, S0, S) :-
        phrase(GRBody, Cont, S0, S1),
        ( Cont == {} ->
	    S = S1
	;   Cont = !(SBody),
	    !,
	    phrase(SBody, S1, S)
        ).

phrase(GRBody, _, S0, S) :-
        var(GRBody),
        throw(error(instantiation_error, phrase(GRBody, S0, S))).
phrase(GRBody, _, S0, S) :-
        \+ callable(GRBody),
        throw(error(type_error(callable, GRBody), phrase(GRBody, S0, S))).
phrase(GRBody, _, S0, S) :-
        nonvar(S0),
        \+ is_list(S0),
        throw(error(type_error(list, S0), phrase(GRBody, S0, S))).
phrase(GRBody, _, S0, S) :-
        nonvar(S),
        \+ is_list(S),
        throw(error(type_error(list, S), phrase(GRBody, S0, S))).
phrase(!, Cont, S0, S) :-
        !,
        Cont = !({}),
        S = S0.
phrase((GRBody1, GRBody2), Cont, S0, S) :-
        !,
        phrase(GRBody1, ContGRBody1, S0, S1),
        ( ContGRBody1 == {} ->
	    phrase(GRBody2, Cont, S1, S)
        ;   ContGRBody1 = !(SGRBody1),
	    Cont = !((SGRBody1, GRBody2)),
	    S = S1
        ).
phrase(\+ GRBody, Cont, S0, S) :-
        !,
        \+ phrase(GRBody, S0, S),
        Cont = {},
        S0 = S.
phrase((GRBody1; GRBody2), Cont, S0, S) :-
        !,
        ( phrase(GRBody1, Cont, S0, S)
        ; phrase(GRBody2, Cont, S0, S)
        ).
phrase((GRBody1 -> GRBody2), Cont, S0, S) :-
        !,
        phrase(GRBody1, S0, S1),
        phrase(GRBody2, Cont, S1, S).
phrase({}, Cont, S0, S) :-
        !,
        Cont = {},
        S = S0.
phrase({Goal}, Cont, S0, S) :-
        !,
        call(Goal),
        Cont = {},
        S = S0.
phrase([], Cont, S0, S) :-
        !,
        Cont = {},
        S = S0.
phrase([Head| Tail], Cont, S0, S) :-
        !,
        append([Head| Tail], S, S0),
        Cont = {}.
phrase(GRHead, _, S0, S) :-
        \+ dcg_clause(GRHead, _),
        current_prolog_flag(unknown, Value),
        ( Value == fail ->
	    fail
        ; Value == warning ->
	    % implementation-defined warning
        ;   functor(GRHead, NonTerminal, Arity),
	    throw(error(
		existence_error(procedure, NonTerminal//Arity),
		phrase(GRHead, S0, S)))
        ).
phrase(GRHead, {}, S0, S) :-
        dcg_clause(GRHead, GRBody),
        phrase(GRBody, ContY, S0, S1),
        ( ContY == {} ->
	    S = S1
        ;   ContY = !(SBody),
	    !,
	    phrase(SBody, S1, S)
        ).