/******************************************************************************/
/* */
/* Quelques predicats utiles en Prolog */
/* */
/******************************************************************************/
:-module('cd-tool',
[
error/1, error/2,
warning/1, warning/2,
chk/2, chk/3,
noex/1,
empty_db/1,
empty_module/1,
reinit/0,
gen_ref/1,
rasserta/1, rassertz/1,
rretracta/1, rretractz/1,
member/3,
op/1,
menu/3,
readln/1,
merge_sort/3,
for/4,
define/1, redefine/1, undefine/1,
ifdef/1, ifdef/2, ifndef/1, ifndef/2, ifdef/3, ifndef/3,
'*='/2, % unification avec controle d'occurrence
'=>'/2, % semi unification
'*=>'/2, % semi unification avec controle d'occurrence
subst/3,
pwritef/2
]
).
/******************************************************************************/
/* */
/* Messages d'erreur et avertissement, tests de condition */
/* */
/******************************************************************************/
error(MSG):-error(MSG,[]).
error(MSG,ARGS):-
writef("ERROR : "), writef(MSG,ARGS), nl,
abort.
warning(MSG):-warning(MSG,[]).
warning(MSG,ARGS):-
writef("WARNING : "), writef(MSG,ARGS), nl.
:-module_transparent chk/2, chk/3.
/* Si COND echoue, chk emet un message d'erreur
*/
chk(COND,MSG):-chk(COND,MSG,[]).
chk(COND,MSG,ARGS):-
( COND
; error(MSG,ARGS)
),
!.
/*****************************************************************************/
/* */
/* Suppression des exceptions */
/* */
/*****************************************************************************/
noex(GOAL):-catch(GOAL,_,fail).
/******************************************************************************/
/* */
/* Remise a zero d'une base de donnees */
/* */
/******************************************************************************/
empty_db([]):-!.
empty_db([K|KS]):-!,empty_db(K),empty_db(KS).
empty_db(K):-forall(recorded(K,_,REF),erase(REF)).
/******************************************************************************/
/* */
/* Remise a zero d'un module */
/* */
/******************************************************************************/
empty_module([]):-!.
empty_module([M|MS]):-!,empty_module(M),empty_module(MS).
empty_module(M):-forall(clause(M:_,_,REF),erase(REF)).
/******************************************************************************/
/* */
/* Menu textuel */
/* */
/******************************************************************************/
:-module_transparent menu/3.
menu(TITLE,OPTIONS,PROMPT):-
writef("\n%s\n\n",[TITLE]),
forall(member(CH:OPT:_,OPTIONS),
( writef("%s : ",[CH]),
( OPT=(FORMAT,ARGS)
-> writef(FORMAT,ARGS)
; writef(OPT)
),
nl
)
),
writef("\n%s",[PROMPT]),
repeat,
get_single_char(C),
memberchk([C]:_:GOAL,OPTIONS),
writef("%s\n",[[C]]),
( GOAL
; warning("The command failed")
),
!.
/******************************************************************************/
/* */
/* Saisie d'une ligne de texte */
/* */
/******************************************************************************/
readln(LN):-
readln([],LN),
!.
readln(LN0,LN):- % LN0 : already read text
get_single_char(CH),
( CH==8 -> ( LN0=[_|LN1], writef([8,32,8])
; LN1=[]
),
readln(LN1,LN)
; CH>=32 -> writef("%s",[[CH]]),
readln([CH|LN0],LN)
; ( CH==13
; CH==10
) -> reverse(LN0,LIST),
name(LN,LIST)
; readln(LN0,LN)
).
/******************************************************************************/
/* */
/* Reinitialisation de module */
/* */
/******************************************************************************/
:-module_transparent
reinit/0,
reinit/1.
reinit:-
findall(M:INIT,
( current_module(M),
clause(M:init,INIT)
),
INITS
),
reinit(INITS).
reinit([]):-!.
reinit([INIT|INITS]):-
( memberchk(INIT,INITS)
; INIT
),
!,
reinit(INITS).
/******************************************************************************/
/* */
/* Generateur de references uniques */
/* */
/******************************************************************************/
init:-flag(gen_ref,_,0).
gen_ref(R):-flag(gen_ref,R,R+1).
/******************************************************************************/
/* */
/* Tri par fusion */
/* */
/******************************************************************************/
/* Tri la liste L selon l'ordre defini par le predicat CMP_FUNC
* CMP_FUNC doit definir un ordre ('<' par exemple)
*/
:-module_transparent merge_sort/3, merge__go/4, merge_2/3, cmp/2.
merge_sort(CMP_FUNC,L,S):-
asserta(('cd-tools':cmp(X,Y):-!,call(CMP_FUNC,X,Y)),REF),
length(L,N),
merge__go(N,L,S,[]), % tri les N premiers elem de L
erase(REF).
merge__go(0,L,[],L):-!. % rien a trier
merge__go(1,[X|L],[X],L):-!. % tri un seul element
merge__go(N,L,S,R):- % tri N elements
N1 is N>>1, merge__go(N1,L,S1,R1), % tri la premiere moitier
N2 is N-N1, merge__go(N2,R1,S2,R), % puis la seconde
merge_2(S2,S1,S). % et fusionne les deux sous listes
merge_2([],S,S):-!.
merge_2([X|L1],[Y|L2],[X|L]):-
'cd-tools':cmp(X,Y),
!,
merge_2(L1,[Y|L2],L).
merge_2(L1,[Y|L2],[Y|L]):-
merge_2(L2,L1,L).
/******************************************************************************/
/* */
/* boucles */
/* */
/******************************************************************************/
:-module_transparent for/4.
for(I,MIN,MAX,BODY):-
VMIN is MIN,
VMAX is MAX,
between(VMIN,VMAX,I),
BODY,
fail.
for(_,_,_,_).
/*****************************************************************************/
/* */
/* assert et retract reversibles */
/* */
/*****************************************************************************/
/* Le backtrack sur ces predicats supprime leurs effets
*/
:-module_transparent rasserta/1, rassertz/1, rretracta/1, rretractz/2.
rasserta(X):-
asserta(X,REF),
( true
; erase(REF), fail
).
rassertz(X):-
assertz(X,REF),
( true
; erase(REF), fail
).
rretracta(X):-
retract(X),
( true
; asserta(X), fail
).
rretractz(X):-
retract(X),
( true
; assertz(X), fail
).
/******************************************************************************/
/* */
/* member avec extraction */
/* */
/******************************************************************************/
member(E,[E|L],L).
member(E,[F|L1],[F|L2]):-member(E,L1,L2).
/******************************************************************************/
/* */
/* Directives d'execution */
/* */
/******************************************************************************/
:-module_transparent ifdef/2, ifdef/3, ifndef/2, ifndef/3.
define(A=X):-
!,
( ifdef(A)
-> warning("%t is redefined.",[A]),
undefine(A)
; true
),
recordz(A,X).
define(A):-
define(A=true).
redefine(A):-
undefine(A),
define(A).
ifdef(A=X):-!, recorded(A,X).
ifdef(A):-recorded(A,_).
ifdef(A,GOAL):-ifdef(A), !, GOAL.
ifdef(_,_).
ifdef(A,GOAL,_):-ifdef(A), !, GOAL.
ifdef(_,_,GOAL):-GOAL.
ifndef(A=X):-!, \+recorded(A,X).
ifndef(A):- \+recorded(A,_).
ifndef(A,GOAL):-ifndef(A), !, GOAL.
ifndef(_,_).
ifndef(A,GOAL,_):-ifndef(A), !, GOAL.
ifndef(_,_,GOAL):-GOAL.
undefine(A=X):-!, forall(recorded(A,X,REF),erase(REF)).
undefine(A):-forall(recorded(A,_,REF),erase(REF)).
/******************************************************************************/
/* */
/* Unification avec occur check */
/* */
/******************************************************************************/
/* occur_check : controle d'occurrence d'une variable dans un terme
* X=f(X) echoue
* semi unification : X => Y "X s'unifie a Y"
* La semi unification de X vers Y ne modifie que X
*/
:-op(700,xfx,[*=,*=>,=>]).
:-op(700,xfx,has_no).
/* Unification avec controle d'occurrence
*/
X *= Y :-
( var(X)
-> ( var(Y)
-> X=Y
; Y has_no X,
X=Y
)
; ( var(Y)
-> X has_no Y,
X=Y
; functor(X,F,N),
functor(Y,F,N),
unify_args(N,X,Y)
)
).
/* Semi-unification avec controle d'occurrence
*/
X *=> Y :-
( var(X)
-> ( var(Y)
-> X=Y
; Y has_no X,
X=Y
)
; nonvar(Y),
functor(X,F,N),
functor(Y,F,N),
half_unify_args(N,X,Y)
).
/* Semi-unification rapide (sans controle d'occurrence)
*/
X => Y :-
( var(X)
-> X=Y
; nonvar(Y),
functor(X,F,N),
functor(Y,F,N),
quick_half_unify_args(N,X,Y)
).
TERM has_no VAR :-
( var(TERM)
-> TERM\==VAR
; functor(TERM,_,N),
has_no(N,TERM,VAR)
).
has_no(0,_,_):-!.
has_no(N,TERM,VAR):-
arg(N,TERM,ARG),
ARG has_no VAR,
N1 is N-1,
has_no(N1,TERM,VAR).
unify_args(0,_,_):-!.
unify_args(N,X,Y):-
arg(N,X,XN),
arg(N,Y,YN),
XN*=YN,
N1 is N-1,
unify_args(N1,X,Y).
half_unify_args(0,_,_):-!.
half_unify_args(N,X,Y):-
arg(N,X,XN),
arg(N,Y,YN),
XN*=>YN,
N1 is N-1,
half_unify_args(N1,X,Y).
quick_half_unify_args(0,_,_):-!.
quick_half_unify_args(N,X,Y):-
arg(N,X,XN),
arg(N,Y,YN),
XN=>YN,
N1 is N-1,
quick_half_unify_args(N1,X,Y).
/******************************************************************************/
/* */
/* Substitution de termes */
/* */
/******************************************************************************/
:-op(950,xfx,>>>).
:-op(949,xfx,if).
:-module_transparent subst/3, subst_args/4.
subst(S,T,TS):-
functor(T,F,N),
functor(TS0,F,N),
subst_args(N,S,T,TS0),
( member(LHS0>>>RHS0,S),
copy_term(LHS0>>>RHS0,LHS>>>RHS),
match(LHS,TS0),
( var(RHS)
-> TS=RHS0
; RHS=(TS1 if COND)
-> COND,
( var(TS1)
-> RHS0=(TS0 if _),
TS=TS0
; subst(S,TS1,TS)
)
; subst(S,RHS,TS)
)
; TS=TS0
),
!.
subst(_,X,X).
subst_args(0,_,_,_):-!.
subst_args(N,S,T,TS):-
arg(N,T,A),
arg(N,TS,AS),
subst(S,A,AS),
N1 is N-1,
subst_args(N1,S,T,TS).
match(X,Y):-
( var(X)
-> X=Y
; nonvar(Y),
functor(X,F,N),
functor(Y,F,N),
match_args(N,X,Y)
).
match_args(0,_,_):-!.
match_args(N,X,Y):-
arg(N,X,AX),
arg(N,Y,AY),
match(AX,AY),
N1 is N-1,
match_args(N1,X,Y).
/*****************************************************************************/
/* */
/* Depth */
/* */
/*****************************************************************************/
depth(T,D):-
functor(T,_,N),
!,
max_depth(N,T,0,DA),
D is DA+1.
depth(_,0).
max_depth(0,_,D,D):-!.
max_depth(N,T,D1,D2):-
arg(N,T,A),
depth(A,D),
N1 is N-1,
( D>D1
-> max_depth(N1,T,D,D2)
; max_depth(N1,T,D1,D2)
).
/*****************************************************************************/
/* */
/* Element maximal d'une liste de reels positifs */
/* */
/*****************************************************************************/
max([],0):-!.
max([E|L],M):-max(L,N), M is max(E,N).
/*****************************************************************************/
/* */
/* writef + instanciation des variables */
/* */
/*****************************************************************************/
pwritef(MSG,ARGS):-
copy_term(ARGS,TMP),
numbervars(TMP,0,_),
writef(MSG,TMP).
/******************************************************************************/
/* */
/* Version simplifiee pour les appels multiples a op/3 */
/* */
/******************************************************************************/
op([]):-!.
op([PRECEDENCE,TYPE,OP|OPS]):-
op(PRECEDENCE,TYPE,OP),
op(OPS).