Merge https://github.com/vscosta/yap-6.3

C/exec.c

@@ -980,7 +980,7 @@ static bool watch_retry(Term d0 USES_REGS) {
 
     while (B->cp_ap->opc == FAIL_OPCODE)
         B = B->cp_b;
-
+    ASP = (CELL *) PROTECT_FROZEN_B(B);
     // just do the frrpest
     if (B >= B0 && !ex_mode && !active)
         return true;

C/fail_absmi_insts.h

@@ -215,10 +215,7 @@ failloop:
   }
 /* pointer to code space */
 /* or updatable variable */
-#if defined(TERM_EXTENSIONS) || defined(FROZEN_STACKS) ||                      \
-    defined(MULTI_ASSIGNMENT_VARIABLES)
   if (IsPairTerm(d1))
-#endif /* TERM_EXTENSIONS || FROZEN_STACKS || MULTI_ASSIGNMENT_VARIABLES */
   {
     register CELL flags;
     CELL *pt1 = RepPair(d1);
@@ -245,19 +242,20 @@ failloop:
       goto failloop;
     } else
 #endif /* FROZEN_STACKS */
-        if (IN_BETWEEN(H0, pt1, HR)) {
+        if (IN_BETWEEN(H0, pt1, LCL0)) {
       if (IsAttVar(pt1)) {
         goto failloop;
       } else {
         TR = pt0;
-        Yap_CleanOpaqueVariable(d1);
+
+Yap_CleanOpaqueVariable(d1);
 
         goto failloop;
       }
     }
 #ifdef FROZEN_STACKS /* TRAIL */
     /* don't reset frozen variables */
-    if (pt0 < TR_FZ)
+    else if (pt0 < TR_FZ)
       goto failloop;
 #endif
     flags = *pt1;
@@ -306,9 +304,7 @@ hence we don't need to have a lock it */
         } else {
           LogUpdClause *cl = ClauseFlagsToLogUpdClause(pt1);
           int erase;
-#if PARALLEL_YAP
           PredEntry *ap = cl->ClPred;
-#endif
           /* BB support */
           if (ap) {
 

C/globals.c

@@ -286,10 +286,9 @@ static Term GrowArena(Term arena, size_t size,
       XREGS[arity + 1] = arena;
       if (!Yap_gcl(size * sizeof(CELL), arity + 1, ENV, gc_P(P, CP))) {
           Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
-          return false;
+          return 0;
       }
       arena = XREGS[arity + 1];
-      adjust_cps(size PASS_REGS);
   }
     pt = ArenaLimit(arena);
    if (pt == HR) {
@@ -301,8 +300,8 @@ static Term GrowArena(Term arena, size_t size,
       }
         arena = XREGS[arity + 1];
      }
-    CreateNewArena(RepAppl(arena), size+old_size);
+    arena = CreateNewArena(RepAppl(arena), size+old_size);
-    return size+old_size;
+    return arena;
 }
 
 CELL *Yap_GetFromArena(Term *arenap, UInt cells, UInt arity) {
@@ -329,11 +328,11 @@ CELL *Yap_GetFromArena(Term *arenap, UInt cells, UInt arity) {
 }
 }
 
-static Term CloseArena(cell_space_t *region, Term arena,
+static Term CloseArena(cell_space_t *region,
                        UInt old_size USES_REGS) {
   UInt new_size;
-  new_size = old_size - (HR - RepAppl(arena));
+  new_size = old_size - (HR - HB);
-  arena = CreateNewArena(HR, new_size);
+  Term arena = CreateNewArena(HR, new_size);
   exit_cell_space( region );
   return arena;
 }
@@ -649,10 +648,10 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
     cell_space_t cspace;
     int res = 0, restarts = 0;
     Term tn;
+    old_size = ArenaSz(arena);
 
     restart:
     enter_cell_space(&cspace);
-    old_size = ArenaSz(arena);
     t = Deref(t);
     if (IsVarTerm(t)) {
         ASP = ArenaLimit(arena);
@@ -668,12 +667,12 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
                                          Hi PASS_REGS)) < 0) {
                 goto error_handler;
             }
-            *newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+            *newarena = CloseArena(&cspace, old_size PASS_REGS);
             return Hi[0];
         }
 #endif
         if (share && VarOfTerm(t) > ArenaPt(arena)) {
-            *newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+            *newarena = CloseArena(&cspace, old_size PASS_REGS);
             return t;
         }
         tn = MkVarTerm();
@@ -681,7 +680,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
             res = -1;
             goto error_handler;
         }
-	*newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+	*newarena = CloseArena(&cspace, old_size PASS_REGS);
         return tn;
     } else if (IsAtomOrIntTerm(t)) {
         return t;
@@ -703,7 +702,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
                                      Hi PASS_REGS)) < 0) {
             goto error_handler;
         }
