diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

improve JT

Browse Source 
fix graph compatibility with SICStus
re-export declaration.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2037 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-12-05 12:17:25 +00:00
parent c9c6b2e25c
commit 64d62f1e3e
33 changed files with 1135 additions and 460 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
C/adtdefs.c
View File

@ -1169,4 +1169,60 @@ Yap_PutInSlot(long slot, Term t)
LCL0[slot] = t;
}
HoldEntry *
Yap_InitAtomHold(void)
{
HoldEntry *x = (HoldEntry *)Yap_AllocAtomSpace(sizeof(struct hold_entry));
x->KindOfPE = HoldProperty;
x->NextOfPE = NIL;
return x;
}
int
Yap_AtomGetHold(Atom at)
{
AtomEntry *ae = RepAtom(at);
PropEntry *pp, *opp = NULL;
WRITE_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp)) {
pp = RepProp(pp->NextOfPE);
opp = pp;
}
if (!pp) {
ae->PropsOfAE = AbsHoldProp(GlobalHoldEntry);
} else if (opp->KindOfPE != HoldProperty) {
opp->NextOfPE = AbsHoldProp(GlobalHoldEntry);
} else {
WRITE_UNLOCK(ae->ARWLock);
return FALSE;
}
WRITE_UNLOCK(ae->ARWLock);
return TRUE;
}
int
Yap_AtomReleaseHold(Atom at)
{
AtomEntry *ae = RepAtom(at);
PropEntry *pp, *opp = NULL;
WRITE_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp)) {
if (pp->KindOfPE == HoldProperty) {
if (!opp) {
ae->PropsOfAE = NIL;
} else {
opp->NextOfPE = NIL;
}
WRITE_UNLOCK(ae->ARWLock);
return TRUE;
}
pp = RepProp(pp->NextOfPE);
opp = pp;
}
WRITE_UNLOCK(ae->ARWLock);
return FALSE;
}

1
C/agc.c
View File

@ -153,6 +153,7 @@ AtomAdjust(Atom a)
#define TrailAddrAdjust(P) (P)
#define XAdjust(P) (P)
#define YAdjust(P) (P)
#define HoldEntryAdjust(P) (P)
static void
recompute_mask(DBRef dbr)

27
C/c_interface.c
View File

@ -10,8 +10,11 @@
* File: c_interface.c *
* comments: c_interface primitives definition *
* *
* Last rev: $Date: 2007-11-16 14:58:40 $,$Author: vsc $ *
* Last rev: $Date: 2007-12-05 12:17:23 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.103 2007/11/16 14:58:40 vsc
* implement sophisticated operations with matrices.
*
* Revision 1.102 2007/11/01 20:50:31 vsc
* fix YAP_LeaveGoal (again)
*
@ -412,6 +415,8 @@ X_API int STD_PROTO(YAP_ThreadDestroyEngine,(int));
X_API Term STD_PROTO(YAP_MkBlobTerm,(unsigned int));
X_API void *STD_PROTO(YAP_BlobOfTerm,(Term));
X_API Term STD_PROTO(YAP_TermNil,(void));
X_API int STD_PROTO(YAP_AtomGetHold,(Atom));
X_API int STD_PROTO(YAP_AtomReleaseHold,(Atom));
static int (*do_getf)(void);
@ -452,7 +457,7 @@ doexpand(UInt sz)
} else {
arity = 0;
}
if (!Yap_gcl(sz, arity, ENV, CP)) {
if (!Yap_gcl(sz, arity, ENV, P)) {
return FALSE;
}
return TRUE;
@ -2061,3 +2066,21 @@ YAP_TermNil(void)
return TermNil;
}
X_API int
YAP_AtomGetHold(Atom at)
{
return Yap_AtomGetHold(at);
}
X_API int
YAP_AtomReleaseHold(Atom at)
{
return Yap_AtomReleaseHold(at);
}
X_API void
YAP_AGCRegisterHook(Agc_hook hook)
{
AGCHook = hook;
}

2
C/init.c
View File

