SWISH -- SWI-Prolog for SHaring

%%%%%%%%%
%%%%%%%%% Value taxonomy examples (directed acyclic graphs -- DAGs) 
%%%%%%%%%

% The directed acyclic graph is defined by a set of edges by the edges/2 predicate

%nodes([n1,n2,n3,n4,n5,n6,n7,n8,n9]).
%edges([(n1,n2),(n1,n3),(n2,n4),(n3,n5),(n3,n6),(n4,n7),(n4,n8),(n5,n9)]).
%importance([(n2,0.8),(n3,0.7),(n8,0.9)]).
%importance([(n2,0.8),(n3,0.7)]).

%nodes([n1,n2,n3,n4,n5,n6,n7,n8,n9,n10,n11,n12,n13,n14,n15,n16]).
edges([(n1,n2),(n6,n2),(n1,n3),(n1,n4),(n2,n5),(n2,n6),(n2,n7),(n2,n8),(n5,n9),(n5,n10),(n6,n11),(n7,n12),(n7,n13),(n10,n14),(n11,n15),(n13,n16)]).
importance([(n1,0.3),(n3,0.1),(n4,0.2),(n8,0.8),(n15,0.5),(n16,0.3)]).

%%%%%%%%%
%%%%%%%%% Algorithm for Propagation & Coherence Check
%%%%%%%%%

propagate(I4) :- 
    edges(E), importance(I), 
    get_nodes_from_edges(E,N), 
  	confirm_dag(N,E), 				% confirm the input is a DAG (to be completed)
  	root(N,E,R), 
	confirmed_values(N,E,I,I2),		% propagating to/from only child (no backtracking)
    propagate(R,E,I2,I3), 
    subtract(I3,I,I4).

propagate(R,E,I,I4) :-
    propagate2([R],E,I,I3), 
    (   (   I3==I, !, I4=I3		)	; propagate(R,E,I3,I4)	).

confirmed_values(N,E,I,I2) :-
    parents_with_one_child(N,E,List), 
    confirmed_values(List,I,I2).

confirmed_values(List,I,I3) :-
	confirmed_values2(List,I,I2),
    (   (   I==I2, !, I3=I2	)	;
    	(   confirmed_values(List,I2,I3)	)	).

confirmed_values2([],I,I) :- !.
confirmed_values2([(P,X)|T],I,I3) :- 
    (   (   member((P,V),I), 
    		\+member((X,_),I), !,
    		append([(X,V)],I,I2)	)	;
    	(   \+member((P,_),I), 
    		member((X,V),I), !,
        	append([(P,V)],I,I2)	)	;
    	(   member((P,V1),I), 
    		member((X,V2),I), !,
        	check_values_if_equal(P,V1,X,V2), I2 = I	)	;
    	(   \+member((P,_),I), 
    		\+member((X,_),I), !, I2 = I	)	
    ), 
    confirmed_values2(T,I2,I3).
    	
parents_with_one_child([],_E,[]) :- !.
parents_with_one_child([N|T],E,[(N,R)|T2]) :-
	children(N,E,X), 
    X = [R|[]], !,					% Case of nodes with one child
    parents_with_one_child(T,E,T2).
parents_with_one_child([_N|T],E,T2) :-
    parents_with_one_child(T,E,T2).	% Case of nodes not with one child

propagate2([],_E,I,I).
propagate2([N|T],E,I,I4) :-
    member((N,V),I), !,				% Case when node N has an importance measure
    children(N,E,X),
    analyse_children(X,I,[],0,0,0,XP,Sum,NT,NF),
    propagate_down(N,E,I,V,XP,Sum,NT,NF,I2), 
    propagate2(X,E,I2,I3), 
    propagate2(T,E,I3,I4).
propagate2([N|T],E,I,I4) :-
    children(N,E,X),				% Case when node N does not have an importance measure	
    analyse_children(X,I,[],0,0,0,XP,Sum,NT,NF),
    propagate_up(N,E,I,XP,Sum,NT,NF,I2),
    propagate2(X,E,I2,I3),
    propagate2(T,E,I3,I4).	
% where,
% XP is the list of children nodes to propagte V to (those that do not have an assigned importance measure),
% Sum is the sum of the importance measures of all children nodes with assigned importance measures,
% NT is the number of children nodees that do have (true) an importance measure
% NF is the number of children nodes that do not (false) have an importance measure

propagate_down(_N,_E,I,_V,[],_Sum,0,0,I) :- !.		% No children to propagate down to
propagate_down(N,_E,I,V,[],Sum,NT,0,I) :- !,		% No children with no assigned importance measures to propagate down to
    catch(V \== (Sum/NT),_,
          (write(N), write("and its children are all set already, and the value of the parent node is not equal to the average of its children nodes. Please fix this inconsistency."), nl, !, fail)).
propagate_down(_N,_E,I,V,XP,Sum,NT,1,I2) :- !,		% 1 child with no value to propagate down to
    V2 is (V * (NT+1)) - (Sum), 
    propagate_value(XP,V2,I,I2).
