regex with boolean operations over character classes built

Kuniaki Mukai

2014-08-01 16:50:56 UTC

Post by Kuniaki Mukai
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.
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 = :***@X@Y.
(X|Y) = :***@X@Y.
(X\Y) = :***@X@Y.
&(X, Y) = :***@X@Y.
+(X) = ( X + (*(X))).
*(X) = :***@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

Post by Michael Hendricks
--
Michael
-------------- next part --------------
HTML attachment scrubbed and removed
_______________________________________________
SWI-Prolog mailing list
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>