Re: regex with boolean operations over character classes built_in on DCG

On Aug 1, 2014, at 10:51 PM, Michael Hendricks <[email protected]> wrote:

> On Fri, Aug 1, 2014 at 3:34 AM, Kuniaki Mukai <[email protected]> wrote:
> 
>> I have completely rewritten  my old codes for regex in SWI-Prolog DCG, so
>> that
>> now it is working stable on SWI-Prolog develop version.
>> 
>> Features are:
>> 1.  Character classes
>> 2.  Boolean operations
>> 3.  States are minimized as taught in automata theory.
>> 4.  Built_in on DCG.
>> 5.  Hybrid syntax of unix-like regex and prolog terms.
>> 6.  regex expressions are term-expanded on being read.
>> 7.  No runtime library needed except generated predicates as state labels.
>> 
> 
> This is intriguing.  Is the source code available somewhere for us to see?

Thank you for your interest.  I have no idea on  how to
make the source code available, though I wish to do so if there
is any handy way.  What I can do for your request for now 
is to copy and paste a main source codes file "expand-word.pl"
for term-expansion to expand the regex. The codes is dirty, 
lengthy and not clean, but I hope you can find something
what the codes is doing to cover the features announced.

:- module(word,[]).
:- include(pac('pac-only')).
:- include(pac(op)).

% ?-  phrase(w(char(alnum) + *(char(alpha))), [a, '1', b,c], S).
%@ S = ['1', b, c] ;
% ?-  phrase(w(ab+cd), [a, b, c, d, e], S).
% ?-  phrase(w("abcd"), [a, b, c, d, e], S).
%@ S = [e].

