# $Id: grammar.pl,v 1.1 2006/10/04 15:09:53 olafs Exp $

:-use_module('transducer').

letter(Y) -->
	[X],
	{ char_type(X, alpha), char_code(Y, X)}.
caplet(Y) -->
	[X],
	{ char_type(X, upper), char_code(Y, X)}.
digit(Y) -->
	[X],
	{ char_type(X, digit), char_code(Y, X)}.

ornament(0'$).
ornament(0'+).
ornament(0'-).
ornament(0'?).
ornament(0'@).
ornament(0'^).
ornament(0'~).
ornament(0'`).
ornament(0'_).
%ornament(32).

ornament(X) -->
	[C], {ornament(C), char_code(X, C)}.

letment(X) -->
	letter(X); digit(X); ornament(X).

sidentifier(X) -->
	digment_seq_opt(Y1), letter(X1),!, letment_seq_opt(Y2),
	{ append(Y1, [X1|Y2], Z),
	  string_to_atom(Z, X)}.

digment_seq_opt(X) -->
	digment_seq(X);
	("", {X=[]}).

digment_seq([X1|Y1]) -->
	digment(X1), !, digment_seq_back_opt(Y1).

digment_seq_back_opt(X) -->
	digment_seq(X);
	("", {X=[]}).

digment(X) -->
	digit(X);ornament(X).	

letment_seq_opt(X) -->
	letment_seq(X);
	("",{X=[]}).

letment_seq([X1|Y1]) -->
	letment(X1),!, letment_seq_back_opt(Y1).

letment_seq_back_opt(X) -->
	letment_seq(X);
	("", {X=[]}).

identifier(X) -->
	sidentifier(X1), " ",!, identifier(Y1),
	{concat_atom([X1,' ',Y1], X)};
	sidentifier(X).
% WARNING - this should be transformed to contain only capital letters

cidentifier(X) -->
	cidentifier1(X1), !, ornament_seq_opt(Y1),
	{concat_atom([X1, Y1], X)}.

ornament_seq(X) -->
	ornament(X1), !, ornament_seq_back_opt(Y1), {concat_atom([X1,Y1], X)}.

ornament_seq_back_opt(X) -->
	ornament_seq(X);
	("", {X = ''}).

ornament_seq_opt(X) -->
	ornament_seq(X);
	("", {X=''}).

cidentifier1(X) -->
	digment_seq_opt(Y1), caplet(X1),!, capletment_seq_opt(Y2),
	{ append(Y1, [X1|Y2], Z),
	  string_to_atom(Z, X)}.

capletment_seq_opt(X) -->
	capletment_seq(X);
	("",{X=[]}).

capletment_seq([X1|Y1]) -->
	capletment(X1),!, capletment_seq_back_opt(Y1).

capletment_seq_back_opt(X) -->
	capletment_seq(X);
	("", {X = []}).

capletment(X) -->
	caplet(X); digit(X); ornament(X).

%returns a list of chars, transformed to their real value: "\n" -> ['\n']
text_denotation(X) -->
	("\"", char_seq(X), "\""),!.


char_seq(X) -->
	([0'\\], !, [C],  char_seq(Y1), {special(C, D),X = [D|Y1]});
	(nonquote(C),!, char_seq(Y1), {X = [C|Y1]});
	("", {X = []}).

nonquote(C) -->
	[C] ,
	{C \=34}. %char_code('"', 34).

special(X) -->
	[C],
	{special(C, X)}.

special(0't, 0'\t).
special(0'n, 0'\n).
special(0'\\, 0'\\).
special(32, 32).
special(X, X).

%returns a number/term
number(X) -->
	digit_seq(Y), {string_to_atom(Y, Z), atom_to_term(Z, X, [])}.

digit_seq([X1|Y1]) -->
	digit(X1),!, digit_seq_back_opt(Y1).

digit_seq_back_opt(X) -->
	digit_seq(X);
	("", {X=[]}).

nonterminal_name(X) -->
	identifier(X).

module_name(X) -->
	sidentifier(X).
grammar_name(X) -->
	sidentifier(X).
lexicon_name(X) -->
	sidentifier(X).

affix_name(X) -->
	capletment2_seq(Y), {string_to_atom(Y, X)}.

capletment2_seq([X1|Y1]) -->
	capletment2(X1),!, capletment2_seq_back_opt(Y1).

capletment2_seq_back_opt(X) -->
	capletment2_seq(X);
	("", {X=[]}).

capletment2(X) -->
	caplet(X); ornament(X).

special_name(X) -->
	("$",cidentifier(X)).

affix_rule -->
	affix_rule_head(X), "::",!, affix_alternatives(Y), ".",
	{ do_affix_rules(X, Y)}.

do_affix_rules([],_).
do_affix_rules([X|Z], Y):-
	assert(affixrule(X, Y)),
	do_affix_rules(Z, Y).

affix_rule_head(X) -->
	affix_nonterminal_list(X).

affix_nonterminal_list(X) -->
	affix_nonterminal(X1), !,affix_nonterminal_list_back_opt(Y1),
	{X = [X1|Y1]}.

affix_nonterminal_list_back_opt(X) -->
	",", !, affix_nonterminal_list(X);
	("", {X = []}).

affix_nonterminal(X) -->
	affix_name(X).

affix_alternatives(X) -->
	predefined_domain(X1), {X = [affix_predef(X1)]}.

affix_alternatives([X1|Y1]) -->
	affix_alternative(X1), affix_alternatives_back_opt(Y1).


affix_alternatives_back_opt(X) -->
	"|",!, affix_alternatives(X);
	("", {X= []}).

affix_alternative(X) -->
	affix_nonterminal(X1), {X = affix_nont(X1)};
	affix_terminal(X).

predefined_domain(X) -->
	"TEXT",!, {X = 'TEXT'};
	("INT",!, {X = 'INT'}).

affix_terminal(X) -->
	identifier(X);
	number(X1), {X = int(X1)};
	text_denotation(X1), {X = text(X1)}.

statement -->
	specification;
	rule.

rule --> syntax_rule;
	affix_rule.

specification -->
	syntax_rule_heading(head(X,Y,Z)), ".",
	{assert(specif(X, Y, Z))}.

syntax_rule -->
	lhs_list(X, [], NewVars, [], NewFakes, In, Out, Weight), ":",!,
	rhs(Y, NewVars, NewFakes, In, Out, Weight), ".",
	{do_syntax_rules(X, Y)}.

do_syntax_rules([], _).
do_syntax_rules([C|T], Y):-
	C =.. [Name, Type, W, I, O|Pars],
	assert(synrule(Name, Type, Pars, W, I, O, Y)),
	do_syntax_rules(T, Y).

lhs(X, Vars, NewVars, OldFakes, NewFakes, I, O, W) -->
	syntax_rule_heading(X, Vars, NewVars, OldFakes, NewFakes, I, O, W).

rhs(X, NV, NF, I, O, W) -->
%	{initial_weight(IW)},
	alternatives(X, NV, NF, I, O, 0, W, 0).

lhs_list([X1|Y1], Vars, NewVars, OldFakes, NewFakes, In, Out, W) -->
	lhs(X1, Vars, NV1, OldFakes, NF1, In, Out, W), 
	!,lhs_list_back_opt(Y1, NV1, NewVars, NF1, NewFakes, In, Out, W).

lhs_list_back_opt(X, V, NV, OF, NF, I, O, W) -->
	",",!,lhs_list(X, V, NV, OF, NF, I, O, W);
	("", {X = [], V = NV, NF = OF}).

syntax_rule_heading(X) -->
	syntax_rule_type(Type),
	nonterminal_name(Name),
	parameter_list_pack_opt(Parameters),
	{X = head(Name, Type, Parameters)}.

syntax_rule_heading(X, V, NV, OF, NF, I, O, W) -->
	syntax_rule_type(Type),
	nonterminal_name(Name),
	parameter_list_pack_opt(Parameters),
	{ do_vars(V, NV, OF, NF, Parameters, NewParams),
	X =.. [Name, Type, W, I, O|NewParams] }.

do_vars(X, X,  Y, Y, [], []).

do_vars(V, NV, OF, NF, [X|P], [Y|NP]):-
	(is_list(X)->
	    NV1 = V,
	    NF1 = [A:B|OF],
	    Y = X:A:B;
	    (member(X:L:K, V)->
		Y = X:L:K, % aici
		NV1 = V;
		Y = X:G:H, % si aici
 		NV1 = [X:G:H|V]),
	    NF1 = OF),
	do_vars(NV1, NV, NF1, NF, P, NP).


syntax_rule_type(X) -->
	"RULE ", {X = rule};
	"OPTION ", {X = option};
	"CONDITION ", {X = condition};
	"COND ", {X = condition};
	("", {X = rule}).
parameter_list_pack_opt(X) -->
	parameter_list_pack(X);
	("",{X=[]}).

parameter_list_pack(X) -->
	("(", parameter_list(X),")").

parameter_list([X1|Y1]) -->
	parameter(X1), !,parameter_list_back_opt(Y1).

parameter_list_back_opt(X) -->
	",", !, parameter_list(X);
	("", {X = []}).

parameter(X) -->
	affix_variable(X);
	affix_expression(X).

affix_variable(X) -->
	affix_nonterminal(X1), number(Y1),
	{ X = affixvar(X1, Y1)};
	affix_nonterminal(X1),
	{ X = affixvar(X1,0)}.

affix_expression([X1|Y1]) -->
	affix_terminal(X1),!, affix_expression_back_opt(Y1).

affix_expression_back_opt(X) -->
	"|",!,affix_expression(X);
	("",{X = []}).

alternatives(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPenalties) -->
	alternative_ser(X1, Vars, Fakes, I, O, InitialWeight, Weight1, InitialPenalties),!,
	{%div2(InitialWeight, 1, NewWeight),
	NewPenalties is InitialPenalties + 1},
	commited_alternatives(Y1, Vars, Fakes, I, O, InitialWeight, Weight2, NewPenalties),
	{append(X1, Y1, X), Weight is Weight1 + Weight2}.

commited_alternatives(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPenalties) -->
	"!",!, alternatives(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPenalties);
	("",{X = [], Weight is 0}).

alternative_ser(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPen) -->
	alternative(X1, Vars, Fakes, I, O, InitialWeight, Weight1, InitialPen, Penalties),
	!,
	alternative_ser_back_opt(Y1, Vars, Fakes, I, O, InitialWeight, Weight2, InitialPen),
	{X2 = Weight1:Penalties:X1, Weight is Weight1 + Weight2,
	 (Y1 = [] ->
	     X = [X2];
	     X = [X2| Y1])}.

alternative_ser_back_opt(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPen) -->
	";", !, alternative_ser(X, Vars, Fakes, I, O, InitialWeight, Weight, InitialPen);
	("", {X = [], Weight is 0}).

alternative(X, Vars, Fakes, I, O, IW, W, IP, P) -->
	syntax_part(X, Vars, Fakes, I, O, IW, W, IP, P),				 
	transduction_part_opt(_).

syntax_part(X, Vars, Fakes, I, O, IW, W, IP, P) -->
	{get_ins(Vars, NewVars)},
	(%free_order(X, NewVars, OutVars, I, O, IW, W),!;
	freq_opt(Fr),
	memb_list_opt(X1, NewVars, OutVars, I, O, IP, P)),
	{W1 is IW + Fr,
	 (W1 \= 0 -> W = W1; W is 1),
	 unify_out_vars(Vars, OutVars, X1, X2),
	 unify_fakes(Fakes, X2, X)}.

unify_fakes([], X, X).

unify_fakes([A:B|T], X1, X):-
	unify_fakes(T, X1, X2),
	X = [A = B| X2].

get_ins([],[]).
get_ins([X:Y:_|T], [X:Y|S]):-
	get_ins(T, S).

get_outs([],[]).
get_outs([X:_:Y|T], [X:Y|S]):-
	get_outs(T, S).

get_names([], []).
get_names([X:_:_|T], [X:_|S]):-
	get_names(T, S).


unify_out_vars([],_, X, X).
unify_out_vars([X:_:Z|V], T, X1,[Z = Y| X2]):-
	unify_out_vars(V, T, X1, X2),
	member(X:Y, T).

put_commas(X, [''|Y]):-put_commas(X, Y).

put_commas(X, [X, '']).

put_commas(','(X1, Y1), [X1,Y1]).

put_commas(','(X1, Y2), [X1|Y1]):-
	put_commas(Y2, Y1).
put_commas(X, [X]).


put_ands(X, [''|Y]):-put_ands(X, Y).

put_ands('&'(X1, Y1), [X1,Y1]).

put_ands('&'(X1, Y2), [X1|Y1]):-
	put_ands(Y2, Y1).

freq_opt(X) -->
	"[", number(X), "]";
	("", {X = 0}).

memb_list_opt(X, V, OV, I, O, IP, P) -->
	memb_list(X, V, OV, I, O, IP, P);
	("", {X = ['='(I, O)], OV = V, P = IP}).

memb_list([X1|Y1], V, OV, I, O, IP, P) -->
	memb(X1, V, OV1, I, O1, IP, P1), !,
	memb_list_back_opt(Y1, OV1, OV, O1, O, P1, P).

memb_list_back_opt(X, V, OV, I, O, IP, P) -->
	",", !, memb_list(X, V, OV, I, O, IP, P);
	("", {X = ['='(I,O)], OV = V, IP = P}).

memb(X, V, OV, I, O, IP, P) -->
	penalty(IP, P),!,{OV = V, X = '='(I, O)};
	terminal_symbol(X, V, OV, I, O),!, {IP = P};		
	call_(X, V, OV, I, O),!, {IP= P};
	group(X, V, OV, I, O),!, {IP= P};
	option(X, V, OV, I, O),!, {IP = P};
	guard(X, V, OV),!, {I = O, IP = P}.

call_(X, V, OV, I, O) -->
	nonterminal_name(Y),!, parameter_list_pack_opt(Z),
	{ update_vars(V, Z, OV, NZ),
	  X =.. [Y, I, O|NZ]}.

update_vars(V, [], V, []).

update_vars(V, [X|T], NV, [X:_|S]):-
	is_list(X),
	update_vars(V, T, NV, S).

update_vars(V, [X|T], NV, [Y|S]):-
	(member(X:A,V) ->
	    Y = A:B,
	    update_one_var(V, X:B, NV1);
	    Y = X:B, %aici
	    NV1 = [X:B|V]),
	update_vars(NV1, T, NV, S).

update_one_var([X:_|T], X:Y, [X:Y|T]).

update_one_var([A:B|T], X:Y, [A:B|S]):-
	update_one_var(T, X:Y, S).

group(X, V, OV, I, O) -->
	{%initial_weight(IW),
	 get_names(Vars, V),
%	 get_fulls_from_names(Fulls, Vars)
	 Fulls = Vars
	},
	("(",!, alternatives(Y, Vars, [], I1, O1, 0, W, 0), ")"),
	{!,repeat,
	 random_string(10, N1),
	 string_to_atom(N1, N2),
	 concat_atom(['group_', N2], N),
	 not(synrule(N, _, _, _, _, _, _)),
	 assert(synrule(N, rule, Fulls, W, I1, O1, Y)),
	 get_group_params(V, OV, Prms),
	 X =..[N, I, O| Prms]
	}.

get_group_params([], [], []).
get_group_params([X:A|T], [X:B|S], [A:B|U]):-
	get_group_params(T, S, U).

/*option(X) -->
	("[",!, alternatives(Y), "]"),
	{X = option(Y)}.*/

option(X, V, OV, I, O) -->
	{%initial_weight(IW),
	 get_names(Vars, V),
%	 get_fulls_from_names(Fulls, Vars)
	 Fulls = Vars
	},
	("[",!, alternatives(Y1, Vars, [], I1, O1, 0, W1, 0), "]"),
	{
	 get_ins(Vars, Ins),
	 unify_out_vars(Vars, Ins, ['='(I1,O1)], Y2),
	 Y = [W1:0:Y2|Y1],
	 W is 2*W1,!,
	 repeat,
	 random_string(10, N1),
	 string_to_atom(N1, N2),
	 concat_atom(['option_', N2], N),
	 not(synrule(N, _, _, _, _, _, _)),
	 assert(synrule(N, rule, Fulls, W, I1, O1, Y)),
	 get_group_params(V, OV, Prms),
	 X =..[N, I, O| Prms]
	}.

get_dumb_vars([], []).
get_dumb_vars([_|T], [_|S]):-
	get_dumb_vars(T, S).


get_fulls_from_names([], []).

get_fulls_from_names([full:X:Y|T],[_:X:Y|S]):-
	get_fulls_from_names(T, S).


terminal_symbol(X, V, OV, I, O) -->
	text_denotation(X2),
	{
	 X = grammar_terminal(X2, O, I),
	 V = OV};
	quasi_terminal(X, I, O),
	{V = OV}.
%	lexicon_terminal(X).

quasi_terminal(X, I, O) -->
	match(X, I, O) ; skip(X, I, O).

%temporary i don't care about match and skip
match(X, I, O) -->
	"$MATCH", "(", !,text_denotation(X2), ")",
	{ 
	  X3 = "$MATCH(",
	  append(X3, X2, X4),
	  X5 = ")",
	  append(X4, X5, X6),
	  X = grammar_terminal(X6, O, I)}.

skip(X, I, O) -->
	"$SKIP", "(", !,text_denotation(X2), ")",
	{ 
	  X3 = "$SKIP(",
	  append(X3, X2, X4),
	  X5 = ")",
	  append(X4, X5, X6),
	  X = grammar_terminal(X6, O, I)}.


%skip(X) -->
%	"$SKIP", "(", !,text_denotation(Y),")",
%	{ X = skip(Y)}.

lexicon_terminal(X) -->
	nonterminal_name(X1),!, parameter_list_pack_opt(Y1),
	{defines(U), member(head(X1, _, _), U),X = lexterm(X1,Y1)}.

guard(X, V, OV) -->
	"{",!, guard_alternative(Y), "}",
	{get_guards(X1, Y, V, OV),
	 X= restrict(X1)}.

get_guards([], [], V, V).

get_guards([A:B:C|T], [restriction(X,A)|S], V, OV):-
	(member(X:B, V)->
	    update_one_var(V, X:C, OV1);
	    B = full,
	    OV1 = [X:C|V]),
	get_guards(T, S, OV1, OV).

guard_alternative(X) -->
	confrontation_list(X).

confrontation_list([X1|Y1]) -->
	confrontation(X1), !,  confrontation_list_back_opt(Y1).

confrontation_list_back_opt(X) -->
	",",!, confrontation_list(X);
	("", {X=[]}).

confrontation(X) -->
	restriction(X).
%	equation(X).

restriction(X) -->
	affix_variable(X1), "::", affix_expression(Y1),
	{X = restriction(X1,Y1)}.


equation(X) -->
	affix_variable(X1), "=", affix_variable(Y1),
	{X = equation(X1, Y1)}.

penalty(IP, P) -->
	"$PENALTY",!, number_pack_opt(X1),
	{P is IP+X1}.

number_pack_opt(X) -->
	"(", number(X), ")";
	("", {X=1}).

% free_order('&'(X1,Y1), V, OV, I, O, IW, W) -->
% 	memb(X1),"&",!,free_order(Y1),
% 	{X = [X1|Y1]};
% 	memb(X1),"&",!,memb(X2),
% 	{X = [X1|X2]}.

transduction_part_opt(X) -->
	("/",!, transduction_memb_list_opt(X));
	("",!, {X = []}).
transduction_memb_list_opt(X) -->
	transduction_memb_list(X);
	("", {X = []}).

transduction_memb_list([X1|Y1]) -->
	transduction_memb(X1), !, transduction_memb_list_back_opt(Y1).

transduction_memb_list_back_opt(X) -->
	",", !, transduction_memb_list(X);
	("", {X = []}).

transduction_memb(X) -->
	("()",{X = empty});
	nonterminal_placeholder(X);
	affix_placeholder(X);
	regexp_placeholder(X);
	text_denotation(X).

nonterminal_placeholder(X) -->
	nonterminal_name(X1),!, index_opt(Y1),
	{ X = nont_ph(X1-Y1)};
	number(X1), {X = nont_ph(X1)}.

index_opt(X) -->
	number(X);
	("", {X = -1}).
affix_placeholder(X) -->
	affix_variable(X), "::";
	affix_variable(X).
regexp_placeholder(X) -->
	"$MATCH",!, index_opt(X1),
	{X = regexp_ph(match, X1)}.
	
regexp_placeholder(X) -->
	"$SKIP",!, index_opt(X1),
	{X = regexp_ph(skip, X1)}.

module_body -->
	statement, module_body;
	statement.

grammar_head -->
	("GRAMMAR ", grammar_name(X), ".", {assert(grammar_name(X))}).

root_statement -->
	("ROOT ", nonterminal_name(X), "."), {assert(root(X))}.

uses_part -->
	"USES ", module_name_list(X), ".",
	{
	 (uses(Y) ->
	     append(Y, X, Z),
	     retractall(uses(_)),
	     assert(uses(Z));
	     assert(uses(X)))};
	"INCLUDES ", module_name_list(X), ".",
	{
	 (uses(Y) ->
	     append(Y, X, Z),
	     retractall(uses(_)),
	     assert(uses(Z));
	     assert(uses(X)))}.

module_name_list([X1|Y1]) -->
	module_name(X1), !, module_name_list_back_opt(Y1).

module_name_list_back_opt(X) -->
	",", !, module_name_list(X);
	("", {X = []}).

defines_part -->
	("DEFINES ", obj_spec_list(X), "."), {assert(defines(X))}.

obj_spec_list([X1|Y1]) -->
	obj_spec(X1), !, obj_spec_list_back_opt(Y1).

obj_spec_list_back_opt(X)-->
	",", !, obj_spec_list(X);
	("", {X=[]}).

obj_spec(X) -->
	syntax_rule_heading(X);
	(affix_nonterminal(X), "::");
	affix_nonterminal(X).


lexicon_part -->
	"LEXICON ", module_name_list(X), " ",
	defines_part, {assert(lexmodules(X))}.

hyper_statement -->
	grammar_head,!;
	root_statement,!;
	lexicon_part,!;
	defines_part,!;
	uses_part,!;
	statement,!.

get_var_tail(X, Y):-
	append(_, Y, X),
	var(Y),!.

lexicon_entry -->
	text_denotation(X1),"\t",!,
	freq_opt(_),
	syntax_rule_heading(Z1,[],_, [], _, _, _, _),!,
	{
	 Z1 =.. [Name, _, _, _, _| Pars],
	 assert(lexen(Name, Pars, X1))}.

strip_pars([], []).
strip_pars([A:_:_|P1], [A|P]):-
	strip_pars(P1, P).
	     
lexicon_entry_seq([X1|Y1]) -->
	lexicon_entry(X1), lexicon_entry_seq_opt(Y1).

lexicon_entry_seq_opt(X) -->
	lexicon_entry_seq(X);
	("",{X = []}).

set_attribute(Name, Value):-
	S =.. [Name, Value],
	T =.. [Name, _],
	retractall(T),
	assert(S).

% Not all combination of trace options make sense.
% If trace_bare_terminals is true it makes sense that show_trace is false,
% since it is a partial override over a false show_trace.
% Here we also have a quick way to be very quiet if you specify -q to pl.
init_attributes:-
	set_attribute(stepbystep, false),
	set_attribute(step_on_backtrack, false),
	set_attribute(show_trace, true),
	set_attribute(animate_trace, true),
	set_attribute(trace_bare_terminals, true),
	set_attribute(max_penalty, 20),
	set_attribute(use_penalties, true),
	( current_prolog_flag(verbose, silent) -> 
	    set_attribute(trace_bare_terminals, false),
	    set_attribute(show_trace, false),
	    set_attribute(step_on_backtrack, false);
	    true ).

load_grammar(Name):-
	init_attributes,
	delete_grammar,
	delete_lexicon,
	retractall(final_char(_,_)),
	assert(final_char('.','.')),
	judge_file(Name),
	(uses(S) ->
	    judge_uses(S);
	    true),
 	retractall(final_char(_,_)),
 	assert(final_char('\n', '.')),
	assert(lexen(_,_,_)),
	retractall(lexen(_,_,_)),
 	(lexmodules(T) ->
 	    judge_lexs(T);
 	    true),
	dbwritef("Building affix domains\n"),
	get_domains,
	finish_sets.


get_domains:-
	repeat,
	(affixrule(Name, _)->
	    get_domain(Name, Domain),
	    findall(affix_predef(A), member(affix_predef(A), Domain), Predefs),
	    subtract(Domain, Predefs, NonPredefs),
	    sort(Domain, SDomain),
	    assert(affixdomain(Name, SDomain, Predefs, NonPredefs)),
	    retractall(affixrule(Name, _)),
	    fail;
	    true).

get_domain(Name, Domain):-
	affixrule(Name, Set),
	construct_domain(Set, [], Domain),!.

construct_domain([], X, X).

construct_domain([affix_nont(X)|R], Prev, Domain):-
	(affixdomain(X, S, _, _)->
	    append(S, Prev, Prev1);
	    get_domain(X, Dom),
	    append(Dom, Prev, Prev1)),
	construct_domain(R, Prev1, Domain).

construct_domain([X|R], T, Dom):-
	construct_domain(R, [X|T], Dom).

finish_sets:-
	repeat,
	(lexen(Name, Pars, _) ->
	    findall(X, lexen(Name, Pars, X), L),
	    length(L, N),
	    assert(lexset(Name, Pars, N, L)),
	    retractall(lexen(Name, Pars, _)),
	    fail;
	    dbwritef("Finished creating lexsets\n")).

do_nos([]).
do_nos([No:Set|L]):-
	get_var_tail(Set, Tail),
	Tail = [],
	length(Set, No),
	write(No),
	do_nos(L).

judge_file(Name) :-
	dbwritef("Loading grammar from file %w\n", [Name]),
	open(Name, read, F),!,
	repeat,
	transduce_one(F, L),
	(L == end_of_file ->
	    dbwritef("The End\n");
	    (hyper_statement(L,[])->
		true;
		dbwritef("Invalid rule: %s\n", [L])),
	    fail).

judge_uses([]).
judge_uses([X|T]):-
	concat_atom([X,'.gra'], Y),
	dbwritef("Loading included grammar %w\n",[Y] ),
	judge_file(Y),
	judge_uses(T).

judge_lexs([]).
judge_lexs([X|T]):-
	concat_atom([X,'.dat'],Y),
	dbwritef("Loading lexicon %w\n", [Y]),
	judge_lexicon_wrap(Y),
	judge_lexs(T).

judge_lexicon_wrap(Name):-
	open(Name, read, F),!,
	repeat,
	read_line_to_codes(F, L),
 	(L \= end_of_file ->
%	    dbwritef("%w\n", [L]),
	    (lexicon_entry(L, []) ->
		true;
		dbwritef("Invalid line: %s\n", [L])),
	    fail;
	    dbwritef("The End\n")).

delete_grammar:-
	retractall(affixrule(_,_)),
	retractall(specif(_,_,_)),
	retractall(synrule(_,_,_,_,_,_,_)),
	retractall(grammar_name(_)),
	retractall(root(_)),
	retractall(uses(_)),
	retractall(defines(_)),
	retractall(lexmodules(_)),
	retractall(lexset(_,_,_,_)),
	retractall(affixdomain(_,_, _, _)).

delete_lexicon:-
	retractall(lex_entry(_,_,_)),
	retractall(lex_set(_,_)).

judge_lists([]).

judge_lists([L|T]):-
	chars_codes(L1, L), write(L1),nl,
	hyper_statement(L,[]),!,
	judge_lists(T).

pow2(0,1).
pow2(1,2).
pow2(2,4).
pow2(3,8).
pow2(4,16).
pow2(5,32).
pow2(6,64).
pow2(7,128).
pow2(8,256).
pow2(9,512).
pow2(10,1024).
pow2(11,2048).
pow2(12,4096).
pow2(13,8192).
pow2(14,16384).
pow2(15,32768).
pow2(16,65536).

initial_weight(X):-
	pow2(16, X).

%Z =  X / 2^Y
div2(X, Y, Z):-
	pow2(A, X),
	B is A-Y,
	(B >= 0->
	    pow2(B, Z);
	    pow2(0,Z)).

letters([a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,x,y,z]).

random_string(N, S):-
	N1 is random(N)+1,
	letters(L),
	get_lets(N1, L, S),!.

get_lets(0, _, []).

get_lets(N, L, [X|S]):-
	rand_member(L, X),
	N1 is N-1,
	get_lets(N1, L, S).

rand_member(L, X):-
	length(L, N),
	M is random(N),
	nth0(M, L, X).

get_term_sat_list(_, [], []):-!.

get_term_sat_list(Pars, [HPars:N|R1], Z):-
	!,
	(unify_pars(Pars,HPars)->
	    Z = [HPars:N|R2];
	    Z = R2),
	get_term_sat_list(Pars,R1,R2),!.

sum_sats([], S, S):-!.

sum_sats([_:N|R], S1, S):-
	S2 is S1+N,
	sum_sats(R, S2, S),!.

pick_term(Name, [HP:N|R], T, E, HP1):-
	(T< N->
	    lexset(Name, HP, N, L),
	    nth0(T, L, E), HP1 = HP;
	    T1 is T-N,
	    pick_term(Name, R, T1, E, HP1)),!.

unify_term_inouts([]):-!.
unify_term_inouts([_:A:A|R]):-
	unify_term_inouts(R),!.

get_head_pars([],[]):-!.
get_head_pars([_:_|T],[_:_:_|S]):-
	get_head_pars(T, S),!.

% call_nonterm(Sp,Name, I, O, Pars):-
% %	get_byte(_),
% %	dbwritef(I),nl,
% %	dbwritef(O),nl,
% 	get_head_pars(Pars, HPars),
% %	Z =.. [Name|HPars],
% 	findall(synrule(Name, Type, HPars, W, I1, O1, Alternatives),
% 	(member(Type,[rule,option]),
% 	synrule(Name, Type, HPars, W, I1, O1, Alternatives)), L1),
% 	unify_inouts(I, O, L1),
%	get_sat_list(Pars, L1, L),
% 	(L == [] ->
% 	    dbwritef("Error no alternatives found \n"), abort;
% 	    random_sat_body(Sp,L)).

unify_inouts(_, _, []):-!.
unify_inouts(I, O, [synrule(_, _, _, _, I, O, _)| R]):-	
	unify_inouts(I, O, R),!.

get_sat_list(_, [], []):-!.

get_sat_list(Pars, [synrule(N, T, HPars, W, I, O, Alts)|R1], Z):-
	!,
	(unify_pars(Pars,HPars)->
	    Z = [synrule(N, T, HPars, W, I, O, Alts)|R2];
	    Z = R2),
	get_sat_list(Pars,R1,R2).

unify_pars([],[]).

unify_pars([In:Out|R1], [Restriction:In1:Out|R2]):-
	!,
	unify_var(In,Restriction, In1),
	unify_pars(R1,R2).

unify_var(affixvar(Name1, _), affixvar(Name2, _), affixvar(Out, 0)):-
	affixdomain(Name1, Dom1, _, _),
	affixdomain(Name2, Dom2, _, _),
	intersection(Dom1, Dom2, Dom3),
	affixdomain(Out, Dom3, _, _),!.

unify_var(In, affixvar(Name, _), Out):-
	affixdomain(Name, _, Predefs, NonPredefs),
	get_predefs(Predefs, In, Out1),
	subtract(In, Out1, L2),
	intersection(NonPredefs, L2, Out2), append(Out1, Out2, Out), !, Out \= [].

unify_var(affixvar(Name, _), Rest, Out):-
	is_list(Rest),
	affixdomain(Name, _, Predefs, NonPredefs),
	get_predefs(Predefs, Rest, Out1),
	subtract(Rest, Out1, L2),
	intersection(NonPredefs, L2, Out2), append(Out1, Out2, Out), !, Out \= [].

unify_var(In, Rest, Out):-
	is_list(Rest),
	is_list(In),
	intersection(In, Rest, Out),!,
	Out \=[].

get_predefs(Predefs, Values, Out):-
	(member(affix_predef('TEXT'), Predefs)->
	    findall(text(A), member(text(A),Values), Texts);
	    Texts = []),
	(member(affix_predef('INT'), Predefs)->
	    findall(int(A), member(int(A),Values), Ints);
	    Ints = []),
	append(Texts, Ints, Out).

builtin('=').
builtin(append).
builtin(grammar_terminal).

grammar_terminal1([0'-|T1], O, I):-
%	writef("Case 2\n"),
	grammar_terminal2([1|T1], O, I),!.

grammar_terminal1(T, O, I):-
%	writef("Case 3\n"),
	grammar_terminal2([2|T], O, I),!.

grammar_terminal2(T, O, I):-
	(last(T, 0'-)->
%	    writef("Case 1\n"),
	    reverse(T, [0'-|S]),
	    reverse(S, T1),
	    append(T1, [1|O], I),!;
%	    writef("Case 4\n"),
	    append(T, O, I),!).

grammar_terminal(T, O, I):-
 	append([2|T], O, I).

generate_sentence(I):-
	root(Name),
	(generate_nonterminal(Name, I, [])->
	    true;
	    dbwritef("****Could not generate sentence****\n")).

double_params([], []).
double_params([X|Rest1], [Y|Rest2]):-
	(is_list(X)-> Y = X:_;
	    Y = affixvar(X, 0):_),
	double_params(Rest1, Rest2).

generate_nonterminal(Name, I, Parameters):-
	double_params(Parameters, DParameters),
	do_call([32], Name, I1, [], DParameters, 0, OutP),
%	write(I1),
	writef("Penalties = %w \n", [OutP]),
	strip_glues(I1, I).
	

do_call(Sp, Name, I, O, Pars, InP, OutP):-
	(stepbystep(true) ->
	    get_byte(C),
	    (C == 32-> set_attribute(stepbystep, false) ;true);
	    true),	    
	get_head_pars(Pars, HPars),
	findall(synrule(Name, Type, HPars, W, I1, O1, Alternatives),
		(member(Type,[rule,option]),synrule(Name, Type, HPars, W, I1, O1, Alternatives)),
		L1),
	unify_inouts(I, O, L1),
	get_sat_list(Pars, L1, L),!,
	random_select_variant([32|Sp], L, InP, OutP).

strip_glues([], []):-!.
strip_glues([1|Rest], I):-
	strip_glues1(Rest, R),!,
	strip_glues(R, I).
strip_glues([2|Rest], I):-
	strip_glues2(Rest, R),!,
	strip_glues(R, I).
	

strip_glues([X|Rest], [X|R]):-
	strip_glues(Rest, R),!.


strip_glues1([], []):-!.
strip_glues1([1|R], T):-
	strip_glues1(R, T),!.

strip_glues1([2|R], T):-
	strip_glues1(R, T),!.

strip_glues1([X|R], [X|R]):-!.

strip_glues2([], []):-!.
strip_glues2([1|R], T):-
	strip_glues1(R, T),!.

strip_glues2([2|R], T):-
	strip_glues2(R, T),!.

strip_glues2([X|R], [32,X|R]):-!.

random_select_variant(_, [], _, _):- !, fail.

random_select_variant(Sp, Variants, InP, OutP):-
	rand_member(Variants, X),
	X = synrule(N, _, Ps, _, _, _, _),
	Z =.. [N|Ps],
	trace_nonterm(Sp, [ "++>%w, Pens = %w", Z, InP ]),
	(solve_variant([32|Sp], X, InP, Out1)->
	    trace_nonterm(Sp, [ "<--%w Pens = %w", Z , Out1]),
	    true, !, not(var(Out1)), OutP = Out1, !;
	    (step_on_backtrack(true)->
		set_attribute(setbystep, true);
		true),
	    trace_nonterm(Sp, [ "xx<%w", Z ]),
	    delete(Variants, X, Variants2),!,
	    random_select_variant(Sp, Variants2, InP, OutP)).

solve_variant(_, synrule(_,_,_,0,_,_,[]), _, _):- !, fail.

solve_variant(Sp, synrule(Name, Type, HPars, W, I, O, Alternatives), InP, OutP):-
 	W1 is random(W),
	random_select_alternative(Alternatives, W1, Ww:Pp:A),
	In1 is InP + Pp,
	(solve_alternative(Sp, A, In1, Out1)->
	    true,OutP = Out1, !;
	    (step_on_backtrack(true)->
		set_attribute(setbystep, true);
		true),
	    delete(Alternatives, Ww:Pp:A, Alternatives2),
	    W2 is W - Ww,!,
	    solve_variant(Sp, synrule(Name, Type, HPars, W2, I, O, Alternatives2), InP, OutP)).
	
random_select_alternative([], _, _):-
	dbwritef("Error: No alternative selected\n"), !.

random_select_alternative([W1:P1:Alternative| Rest], W, X):-
	(W < W1 ->
	    X = W1:P1:Alternative,!;
	    Wx is W-W1,!,
	    random_select_alternative(Rest, Wx, X)).

solve_alternative(_, [], X, X):-!.

solve_alternative(Sp, [restrict(A)| Rest], InP, OutP):-!,
	trace_nonterm(Sp, [ "%%%Solving guards %w\n", restrict(A)]),
	unify_vars(A),!,
	trace_nonterm(Sp, [ "%%%Solving guards %w\n", restrict(A)]),
	solve_alternative(Sp,Rest, InP, OutP).

solve_alternative(Sp, [X| Rest], InP, OutP):-
%	dbwritef("Solving alternative %w \n", [X]),
	(use_penalties(true)->
	    max_penalty(P),!,
	    (InP =< P -> true; trace_nonterm(Sp, ["@@>Max = %w Current = %w\n", P, InP]), !,fail);
	    true),!,
	solve_member(Sp, X, InP, P1),!,
	solve_alternative(Sp, Rest, P1, OutP).

unify_vars([]):-!.

unify_vars([A:B:C|R]):-
	unify_var(B, A, C),!,
	unify_vars(R).


solve_member(Sp, X, InP, OutP):-
	functor(X, F, _),
 	(builtin(F)->
%	    term_to_atom(X, A),
%	    trace_nonterm(Sp,[">Builtin %w\n", [F]]),
	    (F == grammar_terminal ->
		X =.. [grammar_terminal, AA|_],
		trace_terminal(Sp, ">>>Terminal ***", AA);
		true),!,
	    InP = OutP,
 	    call(X),!;
	    (defines(D), member(head(F, rule, _), D) ->
		InP = OutP,!,solve_term(Sp, X),!;
		X =.. [Name, I, O|Parameters],
		do_call([32|Sp],Name, I, O, Parameters, InP, OutP),!)).

solve_term(Sp, X):-
	X =.. [Name, I, O| Parameters],
	get_head_pars(Parameters, HPars),
	findall(HPars:N, lexset(Name, HPars, N, _), L),
	get_term_sat_list(Parameters, L, L1),
	sum_sats(L1, 0, S),!,
	(S ==0 ->
	    Z =.. [Name|Parameters],
	    dbwritef("<<<<<<<<<<<<<<<<<<No alternative found for %w\n", [Z]),
%	    set_attribute(stepbystep, true),
	    !,fail,
	    I = O,!;
	    T is random(S),
	    pick_term(Name, L1, T, E, HP),
	    trace_nonterm(Sp, [ "++>%w(%w)", Name, HP ]),
	    trace_terminal([32,32|Sp], ">Lex Terminal ***", E),
	    unify_term_inouts(HP),
	    trace_nonterm(Sp, [ "<--%w(%w)", Name, HP ]),
	    grammar_terminal1(E, O, I),!).

% ---------------------
%
% Tracing functions
%

trace_nonterm(Sp, [ Fmt | Args ]) :-
    show_trace(true) ->
	locate_cursor(Sp),
	    ewritef(Sp),
		dbwritef(Fmt, Args),
		    dbwritef("\n");
	true.

% If show_trace is true, do a full trace of terminals.
% Otherwise, if trace_bare_terminals is true, print just the terminal itself.

trace_terminal(Sp, Fmt, T) :-
    show_trace(true) ->
	locate_cursor(Sp),
	    ewritef(Sp),
		writef(Fmt), 
		    ewritef(T),
			writef("\n");
	trace_bare_terminals(true) -> 
	    ewritef(T),
		writef("\n");
	    true.

% Some delay makes the animation more interesting
% Contrary to documentation \33 is octal, not decimal (ESC).
% Uses ANSI escape sequences for cursor position (ESC [ row ; col H)
% and Erase In Display (ESC [ kind K).
% If your window is not big enough we still get a mess.
locate_cursor(Sp) :-
    animate_trace(true) ->
	sleep(0.15),
	    length(Sp, L),
		L3 is (L + 2) // 3,
		    writef("\33[%wH\33[J", [L3]);
	true.

% writef of an empty string (an empty list) prints ugly empty lists.
% Avoid that.
ewritef("") :-
    true, !.

ewritef(E) :-
    writef(E).

dbwritef(F) :- current_prolog_flag(verbose, silent) -> true; writef(F).
dbwritef(F, A) :- current_prolog_flag(verbose, silent) -> true; writef(F, A).

go :-
    load_grammar('boeket.gra'),
	generate_sentence(X),
	    writef(X).