-        *newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+        *newarena = CloseArena(&cspace, old_size PASS_REGS);
         return tf;
     } else {
         Functor f;
@@ -724,7 +723,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
         if (IsExtensionFunctor(f)) {
             switch ((CELL) f) {
                 case (CELL) FunctorDBRef:
-                    *newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+                    *newarena = CloseArena(&cspace, old_size PASS_REGS);
                     return t;
                 case (CELL) FunctorLongInt:
                     if (HR > ASP - (MIN_ARENA_SIZE + 3)) {
@@ -783,32 +782,32 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
                 goto error_handler;
             }
         }
-        *newarena = CloseArena(&cspace, arena, old_size PASS_REGS);
+        *newarena = CloseArena(&cspace, old_size PASS_REGS);
         return tf;
     }
     error_handler:
     XREGS[arity + 1] = t;
-    XREGS[arity + 2] = arena;
-    exit_cell_space(&cspace);
     switch (res) {
     case -1:
       if (arena == LOCAL_GlobalArena)
         LOCAL_GlobalArenaOverflows++;
       restarts++;
       min_grow += (restarts < 16 ? 16*1024*restarts*restarts : 128*1024*1024);
-      CreateNewArena (RepAppl(arena),old_size);
+      HR = HB;
-      if((arena=GrowArena(arena, min_grow, arity + 2, &cspace PASS_REGS))==0) {
+      arena = CloseArena (&cspace, old_size PASS_REGS);
+      if((arena=GrowArena(arena, min_grow, arity + 1, &cspace PASS_REGS))==0) {
         Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
         return 0L;
       }
-      break;
+      t = XREGS[arity+1];
+            enter_cell_space(&cspace);
+            old_size = ArenaSz(arena);
+            break;
     default: /* temporary space overflow */
-      return 0;
+        exit_cell_space(&cspace);
+            return 0;
       
     }
-  enter_cell_space(&cspace);
-  arena = Deref(XREGS[arity + 2]);
-  t = XREGS[arity + 1];
   goto restart;
 }
 
@@ -836,7 +835,7 @@ restart:
 //      CELL *old_top = ArenaLimit(*nsizeof(CELL)ewarena);
       if (arena == LOCAL_GlobalArena)
         LOCAL_GlobalArenaOverflows++;
-          CreateNewArena (RepAppl(arena),old_size);
+          arena = CreateNewArena (RepAppl(arena),old_size);
           if ((arena=GrowArena(arena, Nar * sizeof(CELL),
                            arity + 1, &cells PASS_REGS))==0) {
         Yap_Error(RESOURCE_ERROR_STACK, TermNil,
@@ -856,7 +855,7 @@ restart:
       HB0[i] = init;
     }
   }
-  *newarena = CloseArena(&cells, arena, ArenaSz(arena) PASS_REGS);
+  *newarena = CloseArena(&cells, ArenaSz(arena) PASS_REGS);
   return tf;
 }
 
@@ -1658,19 +1657,18 @@ static Int p_nb_queue_enqueue(USES_REGS1) {
   } else {
     min_size = 0L;
   }
-  to = CopyTermToArena(ARG2, arena, FALSE, TRUE, 2, qd + QUEUE_ARENA,
+  Term newarena = arena;
+  to = CopyTermToArena(Deref(ARG2), arena, FALSE, TRUE, 2, &newarena,
                        min_size PASS_REGS);
   if (to == 0L)
     return FALSE;
   cell_space_t cspace;
-  qd = GetQueue(ARG1, "enqueue");
+  arena = newarena;
-  arena = GetQueueArena(qd, "enqueue");
   /* garbage collection ? */
-  enter_cell_space(&cspace);
   HR = HB = ArenaPt(arena);
   old_sz = ArenaSz(arena);
+  qd = GetQueue(ARG1, "enqueue");
   qsize = IntegerOfTerm(qd[QUEUE_SIZE]);
-
   qd[QUEUE_SIZE] = Global_MkIntegerTerm(qsize + 1);
   if (qsize == 0) {
     qd[QUEUE_HEAD] = AbsPair(HR);
@@ -1681,7 +1679,7 @@ static Int p_nb_queue_enqueue(USES_REGS1) {
   RESET_VARIABLE(HR);
   qd[QUEUE_TAIL] = (CELL)HR;
   HR++;
-  qd[QUEUE_ARENA] = CloseArena(&cspace, qd[ QUEUE_ARENA ], old_sz PASS_REGS);
+  qd[QUEUE_ARENA] =CloseArena(&cspace, old_sz PASS_REGS);
   return TRUE;
 }
 
@@ -1705,7 +1703,7 @@ static Int p_nb_queue_dequeue(USES_REGS1) {
   /* garbage collection ? */
   enter_cell_space(&cspace);
   qd[QUEUE_SIZE] = Global_MkIntegerTerm(qsz - 1);
-  qd[QUEUE_ARENA] = CloseArena(&cspace, arena, old_sz PASS_REGS);
+  qd[QUEUE_ARENA] = CloseArena(&cspace, old_sz PASS_REGS);
   return Yap_unify(out, ARG2);
 }
 
@@ -1955,7 +1953,7 @@ restart:
     old_sz = ArenaSz(arena);
     HR = HB = ArenaPt(arena);
     qd[HEAP_MAX] = Global_MkIntegerTerm(hmsize);
-    qd[HEAP_ARENA] = CloseArena(&cspace, arena, old_sz PASS_REGS);
+    qd[HEAP_ARENA] = CloseArena(&cspace, old_sz PASS_REGS);
     goto restart;
   }
   arena = qd[HEAP_ARENA];
@@ -1966,14 +1964,14 @@ restart:
                          mingrow PASS_REGS);
   qd = GetHeap(ARG1, "add_to_heap");
   arena = qd[HEAP_ARENA];