@ -391,6 +391,7 @@ static Opdef Ops[] = {
{">", xfx, 700},
{"=<", xfx, 700},
{">=", xfx, 700},
{"as", xfx, 600},
{":", xfy, 600},
{"+", yfx, 500},
{"-", yfx, 500},
@ -1231,6 +1232,7 @@ InitCodes(void)
Yap_heap_regs->agc_threshold = 10000;
Yap_heap_regs->agc_hook = NULL;
Yap_heap_regs->parser_error_style = EXCEPTION_ON_PARSER_ERROR;
Yap_heap_regs->global_hold_entry = Yap_InitAtomHold();
Yap_heap_regs->size_of_overflow = 0;
/* make sure no one else can use these two atoms */
CurrentModule = 0;

2
C/tracer.c
View File

@ -58,7 +58,7 @@ send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
if (i > 0) fprintf(Yap_stderr, ",");
#if DEBUG
#if COROUTINING
Yap_Portray_delays = TRUE;
Yap_Portray_delays = FALSE;
#endif
#endif
omax_depth = max_depth;

8
CLPBN/clpbn/bnt.yap
View File

@ -164,9 +164,9 @@ get_tied(More,_,Vs,Vs,Ns,Ns,Es,Es,More).
tied_graph(TVars,Graph,Vertices) :-
dgraph_new(Graph0),
dgraph_add_vertices(Vertices, Graph0, Graph1),
dgraph_add_vertices(Graph0, Vertices, Graph1),
get_tied_edges(TVars,Edges),
dgraph_add_edges(Edges, Graph1, Graph).
dgraph_add_edges(Graph1, Edges, Graph).
get_tied_edges([],[]).
get_tied_edges([N-g(_,Vs,_)|TGraph],Edges) :-
@ -192,9 +192,9 @@ distribute_tied([V|Vs],I0,In,[V|NVs],NVs0) :-
extract_graph(AllVars, Graph) :-
dgraph_new(Graph0),
dgraph_add_vertices(AllVars, Graph0, Graph1),
dgraph_add_vertices(Graph0, AllVars, Graph1),
get_edges(AllVars,Edges),
dgraph_add_edges(Edges, Graph1, Graph).
dgraph_add_edges(Graph1, Edges, Graph).
get_edges([],[]).
get_edges([V|AllVars],Edges) :-

7
CLPBN/clpbn/dists.yap
View File

@ -17,7 +17,9 @@
:- use_module(library(lists),[is_list/1]).
:- use_module(library(matrix),[matrix_new/4]).
:- use_module(library(matrix),
[matrix_new/4,
matrix_to_logs/1]).
/*
@ -152,7 +154,8 @@ get_dist(Id, Type, Domain, Tab) :-
get_dist_matrix(Id, Parents, Type, Domain, Mat) :-
recorded(clpbn_dist_db, db(Id, Tab, Type, Domain, _, DomainSize), _),
get_dsizes(Parents, Sizes, []),
matrix_new(floats, [DomainSize|Sizes], Tab, Mat).
matrix_new(floats, [DomainSize|Sizes], Tab, Mat),
matrix_to_logs(Mat).
get_dsizes([], Sizes, Sizes).
get_dsizes([P|Parents], [Sz|Sizes], Sizes0) :-

63
CLPBN/clpbn/jt.yap
View File

@ -76,6 +76,7 @@ jt(LVs,Vs0,AllDiffs) :-
% JTree is a dgraph
% now our tree has cpts
fill_with_cpts(JTree, NewTree),
% write_tree(NewTree,0),
propagate_evidence(Evidence, NewTree, EvTree),
message_passing(EvTree, MTree),
get_margin(MTree, LVs, LPs),
@ -85,8 +86,8 @@ jt(LVs,Vs0,AllDiffs) :-
get_graph(LVs, BayesNet, CPTs, Evidence) :-
run_vars(LVs, Edges, Vertices, CPTs, Evidence),
dgraph_new(V0),
dgraph_add_edges(Edges, V0, V1),
dgraph_add_vertices(Vertices, V1, V2),
dgraph_add_edges(V0, Edges, V1),
dgraph_add_vertices(V1, Vertices, V2),
dgraph_to_ugraph(V2, BayesNet).
run_vars([], [], [], [], []).
@ -125,7 +126,7 @@ build_jt(BayesNet, CPTs, Tree) :-
initial_graph(_,Parents, CPTs) :-
test_graph(0, Graph0, CPTs),
dgraph_new(V0),
dgraph_add_edges(Graph0, V0, V1),
dgraph_add_edges(V0, Graph0, V1),
% OK, this is a bit silly, I could have written the transposed graph
% from the very beginning.
dgraph_transpose(V1, V2),
@ -180,7 +181,7 @@ moralised([_-KPars|Ks],Moral0,MoralF) :-
add_moral_edges([], Moral, Moral).
add_moral_edges([_], Moral, Moral).
add_moral_edges([K1,K2|KPars], Moral0, MoralF) :-
undgraph_add_edge(K1,K2,Moral0,MoralI),
undgraph_add_edge(Moral0, K1, K2, MoralI),
add_moral_edges([K1|KPars], MoralI, MoralJ),
add_moral_edges([K2|KPars],MoralJ,MoralF).
@ -188,9 +189,9 @@ triangulate([], _, Triangulated, Triangulated, []) :- !.
triangulate(Vertices, S0, T0, Tf, Cliques) :-
choose(Vertices, S0, +inf, [], -1, BestVertex, _, Cliques0, Cliques, Edges),
ord_del_element(Vertices, BestVertex, NextVertices),
undgraph_add_edges(Edges, T0, T1),
undgraph_del_vertex(BestVertex, S0, Si),
undgraph_add_edges(Edges, Si, Si2),
undgraph_add_edges(T0, Edges, T1),
undgraph_del_vertex(S0, BestVertex, Si),
undgraph_add_edges(Si, Edges, Si2),
triangulate(NextVertices, Si2, T1, Tf, Cliques0).
choose([], _, _, NewEdges, Best, Best, Clique, Cliques0, [Clique|Cliques0], NewEdges).
@ -208,6 +209,7 @@ choose([V|Vertices], Graph, Score0, _, _, Best, _, Cliques0, Cliques, EdgesF) :-
length(PossibleClique,L),
Cliques = [L-PossibleClique|Cliques0]
;
% cliquelength(PossibleClique,1,CL),
length(PossibleClique,CL),
CL < Score0, !,
choose(Vertices,Graph,CL,NewEdges, V, Best, CL-PossibleClique, Cliques0,Cliques,EdgesF)
@ -227,6 +229,12 @@ new_edges([N1|Neighbors],N,Graph,NewEdges0, NewEdgesF) :-
new_edges([N1|Neighbors],N,Graph,NewEdges0, [N-N1|NewEdgesF]) :-
new_edges(Neighbors,N,Graph,NewEdges0, NewEdgesF).
cliquelength([],CL,CL).
cliquelength([V|Vs],CL0,CL) :-
clpbn:get_atts(V, [dist(Id,_)]),
get_dist_domain_size(Id, Sz),
CL1 is CL0*Sz,
cliquelength(Vs,CL1,CL).
%
@ -239,8 +247,8 @@ cliques(CliqueList, CliquesF) :-
keysort(CliqueList,Sort),
reverse(Sort, Rev),
get_links(Rev, [], Vertices, [], Edges),
wundgraph_add_vertices(Vertices, Cliques0, CliquesI),
wundgraph_add_edges(Edges, CliquesI, CliquesF).
wundgraph_add_vertices(Cliques0, Vertices, CliquesI),
wundgraph_add_edges(CliquesI, Edges, CliquesF).
% stupid quadratic algorithm, needs to be improved.
get_links([], Vertices, Vertices, Edges, Edges).
@ -276,7 +284,7 @@ remove_leaves(Tree, SmallerTree) :-
Vertices = [_,_,_|_],
get_leaves(Vertices, Tree, Leaves),
Leaves = [_|_], !,
undgraph_del_vertices(Leaves, Tree, NTree),
undgraph_del_vertices(Tree, Leaves, NTree),
remove_leaves(NTree, SmallerTree).
remove_leaves(Tree, Tree).
@ -424,21 +432,24 @@ add_evidence_to_kids([K|Kids], V, P, [K|NNKids]) :-
message_passing(tree(Clique-Dist,Kids), tree(Clique-NDist,NKids)) :-
get_CPT_sizes(Dist, Sizes),
upward(Kids, Clique, tab(Dist, Clique, Sizes), IKids, ITab),
upward(Kids, Clique, tab(Dist, Clique, Sizes), IKids, ITab, 1),
ITab = tab(NDist, _, _),
nb_setval(cnt,0),
downward(IKids, Clique, ITab, NKids).
upward([], _, Dist, [], Dist).
upward([tree(Clique1-Dist1,DistKids)|Kids], Clique, Tab, [tree(Clique1-(NewDist1,EDist1),NDistKids)|Kids], NewTab) :-
upward([], _, Dist, [], Dist, _).
upward([tree(Clique1-Dist1,DistKids)|Kids], Clique, Tab, [tree(Clique1-(NewDist1,EDist1),NDistKids)|NKids], NewTab, Lev) :-
get_CPT_sizes(Dist1, Sizes1),
upward(DistKids, Clique1, tab(Dist1,Clique1,Sizes1), NDistKids, NewTab1),
Lev1 is Lev+1,
upward(DistKids, Clique1, tab(Dist1,Clique1,Sizes1), NDistKids, NewTab1, Lev1),
NewTab1 = tab(NewDist1,_,_),
ord_intersection(Clique1, Clique, Int),
sum_out_from_CPT(Int, NewDist1, Clique1, Tab1),
multiply_CPTs(Tab, Tab1, NewTab, EDist1).
multiply_CPTs(Tab, Tab1, ITab, EDist1),
upward(Kids, Clique, ITab, NKids, NewTab, Lev).
downward([], _, _, []).
downward([tree(Clique1-(Dist1,Msg1),DistKids)|Kids], Clique, Tab, [tree(Clique1-NDist1,NDistKids)|Kids]) :-
downward([tree(Clique1-(Dist1,Msg1),DistKids)|Kids], Clique, Tab, [tree(Clique1-NDist1,NDistKids)|NKids]) :-
get_CPT_sizes(Dist1, Sizes1),
ord_intersection(Clique1, Clique, Int),
Tab = tab(Dist,_,_),
@ -446,7 +457,8 @@ downward([tree(Clique1-(Dist1,Msg1),DistKids)|Kids], Clique, Tab, [tree(Clique1-
sum_out_from_CPT(Int, Div, Clique, STab),
multiply_CPTs(STab, tab(Dist1, Clique1, Sizes1), NewTab, _),
NewTab = tab(NDist1,_,_),
downward(DistKids, Clique1, NewTab, NDistKids).
downward(DistKids, Clique1, NewTab, NDistKids),
downward(Kids, Clique, Tab, NKids).
get_margin(NewTree, LVs0, LPs) :-
@ -467,3 +479,20 @@ find_clique_from_kids([K|_], LVs, Clique, Dist) :-
find_clique_from_kids([_|Kids], LVs, Clique, Dist) :-
find_clique_from_kids(Kids, LVs, Clique, Dist).
write_tree(tree(Clique-(Dist,_),Leaves), I0) :- !,
matrix:matrix_to_list(Dist,L),
format('~*c ~w:~w~n',[I0,0' ,Clique,L]),
I is I0+2,
write_subtree(Leaves, I).
write_tree(tree(Clique-Dist,Leaves), I0) :-
matrix:matrix_to_list(Dist,L),
format('~*c ~w:~w~n',[I0,0' ,Clique, L]),
I is I0+2,
write_subtree(Leaves, I).
write_subtree([], _).
write_subtree([Tree|Leaves], I) :-
write_tree(Tree, I),
write_subtree(Leaves, I).

20
CLPBN/clpbn/matrix_cpt_utils.yap
View File

@ -26,16 +26,19 @@
matrix_op/4,
matrix_dims/2,
matrix_sum/2,
matrix_sum_out/3,
matrix_sum_out_several/3,
matrix_sum_logs_out/3,
matrix_sum_logs_out_several/3,
matrix_op_to_all/4,
matrix_to_exps/1,
matrix_to_logs/1,
matrix_set_all_that_disagree/5,
matrix_to_list/2]).
:- use_module(library(lists), [nth0/3]).
init_CPT(List, Sizes, TAB) :-
matrix_new(floats, Sizes, List, TAB).
matrix_new(floats, Sizes, List, TAB),
matrix_to_logs(TAB).
project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
evidence(V,Pos), !,
@ -44,7 +47,7 @@ project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
matrix_dims(NewTable, NSzs).
project_from_CPT(V,tab(Table,Deps,_),tab(NewTable,NDeps,NSzs)) :-
vnth(Deps, 0, V, N, NDeps),
matrix_sum_out(Table, N, NewTable),
matrix_sum_logs_out(Table, N, NewTable),
matrix_dims(NewTable, NSzs).
evidence(V, Pos) :-
@ -110,14 +113,14 @@ split_map([_-M|Is], [M|Map]) :-
split_map(Is, Map).
divide_CPTs(Tab1, Tab2, OT) :-
matrix_op(Tab1,Tab2,/,OT).
matrix_op(Tab1,Tab2,-,OT).
multiply_CPTs(tab(Tab1, Deps1, Sz1), tab(Tab2, Deps2, Sz2), tab(OT, NDeps, NSz), NTab2) :-
expand_tabs(Deps1, Sz1, Deps2, Sz2, Map1, Map2, NDeps),
matrix_expand(Tab1, Map1, NTab1),
matrix_expand(Tab2, Map2, NTab2),
matrix_op(NTab1,NTab2,*,OT),
matrix_op(NTab1,NTab2,+,OT),
matrix_dims(OT,NSz).
expand_tabs([], [], [], [], [], [], []).
@ -149,6 +152,7 @@ expand_tabs([V1|Deps1], [S1|Sz1], [V2|Deps2], [S2|Sz2], Map1, Map2, NDeps) :-
).
normalise_CPT(MAT,NMAT) :-
matrix_to_exps(MAT),
matrix_sum(MAT, Sum),
matrix_op_to_all(MAT,/,Sum,NMAT).
@ -174,11 +178,11 @@ unit_CPT(V,CPT) :-
reset_CPT_that_disagrees(CPT, Vars, V, Pos, NCPT) :-
vnth(Vars, 0, V, Dim, _),
matrix_set_all_that_disagree(CPT, Dim, Pos, 0.0, NCPT).
matrix_set_all_that_disagree(CPT, Dim, Pos, -inf, NCPT).
sum_out_from_CPT(Vs,Table,Deps,tab(NewTable,Vs,Sz)) :-
conversion_matrix(Vs, Deps, Conv),
matrix_sum_out_several(Table, Conv, NewTable),
matrix_sum_logs_out_several(Table, Conv, NewTable),
matrix_dims(NewTable, Sz).
conversion_matrix([], [], []).

4
CLPBN/clpbn/viterbi.yap
View File

@ -48,8 +48,8 @@ mk_graph(NOfNodes, Map, ViterbiCode) :-
empty_assoc(KeyMap0),
get_graph(Vars0, Nodes, Edges, KeyMap0, KeyMap),
dgraph_new(G0),
dgraph_add_vertices(Nodes, G0, G1),
dgraph_add_edges(Edges, G1, G2),
dgraph_add_vertices(G0, Nodes, G1),
dgraph_add_edges(G1, Edges, G2),
dgraph_top_sort(G2, SortedNodes),
compile_viterbi(SortedNodes, KeyMap, NOfNodes, Map, ViterbiCode).

4
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.121 2007-11-26 23:43:08 vsc Exp $ *
* version: $Id: Heap.h,v 1.122 2007-12-05 12:17:23 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -348,6 +348,7 @@ typedef struct various_codes {
unsigned int size_of_overflow;
struct mod_entry *current_modules;
struct operator_entry *op_list;
struct hold_entry *global_hold_entry;
struct static_clause *dead_static_clauses;
struct static_mega_clause *dead_mega_clauses;
struct static_index *dead_static_indices;
@ -949,6 +950,7 @@ struct various_codes *Yap_heap_regs;
#define PredHashInitialSize 1039L
#define PredHashIncrement 7919L
#define ParserErrorStyle Yap_heap_regs->parser_error_style
#define GlobalHoldEntry Yap_heap_regs->global_hold_entry
#define DeadStaticClauses Yap_heap_regs->dead_static_clauses
#define DeadMegaClauses Yap_heap_regs->dead_mega_clauses
#define DBTermsList Yap_heap_regs->dbterms_list

5
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.81 2007-11-06 17:02:12 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.82 2007-12-05 12:17:23 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -41,6 +41,9 @@ void STD_PROTO(Yap_ReleaseAtom,(Atom));
Term STD_PROTO(Yap_StringToList,(char *));
Term STD_PROTO(Yap_StringToDiffList,(char *,Term));
Term STD_PROTO(Yap_StringToListOfAtoms,(char *));
struct hold_entry *STD_PROTO(Yap_InitAtomHold,(void));
int STD_PROTO(Yap_AtomGetHold,(Atom));
int STD_PROTO(Yap_AtomReleaseHold,(Atom));
#define Yap_StartSlots() (*--ASP = MkIntTerm(0))
#define Yap_CurrentSlot() IntOfTerm(ASP[0])

64
H/Yatom.h
View File

@ -188,6 +188,7 @@ IsFunctorProperty (int flags)
bb 00 functor entry
ff df sparse functor
ff ex arithmetic property
ff f6 hold
ff f7 array
ff f8 wide atom
ff fa module property
@ -1110,6 +1111,69 @@ IsBBProperty (int flags)
}
/* hold property entry structure */
typedef struct hold_entry
{
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
} HoldEntry;
#if USE_OFFSETS_IN_PROPS
inline EXTERN HoldEntry *RepHoldProp (Prop p);
inline EXTERN HoldEntry *
RepHoldProp (Prop p)
{
return (HoldEntry *) (AtomBase + Unsigned (p));
}
inline EXTERN Prop AbsHoldProp (HoldEntry * p);
inline EXTERN Prop
AbsHoldProp (HoldEntry * p)
{
return (Prop) (Addr (p) - AtomBase);
}
#else
inline EXTERN HoldEntry *RepHoldProp (Prop p);
inline EXTERN HoldEntry *
RepHoldProp (Prop p)
{
return (HoldEntry *) (p);
}
inline EXTERN Prop AbsHoldProp (HoldEntry * p);
inline EXTERN Prop
AbsHoldProp (HoldEntry * p)
{
return (Prop) (p);
}
#endif
#define HoldProperty 0xfff6
/* only unary and binary expressions are acceptable */
inline EXTERN PropFlags IsHoldProperty (int);
inline EXTERN PropFlags
IsHoldProperty (int flags)
{
return (PropFlags) ((flags == HoldProperty));
}
/* array property entry structure */

6
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2007-11-26 23:43:09 $,$Author: vsc $ *
* Last rev: $Date: 2007-12-05 12:17:23 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.81 2007/11/26 23:43:09 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.80 2007/11/07 09:35:53 vsc
* small fix
*
@ -736,6 +739,7 @@ restore_codes(void)
Yap_heap_regs->readutil_module = AtomTermAdjust(Yap_heap_regs->readutil_module);
Yap_heap_regs->globals_module = AtomTermAdjust(Yap_heap_regs->globals_module);
Yap_heap_regs->swi_module = AtomTermAdjust(Yap_heap_regs->swi_module);
Yap_heap_regs->global_hold_entry = HoldEntryAdjust(Yap_heap_regs->global_hold_entry);
if (Yap_heap_regs->file_aliases != NULL) {
Yap_heap_regs->yap_streams =
(struct stream_desc *)AddrAdjust((ADDR)Yap_heap_regs->yap_streams);

8
H/sshift.h
View File

@ -254,6 +254,14 @@ CellPtoHeapAdjust (CELL * ptr)
return (CELL *) (((CELL *) (CharP (ptr) + HDiff)));
}
inline EXTERN HoldEntry *HoldEntryAdjust (HoldEntry *);
inline EXTERN HoldEntry *
HoldEntryAdjust (HoldEntry * ptr)
{
return (HoldEntry *) (((HoldEntry *) (CharP (ptr) + HDiff)));
}
#if USE_OFFSETS

5
changes-5.1.html
View File

@ -17,6 +17,11 @@
<h2>Yap-5.1.3:</h2>
<ul>
<li> NEW: allow re-exporting other modules.</li>
<li> FIXED: graph add_ and del_ predicates should have the original
graph as the first argument (obs from A N Saravanaraj).</li>
<li> FIXED: implement atom holds so that the C-interface can make sure
the atom garbage collector will not remove an object.</li>
<li> FIXED: implement JT for CLP(BN).</li>
<li> FIXED: use safe locking to ensure that dynamic predicates
run correctly.</li>

384
docs/yap.tex
View File

@ -168,6 +168,7 @@ Subnodes of Modules
* Defining Modules:: How To Define a New Module
* Using Modules:: How to Use a Module
* Meta-Predicates in Modules:: How to Handle New Meta-Predicates
* Re-Exporting Modules:: How to Re-export Predicates From Other Modules
Subnodes of Input/Output
* Streams and Files:: Handling Streams and Files
@ -284,11 +285,13 @@ Subnodes of CHR
Subnodes of C-Interface
* Manipulating Terms:: Primitives available to the C programmer
* Manipulating Terms:: Primitives available to the C programmer
* Unifying Terms:: How to Unify Two Prolog Terms
* Manipulating Strings:: From character arrays to Lists of codes and back
* Memory Allocation:: Stealing Memory From YAP
* Controlling Streams:: Control How YAP sees Streams
* Calling YAP From C:: From C to YAP to C to YAP
* Module Manipulation in C:: Create and Test Modules from within C
* Writing C:: Writing Predicates in C
* Loading Objects:: Loading Object Files
* Save&Rest:: Saving and Restoring
@ -2090,6 +2093,7 @@ slowed down by the presence of modules.
* Defining Modules:: How To Define a New Module
* Using Modules:: How to Use a Module
* Meta-Predicates in Modules:: How to Handle New Meta-Predicates
* Re-Exporting Modules:: How to Re-export Predicates From Other Modules
@end menu
@ -2243,7 +2247,8 @@ the current module. Otherwise, load the files specified by @var{F},
importing the predicates specified in the list @var{L}.
@end table
@node Meta-Predicates in Modules, , Using Modules, Modules
@node Meta-Predicates in Modules, Re-Exporting Modules, Using Modules, Modules
@section Meta-Predicates in Modules
The module system must know whether predicates operate on goals or
@ -2304,6 +2309,61 @@ a(G) :- call(example:G)
@end example
@node Re-Exporting Modules, , Meta-Predicates in Modules, Modules
@section Re-Exporting Predicates From Other Modules
It is sometimes convenient to re-export predicates originally defined in
a different module. This is often useful if you are adding to the
functionality of a module, or if you are composing a large module with
several small modules. The following declarations can be used for that purpose:
@table @code
@item reexport(+@var{F})
@findex reexport/1
@snindex reexport/1
@cnindex reexport/1
Export all predicates defined in file @var{F} as if they were defined in
the curremt module.
@item reexport(+@var{F},+@var{Decls})
@findex reexport/2
@snindex reexport/2
@cnindex reexport/2
Export predicates defined in file @var{F} according to @var{Decls}. The
declarations may be of the form:
@itemize @bullet
@item A list of predicate declarations to be exported. Each declaration
may be a predicate indicator or of the form ``@var{PI} @code{as}
@var{NewName}'', meaning that the predicate with indicator @var{PI} is
to be exported under name @var{NewName}.
@item @code{except}(@var{List})
In this case, all predicates not in @var{List} are exported. Moreover,
if ``@var{PI} @code{as} @var{NewName}'' is found, the predicate with
indicator @var{PI} is to be exported under name @var{NewName}@ as
before.
@end itemize
@end table
Re-exporting predicates must be used with some care. Please, take into
account the following observations:
@itemize @bullet
@item
The @code{reexport} declarations must be the first declarations to
follow the @code{module} declaration.
@item
It is possible to use both @code{reexport} and @code{use_module}, but
all predicates reexported are automatically available for use in the
current module.
@item
In order to obtain efficient execution, YAP compiles dependencies
between re-exported predicates. In practice, this means that changing a
@code{reexport} declaration and then @strong{just} recompiling the file
may result in incorrect execution.
@end itemize
@node Built-ins, Library, Modules, Top
@chapter Built-In Predicates
@ -10460,7 +10520,7 @@ NG = [0-[],1-[3,5],2-[4],3-[],4-[5],5-[],
6-[],7-[],8-[],9-[],10-[],11-[]]
@end example
@item del_vertices(+@var{Vertices}, +@var{Graph}, -@var{NewGraph})
@item del_vertices(+@var{Graph}, +@var{Vertices}, -@var{NewGraph})
@findex del_vertices/3
@syindex del_vertices/3
@cnindex del_vertices/3
@ -10807,7 +10867,7 @@ Unify @var{Edges} with all edges appearing in graph
Unify @var{NewGraph} with a new graph obtained by adding the list of
vertices @var{Vertices} to the graph @var{Graph}.
@item undgraph_del_vertices(+@var{Vertices}, +@var{Graph}, -@var{NewGraph})
@item undgraph_del_vertices(+@var{Graph}, +@var{Vertices}, -@var{NewGraph})
@findex undgraph_del_vertices/3
@syindex undgraph_del_vertices/3
@cnindex undgraph_del_vertices/3
@ -13135,6 +13195,7 @@ The rest of this appendix describes exhaustively how to interface C to YAP.
* Memory Allocation:: Stealing Memory From YAP
* Controlling Streams:: Control How YAP sees Streams
* Calling YAP From C:: From C to YAP to C to YAP
* Module Manipulation in C:: Create and Test Modules from within C
* Writing C:: Writing Predicates in C
* Loading Objects:: Loading Object Files
* Save&Rest:: Saving and Restoring
@ -13329,6 +13390,21 @@ representation-independent way:
int YAP_AtomNameLength(YAP_Atom @var{t})
@end example
@findex YAP_AtomGetHold (C-Interface function)
@findex YAP_AtomReleaseHold (C-Interface function)
@findex YAP_AGCHook (C-Interface function)
The next routines give users some control over the atom
garbage collector. They allow the user to guarantee that an atom is not
to be garbage collected (this is important if the atom is hold
externally to the Prolog engine, allow it to be collected, and call a
hook on garbage collection:
@example
int YAP_AtomGetHold(YAP_Atom @var{at})
int YAP_AtomReleaseHold(YAP_Atom @var{at})
int YAP_AGCRegisterHook(YAP_AGC_hook @var{f})
YAP_Term YAP_TailOfTerm(YAP_Term @var{t})
@end example
@findex YAP_MkPairTerm (C-Interface function)
@findex YAP_MkNewPairTerm (C-Interface function)
@findex YAP_HeadOfTerm (C-Interface function)
@ -13511,15 +13587,169 @@ The available flags are @code{YAP_INPUT_STREAM},
stream is supposed to be at position 0. The argument @var{name} gives
the name by which YAP should know the new stream.
@node Calling YAP From C, Writing C, Controlling Streams, C-Interface
@node Calling YAP From C, Module Manipulation in C, Controlling Streams, C-Interface
@section From @code{C} back to Prolog
@findex YAP_CallProlog (C-Interface function)
Newer versions of YAP allow for calling the Prolog interpreter from
@code{C}. One must first construct a goal @code{G}, and then it is
sufficient to perform:
@findex YAP_RunGoal (C-Interface function)
There are several ways to call Prolog code from C-code. By default, the
@code{YAP_RunGoal()} should be used for this task. It assumes the engine
has been initialised before:
@example
YAP_Bool YAPCallProlog(YAP_Term @var{G})
YAP_RunGoal(YAP_Term Goal)
@end example
Execute query @var{Goal} and return 1 if the query succeeds, and 0
otherwise. The predicate returns 0 if failure, otherwise it will return
an @var{YAP_Term}.
One problem is that @var{YAP_Term} may change due to garbage
collection. To make sure you have access to the current value, it may be
a good idea to reload the term, as next example shows:
@example
val = YAP_RunGoal(YAP_ARG1);
if (val == 0) return FALSE;
else t = YAP_ARG1;
@end example
Note that even if execution failed, garbage collection might still have
been called and moved the term. In this case, this is not a problem:
An alternative that ensures correct access to arguments is to use
@emph{slots}, as shown next:
@example
long sl = YAP_InitSlot(scoreTerm);
out = YAP_RunGoal(t);
t = YAP_GetFromSlot(sl);
YAP_RecoverSlots(1);
if (out == 0) return FALSE;
@end example
Slots are safe houses in the stack, preserved by the garbage collector
and the stack shifter. In this case, we use a slot to preserve @var{t}
during the execution of @code{YAP_RunGoal}. When the execution of
@var{t} is over we read the (possibly changed) value of @var{t} back
from the slot @var{sl} and tell YAP that the slot @var{sl} is not needed
and can be given back to the system. The slot functions are as follows:
@table @code
@item long int YAP_NewSlots(int @var{NumberOfSlots})
@findex YAP_NewSlots (C-Interface function)
Allocate @var{NumberOfSlots} from the stack and return an handle to the
last one. Th eother hand can be obtained by decrementing the handle.
@item long int YAP_CurrentSlot(void)
@findex YAP_CurrentSlot (C-Interface function)
Return a handle to the system's default slot.
@item long YAP_InitSlot(YAP_Term @var{t})
@findex YAP_InitSlot (C-Interface function)
Create a new slot, initialise it with @var{t}, and return a handle to
this slot, that also becomes the current slot.
@item YAP_Term *YAP_AddressFromSlot(long int @var{slot})
@findex YAP_AddressFromSlot (C-Interface function)
Return the address of slot @var{slot}: please use with care.
@item void YAP_PutInSlot(long int @var{slot}, YAP_Term @var{t})
@findex YAP_PutInSlot (C-Interface function)
Set the contents of slot @var{slot} to @var{t}.
@item void YAP_RecoverSlots(int @var{HowMany})
@findex YAP_RecoverSlots (C-Interface function)
Recover the space for @var{HowMany} slots: these will include the
current default slot.
@end table
The following functions complement @var{YAP_RunGoal}:
@table @code
@findex YAP_RestartGoal (C-Interface function)
Look for the next solution to the current query by forcing YAP to
backtrack to the latest goal. Notice that slots allocated since the last
@code{YAP_RunGoal} will become invalid.
@item @code{int} YAP_Reset(@code{void})
@findex YAP_Reset (C-Interface function)
Reset execution environment (similar to the @code{abort/0}
built-in). This is useful when you want to start a new query before
asking all solutions to the previous query.
@item @code{int} YAP_ShutdownGoal(@code{int backtrack})
@findex YAP_ShutdownGoal (C-Interface function)
Clean up the current goal. If
@code{backtrack} is true, stack space will be recovered and bindings
will be undone. In both cases, any slots allocated since the goal was
created will become invalid.
@item @code{YAP_Bool} YAP_GoalHasException(@code{YAP_Term *tp})
@findex YAP_RestartGoal (C-Interface function)
Check if the last goal generated an exception, and if so copy it to the
space pointed to by @var{tp}
@item @code{void} YAP_ClearExceptions(@code{void})
@findex YAP_ClearExceptions (C-Interface function)
Reset any exceptions left over by the system.
@end table
The @var{YAP_RunGoal} interface is designed to be very robust, but may
not be the most efficient when repeated calls to the same goal are made
and when there is no interest in processing exception. The
@var{YAP_EnterGoal} interface should have lower-overhead:
@table @code
@item @code{YAP_PredEntryPtr} YAP_FunctorToPred(@code{YAP_Functor} @var{f},
@findex YAP_FunctorToPred (C-Interface function)
Return the predicate whose main functor is @var{f}.
@item @code{YAP_PredEntryPtr} YAP_AtomToPred(@code{YAP_Atom} @var{at},
@findex YAP_AtomToPred (C-Interface function)
Return the arity 0 predicate whose name is @var{at}.
@item @code{YAP_Bool} YAP_EnterGoal(@code{YAP_PredEntryPtr} @var{pe},
@code{YAP_Term *} @var{array}, @code{YAP_dogoalinfo *} @var{infop})
@findex YAP_EnterGoal (C-Interface function)
Execute a query for predicate @var{pe}. The query is given as an
array of terms @var{Array}. @var{infop} is the address of a goal
handle that can be used to backtrack and to recover space. Succeeds if
a solution was found.
Notice that you cannot create new slots if an YAP_EnterGoal goal is open.
@item @code{YAP_Bool} YAP_RetryGoal(@code{YAP_dogoalinfo *} @var{infop})
@findex YAP_RetryGoal (C-Interface function)
Backtrack to a query created by @code{YAP_EnterGoal}. The query is
given by the handle @var{infop}. Returns whether a new solution could
be be found.
@item @code{YAP_Bool} YAP_LeaveGoal(@code{YAP_Bool} @var{backtrack},
@code{YAP_dogoalinfo *} @var{infop})
@findex YAP_LeaveGoal (C-Interface function)
Exit a query query created by @code{YAP_EnterGoal}. If
@code{backtrack} is @code{TRUE}, variable bindings are undone and Heap
space is recovered. Otherwise, only stack space is recovered, ie,
@code{LeaveGoal} executes a cut.
@end table
Next, follows an example of how to use @code{YAP_EnterGoal}:
@example
void
runall(YAP_Term g)
@{
YAP_dogoalinfo goalInfo;
YAP_Term *goalArgs = YAP_ArraysOfTerm(g);
YAP_Functor *goalFunctor = YAP_FunctorOfTerm(g);
YAP_PredEntryPtr goalPred = YAP_FunctorToGoal(goalFunctor);
result = YAP_EnterGoal( goalPred, goalArgs, &goalInfo );
while (result)
result = YAP_RetryGoal( &goalInfo );
YAP_LeaveGoal(TRUE, &goalInfo);
@}
@end example
@findex YAP_CallProlog (C-Interface function)
YAP allows calling a @strong{new} Prolog interpreter from @code{C}. One
way is to first construct a goal @code{G}, and then it is sufficient to
perform:
@example
YAP_Bool YAP_CallProlog(YAP_Term @var{G})
@end example
@noindent
the result will be @code{FALSE}, if the goal failed, or @code{TRUE}, if
@ -13528,7 +13758,34 @@ the values they have been unified with. Execution only proceeds until
finding the first solution to the goal, but you can call
@code{findall/3} or friends if you need all the solutions.
@node Writing C, Loading Objects, Calling YAP From C, C-Interface
Notice that during execution, garbage collection or stack shifting may
have moved the terms
@node Module Manipulation in C, Writing C, Calling YAP From C, C-Interface
@section Module Manipulation in C
YAP allows one to create a new module from C-code. To create the new
code it is sufficient to call:
@example
YAP_Module YAP_CreateModule(YAP_Atom @var{ModuleName})
@end example
@noindent
Notice that the new module does not have any predicates associated and
that it is not the current module. To find the current module, you can call:
@example
YAP_Module YAP_CurrentModule()
@end example
Given a module, you may want to obtain the corresponding name. This is
possioble by using:
@example
YAP_Term YAP_ModuleName(YAP_Module mod)
@end example
@noindent
Notice that this function returns a term, and not an atom. You can
@code{YAP_AtomOfTerm} to extract the corresponding Prolog atom.
@node Writing C, Loading Objects, Module Manipulation in C, C-Interface
@section Writing predicates in C
We will distinguish two kinds of predicates:
@ -13936,113 +14193,6 @@ simple way for controlling and communicating with the Prolog run-time.
@findex YAP_Read/1
Parse a Term using the function @var{GetC} to input characters.
@item @code{YAP_Term} YAP_RunGoal(@code{YAP_Term} @var{Goal})
@findex YAP_RunGoal/1
Execute query @var{Goal} and return 1 if the query succeeds, and
0 otherwise. The predicate returns 0 if failure, otherwise it will
return @var{YAP_Term}. Note that @var{YAP_Term} may change due to garbage
collection, so you should use something like:
@example
t = YAP_RunGoal(t);
if (t == 0) return FALSE;
@end example
If the execution fails, garbage collection might still have changed
the term, so you should not use the input argument again.
An alternative is to use @emph{slots}, as shown next:
@example
long sl = YAP_InitSlot(scoreTerm);
out = YAP_RunGoal(t);
t = YAP_GetFromSlot(sl);
YAP_RecoverSlots(1);
if (out == 0) return FALSE;
@end example
Slots are safe houses in the stack, preserved by the garbage collector
and the stack shifter. In this case, we use a slot to preserve @var{t}
during the execution of @code{YAP_RunGoal}. When the execution of
@var{t} is over we read the (possibly changed) value of @var{t} back
from the slot @var{sl} and tell YAP that the slot @var{sl} is not
needed and can be given back to the system.
@item @code{int} YAP_RestartGoal(@code{void})
@findex YAP_RestartGoal/0
Look for the next solution to the current query by forcing YAP to
backtrack to the latest goal. Notice that slots allocated since the last
@code{YAP_RunGoal} will become invalid.
@item @code{int} YAP_ShutdownGoal(@code{int backtrack})
@findex YAP_ShutdownGoal/0
Clean up the current goal. If
@code{backtrack} is true, stack space will be recovered and bindings
will be undone. In both cases, any slots allocated since the goal was
created will become invalid.
@item @code{int} YAP_Reset(@code{void})
@findex YAP_Reset/0
Reset execution environment (similar to the @code{abort/0}
built-in). This is useful when you want to start a new query before
asking all solutions to the previous query.
@item @code{YAP_Bool} YAP_GoalHasException(@code{YAP_Term *tp})
@findex YAP_RestartGoal/1
Check if the last goal generated an exception, and if so copy it to the
space pointed to by @var{tp}
@item @code{void} YAP_ClearExceptions(@code{void})
@findex YAP_ClearExceptions/0
Reset any exceptions left over by the system.
@item @code{YAP_PredEntryPtr} YAP_FunctorToPred(@code{YAP_Functor} @var{f},
@findex YAP_FunctorToPred/1
Return the predicate whose main functor is @var{f}.
@item @code{YAP_PredEntryPtr} YAP_AtomToPred(@code{YAP_Atom} @var{at},
@findex YAP_AtomToPred/1
Return the arity 0 predicate whose name is @var{at}.
@item @code{YAP_Bool} YAP_EnterGoal(@code{YAP_PredEntryPtr} @var{pe},
@code{YAP_Term *} @var{array}, @code{YAP_dogoalinfo *} @var{infop})
@findex YAP_EnterGoal/3
Execute a query for predicate @var{pe}. The query is given as an
array of terms @var{Array}. @var{infop} is the address of a goal
handle that can be used to backtrack and to recover space. Succeeds if
a solution was found.
Notice that you cannot create new slots if an YAP_EnterGoal goal is open.
@item @code{YAP_Bool} YAP_RetryGoal(@code{YAP_dogoalinfo *} @var{infop})
@findex YAP_RetryGoal/1
Backtrack to a query created by @code{YAP_EnterGoal}. The query is
given by the handle @var{infop}. Returns whether a new solution could
be be found.
@item @code{YAP_Bool} YAP_LeaveGoal(@code{YAP_Bool} @var{backtrack},
@code{YAP_dogoalinfo *} @var{infop})
@findex YAP_LeaveGoal/2
Exit a query query created by @code{YAP_EnterGoal}. If
@code{backtrack} is @code{TRUE}, variable bindings are undone and Heap
space is recovered. Otherwise, only stack space is recovered, ie,
@code{LeaveGoal} executes a cut.
Next, follows an example of how to use @code{YAP_EnterGoal}:
@example
void
runall(YAP_Term g)
@{
YAP_dogoalinfo goalInfo;
YAP_Term *goalArgs = YAP_ArraysOfTerm(g);
YAP_Functor *goalFunctor = YAP_FunctorOfTerm(g);
YAP_PredEntryPtr goalPred = YAP_FunctorToGoal(goalFunctor);
result = YAP_EnterGoal( goalPred, goalArgs, &goalInfo );
while (result)
result = YAP_RetryGoal( &goalInfo );
YAP_LeaveGoal(TRUE, &goalInfo);
@}
@end example
@item @code{YAP_Term} YAP_Write(@code{YAP_Term} @var{t})
@findex YAP_CopyTerm/1
Copy a Term @var{t} and all associated constraints. May call the garbage

9
include/YapInterface.h
View File

@ -406,6 +406,15 @@ extern X_API YAP_Module PROTO(YAP_CurrentModule,(void));
/* int YAP_CurrentModule() */
extern X_API YAP_Module PROTO(YAP_CreateModule,(YAP_Atom));
/* int YAP_AtomGetHold(YAP_Atom) */
extern X_API int PROTO(YAP_AtomGetHold,(YAP_Atom));
/* int YAP_AtomReleaseHold(YAP_Atom) */
extern X_API int PROTO(YAP_AtomReleaseHold,(YAP_Atom));
/* void YAP_AtomReleaseHold(YAP_Atom) */
extern X_API void PROTO(YAP_AGCRegisterHook,(YAP_agc_hook));
/* thread stuff */
extern X_API int PROTO(YAP_ThreadSelf,(void));
extern X_API YAP_CELL PROTO(YAP_ThreadCreateEngine,(YAP_thread_attr *));

2
include/yap_structs.h
View File

@ -146,3 +146,5 @@ typedef struct {
struct yami *p;
} YAP_dogoalinfo;
typedef int (*YAP_agc_hook)(YAP_Atom);

1
library/Makefile.in
View File

@ -61,6 +61,7 @@ PROGRAMS= $(srcdir)/apply_macros.yap \
$(srcdir)/undgraphs.yap \
$(srcdir)/varnumbers.yap \
$(srcdir)/wdgraphs.yap \
$(srcdir)/wgraphs.yap \
$(srcdir)/wundgraphs.yap \
$(srcdir)/lam_mpi.yap \
$(srcdir)/ypp.yap

66
library/dgraphs.yap
View File

@ -5,7 +5,6 @@
:- module( dgraphs,
[
dgraph_new/1,
dgraph_add_edge/4,
dgraph_add_edges/3,
dgraph_add_vertex/3,
@ -34,9 +33,11 @@
dgraph_isomorphic/4,
dgraph_path/3]).
:- reexport(library(rbtrees),
[rb_new/1 as dgraph_new]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_empty/1,
[rb_empty/1,
rb_lookup/3,
rb_apply/4,
rb_insert/4,
@ -60,27 +61,22 @@
wdgraph_max_path/5,
wdgraph_min_paths/3]).
dgraph_new(Vertices) :-
rb_new(Vertices).
dgraph_add_edge(V1,V2,Vs0,Vs2) :-
dgraph_add_edge(Vs0,V1,V2,Vs2) :-
dgraph_new_edge(V1,V2,Vs0,Vs1),
dgraph_add_vertex(V2,Vs1,Vs2).
dgraph_add_vertex(Vs1,V2,Vs2).
dgraph_add_edges(Edges, V0, VF) :-
dgraph_add_edges(V0, Edges, VF) :-
rb_empty(V0), !,
sort(Edges,SortedEdges),
all_vertices_in_edges(SortedEdges,Vertices),
sort(Vertices,SortedVertices),
edges2graphl(SortedVertices, SortedEdges, GraphL),
ord_list_to_rbtree(GraphL, VF).
dgraph_add_edges(Edges) -->
{
dgraph_add_edges(G0, Edges, GF) :-
sort(Edges,SortedEdges),
all_vertices_in_edges(SortedEdges,Vertices),
sort(Vertices,SortedVertices)
},
dgraph_add_edges(SortedVertices,SortedEdges).
sort(Vertices,SortedVertices),
dgraph_add_edges(SortedVertices,SortedEdges, G0, GF).
all_vertices_in_edges([],[]).
all_vertices_in_edges([V1-V2|Edges],[V1,V2|Vertices]) :-
@ -124,15 +120,15 @@ dgraph_new_edge(V1,V2,Vs0,Vs) :-
insert_edge(V2, Children0, Children) :-
ord_insert(Children0,V2,Children).
dgraph_add_vertices([]) --> [].
dgraph_add_vertices([V|Vs]) -->
dgraph_add_vertex(V),
dgraph_add_vertices(Vs).
dgraph_add_vertices(G, [], G).
dgraph_add_vertices(G0, [V|Vs], GF) :-
dgraph_add_vertex(G0, V, G1),
dgraph_add_vertices(G1, Vs, GF).
dgraph_add_vertex(V,Vs0,Vs0) :-
dgraph_add_vertex(Vs0, V, Vs0) :-
rb_lookup(V,_,Vs0), !.
dgraph_add_vertex(V, Vs0, Vs) :-
dgraph_add_vertex(Vs0, V, Vs) :-
rb_insert(Vs0, V, [], Vs).
dgraph_edges(Vs,Edges) :-
@ -169,14 +165,12 @@ dgraph_complement(Vs0,VsF) :-
complement(Vs,Children,NewChildren) :-
ord_subtract(Vs,Children,NewChildren).
dgraph_del_edge(V1,V2,Vs0,Vs1) :-
dgraph_del_edge(Vs0,V1,V2,Vs1) :-
rb_apply(Vs0, V1, delete_edge(V2), Vs1).
dgraph_del_edges(Edges) -->
{
sort(Edges,SortedEdges)
},
continue_del_edges(SortedEdges).
dgraph_del_edges(G0, Edges, Gf) :-
sort(Edges,SortedEdges),
continue_del_edges(SortedEdges, G0, Gf).
continue_del_edges([]) --> [].
continue_del_edges([V-V1|Es]) --> !,
@ -190,17 +184,17 @@ contract_vertex(V,Children, Vs0, Vs) :-
del_edges(ToRemove,E0,E) :-
ord_subtract(E0,ToRemove,E).
dgraph_del_vertex(V,Vs0,Vsf) :-
dgraph_del_vertex(Vs0, V, Vsf) :-
rb_delete(Vs0, V, Vs1),
rb_map(Vs1, delete_edge(V), Vsf).
delete_edge(V, Edges0, Edges) :-
delete_edge(Edges0, V, Edges) :-
ord_del_element(Edges0, V, Edges).
dgraph_del_vertices(Vs) -->
{ sort(Vs,SortedVs) },
delete_all(SortedVs),
delete_remaining_edges(SortedVs).
dgraph_del_vertices(G0, Vs, GF) -->
sort(Vs,SortedVs),
delete_all(SortedVs, G0, G1),
delete_remaining_edges(SortedVs, G1, GF).
% it would be nice to be able to delete a set of elements from an RB tree
% but I don't how to do it yet.
@ -240,7 +234,7 @@ dgraph_compose(T1,T2,CT) :-
rb_visit(T1,Nodes),
compose(Nodes,T2,NewNodes),
dgraph_new(CT0),
dgraph_add_edges(NewNodes,CT0,CT).
dgraph_add_edges(CT0,NewNodes,CT).
compose([],_,[]).
compose([V-Children|Nodes],T2,NewNodes) :-
@ -264,7 +258,7 @@ dgraph_transitive_closure(G,Closure) :-
continue_closure([], Closure, Closure) :- !.
continue_closure(Edges, G, Closure) :-
transit_graph(Edges,G,NewEdges),
dgraph_add_edges(NewEdges, G, GN),
dgraph_add_edges(G, NewEdges, GN),
continue_closure(NewEdges, GN, Closure).
transit_graph([],_,[]).
@ -287,7 +281,7 @@ is_edge(V1,V2,G) :-
dgraph_symmetric_closure(G,S) :-
dgraph_edges(G, Edges),
invert_edges(Edges, InvertedEdges),
dgraph_add_edges(InvertedEdges, G, S).
dgraph_add_edges(G, InvertedEdges, S).
invert_edges([], []).
invert_edges([V1-V2|Edges], [V2-V1|InvertedEdges]) :-
@ -395,7 +389,7 @@ dgraph_isomorphic(Vs, Vs2, G1, G2) :-
translate_edges(Edges,Map,TEdges),
dgraph_new(G20),
dgraph_add_vertices(Vs2,G20,G21),
dgraph_add_edges(TEdges,G21,G2).
dgraph_add_edges(G21,TEdges,G2).
mapping([],[],Map,Map).
mapping([V1|Vs],[V2|Vs2],Map0,Map) :-

9
library/matrix.yap
View File

@ -31,7 +31,8 @@ typedef enum {
MAT_SUB=1,
MAT_TIMES=2,
MAT_DIV=3,
MAT_IDIV=4
MAT_IDIV=4,
MAT_ZDIV=5
} op_type;
*/
@ -63,9 +64,13 @@ typedef enum {
matrix_sum/2,
matrix_sum_out/3,
matrix_sum_out_several/3,
matrix_sum_logs_out/3,
matrix_sum_logs_out_several/3,
matrix_add_to_all/2,
matrix_agg_lines/3,
matrix_agg_cols/3,
matrix_to_logs/1,
matrix_to_exps/1,
matrix_op/4,
matrix_op_to_all/4,
matrix_op_to_lines/4,
@ -125,6 +130,8 @@ matrix_op(M1,M2,*,NM) :-
do_matrix_op(M1,M2,2,NM).
matrix_op(M1,M2,/,NM) :-
do_matrix_op(M1,M2,3,NM).
matrix_op(M1,M2,zdiv,NM) :-
do_matrix_op(M1,M2,5,NM).
matrix_op_to_all(M1,+,Num,NM) :-
do_matrix_op_to_all(M1,0,Num,NM).

318
library/matrix/matrix.c
View File

@ -60,7 +60,10 @@ typedef enum {
MAT_SUB=1,
MAT_TIMES=2,
MAT_DIV=3,
MAT_IDIV=4
MAT_IDIV=4,
MAT_ZDIV=5,
MAT_LOG=6,
MAT_EXP=7
} op_type;
static long int *
@ -1002,6 +1005,52 @@ matrix_min(void)
return YAP_Unify(YAP_ARG2, tf);
}
static int
matrix_log_all(void)
{
int *mat;
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
if (!mat) {
/* Error */
return FALSE;
}
if (mat[MAT_TYPE] == INT_MATRIX) {
return FALSE;
} else {
double *data = matrix_double_data(mat, mat[MAT_NDIMS]);
int i;
for (i=0; i< mat[MAT_SIZE]; i++) {
data[i] = log(data[i]);
}
}
return TRUE;
}
static int
matrix_exp_all(void)
{
int *mat;
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
if (!mat) {
/* Error */
return FALSE;
}
if (mat[MAT_TYPE] == INT_MATRIX) {
return FALSE;
} else {
double *data = matrix_double_data(mat, mat[MAT_NDIMS]);
int i;
for (i=0; i< mat[MAT_SIZE]; i++) {
data[i] = exp(data[i]);
}
}
return TRUE;
}
static int
matrix_minarg(void)
{
@ -1492,6 +1541,59 @@ matrix_double_div_data(double *nmat, int siz, double mat1[], double mat2[])
}
}
static void
matrix_long_zdiv_data(long int *nmat, int siz, long int mat1[], long int mat2[])
{
int i;
for (i=0; i< siz; i++) {
if (mat1[i] == 0)
nmat[i] = 0;
else
nmat[i] = mat1[i]/mat2[i];
}
}
static void
matrix_long_double_zdiv_data(double *nmat, int siz, long int mat1[], double mat2[])
{
int i;
for (i=0; i< siz; i++) {
if (mat1[i] == 0)
nmat[i] = 0;
else
nmat[i] = mat1[i]/mat2[i];
}
}
static void
matrix_long_double_zdiv2_data(double *nmat, int siz, double mat1[], long int mat2[])
{
int i;
for (i=0; i< siz; i++) {
if (mat1[i] == 0.0)
nmat[i] = 0;
else
nmat[i] = mat1[i]/mat2[i];
}
}
static void
matrix_double_zdiv_data(double *nmat, int siz, double mat1[], double mat2[])
{
int i;
for (i=0; i< siz; i++) {
if (mat1[i] == 0.0) {
nmat[i] = 0.0;
} else {
nmat[i] = mat1[i]/mat2[i];
}
}
}
static int
matrix_op(void)
{
@ -1549,6 +1651,9 @@ matrix_op(void)
case MAT_DIV:
matrix_long_div_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
case MAT_ZDIV:
matrix_long_zdiv_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
default:
return FALSE;
}
@ -1581,6 +1686,9 @@ matrix_op(void)
case MAT_DIV:
matrix_long_double_div_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
case MAT_ZDIV:
matrix_long_double_zdiv_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
default:
return FALSE;
}
@ -1622,6 +1730,9 @@ matrix_op(void)
case MAT_DIV:
matrix_long_double_div2_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
case MAT_ZDIV:
matrix_long_double_zdiv2_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
default:
return FALSE;
}
@ -1654,6 +1765,9 @@ matrix_op(void)
case MAT_DIV:
matrix_double_div_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
case MAT_ZDIV:
matrix_double_zdiv_data(ndata, mat1[MAT_SIZE], data1, data2);
break;
default:
return FALSE;
}
@ -2244,7 +2358,7 @@ matrix_sum_out_several(void)
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += data[i];
ndata[matrix_get_offset(nmat, nindx)] = log(exp(ndata[matrix_get_offset(nmat, nindx)]) + exp(data[i]));
}
} else {
double *data, *ndata;
@ -2273,7 +2387,199 @@ matrix_sum_out_several(void)
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += data[i];
ndata[matrix_get_offset(nmat, nindx)] = log(exp(ndata[matrix_get_offset(nmat, nindx)]) + exp(data[i]));
}
}
return YAP_Unify(YAP_ARG3, tf);
}
/* given a matrix M and a set of dims, sum out one of the dimensions
*/
static int
matrix_sum_out_logs(void)
{
int ndims, i, j, *dims, newdims, prdim;
int indx[MAX_DIMS], nindx[MAX_DIMS];
YAP_Term tpdim, tf;
int *mat = (int *)YAP_BlobOfTerm(YAP_ARG1), *nmat;
if (!mat) {
/* Error */
return FALSE;
}
/* we now have our target matrix, let us grab our conversion arguments */
tpdim = YAP_ARG2;
ndims = mat[MAT_NDIMS];
dims = mat+MAT_DIMS;
if (!YAP_IsIntTerm(tpdim)) {
return FALSE;
}
prdim = YAP_IntOfTerm(tpdim);
newdims = ndims-1;
for (i=0, j=0; i< ndims; i++) {
if (i != prdim) {
nindx[j]= (mat+MAT_DIMS)[i];
j++;
}
}
if (mat[MAT_TYPE] == INT_MATRIX) {
long int *data, *ndata;
/* create a new matrix with the same size */
tf = new_int_matrix(newdims,nindx,NULL);
if (tf == YAP_TermNil())
return FALSE;
/* in case the matrix moved */
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
nmat = (int *)YAP_BlobOfTerm(tf);
data = matrix_long_data(mat,ndims);
ndata = matrix_long_data(nmat,newdims);
/* create a new matrix with smaller size */
for (i=0;i<nmat[MAT_SIZE];i++)
ndata[i] = 0;
for (i=0; i< mat[MAT_SIZE]; i++) {
int j, k;
/*
not very efficient, we could try to take advantage of the fact
that we usually only change an index at a time
*/
matrix_get_index(mat, i, indx);
for (j = 0, k=0; j < ndims; j++) {
if (j != prdim) {
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += exp(data[i]);
}
for (i=0; i< nmat[MAT_SIZE]; i++) {
ndata[i] = log(ndata[i]);
}
} else {
double *data, *ndata;
/* create a new matrix with the same size */
tf = new_float_matrix(newdims,nindx,NULL);
if (tf == YAP_TermNil())
return FALSE;
/* in case the matrix moved */
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
nmat = (int *)YAP_BlobOfTerm(tf);
data = matrix_double_data(mat,ndims);
ndata = matrix_double_data(nmat,newdims);
/* create a new matrix with smaller size */
for (i=0;i<nmat[MAT_SIZE];i++)
ndata[i] = 0.0;
for (i=0; i< mat[MAT_SIZE]; i++) {
int j, k;
/*
not very efficient, we could try to take advantage of the fact
that we usually only change an index at a time
*/
matrix_get_index(mat, i, indx);
for (j = 0, k=0; j < ndims; j++) {
if (j != prdim) {
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += exp(data[i]);
}
for (i=0; i< nmat[MAT_SIZE]; i++) {
ndata[i] = log(ndata[i]);
}
}
return YAP_Unify(YAP_ARG3, tf);
}
/* given a matrix M and a set of dims, sum out one of the dimensions
*/
static int
matrix_sum_out_logs_several(void)
{
int ndims, i, *dims, newdims;
int indx[MAX_DIMS], nindx[MAX_DIMS], conv[MAX_DIMS];
YAP_Term tf, tconv;
int *mat = (int *)YAP_BlobOfTerm(YAP_ARG1), *nmat;
if (!mat) {
/* Error */
return FALSE;
}
ndims = mat[MAT_NDIMS];
dims = mat+MAT_DIMS;
/* we now have our target matrix, let us grab our conversion arguments */
tconv = YAP_ARG2;
for (i=0, newdims=0; i < ndims; i++) {
YAP_Term th;
if (!YAP_IsPairTerm(tconv))
return FALSE;
th = YAP_HeadOfTerm(tconv);
if (!YAP_IsIntTerm(th))
return FALSE;
conv[i] = YAP_IntOfTerm(th);
if (!conv[i]) {
nindx[newdims++] = dims[i];
}
tconv = YAP_TailOfTerm(tconv);
}
if (mat[MAT_TYPE] == INT_MATRIX) {
long int *data, *ndata;
/* create a new matrix with the same size */
tf = new_int_matrix(newdims,nindx,NULL);
if (tf == YAP_TermNil())
return FALSE;
/* in case the matrix moved */
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
nmat = (int *)YAP_BlobOfTerm(tf);
data = matrix_long_data(mat,ndims);
ndata = matrix_long_data(nmat,newdims);
/* create a new matrix with smaller size */
for (i=0;i<nmat[MAT_SIZE];i++)
ndata[i] = 0;
for (i=0; i< mat[MAT_SIZE]; i++) {
int j, k;
/*
not very efficient, we could try to take advantage of the fact
that we usually only change an index at a time
*/
matrix_get_index(mat, i, indx);
for (j = 0, k=0; j < ndims; j++) {
if (!conv[j]) {
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += exp(data[i]);
}
} else {
double *data, *ndata;
/* create a new matrix with the same size */
tf = new_float_matrix(newdims,nindx,NULL);
if (tf == YAP_TermNil())
return FALSE;
/* in case the matrix moved */
mat = (int *)YAP_BlobOfTerm(YAP_ARG1);
nmat = (int *)YAP_BlobOfTerm(tf);
data = matrix_double_data(mat,ndims);
ndata = matrix_double_data(nmat,newdims);
/* create a new matrix with smaller size */
for (i=0;i<nmat[MAT_SIZE];i++)
ndata[i] = 0.0;
for (i=0; i< mat[MAT_SIZE]; i++) {
int j, k;
/*
not very efficient, we could try to take advantage of the fact
that we usually only change an index at a time
*/
matrix_get_index(mat, i, indx);
for (j = 0, k=0; j < ndims; j++) {
if (!conv[j]) {
nindx[k++]= indx[j];
}
}
ndata[matrix_get_offset(nmat, nindx)] += exp(data[i]);
}
for (i=0; i< nmat[MAT_SIZE]; i++) {
ndata[i] = log(ndata[i]);
}
}
return YAP_Unify(YAP_ARG3, tf);
@ -2370,12 +2676,12 @@ matrix_expand(void)
not very efficient, we could try to take advantage of the fact
that we usually only change an index at a time
*/
matrix_next_index(nmat+MAT_DIMS, newdims, indx);
for (j = 0; j < newdims; j++) {
if (!new[j])
nindx[k++] = indx[j];
}
ndata[i] = data[matrix_get_offset(mat, nindx)];
matrix_next_index(nmat+MAT_DIMS, newdims, indx);
}
}
return YAP_Unify(YAP_ARG3, tf);
@ -2496,8 +2802,12 @@ init_matrix(void)
YAP_UserCPredicate("matrix_expand", matrix_expand, 3);
YAP_UserCPredicate("matrix_select", matrix_select, 4);
YAP_UserCPredicate("matrix_add_to_all", matrix_sum, 2);
YAP_UserCPredicate("matrix_to_logs", matrix_log_all,1);
YAP_UserCPredicate("matrix_to_exps", matrix_exp_all, 1);
YAP_UserCPredicate("matrix_sum_out", matrix_sum_out, 3);
YAP_UserCPredicate("matrix_sum_out_several", matrix_sum_out_several, 3);
YAP_UserCPredicate("matrix_sum_logs_out", matrix_sum_out_logs, 3);
YAP_UserCPredicate("matrix_sum_logs_out_several", matrix_sum_out_logs_several, 3);
YAP_UserCPredicate("matrix_set_all_that_disagree", matrix_set_all_that_disagree, 5);
YAP_UserCPredicate("do_matrix_op", matrix_op, 4);
YAP_UserCPredicate("do_matrix_agg_lines", matrix_agg_lines, 3);

2
library/ugraphs.yap
View File

@ -154,7 +154,7 @@ add_empty_vertices([V|G], [V-[]|NG]) :-
%
% unmark a set of vertices plus all edges leading to them.
%
del_vertices(Vertices, Graph, NewGraph) :-
del_vertices(Graph, Vertices, NewGraph) :-
msort(Vertices, V1),
(V1 = [] -> Graph = NewGraph ;
del_vertices(Graph, V1, V1, NewGraph) ).

82
library/undgraphs.yap
View File

@ -8,7 +8,6 @@
undgraph_new/1,
undgraph_add_edge/4,
undgraph_add_edges/3,
undgraph_add_vertex/3,
undgraph_add_vertices/3,
undgraph_del_edge/4,
undgraph_del_edges/3,
@ -16,31 +15,35 @@
undgraph_del_vertices/3,
undgraph_edge/3,
undgraph_edges/2,
undgraph_vertices/2,
undgraph_neighbors/3,
undgraph_neighbours/3,
undgraph_complement/2,
dgraph_to_undgraph/2,
undgraph_min_tree/2]).
:- reexport( library(dgraphs),
[
dgraph_new/1 as undgraph_new,
dgraph_add_vertex/3 as undgraph_add_vertex,
dgraph_vertices/2 as undgraph_vertices,
dgraph_complement/2 as undgraph_complement,
dgraph_symmetric_closure/2 as dgraph_to_undgraph,
dgraph_edge/3 as undgraph_edge
]).
:- use_module( library(dgraphs),
[
dgraph_new/1,
dgraph_add_edge/4,
dgraph_add_edges/3,
dgraph_add_vertex/3,
dgraph_add_vertices/3,
dgraph_del_edge/4,
dgraph_del_edges/3,
dgraph_del_vertex/3,
dgraph_del_vertices/3,
dgraph_edge/3,
dgraph_edges/2,
dgraph_vertices/2,
dgraph_neighbors/3,
dgraph_neighbours/3,
dgraph_complement/2,
dgraph_symmetric_closure/2]).
dgraph_neighbours/3]).
:- use_module(library(wundgraphs), [
undgraph_to_wundgraph/2,
@ -58,28 +61,22 @@
rb_partial_map/4
]).
undgraph_new(Vertices) :-
dgraph_new(Vertices).
undgraph_add_edge(V1,V2,Vs0,Vs2) :-
undgraph_add_edge(Vs0,V1,V2,Vs2) :-
dgraphs:dgraph_new_edge(V1,V2,Vs0,Vs1),
dgraphs:dgraph_new_edge(V2,V1,Vs1,Vs2).
undgraph_add_edges(Edges) -->
{ dup_edges(Edges, DupEdges) },
dgraph_add_edges(DupEdges).
undgraph_add_edges(G0, Edges, GF) :-
dup_edges(Edges, DupEdges),
dgraph_add_edges(G0, DupEdges, GF).
dup_edges([],[]).
dup_edges([E1-E2|Edges], [E1-E2,E2-E1|DupEdges]) :-
dup_edges(Edges, DupEdges).
undgraph_add_vertices([]) --> [].
undgraph_add_vertices([V|Vs]) -->
dgraph_add_vertex(V),
undgraph_add_vertices(Vs).
undgraph_add_vertex(V) -->
dgraph_add_vertex(V).
undgraph_add_vertices(G, [], G).
undgraph_add_vertices(G0, [V|Vs], GF) :-
dgraph_add_vertex(G0, V, GI),
undgraph_add_vertices(GI, Vs, GF).
undgraph_edges(Vs,Edges) :-
dgraph_edges(Vs,DupEdges),
@ -92,9 +89,6 @@ remove_dups([V1-V2|DupEdges],NEdges) :- V1 @< V2, !,
remove_dups([_|DupEdges],Edges) :-
remove_dups(DupEdges,Edges).
undgraph_vertices(Vs,Vertices) :-
dgraph_vertices(Vs,Vertices).
undgraph_neighbours(V,Vertices,Children) :-
dgraph_neighbours(V,Vertices,Children0),
(
@ -114,20 +108,15 @@ undgraph_neighbors(V,Vertices,Children) :-
Children = Children0
).
undgraph_complement(Vs0,VsF) :-
dgraph_complement(Vs0,VsF).
undgraph_del_edge(Vs0,V1,V2,VsF) :-
dgraph_del_edge(Vs0,V1,V2,Vs1),
dgraph_del_edge(Vs1,V2,V1,VsF).
undgraph_del_edge(V1,V2,Vs0,VsF) :-
dgraph_del_edge(V1,V2,Vs0,Vs1),
dgraph_del_edge(V2,V1,Vs1,VsF).
undgraph_del_edges(G0, Edges, GF) :-
dup_edges(Edges,DupEdges),
dgraph_del_edges(G0, DupEdges, GF).
undgraph_del_edges(Edges) -->
{
dup_edges(Edges,DupEdges)
},
dgraph_del_edges(DupEdges).
undgraph_del_vertex(V, Vs0, Vsf) :-
undgraph_del_vertex(Vs0, V, Vsf) :-
rb_delete(Vs0, V, BackEdges, Vsi),
(
ord_del_element(BackEdges,V,RealBackEdges)
@ -138,11 +127,11 @@ undgraph_del_vertex(V, Vs0, Vsf) :-
),
rb_partial_map(Vsi, RealBackEdges, del_edge(V), Vsf).
undgraph_del_vertices(Vs) -->
{ sort(Vs,SortedVs) },
delete_all(SortedVs, [], BackEdges),
{ ord_subtract(BackEdges, SortedVs, TrueBackEdges) },
delete_remaining_edges(SortedVs, TrueBackEdges).
undgraph_del_vertices(G0, Vs, GF) :-
sort(Vs,SortedVs),
delete_all(SortedVs, [], BackEdges, G0, GI),
ord_subtract(BackEdges, SortedVs, TrueBackEdges),
delete_remaining_edges(SortedVs, TrueBackEdges, GI, GF).
% it would be nice to be able to delete a set of elements from an RB tree
% but I don't how to do it yet.
@ -161,13 +150,6 @@ del_edges(ToRemove,E0,E) :-
del_edge(ToRemove,E0,E) :-
ord_del_element(E0,ToRemove,E).
dgraph_to_undgraph(G, U) :-
dgraph_symmetric_closure(G, U).
undgraph_edge(N1, N2, G) :-
dgraph_edge(N1, N2, G).
undgraph_min_tree(G, T) :-
undgraph_to_wundgraph(G, WG),
wundgraph_min_tree(WG, WT, _),

94
library/wdgraphs.yap
View File

@ -8,15 +8,12 @@
wdgraph_new/1,
wdgraph_add_edge/5,
wdgraph_add_edges/3,
wdgraph_add_vertex/3,
wdgraph_add_vertices/3,
wdgraph_add_vertices_and_edges/4,
wdgraph_del_edge/5,
wdgraph_del_edges/3,
wdgraph_del_vertex/3,
wdgraph_del_vertices/3,
wdgraph_edge/4,
wdgraph_edges/2,
wdgraph_vertices/2,
wdgraph_to_dgraph/2,
dgraph_to_wdgraph/2,
wdgraph_neighbors/3,
@ -30,13 +27,17 @@
wdgraph_max_path/5,
wdgraph_path/3]).
:- reexport(library(dgraphs),
[dgraph_add_vertex/3 as wdgraph_add_vertex,
dgraph_add_vertices/3 as wdgraph_add_vertices,
dgraph_vertices/2 as wdgraph_vertices,
dgraph_edges/2 as wdgraph_edges
]).
:- use_module(library(dgraphs),
[
dgraph_add_vertex/3,
dgraph_add_vertices/3,
dgraph_top_sort/2,
dgraph_edges/2,
dgraph_vertices/2,
dgraph_path/3
]
).
@ -69,24 +70,27 @@
wdgraph_new(Vertices) :-
rb_new(Vertices).
wdgraph_add_edge(V1,V2,Weight,Vs0,Vs2) :-
wdgraph_new_edge(V1,V2,Weight,Vs0,Vs1),
dgraph_add_vertex(V2,Vs1,Vs2).
wdgraph_add_vertices_and_edges(Vs0,Vertices,Edges,Vs2) :-
wdgraph_add_vertices(Vs0, Vertices, Vs1),
wdgraph_add_edges(Vs1, Edges, Vs2).
wdgraph_add_edges(Edges, V0, VF) :-
wdgraph_add_edge(Vs0,V1,V2,Weight,Vs2) :-
wdgraph_new_edge(V1,V2,Weight,Vs0,Vs1),
dgraph_add_vertex(Vs1,V2,Vs2).
wdgraph_add_edges(V0, Edges, VF) :-
rb_empty(V0), !,
sort(Edges,SortedEdges),
all_vertices_in_wedges(SortedEdges,Vertices),
sort(Vertices,SortedVertices),
edges2wgraphl(SortedVertices, SortedEdges, GraphL),
ord_list_to_rbtree(GraphL, VF).
wdgraph_add_edges(Edges) -->
{
wdgraph_add_edges(G0, Edges, GF) :-
sort(Edges,SortedEdges),
all_vertices_in_wedges(SortedEdges,Vertices),
sort(Vertices,SortedVertices)
},
wdgraph_add_edges(SortedVertices,SortedEdges).
sort(Vertices,SortedVertices),
add_edges(SortedVertices,SortedEdges, G0, GF).
all_vertices_in_wedges([],[]).
all_vertices_in_wedges([V1-(V2-_)|Edges],[V1,V2|Vertices]) :-
@ -100,14 +104,14 @@ edges2wgraphl([V|Vertices], SortedEdges, [V-[]|GraphL]) :-
edges2wgraphl(Vertices, SortedEdges, GraphL).
wdgraph_add_edges([],[]) --> [].
wdgraph_add_edges([VA|Vs],[VB-(V1-W)|Es]) --> { VA == VB }, !,
add_edges([],[]) --> [].
add_edges([VA|Vs],[VB-(V1-W)|Es]) --> { VA == VB }, !,
{ get_extra_children(Es,VA,Children,REs) },
wdgraph_update_vertex(VA,[V1-W|Children]),
wdgraph_add_edges(Vs,REs).
wdgraph_add_edges([V|Vs],Es) --> !,
add_edges(Vs,REs).
add_edges([V|Vs],Es) --> !,
wdgraph_update_vertex(V,[]),
wdgraph_add_edges(Vs,Es).
add_edges(Vs,Es).
get_extra_children([VA-(C-W)|Es],VB,[C-W|Children],REs) :- VA == VB, !,
get_extra_children(Es,VB,Children,REs).
@ -144,12 +148,6 @@ wdgraph_new_edge(V1,V2,W,Vs0,Vs) :-
insert_edge(V2, W, Children0, Children) :-
ord_insert(Children0,V2-W,Children).
wdgraph_add_vertex(V) -->
dgraph_add_vertex(V).
wdgraph_add_vertices(V) -->
dgraph_add_vertices(V).
wdgraph_top_sort(WG,Q) :-
wdgraph_to_dgraph(WG, G),
dgraph_top_sort(G, Q).
@ -168,7 +166,7 @@ find_edge(N-W,[N1-W|_]) :- N == N1, !.
find_edge(El,[_|Edges]) :-
find_edge(El,Edges).
wdgraph_del_edge(V1, V2, W, Vs0, Vs) :-
wdgraph_del_edge(Vs0, V1, V2, W, Vs) :-
rb_update(Vs0, V1, Children0, NewChildren, Vs),
del_edge(Children0, V2, W, NewChildren).
@ -183,11 +181,9 @@ del_edge([K-W|Children], K1, W1, NewChildren) :-
del_edge(Children, K1, W1, ChildrenLeft)
).
wdgraph_del_edges(Edges) -->
{
sort(Edges,SortedEdges)
},
continue_del_edges(SortedEdges).
wdgraph_del_edges(G0, Edges, GF) :-
sort(Edges,SortedEdges),
continue_del_edges(SortedEdges, G0, GF).
continue_del_edges([]) --> [].
continue_del_edges([V-V1|Es]) --> !,
@ -200,18 +196,18 @@ contract_vertex(V,Children, Vs0, Vs) :-
del_vertices(Children, Children0, NewChildren).
% I assume first argument is subset of second.
del_vertices([], Children, Children).
del_vertices([K-W|ToDel], [K1-W1|Children0], NewChildren) :-
del_vertices(Children, [], Children).
del_vertices([K1-W1|Children0], [K-W|ToDel], NewChildren) :-
( K == K1 ->
W = W1,
del_vertices(ToDel, Children0, NewChildren)
del_vertices(Children0, ToDel, NewChildren)
;
% K1 @< K
NewChildren = [K1-W1|ChildrenLeft],
del_vertices([K-W|ToDel], Children0, ChildrenLeft)
del_vertices(Children0, [K-W|ToDel], ChildrenLeft)
).
wdgraph_del_vertex(V,Vs0,Vsf) :-
wdgraph_del_vertex(Vs0, V, Vsf) :-
rb_delete(Vs0, V, Vs1),
rb_map(Vs1, delete_wedge(V), Vsf).
@ -227,10 +223,10 @@ delete_wedge(V, [K-W|Children], NewChildren) :-
Children = NewChildren
).
wdgraph_del_vertices(Vs) -->
{ sort(Vs,SortedVs) },
delete_all(SortedVs),
delete_remaining_edges(SortedVs).
wdgraph_del_vertices(G0, Vs, GF) :-
sort(Vs,SortedVs),
delete_all(SortedVs, G0, G1),
delete_remaining_edges(SortedVs, G1, GF).
% it would be nice to be able to delete a set of elements from an RB tree
% but I don't how to do it yet.
@ -256,12 +252,6 @@ del_possible_edges([K|ToDel], [K1-W1|Children0], NewChildren) :-
del_possible_edges(ToDel, [K1-W1|Children0], NewChildren)
).
wdgraph_edges(G,Edges) :-
dgraph_edges(G,Edges).
wdgraph_vertices(G,Edges) :-
dgraph_vertices(G,Edges).
wdgraph_to_dgraph(WG, DG) :-
rb_clone(WG, EdgesList0, DG, EdgeList),
cvt_wedges(EdgesList0, EdgeList).
@ -327,7 +317,7 @@ wdgraph_transitive_closure(G,Closure) :-
continue_closure([], Closure, Closure) :- !.
continue_closure(Edges, G, Closure) :-
transit_wgraph(Edges,G,NewEdges),
wdgraph_add_edges(NewEdges, G, GN),
wdgraph_add_edges(G, NewEdges, GN),
continue_closure(NewEdges, GN, Closure).
transit_wgraph([],_,[]).
@ -351,7 +341,7 @@ is_edge(V1,V2,G) :-
wdgraph_symmetric_closure(G,S) :-
dgraph_edges(G, WEdges),
invert_wedges(WEdges, InvertedWEdges),
wdgraph_add_edges(InvertedWEdges, G, S).
wdgraph_add_edges(G, InvertedWEdges, S).
invert_wedges([], []).
invert_wedges([V1-(V2-W)|WEdges], [V2-(V1-W)|InvertedWEdges]) :-
@ -421,7 +411,7 @@ wdgraph_min_paths(V1, WGraph, T) :-
queue_edges(Edges, V1, 0, H0, H1),
dijkstra(H1, WGraph, Status, [], EPath),
rb_empty(T0),
wdgraph_add_edges(EPath, T0, T).
wdgraph_add_edges(T0, EPath, T).
dijkstra(H0, WGraph, Status, Path0, PathF) :-

