Le PTMS a été décrit dans le rapport (page 11). Le programme qui suit est une implémentation du PTMS en Prolog.
/******************************************************************************/
/* */
/* Probabilistic Truth Maintenance System */
/* */
/******************************************************************************/
/* Le reseau est stocke dans la BD de Prolog (soit ptms cette cle)
* Dans la suite : key-name = format designe un objet de type 'name'
* enregistre avec la cle 'key' au format 'format'
*
* Liste des PTMS en cours d'utilisation :
* recorded_ptms-KEY = KEY
*
* Reseau des connaissances :
*
* ptms-PTMS = ptms(IRK,IIRK,MSK,GAME)
*
* ptms_ir-IR = ir(GAME,LHS,RHS,NLHS,NRHS,COND,P)
* ptms_iir-IIR= iir(REF,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)
* ptms_ms-MS = ms(REF,A,P,JUSTIF,CONSEQ)
* PREMISSES = [REF]
* CONCL = [REF]
* JUSTIF = [REF]
* CONSEQ = [REF]
*
* Donnees intermediaires :
* state_to_propagate : file des etats a propager (DEPTH,STATE,PROBA)
*/
:-module(ptms,
[
new_ptms/1, % new_ptms(PTMS)
delete_ptms/1, % delete_ptms(PTMS)
print_ptms/1, % print_ptms(PTMS)
copy_ptms/2, % copy_ptms(PTMS1,PTMS2)
get_ptms_game/2, % get_ptms_game(PTMS,GAME)
set_ptms_game/2, % set_ptms_game(PTMS,GAME)
new_ir/3, % new_ir(PTMS,IR,GAME)
ask/3, % ask(PTMS,A,P)
store/4 % store(PTMS,DEPTH,A,P)
]
).
:-use_module(cd-tools).
/******************************************************************************/
/* */
/* Definition des connecteurs logiques */
/* */
/******************************************************************************/
:-op(
[
970, xfx, #,
960, xfy, |,
950, xfx, then,
500, yfx, or,
400, yfx, and,
200, fx, -
]
).
/******************************************************************************/
/* */
/* Initialisation du module */
/* */
/******************************************************************************/
init:-
empty_db([recorded_ptms,state_to_propagate,rule_to_connect,state_to_connect,
state_to_eventually_connect,connection_to_propagate]),
forall(recorded(recorded_ptms,PTMS),delete_ptms(PTMS)).
/******************************************************************************/
/* */
/* Creation d'un nouveau PTMS */
/* */
/******************************************************************************/
new_ptms(PTMS):-
( nonvar(PTMS)
; gensym(ptms,PTMS)
),
!,
delete_ptms(PTMS),
concat(PTMS,'_ir',IRK),
concat(PTMS,'_iir',IIRK),
concat(PTMS,'_ms',MSK),
recordz(PTMS,ptms(IRK,IIRK,MSK,no_game_at_initialisation)),
recordz(recorded_ptms,PTMS).
/******************************************************************************/
/* */
/* Destruction d'un PTMS */
/* */
/******************************************************************************/
delete_ptms(PTMS):-
( recorded(recorded_ptms,PTMS,REF1)
-> erase(REF1)
; true
),
recorded(PTMS,ptms(IRK,IIRK,MSK,_),REF2),
!,
empty_db([IRK,IIRK,MSK]),
erase(REF2).
delete_ptms(_).
/******************************************************************************/
/* */
/* Affichage du reseau d'un PTMS */
/* */
/******************************************************************************/
print_ptms(PTMS):-
recorded(PTMS,ptms(IRK,IIRK,MSK,CUR_GAME)),
!,
writef("Jeu courant : %t\n",[CUR_GAME]),
( nl,
recorded(IRK,ir(GAME,LHS,RHS,_,_,COND,P)),
numbervars((GAME,LHS,RHS,COND),0,_),
writef("%t : %t then %t\t| %t\t# %t\n",[GAME,LHS,RHS,COND,P]),
fail
; nl,
recorded(IIRK,iir(REF,GAME,LHS,RHS,_,_,P,_,_)),
numbervars((GAME,LHS,RHS),0,_),
writef("%t\t%t : %t then %t\t\t# %t\n",[REF,GAME,LHS,RHS,P]),
fail
; nl,
recorded(MSK,ms(REF,A,P,_,_)),
numbervars(A,0,_),
writef("%t\t%t\t# %t\n",[REF,A,P]),
fail
; nl
).
/******************************************************************************/
/* */
/* Duplication d'un PTMS */
/* */
/******************************************************************************/
copy_ptms(PTMS1,PTMS2):-
nonvar(PTMS1),
new_ptms(PTMS2),
get_ptms_game(PTMS1,GAME),
set_ptms_game(PTMS2,GAME),
recorded(PTMS1,ptms(IRK1,IIRK1,MSK1,_)),
recorded(PTMS2,ptms(IRK2,IIRK2,MSK2,_)),
copy(IRK1,IRK2),
copy(IIRK1,IIRK2),
copy(MSK1,MSK2).
copy(K1,K2):-
forall(recorded(K1,X),recordz(K2,X)).
/******************************************************************************/
/* */
/* Lecture du jeu courant d'un PTMS */
/* */
/******************************************************************************/
get_ptms_game(PTMS,GAME):-
recorded(PTMS,ptms(_,_,_,GAME)).
/******************************************************************************/
/* */
/* Changement du jeu courant d'un PTMS */
/* */
/******************************************************************************/
set_ptms_game(PTMS,GAME):-
recorded(PTMS,ptms(IRK,IIRK,MSK,_),REF),
erase(REF),
recordz(PTMS,ptms(IRK,IIRK,MSK,GAME)).
/******************************************************************************/
/* */
/* Ajout d'une nouvelle regle d'inference */
/* */
/******************************************************************************/
new_ir(PTMS,(LHS then RHS|COND#P),GAME):-!,new_ir0(PTMS,LHS,RHS,COND,P,GAME).
new_ir(PTMS,(LHS then RHS|COND),GAME):-!,new_ir0(PTMS,LHS,RHS,COND,1,GAME).
new_ir(PTMS,(LHS then RHS#P),GAME):-!,new_ir0(PTMS,LHS,RHS,true,P,GAME).
new_ir(PTMS,(LHS then RHS),GAME):-!,new_ir0(PTMS,LHS,RHS,true,1,GAME).
new_ir0(PTMS,LHS,RHS,COND,P,GAME):-
recorded(PTMS,ptms(IRK,_,_,_)),
neg(LHS,NLHS),
neg(RHS,NRHS),
recordz(IRK,ir(GAME,LHS,RHS,NLHS,NRHS,COND,P)).
neg(P,NP):-simpl(-P,NP).
/******************************************************************************/
/* */
/* Interrogation d'un PTMS */
/* */
/******************************************************************************/
ask(PTMS,A,P):-
recorded(PTMS,ptms(_,_,MSK,_)),
simpl(A,A0),
% findall(P0,ask0(MSK,A0,P0),LP),
% max(LP,P).
ask0(MSK,A0,P).
ask0(MSK,A,P):-
var(A),
!,
recorded(MSK,ms(_,A,P,_,_)).
% fail.
ask0(_,true,1):-!.
ask0(_,false,0):-!.
ask0(MSK,A and B,P):-
!,
ask0(MSK,A,PA),
ask0(MSK,B,PB),
P is min(PA,PB).
ask0(MSK,A or B,P):-
!,
ask0(MSK,A,PA),
ask0(MSK,B,PB),
P is max(PA,PB).
ask0(MSK,-A,P):-
!,
ask0(MSK,A,PA),
P is 1-PA.
ask0(MSK,A,P):-
( recorded(MSK,ms(_,A,P,_,_))
*-> true
; P=0.5
).
simpl(V,V):- var(V), !.
simpl(-V,-V):- var(V), !.
simpl(-(-X),U):- !, simpl(X,U).
simpl(-(X and Y),U or V):- !, simpl(-X,U), simpl(-Y,V).
simpl(-(X or Y),U and V):- !, simpl(-X,U), simpl(-Y,V).
simpl(T,TS):-
functor(T,F,N),
!,
functor(TS,F,N),
simpl_args(N,T,TS).
simpl(T,T).
simpl_args(0,_,_):-!.
simpl_args(N,T,TS):-
arg(N,T,A),
simpl(A,AS),
arg(N,TS,AS),
N1 is N-1,
simpl_args(N1,T,TS).
/******************************************************************************/
/* */
/* Mise a jour d'un PTMS */
/* */
/******************************************************************************/
store(PTMS,DEPTH,A,P):-
simpl(A,A0),
store0(PTMS,DEPTH,A0,P),
!,
% update(PTMS,DEPTH,A,P).
propagate(PTMS).
store(_,_,_,_).
store1(PTMS,DEPTH,A,P):-
simpl(A,A0),
store0(PTMS,DEPTH,A0,P).
/* La mise a jour se fait de maniere a modifier le moins possible la
* base de connaissances.
*/
/* store0 echoue s'il n'y a pas de modif a faire ! */
store0(_,_,V,_):-
var(V),
!,
fail.
/* Conjonction : (A and B)(P)
* KB={A(Pa), B(Pb)}
* On veut : min{Pa',Pb'}>=P
* donc Pi'=max(Pi,P)
*/
store0(K,D,A and B,P):-
!,
ask(K,A,PA),
ask(K,B,PB),
( P>PA
-> store0(K,D,A,P),
( P>PB
-> store0(K,D,B,P)
; true
)
; P>PB
-> store0(K,D,B,P)
).
/* Disjonction : (A or B)(P)
* KB={A(Pa), B(Pb)}
* On veut : max{Pa', Pb'}>=P
* Donc si Pa<P et Pb<P, on maj l'etat le plus proche de P
*/
store0(K,D,A or B,P):-
!,
ask(K,A,PA),
( PA<P
-> ask(K,B,PB),
( PB<P
-> ( PA<PB % PB plus proche de P que PA
-> store0(K,D,B,P)
; store0(K,D,A,P)
)
)
).
/* Negation : (-A)(P)
* KB={A(Pa)}
* (-A)(P) : "A est faux avec une proba >= P
* donc A est vrai avec une proba =< 1-P
* donc Pa'=min{Pa,1-P}
*/
store0(_,_,-V,_):-
var(V),
!,
fail.
%store0(K,D,-(A and B),P):-!, store0(K,D,-A or -B,P).
%store0(K,D,-(A or B),P):-!, store0(K,D,-A and -B,P).
%store0(K,D,-(-A),P):-!, store0(K,D,A,P).
store0(K,D,-A,P):-
!,
ask(K,A,PA),
NPA is 1-P,
( NPA<PA
-> recordz(state_to_propagate,(D,A,NPA))
).
/* Fait positif : A(P)
* KB={A(Pa)}
* A(P) : "A est vrai avec une proba >= P
* donc Pa'=max{Pa,P}
*/
store0(K,D,A,P):-
ask(K,A,PA),
( P>PA
-> recordz(state_to_propagate,(D,A,P))
).
/******************************************************************************/
/* */
/* Propagation des modifications dans le reseau */
/* */
/******************************************************************************/
propagate(PTMS):-
recorded(state_to_propagate,(D,A,P),REF),
erase(REF),
update(PTMS,D,A,P),
( D > 0
-> D1 is D-1,
recorded(PTMS,ptms(_,IIRK,MSK,GAME)),
recorded(MSK,ms(_,A,_,JUSTIF,CONSEQ)),
!,
( member(REF_IIR,CONSEQ),
recorded(IIRK,iir(REF_IIR,GAME,LHS,RHS,_,_,P_IIR,_,_)),
ask(PTMS,LHS,P_LHS),
P_RHS is min(P_LHS,P_IIR),
store1(PTMS,D1,RHS,P_RHS),
fail
; member(REF_IIR,JUSTIF),
recorded(IIRK,iir(REF_IIR,GAME,_,_,NLHS,NRHS,P_IIR,_,_)),
ask(PTMS,NRHS,P_NRHS),
P_NLHS is max(P_NRHS,1-P_IIR),
store1(PTMS,D1,NLHS,P_NLHS),
fail
; true
)
),
propagate(PTMS).
propagate(_). % Pas d'etat a propager
/******************************************************************************/
/* */
/* Mise a jour des etats propages */
/* */
/******************************************************************************/
update(PTMS,D,A,P):-
recorded(PTMS,ptms(_,_,MSK,_)),
( recorded(MSK,ms(REFA,A,_,JUSTIF,CONSEQ),REF)
-> erase(REF),
recordz(MSK,ms(REFA,A,P,JUSTIF,CONSEQ))
; gen_ref(REFA),
recordz(MSK,ms(REFA,A,P,[],[])),
connect(PTMS,REFA,D)
).
/******************************************************************************/
/* */
/* Connexion d'un etat au PTMS */
/* */
/******************************************************************************/
connect(_,_,0):-!.
connect(PTMS,REFA,DEPTH):-
recorded(PTMS,ptms(_,IIRK,MSK,_)),
( instanciated_inference_rule(PTMS,IIR),
( rule_uses(IIR,REFA),
new_rule(IIRK,IIR)
-> IIR=iir(REF_IIR,_,_,_,_,_,_,_,_),
gen_ref(REF_IIR),
recordz(rule_to_connect,IIR),
( recorded(state_to_eventually_connect,ST0,REF),
erase(REF),
ST=ST0, %simpl(ST0,ST),
recordz(state_to_connect,ST),
fail
; true
)
; empty_db(state_to_eventually_connect)
),
fail
; recorded(state_to_connect,(NEW_REF,A,P),REF),
erase(REF),
recordz(MSK,ms(NEW_REF,A,P,[],[])),
DEPTH1 is DEPTH-1,
recordz(connection_to_propagate,(DEPTH1,NEW_REF)),
fail
; recorded(rule_to_connect,IIR,REF),
erase(REF),
connect_rule(PTMS,IIR),
fail
; recorded(connection_to_propagate,(D,R),REF)
-> erase(REF),
connect(PTMS,R,D)
; true
).
connect_rule(PTMS,iir(REF_IIR,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)):-
recorded(PTMS,ptms(_,IIRK,MSK,_)),
recordz(IIRK,iir(REF_IIR,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)),
( member(REF_MS,PREMISSES),
recorded(MSK,ms(REF_MS,A,PA,JUSTIF,CONSEQ),REF),
erase(REF),
recordz(MSK,ms(REF_MS,A,PA,JUSTIF,[REF_IIR|CONSEQ])),
fail
; member(REF_MS,CONCL),
recorded(MSK,ms(REF_MS,A,PA,JUSTIF,CONSEQ),REF),
erase(REF),
recordz(MSK,ms(REF_MS,A,PA,[REF_IIR|JUSTIF],CONSEQ)),
fail
; true
).
rule_uses(iir(_,_,_,_,_,_,_,PREMISSES,_),REFA):-
memberchk(REFA,PREMISSES),
!.
rule_uses(iir(_,_,_,_,_,_,_,_,CONCL),REFA):-
memberchk(REFA,CONCL).
new_rule(IIRK,iir(_,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)):-
\+recorded(IIRK,iir(_,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)),
\+recorded(rule_to_connect,iir(_,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)).
/******************************************************************************/
/* */
/* Instanciation d'une regle d'inference */
/* */
/******************************************************************************/
/* Le backtracking fournit toutes les instances possibles
*/
instanciated_inference_rule(PTMS,
iir(_,GAME,LHS,RHS,NLHS,NRHS,P,PREMISSES,CONCL)):-
recorded(PTMS,ptms(IRK,_,MSK,GAME)),
recorded(IRK,ir(GAME,LHS0,RHS0,NLHS0,NRHS0,COND,P)),
inst(LHS0,MSK,PREMISSES),
COND,
simpl(LHS0,LHS),
simpl(RHS0,RHS),
simpl(NLHS0,NLHS),
simpl(NRHS0,NRHS),
formula_items(RHS,MSK,CONCL).
inst(A,MSK,PA):-
var(A),
!,
inst0(A,MSK,PA).
inst(A and B,MSK,PAB):-
!,
inst(A,MSK,PA),
inst(B,MSK,PB),
union(PA,PB,PAB).
inst(A or B,MSK,PAB):-
!,
inst(A,MSK,PA),
inst(B,MSK,PB),
union(PA,PB,PAB).
inst(-A,MSK,PA):-
!,
inst(A,MSK,PA).
inst(A,MSK,PA):-
inst0(A,MSK,PA).
inst0(A,MSK,[REF]):- recorded(MSK,ms(REF,A,_,_,_)).
inst0(A,_,[REF]):- recorded(state_to_connect,(REF,A,_)).
formula_items(A,_,_):-
var(A),
!,
fail.
formula_items(A and B,MSK,PAB):-
!,
formula_items(A,MSK,PA),
formula_items(B,MSK,PB),
union(PA,PB,PAB).
formula_items(A or B,MSK,PAB):-
!,
formula_items(A,MSK,PA),
formula_items(B,MSK,PB),
union(PA,PB,PAB).
formula_items(-A,MSK,PA):-
!,
formula_items(A,MSK,PA).
formula_items(A,MSK,[REFA]):-
( ( recorded(MSK,ms(REFA,A,_,_,_))
; recorded(state_to_connect,(REFA,A,_))
; recorded(state_to_eventually_connect,(REFA,A,_))
)
*-> true
; gen_ref(REFA),
recordz(state_to_eventually_connect,(REFA,A,0.5))
).