1:- module(pac_listing, [expand_pac_text/1,
    2					 expand_pac/1,
    3					 expand_goal/1,
    4					 expand_exp/1,
    5					string_to_terms/2,
    6					compile_pac/3,
    7					pred_grouping/2,
    8					clause_to_string/3,
    9					is_backquote_begin/2,
   10					is_backquote_end/2
   11						]).   12
   13% :- dynamic '$algebra'/2.
   14% :- discontiguous '$algebra'/2.
   15:- use_module(pac('odict-attr')).   16:- use_module(pac('odict-expand')).   17:- use_module(pac(reduce)).   18:- use_module(pac('pac-aux')).   19:- use_module(pac('expand-pac')).   20:- use_module(pac(basic)).   21:- use_module(pac(op)).   22
   23term_expansion --> pac:expand_pac.
   24
   25:- op(8,	fy,		user:('`')).   26:- op(10,	fy,		user:(:)).   27:- op(10,	fy,		user:(*)).   28:- op(10,	fy,		user:(?)).   29:- op(10,	fy,		user:(@)).   30:- op(10,	fy,		user:(#)).   31:- op(60,	yfx,	user:(@)).   32:- op(750,	yfx,	user:(&)).   33:- op(1200,	xfx,	user:(-->>)).   34:- op(650,	xfy,	user:(::)).   35:- op(1050, xfy,	user:(\)).   36:- op(1105, xfy,	user:('|')).   37:- op(450,	xfx,	user:(..)).   38:- op(710,	fy,		user:(~)).   39% :- op(500,  yfx,    user:(+)).
   40
   41% ?- pac_demo("a-->w('.*').\n", Y).
   42% ?- pac_demo('a-->w(".*").\n', Y).
   43% ?- pac_demo("a.\n", Y).
   44
   45pac_demo(X, Y):- atomic(X),
   46		string_codes(X, Z),
   47		cgi_demo(Z, Y).
   48
   49% ?- show(call(pred([]))).
   50% ?- expand_pac(a(X) :- call(pred([hello]), X)).
   51% ?- expand_pac(a --> w(".*")).
   52% ?- expand_pac((trim_white(A) --> wl("[ \t]*"), w(".*", A), wl("[ \t]*"))).
   53% ?- cgi_demo(`a-->w(".*").\n`, Y).
   54% ?- cgi_demo(`a.\n`, Y).
   55
   56cgi_demo(X, Y):-
   57	nb_setval(pac_name_prefix, pac),
   58	nb_setval(nt_name_prefix, nt),
   59	ejockey:handle([expand, pac], X, Y0),
   60	smash_string(Y0, Y1),
   61	www_form_encode(Y1, Y).
   62
   63expand_pac(X)	:-
   64	compile_pred_word(X, [], H0, R0),
   65	smash(["\n", H0, ".\n\n", R0, "\n"]).
   66
   67%
   68expand_exp(X)	:- show_exp(X).
   69%
   70expand_goal(X)	:- show(X).
   71
   72
   73		/*************************************************
   74		*     Demo :  Compile clause / DCG with regex    *
   75		*************************************************/
   76
   77
   78% ?- nb_setval(nt_name_prefix, nt).
   79% ?- nb_setval(pac_name_prefix, pac).
   80% ?- expand_pac_text("zip(P,Q):-maplist(pred([X,Y,X-Y]), P, Q)").
   81% ?- expand_pac_text("a :- call(pred([X]))").
   82% ?- expand_pac_text("a --> b").
   83% ?- expand_pac_text('a --> w(".*")').
   84% ?- expand_pac_text('trim_white(A) --> wl("[ \t]*"), w(".*", A), wl("[ \t]*")').
   85% ?- expand_pac_text('trim_white(A) --> wl("[ \t]*"), w(".*", A), wl("[ \t]*")').
   86% ?- expand_pac_text('a(`(b)`)').
   87% ?- qcompile(util(zdd)), qcompile(util('emacs-jockey')), module(pac_listing).
   88% ?- enter_back_quotes.
   89% ?- exit_back_quotes.
   90
   91expand_pac_text(S):-
   92	term_string(X, S, [variable_names(Eqs)]),
   93	compile_pred_word(X, Eqs, H0, R0),
   94	smash(["\n", H0, ".\n\n", R0, "\n"]).
   95%
   96expand_pac_text_symbol_char(S):-
   97	with_backquote_symbol_char(
   98		(	term_string(X, S, [module(symbol_char),
   99					   variable_names(Eqs)]),
  100			compile_pred_word(X, Eqs, H0, R0),
  101			smash(["\n", H0, ".\n\n", R0, "\n"])
  102		)).
  103
  104% ?- new_names([X,Y], Eqs, 1, 'A', [a1,a2,a3]).
  105new_names([V|Vs], [A=V|Eqs], N, Prefix, As):-
  106	new_name(N, As, A, Prefix, K),
  107	new_names(Vs, Eqs, K, Prefix, As).
  108new_names([], [], _, _, _).
  109
  110%
  111new_name(N, As, B, Prx, K):- atom_concat(Prx, N, B),
  112						\+ memberchk(B, As),
  113						!,
  114						succ(N, K).
  115new_name(N, As, A, Prx, K):- succ(N, N1),
  116						new_name(N1, As, A, Prx, K).
  117
  118% ?- subtractq([X,Y,X,Y,X,Y], [X], R).
  119subtractq([], _, []).
  120subtractq([A|As], B,  C):- memq(A, B), !,
  121	subtractq(As, B, C).
  122subtractq([A|As], B, [A|C]):- subtractq(As, B, C).
  123
  124% ?- expand_clause_slim(a(X):-call(pred([1]),X), Y).
  125expand_clause_slim(X, [H|Y]):-
  126	anti_subst:expand_clause(X, [], Y0, []),
  127	maplist(pred(&([X:-true, X], [C, C])),  Y0, [H|Y1]),
  128	maplist(copy_term, Y1, Y).
  129
  130% ?- compile_pred_word(a(X):-call(pred([1]),X), ['X'=X], H, R).
  131compile_pred_word(Clause, Eqs, H0, R0):-!,
  132		maplist(pred([A=P, A, P]), Eqs, As, Vs),
  133		expand_clause_slim(Clause, [H|R]),
  134		term_variables(H, HVs),
  135		subtractq(HVs, Vs, SVs),
  136		new_names(SVs, Eqs0, 1, 'A', As),
  137		append(Eqs0, Eqs, Eqs1),
  138		term_string(H, H0, [ module(pac_op),
  139							variable_names(Eqs1),
  140							quoted(true)]),
  141		maplist(pred(([U, [V,"\s.\n"]] :-
  142								numbervars(U, 0, _, [singleons(true)]),
  143								term_string(U, V, [ module(pac_op),
  144													numbervars(true),
  145													quoted(true)]))),
  146				R, R0).
  147
  148		/**********************************
  149		*     format clause for output    *
  150		**********************************/
  151
  152% ?- clause_to_string(p(a(X):-b(X), ['X'=X], [b(Y)]), C, H).
  153clause_to_string(p(X, Eqs, H), Z, H0):-
  154		maplist(pred([A=P, A, P]), Eqs, As, Vs),
  155		term_variables([X|H], HVs),
  156		subtractq(HVs, Vs, SVs),
  157		new_names(SVs, Eqs0, 1, 'A', As),
  158		append(Eqs0, Eqs, Eqs1),
  159		(	X ==[]
  160		->  Z = []
  161		;	term_string(X, X0, [ module(pac_op),
  162								variable_names(Eqs1),
  163							quoted(true)]),
  164			Z = [X0,"\s.\n"]
  165		),
  166		maplist(pred(([U, [V,"\s.\n"]] :-
  167								numbervars(U, 0, _, [singleton(true)]),
  168								term_string(U, V, [ module(pac_op),
  169													numbervars(true),
  170													quoted(true)]))),
  171				H, H0).
  172%
  173clause_to_string(X, Y, Z):- clause_to_string(p(X, [], []), Y, Z).
  174
  175
  176		/***************************
  177		*     compile pac block    *
  178		***************************/
  179
  180% ?- compile_pac([(a:- maplist(=, []))-[]], P, []).
  181% ?- compile_pac([(a := [])-[], (d:=(a + a))-[]], X, []).
  182% ?- compile_pac([(f(X):-call(pred([a]), X))-[], (:-bekind(a,[]))-[], (a+b=1)-[], (a*b = c)-[],(:-ekind)-[], z-[]], P, []).
  183% ?- compile_pac([(:-bekind(a,[]))-[], (a+b=1)-[], (:-ekind)-[]], P, []).
  184% ?- compile_pac([(:-bekind(a,[]))-[], (a+b= '`'(c))-[], (:-ekind)-[]], P, []).
  185% ?- compile_pac([(:-bekind(a,[]))-[], (a+b= c@1)-[], (:-ekind)-[]], P, []).
  186% ?- compile_pac([(:-bekind(a,[]))-[], (:-ekind)-[]], P, []).
  187% ?- compile_pac([(:-betrs(a))-[], (x=y)-[], ((x=y):-z=u) - [], (:-etrs)-[]], P, []).
  188% ?- compile_pac([(:-betrs(a))-[], (x=y)-[], ((x=y):-z=u) - [], (:-etrs)-[]], P, []).
  189% ?- compile_pac([(a:=[b/2-f])-[]], P, []).
  190% ?- compile_pac([(a:=[b/0-f])-[]], P, []).
  191
  192compile_pac(X, [p([],[],R)|P], Q) :- collect_sgn(X, Y, Zip), !,
  193	expand_sgn_defs(Zip, E, R, []),
  194	compile_pac(Y, E, P, Q).
  195%
  196compile_pac([X-Eqs|Xs], D, P, Q) :-
  197	compile_pac(X, Eqs, D, Xs, Ys, P, P0),
  198	!,
  199	compile_pac(Ys, D, P0, Q).
  200compile_pac([], _, P, P).
  201
  202% ?- expand_sgn_defs([(a:=[b-c])-U], U, X, []).
  203% ?- expand_sgn_defs((a:=[a-pred([c])])-U, X).
  204expand_sgn_defs([], [], X, X).
  205expand_sgn_defs([(K := L)-(K := L0)|R], [K-L0|S], P, Q):-
  206	expand_sgn_term(L, L0, P, P0),
  207	expand_sgn_defs(R, S, P0, Q).
  208
  209%
  210expand_sgn_term(L, L0, P, Q):-
  211	(	is_list(L) -> expand_sgn_term_list(L, L0, P, Q)
  212	;	L=..[F|As],
  213		expand_sgn_terms(As, Bs, P, Q),
  214		L0=..[F|Bs]
  215	).
  216%
  217expand_sgn_term_list([], [], P, P).
  218expand_sgn_term_list([W-U|L], [W-V|L0], P, Q):-
  219	expand_arg(U, [], V, P, P0),
  220	expand_sgn_term_list(L, L0, P0, Q).
  221%
  222expand_sgn_terms([], [], P, P).
  223expand_sgn_terms([A|As], [B|Bs], P, Q):-
  224	expand_sgn_term(A, B, P, P0),
  225	expand_sgn_terms(As, Bs, P0, Q).
  226expand_sgn_terms(A, A, P, P).
  227%
  228collect_sgn([], [], []).
  229collect_sgn([X-Eqs|Xs], [X0-Eqs|Y], [X-X0|Z]):- sgn_dcl_term(X), !,
  230	collect_sgn(Xs, Y, Z).
  231collect_sgn([U|Xs], [U|Y], Z):- collect_sgn(Xs, Y, Z).
  232
  233%
  234sgn_dcl_term(_ := _).
  235
  236
  237%  'pac:' is necessary. [2017/04/12]
  238compile_pac(:-bekind(N, Opts), _Eqs, _D, Xs, Ys, P, Q) :-
  239	once(pac:kind_term(N,  N1)),
  240	(	memberchk(nonvar, Opts)
  241	->  Nonvarcheck = "(X = [] :- var(X), !, fail)",
  242		term_string(Ruleterm, Nonvarcheck, [variable_names(Eqs)]),
  243		U = [Ruleterm - Eqs| Xs]
  244	;	U = Xs
  245	),
  246	compile_kind_block(U, N1, Opts, Ys, P, Q).
  247compile_pac(:-betrs(N), Eqs, D, Xs, Ys, P, Q) :-!,
  248		compile_pac(:-betrs(N, []), Eqs, D, Xs, Ys, P, Q).
  249compile_pac(:-betrs(N, Vs), _Eqs, _D, Xs, Ys, P, Q) :-
  250		term_variables(Vs, Us),
  251		make_trs_ref(N, Us, [], N0),
  252		pac:new_pac_name(Sub),
  253		make_trs_ref(Sub, Us, [], Sub0),
  254		pac_aux:expand_core_rec(N0, [],
  255			&(([X, Y]:-	call(Sub, X, X0), !,
  256						call(N0, X0, Y)),
  257			([X, X])),
  258			[], _, [U1, U2], []),
  259		P = [p(U1,['X'=X, 'Y'=Y, 'Z'=X0],[]),
  260			 p(U2,['X'=X],[])|P0],
  261		compile_trs_block(Xs, Ys, Sub0, P0, Q).
  262compile_pac(:-befun, _Eqs, _, Xs, Ys, P, Q) :-
  263 	compile_fun_block(Xs, Ys, P, Q).
  264compile_pac(:-X, _Eqs, _, Xs, Xs, [p(:-X, [], [])|P], P).
  265compile_pac(A := Expr, Eqs, Assoc, Xs, Xs,
  266			[p(A := Expr, Eqs, [])|P], Q) :- !,
  267	rec_subst(Expr, S0, Assoc),
  268	pac:zip_algebra(S0, S1),
  269	(	Cs \== []
  270	->	maplist(pac:expand_sgn(A), S1,  Cs),
  271		pac_etc:list_to_ampersand(Cs, As),
  272		pac_aux:expand_core_rec(A, [], &(As, [U, U]), [], _, Ds, [])
  273	;	pac_aux:expand_core_rec(A, [], [U, U], [], _, Ds, [])
  274	),
  275	maplist(pred([U, p(U,[],[])]), Ds, Y0),
  276	append(Y0, Q, P).
  277compile_pac(X, Eqs, _, Xs, Xs, Q, P) :-
  278	expand_clause_slim(X, [C|H]),
  279	( C == end_of_file  ->	Q = P   % Comment or white linecgi in prolog access
  280	;	Q  =  [p(C, Eqs, H)|P]
  281	).
  282
  283% ?- rec_subst(a+a, R, [a-b, b-[]]).
  284rec_subst(A+B, A0+B0, F):-
  285	rec_subst(A, A0,F),
  286	rec_subst(B, B0,F).
  287rec_subst(A*B, A0*B0, F):-
  288	rec_subst(A, A0,F),
  289	rec_subst(B, B0,F).
  290rec_subst(\(A,B), \(A0,B0), F):-
  291	rec_subst(A, A0, F),
  292	rec_subst(B, B0, F).
  293rec_subst(A, B, _):- (is_list(A), B = A;  A=sgn(B)), !.
  294rec_subst(A, B, F):- memberchk(A-A0, F), !,
  295	rec_subst(A0, B, F).
  296rec_subst(A, A, _).
  297
  298%
  299compile_kind_block([X-Eqs|Xs], N, Opts, Ys, P, Q):-
  300	once(compile_kind_block(X, Eqs, Xs, N, Opts, Ys, P, Q)).
  301%
  302% compile_kind_block(:-ekind, _, Xs, _, _, Xs, P, P).
  303compile_kind_block(:-ekind, _, Xs, N, Opts, Xs, P, Q):-
  304	(	memberchk(stop, Opts) ->
  305		Stop = "(X = quote(X) :-true)",
  306		term_string(Rule, Stop, [variable_names(Eqs)]),
  307		pac:compile_kind_rule(N, Opts, Rule, C, H, []),
  308		P = [p(C, Eqs, H)|Q]
  309	;	Q = P
  310	).
  311compile_kind_block(X, Eqs, Xs, N, Opts, Ys, [p(Y, Eqs, H)|P], Q):-
  312	pac:compile_kind_rule(N, Opts, X, Y, H, []),
  313	compile_kind_block(Xs, N, Opts, Ys, P, Q).
  314%
  315normalilze_rule((L = R):-B, L, R, B):-!.
  316normalilze_rule(L = R, L, R, true).
  317
  318% ?- make_trs_ref(t, [A,A], M, R).
  319make_trs_ref(T, Vs, M, R):-
  320	( Vs==[] -> Args = []
  321	;	Args = [[Vs]]
  322	),
  323	complete_args(T, Args, T0),
  324	attach_prefix(M, T0, R).
  325
  326%
  327compile_trs_block([(:-etrs)-_|Xs], Xs, _, P, P).
  328compile_trs_block([end_of_file|Xs], Ys, Ref, P, Q):-
  329	compile_trs_block(Xs, Ys, Ref, P, Q).
  330compile_trs_block([X-Eqs|Xs], Ys, Ref, [p(Y, Eqs, H)|P], Q):-
  331	make_trs_sub(Ref, X, Y, H, []),
  332	compile_trs_block(Xs, Ys, Ref, P, Q).
  333%
  334make_trs_sub(N, A = B, H, L, L):-!,
  335	complete_args(N, [A,B], H).
  336make_trs_sub(N, (A = B :- Right), H :- C, L, M):-
  337		complete_args(N, [A,B], H),
  338		once(make_trs_cond(Right, N, C, L, M)).
  339%
  340make_trs_cond((X, Y), R, (X0, Y0), P, Q):-
  341	make_trs_cond(X, R, X0, P, P0),
  342	make_trs_cond(Y, R, Y0, P0, Q).
  343make_trs_cond((X; Y), R, (X0; Y0), P, Q):-
  344	make_trs_cond(X, R, X0, P, P0),
  345	make_trs_cond(Y, R, Y0, P0, Q).
  346make_trs_cond(U=V, R, C, P, P):- complete_args(R, [U, V], C).
  347make_trs_cond(G, _, G0, P, Q):- expand_arg(G, [], G0, P, Q).
  348
  349%
  350compile_fun_block([(:-efun)-_|Xs], Xs, P, P).
  351compile_fun_block([end_of_file|Xs], Ys, P, Q):-
  352	compile_fun_block(Xs, Ys, P, Q).
  353compile_fun_block([X-Eqs|Xs], Ys, [p(Y, Eqs, [])|P], Q):-
  354	pac:expand_fun(X, Y),
  355	compile_fun_block(Xs, Ys, P, Q).
  356
  357% ?- pred_grouping([p(a,[],[]), p(a:-b,[],[])], G).
  358% ?- pred_grouping([p(m:a,[],[]), p(m:a:-b,[],[])], G).
  359pred_grouping([], []).
  360pred_grouping([P|R], [[P|G]|R0]):-
  361	pred_grouping(P, R, G, R1),
  362	pred_grouping(R1, R0).
  363
  364%
  365pred_grouping(_, [], [], []).
  366pred_grouping(P, [Q|R], [Q|G], R0):-
  367	P=p(C,_,_),
  368	Q=p(D,_,_),
  369	same_predicate_arity(C, D),
  370	!,
  371	pred_grouping(P, R, G, R0).
  372pred_grouping(_, R, [], R).
  373
  374%
  375same_predicate_arity(X, Y):- predicate_arity(X, S),
  376							 predicate_arity(Y, S).
  377
  378% ?-predicate_arity(user:a(_,_), R).
  379predicate_arity(X, Sig):-
  380	strip_module(X, M, X0),
  381	predicate_arity(X0, M, Sig).
  382%
  383predicate_arity(X:-_, M, M0:F/N):-
  384	strip_module(M:X, M0, X0),
  385	functor(X0, F, N).
  386predicate_arity(X, M, M:F/N):-
  387	functor(X, F, N).
  388
  389%
  390is_backquote_begin(:-bekind(X,Y), :-bekind(X, Y)).
  391is_backquote_begin(:-bekind(X),   :-bekind(X, [])).
  392is_backquote_begin(:-befun,   :-befun).
  393
  394%
  395is_backquote_end(:-ekind, :-ekind).
  396is_backquote_end(:-efun, :-efun).
  397
  398		/*************************
  399		*     string_to_terms    *
  400		*************************/
  401
  402string_to_terms(InStr, OutStr):-
  403	setup_call_cleanup(
  404		open_string(InStr, Stream),
  405		string_to_terms(Stream, OutStr, []),
  406		close(Stream)).
  407%
  408string_to_terms(Stream, P, Q) :-
  409		read_term(Stream, X, [variable_names(Eqs)]),
  410		(	at_end_of_stream(Stream) ->	Q = P
  411		;	update_back_quotes(X, X0),
  412			P = [X0 - Eqs|P0],
  413			string_to_terms(Stream, P0, Q)
  414		).
  415%
  416update_back_quotes(X, Y):-
  417		(	is_backquote_begin(X, Y) ->
  418			set_prolog_flag(back_quotes, symbol_char)
  419		; 	is_backquote_end(X, Y)	->
  420			set_prolog_flag(back_quotes, codes)
  421		;	Y = X
  422		)