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