115
library/wundgraphs.yap
View File

@ -5,56 +5,44 @@
:- module( wundgraphs,
[
wundgraph_new/1,
wundgraph_add_edge/5,
wundgraph_add_edges/3,
wundgraph_add_vertex/3,
wundgraph_add_vertices/3,
wundgraph_del_edge/5,
wundgraph_del_edges/3,
wundgraph_del_vertex/3,
wundgraph_del_vertices/3,
wundgraph_edge/4,
wundgraph_edges/2,
wundgraph_vertices/2,
wundgraph_neighbors/3,
wundgraph_neighbours/3,
wdgraph_to_wundgraph/2,
wundgraph_to_wdgraph/2,
undgraph_to_wundgraph/2,
wundgraph_to_undgraph/2,
wundgraph_min_tree/3,
wundgraph_max_tree/3,
wundgraph_min_path/5,
wundgraph_min_paths/3,
wundgraph_max_path/5,
wundgraph_path/3]).
wundgraph_max_tree/3]).
:- reexport( library(wdgraphs),
[
wdgraph_new/1 as wundgraph_new,
wdgraph_add_vertex/3 as wundgraph_add_vertex,
wdgraph_add_vertices/3 as wundgraph_add_vertices,
wdgraph_vertices/2 as wundgraph_vertices,
wdgraph_del_vertices/3 as wundgraph_del_vertices,
wdgraph_edge/4 as wundgraph_edge,
wdgraph_to_dgraph/2 as wundgraph_to_undgraph,
dgraph_to_wdgraph/2 as undgraph_to_wundgraph,
wdgraph_min_path/5 as wundgraph_min_path,
wdgraph_min_paths/3 as wundgraph_min_paths,
wdgraph_max_path/5 as wundgraph_max_path,
wdgraph_path/3 as wundgraph_path]).
:- use_module( library(wdgraphs),
[
wdgraph_new/1,
wdgraph_add_edge/5,
wdgraph_add_edges/3,
wdgraph_add_vertex/3,
wdgraph_add_vertices/3,
wdgraph_del_edge/5,
wdgraph_del_edges/3,
wdgraph_del_vertex/3,
wdgraph_del_vertices/3,
wdgraph_edge/4,
wdgraph_edges/2,
wdgraph_to_dgraph/2,
dgraph_to_wdgraph/2,
wdgraph_symmetric_closure/2,
wdgraph_min_path/5,
wdgraph_min_paths/3,
wdgraph_max_path/5,
wdgraph_path/3]).
:- use_module( library(dgraphs),
[
dgraph_vertices/2,
dgraph_neighbors/3
wdgraph_neighbors/3,
wdgraph_symmetric_closure/2
]).
:- use_module(library(rbtrees),
@ -72,27 +60,18 @@
reverse/2
]).
wundgraph_new(Vertices) :-
wdgraph_new(Vertices).
wundgraph_add_edge(V1,V2,K,Vs0,Vs2) :-
wundgraph_add_edge(Vs0, V1, V2, K, Vs2) :-
wdgraphs:wdgraph_new_edge(V1,V2,K,Vs0,Vs1),
wdgraphs:wdgraph_new_edge(V2,V1,K,Vs1,Vs2).
wundgraph_add_edges(Edges) -->
{ dup_edges(Edges, DupEdges) },
wdgraph_add_edges(DupEdges).
wundgraph_add_edges(G0, Edges, GF) :-
dup_edges(Edges, DupEdges),
wdgraph_add_edges(G0, DupEdges, GF).
dup_edges([],[]).
dup_edges([E1-(E2-K)|Edges], [E1-(E2-K),E2-(E1-K)|DupEdges]) :-
dup_edges(Edges, DupEdges).
wundgraph_add_vertices(Vs) -->
wdgraph_add_vertices(Vs).
wundgraph_add_vertex(V) -->
wdgraph_add_vertex(V).
wundgraph_edges(Vs, Edges) :-
wdgraph_edges(Vs, DupEdges),
remove_dups(DupEdges,Edges).
@ -104,11 +83,8 @@ remove_dups([V1-(V2-K)|DupEdges],NEdges) :- V1 @< V2, !,
remove_dups([_|DupEdges],Edges) :-
remove_dups(DupEdges,Edges).
wundgraph_vertices(Vs,Vertices) :-
dgraph_vertices(Vs,Vertices).
wundgraph_neighbours(V,Vertices,Children) :-
dgraph_neighbours(V,Vertices,Children0),
wdgraph_neighbours(V,Vertices,Children0),
(
del_me(Children0,V,Children)
->
@ -117,7 +93,7 @@ wundgraph_neighbours(V,Vertices,Children) :-
Children = Children0
).
wundgraph_neighbors(V,Vertices,Children) :-
dgraph_neighbors(V,Vertices,Children0),
wdgraph_neighbors(V,Vertices,Children0),
(
del_me(Children0,V,Children)
->
@ -139,17 +115,15 @@ del_me([K-_|Children], K1, NewChildren) :-
compact(Children, MoreChildren)
).
wundgraph_del_edge(V1,V2,K,Vs0,VsF) :-
wdgraph_del_edge(V1,V2,K,Vs0,Vs1),
wdgraph_del_edge(V2,V1,K,Vs1,VsF).
wundgraph_del_edge(Vs0,V1,V2,K,VsF) :-
wdgraph_del_edge(Vs0,V1,V2,K,Vs1),
wdgraph_del_edge(Vs1,V2,V1,K,VsF).
wundgraph_del_edges(Edges) -->
{
dup_edges(Edges,DupEdges)
},
wdgraph_del_edges(DupEdges).
wundgraph_del_edges(G0, Edges, GF) :-
dup_edges(Edges,DupEdges),
wdgraph_del_edges(G0, DupEdges, GF).
wundgraph_del_vertex(V, Vs0, Vsf) :-
wundgraph_del_vertex(Vs0, V, Vsf) :-
rb_delete(Vs0, V, BackEdges, Vsi),
del_and_compact(BackEdges,V,BackVertices),
rb_partial_map(Vsi, BackVertices, del_edge(V), Vsf).
@ -172,8 +146,8 @@ compact([K-_|Children], [K|CompactChildren]) :-
compact(Children, CompactChildren).
wundgraph_del_vertices(Vs) -->
wdgraph_del_vertices(Vs).
wundgraph_del_vertices(G0, Vs, GF) :-
wdgraph_del_vertices(G0, Vs, GF).
del_edge(_, [], []).
del_edge(K1, [K-W|Children], NewChildren) :-
@ -195,21 +169,6 @@ wdgraph_to_wundgraph(G, U) :-
wundgraph_to_wdgraph(G, G).
wundgraph_min_path(V1, V2, WGraph, Path, Cost) :-
wdgraph_min_path(V1, V2, WGraph, Path, Cost).
wundgraph_max_path(V1, V2, WGraph, Path, Cost) :-
wdgraph_max_path(V1, V2, WGraph, Path, Cost).
wundgraph_min_paths(V1, WGraph, T) :-
wdgraph_min_paths(V1, WGraph, T).
wundgraph_path(V, WG, P) :-
wdgraph_path(V, WG, P).
undgraph_to_wundgraph(G1, G2) :-
dgraph_to_wdgraph(G1, G2).
wundgraph_to_undgraph(G1, G2) :-
wdgraph_to_dgraph(G1, G2).
@ -225,14 +184,14 @@ generate_min_tree([], T, 0) :- !,
wundgraph_new(T).
generate_min_tree([El-_], T, 0) :- !,
wundgraph_new(T0),
wundgraph_add_vertex(El,T0,T).
wundgraph_add_vertex(T0, El, T).
generate_min_tree(Els0, T, C) :-
mk_list_of_edges(Els0, Edges),
keysort(Edges, SortedEdges),
rb_new(V0),
rb_new(T0),
add_sorted_edges(SortedEdges, V0, TreeEdges, 0, C),
wundgraph_add_edges(TreeEdges, T0, T).
wundgraph_add_edges(T0, TreeEdges, T).
wundgraph_max_tree(G, T, C) :-
rb_visit(G, Els0),
@ -242,7 +201,7 @@ generate_max_tree([], T, 0) :- !,
wundgraph_new(T).
generate_max_tree([El-_], T, 0) :- !,
wundgraph_new(T0),
wundgraph_add_vertex(El,T0,T).
wundgraph_add_vertex(T0, El, T).
generate_max_tree(Els0, T, C) :-
mk_list_of_edges(Els0, Edges),
keysort(Edges, SortedEdges),
@ -250,7 +209,7 @@ generate_max_tree(Els0, T, C) :-
rb_new(V0),
rb_new(T0),
add_sorted_edges(ReversedEdges, V0, TreeEdges, 0, C),
wundgraph_add_edges(TreeEdges, T0, T).
wundgraph_add_edges(T0, TreeEdges, T).
mk_list_of_edges([], []).
mk_list_of_edges([V-Els|Els0], Edges) :-