-  to = CopyTermToArena(ARG3, arena, FALSE, TRUE, 3, qd + HEAP_ARENA,
+  to = CopyTermToArena(ARG3, arena, FALSE, TRUE, 3, &arena,
                        mingrow PASS_REGS);
   /* protect key in ARG2 in case there is an overflow while copying to */
   key = ARG2;
   if (key == 0 || to == 0L)
     return FALSE;
   qd = GetHeap(ARG1, "add_to_heap");
-  arena = qd[HEAP_ARENA];
+  qd[HEAP_ARENA] = arena;
   /* garbage collection ? */
   enter_cell_space(&cspace);
   HR = HB = ArenaPt(arena);
@@ -1987,7 +1985,7 @@ restart:
       gsiz = 1024;
     }
     ARG3 = to;
-      CreateNewArena (RepAppl(arena),old_sz);
+      arena = CreateNewArena (RepAppl(arena),old_sz);
     if ((arena=GrowArena(arena, gsiz, 3, &cspace PASS_REGS))==0) {
       Yap_Error(RESOURCE_ERROR_STACK, arena, LOCAL_ErrorMessage);
       return 0L;
@@ -2003,7 +2001,7 @@ restart:
   pt[2 * hsize + 1] = to;
   PushHeap(pt, hsize);
   qd[HEAP_SIZE] = Global_MkIntegerTerm(hsize + 1);
-  qd[HEAP_ARENA] = CloseArena(&cspace, qd[ HEAP_ARENA ], old_sz PASS_REGS);
+  qd[HEAP_ARENA] = CloseArena(&cspace, old_sz PASS_REGS);
   return TRUE;
 }
 
@@ -2347,7 +2345,7 @@ cell_space_t cspace;
     }
     ARG3 = to;
     /*    fprintf(stderr,"growing %ld cells\n",(unsigned long int)gsiz);*/
-      CreateNewArena (RepAppl(arena),old_sz);
+      arena = CreateNewArena (RepAppl(arena),old_sz);
     if (!GrowArena(arena, gsiz, 3, &cspace PASS_REGS)) {
       Yap_Error(RESOURCE_ERROR_STACK, arena, LOCAL_ErrorMessage);
       return 0L;
@@ -2360,7 +2358,7 @@ cell_space_t cspace;
   pt = qd + HEAP_START;
   PushBeam(pt, pt + 2 * hmsize, hsize, key, to);
   qd[HEAP_SIZE] = Global_MkIntegerTerm(hsize + 1);
-  qd[HEAP_ARENA] = CloseArena(&cspace, qd[ HEAP_ARENA ], old_sz PASS_REGS);
+  qd[HEAP_ARENA] = CloseArena(&cspace, old_sz PASS_REGS);
   return TRUE;
 }
 