% ?- word:let_word(X, regex("a*"

% ?- word:let_word(X, "a*").
% ?- word:let_word(X, "a*"), phrase(w(X), [a,a,b,c], R).
% ?- word:let_word(X, abc), phrase(w(X), [a,b,c,d,e], R).


% NOT meta_predicate !
% ?- word:let_word(X, ".*"), phrase(w(X), [a,b,c], R).
let_word(F, X):- once(let_word(coa_dcg, F, X, Y)),
	maplist(assert, Y).

% ?- word:let_word_d(X, ".*"), phrase(w(X, A), [a,b,c], R).
let_word_d(F, X):- once(let_word(coa_dcg_d, F, X, Y)),
	maplist(assert, Y).

% NOT meta_predicate !
let_word(T, F, X, Y):- nb_getval(module_name_for_aux, M),
 	regex_coalgebra(X, Coa),
	translate_coa(T, Coa, M, F, Y, []).

% ?- trace, word:regex_coalgebra(*(a|b)+ [a]+(*([]))+ (*(*([]|[]))), N).
% ?- word:regex_coalgebra(".*", X).
%@ X = coa([1-[[], dot([inf-sup])-1]], 1, [1]).
% ?- word:regex_coalgebra(*(.), X).
%@ X = coa([1-[[], dot([inf-sup])-1]], 1, [1]).
% ?- word:regex_coalgebra(ab+cd, X).
% ?- word:regex_coalgebra_code(ab+cd, X).
% ?- word:regex_coalgebra_char(ab+cd, X).

%
regex_coalgebra_code(X, coa(E0, I, Fs)):- once(regex_am(X,  coa(E, I))),
	am_finals(coa(E, _), Fs),
 	am_convert_interval_code(E, E0).
%
regex_coalgebra_char(X, coa(E0, I, Fs)):- once(regex_am(X,  coa(E, I))),
	am_finals(coa(E, _), Fs),
 	am_convert_interval_char(E, E0).
%
regex_coalgebra(X, C):- regex_coalgebra_char(X, C).


% ?-  phrase(w(char(alnum) + *(char(alpha))), [a, '1', b,c], S).
%@ S = ['1', b, c] ;
%@ S = ['1', b, c] ;
% ?-  phrase(w(ab+cd), [a, b, c, d, e], S).
% ?-  phrase(w("abcd"), [a, b, c, d, e], S).
%@ S = [e].

% ?- word:let_word(X, "a*").
% ?- word:let_word(X, "a*"), phrase(w(X), [a,a,b,c], R).
% ?- word:let_word(X, abc), phrase(w(X), [a,b,c,d,e], R).


% ?- trace, word:expand_w("[a]", user, G, P, []).
% ?- trace, word:expand_w("[^a]", user, G, P, []).


%
am_convert_interval_char(X, Y):- am_convert_interval(X, Y,  interval_char_code).
%
am_convert_interval_code(X, Y):-  am_convert_interval(X, Y, =).

:- meta_predicate am_convert_interval(?,?,2).
am_convert_interval([], [],  _).
am_convert_interval([I-A|R], [I-B|S], F):- am_convert_interval_aux(A, B, F),
	am_convert_interval(R, S, F).

am_convert_interval_aux([], [], _).
am_convert_interval_aux([[]|Q], [[]|R], F) :- am_convert_interval_aux(Q, R, F).
am_convert_interval_aux([U-S|Q], [dot(V)-S|R], F) :- maplist(F, U, V),
		am_convert_interval_aux(Q, R, F).

	
% am_convert_interval(X, Y):- 
% 	maplist([I-A, I-B]:- 
% 		maplist(pred(	[[], []]
% 			    &	([U-S, dot(V)-S] :- 
% 					maplist(interval_char_code,
% 						U, V))),
% 			A, B),
% 		X,  Y).


% wrap_char_dot(X, Y):- 
% 	maplist([I-A, I-B]:- 
% 		maplist(pred(	[[], []]
% 			    &	([U-S, dot(V)-S] ))
% 		       A, B),
% 		X,  Y).


interval_char_code(inf-sup, inf-sup).
interval_char_code(inf-X, inf-Y):- char_code(Y, X).
interval_char_code(X-sup, Y-sup):- char_code(Y, X).
interval_char_code(X-X0, Y-Y0):- char_code(Y, X), 
	char_code(Y0, X0).

% ?- coa:regex_min_coa("a" & "b", R).
%@ R = coa([1-[[]]], 1) .

% regex_min_coa(R, C):- once(word_am(R, coa(E0, I))),  
% 	distribute_am_goto(E0, E1), 
% 	am_minimum(coa(E1, I), C).

% distribute_am_goto(X, Y):- refine_am_goto(X, X0), split_goto(X0, Y).

% ?- iboole:m_partition([[1-5], [3-6], [1-5]],R).
% ?- iboole:m_partition([[3-6], [1-5]], R).
%@ R = [[3-5, 6-6], [1-2, 3-5]] .

%  ?-  coa:refine_am_goto([a-[[1-5]-b, [3-6]-c], d-[[inf-sup]-3]], X).
%@ X = [a-[[1-2, 3-5]-b, [3-5, 6-6]-c], d-[[inf-0, 1-2, 3-5, 6-6, 7-sup]-3]] .

refine_am_goto(E, E0):- am_char_table(E, E0, [], P), 
	refine_char_table(P).

%
refine_char_table(Tzip):-  zip_hyphen(Left, Right, Tzip),
	iboole:m_partition(Left, Right).

%  ?-  coa:am_char_table([2-[[inf-sup]-3]], C, [], P).
%@ C = [2-[_G2137-3]],
%@ P = [[inf-sup]-_G2137].

am_char_table([], [], P, P).
am_char_table([[]|Z], [[]|Z0], P, Q):- am_char_table(Z, Z0, P, Q).
am_char_table([X-Y|Z], [X-Y0|Z0], P, Q):-
	goto_table(Y, Y0, P, R), 
	am_char_table(Z, Z0, R, Q).


%
goto_table([], [], P, P).
goto_table([[]|X],[[]|Y], P, Q):- goto_table(X, Y, P, Q).
goto_table([I-S|X],[V-S|Y], P, Q):- add_char_table(I, P, P0, V),
	goto_table(X, Y, P0, Q).

%
% add_char_table([X],P, Q, V):- !, add_char_table(char([X-X]), P, Q, V).
add_char_table(I, P, P, V):- memberchk(I-V, P), !.
add_char_table(I, P, [I-V|P], V).

%
expand_char_class(U, V):-
	maplist(([X-Y, X-Y0]:-
		maplist(pred( [[], []] &
			      ([V-S, Gotos] :- maplist(S^([A, A-S]), V, Gotos))),
			Y, Y0)),
		 U, V).


% ?- coa:split_goto([1-[[], [1,2,3]-s, [2,3]-t], 1-[[1,2,3]-s, [2,3]-t]], X).
%@ X = [1-[[], 1-s, 2-s, 3-s, 2-t, 3-t], 1-[1-s, 2-s, 3-s, 2-t, 3-t]] .
split_goto(X, Y):-
	maplist([I-S, I-S0]:- distribute_state(S, S0), 	X,  Y).

%
distribute_state([], []).
distribute_state([[]|X], [[]|X0]):- distribute_state(X, X0).
distribute_state([X-S|Y], Z):- distribute_state(Y, Y0),
	maplist(pred(S, [C, C-S]), X, XS),
	append(XS, Y0, Z).

% ?- coa:word_am("a", X).
% ?- coa:word_am(".*", X).
%@ X = coa([1-[[], [46-46]-1]], 1) .
%@ X = coa([1-[[], [46-46]-1]], 1) .
       
:-bekind(word_am, []).
% (.)	= char([inf-sup]).
char(X) = :am_char@ ((iboole:i_boole)  @ (coa:char_boole_form(X))).
'$INTLIST'(X)  = :am_char_simple(X).
[]	= char([]).
[X|Y]	= :am_codes([X|Y]).
X+Y	= :am_concat@X@Y.
(X|Y)   = :am_cup@X@Y.
(X\Y)	= :am_minus@X@Y.
&(X, Y) = :am_cap@X@Y.
+(X)	= ( X + (*(X))).
*(X)	= :am_star@X.
\+(X)   = ( *(.) \ X ).
?(X)	=  ( [] | X ).	    
E^N	=  :am_repeat(N)@E.
(E<N)	=  :am_repeat_upto(N)@E.
E	= @(:parse_regex(E))		:- string(E).
E	= @(:atom_codes(E))		:- atom(E).
E	= @(:number_codes(E))		:- number(E).
:- ekind.

%
merge([X,X|Y], U):-!,  merge([X|Y], U).
merge([X|R], [X|U]):- merge(R, U).
merge([], []).

%
regex_am(X, Y):- regex_word(X, X0, Basic_interval_table),
 	word_am(X0, Y0),
 	am_connected_region(Y0, Y0_reachable),
 	am_remove_empty_states(Y0_reachable, Y0_slim),
	am_remove_useless_states(Y0_slim, Y0_useful),
 	am_char_back(Y0_useful, Basic_interval_table, Y1),
 	am_normal(Y1, Y).

regex_word(X, Y, Basic_interval_table):- 
	parse_interval(X, Y, P, []), 
	sort(P, SortedP),
	merge(SortedP, P0),
	zip_hyphen(Is, Js, P0),
	zip_hyphen(Is, Ks, Q0),
	refine_char_table(Q0), 
	basic_interval_index(Ks, Js, Basic_interval_table).

am_char_back(coa(X, I), M, coa(Y, I)):- 
	maplist(pred(M, [I-A, I-B]:- 
			maplist(pred(M, ([[], []] 
	 			      & ([C-J, D-J] :-  memberchk(D-C, M)))),
			A, B)), 
       X, Y).

basic_interval_index(Ks, Js, Basic_interval_table):- 
	maplist([B, C, D]:- zip_hyphen(B, C, D), 
		Ks, Js,  U),
	flatten(U, V),
	sort(V, Basic_interval_table0),
	merge(Basic_interval_table0, Basic_interval_table),
	length(Basic_interval_table, N),
	(	N==0
	->	true
	; 	numlist(1, N, NZip),
		zip_hyphen(_, NZip, Basic_interval_table)
	).

% ?- coa:regex_am((.), R).
%@ R = coa([1-[inf-sup-2], 2-[[]]], 1) .

parse_interval((.), '$INTLIST'(U), [[inf-sup]-U|P], P).
parse_interval(char(X), '$INTLIST'(U) , [I-U|P], P) :- 
	char_boole_form(X, X0), iboole:i_boole(X0, I).
parse_interval(out(X), U, P, Q):- parse_interval(char(out(X)), U, P, Q).
parse_interval(dot(X), U, P, Q):- parse_interval(char(X), U, P, Q). 
parse_interval(X+Y, U+V, P, Q):-  parse_interval(X, U, P, P0), 
	parse_interval(Y, V, P0, Q).
parse_interval(X|Y, U|V, P, Q):-  parse_interval(X, U, P, P0), 
	parse_interval(Y, V, P0, Q).
parse_interval(X\Y, U\V, P, Q):-  parse_interval(X, U, P, P0), 
	parse_interval(Y, V, P0, Q).
parse_interval(X&Y, U&V, P, Q):-  parse_interval(X, U, P, P0), 
	parse_interval(Y, V, P0, Q).
parse_interval(+(X), +(U), P, Q):-  parse_interval(X, U, P, Q).
parse_interval(*(X), *(U), P, Q):-  parse_interval(X, U, P, Q).
parse_interval(\+(X), U, P, Q) :- parse_interval( *(.) \ X, U, P, Q).
parse_interval(flip(X), U, P, Q):- parse_interval(\+X, U, P, Q).
parse_interval(?(X), ?(U), P, Q):- parse_interval(X, U, P, Q).
parse_interval(E^N, E0^N, P, Q):- parse_interval(E, E0, P, Q).
parse_interval(E<N, E0<N, P, Q):- parse_interval(E, E0, P, Q).
parse_interval(X,  U, P, Q):- string(X), !, 
	parse_regex(X, X0), 
	parse_interval(X0, U, P, Q).
parse_interval(X, U, P, Q):- atom(X), !,
	atom_codes(X, X0),  
	parse_interval(X0, U, P, Q).
parse_interval(X, U, P, Q):- number(X), !, 
	number_codes(X, X0),  
	parse_interval(X0, U, P, Q).
parse_interval(X, U, P, Q):- is_list(X), 
	parse_interval_codes(X, U, P, Q).

%
parse_interval_codes([], [],  P, P).
parse_interval_codes([X], '$INTLIST'(U), [[X-X]- U|P], P).
parse_interval_codes([X, Y|Z], '$INTLIST'(U) + R, [[X-X]- U|P], Q):- 
	parse_interval_codes([Y|Z], R, P, Q).


% Note.
% ?- val(:(=) @ (:(=) @ (:(=) @ 1)), V).
%@ V = 1 .

% ?- trace, coa:am_codes([a,b], X).
%@    Call: (8) coa:am_codes([a, b], _G820) ? no debug
%@ X = coa([1-[[a-a]-2], 2-[[b-b]-3], 3-[[]]], 1) .
am_codes([X|Y], Coa):-  
	am_char([X-X], Coa0),
	( Y == [] 
	->	Coa = Coa0
	;	am_codes(Y, Coa1),
		am_concat(Coa0, Coa1, Coa)
	).

% %% Boolean operations on sets of intergers represented
% as a list of characters
% and intervals of characters, e.g, [a, c-k, u, x-z].

% ?- coa:char_boole_form(., X).
% ?- coa:char_boole_form((a-c)&(b-d), X).
% ?- coa:char_boole_form(abc, X).
% ?- char_code(a, R).
%@ R = 97.

char_boole_form((.), [inf-sup]):- !.
char_boole_form([], []):- !.
char_boole_form(X-Y, [A0-A1]):- !,
	(atom(X), atom_length(X, 1); integer(X)),
	(atom(Y), atom_length(Y, 1); integer(Y)),
	( atom(X)-> char_code(X, X0); X0=X ),
	( atom(Y)-> char_code(Y, Y0); Y0=Y ),
	msort([X0,Y0], [A0,A1]).
char_boole_form(X, Y):- atom(X), !, i_type_assoc(Assoc),
	memberchk(X-C, Assoc),
%	maplist(pred([A-B, A-B]& [A, A-A]), C, C0),
	maplist(pred(([A-B, A0-B0]:-  char_code(A, A0), char_code(B, B0)) 
		    & ([A, A0] :-  char_code(A, A0))), 
		C, C0),
	char_boole_form(C0, Y).
char_boole_form(X, [X-X]):- integer(X), !.
char_boole_form([X|Y], X0;Y0):- char_boole_form(X, X0),
	char_boole_form(Y, Y0).
char_boole_form(dot(X), Y):- char_boole_form(X, Y).
char_boole_form(out(X), out(Y)):- char_boole_form(X, Y).
char_boole_form(^(X), Y):- char_boole_form(out(X), Y).
char_boole_form(\+(X), Y):- char_boole_form(out(X), Y).
char_boole_form(X|Y, X0|Y0):- char_boole_form(X, X0),
	char_boole_form(Y, Y0).
char_boole_form(X;Y, Z):- char_boole_form(X|Y, Z).
char_boole_form(X&Y, X0&Y0):- char_boole_form(X, X0),
	char_boole_form(Y, Y0).


%%% Tiny helpers
zip_hyphen([], [], []).
zip_hyphen([A|B], [C|D], [A-C|R]):- zip_hyphen(B, D, R).

%
zip_comma([], [], []).
zip_comma([A|B], [C|D], [(A,C)|R]):- zip_comma(B, D, R).

%
translate_coa(F, coa(C, I, _), M, M:Name, P, Q):-
	all_states(C, Nts),
	maplist([J, J-N]:- gensym('nt#', N), Nts, Assoc),
	call(F, C, M, P0, [], Assoc),
	memberchk(I-Name, Assoc),	
	maplist(dcg_translate_rule_expand_dot, P0, P1),
	append(P1, Q, P).

%
dcg_translate_rule_expand_dot(P,  H:-G0):- 
	dcg_translate_rule(P, H:-G),
	pac:expand_goal(G, [], G0, _, []).
%
am_dcg([], _, P, P, _).
am_dcg([I-D|E], M, P, Q, Assoc):- am_dcg(I, M, D, P, R, Assoc),
	am_dcg(E, M,  R, Q, Assoc).

am_dcg(_, _, [], P, P, _).
am_dcg(I, M, [[]|R], [M:PI-->[]|P], Q, Assoc):-
	memberchk(I-PI, Assoc),
	am_dcg(I, M, R, P, Q, Assoc).
am_dcg(I, M, [A-J|R], [M:PI-->(A0, M:PJ)|P], Q, Assoc):-
	memberchk(I-PI, Assoc),
	memberchk(J-PJ, Assoc),
	(  A == (.),  A0=[_];
	   A0 = A  ),
	!,
	am_dcg(I, M, R, P, Q, Assoc).

%  d means d-list version of am_dcg 
am_dcg_d([], _, P, P, _).
am_dcg_d([I-D|E], M, P, Q, Assoc):- am_dcg_d(I, M, D, P, R, Assoc),
	am_dcg_d(E, M,  R, Q, Assoc).

am_dcg_d(_, _, [], P, P, _).
am_dcg_d(I, M, [[]|R], [M:PI-->[]|P], Q, Assoc):- memberchk(I-PI0, Assoc),
	PI=..[PI0, X, X],
	am_dcg_d(I, M, R, P, Q, Assoc).
am_dcg_d(I, M, [A-J|R], [M:PI-->(A0, M:PJ)|P], Q, Assoc):-
	memberchk(I-PI0, Assoc),
	memberchk(J-PJ0, Assoc),
	PI=..[PI0, U, V],
	dcg_d(A, U, W, A0),
	PJ=..[PJ0, W, V],
	am_dcg_d(I, M, R, P, Q, Assoc).

%
dcg_d((.), [A|B], B, [A]).
dcg_d([A], [A|B], B, [A]).
dcg_d({G},  A,    A, {G}).
dcg_d(X, A, B, X0):-  pac:complete_args(X, [A, B], X0).


% ?- coa:am_determine([1-[a-1]], 1, D, R).
%@ D = [[1]-[a-[1]]],
%@ R = [1].
% ?- coa:am_determine([1-[a-1, a-2], 2-[[]]], 1, D, R).
%@ D = [[1]-[a-[1, 2]], [1, 2]-[[], a-[1, 2]]],
%@ R = [1] 
% ?-  coa:am_determine(coa([1-[a-1, a-2], 2-[[]]], 1), D).
%@ D = coa([1-[a-2], 2-[[], a-2]], 1) .

am_determine(coa(E, I), D):- am_determine(E, I, E0, I0),
	am_fresh(coa(E0, I0), D0),
	am_clean(D0, D).

am_determine(E, I, D, [I]):-  am_determine([[I]], [], E, D, []).

am_determine([], _, _, P, P).
am_determine([S|R], H, E, P, Q):-  memberchk(S, H), !, 
	am_determine(R, H, E, P, Q).
am_determine([S|R], H, E, [S-C|P], Q):- 
	expand_power_state(S, E, C, R0, R),
	am_determine(R0, [S|H], E, P, Q).

%
am_slim(coa(E, I), coa(D, I)):- am_slim([I], [], E, D, []).

am_slim([], _, _, P, P).
am_slim([S|R], H, E, P, Q):-  memberchk(S, H), !, 
	am_slim(R, H, E, P, Q).
am_slim([I|A], H, E, [I-U|P], Q):- once(select(I-U, E, E0)), 
	am_slim(U, A, [I|H], E0, P, Q). 

%
am_slim([], A, H, E, P, Q):- !, am_slim(A, H, E, P, Q).
am_slim([[]|R], A, H, E, P, Q):- !, am_slim(R, A, H, E, P, Q).
am_slim([_-G|R], A, H, E, P, Q):- !, am_slim(R, [G|A], H, E, P, Q).

%
% ?- coa:expand_power_state([x,y], [x-[a-2, b-3], y-[a-2, b-4, c-5]], R, A, []).
%@ R = [a-[2], b-[3, 4], c-[5]],
%@ A = [[2], [3, 4], [5]] .

expand_power_state(S, E, Coa, P, Q):- 
	foldl(pred(E, ([K, L, M]  :-  
		      memberchk(K-B, E), 
		      foldl(pred([X, U, [X|U]]), B, L, M))),
		   S, [], Pairs0),
	sort(Pairs0, Pairs),
	merge_pairs(Pairs, Coa, [], P, Q).


% ?-coa:is_deterministic(coa([1-[a-1, b-1]], _)).
%@ true.
% ?-coa:is_deterministic(coa([1-[a-1, a-1]], _)).
%@ false.

is_deterministic(coa(E, _)):- is_deterministic(E).

%
is_deterministic([]).
is_deterministic([_-A|_]):- consecutive_same_key(A), !, fail.
is_deterministic([_|R]):- is_deterministic(R).

%
consecutive_same_key([A-_, A-_|_]):-!.
consecutive_same_key([_, A|B]):- consecutive_same_key([A|B]).

	
%%% automata state minimization 

% ?-  word:regex_coalgebra(".*****",  X).
%@ X = coa([1-[[], dot([inf-sup])-1]], 1, [1]).
% ?- word:am_minimum([2-[[], (inf-sup)-3], 3-[[], (inf-sup)-3]], 2, R).
%@ R = coa([1-[[], dot([inf-sup])-1]], 1, [1]) .

% ?- coa:am_minimum([1-[[inf-sup]-1]], Q).
%@ Q = [[1]-1] .
% ?- coa:am_minimum([1-[(a-b)-1, (b-c)-2], 2-[[]]], Q).
% ?-trace,  E= [1-[(inf-sup)-1]], word:ya_am_minimum(E, Q), word:ya_quotient_coa(E, Q, E0), word:am_normal(E0, E1).
% ?-trace,  E= [2-[(inf-sup)-3], 3-[[]]], word:ya_am_minimum(E, Q), word:ya_quotient_coa(E, Q, E0), word:am_normal(E0, E1).
%@    Call: (8) _G1418=[2-[inf-sup-3], 3-[[]]] ? no debug
%@ E = [2-[inf-sup-3], 3-[[]]],
%@ Q = [[2]-1, [3]-2],
%@ E0 = E1, E1 = [1-[inf-sup-2], 2-[[]]] ;

% ?- coa:am_minimum(coa([1-[a-2, b-1], 2-[a-1, b-2], 3-[a-3, b-1]],  1), D).
%@ D = coa([1-[[a, b]-1]], 1) .


am_minimum(coa(E,I), C):- am_minimum(E, I, C).

am_minimum(E, I, coa(E3, J)):-  minimum_am_qmap(E, Qmap),
	(	Qmap == []
	->	E3 = E,
		J  = I
	; 	member(X-I0,  Qmap),
		memberchk(I, X),
		quotient_coa(E, Qmap, E1), 
		am_clean(coa(E1, I0), coa(E2, J)),
		sort(E2, E3)
	).

%@@@ 
minimum_am_qmap(Coa, Qmap):-  
	am_conflict_pairs(Coa, Conflicts),
	sort(Conflicts, CSorted),
	pairs_to_assoc(CSorted, Inicon, []),
	all_states(Coa, All),
	assoc_product(All, All, Prod, []),
	assoc_subtract(Prod, Inicon, Rel),
	maplist([I, [I]], All, Singletons),
	union_find(Rel, Singletons, Clusters),  
	(	Clusters == []
	->	Qmap = []
	;	length(Clusters, N),
		numlist(1, N, S),
		zip_hyphen(Clusters, S, Qmap)
	).	


%
quotient_coa(Eqs, Qmap, Eqs0) :-
	maplist(Qmap^[S-L, S0-L0]:-
		(	member(Cluster-S0, Qmap),
			memberchk(S, Cluster),
			maplist(pred(Qmap,
					[[],[]]
				    &
					([A-G, A-G0]:-
						(member(GCluster-G0, Qmap),
						 memberchk(G, GCluster)))
				    ), L, L1 ),
			predsort(compare_right, L1, L0)
		), Eqs, Eqs0).


%
am_normal(coa([], _), C):- !, am_empty(C).
am_normal(coa(A,I), coa(B, I)):-  sort(A, C), am_normal(C, B, []).

%
am_normal([], P, P).
am_normal([I-A|R], [I-B|P], Q):- 
	am_normal(I, R, R0, As, []),
	append([A|As], H),
	sort(H, G),
	am_normal_body(G, B),
	am_normal(R0, P,  Q).	

am_normal_body([], []).
am_normal_body([[]|G], [[]|B]) :- !, am_normal_body(G, B).
am_normal_body(G, B) :-  keysort_right(G, G0), 
	join_char(G0, B0), 
	maplist([I-X, J-X] :- iboole:i_normal(I, J), B0, B).

%
am_normal(I, [I-A|R], R0, [A|P], Q):- !, am_normal(I, R, R0, P, Q).
am_normal(_, R, R, P, P).

%
compare_right(=, [], []).
compare_right(<, [], _).
compare_right(>, _, []).
compare_right(C, X-Y, Z-Y):- !, compare(C, X, Z).
compare_right(C, _-X, _-Y):-  compare(C, X, Y).

% ?- coa:merge_pairs([a-2, a-3, a-2,  b-1, b-3, c-2], R, [], S, []).
%@ R = [a-[2, 3], b-[1, 3], c-[2]],
%@ S = [[2, 3], [1, 3], [2]].

merge_pairs([], D, D, A, A).
merge_pairs([[]|Cs], [[]|D0], D, A0, A):- !, 
	merge_pairs(Cs, D0, D, A0, A).
merge_pairs([I-X|Cs], [I-Pow|D0], D, [Pow|A0], A):- 
	power_state(I, Cs, Cs0, Pow0, []), 
	sort([X|Pow0], Pow),
	merge_pairs(Cs0, D0, D, A0, A).

%
power_state(I, [I-G|R], R0, [G|P], Q):- !, 
	power_state(I, R, R0, P, Q).
power_state(_, A, A, B, B).

% ?- coa:join_char_interval([], []).
% ?- trace, coa:join_char_interval([(3-4)-t], R).
%@ R = [[3-4]-t] .
% ?- trace, coa:join_char_interval([(inf-4)-t, (5-sup)-t], R).
%@ R = [[inf-sup]-t] .
% ?-coa:join_char_interval([(10-sup)-t, (20-20)-s, (inf-4)-t], R).
%@ R = [[20-20]-s, [10-sup, inf-4]-t].

keysort_right(X,Y):- predsort(pred(	[=, [], []]
				   & 	[<, [], _]
				   &	[>, _, []]
				   &    ([C, _-U, _-V]
					:-U @> V, C=(>); C=(<))), 
			      X, Y).

join_char_interval(A, B):- keysort_right(A, A0), join_char(A0, B).

%
join_char([], []).
join_char([[]|R], [[]|S]):- join_char(R, S).
join_char([X-A|R], [[X|Xs]-A|S]):- 
	join_char(A, R, Xs, R0),
	join_char(R0, S).

%
join_char(_, [], [], []):- !.
join_char(A, [X-A|R], [X|Xs], S):- !, 
	join_char(A, R, Xs, S).
join_char(_, R, [], R).


% ?- coa:merge_target([a-1], R, []).
%@ R = [a-[1]].
% ?- coa:merge_target([a-1, a-2], R, []).
%@ R = [a-[1, 2]] .
% ?- coa:merge_target([a-1, a-2, b-3], R, []).
%@ R = [a-[1, 2], b-[3]] .
% ?- coa:merge_target([[], a-1, a-2, b-3], R, []).
%@ R = [[], a-[1, 2], b-[3]] .
% ?- coa:merge_target([[], a-1,  b-3, a-2], R).
%@ R = [[], a-[1, 2], b-[3]] .

merge_target(X, Y):- sort(X, X0), merge_target(X0, Y, []).

merge_target([], P, P).
merge_target([[]|R], [[]|P], Q):- merge_target(R, P, Q).
merge_target([I-X|R], [I-Xs|P], Q):-
	merge_target(I, R, R0, [X], Xs),
	merge_target(R0, P, Q).

%
merge_target(I, [I-X|R], R0, P, Q):- contract_insert(X, P, P0),
	merge_target(I, R, R0, P0, Q).
merge_target(_, R, R, P, P).

% ?- union_find([a-b,x-y, x-x, y-z, b-c], [], R).
% ?- union_find([a-b,x-y, x-x, y-z, b-c], [], R).

union_find([], X, X).
union_find([X-Ys|R],C,D):-union_find(Ys, X, C,C1),
	union_find(R,C1,D).

union_find([], _, P, P).
union_find([Y|Ys], X, P, Q):- union_find_one(X, Y, P, P0),
	union_find(Ys, X, P0, Q).

union_find_one(X,Y,Z,U):-find_cluster(X,Z,C,Z0),
	(memberchk(Y, C) -> U=[C|Z0]
	; find_cluster(Y, Z0, C0, Z1),
	  append(C,C0, C1),
	  U=[C1|Z1]
	).


% ?- coa:find_cluster(a, [[a,b],[c,d]], C, X).

find_cluster(X,[],[X],[]):-!.
find_cluster(X,[Y|Z],Y,Z):- memberchk(X,Y),!.
find_cluster(X,[Y|Z],U,[Y|V]):- find_cluster(X,Z,U,V).

% Reversing coalgebra
% ?- coa:am_reverse([a-[b-c], d-[b-c], e-[b-c], x-[y-z]], R).
%@ R = [c-[b-[a, d, e]], z-[y-[x]]] .
% ?- coa:am_reverse([a-[b-c], d-[b-c], e-[m-c], x-[y-z]], R).
%@ R = [c-[b-[a, d], m-[e]], z-[y-[x]]] .
% ?- coa:am_reverse([a-[[], b-c, d-e, e-c], x-[y-z]], R).
%@ R = [c-[b-[a], e-[a]], e-[d-[a]], z-[y-[x]]] .
% ?- coa:am_reverse([a-[d-e, e-c], x-[y-z]], R).
%@ R = [c-[e-[a]], e-[d-[a]], z-[y-[x]]] .
% ?- coa:am_reverse([1-[a-1]], R).
%@ R = [1-[a-[1]]] .
% ?- coa:am_reverse([], X).
%@ X = [].

am_reverse(X, Y):- 
	maplist(pred([I-As, B]:- 
			foldr(pred(I, (	  [  C-J, [(J-(C-I))|W], W]	
					& [  [] ,  W,		 W] )
				  ),	As, B, [])
		    ),	X, X0 ),
	append(X0, X1),
	triples_to_coa(X1, Y).

%?- coa:triples_to_coa([1-(a-4), 3-(c-3), 2-(b-1), 1-(a-2)], R).
%@ R = [1-[a-[2, 4]], 2-[b-[1]], 3-[c-[3]]].

triples_to_coa(X, Y):-sort(X, X0),
	pairs_to_assoc(X0, Assoc, []),
	maplist(pred([I-U, I-V]:- pairs_to_assoc(U, V, [])), 
		Assoc, Y).

%
am_to_reversed_dag(E, D):- am_to_reversed_dag(E, [], Ps),
	sort(Ps, Ps0),
	pairs_to_assoc(Ps0, D, []).

am_to_reversed_dag([], X, X).
am_to_reversed_dag([I-A|R], X, Y):- am_to_reversed_dag(A, I, X, X0),
	am_to_reversed_dag(R, X0, Y).

am_to_reversed_dag([], _, X, X).
am_to_reversed_dag([[]|R], I, X, Y):-  am_to_reversed_dag(R, I, X, Y).
am_to_reversed_dag([_-G|R], I, X, Y):- am_to_reversed_dag(R, I, [G-I|X], Y).


% ?- trace, coa:fiber_product_basic([a-[b,c]], [a-[1,2]], [], P).
%%@ P = [2-c, 1-c, 2-c, 1-c, 2-b, 1-b] .
% ?- coa:am_conflict_pairs([a-[[],1-a], b-[1-b]], S).
%@ S = [a-b] .
% ?- coa:am_conflict_pairs([a-[[],1-a], b-[1-b], c-[[],1-a]], S).
%@ S = [b-c, a-b] .
% ?- trace,  coa:am_conflict_pairs([a-[1-a], b-[1-b]], S).
% ?- trace,  coa:am_conflict_pairs([a-[[]], b-[[]]], S).

% am_conflict_pairs(Coa, S):- 
% 	am_arity_dict(Coa, Dict),
% 	arity_conflict_pairs(Dict, IniCon, []),
% 	sort(IniCon, IniCon0),
% 	pairs_to_assoc(IniCon0, IniCon1, []),
% 	am_reverse(Coa, RCoa),
% 	propagate_conflict(IniCon1, RCoa, [], S).

am_conflict_pairs(Coa, S):- 
	am_arity_dict(Coa, Dict),
	arity_conflict_pairs(Dict, IniCon, []),
	sort(IniCon, IniCon0),
%	pairs_to_assoc(IniCon0, IniCon1, []),
	am_reverse(Coa, RCoa),
	propagate_conflict(IniCon0, RCoa, [], S).

% by agenda programming
propagate_conflict([], _, P, P).
propagate_conflict([U|R], Coa, P, Q):- memberchk(U, P), !,
	propagate_conflict(R, Coa, P, Q).
propagate_conflict([I-J|R], Coa, P, Q):-  memberchk(I-A, Coa),
	memberchk(J-B, Coa), !,
	fiber_product(A, B, F),
	append(F, R, R0),
	propagate_conflict(R0, Coa, [I-J|P], Q).
propagate_conflict([U|R], Coa, P, Q):-  
	propagate_conflict(R, Coa, [U|P], Q).



% ?- coa:fiber_product([a-[7,8,9], b-[1,2,3]], [a-[6,7,8], b-[1,2,3]],  P).
%@ P = [1-2, 1-3, 2-3, 6-7, 6-8, 6-9, 7-8, 7-9, 8-9] .

fiber_product(A, B, P):- fiber_product(A, B, [], P0),
	sort(P0, P).

fiber_product([], _,  P, P).
fiber_product([X|Y], N,  P, Q):-
	fiber_product_one(X, N, P, R),
	fiber_product(Y, N, R, Q).

fiber_product_one([], _, P, P).
fiber_product_one(_, [], P, P).
fiber_product_one(X, [Y|Z], P, Q):-
	fiber_product_one_one(X, Y, P, R),
	fiber_product_one(X, Z, R, Q).

fiber_product_one_one(_, [], P, P).
fiber_product_one_one(A-G, A-H, P, Q):- !,
	s_product(G, H, P, Q).
fiber_product_one_one(_, _, P, P).


% ?- coa:pairs_to_assoc([1-2, 1-3, 2-3, 2-4], X, []).
%@ X = [1-[2, 3], 2-[3, 4]].
pairs_to_assoc([], X, X).
pairs_to_assoc([I-A|R], [I-As|V], V0):- 
	pairs_to_assoc(I, R, R0, [A], As),
	pairs_to_assoc(R0, V, V0).

%
pairs_to_assoc(I, [I-A|R], R0,  S, T):-!,
	contract_insert(A, S, S0),
	pairs_to_assoc(I, R, R0, S0, T).
pairs_to_assoc(_, R, R,  S, S).

% ?- coa:assoc_to_pairs([1-[2,3], 2-[3,4]], R, []).
%@ R = [1-2, 1-3, 2-3, 2-4].

assoc_to_pairs([], P, P).
assoc_to_pairs([I-Vs|A], P, Q):- assoc_to_pairs(I, Vs, P, P0),
	assoc_to_pairs(A, P0, Q).

assoc_to_pairs(_, [], P, P):- !.
assoc_to_pairs(I, [X|Xs], [I-X|P], Q):- 
	assoc_to_pairs(I, Xs, P, Q). 
	
% ?- coa:contract_merge([1,3,6], [2, 5, 7], R).
%@ R = [1, 2, 3, 5, 6, 7].

%  Remark.
% ?- union([1,3,6], [2, 5, 7], R).
%@ R = [1, 3, 6, 2, 5, 7].
% ?- union([1,3,6], [2, 3,  5, 7], R).
%@ R = [1, 6, 2, 3, 5, 7].

contract_merge([], X, X):-!.
contract_merge(X, [], X):-!.
contract_merge([X|R], [X|S], [X|T]):- !, contract_merge(R, S, T).
contract_merge([X|R], [Y|S], [X|T]):- X@<Y, !, contract_merge(R, [Y|S], T).
contract_merge([X|R], [Y|S], [Y|T]):- contract_merge([X|R], S, T).

% ?- coa:contract_insert(3, [2, 5, 7], R).
%@ R = [2, 3, 5, 7].

contract_insert(X, [], [X]):-!.
contract_insert(X, [X|S], [X|S]):- !.
contract_insert(X, [Y|S], [X, Y|S]):- X@<Y, !.
contract_insert(X, [Y|S], [Y|R]):- contract_insert(X, S, R).

% ?- coa:final_states([1-[[],a-b], 2-[c-d]], R).
%@ R = [1].

all_states(X, S):- maplist([A-_, A], X, S0), sort(S0, S).
%
arity(X, Y):- maplist(pred([[], []] & [A-_, A]), X, Y0), sort(Y0, Y).

am_arity_dict(Coa, Dict):- maplist([I-X, I-M]:- arity(X, M), Coa, Dict).

% ?- coa:arity_conflict_pairs([1-a, 2-b, 3-a, 4-b], A, []).
%@ A = [1-2, 1-4, 2-3, 3-4] .

arity_conflict_pairs([], A, A).
arity_conflict_pairs([I-A|As], P, Q):- arity_conflict_pairs(I, A, As, P, P0),
	arity_conflict_pairs(As, P0, Q).

%
arity_conflict_pairs(_, _, [], P, P).
arity_conflict_pairs(I, A, [J-B|Bs], [I-J|P], Q):- A\==B, !, 
	arity_conflict_pairs(I, A, Bs, P, Q).
arity_conflict_pairs(I, A, [_|Bs], P, Q):- 
	arity_conflict_pairs(I, A, Bs, P, Q).


% ?-coa:s_product([1,2,3],[1,2,3], P).
%@ P = [1-2, 1-3, 2-3] .

s_product(X, Y, P):- s_product(X, Y, [], Q), sort(Q, P).

s_product([], _, P, P).
s_product([X|Xs], Y, P, Q):-
	s_product(X, Xs, Y, P, R),
	s_product(Xs, Y, R, Q).

s_product(X, Xs, Y, P, Q):-
	foldl(pred(X,	([A, L, L]:- A==X, !) &
			([A, L, [W|L]]:- s_pair(X, A, W))), Y, P, R),
	s_product(Xs, Y, R, Q).


% ?- trace, coa:assoc_product([1,2,3], [1,2,3], R, []).
%@ R = [1-[2, 3], 2-[3]] .

assoc_product([], _, P, P).
assoc_product(_, [], P, P).
assoc_product([X|Xs], [Y|Ys], [X-[Y|Ys]|P], Q):- Y@>X, !, 
	assoc_product(Xs, [Y|Ys], P, Q).
assoc_product(Xs, [_|Ys], P, Q):-assoc_product(Xs, Ys, P, Q).

%  subtraction on assoc lists.
% ?- coa:assoc_subtract([1-[2,3,4], 2-[3,4], 3-[4,5,6]], [1-[3], 2-[4], 5-[6,7,8]], R).
%@ R = [1-[2, 4], 2-[3], 3-[4, 5, 6]] .

assoc_subtract([], _, []).
assoc_subtract(A, [], A).
assoc_subtract([I-A|Ps], [I-B|Qs], R):-  !, ord_subtract(A, B, C),
	(	C == []
	->      R = Rs
	;	R = [I-C|Rs]
	),
	assoc_subtract(Ps, Qs, Rs).
assoc_subtract([I-A|Ps], [J-B|Qs], [I-A|Rs]):-  I@<J, !, 
	assoc_subtract(Ps,[J-B|Qs], Rs).
assoc_subtract([I-A|Ps], [_|Qs], [I-A|Rs]):-  
	assoc_subtract(Ps, Qs, Rs).

% ?-coa:assoc_complement([1,2,3], [1-[2], 2-[3]], R).
%@ R = [1-[3]] .
%@ R = [1-[3]] .

assoc_complement(A, C, D):- assoc_product(A, A, AConf, []), 
	assoc_subtract(AConf, C, D).

%
s_pair(A, B, A-B):- A @< B, !.
s_pair(A, B, B-A).

%
expand_dot_list([A], X, P):-!, expand_dot(A, X, P).
expand_dot_list([A, B], X, P):- expand_dot_adhoc(A, B, X, P), !.
expand_dot_list([I|Is], X, P; Ps):- expand_dot(I, X, P), 
	expand_dot_list(Is, X, Ps).

% Ad hoc code optimization. Shoud be revised.  !!
% expand_dot_adhoc(inf-A, B-sup, X, X\==C):-  integer(A), integer(B), !, 
% 	B  is A + 2, 
% 	C  is A + 1.

expand_dot_adhoc(inf-A, B-sup, X, X\==C):- B  is A + 2, !, 
	C  is A + 1.

%
expand_dot(A,	X,	X==A ):- atomic(A).
expand_dot(A-A, X,	P ):- expand_dot(A, X, P).
expand_dot(inf-sup, _,	true ).
expand_dot(inf-A, X,	X @=< A ).
expand_dot(A-sup, X,	A @=< X ).
expand_dot(A-B,	  X,	(A @=< X, X @=< B) ).

%
am_char([], coa([1-[[]]], 1)):-!.
am_char(Is, coa([1-[[]|G], 2-[[]]], 1)):- maplist([I, I-2], Is, G).

am_char_simple([], coa([1-[[]]], 1)):-!.
am_char_simple(Is, coa([1 - G, 2-[[]]], 1)):- maplist([I, I-2], Is, G).


% digraph traversal by Agenda Programming. 
%
am_cap(coa(E0, I0), coa(E1, I1), Coa):- 
	am_cap([I0*I1], [], E0, E1, [], E2),
	am_fresh(coa(E2, I0*I1), Coa0),
	am_minimum(Coa0, Coa).

%
am_cap([], _, _, _,  P, P).
am_cap([U|R], H, A, B, P0, P):- memberchk(U, H), !,
	am_cap(R, H, A, B, P0, P).
am_cap([I*J|R], H, A, B,  P0, P):- memberchk(I-GI, A), 
	memberchk(J-GJ, B),
	product_cap(GI, GJ, R0, R, Q, []),
	am_cap(R0, [I*J|H], A, B, [I*J-Q|P0], P).

%
product_cap([], _, R, R, Q, Q).
product_cap(_, [], R, R, Q, Q).
product_cap([[]|G], [[]|H], R0, R, [[]|Q0], Q):-!, 
	product_cap(G, H, R0, R, Q0, Q).
product_cap([[]|G], H, R0, R, Q0, Q):-!, 
	product_cap(G, H, R0, R, Q0, Q).
product_cap(G, [[]|H], R0, R, Q0, Q):-!, 
	product_cap(G, H, R0, R, Q0, Q).
product_cap([U-I|G], [U-J|H], [I*J|R0], R, [U-I*J|Q0], Q):-!,  
	product_cap(G, H, R0, R, Q0, Q).
product_cap([U-_|G], [V-I|H], R0, R, Q0, Q):- U@<V, !, 
	product_cap(G, [V-I|H], R0, R, Q0, Q).
product_cap([U-I|G], [_|H], R0, R, Q0, Q):- 
	product_cap([U-I|G], H, R0, R, Q0, Q).

%
am_minus(coa(E0,I0), coa(E1, I1), Coa):- 
	am_minus([I0*I1], [], E0, E1, [], E2),
	append(E0, E2, E3), 
	am_determine(coa(E3, I0*I1), NCoa),
	am_minimum(NCoa, Coa).

% 
am_minus([], _, _, _,  P, P).
am_minus([U|R], H, A, B, P0, P):- memberchk(U, H), !,
	am_minus(R, H, A, B, P0, P).
am_minus([I*J|R], H, A, B,  P0, P):- memberchk(I-GI, A), 
	memberchk(J-GJ, B),
	product_minus(GI, GJ, R0, R, Q, []),
	am_minus(R0, [I*J|H], A, B, [I*J-Q|P0], P).

%
product_minus([], _, R, R, Q, Q).
product_minus([W|G], [], R0, R, [W|P], Q):- 
	product_minus(G, [], R0, R, P, Q). 
product_minus([[]|G], [[]|H], R0, R, Q0, Q):-!, 
	product_minus(G, H, R0, R, Q0, Q).
product_minus([[]|G], H, R0, R, [[]|Q0], Q):-!, 
	product_minus(G, H, R0, R, Q0, Q).
product_minus(G, [[]|H], R0, R, Q0, Q):-!, 
	product_minus(G, H, R0, R, Q0, Q).
product_minus([U-I|G], [U-J|H], [I*J|R0], R, [U-I*J|Q0], Q):-!,  
	product_minus(G, H, R0, R, Q0, Q).
product_minus([U-I|G], [V-I|H], R0, R, [U-I|Q0], Q):- U@<V, !, 
	product_minus(G, [V-I|H], R0, R, Q0, Q).
product_minus([U-I|G], [_|H], R0, R, Q0, Q):- 
	product_minus([U-I|G], H, R0, R, Q0, Q).

%
am_cup(coa(A,I), Coa0,  Coa):- 
	length(A, N),
	am_shift(N, Coa0, coa(C, K)),
	append(A, C, D), 
	am_determine([[I,K]], [], D,  E, []),
	am_fresh(coa(E, [I,K]), Coa1),
	am_minimum(Coa1, Coa).
	
% ?- trace, coa:am_concat(coa([1-[[], a-2], 2-[[]]],1),  coa([1-[a-2], 2-[[]]],1), R). 
%@ R = coa([1-[a-4, a-2], 2-[a-4], 3-[a-4], 4-[[]]], 1) .

% ?- coa:am_concat(coa([1-[[], a-1]],1),  coa([1-[[], b-1]],1), R).
%@ R = coa([1-[[], b-2, a-1], 2-[[], b-2]], 1) .

am_concat(coa(E0, I0), Coa1, Coa):-
	length(E0, N),
	am_shift(N, Coa1, coa(E3, I3)),
	memberchk(I3-G, E3), 
	maplist(am_replace_null(G), E0, E1),
	append(E1, E3, E4),
	am_slim(coa(E4,I0), E5),
	am_determine(E5, E),
	am_minimum(E, Coa).

%
am_repeat(0, _, coa([1-[[]]], 1)):-!.
am_repeat(N, E, Coa):- am_repeat(N, E, E, Coa).

%
am_repeat(1, _, C, C).
am_repeat(N, E, C, C0):- N>1, 
	am_concat(E, C, C1),
	N0 is N-1,
	am_repeat(N0, E, C1, C0).

% 
am_unit(coa([1-[[]]], 1)).
%
am_empty(coa([], 0)).
%
am_repeat_upto(1, _, U):- am_unit(U).  
am_repeat_upto(N, E, Coa):- N>1, 
	am_unit(U),
	N0 is N-1, 
	am_repeat_upto(N0, E, U, Coa).

%
am_repeat_upto(0, _, C, C).
am_repeat_upto(N, E, C, C0):- N>0, 
	am_concat(C, E, C1), 
	am_unit(U),
	am_cup(C1, U, C2),
	N0 is N-1,
	am_repeat_upto(N0, E, C2, C0).

% ?- coa:am_shift(3, coa([1-[a-2, b-3]],1), R).
%@ R = coa([4-[a-5, b-6]], 4).

am_shift(N, coa(E,I), coa(E0, I0)):- 
	I0 is I+N,
	maplist(state_id_shift(N), E, E0).
	
%
state_id_shift(N, I-A, J-B):- J is I + N,
	maplist(goto_id_shift(N), A, B).

%
goto_id_shift(_, [],[]).
goto_id_shift(N, A-I, A-J):- J is I+N.

%  ?- coa:am_replace_null([a-2], 2-[[]], X).
am_replace_null(A, I-[[]|B], I-C):- !,  ord_union(A, B, C).
am_replace_null(_, P, P).

% ?- coa:am_minimum(coa([1-[a-2, a-3, b-3], 2-[b-3], 3-[a-1]], 1), R).
% ?- coa:am_plus(coa([1-[a-2], 2-[[]]], 1), R).
% ?- coa:am_star(coa([1-[a-2], 2-[[]]], 1), R).
% ?- coa:am_star(coa([1-[a-2, b-3], 3-[[]], 2-[[]]], 1), R).
% ?- coa:am_star(coa([1-[a-2, a-3, b-3], 3-[[]], 2-[[]]], 1), R).
% ?- coa:am_star(coa([1-[a-2], 2-[[]]], 1), R).
%@ R = coa([1-[[], a-1]], 1) .
% ?- coa:am_star(coa([1-[a-2, b-2], 2-[[]]], 1), R). 
%@ R = coa([1-[[], a-1, b-1]], 1) .
% ?- coa:am_plus(coa([1-[a-2, b-2], 2-[[]]], 1), R). 
%@ R = coa([1-[a-2, b-2], 2-[[], a-2, b-2]], 1) .
% ?- coa:am_copy(coa([1-[a-2], 2-[[]]], 1), D).

am_kleene(coa(E, I), Coa):- 
	once(select(I-R, E, E0)),
	drop_null(R, NR),
	maplist(am_replace_null([[]|NR]), E0, E1),
 	am_determine(coa([I-R|E1], I), Coa).

%
am_star(C, D):- am_kleene(C, coa(E0, I)), 
	once(select(I-R0, E0, E)),
	(	R0=[[]|_]
	->	R = R0
	;	R = [[]|R0]
	),
	am_minimum(coa([I-R|E], I), D).

%
am_plus(X, Y):- am_kleene(X, Z), am_minimum(Z, Y).

%
am_fresh(coa([], _), C):- !, am_empty(C).
am_fresh(coa(E, I), coa(E0, I0)):- 
	length(E, L),
	numlist(1, L, Ns),
	zip_hyphen(M, _, E),
	zip_hyphen(M, Ns, S),
	subst_coa(E, S, E0),
	memberchk(I-I0, S).

am_fresh(Coa0, coa(E0, _), Coa):-  length(E0, N), am_shift(N, Coa0, Coa).
am_fresh(Coa0, coa(E0, _), Coa):-  length(E0, N), am_shift(N, Coa0, Coa).

%
am_size(coa(E, _), N):- length(E, N).

am_initial_state(coa(_, I), I).

am_equations(coa(E, _), E).

% ?- coa:am_finals(coa([1-[[]], 2-[a-3], 3-[[]]], 1), R).
%@ R = [1, 3] .
am_finals(coa(E, _), A):- 
	foldl(pred(	[I-[[]|_], [I|U], U]
		  &	[_, U, U]	
		  ), E, A, []).

%  ?- coa:am_states(coa([1-[[]], 2-[a-3], 3-[[]]], 1), R).
%@ R = [1, 2, 3].
am_states(coa(E, _), A):- maplist([I-_, I], E, A).

am_copy(C,  D):-  C = coa(E0, _),
	length(E0, N),
	am_shift(N, C, D).
%
am_clean(coa(E, I),  coa(D, I)):- 
	maplist([I-A, I-B]:- sort(A, B),  E, E0),
	sort(E0, D).

%
drop_null([[]|A], A):- !.
drop_null(A, A).

%
add_one(X, Y, Z):-  ( memberchk(X, Y)  ->  Z=Y ;   Z = [X|Y]).

% ?-coa:subst_coa([1-[b-2]], [1-9, 2-10], X).
%@ X = [9-[b-10]].
% ?-coa:subst_coa([1-[[], b-2]], [1-9, 2-10], X).
%@ X = [9-[[], b-10]].

% ?- coa:am_remove_useless_states(coa([1-[[], a-1, a-2], 2-[b-3], 3-[c-3]], 1), R).
%@ R = coa([1-[[], a-1]], 1) .

am_remove_useless_states(coa(E, I), coa(E0, I)):- 
	am_live_dead(coa(E,I), _, Dead),
	am_remove_states(E, Dead, E0).

am_live_dead(Coa, Live, Dead):- am_finals(Coa, Fs),
	am_equations(Coa, E),
	am_to_reversed_dag(E, Assoc),
	dg_path_find(Fs, Assoc,  [], Live, Dead).

% ?- coa:dg_path_find([], [1-[2], 2-[1]], [], X, Y).
%@ X = [],
%@ Y = [1, 2].
% ?- coa:dg_path_find([1], [1-[2], 2-[1], 3-[1,2]], [], X, Y).
%@ X = [2, 1],
%@ Y = [3].

dg_path_find([], E, Live, Live, Dead):- !, maplist([I-_, I], E, Dead).
dg_path_find([X|R], E,  Z,  Live, Dead):- memberchk(X, Z), !,
	dg_path_find(R, E, Z, Live, Dead).
dg_path_find([X|R], E, Z, Live, Dead):- select(X-G, E, E0), !,
	union(G, R, R0),
	dg_path_find(R0, E0, [X|Z], Live, Dead).
dg_path_find([X|R], E, Z, Live, Dead):- dg_path_find(R, E, [X|Z], Live, Dead).

% ?- trace, coa:am_connected_region(coa([1-[[]]], 1), C).
%@ C = coa([1-[[]]], 1) .
% ?- trace, coa:am_connected_region(coa([1-[[], a-2], 2-[[]], 3-[a-3]], 1), C).
%@ C = coa([1-[[], a-2], 2-[[]]], 1) .
% ?- trace, coa:am_connected_region(coa([1-[[], a-2], 2-[[]], 3-[a-3]], 1), C).

am_connected_region(coa(E, I), coa(E0, I)):- am_path_find([I], [], E, E0, []). 

%
am_path_find([],_H, _E, R, R).
am_path_find(_, _H, [],  R, R).
am_path_find([X|R], H, STS,  E0, E1):- memberchk(X, H), !,
	am_path_find(R, [X|H], STS, E0, E1).
am_path_find([X|R], H, STS,  [X-G|E0], E1) :- select(X-G, STS, STS0), !,
	am_path_find_next(G, R0, R), 
	am_path_find(R0, [X|H], STS0, E0, E1).
am_path_find([X|R], H, STS,  [X|E0], E1) :- am_path_find(R, [X|H], STS, E0, E1).

%
am_path_find_next([], X, X).
am_path_find_next([[]|R], X, Y):- am_path_find_next(R, X, Y).
am_path_find_next([_-G|R], [G|X], Y):- am_path_find_next(R, X, Y).

% naive method.

% ?- coa:am_remove_empty_states(coa([], 1), C).
%@ C = coa([], 1).
%@ C = coa([], 1).
% ?- trace, coa:am_remove_empty_states(coa([1-[[],a-2], 2-[]], 1), C).
%@ C = coa([1-[[]]], 1) .
% ?- trace, coa:am_remove_empty_states(coa([1-[[],a-2, a-3], 3-[b-2], 2-[]], 1),
%@ C = coa([1-[[]]], 1) .

am_remove_empty_states(coa(E, I), coa(E0,I)):-	am_elim_empty_states(E, E0).

%
am_elim_empty_states(E, E0):- am_elim_empty_states(E, S, [], E1, []), 
	(	S == []
	->	E0 = E1
	;   	am_elim_link(S, E1, E2),
		am_elim_empty_states(E2, E0)
	).

%
am_elim_empty_states([], X, X, Y, Y). 
am_elim_empty_states([I-[]|R], [I|X], X0, Y, Y0):- !,
	am_elim_empty_states(R, X, X0, Y, Y0).
am_elim_empty_states([U|R], X, X0, [U|Y], Y0):- 
	am_elim_empty_states(R, X, X0, Y, Y0).

%
am_elim_link([], E, E).
am_elim_link(Is, E, E0):- am_elim_link(Is, E, E0, []).

%
am_elim_link(_, [], E, E).
am_elim_link(Is, [I-A|R], [I-B|E], F):- elim_link_step(Is, A, B, []), !,
	am_elim_link(Is,  R, E, F).

%
elim_link_step(_,  [], X, X).
elim_link_step(Is, [[]|R], [[]|X], Y):- !, elim_link_step(Is, R, X, Y).
elim_link_step(Is, [_-S|R], X, Y):-  memberchk(S, Is), !, 
	elim_link_step(Is, R, X, Y).
elim_link_step(Is, [I-S|R], [I-S|X], Y):- elim_link_step(Is, R, X, Y).


% ?- coa:am_remove_states([1-[a-2,b-2]], [1,2], R).
%@ R = [].
% ?- coa:am_remove_states([1-[[],a-2,b-2], 2-[b-1]], [1], R).
%@ R = [2-[]].

am_remove_states([], _, []).
am_remove_states([I-_|R], Ds, E):- memberchk(I, Ds), !,
	am_remove_states(R, Ds, E).
am_remove_states([I-A|R], Ds, [I-B|E]):- am_remove_goto(A, Ds, B),
	am_remove_states(R, Ds, E).

%
am_remove_goto([], _, []).
am_remove_goto([[]|R], Ds, [[]|S]):- am_remove_goto(R, Ds, S).
am_remove_goto([_-G|R], Ds, S):- memberchk(G, Ds), !, 
	am_remove_goto(R, Ds, S).
am_remove_goto([U|R], Ds, [U|S]):- am_remove_goto(R, Ds, S).

%
subst_coa([], _, []).
subst_coa([I-G|R], S, [I0-G0|R0]):- memberchk(I-I0, S),
	subst_am_goto(G, S, G0),
	subst_coa(R, S, R0).

subst_am_goto([], _, []).      
subst_am_goto([[]|R], S, [[]| R0]):- !, subst_am_goto(R, S, R0).
subst_am_goto([A-I|R], S, [A-J|R0]):-  memberchk(I-J, S),
	subst_am_goto(R, S, R0).


%
i_type_assoc([	alnum-['0'-'9', 'A'-'Z', a-z],
		alpha-['A'-'Z', a-z],
		csym-['0'-'9', 'A'-'Z', '_', a-z],
		csymf-['A'-'Z', '_', a-z],
		digit-['0'-'9'],
		lower-[a-z],
		quote-['"', '\'', '`'],
		white-['\t', ' '],
		paren(')')-['('],
		paren(']')-['['],
		paren('}')-['{'],
		cntrl-['\000\'-'\037\', '\177\']    %'
		]).    

%
expand_coa(C, I, M, M:G, P, Q):-
	all_states(C, Nts),
	maplist([J, J-N]:- gensym('nt#', N), Nts, Assoc),
	memberchk(I-G, Assoc),
	coa_dcg(C, M, P0, [], Assoc),
	maplist(dcg_translate_rule_expand_dot, P0, P1),
	append(P1, Q, P).

%
expand_coa(C, I, A, B, M, M:G, P, Q):-
	all_states(C, Nts),
	maplist([J, J-N]:- gensym('nt#', N), Nts, Assoc),
	memberchk(I-G0, Assoc),
	G =..[G0, A, B],
	coa_dcg_d(C, M, P0, [], Assoc),
	maplist(dcg_translate_rule_expand_dot, P0, P1),
	append(P1, Q, P).

%
coa_dcg([], _, P, P, _).
coa_dcg([I-D|E], M, P, Q, Assoc):- coa_dcg(I, M, D, P, R, Assoc),
	coa_dcg(E, M,  R, Q, Assoc).

coa_dcg(_, _, [], P, P, _).
coa_dcg(I, M, [[]|R], [M:PI-->[]|P], Q, Assoc):-
	memberchk(I-PI, Assoc),
	coa_dcg(I, M, R, P, Q, Assoc).
coa_dcg(I, M, [A-J|R], [M:PI-->(A0, M:PJ)|P], Q, Assoc):-
	memberchk(I-PI, Assoc),
	memberchk(J-PJ, Assoc),
	(  A == (.),  A0=[_];
	   A0 = A  ),
	!,
	coa_dcg(I, M, R, P, Q, Assoc).

%  d means d-list version of coa_dcg 
coa_dcg_d([], _, P, P, _).
coa_dcg_d([I-D|E], M, P, Q, Assoc):- coa_dcg_d(I, M, D, P, R, Assoc),
	coa_dcg_d(E, M,  R, Q, Assoc).

coa_dcg_d(_, _, [], P, P, _).
coa_dcg_d(I, M, [[]|R], [M:PI-->[]|P], Q, Assoc):- memberchk(I-PI0, Assoc),
	PI=..[PI0, X, X],
	coa_dcg_d(I, M, R, P, Q, Assoc).
coa_dcg_d(I, M, [A-J|R], [M:PI-->(A0, M:PJ)|P], Q, Assoc):-
	memberchk(I-PI0, Assoc),
	memberchk(J-PJ0, Assoc),
	PI=..[PI0, U, V],
	dcg_d(A, U, W, A0),
	PJ=..[PJ0, W, V],
	coa_dcg_d(I, M, R, P, Q, Assoc).

% %
% dcg_d((.), [A|B], B, [A]).
% dcg_d([A], [A|B], B, [A]).
% dcg_d({G},  A,    A, {G}).
% dcg_d(X, A, B, X0):-  pac:complete_args(X, [A, B], X0).
%%%%
% ?- pac:parse_regex("a\\*",R).
%@ R = [a]+[*].
% ?- pac:parse_regex("a\\\*",R).  % <== intentional Syntex error
% ?- pac:parse_regex("a\\\\*",R).
% ?- pac:parse_regex("a\\\\\\*",R).
% ?- pac:parse_regex("[abc\\]]*",R).
% ?- pac:parse_regex("[abc\\\\]]*",R).
% ?- pac:parse_regex("a", R).
% ?- pac:parse_regex("(a)", R).
% ?- pac:parse_regex("(abc)", R).
% ?- pac:parse_regex("[abc]", R).
% ?- pac:parse_regex("[abc]*",R).
% ?- pac:parse_regex("[^abc]", R).
% ?- pac:parse_regex("(.*)", R).
% ?- pac:parse_regex("(a*)", R).
% ?- pac:parse_regex("a*b", R).
% ?- trace, pac:parse_regex(".", R).
% ?- pac:parse_regex("[^a-zA-Z]",R).
% ?- pac:parse_regex("a|b|c", R).
% ?- pac:parse_regex("(a|b|c)**", R).
% ?- pac:parse_regex("(\\(*[a]|1)",R).
% ?- pac:parse_regex("abc",R).
% ?- pac:parse_regex('abc',R).
% ?- pac:parse_regex("[a]",R).
% ?- pac:parse_regex("[ab]",R).
% ?- pac:parse_regex("[a-b]",R).


% parse_regex/2  never fails.

char_code_option(X, Y):- char_code(X, Y).

parse_regex(X, R):- regex(X, Y), paren_to_plus(Y, R).

regex(X, Y) :- is_list(X), !, once(regex_list(Y, [], X, [])).
regex(X, Y) :-  must_be(string, X),
	string_chars(X, X0),
	once(regex_list(Y, [], X0, [])).

%
regex([\(C)])	--> [(\)], [C].  % escape charcter
regex([(.)])	--> [(.)]. 
regex(G)	--> ['('],  regex_list(G,  []), [')'].
regex(out(D))	--> ['[', ^],  regex_dot(D0, []), {dot_hyphen(D0, D)}.
regex(dot(D))	--> ['['], regex_dot(D0, []), {dot_hyphen(D0, D)}.
regex({J,K})	--> ['{'], digits(J0), [','], digits(K0), ['}'],
	{	number_chars(J, J0),
		number_chars(K, K0)
	}.
regex([C])	--> [C0], {char_code_option(C0, C)}.  

%
digits([D|Ds]) --> [D0], {char_type(D0, digit), char_code_option(D0, D)}, 
	digits(Ds).
digits([]) --> [].

%
regex_list(L, L)  --> look_ahead(')').
regex_list(L0, L) --> regex(X), regex_list(X, L0, L).
regex_list(L, L)  --> [].

%
regex_list(X, L0, L) --> [*], regex_list(*(X), L0, L).
regex_list(X, L0, L) --> [#], regex_list(#(X), L0, L).
regex_list(X, L0, L) --> [+], regex_list(+(X), L0, L).
regex_list(X, L0, L) --> [?],  regex_list(?(X), L0, L).
regex_list(X, [(X|Y)|L0], L) --> ['|'], regex_list([Y|L0], L).
% regex_list(X, [(X;Y)|L0], L) --> ['|'], regex_list([Y|L0], L).
regex_list(X, L0, L) --> look_ahead('{'),
	regex( {J, K} ),
	{J =< K },
	regex_list(?(X,J,K), L0, L).
regex_list(X, [X|L0], L) --> regex_list(L0, L).

%
regex_dot([\(C)|Y], Z)	--> [\], [C], regex_dot(Y,Z).
regex_dot(X, X)		--> [']'].
regex_dot([C|Y], Z)	--> [C], regex_dot(Y,Z).

%
dot_hyphen([],[]).
dot_hyphen([X, -, Y|R], [C - D|S]):- !, drop_escape(X, X0),
	drop_escape(Y, Y0),
	char_code(X0, C),
	char_code(Y0, D),
	dot_hyphen(R, S).
dot_hyphen([X|R], [C|S]):- drop_escape(X, X0),
	char_code(X0, C),
	dot_hyphen(R, S).

%
drop_escape(\(X), X):-!.
drop_escape(X, X).

% Eliminating parenthesis which is used for grouping.
% ex.  [dot, dot([a,b]), [c, d]] => dot + dot([a,b]) + [c,d]
paren_to_plus(X, Y):- is_list(X), !, flatten(X, X0),
	delete(X0, [], X1),
	maplist(paren_to_plus, X1, X2),
	binary_term(+, X2, Y).
paren_to_plus(*(X), *(Y)):- !, paren_to_plus(X,  Y).
paren_to_plus(+(X), +(Y)):- !, paren_to_plus(X,  Y).
paren_to_plus(?(X), []|Y):- !, paren_to_plus(X,  Y).
paren_to_plus(?(X, N), Y):- !, paren_to_plus(X, X0),
	paren_to_plus(N, X0, Y).
paren_to_plus(?(X, J, K), Y):- !, paren_to_plus(X, X0),
	paren_to_plus(J, K, X0, Y).
paren_to_plus((X; Y), (X0; Y0)):- !, paren_to_plus(X, X0),
	paren_to_plus(Y, Y0).
paren_to_plus((X| Y), (X0| Y0)):- !, paren_to_plus(X, X0),
	paren_to_plus(Y, Y0).
paren_to_plus(\(X), [X]):- !.
paren_to_plus(X, X):- compound(X), !.
paren_to_plus((.), (.)).
paren_to_plus(A, [A]).

%
paren_to_plus(0, _, []).
paren_to_plus(N, X, (X|[])+Y):- N>0, N0 is N-1,
	paren_to_plus(N0, X, Y).

paren_to_plus(0, K, X, Y):- paren_to_plus(K, X, Y).
paren_to_plus(J, K, X, X+Y):- J > 0, J0 is J-1,
	K0 is K - 1,
	paren_to_plus(J0, K0, X, Y).
%
look_ahead(C, [C|X], [C|X]).

%
% ?- phrase((w(*(.), X), w(*(.), Y)),  [a,b,c], []).
% ?- phrase((wl(*(.), X), wl(*(.), Y)),  [a,b,c], []).

expand_w(X, _, call(X), P, P):-var(X), !.	% @ meta call
expand_w(X, M, G, P, Q):-
	regex_coalgebra_code(X, coa(C, I, _)),
	expand_coa(C, I, M, G, P, Q).

%
expand_w(X, A, B, _, call(X, A, B), P, P):- var(X), !.  % @ meta call
expand_w(X, A, B, M, G, P, Q):-
	regex_coalgebra_code(X, coa(C, I, _)),
	expand_coa(C, I, A, B, M, G, P, Q).

expand_wl(X, _, call(X), P, P):-var(X), !.	% @ meta call
expand_wl(X, M, G, P, Q):-
	regex_coalgebra_code(X, coa(C, I, _)),
	reverse_coa(C, C0),
	expand_coa(C0, I, M, G, P, Q).

%
expand_wl(X, A, B, _, call(X, A, B), P, P):- var(X), !.  % @ meta call
expand_wl(X, A, B, M, G, P, Q):-
	regex_coalgebra_code(X, coa(C, I, _)),
	reverse_coa(C, C0),
	expand_coa(C0, I, A, B, M, G, P, Q).

reverse_coa(X, Y):- maplist(reverse_coa_, X, Y).

reverse_coa_(A-B, A-C):- reverse(B, C).


Kuniaki Mukai


> 
> -- 
> Michael
> -------------- next part --------------
> HTML attachment scrubbed and removed
> _______________________________________________
> SWI-Prolog mailing list
> [email protected]
> https://lists.iai.uni-bonn.de/mailman/listinfo.cgi/swi-prolog

-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 496 bytes
Desc: Message signed with OpenPGP using GPGMail
URL: <https://lists.iai.uni-bonn.de/pipermail/swi-prolog/attachments/20140802/1f009281/signature.asc>