15
library/yap2swi/yap2swi.c
View File

@ -33,14 +33,13 @@ alloc_ring_buf(void)
return buffers+(TMP_BUF_SIZE+ret*BUF_SIZE);
}
/* SWI: void PL_agc_hook(void)
YAP: NO EQUIVALENT */
/* SWI: void PL_agc_hook(void) */
/* dummy function for now (until Vitor comes through!)*/
X_API PL_agc_hook_t
PL_agc_hook(PL_agc_hook_t entry)
{
return entry;
YAP_AGCRegisterHook((YAP_agc_hook)entry);
}
/* SWI: char* PL_atom_chars(atom_t atom)
@ -977,18 +976,20 @@ X_API int PL_unify_term(term_t l,...)
/* end PL_unify_* functions =============================*/
/* SWI: void PL_register_atom(atom_t atom)
YAP: NO EQUIVALENT */
/* SWI: void PL_register_atom(atom_t atom) */
/* SAM TO DO */
X_API void PL_register_atom(atom_t atom)
{
extern int Yap_AtomGetHold(atom_t atom);
Yap_AtomGetHold(atom);
}
/* SWI: void PL_unregister_atom(atom_t atom)
YAP: NO EQUIVALENT */
/* SWI: void PL_unregister_atom(atom_t atom) */
/* SAM TO DO */
X_API void PL_unregister_atom(atom_t atom)
{
extern int Yap_AtomReleaseHold(atom_t atom);
Yap_AtomReleaseHold(atom);
}
X_API int PL_get_string_chars(term_t t, char **s, int *len)