@@ -2383,7 +2381,7 @@ static Int p_nb_beam_del(USES_REGS1) {
   /* garbage collection ? */
  enter_cell_space(&cspace);
   qd[HEAP_SIZE] = Global_MkIntegerTerm(qsz - 1);
-  qd[ HEAP_ARENA] = CloseArena(&cspace, arena, old_sz PASS_REGS);
+  qd[ HEAP_ARENA] = CloseArena(&cspace, old_sz PASS_REGS);
   tk = qd[HEAP_START];
   tv = DelBeamMin(qd + HEAP_START,
                   qd + (HEAP_START + 2 * IntegerOfTerm(qd[HEAP_MAX])), qsz);

C/stdpreds.c

@@ -1576,6 +1576,7 @@ void Yap_InitCPreds(void) {
   Yap_InitDBPreds();
   Yap_InitErrorPreds();
   Yap_InitExecFs();
+  Yap_InitErrorPreds();
   Yap_InitGlobals();
   Yap_InitInlines();
   Yap_InitIOPreds();

C/write.c

@@ -77,7 +77,6 @@ typedef struct write_globs {
   UInt  last_atom_minus;
   UInt MaxDepth, MaxArgs;
   wtype lw;
-  CELL *visited, *visited0, *visited_top;
 } wglbs;
 
 #define lastw wglb->lw
@@ -732,9 +731,10 @@ static void write_list(Term t, int direction, int depth,
   struct rewind_term nrwt;
   nrwt.parent = rwt;
   nrwt.u_sd.s.ptr = 0;
-  bool loop = true;
+
-  while (loop) {
+  while (1) {
-loop = false;
+
+    PROTECT(t, writeTerm(HeadOfTerm(t), 999, depth + 1, FALSE, wglb, &nrwt));
     ti = TailOfTerm(t);
     if (IsVarTerm(ti))
       break;
@@ -786,6 +786,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
   if (IsVarTerm(t)) {
     write_var((CELL *)t, wglb, &nrwt);
   } else if (IsIntTerm(t)) {
+
     wrputn((Int)IntOfTerm(t), wglb);
   } else if (IsAtomTerm(t)) {
     putAtom(AtomOfTerm(t), wglb->Quote_illegal, wglb);
@@ -876,8 +877,7 @@ static void writeTerm(Term t, int p, int depth, int rinfixarg,
         return;
       }
     }
-
+    if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) {
-      if (!wglb->Ignore_ops && Arity == 1 && Yap_IsPrefixOp(atom, &op, &rp)) {
       Term tright = ArgOfTerm(1, t);
       int bracket_right = !IsVarTerm(tright) && IsAtomTerm(tright) &&
                           Yap_IsOp(AtomOfTerm(tright));
@@ -1110,8 +1110,8 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
   wglb.lw = separator;
   Term tp;
   
-   if ( 0&& (flags & Handle_cyclics_f) ){
+   if ((flags & Handle_cyclics_f) ){
-    tp = Yap_BreakCyclesInTerm(t PASS_REGS);
+     tp = Yap_CyclesInTerm(t PASS_REGS);
    } else {
      tp = t;
    }

H/Yapproto.h

@@ -175,6 +175,7 @@ extern int Yap_DBTrailOverflow(void);
 extern CELL Yap_EvalMasks(Term, CELL *);
 extern void Yap_InitBackDB(void);
 extern void Yap_InitDBPreds(void);
+extern void Yap_InitDBLoadPreds(void);
 
 /* errors.c */
 #if DEBUG

H/absmi.h

@@ -31,6 +31,12 @@
 #define register
 #endif
 
+
+#if TABLING
+#define FROZEN_STACKS 1
+//#define MULTIPLE_STACKS 1
+#endif
+
 /***************************************************************
  * Macros for register manipulation                             *
  ***************************************************************/

H/amidefs.h

@@ -48,6 +48,7 @@ typedef struct regstore_t *regstruct_ptr;
 
 #endif
 
+
 typedef Int (*CPredicate)(CACHE_TYPE1);
 
 typedef Int (*CmpPredicate)(Term, Term);

H/trim_trail.h

@@ -1,17 +1,17 @@
 
 #ifdef FROZEN_STACKS
+
+#define RESET_TRAIL_ENTRY(pt)  { TrailTerm(pt) = (CELL)(pt); TrailVal(pt) = (CELL)(pt); }
 {
-  tr_fr_ptr pt0, pt1, pbase, ptop;
+  tr_fr_ptr  pt1, pbase;
-  pbase = B->cp_tr, ptop = TR;
+  pbase = B->cp_tr;
-  pt0 = pt1 = TR - 1;
+  pt1 = TR - 1;
   while (pt1 >= pbase) {
     BEGD(d1);
     d1 = TrailTerm(pt1);
     if (IsVarTerm(d1)) {
-      if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) {
+      if (d1 >= (CELL)HBREG && d1 < Unsigned(HR)) {
-        TrailTerm(pt0) = d1;
+          RESET_TRAIL_ENTRY(pt1);
-        TrailVal(pt0) = TrailVal(pt1);
-        pt0--;
       }
       pt1--;
     } else if (IsPairTerm(d1)) {
@@ -28,14 +28,14 @@
         /* skip, this is a problem because we lose information,
            namely active references */
         pt1 = (tr_fr_ptr)pt;
-      } else if (IN_BETWEEN(H0, pt, HR) && IsApplTerm(HeadOfTerm(d1))) {
+      } else if (IN_BETWEEN(H0, pt, LCL0) && IsApplTerm(HeadOfTerm(d1))) {
         Term t = HeadOfTerm(d1);
         Functor f = FunctorOfTerm(t);
         if (f == FunctorBigInt) {
           Int tag = Yap_blob_tag(t);
           GLOBAL_OpaqueHandlers[tag].cut_handler(d1);
-        } else {
+           RESET_TRAIL_ENTRY(pt1);
-          pt0--;
+
         }
         pt1--;
         continue;
@@ -48,6 +48,7 @@
 
         LOCK(ap->PELock);
         DEC_CLREF_COUNT(cl);
+                  RESET_TRAIL_ENTRY(pt1);
         cl->ClFlags &= ~InUseMask;
         erase = (cl->ClFlags & (ErasedMask | DirtyMask)) && !(cl->ClRefCount);
         if (erase) {
@@ -59,43 +60,23 @@
             Yap_CleanUpIndex(cl);
         }
         UNLOCK(ap->PELock);
-      } else {
-        TrailTerm(pt0) = d1;
-        TrailVal(pt0) = TrailVal(pt1);
-        pt0--;
       }
       pt1--;
     } else if (IsApplTerm(d1)) {
       if (IN_BETWEEN(HBREG, RepAppl(d1), B->cp_b)) {
-        /* deterministic binding to multi-assignment variable */
+                  RESET_TRAIL_ENTRY(pt1);
-        pt1 -= 2;
+                  pt1--;
+          RESET_TRAIL_ENTRY(pt1);
+/* deterministic binding to multi-assignment variable */
+        pt1 --;
       } else {
-        TrailVal(pt0) = TrailVal(pt1);
-        TrailTerm(pt0) = d1;
-        TrailVal(pt0 - 1) = TrailVal(pt1 - 1);
-        TrailTerm(pt0 - 1) = TrailTerm(pt1 - 1);
-        pt0 -= 2;
         pt1 -= 2;
       }
     } else {
-      TrailTerm(pt0) = d1;
+       pt1--;
-      TrailVal(pt0) = TrailVal(pt1);
-      pt0--;
-      pt1--;
     }
     ENDD(d1);
   }
-  if (pt0 != pt1) {
-    int size;
-    pt0++;
-    size = ptop - pt0;
-    memmove(pbase, pt0, size * sizeof(struct trail_frame));
-    if (ptop != TR) {
-      memmove(pbase + size, ptop, (TR - ptop) * sizeof(struct trail_frame));
-      size += (TR - ptop);
-    }
-    TR = pbase + size;
-  }
 }
 #else
 {

packages/ProbLog/problog.yap

@@ -845,7 +845,7 @@ term_expansion_intern(Head :: Goal,Module,problog:ProbFact) :-
 
 % handles probabilistic facts
 term_expansion_intern(P :: Goal,Module,problog:ProbFact) :-
-	copy_term((P,Goal),(P_Copy,Goal_Copy)),
+    copy_term((P,Goal),(P_Copy,Goal_Copy)),
 	functor(Goal, Name, Arity),
 	atomic_concat([problog_,Name],ProblogName),
 	Goal =.. [Name|Args],

packages/ProbLog/problog/lbdd.yap

@@ -91,6 +91,7 @@ gradient(QueryID, g, Slope) :-
 query_probabilities( DBDD, Prob) :-
     DBDD = bdd(Dir, Tree, _MapList),
     findall(P, evalp(Tree,P), [Prob0]),
+   % nonvar(Prob0),
     (Dir == 1 -> Prob0 = Prob ;  Prob is 1.0-Prob0).
 
 evalp( Tree, Prob0) :-
@@ -104,7 +105,7 @@ query_gradients(bdd(Dir, Tree, MapList),I,IProb,Grad) :-
 
 evalp( pn(P, _-X, PL, PR), _,P ):-
     P is X*PL+ (1.0-X)*(1.0-PR).
-evalp( pp(P, _-X, PL, PR), _,P ):-
+evalp( pp(P, _-X, PL, PR), _,P ):-  
     P is X*PL+ (1.0-X)*PR.
 
 evalg( I, pp(P-G, J-X, L, R), _, G ):-

packages/ProbLog/problog_examples/learn_graph_lbdd.pl

@@ -14,20 +14,9 @@
 % will run 20 iterations of learning with default settings
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
-:- use_module('../problog_lbfgs').
+:- use_module('../problog_learning_lbdd').
 
 
- :- if(true).
-
- :- use_module('kbgraph').
-
-
-%%%%
-% background knowledge
-%%%% 
-% definition of acyclic path using list of visited nodes
-
-:- else. 
 
 :- Query=path(X,Y), set_problog_flag(init_method,(Query,K,Bdd,problog:problog_exact_lbdd(Query,Bdd))).
 
@@ -48,7 +37,6 @@ edge(X,Y) :- dir_edge(X,Y).
 absent(_,[]).
 absent(X,[Y|Z]):-X \= Y, absent(X,Z).
 
-:- endif.
 
 %%%%
 % probabilistic facts 

packages/ProbLog/problog_examples/learn_graph_lbfgs.pl

@@ -0,0 +1,113 @@
+%%% -*- mode: Prolog; -*-
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% ProbLog program describing a probabilistic graph
+% (running example from ProbLog presentations)
+% $Id: learn_graph.pl 4875 2010-10-05 15:28:35Z theo $
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% example for parameter learning with LeProbLog
+%
+% training and test examples are included at the end of the file
+% query ?- do_learning(20).
+% will run 20 iterations of learning with default settings
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+:- use_module('../problog_lbfgs').
+
+
+ :- if(true).
+
+ :- use_module('kbgraph').
+
+
+%%%%
+% background knowledge
+%%%% 
+% definition of acyclic path using list of visited nodes
+
+:- else. 
+
+:- Query=path(X,Y), set_problog_flag(init_method,(Query,K,Bdd,problog:problog_exact_lbdd(Query,Bdd))).
+
+path(X,Y) :- path(X,Y,[X],_).
+
+path(X,X,A,A).
+path(X,Y,A,R) :- 
+  X\==Y, 
+  edge(X,Z), 
+  absent(Z,A), 
+  path(Z,Y,[Z|A],R).
+
+% using directed edges in both directions
+edge(X,Y) :- dir_edge(Y,X).
+edge(X,Y) :- dir_edge(X,Y).
+
+% checking whether node hasn't been visited before
+absent(_,[]).
+absent(X,[Y|Z]):-X \= Y, absent(X,Z).
+
+:- endif.
+
+%%%%
+% probabilistic facts 
+% - probability represented by t/1 term means learnable parameter
+% - argument of t/1 is real value (used to compare against in evaluation when known), use t(_) if unknown
+%%%%
+t(0.9)::dir_edge(1,2).
+t(0.8)::dir_edge(2,3).
+t(0.6)::dir_edge(3,4).
+t(0.7)::dir_edge(1,6).
+t(0.5)::dir_edge(2,6).
+t(0.4)::dir_edge(6,5).
+t(0.7)::dir_edge(5,3).
+t(0.2)::dir_edge(5,4).
+
+%%%%%%%%%%%%%%
+% training examples of form example(ID,Query,DesiredProbability) 
+%%%%%%%%%%%%%%
+
+example(1,path(1,2),0.94).
+example(2,path(1,3),0.81).
+example(3,path(1,4),0.54).
+example(4,path(1,5),0.70).
+example(5,path(1,6),0.87).
+example(6,path(2,3),0.85).
+example(7,path(2,4),0.57).
+example(8,path(2,5),0.72).
+example(9,path(2,6),0.86).
+example(10,path(3,4),0.66).
+example(11,path(3,5),0.80).
+example(12,path(3,6),0.75).
+example(13,path(4,5),0.57).
+example(14,path(4,6),0.51).
+example(15,path(5,6),0.69).
+% some examples for learning from proofs:
+/*example(16,(dir_edge(2,3),dir_edge(2,6),dir_edge(6,5),dir_edge(5,4)),0.032).
+example(17,(dir_edge(1,6),dir_edge(2,6),dir_edge(2,3),dir_edge(3,4)),0.168).
+example(18,(dir_edge(5,3),dir_edge(5,4)),0.14).
+example(19,(dir_edge(2,6),dir_edge(6,5)),0.2).
+example(20,(dir_edge(1,2),dir_edge(2,3),dir_edge(3,4)),0.432).
+*/
+%%%%%%%%%%%%%%
+% test examples of form test_example(ID,Query,DesiredProbability) 
+% note: ID namespace is shared with training example IDs
+%%%%%%%%%%%%%%
+
+test_example(21,path(2,1),0.94).
+test_example(22,path(3,1),0.81).
+test_example(23,path(4,1),0.54).
+test_example(24,path(5,1),0.70).
+test_example(25,path(6,1),0.87).
+test_example(26,path(3,2),0.85).
+test_example(27,path(4,2),0.57).
+test_example(28,path(5,2),0.72).
+test_example(29,path(6,2),0.86).
+test_example(30,path(4,3),0.66).
+test_example(31,path(5,3),0.80).
+test_example(32,path(6,3),0.75).
+test_example(33,path(5,4),0.57).
+test_example(34,path(6,4),0.51).
+test_example(35,path(6,5),0.69).
+

packages/ProbLog/problog_lbfgs.yap

@@ -553,7 +553,7 @@ empty_bdd_directory.
 init_queries :-
     empty_bdd_directory,
 	format_learning(2,'Build BDDs for examples~n',[]),
-	forall(user:test_example(ID,Query,_Prob,_),init_one_query(ID,Query,test)),	
+	forall(user:test_example(ID,Query,_Prob,_),init_one_query(ID,Query,test)),
 	forall(user:example(ID,Query,_Prob,_),init_one_query(ID,Query,training)).
 
 bdd_input_file(Filename) :-
@@ -835,7 +835,7 @@ update_values :-
 	% delete old values
 	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 	retractall(query_probability_intern(_,_)),
-	retractall(query_gradient_intern(_,_,_,_)),	
+	retractall(query_gradient_intern(_,_,_,_)),
 
 
 	assertz(values_correct).
@@ -847,7 +847,7 @@ update_values :-
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 % start calculate gradient
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-user:evaluate(LLH_Training_Queries, X,Grad,N,_,_) :- 
+user:evaluate(LLH_Training_Queries, X,Grad,N,_,_) :-
     %Handle = user_error,
     N1 is N-1,
     forall(between(0,N1,I),(Grad[I]<==0.0)),
@@ -893,13 +893,11 @@ compute_gradient( Grad, X, Slope, LL) :-
 	BDD = bdd(_,_,MapList),
 	MapList = [_|_],
 	bind_maplist(MapList, Slope, X),
-%writeln(QueryID:MapList),
 	query_probabilities( BDD, BDDProb),
 	(isnan(BDDProb) -> writeln((nan::QueryID)), fail;true),
-writeln(BDDProb),
 	LL is (BDDProb-QueryProb)*(BDDProb-QueryProb),
     forall(
-	query_gradients(BDD,I,IProb,GradValue), 
+	query_gradients(BDD,I,IProb,GradValue),
 	gradient_pair(BDDProb, QueryProb, Grad, GradValue, I, IProb)
     ).
 
@@ -925,8 +923,9 @@ wrap( _X, _Grad, _GradCount).
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 user:progress(FX,_X,_G, _X_Norm,_G_Norm,_Step,_N,_CurrentIteration,_Ls,-1) :-
     FX < 0, !,
-    format('stopped on bad FX=~4f~n',[FX]).
+    format('Bad FX=~4f~n',[FX]).
 user:progress(FX,X,G,X_Norm,G_Norm,Step,_N, LBFGSIteration,Ls,0) :-
+writeln(fx=FX),
      problog_flag(sigmoid_slope,Slope),
      save_state(X, Slope, G),
     logger_set_variable(mse_trainingset, FX),
@@ -946,22 +945,6 @@ save_state(X,Slope,_Grad) :-
     	tunable_fact(FactID,_GroundTruth),
     	set_tunable(FactID,Slope,X),
     	fail.
-save_state(X, Slope, _) :-
-	    user:example(QueryID,_Query,_QueryProb),
-	    recorded(QueryID,BDD,_),
-	    BDD = bdd(_,_,MapList),
-	    bind_maplist(MapList, Slope, X),
-	    query_probabilities( BDD, BDDProb),
-	    assert( query_probability_intern(QueryID,BDDProb)),
-	fail.
-save_state(X, Slope, _) :-
-	    user:test_example(QueryID,_Query,_QueryProb),
-	    recorded(QueryID,BDD,_),
-	    BDD = bdd(_,_,MapList),
-	    bind_maplist(MapList, Slope, X),
-	    query_probabilities( BDD, BDDProb),
-	    assert( query_probability_intern(QueryID,BDDProb)),
-	fail.
 save_state(_X, _Slope, _).
 
 %========================================================================

packages/ProbLog/problog_learning.yap

@@ -710,7 +710,7 @@ update_values :-
 %=
 %========================================================================
 
-    listing(
+ update_query_cleanup(QueryID) :-
 	(
 	 (query_is_similar(QueryID,_) ; query_is_similar(_,QueryID))
 	->
@@ -893,7 +893,6 @@ ground_truth_difference :-
 %=
 %= -Float
 %========================================================================
-
 mse_trainingset_only_for_linesearch(MSE) :-
 	update_values,
 

packages/ProbLog/problog_learning_lbdd.yap

@@ -228,6 +228,7 @@
 :- use_module('problog/utils_lbdd').
 :- use_module('problog/utils').
 :- use_module('problog/tabling').
+:- use_module('problog/lbdd').
 
 % used to indicate the state of the system
 :- dynamic(values_correct/0).

packages/yap-lbfgs/lbfgs.pl

@@ -24,6 +24,7 @@
 		 lbfgs_initialize/4,
 		 lbfgs_run/3,
 
+		 lbfgs_fx/1,
 		 lbfgs_finalize/1,
 
 		 lbfgs_set_parameter/2,
@@ -180,7 +181,8 @@ lbfgs_finalize(_N).
 run the algorithm. output the final score of the function being optimised
 */
 lbfgs_run(N,X,FX) :-
-    lbfgs(N,X, FX).
+    lbfgs(N,X),
+    lbfgs_fx(FX).
 
 
 

packages/yap-lbfgs/yap_lbfgs.c

@@ -35,7 +35,7 @@ X_API void init_lbfgs_predicates(void);
 YAP_Functor fevaluate, fprogress, fmodule, ffloats;
 YAP_Term tuser;
 
-lbfgsfloatval_t *x_p;
+lbfgsfloatval_t *x_p, f_x;
 
 static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x,
                                 lbfgsfloatval_t *g_tmp, const int n,
@@ -43,7 +43,7 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x,
   YAP_Term call;
   YAP_Bool result;
   lbfgsfloatval_t rc=0.0;
-  YAP_Term v=YAP_MkVarTerm(), t1, t12;
+  YAP_Term t12;
   YAP_Term t[6], t2[2];
 
   YAP_Term t_0 = YAP_MkIntTerm((YAP_Int)&rc);
@@ -60,8 +60,6 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x,
   t2[1] = YAP_MkApplTerm(fevaluate, 6, t);
 
   call = YAP_MkApplTerm(fmodule, 2, t2);
-
-  int sl = YAP_InitSlot(v);
   // lbfgs_status=LBFGS_STATUS_CB_EVAL;
   result = YAP_RunGoalOnce(call);
   // lbfgs_status=LBFGS_STATUS_RUNNING;
@@ -72,8 +70,6 @@ static lbfgsfloatval_t evaluate(void *instance, const lbfgsfloatval_t *x,
     return FALSE;
   }
    YAP_ShutdownGoal(true);
-  YAP_RecoverSlots(1, sl);
-  fprintf(stderr,"%gxo\n",rc);
   return rc;
 }
 
@@ -183,7 +179,7 @@ value will terminate the optimization process.
  */
 static YAP_Bool p_lbfgs(void) {
   YAP_Term t1 = YAP_ARG1, t;
-  int n, sl;
+  int n;
   lbfgsfloatval_t *x;
   lbfgsfloatval_t fx;
 
@@ -196,7 +192,6 @@ static YAP_Bool p_lbfgs(void) {
   if (n < 1) {
     return FALSE;
   }
-  sl = YAP_InitSlot(YAP_ARG3);
 
   if (!x_p)
    x_p = lbfgs_malloc(n+1);
@@ -206,15 +201,17 @@ static YAP_Bool p_lbfgs(void) {
   lbfgs_parameter_t *param = &parms;
   void *ui = NULL; //(void *)YAP_IntOfTerm(YAP_ARG4);
   int ret = lbfgs(n, x, &fx, evaluate, progress, ui, param);
-  t = YAP_GetFromSlot(sl);
+  f_x = fx;
-  YAP_Unify(t, YAP_MkFloatTerm(fx));
+if (ret == 0)
-  YAP_RecoverSlots(1, sl);
-  if (ret == 0)
     return true;
   fprintf(stderr, "optimization terminated with code %d\n ",ret);
   return true;
 }
 
+static YAP_Bool lbfgs_fx(void) {
+    return YAP_Unify(YAP_ARG1, YAP_MkFloatTerm(f_x));
+}
+
 static YAP_Bool lbfgs_grab(void) {
   int n = YAP_IntOfTerm(YAP_ARG1);
 
@@ -468,8 +465,9 @@ X_API void init_lbfgs_predicates(void) {
   lbfgs_parameter_init(&parms);
 
   YAP_UserCPredicate("lbfgs_grab", lbfgs_grab, 2);
-  YAP_UserCPredicate("lbfgs", p_lbfgs, 3);
+  YAP_UserCPredicate("lbfgs", p_lbfgs, 2);
-  YAP_UserCPredicate("lbfgs_release", lbfgs_release, 1);
+    YAP_UserCPredicate("lbfgs_release", lbfgs_release, 1);
+    YAP_UserCPredicate("lbfgs_fx", lbfgs_fx, 1);
 
   YAP_UserCPredicate("lbfgs_defaults", lbfgs_defaults, 0);
   

pl/consult.yap

@@ -1011,7 +1011,7 @@ prolog_load_context(file, FileName) :-
         ).
 prolog_load_context(module, X) :-
         '__NB_getval__'('$consulting_file', _, fail),
-        'current_module'(X).
+        current_source_module(X,X).
 prolog_load_context(source, F0) :-
         ( source_location(F0, _) /*,
                                    '$input_context'(Context),

pl/imports.yap

@@ -35,20 +35,17 @@ fail.
 % parent module mechanism
 %% system has priority
 '$get_predicate_definition'(_ImportingMod:G,prolog:G) :-
-    nonvar(G),
+    nonvar(G).
-    '$pred_exists'(G,prolog).
 %% I am there, no need to import
 '$get_predicate_definition'(Mod:Pred,Mod:Pred) :-
-    nonvar(Pred),
+    nonvar(Pred).
-    '$pred_exists'(Pred, Mod).
 %% export table
 '$get_predicate_definition'(ImportingMod:G,ExportingMod:G0) :-
     recorded('$import','$import'(ExportingMod,ImportingMod,G0,G,_,_),_).
 %% parent/user
-'$get_predicate_definition'(ImportingMod:G,ExportingMod:G0) :-
+'$get_predicate_definition'(ImportingMod:G,PMod:G) :-
     ( '$parent_module'(ImportingMod, PMod) ; PMod = user ),
-    ImportingMod \= PMod,
+    ImportingMod \= PMod.
-    '$get_predicate_definition'(PMod:G, ExportingMod:G0).
 %% autoload`
 %'$get_predicate_definition'(ImportingMod:G,ExportingMod:G) :-
 %    current_prolog_flag(autoload, true),
@@ -57,22 +54,25 @@ fail.
 
 '$predicate_definition'(Imp:Pred,Exp:NPred) :-
     '$predicate_definition'(Imp:Pred,[],Exp:NPred),
+    '$pred_exists'(NPred,Exp),
 %writeln((Imp:Pred -> Exp:NPred )).
     !.
 
 '$one_predicate_definition'(Imp:Pred,Exp:NPred) :-
-    '$predicate_definition'(Imp:Pred,[],Exp:NPred),
+    '$get_predicate_definition'(Imp:Pred,[],Exp:NPred),
+    '$pred_exists'(NPred,Exp),
 %writeln((Imp:Pred -> Exp:NPred )).
     !.
 '$one_predicate_definition'(Exp:Pred,Exp:Pred).
     
 '$predicate_definition'(M0:Pred0,Path,ModF:PredF) :-
     '$get_predicate_definition'(M0:Pred0, Mod:Pred),
-    \+ lists:member(Mod:Pred,Path),
     (
-	'$predicate_definition'(Mod:Pred,[Mod:Pred|Path],ModF:PredF)
+    '$pred_exists'(Pred,Mod), Mod = ModF, Pred = PredF
     ;
-    Mod = ModF, Pred = PredF
+    \+ lists:member(Mod:Pred,Path),
+      '$predicate_definition'(Mod:Pred,[Mod:Pred|Path], ModF:PredF)
+
     ).
 
 %

pl/meta.yap

@@ -405,6 +405,10 @@ meta_predicate(P) :-
     '$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
     '$expand_goals'(C,C1,CO,HM,SM,BM,HVars),
     '$clean_cuts'(AO0, DCP, AO).
+'$expand_goals'(forall(A,B), forall(A1,B1),
+(A0 , ( B0 -> fail ; true ) -> fail; true ),HM,SM,BM,HVars) :- !,
+    '$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
+    '$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
 '$expand_goals'((A*->B;C),(A1*->B1;C1),
 		('$current_choice_point'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !,
     '$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),

pl/preds.yap

@@ -490,7 +490,7 @@ current_predicate(A0,T0) :-
     '$current_predicate'(A,M,T,_),
     functor(T, A, _)
     ;
-    '$get_predicate_definition'(M:T,M1:_T1),
+    '$predicate_definition'(M:T,M1:_T1),
     M\=M1,
     functor(T, A, _)
     ).

pl/top.yap

@@ -602,7 +602,7 @@ write_query_answer( Bindings ) :-
 	expand_goal(M:G, NG),
 	must_be_callable(NG),
 
-	    '$yap_strip_module'(NG,NM,NC),
+	    '$yap_strip_module'(M:NG,NM,NC),
         '$call'(NC,CP,G0,NM).
 '$call'((X,Y),CP,G0,M) :- !,
         '$call'(X,CP,G0,M),
@@ -614,8 +614,11 @@ write_query_answer( Bindings ) :-
 	 '$call'(Y,CP,G0,M)
 	).
 '$call'((X*->Y),CP,G0,M) :- !,
-	'$call'(X,CP,G0,M),
+	(
-	'$call'(Y,CP,G0,M).
+	'$call'(X,CP,G0,M)
+	*->
+	'$call'(Y,CP,G0,M)
+	).
 '$call'((X->Y; Z),CP,G0,M) :- !,
 	(
 	    '$call'(X,CP,G0,M)
@@ -671,6 +674,13 @@ write_query_answer( Bindings ) :-
 	  '$call'(X,CP,G0,M) ).
 '$call'(!, CP, _G0, _m) :- !,
 	'$$cut_by'(CP).
+'$call'(forall(X,Y), CP, _G0, _m) :- !,
+	\+ ('$call'(X, CP, G0, M),
+	     \+ '$call'(Y, CP, G0, M) ).
+'$call'(once(X), CP, G0, M) :- !,
+	( '$call'(X, CP, G0, M) -> true).
+'$call'(!, CP, _G0, _m) :- !,
+	'$$cut_by'(CP).
 '$call'([X|Y], _, _, M) :-
     (Y == [] ->
     consult(M:X)
@@ -853,7 +863,6 @@ rules: first try term_expansion/2  in the current module, and then try to use th
 for DCG rules is applied, together with the arithmetic optimizer
 whenever the compilation of arithmetic expressions is in progress.
 
-
 */
 expand_term(Term,Expanded) :-
 	(