propagate_down(_N,E,I,V,XP,Sum,NT,NF,I2) :-			% More than 1 child to propagate down to
    descendants_check(XP,E,I), !,					% and these children are with no descendents that have assigned importance measure
    V2 is ((V * (NT+NF)) - (Sum)) / NF, 
    propagate_value(XP,V2,I,I2).
propagate_down(_N,_E,I,_V,_XP,_Sum,_NT,_NF,I).

propagate_up(_N,_E,I,[],_Sum,0,0,I) :- !.		% No children to propagate their values up, Will this even be set?
propagate_up(N,_E,I,[],Sum,NT,0,I2) :- !,		% All children (where the node has at least one child) have an assigned importance measure, so upward propagation is straightforward (the average of the childrens' importance)
	V is Sum / NT,
    propagate_value([N],V,I,I2).
propagate_up(_N,E,I,XP,_Sum,0,_NF,I) :-			% All children are with no assigned importance measures and have no descendants with an assigned importance measure (this catches the case of having a denominator 0 in the following predicate)
    descendants_check(XP,E,I), !.					
propagate_up(N,E,I,XP,Sum,NT,_NF,I2) :-			% None of the children with no assigned importance measures has a descendant with an assigned importance measure, and there is at least one child with an assigned importance measure (guaranteed by the case above), so upward propagation is confirmed (even though it is an approximation)
    descendants_check(XP,E,I), !,					
    V2 is Sum / NT, 
    propagate_value([N|XP],V2,I,I2).
propagate_up(_N,_E,I,_XP,_Sum,_NT,_NF,I).		% Some (or all) of the children are with no assigned importance measures, and some of those have descendants with an assigned importance measure, so upward propagation is PAUSED (hoping the next iteration can bring in information)

propagate_value([],_V,I,I).
propagate_value([X|T],V,I,I3) :-
	append([(X,V)],I,I2),
    propagate_value(T,V,I2,I3).

analyse_children([],_I,XP,Sum,NT,NF,XP,Sum,NT,NF) :- !.
analyse_children([X|T],I,XP,Sum,NT,NF,XP2,Sum2,NT2,NF2) :-
    member((X,V),I), !,			% Case when node X has an assigned importance measure 
	Sum1 is Sum + V,
    NT1 is NT + 1,
    analyse_children(T,I,XP,Sum1,NT1,NF,XP2,Sum2,NT2,NF2).
analyse_children([X|T],I,XP,Sum,NT,NF,XP2,Sum2,NT2,NF2) :-
    NF1 is NF + 1,				% Case when node X does not have an assigned importance measure	
    analyse_children(T,I,[X|XP],Sum,NT,NF1,XP2,Sum2,NT2,NF2).

check_values_if_equal(_P,V,_X,V) :- !.
check_values_if_equal(P,_V1,X,_V2) :-
    write("The following two parent/child nodes have different values when theire values should be the same: "),
    write(P), write(" and "), write(X), nl, !, fail.

descendants_check(XP,E,I0) :-	% All descendants have no assigned importance measures 
    descendants(XP,E,X),
    findall(Y, (member(Y,X),member((Y,_V),I0)), G), 
    G == [].

%%%%%%%%% General predicates

children(N,E,X) :-
    findall(Y,member((N,Y),E),X).

descendants([],_E,[]).
descendants([N|T],E,X5) :-
    findall(Y,member((N,Y),E),X),
    descendants(X,E,X2),
    descendants(T,E,X3),
    append(X,X2,X4),
    append(X4,X3,X5).

root(N,E,R) :-					% Finding the root in a directed acyclic graph (DAG)
    findall(Y,member((_,Y),E),X),
    subtract(N,X,P),
    (	(   length(P,1), !, P=[R|[]] )	;    
    	(   write("There is no ONE root note. Please fix the directed acyclic graph."), nl, !, fail)
    ).

get_nodes_from_edges([], []).
get_nodes_from_edges([(N1,N2)|T], NList) :-
    get_nodes_from_edges(T, NList1), 
    (   (   member(N1, NList1) , ! , NList2 = NList1	)
    	;   (   NList2 = [N1|NList1]	)	
    ),
    (   (   member(N2, NList1) , !, NList = NList2)
    	;   (   NList = [N2|NList2]	)
    ).

confirm_dag(N,E) :- 
    no_cycles(N,E), !.
confirm_dag(_N,_E) :- 
    write("This is not a directed acyclic graphs (DAG). There seems to be some cycles between nodes."), nl, !, fail.

no_cycles([], _).
no_cycles([N|T], E) :-
    \+ reachable(N, N, E, []), 
    no_cycles(T,E).

reachable(N1, N2, E, Visited) :-		% Check whether there's a path between the two nodes
    member((N1, Ni), E),
    \+ member(Ni, Visited),
    (   (   Ni == N2, write(Ni),write(N2)	)
    	;   reachable(Ni, N2, E, [N1|Visited])
    ).