5
pl/boot.yap
View File

@ -814,9 +814,8 @@ not(G) :- \+ '$execute'(G).
'$find_undefp_handler'(G,M,Goal,NM), !,
'$execute0'(Goal,NM).
'$find_undefp_handler'(G,M,G,S) :-
functor(G,F,N),
recorded('$import','$import'(S,M,F,N),_),
'$find_undefp_handler'(G,M,NG,S) :-
recorded('$import','$import'(S,M,NG,G,_,_),_),
S \= M, % can't try importing from the module itself.
!,
'$exit_undefp'.

16
pl/debug.yap
View File

@ -50,10 +50,11 @@
->
M = EM
;
recorded('$import','$import'(EM,M,A,_),_)
recorded('$import','$import'(EM,M,GA,_,A,_),_),
functor(GA,NA,_)
),
!,
'$do_suspy_predicates_by_name'(A,S,EM).
'$do_suspy_predicates_by_name'(NA,S,EM).
'$suspy_predicates_by_name'(A,spy,M) :- !,
'$print_message'(warning,no_match(spy(M:A))).
'$suspy_predicates_by_name'(A,nospy,M) :-
@ -64,17 +65,18 @@
functor(T,A,N),
'$do_suspy'(S, A, N, T, M).
'$do_suspy_predicates_by_name'(A, S, M) :-
recorded('$import','$import'(EM,M,A,N),_),
functor(T,A,N),
'$do_suspy'(S, A, N, T, EM).
recorded('$import','$import'(EM,M,T0,_,A,N),_),
functor(T0,A0,N0),
'$do_suspy'(S, A0, N0, T, EM).
%
% protect against evil arguments.
%
'$do_suspy'(S, F, N, T, M) :-
recorded('$import','$import'(EM,M,F,N),_), !,
'$do_suspy'(S, F, N, T, EM).
recorded('$import','$import'(EM,M,T0,_,F,N),_), !,
functor(T0, F0, N0),
'$do_suspy'(S, F0, N0, T, EM).
'$do_suspy'(S, F, N, T, M) :-
'$undefined'(T,M), !,
( S = spy ->

6
pl/directives.yap
View File

@ -54,6 +54,8 @@
'$directive'(else).
'$directive'(elif(_)).
'$directive'(endif).
'$directive'(reexport(_)).
'$directive'(reexport(_,_)).
'$exec_directives'((G1,G2), Mode, M) :- !,
'$exec_directives'(G1, Mode, M),
@ -109,6 +111,10 @@
'$consult'(Fs, M).
'$exec_directive'(use_module(F), _, M) :-
'$load_files'(M:F, [if(not_loaded)],use_module(F)).
'$exec_directive'(reexport(F), _, M) :-
'$reexport'(F, all, M).
'$exec_directive'(reexport(F,Spec), _, M) :-
'$reexport'(F, Spec, M).
'$exec_directive'(use_module(F,Is), _, M) :-
'$load_files'(M:F, [if(not_loaded),imports(Is)],use_module(F,Is)).
'$exec_directive'(use_module(Mod,F,Is), _, _) :-

146
pl/modules.yap
View File

@ -99,7 +99,7 @@ module(N) :-
% redefining a previously-defined file, no problem.
'$add_preexisting_module_on_file'(F, F, Mod, Exports, R) :- !,
erase(R),
( recorded('$import','$import'(Mod,_,_,_),R), erase(R), fail; true),
( recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R), fail; true),
recorda('$module','$module'(F,Mod,Exports),_).
'$add_preexisting_module_on_file'(F,F0,Mod,Exports,R) :-
repeat,
@ -119,38 +119,11 @@ module(N) :-
'$import'([],_,_) :- !.
'$import'([N/K|L],M,T) :-
integer(K), atom(N), !,
( '$check_import'(M,T,N,K) ->
( T = user ->
( recordzifnot('$import','$import'(M,user,N,K),_) -> true ; true)
;
( recordaifnot('$import','$import'(M,T,N,K),_) -> true ; true )
)
;
true
),
'$do_import'(N, K, M, T),
'$import'(L,M,T).
'$import'([PS|L],_,_) :-
'$do_error'(domain_error(predicate_spec,PS),import([PS|L])).
'$check_import'(M,T,N,K) :-
recorded('$import','$import'(MI,T,N,K),R),
\+ '$module_produced by'(M,T,N,K), !,
format(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[MI:N/K,T]),
format(user_error," Do you want to import it from ~w ? [y or n] ",M),
repeat,
get0(C), '$skipeol'(C),
( C is "y" -> erase(R), !;
C is "n" -> !, fail;
write(user_error, ' Please answer with ''y'' or ''n'' '), fail
).
'$check_import'(_,_,_,_).
'$module_produced by'(M,M0,N,K) :-
recorded('$import','$import'(M,M0,N,K),_), !.
'$module_produced by'(M,M0,N,K) :-
recorded('$import','$import'(MI,M0,N,K),_),
'$module_produced by'(M,MI,N,K).
% $use_preds(Imports,Publics,Mod,M)
'$use_preds'(Imports,Publics,Mod,M) :- var(Imports), !,
'$import'(Publics,Mod,M).
@ -164,18 +137,49 @@ module(N) :-
( '$member'(N/K,Publics) -> true ;
print_message(warning,import(N/K,Mod,M,private))
),
( '$check_import'(M,Mod,N,K) ->
% format(user_error,'[ Importing ~w to ~w]~n',[M:N/K,Mod]),
% '$trace_module'(importing(M:N/K,Mod)),
(Mod = user ->
( recordzifnot('$import','$import'(M,user,N,K),_) -> true ; true )
'$do_import'(N, K, M, Mod).
'$do_import'(N, K, M, T) :-
functor(G,N,K),
'$follow_import_chain'(M,G,M0,G0),
functor(G0,N1,K),
( '$check_import'(M0,T,N1,K) ->
( T = user ->
( recordzifnot('$import','$import'(M0,user,G0,G,N,K),_) -> true ; true)
;
( recordaifnot('$import','$import'(M,Mod,N,K),_) -> true ; true )
( recordaifnot('$import','$import'(M0,T,G0,G,N,K),_) -> true ; true )
)
;
true
).
'$follow_import_chain'(M,G,M0,G0) :-
recorded('$import','$import'(M1,M,G1,G,_,_),_), !,
'$follow_import_chain'(M1,G1,M0,G0).
'$follow_import_chain'(M,G,M,G).
'$check_import'(M,T,N,K) :-
recorded('$import','$import'(MI,T,_,_,N,K),R),
\+ '$module_produced by'(M,T,N,K), !,
format(user_error,"NAME CLASH: ~w was already imported to module ~w;~n",[MI:N/K,T]),
format(user_error," Do you want to import it from ~w ? [y or n] ",M),
repeat,
get0(C), '$skipeol'(C),
( C is "y" -> erase(R), !;
C is "n" -> !, fail;
write(user_error, ' Please answer with ''y'' or ''n'' '), fail
).
'$check_import'(_,_,_,_).
'$module_produced by'(M,M0,N,K) :-
recorded('$import','$import'(M,M0,_,_,N,K),_), !.
'$module_produced by'(M,M0,N,K) :-
recorded('$import','$import'(MI,M0,G1,_,N,K),_),
functor(G1, N1, K1),
'$module_produced by'(M,MI,N1,K1).
% expand module names in a clause
'$module_expansion'(((Mod:H) :-B ),((Mod:H) :- B1),((Mod:H) :- BO),M) :- !,
'$prepare_body_with_correct_modules'(B, M, B0),
@ -279,8 +283,8 @@ module(N) :-
%
'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars) :-
% is this imported from some other module M1?
( '$imported_pred'(G, CurMod, M1) ->
'$module_expansion'(G, G1, GO, M1, MM, TM, HVars)
( '$imported_pred'(G, CurMod, GG, M1) ->
'$module_expansion'(GG, G1, GO, M1, MM, TM, HVars)
;
( '$meta_expansion'(CurMod, MM, G, GI, HVars)
;
@ -290,10 +294,9 @@ module(N) :-
).
'$imported_pred'(G, ImportingMod, ExportingMod) :-
'$imported_pred'(G, ImportingMod, G0, ExportingMod) :-
'$undefined'(G, ImportingMod),
functor(G,F,N),
recorded('$import','$import'(ExportingMod,ImportingMod,F,N),_),
recorded('$import','$import'(ExportingMod,ImportingMod,G0,G,_,_),_),
ExportingMod \= ImportingMod.
% args are:
@ -562,6 +565,67 @@ abolish_module(Mod) :-
recorded('$module','$module'(_,Mod,_),R), erase(R),
fail.
abolish_module(Mod) :-
recorded('$import','$import'(Mod,_,_,_),R), erase(R),
recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R),
fail.
abolish_module(_).
'$reexport'(ModuleSource, Spec, Module) :-
nb_getval('$consulting_file',TopFile),
(
Spec == all
->
Goal = reexport(ModuleSource)
;
Goal = reexport(ModuleSource,Spec)
),
absolute_file_name(ModuleSource, File),
'$load_files'(File, [if(not_loaded)], Goal),
recorded('$module', '$module'(FullFile, Mod, Exports),_),
atom_concat(File, _, FullFile), !,
'$convert_for_reexport'(Spec, Exports, Tab, MyExports, Goal),
'$add_to_imports'(Tab, Module, Mod),
recorded('$lf_loaded','$lf_loaded'(TopFile,TopModule,_),_),
recorded('$module', '$module'(CurrentFile, Module, ModExports), Ref),
erase(Ref),
'$append'(ModExports, MyExports, AllExports),
recorda('$module', '$module'(CurrentFile, Module, AllExports), _),
'$import'(MyExports, Module, TopModule).
'$convert_for_reexport'(all, Exports, Tab, MyExports, _) :-
'$simple_conversion'(Exports, Tab, MyExports).
'$convert_for_reexport'([P1|Ps], Exports, Tab, MyExports, Goal) :-
'$clean_conversion'([P1|Ps], Exports, Tab, MyExports, Goal).
'$convert_for_reexport'(except(List), Exports, Tab, MyExports, Goal) :-
'$neg_conversion'(Exports, List, Tab, MyExports, Goal).
'$simple_conversion'([], [], []).
'$simple_conversion'([P|Exports], [P-P|Tab], [P|MyExports]) :-
'$simple_conversion'(Exports, Tab, MyExports).
'$clean_conversion'([], _, [], [], _).
'$clean_conversion'([P1|Ps], List, [P1-P1|Tab], [P1|MyExports], Goal) :-
'$member'(P1, List), !,
'$clean_conversion'(Ps, List, Tab, MyExports, Goal).
'$clean_conversion'([(N1/A1 as N2)|Ps], List, [N1/A1-N2/A1|Tab], [N2/A1|MyExports], Goal) :-
'$member'(N1/A1, List), !,
'$clean_conversion'(Ps, List, Tab, MyExports, Goal).
'$clean_conversion'([P|_], _, _, _, Goal) :-
'$do_error'(domain_error(module_reexport_predicates,P), Goal).
'$neg_conversion'([], _, [], [], _).
'$neg_conversion'([P1|Ps], List, Tab, MyExports, Goal) :-
'$member'(P1, List), !,
'$neg_conversion'(Ps, List, Tab, MyExports, Goal).
'$neg_conversion'([N1/A1|Ps], List, [N1/A1-N2/A1|Tab], [N2/A1|MyExports], Goal) :-
'$member'(N1/A1 as N2, List), !,
'$neg_conversion'(Ps, List, Tab, MyExports, Goal).
'$neg_conversion'([P|Ps], List, [P-P|Tab], [P|MyExports], Goal) :-
'$neg_conversion'(Ps, List, Tab, MyExports, Goal).
'$add_to_imports'([], _, _).
'$add_to_imports'([N0/K0-N1/_|Tab], Mod, ModR) :-
functor(G,N0,K0),
G=..[N0|Args],
G1=..[N1|Args],
recordaifnot('$import','$import'(ModR,Mod,G,G1,N0,K0),_),
'$add_to_imports'(Tab, Mod, ModR).

17
pl/preds.yap
View File

@ -634,8 +634,7 @@ abolish(X) :-
erase(Ref),
fail.
'$abolishd'(T, M) :-
functor(T,N,A),
recorded('$import','$import'(_,M,N,A),R),
recorded('$import','$import'(_,M,_,T,_,_),R),
erase(R),
fail.
'$abolishd'(T, M) :-
@ -665,8 +664,7 @@ abolish(X) :-
erase(Ref),
fail.
'$abolishs'(T, M) :-
functor(T,N,A),
recorded('$import','$import'(_,M,N,A),R),
recorded('$import','$import'(_,M,_,_,T,_,_),R),
erase(R),
fail.
'$abolishs'(G, M) :-
@ -803,16 +801,14 @@ predicate_property(Pred,Prop) :-
'$pred_exists'(Pred,Mod), !,
'$predicate_property'(Pred,Mod,Mod,Prop).
'$predicate_property2'(Pred,Prop,Mod) :-
functor(Pred, N, K),
recorded('$import','$import'(M,Mod,N,K),_),
'$predicate_property'(Pred,M,Mod,Prop).
recorded('$import','$import'(M,Mod,NPred,Pred,_,_),_),
'$predicate_property2'(NPred,Prop,M).
'$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(M,Na,Ar),
functor(Pred, Na, Ar).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
recorded('$import','$import'(SourceMod,Mod,N,K),_),
functor(Pred, N, K).
recorded('$import','$import'(SourceMod,Mod,_,Pred,_,_),_).
'$predicate_property'(P,M,_,built_in) :-
@ -834,8 +830,7 @@ predicate_property(Pred,Prop) :-
'$predicate_property'(P,M,_,multifile) :-
'$is_multifile'(P,M).
'$predicate_property'(P,Mod,M,imported_from(Mod)) :-
functor(P,N,K),
recorded('$import','$import'(Mod,M,N,K),_).
recorded('$import','$import'(Mod,M,_,P,_,_),_).
'$predicate_property'(P,M,_,public) :-
'$is_public'(P,M).
'$predicate_property'(P,M,M,exported) :-