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

cleanup of CLPQR and CHR;

Browse Source 
simplification of module handling;
new timestamp implementation


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@52 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2001-06-06 19:10:51 +00:00
parent 9facb55dcb
commit 38247e38fc
62 changed files with 577 additions and 11915 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
C/attvar.c
View File

@ -31,7 +31,6 @@ static char SccsId[]="%W% %G%";
#endif
STATIC_PROTO(Int InitVarTime, (void));
STATIC_PROTO(Int CurrentTime, (void));
static CELL *
AddToQueue(attvar_record *attv)
@ -96,7 +95,6 @@ CopyAttVar(Term orig, CELL ***to_visit_ptr)
register attvar_record *attv = (attvar_record *)orig;
register attvar_record *newv;
CELL **to_visit = *to_visit_ptr;
Term ttime;
Term time = InitVarTime();
Int j;
@ -108,9 +106,8 @@ CopyAttVar(Term orig, CELL ***to_visit_ptr)
newv->sus_id = attvars_ext;
RESET_VARIABLE(&(newv->Value));
newv->NS = UpdateTimedVar(AttsMutableList, (CELL)&(newv->Done));
ttime = MkIntegerTerm(time);
for (j = 0; j < NUM_OF_ATTS; j++) {
newv->Atts[2*j] = ttime;
newv->Atts[2*j] = time;
to_visit[0] = attv->Atts+2*j;
to_visit[1] = attv->Atts+2*j+1;
to_visit[2] = newv->Atts+2*j+1;
@ -192,32 +189,20 @@ mark_attvar(CELL *orig)
#endif /* FIXED_STACKS */
static Int
CurrentTime(void) {
return((CELL *)(TR)-(CELL *)TrailBase);
}
static Int
InitVarTime(void) {
return(0);
#ifdef BEFORE_TRAIL_COMPRESSION
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
return((CELL *)(B->cp_tr)-(CELL *)TrailBase);
#endif
Term t = (CELL)H;
*H++ = TermFoundVar;
return(t);
}
static Int
PutAtt(attvar_record *attv, Int i, Term tatt) {
Int pos = i*2;
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase+IntegerOfTerm(attv->Atts[pos]));
if (B->cp_tr <= timestmp
CELL *timestamp = (CELL *)(attv->Atts[pos]);
if (B->cp_h <= timestamp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
&& timestmp <= H
#endif
) {
#if defined(SBA)
@ -236,7 +221,8 @@ PutAtt(attvar_record *attv, Int i, Term tatt) {
} else {
Term tnewt;
MaBind(attv->Atts+pos+1, tatt);
tnewt = MkIntegerTerm(CurrentTime());
tnewt = (Term)H;
*H++ = TermFoundVar;
MaBind(attv->Atts+pos, tnewt);
}
return(TRUE);
@ -246,10 +232,10 @@ static Int
RmAtt(attvar_record *attv, Int i) {
Int pos = i *2;
if (!IsVarTerm(attv->Atts[pos+1])) {
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase+IntegerOfTerm(attv->Atts[pos]));
if (B->cp_tr <= timestmp
CELL *timestmp = (CELL *)(attv->Atts[pos]);
if (B->cp_h <= timestmp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
&& timestmp <= H
#endif
) {
RESET_VARIABLE(attv->Atts+(pos+1));
@ -266,8 +252,9 @@ RmAtt(attvar_record *attv, Int i) {
#else
MaBind(attv->Atts+(pos+1), (CELL)(attv->Atts+(pos+1)));
#endif
tnewt = MkIntegerTerm(CurrentTime());
MaBind(attv->Atts+pos, tnewt);
tnewt = (Term)H;
*H++ = TermFoundVar;
MaBind(attv->Atts+pos, tnewt);
}
}
return(TRUE);
@ -277,9 +264,8 @@ static Int
BuildNewAttVar(Term t, Int i, Term tatt)
{
/* allocate space in Heap */
Term time = InitVarTime();
Term time;
int j;
Term ttime;
attvar_record *attv = (attvar_record *)ReadTimedVar(DelayedVars);
if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
@ -289,12 +275,12 @@ BuildNewAttVar(Term t, Int i, Term tatt)
t = ARG1;
tatt = ARG2;
}
time = InitVarTime();
RESET_VARIABLE(&(attv->Value));
RESET_VARIABLE(&(attv->Done));
attv->sus_id = attvars_ext;
ttime = MkIntegerTerm(time);
for (j = 0; j < NUM_OF_ATTS; j++) {
attv->Atts[2*j] = ttime;
attv->Atts[2*j] = time;
RESET_VARIABLE(attv->Atts+2*j+1);
}
attv->NS = UpdateTimedVar(AttsMutableList, (CELL)&(attv->Done));

20
C/bb.c
View File

@ -194,7 +194,7 @@ AddBBProp(Term t1, char *msg)
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
} if (IsAtomTerm(t1)) {
p = PutBBProp(RepAtom(AtomOfTerm(t1)));
@ -203,20 +203,20 @@ AddBBProp(Term t1, char *msg)
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
CurrentModule = LookupModule(mod);
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
t1 = ArgOfTerm(2, t1);
p = AddBBProp(t1, msg);
} else {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(p);
}
@ -228,7 +228,7 @@ FetchBBProp(Term t1, char *msg)
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
} if (IsAtomTerm(t1)) {
p = GetBBProp(RepAtom(AtomOfTerm(t1)));
@ -237,20 +237,20 @@ FetchBBProp(Term t1, char *msg)
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
Term mod = ArgOfTerm(1, t1);
if (!IsVarTerm(mod) ) {
CurrentModule = LookupModule(mod);
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
t1 = ArgOfTerm(2, t1);
p = FetchBBProp(t1, msg);
} else {
Error(INSTANTIATION_ERROR, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
} else {
Error(TYPE_ERROR_ATOM, t1, msg);
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(NULL);
}
CurrentModule = old_module;
*CurrentModulePtr = MkIntTerm(old_module);
return(p);
}

8
C/cdmgr.c
View File

@ -1657,7 +1657,7 @@ p_undefined(void)
restart_undefined:
if (IsVarTerm(t)) {
Error(INSTANTIATION_ERROR,ARG1,"undefined/1");
CurrentModule = omod;
*CurrentModulePtr = MkIntTerm(omod);
return(FALSE);
}
if (IsAtomTerm(t)) {
@ -1668,7 +1668,7 @@ p_undefined(void)
if (funt == FunctorModule) {
Term mod = ArgOfTerm(1, t);
if (!IsVarTerm(mod) ) {
CurrentModule = LookupModule(mod);
*CurrentModulePtr = MkIntTerm(LookupModule(mod));
t = ArgOfTerm(2, t);
goto restart_undefined;
}
@ -1676,11 +1676,11 @@ p_undefined(void)
at = NameOfFunctor(funt);
arity = ArityOfFunctor(funt);
} else {
CurrentModule = omod;
*CurrentModulePtr = MkIntTerm(omod);
return (FALSE);
}
pe = RepPredProp(GetPredProp(at, arity));
CurrentModule = omod;
*CurrentModulePtr = MkIntTerm(omod);
if (pe == RepPredProp(NIL))
return (TRUE);
READ_LOCK(pe->PRWLock);

58
C/compiler.c
View File

@ -1131,7 +1131,7 @@ c_goal(Term Goal)
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
CurrentModule = PrimitivesModule;
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
}
if (IsNumTerm(Goal)) {
FAIL("goal can not be a number", TYPE_ERROR_CALLABLE, Goal);
@ -1142,7 +1142,7 @@ c_goal(Term Goal)
FAIL("goal argument in static procedure can not be a data base reference", TYPE_ERROR_CALLABLE, Goal);
} else if (IsPairTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
CurrentModule = PrimitivesModule;
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
} else if (IsApplTerm(Goal) && FunctorOfTerm(Goal) == FunctorModule) {
Term M = ArgOfTerm(1, Goal);
@ -1153,19 +1153,19 @@ c_goal(Term Goal)
save_machine_regs();
longjmp(CompilerBotch, 1);
}
CurrentModule = LookupModule(M);
*CurrentModulePtr = MkIntTerm(LookupModule(M));
Goal = ArgOfTerm(2, Goal);
}
if (IsVarTerm(Goal)) {
Goal = MkApplTerm(FunctorCall, 1, &Goal);
CurrentModule = PrimitivesModule;
*CurrentModulePtr = MkIntTerm(PrimitivesModule);
}
if (IsAtomTerm(Goal)) {
Atom atom = AtomOfTerm(Goal);
if (atom == AtomFail || atom == AtomFalse) {
emit(fail_op, Zero, Zero);
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (atom == AtomTrue || atom == AtomOtherwise) {
@ -1178,7 +1178,7 @@ c_goal(Term Goal)
#endif /* TABLING */
emit(procceed_op, Zero, Zero);
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (atom == AtomCut) {
@ -1207,7 +1207,7 @@ c_goal(Term Goal)
/* needs to adjust previous commits */
adjust_current_commits();
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
#ifndef YAPOR
@ -1247,7 +1247,7 @@ c_goal(Term Goal)
onbranch = pop_branch();
emit(pop_or_op, Zero, Zero);
/* --onbranch; */
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
#endif /* YAPOR */
@ -1381,7 +1381,7 @@ c_goal(Term Goal)
c_goal(MkAtomTerm(AtomTrue));
}
emit(pop_or_op, Zero, Zero);
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorComma) {
@ -1392,7 +1392,7 @@ c_goal(Term Goal)
c_goal(ArgOfTerm(1, Goal));
onlast = save;
c_goal(t2);
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorNot || f == FunctorAltNot) {
@ -1430,7 +1430,7 @@ c_goal(Term Goal)
c_goal(MkAtomTerm(AtomTrue));
++goalno;
emit(pop_or_op, Zero, Zero);
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorArrow) {
@ -1449,7 +1449,7 @@ c_goal(Term Goal)
c_var(comitvar, comit_b_flag, 1);
onlast = save;
c_goal(ArgOfTerm(2, Goal));
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
}
else if (f == FunctorEq) {
@ -1469,7 +1469,23 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else if (f == FunctorModSwitch) {
Term omod = MkVarTerm();
Term mod = ArgOfTerm(1, Goal);
Term goal = ArgOfTerm(2, Goal);
Term a[1];
int cp_onlast = onlast;
onlast = FALSE;
a[0] = omod;
c_goal(MkApplTerm(FunctorCurrentModule, 1, a));
a[0] = mod;
c_goal(MkApplTerm(FunctorChangeModule, 1, a));
c_goal(goal);
a[0] = omod;
onlast = cp_onlast;
c_goal(MkApplTerm(FunctorChangeModule, 1, a));
return;
} else if (p->PredFlags & BasicPredFlag) {
int op = p->PredFlags & 0x7f;
@ -1490,7 +1506,7 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else if (op >= _plus && op <= _functor) {
if (op == _functor) {
@ -1514,7 +1530,7 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else {
c_args(Goal);
@ -1589,7 +1605,7 @@ c_goal(Term Goal)
READ_UNLOCK(CurrentPred->PRWLock);
#endif
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
return;
} else {
if (profiling)
@ -1663,7 +1679,7 @@ c_goal(Term Goal)
if (!onlast)
++goalno;
}
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
}
static void
@ -2745,7 +2761,7 @@ cclause(Term inp_clause, int NOfArgs)
reset_vars();
{
Int osize = 2*sizeof(CELL)*(ASP-H);
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
ARG1 = my_clause;
if (!gc(2, ENV, P)) {
Error_TYPE = SYSTEM_ERROR;
@ -2765,7 +2781,7 @@ cclause(Term inp_clause, int NOfArgs)
/* out of temporary cells */
restore_machine_regs();
reset_vars();
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
if (maxvnum < 16*1024) {
maxvnum *= 2;
} else {
@ -2775,7 +2791,7 @@ cclause(Term inp_clause, int NOfArgs)
/* not enough heap */
restore_machine_regs();
reset_vars();
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
Error_TYPE = SYSTEM_ERROR;
Error_Term = TermNil;
ErrorMessage = "not enough heap space to compile clause";
@ -2783,7 +2799,7 @@ cclause(Term inp_clause, int NOfArgs)
}
restart_compilation:
if (ErrorMessage != NIL) {
CurrentModule = save_CurrentModule;
*CurrentModulePtr = MkIntTerm(save_CurrentModule);
reset_vars();
return (0);
}

3
C/exec.c
View File

@ -917,6 +917,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
B->cp_depth = DEPTH;
#endif /* DEPTH_LIMIT */
if (top) {
Term t;
#if COROUTINING
RESET_VARIABLE((CELL *)GlobalBase);
DelayedVars = NewTimedVar((CELL)GlobalBase);
@ -924,6 +925,8 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
MutableList = NewTimedVar(TermNil);
AttsMutableList = NewTimedVar(TermNil);
#endif
t = NewTimedVar(MkIntTerm(0));
CurrentModulePtr = RepAppl(t)+1;
}
YENV = ASP = (CELL *)B;
HB = H;

4
C/grow.c
View File

@ -142,6 +142,8 @@ SetHeapRegs(void)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
}
static void
@ -180,6 +182,8 @@ SetStackRegs(void)
YENV = PtoLocAdjust(YENV);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
}
static void

68
C/heapgc.c
View File

@ -21,8 +21,6 @@ static char SccsId[] = "%W% %G%";
#include "absmi.h"
#include "yapio.h"
#define DEBUG 1
#define EARLY_RESET 1
#define EASY_SHUNTING 1
#define HYBRID_SCHEME 1
@ -104,10 +102,11 @@ gc_lookup_ma_var(CELL *addr, tr_fr_ptr trp) {
nptr = nptr->next;
}
nptr = GC_ALLOC_NEW_MASPACE();
optr->next = nptr;
nptr->addr = addr;
nptr->next = optr;
nptr->trptr = trp;
nptr->ma_list = live_list;
nptr->next = NULL;
live_list = nptr;
return(NULL);
}
@ -153,6 +152,8 @@ STATIC_PROTO(Int p_gc, (void));
static choiceptr current_B;
static tr_fr_ptr sTR;
static CELL *prev_HB;
#endif
static tr_fr_ptr new_TR;
@ -322,6 +323,7 @@ push_registers(Int num_regs, yamop *nextop)
TrailTerm(TR+3) = DelayedVars;
TR += 4;
#endif
TrailTerm(TR++) = AbsAppl(CurrentModulePtr-1);
for (i = 1; i <= num_regs; i++)
TrailTerm(TR++) = (CELL) XREGS[i];
/* push any live registers we might have hanging around */
@ -365,6 +367,7 @@ pop_registers(Int num_regs, yamop *nextop)
DelayedVars = TrailTerm(ptr++);
#endif
#endif
CurrentModulePtr = RepAppl(TrailTerm(ptr++))+1;
for (i = 1; i <= num_regs; i++)
XREGS[i] = TrailTerm(ptr++);
/* pop any live registers we might have hanging around */
@ -660,7 +663,7 @@ init_dbtable(tr_fr_ptr trail_ptr) {
#ifdef DEBUG
#define INSTRUMENT_GC 1
/*#define CHECK_CHOICEPOINTS 1*/
#define CHECK_CHOICEPOINTS 1
#ifdef INSTRUMENT_GC
typedef enum {
@ -850,7 +853,7 @@ mark_variable(CELL_PTR current)
if (!MARKED((cnext = *next))) {
if (IsVarTerm(cnext) && (CELL)next == cnext) {
/* new global variable to new global variable */
if (current < H && current >= HB && next >= HB) {
if (current < prev_HB && current >= HB && next >= HB && next < prev_HB) {
#ifdef INSTRUMENT_GC
inc_var(current, current);
#endif
@ -866,7 +869,7 @@ mark_variable(CELL_PTR current)
}
} else {
/* binding to a determinate reference */
if (next >= HB && current < LCL0) {
if (next >= HB && current < LCL0 && cnext != TermFoundVar) {
*current = cnext;
total_marked--;
POP_POINTER();
@ -1369,6 +1372,9 @@ static void
mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR)
{
#ifdef EASY_SHUNTING
HB = H;
#endif
while (gc_B != NULL) {
op_numbers opnum;
register OPCODE op;
@ -1376,6 +1382,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR)
#ifdef EASY_SHUNTING
current_B = gc_B;
prev_HB = HB;
#endif
HB = gc_B->cp_h;
#ifdef INSTRUMENT_GC
@ -1677,15 +1684,12 @@ into_relocation_chain(CELL_PTR current, CELL_PTR next)
static void
sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
{
tr_fr_ptr trail_ptr, dest, tri = (tr_fr_ptr)db_vec;
tr_fr_ptr trail_ptr, dest;
Int OldHeapUsed = HeapUsed;
#ifdef DEBUG
Int hp_entrs = 0, hp_erased = 0, hp_not_in_use = 0,
hp_in_use_erased = 0, code_entries = 0;
#endif
#if MULTI_ASSIGNMENT_VARIABLES
tr_fr_ptr next_timestamp = NULL;
#endif
/* adjust cp_tr pointers */
{
@ -1814,33 +1818,6 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
else
ptr = RepAppl(trail_cell);
/* now, we must check whether we are looking at a time-stamp */
if (next_timestamp == trail_ptr) {
/* we have a time stamp. Problem is: the trail shifted and we can not trust the
current time stamps */
CELL old_cell = *ptr;
int was_marked = MARKED(old_cell);
tr_fr_ptr old_timestamp;
if (was_marked)
old_cell = UNMARK_CELL(old_cell);
old_timestamp = (tr_fr_ptr)TrailBase+IntegerOfTerm(old_cell);
if (old_timestamp >= trail_ptr) {
/* first time, we found the current timestamp */
old = MkIntTerm(0);
} else {
/* set time stamp to current */
old = old_cell;
}
*ptr = MkIntegerTerm(dest-(tr_fr_ptr)TrailBase);
if (was_marked)
MARK(ptr);
} else if (ptr < H0 || UNMARK_CELL(ptr[-1]) == (CELL)FunctorMutable) {
/* yes, we do have a time stamp */
next_timestamp = trail_ptr+2;
}
TrailTerm(dest) = old;
TrailTerm(dest+1) = trail_cell;
if (MARKED(old)) {
@ -1853,13 +1830,7 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
if (MARKED(trail_cell)) {
UNMARK(&TrailTerm(dest));
if (HEAP_PTR(trail_cell)) {
if (next_timestamp == trail_ptr) {
/* wait until we're over to insert in relocation chain */
TrailTerm(tri) = (CELL)dest;
tri++;
} else {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
}
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
}
}
trail_ptr++;
@ -1878,13 +1849,6 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
dest++;
}
}
while (tri > (tr_fr_ptr)db_vec) {
tr_fr_ptr x = (tr_fr_ptr)TrailTerm(--tri);
CELL trail_cell = TrailTerm(x);
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(&TrailTerm(x), GET_NEXT(trail_cell));
}
}
new_TR = dest;
if (is_gc_verbose()) {
YP_fprintf(YP_stderr,
@ -2672,7 +2636,7 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
if (total_marked != iptop-(CELL_PTR *)H && iptop < (CELL_PTR *)ASP -1024)
YP_fprintf(YP_stderr,"[GC] Oops on iptop-H (%d) vs %d\n", iptop-(CELL_PTR *)H, total_marked);
#endif
if (iptop < (CELL_PTR *)ASP /* && 10*total_marked < H-H0 */) {
if (iptop < (CELL_PTR *)ASP && 10*total_marked < H-H0) {
int effectiveness = (((H-H0)-total_marked)*100)/(H-H0);
#ifdef DEBUG
YP_fprintf(YP_stderr,"[GC] using pointers (%d)\n", effectiveness);

15
C/init.c
View File

@ -151,11 +151,6 @@ REGSTORE REGS;
#endif
/* module data */
SMALLUNSGN CurrentModule = 0;
/************** Access to yap initial arguments ***************************/
char **yap_args;
@ -181,6 +176,8 @@ sigjmp_buf RestartEnv; /* used to restart after an abort execution */
CPredicate c_predicates[MAX_C_PREDS];
cmp_entry cmp_funcs[MAX_CMP_FUNCS];
static CELL InitModuleAddress;
/************** declarations local to init.c ************************/
static char *optypes[] =
{"", "xfx", "xfy", "yfx", "xf", "yf", "fx", "fy"};
@ -940,6 +937,9 @@ InitCodes(void)
heap_regs->functor_stream = MkFunctor (AtomStream, 1);
heap_regs->functor_stream_pos = MkFunctor (AtomStreamPos, 3);
heap_regs->functor_stream_eOS = MkFunctor (LookupAtom("end_of_stream"), 1);
heap_regs->functor_change_module = MkFunctor (LookupAtom("$change_module"), 1);
heap_regs->functor_current_module = MkFunctor (LookupAtom("$current_module"), 1);
heap_regs->functor_mod_switch = MkFunctor (LookupAtom("$mod_switch"), 2);
heap_regs->functor_v_bar = MkFunctor(LookupAtom("|"), 2);
heap_regs->functor_var = MkFunctor(AtomVar, 1);
#ifdef EUROTRA
@ -952,9 +952,9 @@ InitCodes(void)
heap_regs->yap_lib_dir = NULL;
heap_regs->size_of_overflow = 0;
/* make sure no one else can use these two atoms */
CurrentModule = 1;
*CurrentModulePtr = MkIntTerm(1);
heap_regs->pred_goal_expansion = RepPredProp(PredProp(LookupAtom("goal_expansion"),3));
CurrentModule = 0;
*CurrentModulePtr = MkIntTerm(0);
heap_regs->dead_clauses = NULL;
heap_regs->pred_meta_call = RepPredProp(PredProp(heap_regs->atom_meta_call,3));
ReleaseAtom(AtomOfTerm(heap_regs->term_refound_var));
@ -1082,6 +1082,7 @@ InitStacks(int Heap,
/* the emulator will eventually copy them to its own local
register array, but for now they exist */
#endif /* PUSH_REGS */
CurrentModulePtr = &InitModuleAddress;
/* Init signal handling and time */
/* also init memory page size, required by later functions */

4
C/load_foreign.c
View File

@ -125,13 +125,13 @@ ReOpenLoadForeign(void)
YapInitProc InitProc = NULL;
while (f_code != NULL) {
CurrentModule = f_code->module;
*CurrentModulePtr = MkIntTerm(f_code->module);
if(ReLoadForeign(f_code->objs,f_code->libs,f_code->f,&InitProc)==LOAD_SUCCEEDED) {
(*InitProc)();
}
f_code = f_code->next;
}
CurrentModule = OldModule;
*CurrentModulePtr = MkIntTerm(OldModule);
}

72
C/mavar.c
View File

@ -24,8 +24,6 @@
#include "eval.h"
STD_PROTO(static Int p_setarg, (void));
STD_PROTO(static void CreateTimedVar, (Term));
STD_PROTO(static void CreateEmptyTimedVar, (void));
STD_PROTO(static Int p_create_mutable, (void));
STD_PROTO(static Int p_get_mutable, (void));
STD_PROTO(static Int p_update_mutable, (void));
@ -109,56 +107,30 @@ p_setarg(void)
== B->TR) we will add a little something ;-).
*/
static void
CreateTimedVar(Term val)
{
timed_var *tv = (timed_var *)H;
tv->clock = MkIntTerm(0);
#ifdef BEFORE_TRAIL_COMPRESSION
tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase));
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
#endif
tv->value = val;
H += sizeof(timed_var)/sizeof(CELL);
}
static void
CreateEmptyTimedVar(void)
{
timed_var *tv = (timed_var *)H;
tv->clock = MkIntTerm(0);
#ifdef BEFORE_TRAIL_COMPRESSION
tv->clock = MkIntegerTerm((Int)((CELL *)(B->cp_tr)-(CELL *)TrailBase));
if (B->cp_tr == TR) {
/* we run the risk of not making non-determinate bindings before
the end of the night */
/* so we just init a TR cell that will not harm anyone */
Bind((CELL *)(TR+1),AbsAppl(H-1));
}
#endif
RESET_VARIABLE(&(tv->value));
H += sizeof(timed_var)/sizeof(CELL);
}
Term NewTimedVar(CELL val)
{
Term t = AbsAppl(H);
timed_var *tv;
Term out;
out = AbsAppl(H);
*H++ = (CELL)FunctorMutable;
CreateTimedVar(val);
return(t);
tv = (timed_var *)H;
RESET_VARIABLE(&(tv->clock));
tv->value = val;
H += sizeof(timed_var)/sizeof(CELL);
return(out);
}
Term NewEmptyTimedVar(void)
{
Term t = AbsAppl(H);
timed_var *tv;
Term out;
out = AbsAppl(H);
*H++ = (CELL)FunctorMutable;
CreateEmptyTimedVar();
return(t);
tv = (timed_var *)H;
RESET_VARIABLE(&(tv->clock));
RESET_VARIABLE(&(tv->value));
H += sizeof(timed_var)/sizeof(CELL);
return(out);
}
Term ReadTimedVar(Term inv)
@ -173,13 +145,13 @@ Term UpdateTimedVar(Term inv, Term new)
{
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
CELL t = tv->value;
tr_fr_ptr timestmp = (tr_fr_ptr)((CELL *)TrailBase + IntegerOfTerm(tv->clock));
CELL* timestmp = (CELL *)(tv->clock);
if (B->cp_tr <= timestmp
if (B->cp_h <= timestmp
#if defined(SBA) || defined(TABLING)
&& timestmp <= TR
&& timestmp <= (CELL)H
#endif
) {
) {
/* last assignment more recent than last B */
#if SBA
if (Unsigned((Int)(tv)-(Int)(H_FZ)) >
@ -194,9 +166,9 @@ Term UpdateTimedVar(Term inv, Term new)
TrailVal(timestmp-1) = new;
#endif
} else {
Term nclock;
Term nclock = (Term)H;
MaBind(&(tv->value), new);
nclock = MkIntegerTerm((Int)((CELL *)TR-(CELL *)TrailBase));
*H++ = TermFoundVar;
MaBind(&(tv->clock), nclock);
}
return(t);

21
C/modules.c
View File

@ -70,11 +70,12 @@ p_current_module(void)
return (0);
for (i = 0; i < NoOfModules; ++i)
if (ModuleName[i] == t) {
CurrentModule = i;
return (1);
*CurrentModulePtr = MkIntTerm(i);
return (TRUE);
}
ModuleName[CurrentModule = NoOfModules++] = t;
return (1);
*CurrentModulePtr = MkIntTerm(NoOfModules);
ModuleName[NoOfModules++] = t;
return (TRUE);
}
static Int
@ -85,12 +86,22 @@ p_current_module1(void)
return (1);
}
static Int
p_change_module(void)
{ /* $change_module(New) */
Term t = MkIntTerm(LookupModule(Deref(ARG1)));
UpdateTimedVar(AbsAppl(CurrentModulePtr-1), t);
return (TRUE);
}
void
InitModules(void)
{
ModuleName[CurrentModule = PrimitivesModule = 0] =
ModuleName[PrimitivesModule = 0] =
MkAtomTerm(LookupAtom("prolog"));
*CurrentModulePtr = MkIntTerm(0);
ModuleName[1] = MkAtomTerm(LookupAtom("user"));
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag);
}

9
C/save.c
View File

@ -377,12 +377,12 @@ save_regs(int mode)
putcellptr((CELL *)TopB);
putcellptr((CELL *)DelayedB);
putout(FlipFlop);
putcellptr(CurrentModulePtr);
#ifdef COROUTINING
putout(DelayedVars);
#endif
}
putcellptr((CELL *)HeapPlus);
putout(CurrentModule);
if (mode == DO_EVERYTHING) {
#ifdef COROUTINING
putout(WokenGoals);
@ -672,12 +672,12 @@ get_regs(int flag)
TopB = (choiceptr)get_cellptr();
DelayedB = (choiceptr)get_cellptr();
FlipFlop = get_cell();
CurrentModulePtr = get_cellptr();
#ifdef COROUTINING
DelayedVars = get_cell();
#endif
}
HeapPlus = (ADDR)get_cellptr();
CurrentModule = get_cell();
if (flag == DO_EVERYTHING) {
#ifdef COROUTINING
WokenGoals = get_cell();
@ -1082,6 +1082,9 @@ restore_codes(void)
heap_regs->functor_stream = FuncAdjust(heap_regs->functor_stream);
heap_regs->functor_stream_pos = FuncAdjust(heap_regs->functor_stream_pos);
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
heap_regs->functor_change_module = FuncAdjust(heap_regs->functor_change_module);
heap_regs->functor_current_module = FuncAdjust(heap_regs->functor_current_module);
heap_regs->functor_mod_switch = FuncAdjust(heap_regs->functor_mod_switch);
heap_regs->functor_v_bar = FuncAdjust(heap_regs->functor_v_bar);
heap_regs->functor_var = FuncAdjust(heap_regs->functor_var);
#ifdef EUROTRA
@ -1145,6 +1148,8 @@ restore_regs(int flag)
HeapPlus = AddrAdjust(HeapPlus);
if (MyTR)
MyTR = PtoTRAdjust(MyTR);
if (CurrentModulePtr)
CurrentModulePtr = PtoGloAdjust(CurrentModulePtr);
#ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
#ifdef MULTI_ASSIGNMENT_VARIABLES

96
CHR/Makefile.in Normal file
View File

@ -0,0 +1,96 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
CHR_PROGRAMS= $(srcdir)/chr/chrcmp.pl \
$(srcdir)/chr/compenv.pl \
$(srcdir)/chr/concat.pl \
$(srcdir)/chr/getval.pl \
$(srcdir)/chr/matching.pl \
$(srcdir)/chr/operator.pl \
$(srcdir)/chr/ordering.pl \
$(srcdir)/chr/sbag.pl \
$(srcdir)/chr/sbag_a.pl \
$(srcdir)/chr/sbag_l.pl \
$(srcdir)/chr/trace.yap \
CHR_TOP= $(srcdir)/chr.yap
CHR_LICENSE= $(srcdir)/CHR.LICENSE
CHR_EXAMPLES= $(srcdir)/chr/examples/allentable.pl \
$(srcdir)/chr/examples/arc.pl \
$(srcdir)/chr/examples/bool.pl \
$(srcdir)/chr/examples/cft.pl \
$(srcdir)/chr/examples/domain.pl \
$(srcdir)/chr/examples/examples-adder.bool \
$(srcdir)/chr/examples/examples-benchmark.math \
$(srcdir)/chr/examples/examples-deussen.bool \
$(srcdir)/chr/examples/examples-diaz.bool \
$(srcdir)/chr/examples/examples-fourier.math \
$(srcdir)/chr/examples/examples-holzbaur.math \
$(srcdir)/chr/examples/examples-lim1.math \
$(srcdir)/chr/examples/examples-lim2.math \
$(srcdir)/chr/examples/examples-lim3.math \
$(srcdir)/chr/examples/examples-puzzle.bool \
$(srcdir)/chr/examples/examples-queens.bool \
$(srcdir)/chr/examples/examples-queens.domain \
$(srcdir)/chr/examples/examples-stuckey.math \
$(srcdir)/chr/examples/examples-thom.math \
$(srcdir)/chr/examples/gcd.pl \
$(srcdir)/chr/examples/interval.pl \
$(srcdir)/chr/examples/kl-one.pl \
$(srcdir)/chr/examples/leq.pl \
$(srcdir)/chr/examples/list.pl \
$(srcdir)/chr/examples/listdom.pl \
$(srcdir)/chr/examples/math-elim.pl \
$(srcdir)/chr/examples/math-fougau.pl \
$(srcdir)/chr/examples/math-fourier.pl \
$(srcdir)/chr/examples/math-gauss.pl \
$(srcdir)/chr/examples/math-utilities.pl \
$(srcdir)/chr/examples/minmax.pl \
$(srcdir)/chr/examples/modelgenerator.pl \
$(srcdir)/chr/examples/osf.pl \
$(srcdir)/chr/examples/oztype.pl \
$(srcdir)/chr/examples/path.pl \
$(srcdir)/chr/examples/pathc.pl \
$(srcdir)/chr/examples/primes.pl \
$(srcdir)/chr/examples/scheduling.pl \
$(srcdir)/chr/examples/tarski.pl \
$(srcdir)/chr/examples/term.pl \
$(srcdir)/chr/examples/time-pc.pl \
$(srcdir)/chr/examples/time-point.pl \
$(srcdir)/chr/examples/time-rnd.pl \
$(srcdir)/chr/examples/time.pl \
$(srcdir)/chr/examples/tree.pl \
$(srcdir)/chr/examples/type.pl
install: $(CHR_TOP) $(CHR_LICENSE) $(CHR_PROGRAMS) $(CHR_EXAMPLES)
-mkdir $(DESTDIR)$(LIBDIR)/library
-mkdir $(DESTDIR)$(LIBDIR)/library/chr
-mkdir $(DESTDIR)$(LIBDIR)/library/chr/examples
$(INSTALL_DATA) $(CHR_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CHR_LICENSE) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CHR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/chr
$(INSTALL_DATA) $(CHR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/chr/examples

150
CLPQR/Makefile.in Normal file
View File

@ -0,0 +1,150 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
CLPQR_PROGRAMS= $(srcdir)/clpqr/arith.pl \
$(srcdir)/clpqr/bb.yap \
$(srcdir)/clpqr/bv.yap \
$(srcdir)/clpqr/compenv.pl \
$(srcdir)/clpqr/dump.pl \
$(srcdir)/clpqr/fourmotz.pl \
$(srcdir)/clpqr/ineq.yap \
$(srcdir)/clpqr/itf3.pl \
$(srcdir)/clpqr/nf.yap \
$(srcdir)/clpqr/ordering.yap \
$(srcdir)/clpqr/project.pl \
$(srcdir)/clpqr/redund.pl \
$(srcdir)/clpqr/store.yap
CLPQR_LOCAL= \
$(srcdir)/clpqr/expand.yap \
$(srcdir)/clpqr/monash.pl \
$(srcdir)/clpqr/printf.pl
CLPR_PROGRAMS= $(srcdir)/clpr/arith_r.pl \
$(srcdir)/clpr/class.pl\
$(srcdir)/clpr/geler.yap \
$(srcdir)/clpr/nfr.yap
CLPQ_PROGRAMS= $(srcdir)/clpq/arith_q.pl \
$(srcdir)/clpq/class.pl\
$(srcdir)/clpq/geler.yap \
$(srcdir)/clpq/nfq.yap
CLPR_TOP= $(srcdir)/clpr.yap
CLPQ_TOP= $(srcdir)/clpq.pl
CLPQR_LICENSE= $(srcdir)/CLPQR.LICENSE
CLPQR_EXAMPLES= $(srcdir)/clpqr/examples/README \
$(srcdir)/clpqr/examples/caneghem.pl \
$(srcdir)/clpqr/examples/eliminat.pl \
$(srcdir)/clpqr/examples/matmul.pl \
$(srcdir)/clpqr/examples/mg.pl \
$(srcdir)/clpqr/examples/mip.pl \
$(srcdir)/clpqr/examples/root.pl \
$(srcdir)/clpqr/examples/simplex.pl \
$(srcdir)/clpqr/examples/squares.pl \
CLPQR_EXAMPLES_MONASH= $(srcdir)/clpqr/examples/monash/README \
$(srcdir)/clpqr/examples/monash/air \
$(srcdir)/clpqr/examples/monash/amplif \
$(srcdir)/clpqr/examples/monash/complex \
$(srcdir)/clpqr/examples/monash/critical \
$(srcdir)/clpqr/examples/monash/dnf \
$(srcdir)/clpqr/examples/monash/fib \
$(srcdir)/clpqr/examples/monash/findroot \
$(srcdir)/clpqr/examples/monash/invert \
$(srcdir)/clpqr/examples/monash/laplace \
$(srcdir)/clpqr/examples/monash/mortgage \
$(srcdir)/clpqr/examples/monash/nrev \
$(srcdir)/clpqr/examples/monash/option \
$(srcdir)/clpqr/examples/monash/pictures \
$(srcdir)/clpqr/examples/monash/rkf45 \
$(srcdir)/clpqr/examples/monash/rlc \
$(srcdir)/clpqr/examples/monash/smm \
$(srcdir)/clpqr/examples/monash/toolpath \
$(srcdir)/clpqr/examples/monash/zebra
CLPQR_EXAMPLES_SESSION= $(srcdir)/clpqr/examples/SESSION/010 \
$(srcdir)/clpqr/examples/SESSION/011 \
$(srcdir)/clpqr/examples/SESSION/012 \
$(srcdir)/clpqr/examples/SESSION/013 \
$(srcdir)/clpqr/examples/SESSION/014 \
$(srcdir)/clpqr/examples/SESSION/015 \
$(srcdir)/clpqr/examples/SESSION/016 \
$(srcdir)/clpqr/examples/SESSION/017 \
$(srcdir)/clpqr/examples/SESSION/018 \
$(srcdir)/clpqr/examples/SESSION/019 \
$(srcdir)/clpqr/examples/SESSION/020 \
$(srcdir)/clpqr/examples/SESSION/021 \
$(srcdir)/clpqr/examples/SESSION/022 \
$(srcdir)/clpqr/examples/SESSION/023 \
$(srcdir)/clpqr/examples/SESSION/024 \
$(srcdir)/clpqr/examples/SESSION/030 \
$(srcdir)/clpqr/examples/SESSION/031 \
$(srcdir)/clpqr/examples/SESSION/032 \
$(srcdir)/clpqr/examples/SESSION/033 \
$(srcdir)/clpqr/examples/SESSION/034 \
$(srcdir)/clpqr/examples/SESSION/035 \
$(srcdir)/clpqr/examples/SESSION/110 \
$(srcdir)/clpqr/examples/SESSION/111 \
$(srcdir)/clpqr/examples/SESSION/112 \
$(srcdir)/clpqr/examples/SESSION/113 \
$(srcdir)/clpqr/examples/SESSION/114 \
$(srcdir)/clpqr/examples/SESSION/115 \
$(srcdir)/clpqr/examples/SESSION/116 \
$(srcdir)/clpqr/examples/SESSION/117 \
$(srcdir)/clpqr/examples/SESSION/118 \
$(srcdir)/clpqr/examples/SESSION/119 \
$(srcdir)/clpqr/examples/SESSION/120 \
$(srcdir)/clpqr/examples/SESSION/122 \
$(srcdir)/clpqr/examples/SESSION/123 \
$(srcdir)/clpqr/examples/SESSION/124 \
$(srcdir)/clpqr/examples/SESSION/130 \
$(srcdir)/clpqr/examples/SESSION/131 \
$(srcdir)/clpqr/examples/SESSION/132 \
$(srcdir)/clpqr/examples/SESSION/133 \
$(srcdir)/clpqr/examples/SESSION/134 \
$(srcdir)/clpqr/examples/SESSION/135
install: $(CLPR_TOP) $(CLPQ_TOP) $(CLPQR_LICENSE) $(CLPQR_PROGRAMS) $(CLPQR_LOCAL)\
$(CLPQR_EXAMPLES) $(CLPQR_EXAMPLES_MONASH) $(CLPQR_EXAMPLES_SESSION)
-mkdir $(DESTDIR)$(LIBDIR)/library
-mkdir $(DESTDIR)$(LIBDIR)/library/clpq
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr
-mkdir $(DESTDIR)$(LIBDIR)/library/clpr
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION
-mkdir $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash
$(INSTALL_DATA) $(CLPQ_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPR_TOP) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPQR_LICENSE) $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq
$(INSTALL_DATA) $(CLPQ_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpq
$(INSTALL_DATA) $(CLPQR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr
$(INSTALL_DATA) $(CLPR_PROGRAMS) $(DESTDIR)$(LIBDIR)/library/clpr
$(INSTALL_DATA) $(CLPQR_LOCAL) $(DESTDIR)$(LIBDIR)/library/clpqr
$(INSTALL_DATA) $(CLPQR_EXAMPLES) $(DESTDIR)$(LIBDIR)/library/clpqr/examples
$(INSTALL_DATA) $(CLPQR_EXAMPLES_MONASH) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/monash
$(INSTALL_DATA) $(CLPQR_EXAMPLES_SESSION) $(DESTDIR)$(LIBDIR)/library/clpqr/examples/SESSION

668
CLPQR/clpq/arith.pl
View File

@ -1,668 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: arith.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% common code for R,Q, runtime predicates
%
% linearize evaluation, collect vars
%
% Todo: +) limited encoding length option
% +) 2 stage compilation: a) linearization
% b) specialization to R or Q
%
%
l2conj( [], true).
l2conj( [X|Xs], Conj) :-
( Xs = [], Conj = X
; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc)
).
% ----------------------------------------------------------------------
%
% float/1 coercion is allowed only at the outermost level in Q
%
compile_Q( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_Q( Linear, Code, Ct),
( Res = boolean, Ct = []
; Res = float(R), Ct = []
; Res = rat(N,D), Ct = [ putq(D,N,R) ]
).
%
% assumes normalized params and puts a normalized result
%
compile_Qn( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_Qn( Linear, Code, Ct),
( Res = boolean, Ct = []
; Res = float(R), Ct = []
; Res = rat(N,D), Ct = [ putq(D,N,R) ]
).
compile_case_signum_Qn( Term, Lt,Z,Gt, Code) :-
linearize( Term, rat(N,_), Linear),
specialize_Qn( Linear, Code,
[
compare( Rel, N, 0),
( Rel = <, Lt
; Rel = =, Z
; Rel = >, Gt
)
]).
specialize_Qn( []) --> [].
specialize_Qn( [Op|Ops]) -->
specialize_Qn( Op),
specialize_Qn( Ops).
%
specialize_Qn( op_var(rat(N,D),Var)) --> [ Var=rat(N,D) ]. % <--- here is the difference ---
specialize_Qn( op_integer(rat(I,1),I)) --> [].
specialize_Qn( op_rat(rat(N,D),N,D)) --> [].
specialize_Qn( op_float(rat(N,D),X)) --> [], { float_rat( X, N,D) }.
specialize_Qn( apply(R,Func)) -->
specialize_Q_fn( Func, R).
specialize_Q( []) --> [].
specialize_Q( [Op|Ops]) -->
specialize_Q( Op),
specialize_Q( Ops).
%
specialize_Q( op_var(rat(N,D),Var)) --> [ getq(Var,N,D) ].
specialize_Q( op_integer(rat(I,1),I)) --> [].
specialize_Q( op_rat(rat(N,D),N,D)) --> [], { D > 0 }.
specialize_Q( op_float(rat(N,D),X)) --> [], { float_rat( X, N,D) }.
specialize_Q( apply(R,Func)) -->
specialize_Q_fn( Func, R).
specialize_Q_fn( +rat(N,D), rat(N,D)) --> [].
specialize_Q_fn( numer(rat(N,_)), rat(N,1)) --> [].
specialize_Q_fn( denom(rat(_,D)), rat(D,1)) --> [].
specialize_Q_fn( -rat(N0,D), rat(N,D)) --> [ N is -N0 ].
specialize_Q_fn( abs(rat(Nx,Dx)), rat(N,D)) --> [ N is abs(Nx) ], {D=Dx}.
specialize_Q_fn( signum(rat(Nx,Dx)), rat(N,D)) --> [ signumq( Nx,Dx, N,D) ].
specialize_Q_fn( floor(rat(Nx,Dx)), rat(N,D)) --> [ floorq( Nx,Dx, N,D) ].
specialize_Q_fn( ceiling(rat(Nx,Dx)), rat(N,D)) --> [ ceilingq( Nx,Dx, N,D) ].
specialize_Q_fn( truncate(rat(Nx,Dx)), rat(N,D)) --> [ truncateq( Nx,Dx, N,D) ].
specialize_Q_fn( round(rat(Nx,Dx)), rat(N,D)) --> [ roundq( Nx,Dx, N,D) ].
specialize_Q_fn( log(rat(Nx,Dx)), rat(N,D)) --> [ logq( Nx,Dx, N,D) ].
specialize_Q_fn( exp(rat(Nx,Dx)), rat(N,D)) --> [ expq( Nx,Dx, N,D) ].
specialize_Q_fn( sin(rat(Nx,Dx)), rat(N,D)) --> [ sinq( Nx,Dx, N,D) ].
specialize_Q_fn( cos(rat(Nx,Dx)), rat(N,D)) --> [ cosq( Nx,Dx, N,D) ].
specialize_Q_fn( tan(rat(Nx,Dx)), rat(N,D)) --> [ tanq( Nx,Dx, N,D) ].
specialize_Q_fn( asin(rat(Nx,Dx)), rat(N,D)) --> [ asinq( Nx,Dx, N,D) ].
specialize_Q_fn( acos(rat(Nx,Dx)), rat(N,D)) --> [ acosq( Nx,Dx, N,D) ].
specialize_Q_fn( atan(rat(Nx,Dx)), rat(N,D)) --> [ atanq( Nx,Dx, N,D) ].
specialize_Q_fn( float(rat(Nx,Dx)), float(F)) --> [ rat_float( Nx,Dx, F) ].
%
specialize_Q_fn( rat(Nx,Dx)+rat(Ny,Dy), rat(N,D)) --> [ addq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)-rat(Ny,Dy), rat(N,D)) --> [ subq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)*rat(Ny,Dy), rat(N,D)) --> [ mulq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)/rat(Ny,Dy), rat(N,D)) --> [ divq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( exp(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ expq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( min(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ minq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( max(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ maxq( Nx,Dx, Ny,Dy, N,D) ].
%
specialize_Q_fn( rat(Nx,Dx) < rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, <) ].
specialize_Q_fn( rat(Nx,Dx) > rat(Ny,Dy), boolean) --> [ comq( Ny,Dy, Nx,Dx, <) ].
specialize_Q_fn( rat(Nx,Dx) =< rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, Rel), Rel \== (>) ].
specialize_Q_fn( rat(Nx,Dx) >= rat(Ny,Dy), boolean) --> [ comq( Ny,Dy, Nx,Dx, Rel), Rel \== (>) ].
specialize_Q_fn( rat(Nx,Dx) =\= rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, Rel), Rel \== (=) ].
specialize_Q_fn( rat(Nx,Dx) =:= rat(Ny,Dy), boolean) -->
%
% *normalized* rationals
%
( {Nx = Ny} -> [] ; [ Nx = Ny ] ),
( {Dx = Dy} -> [] ; [ Dx = Dy ] ).
% ----------------------------------------------------------------------
compile_R( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_R( Linear, Code, Ct),
( Res == boolean ->
Ct = [], R = boolean
; float(Res) ->
Ct = [ R=Res ]
;
Ct = [ R is Res ]
).
compile_case_signum_R( Term, Lt,Z,Gt, Code) :-
eps( Eps, NegEps),
linearize( Term, Res, Linear),
specialize_R( Linear, Code,
[
Rv is Res,
( Rv < NegEps -> Lt
; Rv > Eps -> Gt
; Z
)
]).
specialize_R( []) --> [].
specialize_R( [Op|Ops]) -->
specialize_R( Op),
specialize_R( Ops).
%
specialize_R( op_var(Var,Var)) --> [].
specialize_R( op_integer(R,I)) --> [], { R is float(I) }.
specialize_R( op_rat(R,N,D)) --> [], { rat_float( N,D, R) }.
specialize_R( op_float(F,F)) --> [].
specialize_R( apply(R,Func)) -->
specialize_R_fn( Func, R).
specialize_R_fn( signum(X), S) -->
( {var(X)} ->
{Xe=X}
;
[ Xe is X ]
),
{
eps( Eps, NegEps)
},
[
( Xe < NegEps -> S = -1.0
; Xe > Eps -> S = 1.0
; S = 0.0
)
].
specialize_R_fn( +X, X) --> [].
specialize_R_fn( -X, -X) --> [].
specialize_R_fn( abs(X), abs(X)) --> [].
specialize_R_fn( floor(X), float(floor(/*float?*/X))) --> [].
specialize_R_fn( ceiling(X), float(ceiling(/*float?*/X))) --> [].
specialize_R_fn( truncate(X), float(truncate(/*float?*/X))) --> [].
specialize_R_fn( round(X), float(round(/*float?*/X))) --> [].
specialize_R_fn( log(X), log(X)) --> [].
specialize_R_fn( exp(X), exp(X)) --> [].
specialize_R_fn( sin(X), sin(X)) --> [].
specialize_R_fn( cos(X), cos(X)) --> [].
specialize_R_fn( tan(X), tan(X)) --> [].
specialize_R_fn( asin(X), asin(X)) --> [].
specialize_R_fn( acos(X), acos(X)) --> [].
specialize_R_fn( atan(X), atan(X)) --> [].
specialize_R_fn( float(X), float(X)) --> [].
%
specialize_R_fn( X+Y, X+Y) --> [].
specialize_R_fn( X-Y, X-Y) --> [].
specialize_R_fn( X*Y, X*Y) --> [].
specialize_R_fn( X/Y, X/Y) --> [].
specialize_R_fn( exp(X,Y), exp(X,Y)) --> [].
specialize_R_fn( min(X,Y), min(X,Y)) --> [].
specialize_R_fn( max(X,Y), max(X,Y)) --> [].
/**/
%
% An absolute eps is of course not very meaningful.
% An eps scaled by the magnitude of the operands participating
% in the comparison is too expensive to support in Prolog on the
% other hand ...
%
%
% -eps 0 +eps
% ---------------[----|----]----------------
% < 0 > 0
% <-----------] [----------->
% =< 0
% <---------------------]
% >= 0
% [--------------------->
%
%
specialize_R_fn( X < Y, boolean) -->
{
eps( Eps, NegEps)
},
( {X==0} ->
[ Y > Eps ]
; {Y==0} ->
[ X < NegEps ]
;
[ X-Y < NegEps ]
).
specialize_R_fn( X > Y, boolean) --> specialize_R_fn( Y < X, boolean).
specialize_R_fn( X =< Y, boolean) -->
{
eps( Eps, _)
},
[ X-Y < Eps ].
specialize_R_fn( X >= Y, boolean) --> specialize_R_fn( Y =< X, boolean).
specialize_R_fn( X =:= Y, boolean) -->
{
eps( Eps, NegEps)
},
( {X==0} ->
[ Y >= NegEps, Y =< Eps ]
; {Y==0} ->
[ X >= NegEps, X =< Eps ]
;
[
Diff is X-Y,
Diff =< Eps,
Diff >= NegEps
]
).
specialize_R_fn( X =\= Y, boolean) -->
{
eps( Eps, NegEps)
},
[
Diff is X-Y,
( Diff < NegEps -> true ; Diff > Eps )
].
/**/
/**
%
% b30427, pp.218
%
specialize_R_fn( X > Y, boolean) --> specialize_R_fn( Y < X, boolean).
specialize_R_fn( X < Y, boolean) -->
[ scaled_eps(X,Y,E), Y-X > E ].
specialize_R_fn( X >= Y, boolean) --> specialize_R_fn( Y =< X, boolean).
specialize_R_fn( X =< Y, boolean) -->
[ scaled_eps(X,Y,E), X-Y =< E ]. % \+ >
specialize_R_fn( X =:= Y, boolean) -->
[ scaled_eps(X,Y,E), abs(X-Y) =< E ].
specialize_R_fn( X =\= Y, boolean) -->
[ scaled_eps(X,Y,E), abs(X-Y) > E ].
scaled_eps( X, Y, Eps) :-
exponent( X, Ex),
exponent( Y, Ey),
arith_eps( E),
Max is max(Ex,Ey),
( Max < 0 ->
Eps is E/(1<<Max)
;
Eps is E*(1<<Max)
).
exponent( X, E) :-
A is abs(X),
float_rat( A, N, D),
E is msb(N+1)-msb(D).
**/
% ----------------------------------------------------------------------
linearize( Term, Res, Linear) :-
linearize( Term, Res, Vs,[], Lin, []),
keysort( Vs, Vss),
( Vss = [], Linear = Lin
; Vss = [V|Vt], join_vars( Vt, V, Linear, Lin)
).
%
% flatten the evaluation, collect variables, shared by Q,R,...
%
linearize( X, R, [X-R|Vs],Vs) --> {var(X)}, !, [ ].
linearize( X, R, Vs,Vs) --> {integer(X)}, !, [ op_integer(R,X) ].
linearize( X, R, Vs,Vs) --> {float(X)}, !, [ op_float(R,X) ].
linearize( rat(N,D), R, Vs,Vs) --> !, [ op_rat(R,N,D) ].
linearize( Term, R, V0,V1) -->
{
functor( Term, N, A),
functor( Skeleton, N, A)
},
linearize_args( A, Term, Skeleton, V0,V1), [ apply(R,Skeleton) ].
linearize_args( 0, _, _, Vs,Vs) --> [].
linearize_args( N, T, S, V0,V2) -->
{
arg( N, T, Arg),
arg( N, S, Res),
N1 is N-1
},
linearize( Arg, Res, V0,V1),
linearize_args( N1, T, S, V1,V2).
join_vars( [], Y-Ry) --> [ op_var(Ry,Y) ].
join_vars( [X-Rx|Xs], Y-Ry) -->
( {X==Y} ->
{Rx=Ry},
join_vars( Xs, Y-Ry)
;
[ op_var(Ry,Y) ],
join_vars( Xs, X-Rx)
).
% ---------------------------------- runtime system ---------------------------
%
% C candidate
%
limit_encoding_length( 0,D, _, 0,D) :- !. % msb ...
limit_encoding_length( N,D, Bits, Nl,Dl) :-
Shift is min(max(msb(abs(N)),msb(D))-Bits,
min(msb(abs(N)),msb(D))),
Shift > 0,
!,
Ns is N>>Shift,
Ds is D>>Shift,
Gcd is gcd(Ns,Ds),
Nl is Ns//Gcd,
Dl is Ds//Gcd.
limit_encoding_length( N,D, _, N,D).
%
% No longer backconvert to integer
%
% putq( 1, N, N) :- !.
putq( D, N, rat(N,D)).
getq( Exp, N,D) :- var( Exp), !,
raise_exception( instantiation_error(getq(Exp,N,D),1)).
getq( I, I,1) :- integer(I), !.
getq( F, N,D) :- float( F), !, float_rat( F, N,D).
getq( rat(N,D), N,D) :-
integer( N),
integer( D),
D > 0,
1 =:= gcd(N,D).
%
% actually just a joke to have this stuff in Q ...
%
expq( N,D, N1,D1) :- rat_float( N,D, X), F is exp(X), float_rat( F, N1,D1).
logq( N,D, N1,D1) :- rat_float( N,D, X), F is log(X), float_rat( F, N1,D1).
sinq( N,D, N1,D1) :- rat_float( N,D, X), F is sin(X), float_rat( F, N1,D1).
cosq( N,D, N1,D1) :- rat_float( N,D, X), F is cos(X), float_rat( F, N1,D1).
tanq( N,D, N1,D1) :- rat_float( N,D, X), F is tan(X), float_rat( F, N1,D1).
asinq( N,D, N1,D1) :- rat_float( N,D, X), F is asin(X), float_rat( F, N1,D1).
acosq( N,D, N1,D1) :- rat_float( N,D, X), F is acos(X), float_rat( F, N1,D1).
atanq( N,D, N1,D1) :- rat_float( N,D, X), F is atan(X), float_rat( F, N1,D1).
%
% for integer powers we can do it in Q
%
expq( Nx,Dx, Ny,Dy, N,D) :-
( Dy =:= 1 ->
( Ny >= 0 ->
powq( Ny, Nx,Dx, 1,1, N,D)
;
Nabs is -Ny,
powq( Nabs, Nx,Dx, 1,1, N1,D1),
( N1 < 0 ->
N is -D1, D is -N1
;
N = D1, D = N1
)
)
;
rat_float( Nx,Dx, Fx),
rat_float( Ny,Dy, Fy),
F is exp(Fx,Fy),
float_rat( F, N, D)
).
%
% positive integer powers of rational
%
powq( 0, _, _, Nt,Dt, Nt,Dt) :- !.
powq( 1, Nx,Dx, Nt,Dt, Nr,Dr) :- !, mulq( Nx,Dx, Nt,Dt, Nr,Dr).
powq( N, Nx,Dx, Nt,Dt, Nr,Dr) :-
N1 is N >> 1,
( N /\ 1 =:= 0 ->
Nt1 = Nt, Dt1 = Dt
;
mulq( Nx,Dx, Nt,Dt, Nt1,Dt1)
),
mulq( Nx,Dx, Nx,Dx, Nxx,Dxx),
powq( N1, Nxx,Dxx, Nt1,Dt1, Nr,Dr).
/*
%
% the choicepoint ruins the party ...
%
mulq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Db),
( Gcd1 =:= 1 -> Na1=Na,Db1=Db; Na1 is Na//Gcd1,Db1 is Db//Gcd1 ),
Gcd2 is gcd(Nb,Da),
( Gcd2 =:= 1 -> Nb1=Nb,Da1=Da; Nb1 is Nb//Gcd2,Da1 is Da//Gcd2 ),
Nc is Na1 * Nb1,
Dc is Da1 * Db1.
*/
mulq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Db),
Na1 is Na//Gcd1,
Db1 is Db//Gcd1,
Gcd2 is gcd(Nb,Da),
Nb1 is Nb//Gcd2,
Da1 is Da//Gcd2,
Nc is Na1 * Nb1,
Dc is Da1 * Db1.
/*
divq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Nb),
( Gcd1 =:= 1 -> Na1=Na,Nb1=Nb; Na1 is Na//Gcd1,Nb1 is Nb//Gcd1 ),
Gcd2 is gcd(Da,Db),
( Gcd2 =:= 1 -> Da1=Da,Db1=Db; Da1 is Da//Gcd2,Db1 is Db//Gcd2 ),
( Nb1 < 0 -> % keep denom positive !!!
Nc is -(Na1 * Db1),
Dc is Da1 * (-Nb1)
;
Nc is Na1 * Db1,
Dc is Da1 * Nb1
).
*/
divq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Nb),
Na1 is Na//Gcd1,
Nb1 is Nb//Gcd1,
Gcd2 is gcd(Da,Db),
Da1 is Da//Gcd2,
Db1 is Db//Gcd2,
( Nb1 < 0 -> % keep denom positive !!!
Nc is -(Na1 * Db1),
Dc is Da1 * (-Nb1)
;
Nc is Na1 * Db1,
Dc is Da1 * Nb1
).
%
% divq_11( Nb,Db, Nc,Dc) :- divq( 1,1, Nb,Db, Nc,Dc).
%
divq_11( Nb,Db, Nc,Dc) :-
( Nb < 0 -> % keep denom positive !!!
Nc is -Db,
Dc is -Nb
;
Nc is Db,
Dc is Nb
).
'divq_-11'( Nb,Db, Nc,Dc) :-
( Nb < 0 -> % keep denom positive !!!
Nc is Db,
Dc is -Nb
;
Nc is -Db,
Dc is Nb
).
/*
addq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
( Gcd1 =:= 1 -> % This is the case (for random input) with
% probability 6/(pi**2).
Nc is Na*Db + Nb*Da,
Dc is Da*Db
;
T is Na*(Db//Gcd1) + Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2)
).
*/
addq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
T is Na*(Db//Gcd1) + Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2).
/*
subq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
( Gcd1 =:= 1 -> % This is the case (for random input) with
% probability 6/(pi**2).
Nc is Na*Db - Nb*Da,
Dc is Da*Db
;
T is Na*(Db//Gcd1) - Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2)
).
*/
subq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
T is Na*(Db//Gcd1) - Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2).
comq( Na,Da, Nb,Db, S) :- % todo: avoid multiplication by looking a signs first !!!
Xa is Na * Db,
Xb is Nb * Da,
compare( S, Xa, Xb).
minq( Na,Da, Nb,Db, N,D) :-
comq( Na,Da, Nb,Db, Rel),
( Rel = =, N=Na, D=Da
; Rel = <, N=Na, D=Da
; Rel = >, N=Nb, D=Db
).
maxq( Na,Da, Nb,Db, N,D) :-
comq( Na,Da, Nb,Db, Rel),
( Rel = =, N=Nb, D=Db
; Rel = <, N=Nb, D=Db
; Rel = >, N=Na, D=Da
).
signumq( N,_, S,1) :-
compare( Rel, N, 0),
rel2sig( Rel, S).
rel2sig( <, -1).
rel2sig( >, 1).
rel2sig( =, 0).
% -----------------------------------------------------------------------------
truncateq( N,D, R,1) :-
R is N // D.
%
% returns the greatest integral value less than or
% equal to x. This corresponds to IEEE rounding toward nega-
% tive infinity
%
floorq( N,1, N,1) :- !.
floorq( N,D, R,1) :-
( N < 0 ->
R is N // D - 1
;
R is N // D
).
%
% returns the least integral value greater than or
% equal to x. This corresponds to IEEE rounding toward posi-
% tive infinity
%
ceilingq( N,1, N,1) :- !.
ceilingq( N,D, R,1) :-
( N > 0 ->
R is N // D + 1
;
R is N // D
).
%
% rounding towards zero
%
roundq( N,D, R,1) :-
% rat_float( N,D, F), % cheating, can do that in Q
% R is integer(round(F)).
I is N//D,
subq( N,D, I,1, Rn,Rd),
Rna is abs(Rn),
( comq( Rna,Rd, 1,2, <) ->
R = I
; I >= 0 ->
R is I+1
;
R is I-1
).
% ------------------------------- rational -> float -------------------------------
%
% The problem here is that SICStus converts BIG fractions N/D into +-nan
% if it does not fit into a float
%
% | ?- X is msb(integer(1.0e+308)).
% X = 1023
%
rat_float( Nx,Dx, F) :-
limit_encoding_length( Nx,Dx, 1023, Nxl,Dxl),
F is Nxl / Dxl.
% ------------------------------- float -> rational -------------------------------
float_rat( F, N, D) :-
float_rat( 100, F, F, 1,0,0,1, N0,D0), % at most 100 iterations
( D0 < 0 -> % sign normalization
D is -D0,
N is -N0
;
D = D0,
N = N0
).
float_rat( 0, _, _, Na,_,Da,_, Na,Da) :- !.
float_rat( _, _, X, Na,_,Da,_, Na,Da) :-
0.0 =:= abs(X-Na/Da),
!.
float_rat( N, F, X, Na,Nb,Da,Db, Nar,Dar) :-
I is integer(F),
( I =:= F -> % guard against zero division
Nar is Na*I+Nb, % 1.0 -> 1/1 and not 0/1 (first iter.) !!!
Dar is Da*I+Db
;
Na1 is Na*I+Nb,
Da1 is Da*I+Db,
F1 is 1/(F-I),
N1 is N-1,
float_rat( N1, F1, X, Na1,Na,Da1,Da, Nar,Dar)
).

128
CLPQR/clpq/bb.pl
View File

@ -1,128 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: bb.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
bb_inf( Is, Term, Inf) :-
bb_inf( Is, Term, Inf, _, 0.001).
bb_inf( Is, Term, Inf, Vertex, Eps) :-
nf( Eps, ENf),
nf_constant( ENf, EpsN),
wait_linear( Term, Nf, bb_inf_internal(Is,Nf,EpsN,Inf,Vertex)).
% ---------------------------------------------------------------------
bb_inf_internal( Is, Lin, Eps, _, _) :-
bb_intern( Is, IsNf),
( bb_delete( incumbent, _) -> true ; true ),
repair( Lin, LinR), % bb_narrow ...
deref( LinR, Lind),
var_with_def_assign( Dep, Lind),
determine_active_dec( Lind),
bb_loop( Dep, IsNf, Eps),
fail.
bb_inf_internal( _, _, _, Inf, Vertex) :-
bb_delete( incumbent, InfVal-Vertex), % GC
{ Inf =:= InfVal }.
bb_loop( Opt, Is, Eps) :-
bb_reoptimize( Opt, Inf),
bb_better_bound( Inf),
vertex_value( Is, Ivs),
( bb_first_nonint( Is, Ivs, Eps, Viol, Floor, Ceiling) ->
bb_branch( Viol, Floor, Ceiling),
bb_loop( Opt, Is, Eps)
;
round_values( Ivs, RoundVertex),
% print( incumbent( Inf-RoundVertex)), nl,
bb_put( incumbent, Inf-RoundVertex)
).
%
% added ineqs may have led to binding
%
bb_reoptimize( Obj, Inf) :- var( Obj), iterate_dec( Obj, Inf).
bb_reoptimize( Obj, Inf) :- nonvar( Obj), Inf = Obj.
bb_better_bound( Inf) :-
bb_get( incumbent, Inc-_),
!,
arith_eval( Inf < Inc).
bb_better_bound( _).
bb_branch( V, U, _) :- { V =< U }.
bb_branch( V, _, L) :- { V >= L }.
vertex_value( [], []).
vertex_value( [X|Xs], [V|Vs]) :-
rhs_value( X, V),
vertex_value( Xs, Vs).
rhs_value( Xn, Value) :- nonvar(Xn), Value=Xn.
rhs_value( Xn, Value) :- var(Xn),
deref_var( Xn, Xd),
decompose( Xd, _, R, I),
arith_eval( R+I, Value).
%
% Need only one as we branch on the first anyway ...
%
bb_first_nonint( [I|Is], [Rhs|Rhss], Eps, Viol, F, C) :-
( arith_eval( floor(Rhs), Floor),
arith_eval( ceiling(Rhs), Ceiling),
arith_eval(min(Rhs-Floor,Ceiling-Rhs) > Eps) ->
Viol = I,
F = Floor,
C = Ceiling
;
bb_first_nonint( Is, Rhss, Eps, Viol, F, C)
).
round_values( [], []).
round_values( [X|Xs], [Y|Ys]) :-
arith_eval( round(X), Y),
round_values( Xs, Ys).
bb_intern( [], []).
bb_intern( [X|Xs], [Xi|Xis]) :-
nf( X, Xnf),
bb_intern( Xnf, Xi, X),
bb_intern( Xs, Xis).
%
% allow more general expressions and conditions? integral(Exp) ???
%
bb_intern( [], X, _) :- !, arith_eval( 0, X).
bb_intern( [v(I,[])], X, _) :- !, X=I.
bb_intern( [v(One,[X^1])], X, _) :-
arith_eval(One=:=1),
!,
get_atts( X, [type(T),strictness(S)]),
bb_narrow( T, S, X).
bb_intern( _, _, Term) :-
raise_exception( instantiation_error(bb_inf(Term,_,_),1)).
bb_narrow( t_l(L), S, V) :-
S /\ 2'10 =\= 0,
!,
arith_eval( floor(1+L), B),
{ V >= B }.
bb_narrow( t_u(U), S, V) :-
S /\ 2'01 =\= 0,
!,
arith_eval( ceiling(U-1), B),
{ V =< B }.
bb_narrow( t_lu(L,U), S, V) :- !,
bb_narrow( t_l(L), S, V),
bb_narrow( t_u(U), S, V).
bb_narrow( _, _, _).

1256
CLPQR/clpq/bv.pl
View File

File diff suppressed because it is too large Load Diff

1256
CLPQR/clpq/bv.yap
View File

File diff suppressed because it is too large Load Diff

86
CLPQR/clpq/compenv.pl
View File

@ -1,86 +0,0 @@
% Copyright (C) 1994, Swedish Institute of Computer Science.
% Provides compile time environment for fcompiling clpq/clpr
:- meta_predicate nfq:geler(?,:).
:- meta_predicate nfr:geler(?,:).
:- meta_predicate clpq:wait_linear(?,?,:).
:- meta_predicate clpr:wait_linear(?,?,:).
%
% Don't report export of private predicates from clpq
%
:- multifile
user:portray_message/2.
:- dynamic
user:portray_message/2.
%
user:portray_message( warning, import(_,_,From,private)) :-
clpqr( From).
clpqr( clpq).
clpqr( clpr).
env_fcompile( Name, Arith) :-
compile_time_env( Name, Arith, Module),
fcompile( Module:Name).
compile_time_env(File, Arith, Module) :-
file_mod(Arith, File, Module),
load_expansions(Module, Arith).
load_expansions(user, _).
load_expansions(arith_q, _).
load_expansions(arith_r, _).
load_expansions(classq, _) :- [class]. % atts
load_expansions(classr, _) :- [class]. % atts
load_expansions(geler_q, _) :- [geler]. % atts
load_expansions(geler_r, _) :- [geler]. % atts
load_expansions(nfq, Arith) :-
nfq:[Arith]. % macros
load_expansions(nfr, Arith) :-
nfr:[Arith]. % macros
load_expansions(clpr, Arith) :-
clpr:[Arith], % macros
clpr:[itf3], % atts
clpr:[store]. % macros
load_expansions(clpq, Arith) :-
clpq:[Arith], % macros
clpq:[itf3], % atts
clpq:[store]. % macros
file_mod(arith_q, arith, arith_q).
file_mod(arith_r, arith, arith_r).
file_mod(arith_q, arith_q, arith_q).
file_mod(arith_r, arith_r, arith_r).
file_mod(arith_q, bb, clpq).
file_mod(arith_r, bb, clpr).
file_mod(arith_q, bv, clpq).
file_mod(arith_r, bv, clpr).
file_mod(arith_q, class, classq).
file_mod(arith_r, class, classr).
file_mod(_, compenv, user).
file_mod(arith_q, dump, clpq).
file_mod(arith_r, dump, clpr).
file_mod(arith_q, fourmotz, clpq).
file_mod(arith_r, fourmotz, clpr).
file_mod(arith_q, geler, geler_q).
file_mod(arith_r, geler, geler_r).
file_mod(arith_q, ineq, clpq).
file_mod(arith_r, ineq, clpr).
file_mod(arith_q, itf3, clpq).
file_mod(arith_r, itf3, clpr).
file_mod(arith_q, nf, nfq).
file_mod(arith_r, nf, nfr).
file_mod(arith_q, nfq, nfq).
file_mod(arith_r, nfr, nfr).
file_mod(arith_q, ordering, classq).
file_mod(arith_r, ordering, classr).
file_mod(arith_q, project, clpq).
file_mod(arith_r, project, clpr).
file_mod(arith_q, redund, clpq).
file_mod(arith_r, redund, clpr).
file_mod(arith_q, store, clpq).
file_mod(arith_r, store, clpr).

147
CLPQR/clpq/dump.pl
View File

@ -1,147 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: dump.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
dump( +Target, ?NewVars, ?CodedAnswer)
where Target and NewVars are lists of variables of equal length and
CodedAnswer is the term representation of the projection of constraints
onto the target variables where the target variables are replaced by
the corresponding variables from NewVars.
*/
:- use_module( library(terms), [term_variables/2]).
:- use_module( library(assoc),
[
empty_assoc/1,
get_assoc/3,
put_assoc/4,
assoc_to_list/2
]).
dump( Target, NewVars, Constraints) :-
(
( proper_varlist( Target) ->
true
;
raise_exception(instantiation_error(dump(Target,NewVars,Constraints),1))
),
ordering( Target),
related_linear_vars( Target, All),
nonlin_crux( All, Nonlin),
project_attributes( Target, All),
related_linear_vars( Target, Again), % project drops/adds vars
all_attribute_goals( Again, Gs, Nonlin),
empty_assoc( D0),
mapping( Target, NewVars, D0,D1), % late (AVL suffers from put_atts)
copy( Gs, Copy, D1,_), % strip constraints
bb_put( copy, NewVars/Copy),
fail % undo projection
;
bb_delete( copy, NewVars/Constraints) % garbage collect
).
proper_varlist( X) :- var( X), !, fail.
proper_varlist( []).
proper_varlist( [X|Xs]) :-
var( X),
proper_varlist( Xs).
related_linear_vars( Vs, All) :-
empty_assoc( S0),
related_linear_sys( Vs, S0,Sys),
related_linear_vars( Sys, All, []).
related_linear_sys( [], S0,L0) :- assoc_to_list( S0, L0).
related_linear_sys( [V|Vs], S0,S2) :-
( get_atts( V, class(C)) ->
put_assoc( C, S0, C, S1)
;
S1 = S0
),
related_linear_sys( Vs, S1,S2).
related_linear_vars( []) --> [].
related_linear_vars( [S-_|Ss]) -->
{
class_allvars( S, Otl)
},
cpvars( Otl),
related_linear_vars( Ss).
cpvars( Xs) --> {var(Xs)}, !.
cpvars( [X|Xs]) -->
( {var(X)} -> [X] ; [] ),
cpvars( Xs).
nonlin_crux( All, Gss) :-
collect_nonlin( All, Gs, []), % destructive
this_linear_solver( Solver),
nonlin_strip( Gs, Solver, Gss).
nonlin_strip( [], _, []).
nonlin_strip( [M:What|Gs], Solver, Res) :-
( M == Solver ->
( What = {G} ->
Res = [G|Gss]
;
Res = [What|Gss]
)
;
Res = Gss
),
nonlin_strip( Gs, Solver, Gss).
all_attribute_goals( []) --> [].
all_attribute_goals( [V|Vs]) -->
dump_linear( V, toplevel),
dump_nonzero( V, toplevel),
all_attribute_goals( Vs).
mapping( [], [], D0,D0).
mapping( [T|Ts], [N|Ns], D0,D2) :-
put_assoc( T, D0, N, D1),
mapping( Ts, Ns, D1,D2).
copy( Term, Copy, D0,D1) :- var( Term),
( get_assoc( Term, D0, New) ->
Copy = New,
D1 = D0
;
put_assoc( Term, D0, Copy, D1)
).
copy( Term, Copy, D0,D1) :- nonvar( Term),
functor( Term, N, A),
functor( Copy, N, A),
copy( A, Term, Copy, D0,D1).
copy( 0, _, _, D0,D0) :- !.
copy( 1, T, C, D0,D1) :- !,
arg( 1, T, At1),
arg( 1, C, Ac1),
copy( At1, Ac1, D0,D1).
copy( 2, T, C, D0,D2) :- !,
arg( 1, T, At1),
arg( 1, C, Ac1),
copy( At1, Ac1, D0,D1),
arg( 2, T, At2),
arg( 2, C, Ac2),
copy( At2, Ac2, D1,D2).
copy( N, T, C, D0,D2) :-
arg( N, T, At),
arg( N, C, Ac),
copy( At, Ac, D0,D1),
N1 is N-1,
copy( N1, T, C, D1,D2).
end_of_file.

294
CLPQR/clpq/fourmotz.pl
View File

@ -1,294 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.2 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: fourmotz.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% TODO -) remove syntactic redundancy first ?!!
% -) avoid the construction of the crossproduct list
% +) consider strictness in crossproduct generation !!!
%
fm_elim( Vs, Target, Pivots) :-
prefilter( Vs, Vsf),
fm_elim_int( Vsf, Target, Pivots).
prefilter( [], []).
prefilter( [V|Vs], Res) :-
( get_atts( V, -target),
occurs( V) ->
Res = [V|Tail],
put_atts( V, keep_indep),
prefilter( Vs, Tail)
;
prefilter( Vs, Res)
).
%
% the target variables are marked with an attribute, and we get a list
% of them as an argument too
%
fm_elim_int( [], _, Pivots) :- % done
unkeep( Pivots).
fm_elim_int( Vs, Target, Pivots) :-
Vs = [_|_],
( best( Vs, Best, Rest) ->
occurences( Best, Occ),
elim_min( Best, Occ, Target, Pivots, NewPivots)
; % give up
NewPivots=Pivots, Rest = []
),
fm_elim_int( Rest, Target, NewPivots).
%
% Find the variable with the smallest netto increase on the
% size of the ineq. system after its elimination
%
best( Vs, Best, Rest) :-
findall( Delta-N, fm_cp_filter( Vs, Delta, N), Deltas),
keysort( Deltas, [_-N|_]),
select_nth( Vs, N, Best, Rest).
fm_cp_filter( Vs, Delta, N) :-
length( Vs, Len),
mem( Vs,X,Vst),
get_atts( X, [-target,lin(Lin)]),
indep( Lin, X),
occurences( X, Occ),
Occ = [_|_],
% crossproduct( Occ, New, []),
% length( New, CpLnew),
cp_card( Occ, 0,Lnew),
length( Occ, Locc),
Delta is Lnew-Locc,
length( Vst, Vstl),
N is Len-Vstl.
mem( [X|Xs], X, Xs).
mem( [_|Ys], X, Xs) :- mem( Ys, X, Xs).
select_nth( List, N, Nth, Others) :-
select_nth( List, 1,N, Nth, Others).
select_nth( [X|Xs], N,N, X, Xs) :- !.
select_nth( [Y|Ys], M,N, X, [Y|Xs]) :-
M1 is M+1,
select_nth( Ys, M1,N, X, Xs).
%
% fm_detach + reverse_pivot introduce indep t_none, which
% invalidates the invariants
%
elim_min( V, Occ, Target, Pivots, NewPivots) :-
crossproduct( Occ, New, []),
activate_crossproduct( New),
reverse_pivot( Pivots),
fm_detach( Occ),
% length( Occ, Locc), length( New, Lnew), print( fm(-Locc,+Lnew)), nl,
allvars( V, All),
redundancy_vars( All), % only for New \== []
make_target_indep( Target, NewPivots),
drop_dep( All).
%
% restore NF by reverse pivoting
%
reverse_pivot( []).
reverse_pivot( [I:D|Ps]) :-
get_atts( D, type(Dt)),
put_atts( D, -keep), % no longer
pivot( D, I, Dt),
reverse_pivot( Ps).
unkeep( []).
unkeep( [_:D|Ps]) :-
put_atts( D, -keep),
drop_dep_one( D),
unkeep( Ps).
%
% All we drop are bounds
%
fm_detach( []).
fm_detach( [V:_|Vs]) :-
detach_bounds( V),
fm_detach( Vs).
%
% Todo: maybe bulk_basis_add
%
activate_crossproduct( []).
activate_crossproduct( [lez(Strict,Lin)|News]) :-
arith_eval( 0, Z),
var_with_def_intern( t_u(Z), Var, Lin, Strict),
basis_add( Var, _),
activate_crossproduct( News).
% ------------------------------------------------------------------------------
crossproduct( []) --> [].
crossproduct( [A|As]) -->
crossproduct( As, A),
crossproduct( As).
crossproduct( [], _) --> [].
crossproduct( [B:Kb|Bs], A:Ka) -->
{
get_atts( A, [type(Ta),lin(LinA),strictness(Sa)]),
get_atts( B, [type(Tb),lin(LinB),strictness(Sb)]),
arith_eval( -Kb/Ka, K),
add_linear_f1( LinA, K, LinB, Lin)
},
( { arith_eval( K > 0) } -> % signs were opposite
{ Strict is Sa \/ Sb },
cross_lower( Ta, Tb, K, Lin, Strict),
cross_upper( Ta, Tb, K, Lin, Strict)
; % La =< A =< Ua -> -Ua =< -A =< -La
{
flip( Ta, Taf),
flip_strict( Sa, Saf),
Strict is Saf \/ Sb
},
cross_lower( Taf, Tb, K, Lin, Strict),
cross_upper( Taf, Tb, K, Lin, Strict)
),
crossproduct( Bs, A:Ka).
cross_lower( Ta, Tb, K, Lin, Strict) -->
{
lower( Ta, La),
lower( Tb, Lb),
!,
arith_eval(K*La+Lb,L),
normalize_scalar( L, Ln),
arith_eval( -1, Mone),
add_linear_f1( Lin, Mone, Ln, Lhs),
Sl is Strict >> 1 % normalize to upper bound
},
[ lez(Sl,Lhs) ].
cross_lower( _, _, _, _, _) --> [].
cross_upper( Ta, Tb, K, Lin, Strict) -->
{
upper( Ta, Ua),
upper( Tb, Ub),
!,
arith_eval(-(K*Ua+Ub),U),
normalize_scalar( U, Un),
add_linear_11( Un, Lin, Lhs),
Su is Strict /\ 2'01 % normalize to upper bound
},
[ lez(Su,Lhs) ].
cross_upper( _, _, _, _, _) --> [].
lower( t_l(L), L).
lower( t_lu(L,_), L).
lower( t_L(L), L).
lower( t_Lu(L,_), L).
lower( t_lU(L,_), L).
upper( t_u(U), U).
upper( t_lu(_,U), U).
upper( t_U(U), U).
upper( t_Lu(_,U), U).
upper( t_lU(_,U), U).
flip( t_l(X), t_u(X)).
flip( t_u(X), t_l(X)).
flip( t_lu(X,Y),t_lu(Y,X)).
flip( t_L(X), t_u(X)).
flip( t_U(X), t_l(X)).
flip( t_lU(X,Y),t_lu(Y,X)).
flip( t_Lu(X,Y),t_lu(Y,X)).
flip_strict( 2'00, 2'00).
flip_strict( 2'01, 2'10).
flip_strict( 2'10, 2'01).
flip_strict( 2'11, 2'11).
cp_card( [], Ci,Ci).
cp_card( [A|As], Ci,Co) :-
cp_card( As, A, Ci,Cii),
cp_card( As, Cii,Co).
cp_card( [], _, Ci,Ci).
cp_card( [B:Kb|Bs], A:Ka, Ci,Co) :-
get_atts( A, type(Ta)),
get_atts( B, type(Tb)),
arith_eval( -Kb/Ka, K),
( arith_eval( K > 0) -> % signs were opposite
cp_card_lower( Ta, Tb, Ci,Cii),
cp_card_upper( Ta, Tb, Cii,Ciii)
;
flip( Ta, Taf),
cp_card_lower( Taf, Tb, Ci,Cii),
cp_card_upper( Taf, Tb, Cii,Ciii)
),
cp_card( Bs, A:Ka, Ciii,Co).
cp_card_lower( Ta, Tb, Si,So) :-
lower( Ta, _),
lower( Tb, _),
!,
So is Si+1.
cp_card_lower( _, _, Si,Si).
cp_card_upper( Ta, Tb, Si,So) :-
upper( Ta, _),
upper( Tb, _),
!,
So is Si+1.
cp_card_upper( _, _, Si,Si).
% ------------------------------------------------------------------------------
occurences( V, Occ) :-
allvars( V, All),
occurences( All, V, Occ).
occurences( De, _, []) :- var( De), !.
occurences( [D|De], V, Occ) :-
( get_atts( D, [lin(Lin),type(Type)]),
occ_type_filter( Type),
nf_coeff_of( Lin, V, K) ->
Occ = [D:K|Occt],
occurences( De, V, Occt)
;
occurences( De, V, Occ)
).
occ_type_filter( t_l(_)).
occ_type_filter( t_u(_)).
occ_type_filter( t_lu(_,_)).
occ_type_filter( t_L(_)).
occ_type_filter( t_U(_)).
occ_type_filter( t_lU(_,_)).
occ_type_filter( t_Lu(_,_)).
%
% occurs( V) :- occurences( V, Occ), Occ = [_|_].
%
occurs( V) :-
allvars( V, All),
occurs( All, V).
occurs( De, _) :- var( De), !, fail.
occurs( [D|De], V) :-
( get_atts( D, [lin(Lin),type(Type)]),
occ_type_filter( Type),
nf_coeff_of( Lin, V, _) ->
true
;
occurs( De, V)
).

3
CLPQR/clpq/geler.yap
View File

@ -107,7 +107,8 @@ transg( M:G) --> !,
M:transg( G).
transg( G) --> [ G ].
run( Mutex, _) :- nonvar(Mutex).
%vsc: added ! (01/06/06)
run( Mutex, _) :- nonvar(Mutex), !.
run( Mutex, G) :- var(Mutex), Mutex=done, call( G).
:- meta_predicate geler(+,:).

984
CLPQR/clpq/ineq.pl
View File

@ -1,984 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.2 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: ineq.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Lin (=)< 0
%
ineq( [], I, _, Strictness) :- ineq_ground( Strictness, I).
ineq( [v(K,[X^1])|Tail], I, Lin, Strictness) :-
ineq_cases( Tail, I, Lin, Strictness, X, K).
ineq_cases( [], I, _, Strictness, X, K) :-
ineq_one( Strictness, X, K, I).
ineq_cases( [_|_], _, Lin, Strictness, _, _) :-
deref( Lin, Lind), % Id+Hd =< 0
decompose( Lind, Hom, _, Inhom),
ineq_more( Hom, Inhom, Lind, Strictness).
ineq_ground( strict, I) :- arith_eval( I < 0).
ineq_ground( nonstrict, I) :- arith_eval( I =< 0).
%
% Special cases: k={+-}1,i=0
%
ineq_one( strict, X, K, I) :-
( arith_eval(K>0) ->
( arith_eval(I=:=0) ->
ineq_one_s_p_0( X)
;
arith_eval( I/K, Inhom),
ineq_one_s_p_i( X, Inhom)
)
;
( arith_eval(I=:=0) ->
ineq_one_s_n_0( X)
;
arith_eval( -I/K, Inhom),
ineq_one_s_n_i( X, Inhom)
)
).
ineq_one( nonstrict, X, K, I) :-
( arith_eval(K>0) ->
( arith_eval(I=:=0) ->
ineq_one_n_p_0( X)
;
arith_eval( I/K, Inhom),
ineq_one_n_p_i( X, Inhom)
)
;
( arith_eval(I=:=0) ->
ineq_one_n_n_0( X)
;
arith_eval( -I/K, Inhom),
ineq_one_n_n_i( X, Inhom)
)
).
/*
ineq_one( Strictness, X, K, I) :-
get_atts( X, lin(LinX)),
!, % old variable, this is deref
decompose( LinX, OrdX, _, Ix),
ineq_one_old( OrdX, K, I, Strictness, X, Ix).
ineq_one( Strictness, X, K, I) :- % new variable, nothing depends on it
arith_eval( -I/K, Bound),
ineq_one_new( Strictness, X, K, Bound).
ineq_one_new( strict, X, K, Bound) :-
arith_eval( 1, One),
( arith_eval( K < 0) ->
var_intern( t_l(Bound), X, 2'10)
;
var_intern( t_u(Bound), X, 2'01)
).
ineq_one_new( nonstrict, X, K, Bound) :-
arith_eval( 1, One),
( arith_eval( K < 0) ->
var_intern( t_l(Bound), X, 2'00)
;
var_intern( t_u(Bound), X, 2'00)
).
ineq_one_old( [], K, I, Strictness, _X, Ix) :-
arith_eval( K*Ix+I, Inhom),
ineq_ground( Strictness, Inhom).
%
% here we would have the choice to bound X or Y
%
ineq_one_old( [Y*Ky|Tail], K, I, Strictness, X, Ix) :-
( Tail = [],
arith_eval( K*Ky, Coeff),
arith_eval( -(K*Ix+I)/Coeff, Bound),
update_indep( Strictness, Y, Coeff, Bound)
; Tail = [_|_],
arith_eval( -I/K, Bound),
update_dep( Strictness, X, K, Bound)
).
update_dep( strict, X, K, Bound) :-
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
( arith_eval( K < 0) ->
udls( Type, X, Lin, Bound, Old)
;
udus( Type, X, Lin, Bound, Old)
).
update_dep( nonstrict, X, K, Bound) :-
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
( arith_eval( K < 0) ->
udl( Type, X, Lin, Bound, Old)
;
udu( Type, X, Lin, Bound, Old)
).
*/
% --------------------------- strict ----------------------------
ineq_one_s_p_0( X) :-
get_atts( X, lin(LinX)),
!, % old variable, this is deref
decompose( LinX, OrdX, _, Ix),
ineq_one_old_s_p_0( OrdX, X, Ix).
ineq_one_s_p_0( X) :- % new variable, nothing depends on it
arith_eval( 0, Zero),
var_intern( t_u(Zero), X, 2'01).
ineq_one_s_n_0( X) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_s_n_0( OrdX, X, Ix).
ineq_one_s_n_0( X) :-
arith_eval( 0, Zero),
var_intern( t_l(Zero), X, 2'10).
ineq_one_s_p_i( X, I) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_s_p_i( OrdX, I, X, Ix).
ineq_one_s_p_i( X, I) :-
arith_eval( -I, Bound),
var_intern( t_u(Bound), X, 2'01).
ineq_one_s_n_i( X, I) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_s_n_i( OrdX, I, X, Ix).
ineq_one_s_n_i( X, I) :-
var_intern( t_l(I), X, 2'10).
ineq_one_old_s_p_0( [], _, Ix) :-
arith_eval( Ix < 0).
ineq_one_old_s_p_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
arith_eval( -Ix/Ky, Bound),
update_indep( strict, Y, Ky, Bound)
; Tail = [_|_],
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udus( Type, X, Lin, Zero, Old)
).
ineq_one_old_s_n_0( [], _, Ix) :-
arith_eval( Ix > 0).
ineq_one_old_s_n_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
arith_eval( -Ky, Coeff),
arith_eval( Ix/Coeff, Bound),
update_indep( strict, Y, Coeff, Bound)
; Tail = [_|_],
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udls( Type, X, Lin, Zero, Old)
).
ineq_one_old_s_p_i( [], I, _, Ix) :-
arith_eval( Ix+I < 0).
ineq_one_old_s_p_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
arith_eval( -(Ix+I)/Ky, Bound),
update_indep( strict, Y, Ky, Bound)
; Tail = [_|_],
arith_eval( -I, Bound),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udus( Type, X, Lin, Bound, Old)
).
ineq_one_old_s_n_i( [], I, _, Ix) :-
arith_eval( -Ix+I < 0).
ineq_one_old_s_n_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
arith_eval( -Ky, Coeff),
arith_eval( (Ix-I)/Coeff, Bound),
update_indep( strict, Y, Coeff, Bound)
; Tail = [_|_],
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udls( Type, X, Lin, I, Old)
).
% -------------------------- nonstrict --------------------------
ineq_one_n_p_0( X) :-
get_atts( X, lin(LinX)),
!, % old variable, this is deref
decompose( LinX, OrdX, _, Ix),
ineq_one_old_n_p_0( OrdX, X, Ix).
ineq_one_n_p_0( X) :- % new variable, nothing depends on it
arith_eval( 0, Zero),
var_intern( t_u(Zero), X, 2'00).
ineq_one_n_n_0( X) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_n_n_0( OrdX, X, Ix).
ineq_one_n_n_0( X) :-
arith_eval( 0, Zero),
var_intern( t_l(Zero), X, 2'00).
ineq_one_n_p_i( X, I) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_n_p_i( OrdX, I, X, Ix).
ineq_one_n_p_i( X, I) :-
arith_eval( -I, Bound),
var_intern( t_u(Bound), X, 2'00).
ineq_one_n_n_i( X, I) :-
get_atts( X, lin(LinX)),
!,
decompose( LinX, OrdX, _, Ix),
ineq_one_old_n_n_i( OrdX, I, X, Ix).
ineq_one_n_n_i( X, I) :-
var_intern( t_l(I), X, 2'00).
ineq_one_old_n_p_0( [], _, Ix) :-
arith_eval( Ix =< 0).
ineq_one_old_n_p_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
arith_eval( -Ix/Ky, Bound),
update_indep( nonstrict, Y, Ky, Bound)
; Tail = [_|_],
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udu( Type, X, Lin, Zero, Old)
).
ineq_one_old_n_n_0( [], _, Ix) :-
arith_eval( Ix >= 0).
ineq_one_old_n_n_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
arith_eval( -Ky, Coeff),
arith_eval( Ix/Coeff, Bound),
update_indep( nonstrict, Y, Coeff, Bound)
; Tail = [_|_],
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udl( Type, X, Lin, Zero, Old)
).
ineq_one_old_n_p_i( [], I, _, Ix) :-
arith_eval( Ix+I =< 0).
ineq_one_old_n_p_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
arith_eval( -(Ix+I)/Ky, Bound),
update_indep( nonstrict, Y, Ky, Bound)
; Tail = [_|_],
arith_eval( -I, Bound),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udu( Type, X, Lin, Bound, Old)
).
ineq_one_old_n_n_i( [], I, _, Ix) :-
arith_eval( -Ix+I =< 0).
ineq_one_old_n_n_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
arith_eval( -Ky, Coeff),
arith_eval( (Ix-I)/Coeff, Bound),
update_indep( nonstrict, Y, Coeff, Bound)
; Tail = [_|_],
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udl( Type, X, Lin, I, Old)
).
% ---------------------------------------------------------------
ineq_more( [], I, _, Strictness) :- ineq_ground( Strictness, I).
ineq_more( [X*K|Tail], Id, Lind, Strictness) :-
( Tail = [], % one var: update bound instead of slack introduction
get_or_add_class( X, _),
arith_eval( -Id/K, Bound),
update_indep( Strictness, X, K, Bound)
; Tail = [_|_],
ineq_more( Strictness, Lind)
).
ineq_more( strict, Lind) :-
( unconstrained( Lind, U,K, Rest) -> % never fails, no implied value
arith_eval( 0, Z),
arith_eval( 1, One),
var_intern( t_l(Z), S, 2'10),
arith_eval( -1/K, Ki),
add_linear_ff( Rest, Ki, [Z,Z,S*One], Ki, LinU),
decompose( LinU, Hu, _, _),
get_or_add_class( U, Class),
same_class( Hu, Class),
backsubst( U, LinU)
;
arith_eval( 0, Z),
var_with_def_intern( t_u(Z), S, Lind, 2'01),
basis_add( S, _),
determine_active_dec( Lind),
reconsider( S)
).
ineq_more( nonstrict, Lind) :-
( unconstrained( Lind, U,K, Rest) -> % never fails, no implied value
arith_eval( 0, Z),
arith_eval( 1, One),
var_intern( t_l(Z), S, 2'00),
arith_eval( -1/K, Ki),
add_linear_ff( Rest, Ki, [Z,Z,S*One], Ki, LinU),
decompose( LinU, Hu, _, _),
get_or_add_class( U, Class),
same_class( Hu, Class),
backsubst( U, LinU)
;
arith_eval( 0, Z),
var_with_def_intern( t_u(Z), S, Lind, 2'00),
basis_add( S, _),
determine_active_dec( Lind),
reconsider( S)
).
update_indep( strict, X, K, Bound) :-
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
( arith_eval( K < 0) ->
uils( Type, X, Lin, Bound, Old)
;
uius( Type, X, Lin, Bound, Old)
).
update_indep( nonstrict, X, K, Bound) :-
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
( arith_eval( K < 0) ->
uil( Type, X, Lin, Bound, Old)
;
uiu( Type, X, Lin, Bound, Old)
).
% ---------------------------------------------------------------------------------------
%
% Update a bound on a var xi
%
% a) independent variable
%
% a1) update inactive bound: done
%
% a2) update active bound:
% Determine [lu]b including most constraining row R
% If we are within: done
% else pivot(R,xi) and introduce bound via (b)
%
% a3) introduce a bound on an unconstrained var:
% All vars that depend on xi are unconstrained (invariant) ->
% the bound cannot invalidate any Lhs
%
% b) dependent variable
%
% repair upper or lower (maybe just swap with an unconstrained var from Rhs)
%
%
% Sign = 1,0,-1 means inside,at,outside
%
udl( t_none, X, Lin, Bound, _Sold) :-
put_atts( X, [type(t_l(Bound)),strictness(2'00)]),
( unconstrained( Lin, Uc,Kuc, Rest) ->
arith_eval( -1/Kuc, Ki),
arith_eval( 0, Z),
arith_eval( -1, Mone),
add_linear_ff( Rest, Ki, [Z,Z,X*Mone], Ki, LinU),
backsubst( Uc, LinU)
;
basis_add( X, _),
determine_active_inc( Lin),
reconsider( X)
).
udl( t_l(L), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
Strict is Sold /\ 2'01,
put_atts( X, [type(t_l(Bound)),strictness(Strict)]),
reconsider_lower( X, Lin, Bound)
)).
udl( t_u(U), X, Lin, Bound, _Sold) :-
case_signum( U-Bound,
fail,
solve_bound( Lin, Bound),
(
put_atts( X, type(t_lu(Bound,U))),
reconsider_lower( X, Lin, Bound)
)).
udl( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
case_signum( U-Bound,
fail,
(
Sold /\ 2'01 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'01,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)]),
reconsider_lower( X, Lin, Bound)
))
)).
udls( t_none, X, Lin, Bound, _Sold) :-
put_atts( X, [type(t_l(Bound)),strictness(2'10)]),
( unconstrained( Lin, Uc,Kuc, Rest) ->
arith_eval( -1/Kuc, Ki),
arith_eval( -1, Mone),
arith_eval( 0, Z),
add_linear_ff( Rest, Ki, [Z,Z,X*Mone], Ki, LinU),
backsubst( Uc, LinU)
;
basis_add( X, _),
determine_active_inc( Lin),
reconsider( X)
).
udls( t_l(L), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'10,
put_atts( X, [type(t_l(Bound)),strictness(Strict)]),
reconsider_lower( X, Lin, Bound)
)).
udls( t_u(U), X, Lin, Bound, Sold) :-
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)]),
reconsider_lower( X, Lin, Bound).
udls( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)]),
reconsider_lower( X, Lin, Bound)
)).
udu( t_none, X, Lin, Bound, _Sold) :-
put_atts( X, [type(t_u(Bound)),strictness(2'00)]),
( unconstrained( Lin, Uc,Kuc, Rest) ->
arith_eval( -1/Kuc, Ki),
arith_eval( -1, Mone),
arith_eval( 0, Z),
add_linear_ff( Rest, Ki, [Z,Z,X*Mone], Ki, LinU),
backsubst( Uc, LinU)
;
basis_add( X, _),
determine_active_dec( Lin),
reconsider( X)
).
udu( t_u(U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
Strict is Sold /\ 2'10,
put_atts( X, [type(t_u(Bound)),strictness(Strict)]),
reconsider_upper( X, Lin, Bound)
)).
udu( t_l(L), X, Lin, Bound, _Sold) :-
case_signum( Bound-L,
fail,
solve_bound( Lin, Bound),
(
put_atts( X, type(t_lu(L,Bound))),
reconsider_upper( X, Lin, Bound)
)).
udu( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
case_signum( Bound-L,
fail,
(
Sold /\ 2'10 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'10,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)]),
reconsider_upper( X, Lin, Bound)
))
)).
udus( t_none, X, Lin, Bound, _Sold) :-
put_atts( X, [type(t_u(Bound)),strictness(2'01)]),
( unconstrained( Lin, Uc,Kuc, Rest) ->
arith_eval( -1/Kuc, Ki),
arith_eval( -1, Mone),
arith_eval( 0, Z),
add_linear_ff( Rest, Ki, [Z,Z,X*Mone], Ki, LinU),
backsubst( Uc, LinU)
;
basis_add( X, _),
determine_active_dec( Lin),
reconsider( X)
).
udus( t_u(U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'01,
put_atts( X, [type(t_u(Bound)),strictness(Strict)]),
reconsider_upper( X, Lin, Bound)
)).
udus( t_l(L), X, Lin, Bound, Sold) :-
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)]),
reconsider_upper( X, Lin, Bound).
udus( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)]),
reconsider_upper( X, Lin, Bound)
)).
uiu( t_none, X, _Lin, Bound, _) :-
put_atts( X, [type(t_u(Bound)),strictness(2'00)]).
uiu( t_u(U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
Strict is Sold /\ 2'10,
put_atts( X, [type(t_u(Bound)),strictness(Strict)])
)).
uiu( t_l(L), X, Lin, Bound, _Sold) :-
case_signum( Bound-L,
fail,
solve_bound( Lin, Bound),
put_atts( X, type(t_lu(L,Bound)))).
uiu( t_L(L), X, Lin, Bound, _Sold) :-
case_signum( Bound-L,
fail,
solve_bound( Lin, Bound),
put_atts( X, type(t_Lu(L,Bound)))).
uiu( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
case_signum( Bound-L,
fail,
(
Sold /\ 2'10 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'10,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)])
))
)).
uiu( t_Lu(L,U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
case_signum( Bound-L,
fail,
(
Sold /\ 2'10 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'10,
put_atts( X, [type(t_Lu(L,Bound)),strictness(Strict)])
))
)).
%
% update active:
%
uiu( t_U(U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
Strict is Sold /\ 2'10,
( lb( X, Vlb-Vb-Lb),
arith_eval( Bound =< Lb+U) ->
put_atts( X, [type(t_U(Bound)),strictness(Strict)]),
pivot_a( Vlb, X, Vb, t_u(Bound)),
reconsider( X)
;
put_atts( X, [type(t_U(Bound)),strictness(Strict)]),
arith_eval( Bound-U, Delta),
backsubst_delta( X, Delta)
)
)).
uiu( t_lU(L,U), X, Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
true,
(
case_signum( Bound-L,
fail,
(
Sold /\ 2'10 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'10,
( lb( X, Vlb-Vb-Lb),
arith_eval( Bound =< Lb+U) ->
put_atts( X, [type(t_lU(L,Bound)),strictness(Strict)]),
pivot_a( Vlb, X, Vb, t_lu(L,Bound)),
reconsider( X)
;
put_atts( X, [type(t_lU(L,Bound)),strictness(Strict)]),
arith_eval( Bound-U, Delta),
backsubst_delta( X, Delta)
)
))
)).
uius( t_none, X, _Lin, Bound, _Sold) :-
put_atts( X, [type(t_u(Bound)),strictness(2'01)]).
uius( t_u(U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'01,
put_atts( X, [type(t_u(Bound)),strictness(Strict)])
)).
uius( t_l(L), X, _Lin, Bound, Sold) :-
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)]).
uius( t_L(L), X, _Lin, Bound, Sold) :-
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_Lu(L,Bound)),strictness(Strict)]).
uius( t_lu(L,U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_lu(L,Bound)),strictness(Strict)])
)).
uius( t_Lu(L,U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
put_atts( X, [type(t_Lu(L,Bound)),strictness(Strict)])
)).
%
% update active:
%
uius( t_U(U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'01,
( lb( X, Vlb-Vb-Lb),
arith_eval( Bound =< Lb+U) ->
put_atts( X, [type(t_U(Bound)),strictness(Strict)]),
pivot_a( Vlb, X, Vb, t_u(Bound)),
reconsider( X)
;
put_atts( X, [type(t_U(Bound)),strictness(Strict)]),
arith_eval( Bound-U, Delta),
backsubst_delta( X, Delta)
)
)).
uius( t_lU(L,U), X, _Lin, Bound, Sold) :-
case_signum( U-Bound,
true,
(
Strict is Sold \/ 2'01,
put_atts( X, strictness(Strict))
),
(
arith_eval( Bound>L),
Strict is Sold \/ 2'01,
( lb( X, Vlb-Vb-Lb),
arith_eval( Bound =< Lb+U) ->
put_atts( X, [type(t_lU(L,Bound)),strictness(Strict)]),
pivot_a( Vlb, X, Vb, t_lu(L,Bound)),
reconsider( X)
;
put_atts( X, [type(t_lU(L,Bound)),strictness(Strict)]),
arith_eval( Bound-U, Delta),
backsubst_delta( X, Delta)
)
)).
uil( t_none, X, _Lin, Bound, _Sold) :-
put_atts( X, [type(t_l(Bound)),strictness(2'00)]).
uil( t_l(L), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
Strict is Sold /\ 2'01,
put_atts( X, [type(t_l(Bound)),strictness(Strict)])
)).
uil( t_u(U), X, Lin, Bound, _Sold) :-
case_signum( U-Bound,
fail,
solve_bound( Lin, Bound),
put_atts( X, type(t_lu(Bound,U)))).
uil( t_U(U), X, Lin, Bound, _Sold) :-
case_signum( U-Bound,
fail,
solve_bound( Lin, Bound),
put_atts( X, type(t_lU(Bound,U)))).
uil( t_lu(L,U), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
case_signum( U-Bound,
fail,
(
Sold /\ 2'01 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'01,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)])
))
)).
uil( t_lU(L,U), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
case_signum( U-Bound,
fail,
(
Sold /\ 2'01 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'01,
put_atts( X, [type(t_lU(Bound,U)),strictness(Strict)])
))
)).
%
% update active bound: % { a>=100,d=<5000,c>=10,-2*a+d-c=10,a>=2490 }.
%
uil( t_L(L), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
Strict is Sold /\ 2'01,
( ub( X, Vub-Vb-Ub),
arith_eval( Bound >= Ub+L) ->
put_atts( X, [type(t_L(Bound)),strictness(Strict)]),
pivot_a( Vub, X, Vb, t_l(Bound)),
reconsider( X)
; %
% max(X) >= Ub, no implied value missed
%
put_atts( X, [type(t_L(Bound)),strictness(Strict)]),
arith_eval( Bound-L, Delta),
backsubst_delta( X, Delta)
)
)).
uil( t_Lu(L,U), X, Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
true,
(
case_signum( U-Bound,
fail,
(
Sold /\ 2'01 =:= 0,
solve_bound( Lin, Bound)
),
(
Strict is Sold /\ 2'01,
( ub( X, Vub-Vb-Ub),
arith_eval( Bound >= Ub+L) ->
put_atts( X, [type(t_Lu(Bound,U)),strictness(Strict)]),
pivot_a( Vub, X, Vb, t_lu(Bound,U)),
reconsider( X)
;
put_atts( X, [type(t_Lu(Bound,U)),strictness(Strict)]),
arith_eval( Bound-L, Delta),
backsubst_delta( X, Delta)
)
)))).
uils( t_none, X, _Lin, Bound, _Sold) :-
put_atts( X, [type(t_l(Bound)),strictness(2'10)]).
uils( t_l(L), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'10,
put_atts( X, [type(t_l(Bound)),strictness(Strict)])
)).
uils( t_u(U), X, _Lin, Bound, Sold) :-
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)]).
uils( t_U(U), X, _Lin, Bound, Sold) :-
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lU(Bound,U)),strictness(Strict)]).
uils( t_lu(L,U), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lu(Bound,U)),strictness(Strict)])
)).
uils( t_lU(L,U), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
put_atts( X, [type(t_lU(Bound,U)),strictness(Strict)])
)).
%
% update active bound:
%
uils( t_L(L), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
Strict is Sold \/ 2'10,
( ub( X, Vub-Vb-Ub),
arith_eval( Bound >= Ub+L) ->
put_atts( X, [type(t_L(Bound)),strictness(Strict)]),
pivot_a( Vub, X, Vb, t_l(Bound)),
reconsider( X)
; %
% max(X) >= Ub, no implied value missed
%
put_atts( X, [type(t_L(Bound)),strictness(Strict)]),
arith_eval( Bound-L, Delta),
backsubst_delta( X, Delta)
))).
uils( t_Lu(L,U), X, _Lin, Bound, Sold) :-
case_signum( Bound-L,
true,
(
Strict is Sold \/ 2'10,
put_atts( X, strictness(Strict))
),
(
arith_eval( U>Bound),
Strict is Sold \/ 2'10,
( ub( X, Vub-Vb-Ub),
arith_eval( Bound >= Ub+L) ->
put_atts( X, [type(t_Lu(Bound,U)),strictness(Strict)]),
pivot_a( Vub, X, Vb, t_lu(Bound,U)),
reconsider( X)
;
put_atts( X, [type(t_Lu(Bound,U)),strictness(Strict)]),
arith_eval( Bound-L, Delta),
backsubst_delta( X, Delta)
))).
reconsider_upper( X, Lin, U) :-
decompose( Lin, H, R, I),
arith_eval( R+I >= U),
!,
dec_step( H, Status),
rcbl_status( Status, X, [], Binds,[], u(U)),
export_binding( Binds).
reconsider_upper( _, _, _).
reconsider_lower( X, Lin, L) :-
decompose( Lin, H, R, I),
arith_eval( R+I =< L),
!,
inc_step( H, Status),
rcbl_status( Status, X, [], Binds,[], l(L)),
export_binding( Binds).
reconsider_lower( _, _, _).
%
% lin is dereferenced
%
solve_bound( Lin, Bound) :-
arith_eval( Bound =:= 0),
!,
solve( Lin).
solve_bound( Lin, Bound) :-
arith_eval( -Bound, Nb),
normalize_scalar( Nb, Nbs),
add_linear_11( Nbs, Lin, Eq),
solve( Eq).

273
CLPQR/clpq/itf3.pl
View File

@ -1,273 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: itf3.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface to attribute encoding and hooks
%
:- use_module( library(atts)).
:- attribute class/1, order/1, lin/1, forward/1,
type/1, strictness/1, nonzero/0,
target/0, keep_indep/0, keep/0. % project.pl
/* Moved here from store.pl to break cyclic dependencies. --Mats C. */
%
% critical impact on the backsubstitution effort
% AND precision in clp(r)
%
% nf_ordering( A, B, Rel) :-
% get_atts( A, order( Oa)),
% get_atts( B, order( Ob)),
% compare( Rel, Oa, Ob).
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion( nf_ordering(A,B,Rel), Module, Exp) :-
clpqr( Module),
Exp = (
get_atts( A, order(Oa)),
get_atts( B, order(Ob)),
compare( Rel, Oa, Ob)
).
user:goal_expansion( decompose(Lin,H,R,I), Module, Lin=[I,R|H]) :-
clpqr( Module).
clpqr( clpq).
clpqr( clpr).
/* End of code from store.pl */
%
% Parametrize the answer presentation mechanism
% (toplevel,compiler/debugger ...)
%
:- dynamic presentation_context/1.
presentation_context( Old, New) :-
clause( presentation_context(Current), _),
!,
Current = Old,
retractall( presentation_context(_)),
assert( presentation_context( New)).
presentation_context( toplevel, New) :- % default
assert( presentation_context( New)).
%
% attribute_goal( V, V:Atts) :- get_atts( V, Atts).
%
attribute_goal( V, Goal) :-
presentation_context( Cont, Cont),
dump_linear( V, Cont, Goals, Gtail),
dump_nonzero( V, Cont, Gtail, []),
l2wrapped( Goals, Goal).
l2wrapped( [], true).
l2wrapped( [X|Xs], Conj) :-
( Xs = [], wrap( X, Conj)
; Xs = [_|_], wrap( X, Xw),
Conj = (Xw,Xc),
l2wrapped( Xs, Xc)
).
%
% Tests should be pulled out of the loop ...
%
wrap( C, W) :-
prolog_flag(typein_module, Module),
this_linear_solver( Solver),
( Module == Solver ->
W = {C}
; predicate_property( Module:{_}, imported_from(Solver)) ->
W = {C}
;
W = Solver:{C}
).
dump_linear( V, Context) -->
{
get_atts( V, [lin(Lin),type(Type)]),
!,
decompose( Lin, H, _, I)
},
%
% This happens if not all target variables can be made independend
% Example: examples/option.pl:
% | ?- go2(S,W).
%
% W = 21/4,
% S>=0,
% S<50 ? ;
%
% W>5,
% S=221/4-W, this line would be missing !!!
% W=<21/4
%
( { Type=t_none ; get_atts( V, -target) } -> [] ; dump_v( Context, t_none, V, I, H) ),
%
( {Type=t_none, get_atts( V, -target) } -> % nonzero produces such
[]
;
dump_v( Context, Type, V, I, H)
).
dump_linear( _, _) --> [].
dump_v( toplevel, Type, V, I, H) --> dump_var( Type, V, I, H).
dump_v( compiler, Type, V, I, H) --> compiler_dump_var( Type, V, I, H).
dump_nonzero( V, Cont) -->
{
get_atts( V, [nonzero,lin(Lin)]),
!,
decompose( Lin, H, _, I)
},
dump_nz( Cont, V, H, I).
dump_nonzero( _, _) --> [].
dump_nz( toplevel, V, H, I) --> dump_nz( V, H, I).
dump_nz( compiler, V, H, I) --> compiler_dump_nz( V, H, I).
numbers_only( Y, _) :- var(Y), !.
numbers_only( Y, _) :- arith_normalize( Y, Y), !.
numbers_only( Y, X) :-
this_linear_solver( Solver),
( Solver==clpr ->
What = 'a real number'
; Solver==clpq ->
What = 'a rational number'
),
raise_exception( type_error(X=Y,2,What,Y)).
verify_attributes( X, _, []) :-
get_atts(X, [-class(_),-order(_),-lin(_),-forward(_),-type(_),-strictness(_),
-nonzero]),
!.
verify_attributes( X, Y, []) :-
get_atts( X, forward(F)),
!,
fwd_deref( F, Y).
verify_attributes( X, Y, Later) :-
numbers_only( Y, X),
put_atts( X, forward(Y)),
verify_nonzero( X, Y),
verify_type( X, Y, Later, []),
verify_lin( X, Y).
fwd_deref( X, Y) :- nonvar(X), X=Y.
fwd_deref( X, Y) :- var(X),
( get_atts( X, forward(F)) ->
fwd_deref( F, Y)
;
X = Y
).
verify_nonzero( X, Y) :-
get_atts( X, nonzero),
!,
( var(Y) ->
put_atts( Y, nonzero)
;
arith_eval( Y =\= 0)
).
verify_nonzero( _, _).
verify_type( X, Y) -->
{
get_atts( X, [type(Type),strictness(Strict)])
},
!,
verify_type( Y, Type, Strict).
verify_type( _, _) --> [].
verify_type( Y, TypeX, StrictX) --> {var(Y)}, !,
verify_type_var( TypeX, Y, StrictX).
verify_type( Y, TypeX, StrictX) -->
{
verify_type_nonvar( TypeX, Y, StrictX)
}.
verify_type_nonvar( t_none, _, _).
verify_type_nonvar( t_l(L), Value, S) :- lb( S, L, Value).
verify_type_nonvar( t_u(U), Value, S) :- ub( S, U, Value).
verify_type_nonvar( t_lu(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
verify_type_nonvar( t_L(L), Value, S) :- lb( S, L, Value).
verify_type_nonvar( t_U(U), Value, S) :- ub( S, U, Value).
verify_type_nonvar( t_Lu(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
verify_type_nonvar( t_lU(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
lb( S, L, V) :- S /\ 2'10 =:= 0, !, arith_eval( L =< V).
lb( _, L, V) :- arith_eval( L < V).
ub( S, U, V) :- S /\ 2'01 =:= 0, !, arith_eval( V =< U).
ub( _, U, V) :- arith_eval( V < U).
%
% Running some goals after X=Y simplifies the coding. It should be possible
% to run the goals here and taking care not to put_atts/2 on X ...
%
verify_type_var( t_none, _, _) --> [].
verify_type_var( t_l(L), Y, S) --> llb( S, L, Y).
verify_type_var( t_u(U), Y, S) --> lub( S, U, Y).
verify_type_var( t_lu(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
verify_type_var( t_L(L), Y, S) --> llb( S, L, Y).
verify_type_var( t_U(U), Y, S) --> lub( S, U, Y).
verify_type_var( t_Lu(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
verify_type_var( t_lU(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
llb( S, L, V) --> {S /\ 2'10 =:= 0}, !, [ {L =< V} ].
llb( _, L, V) --> [ {L < V} ].
lub( S, U, V) --> {S /\ 2'01 =:= 0}, !, [ {V =< U} ].
lub( _, U, V) --> [ {V < U} ].
%
% We used to drop X from the class/basis to avoid trouble with subsequent
% put_atts/2 on X. Now we could let these dead but harmless updates happen.
% In R however, exported bindings might conflict, e.g. 0 \== 0.0
%
% If X is indep and we do _not_ solve for it, we are in deep shit
% because the ordering is violated.
%
verify_lin( X, Y) :-
get_atts( X, [class(Class),lin(LinX)]),
!,
( indep( LinX, X) ->
detach_bounds( X), % if there were bounds, they are requeued already
class_drop( Class, X),
nf( X-Y, Lin),
deref( Lin, Lind),
( nf_coeff_of( Lind, X, _) ->
solve_x( Lind, X)
;
solve( Lind)
)
;
class_drop( Class, X),
nf( X-Y, Lin),
deref( Lin, Lind),
solve( Lind)
).
verify_lin( _, _).

834
CLPQR/clpq/nf.pl
View File

@ -1,834 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: nf.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module( library(terms), [term_variables/2]).
:- use_module( geler).
% -------------------------------------------------------------------------
{ Rel } :- var( Rel), !, raise_exception(instantiation_error({Rel},1)).
{ R,Rs } :- !, {R}, {Rs}.
{ R;Rs } :- !, ({R} ; {Rs}). % for entailment checking
{ L < R } :- !, nf( L-R, Nf), submit_lt( Nf).
{ L > R } :- !, nf( R-L, Nf), submit_lt( Nf).
{ L =< R } :- !, nf( L-R, Nf), submit_le( Nf).
{ <=(L,R) } :- !, nf( L-R, Nf), submit_le( Nf).
{ L >= R } :- !, nf( R-L, Nf), submit_le( Nf).
{ L =\= R } :- !, nf( L-R, Nf), submit_ne( Nf).
{ L =:= R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ L = R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ Rel } :- raise_exception( type_error({Rel},1,'a constraint',Rel)).
%
% s -> c = ~s v c = ~(s /\ ~c)
% where s is the store and c is the constraint for which
% we want to know whether it is entailed.
%
entailed( C) :-
negate( C, Cn),
\+ { Cn }.
negate( Rel, _) :- var( Rel), !, raise_exception(instantiation_error(entailed(Rel),1)).
negate( (A,B), (Na;Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( (A;B), (Na,Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( A<B, A>=B) :- !.
negate( A>B, A=<B) :- !.
negate( A=<B, A>B) :- !.
negate( A>=B, A<B) :- !.
negate( A=:=B, A=\=B) :- !.
negate( A=B, A=\=B) :- !.
negate( A=\=B, A=:=B) :- !.
negate( Rel, _) :- raise_exception( type_error(entailed(Rel),1,'a constraint',Rel)).
/*
Cases: a) Nf=[]
b) Nf=[A]
b1) A=k
b2) invertible(A)
b3) linear -> A=0
b4) nonlinear -> geler
c) Nf=[A,B|Rest]
c1) A=k
c11) B=X^+-1, Rest=[] -> B=
c12) invertible(A,B)
c13) linear(B|Rest)
c14) geler
c2) linear(Nf)
c3) nonlinear -> geler
*/
submit_eq( []). % trivial success
submit_eq( [T|Ts]) :-
submit_eq( Ts, T).
submit_eq( [], A) :- submit_eq_b( A).
submit_eq( [B|Bs], A) :- submit_eq_c( A, B, Bs).
submit_eq_b( v(_,[])) :- !, fail. % b1: trivial failure
submit_eq_b( v(_,[X^P])) :- % b2,b3: n*x^p=0 -> x=0
var( X),
P > 0,
!,
arith_eval( 0, Z),
export_binding( X, Z).
submit_eq_b( v(_,[NL^1])) :- % b2
nonvar( NL),
arith_eval( 0, Z),
nl_invertible( NL, X, Z, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_b( Term) :- % b4
term_variables( Term, Vs),
geler( Vs, resubmit_eq([Term])).
submit_eq_c( v(I,[]), B, Rest) :- !,
submit_eq_c1( Rest, B, I).
submit_eq_c( A, B, Rest) :- % c2
A=v(_,[X^1]), var(X),
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
Hom = [A,B|Rest],
% 'solve_='( Hom).
nf_length( Hom, 0, Len),
log_deref( Len, Hom, [], HomD),
solve( HomD).
submit_eq_c( A, B, Rest) :- % c3
Norm = [A,B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
submit_eq_c1( [], v(K,[X^P]), I) :- % c11
var( X),
( P = 1, !, arith_eval( -I/K, Val), export_binding( X, Val)
; P = -1, !, arith_eval( -K/I, Val), export_binding( X, Val)
).
submit_eq_c1( [], v(K,[NL^P]), I) :- % c12
nonvar( NL),
( P = 1, arith_eval( -I/K, Y)
; P = -1, arith_eval( -K/I, Y)
),
nl_invertible( NL, X, Y, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_c1( Rest, B, I) :- % c13
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
% 'solve_='( [v(I,[]),B|Rest]).
Hom = [B|Rest],
nf_length( Hom, 0, Len),
normalize_scalar( I, Nonvar),
log_deref( Len, Hom, [], HomD),
add_linear_11( Nonvar, HomD, LinD),
solve( LinD).
submit_eq_c1( Rest, B, I) :- % c14
Norm = [v(I,[]),B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
% -----------------------------------------------------------------------
submit_lt( []) :- fail. % trivial failure
submit_lt( [A|As]) :-
submit_lt( As, A).
submit_lt( [], v(K,P)) :- submit_lt_b( P, K).
submit_lt( [B|Bs], A) :- submit_lt_c( Bs, A, B).
submit_lt_b( [], I) :- !, arith_eval( I<0).
submit_lt_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_s_p_0( X)
;
ineq_one_s_n_0( X)
).
submit_lt_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_lt([v(K,P)])).
submit_lt_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( strict, Y, K, I).
submit_lt_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_lt(Norm))
).
submit_le( []). % trivial success
submit_le( [A|As]) :-
submit_le( As, A).
submit_le( [], v(K,P)) :- submit_le_b( P, K).
submit_le( [B|Bs], A) :- submit_le_c( Bs, A, B).
submit_le_b( [], I) :- !, arith_eval( I=<0).
submit_le_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_n_p_0( X)
;
ineq_one_n_n_0( X)
).
submit_le_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_le([v(K,P)])).
submit_le_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( nonstrict, Y, K, I).
submit_le_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_=<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_le(Norm))
).
submit_ne( Norm1) :-
( nf_constant( Norm1, K) ->
arith_eval( K=\=0)
; linear( Norm1) ->
'solve_=\\='( Norm1)
;
term_variables( Norm1, Vs),
geler( Vs, resubmit_ne(Norm1))
).
linear( []).
linear( v(_,Ps)) :- linear_ps( Ps).
linear( [A|As]) :-
linear( A),
linear( As).
linear_ps( []).
linear_ps( [V^1]) :- var( V). % excludes sin(_), ...
%
% Goal delays until Term gets linear.
% At this time, Var will be bound to the normalform of Term.
%
:- meta_predicate wait_linear( ?, ?, :).
%
wait_linear( Term, Var, Goal) :-
nf( Term, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
%
% geler clients
%
resubmit_eq( N) :-
repair( N, Norm),
submit_eq( Norm).
resubmit_lt( N) :-
repair( N, Norm),
submit_lt( Norm).
resubmit_le( N) :-
repair( N, Norm),
submit_le( Norm).
resubmit_ne( N) :-
repair( N, Norm),
submit_ne( Norm).
wait_linear_retry( Nf0, Var, Goal) :-
repair( Nf0, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
% -----------------------------------------------------------------------
/*
invertible( [v(Mone,[]),v(One,[X^Px,Y^Py])], Norm) :-
Px+Py =:= 0,
abs(Px) mod 2 =:= 1, % odd powers only ...
arith_eval( 1, One),
arith_eval( -1, Mone),
!,
( Px < 0 ->
{X=\=0}
;
{Y=\=0}
),
nf( X-Y, Norm). % x=y
*/
nl_invertible( sin(X), X, Y, Res) :- arith_eval( asin(Y), Res).
nl_invertible( cos(X), X, Y, Res) :- arith_eval( acos(Y), Res).
nl_invertible( tan(X), X, Y, Res) :- arith_eval( atan(Y), Res).
nl_invertible( exp(B,C), X, A, Res) :-
( nf_constant( B, Kb) ->
arith_eval(A>0),
arith_eval(Kb>0),
arith_eval(Kb=\=1),
X = C,
arith_eval( log(A)/log(Kb), Res)
; nf_constant( C, Kc),
\+ (arith_eval(A=:=0),arith_eval(Kc=<0)),
X = B,
arith_eval( exp(A,1/Kc), Res)
).
% -----------------------------------------------------------------------
nf( X, Norm) :- var(X), !,
Norm = [v(One,[X^1])],
arith_eval( 1, One).
nf( X, Norm) :- number(X), !,
nf_number( X, Norm).
%
nf( rat(N,D), Norm) :- !,
nf_number( rat(N,D), Norm).
%
nf( #(Const), Norm) :-
monash_constant( Const, Value),
!,
( arith_eval( 1, rat(1,1)) ->
nf_number( Value, Norm) % swallows #(zero) ... ok in Q
;
arith_normalize( Value, N), % in R we want it
Norm = [v(N,[])]
).
%
nf( -A, Norm) :- !,
nf( A, An),
arith_eval( -1, K),
nf_mul_factor( v(K,[]), An, Norm).
nf( +A, Norm) :- !,
nf( A, Norm).
%
nf( A+B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_add( An, Bn, Norm).
nf( A-B, Norm) :- !,
nf( A, An),
nf( -B, Bn),
nf_add( An, Bn, Norm).
%
nf( A*B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_mul( An, Bn, Norm).
nf( A/B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_div( Bn, An, Norm).
%
nf( Term, Norm) :-
nonlin_1( Term, Arg, Skel, Sa1),
!,
nf( Arg, An),
nf_nonlin_1( Skel, An, Sa1, Norm).
nf( Term, Norm) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
!,
nf( A1, A1n),
nf( A2, A2n),
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, Norm).
%
nf( Term, _) :-
raise_exception( type_error(nf(Term,_),1,'a numeric expression',Term)).
nf_number( N, Res) :-
nf_number( N),
arith_normalize( N, Normal),
( arith_eval( Normal=:=0) ->
Res = []
;
Res = [v(Normal,[])]
).
nf_number( N) :- number( N),
!. /* MC 980507 */
nf_number( N) :- compound( N), N=rat(_,_). % sicstus
nonlin_1( abs(X), X, abs(Y), Y).
nonlin_1( sin(X), X, sin(Y), Y).
nonlin_1( cos(X), X, cos(Y), Y).
nonlin_1( tan(X), X, tan(Y), Y).
nonlin_2( min(A,B), A,B, min(X,Y), X, Y).
nonlin_2( max(A,B), A,B, max(X,Y), X, Y).
nonlin_2( exp(A,B), A,B, exp(X,Y), X, Y).
nonlin_2( pow(A,B), A,B, exp(X,Y), X, Y). % pow->exp
nonlin_2( A^B, A,B, exp(X,Y), X, Y).
nf_nonlin_1( Skel, An, S1, Norm) :-
( nf_constant( An, S1) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
;
S1 = An,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nf_nonlin_2( Skel, A1n, A2n, S1, S2, Norm) :-
( nf_constant( A1n, S1),
nf_constant( A2n, S2) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
; Skel=exp(_,_),
nf_constant( A2n, Exp),
integerp( Exp, I) ->
nf_power( I, A1n, Norm)
;
S1 = A1n,
S2 = A2n,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nl_eval( abs(X), R) :- arith_eval( abs(X), R).
nl_eval( sin(X), R) :- arith_eval( sin(X), R).
nl_eval( cos(X), R) :- arith_eval( cos(X), R).
nl_eval( tan(X), R) :- arith_eval( tan(X), R).
%
nl_eval( min(X,Y), R) :- arith_eval( min(X,Y), R).
nl_eval( max(X,Y), R) :- arith_eval( max(X,Y), R).
nl_eval( exp(X,Y), R) :- arith_eval( exp(X,Y), R).
monash_constant( X, _) :- var(X), !, fail.
monash_constant( p, 3.14259265).
monash_constant( pi, 3.14259265).
monash_constant( e, 2.71828182).
monash_constant( zero, Eps) :- arith_eps( Eps).
%
% check if a Nf consists of just a constant
%
nf_constant( [], Z) :- arith_eval( 0, Z).
nf_constant( [v(K,[])], K).
%
% this depends on the polynf ordering, i.e. [] < [X^1] ...
%
split( [], [], Z) :- arith_eval( 0, Z).
split( [First|T], H, I) :-
( First=v(I,[]) ->
H=T
;
arith_eval( 0, I),
H = [First|T]
).
%
% runtime predicate
%
:- mode nf_add( +, +, ?).
%
nf_add( [], Bs, Bs).
nf_add( [A|As], Bs, Cs) :-
nf_add( Bs, A, As, Cs).
:- mode nf_add( +, +, +, ?).
%
nf_add( [], A, As, Cs) :- Cs = [A|As].
nf_add( [B|Bs], A, As, Cs) :-
A = v(Ka,Pa),
B = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_case( Rel, A, As, Cs, B, Bs, Ka, Kb, Pa).
:- mode nf_add_case( +, +, +, -, +, +, +, +, +).
%
nf_add_case( <, A, As, Cs, B, Bs, _, _, _) :-
Cs=[A|Rest],
nf_add( As, B, Bs, Rest).
nf_add_case( >, A, As, Cs, B, Bs, _, _, _) :-
Cs=[B|Rest],
nf_add( Bs, A, As, Rest).
nf_add_case( =, _, As, Cs, _, Bs, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
nf_add( As, Bs, Cs)
;
Cs=[v(Kc,Pa)|Rest],
nf_add( As, Bs, Rest)
).
:- mode nf_mul( +, +, -).
%
nf_mul( A, B, Res) :-
nf_length( A, 0, LenA),
nf_length( B, 0, LenB),
nf_mul_log( LenA, A, [], LenB, B, Res).
nf_mul_log( 0, As, As, _, _, []) :- !.
nf_mul_log( 1, [A|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A, R).
nf_mul_log( 2, [A1,A2|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A1, A1b),
nf_mul_factor_log( Lb, B, [], A2, A2b),
nf_add( A1b, A2b, R).
nf_mul_log( N, A0, A2, Lb, B, R) :-
P is N>>1,
Q is N-P,
nf_mul_log( P, A0, A1, Lb, B, Rp),
nf_mul_log( Q, A1, A2, Lb, B, Rq),
nf_add( Rp, Rq, R).
:- mode nf_add_2( +, +, -).
%
nf_add_2( Af, Bf, Res) :- % unfold: nf_add( [Af], [Bf], Res).
Af = v(Ka,Pa),
Bf = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_2_case( Rel, Af, Bf, Res, Ka, Kb, Pa).
:- mode nf_add_2_case( +, +, +, -, +, +, +).
%
nf_add_2_case( <, Af, Bf, [Af,Bf], _, _, _).
nf_add_2_case( >, Af, Bf, [Bf,Af], _, _, _).
nf_add_2_case( =, _, _, Res, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
Res = []
;
Res=[v(Kc,Pa)]
).
%
% multiply with a scalar =\= 0
%
nf_mul_k( [], _, []).
nf_mul_k( [v(I,P)|Vs], K, [v(Ki,P)|Vks]) :-
arith_eval( K*I, Ki),
nf_mul_k( Vs, K, Vks).
nf_mul_factor( v(K,[]), Sum, Res) :- !, nf_mul_k( Sum, K, Res).
nf_mul_factor( F, Sum, Res) :-
nf_length( Sum, 0, Len),
nf_mul_factor_log( Len, Sum, [], F, Res).
nf_mul_factor_log( 0, As, As, _, []) :- !.
nf_mul_factor_log( 1, [A|As], As, F, [R]) :- !,
mult( A, F, R).
nf_mul_factor_log( 2, [A,B|As], As, F, Res) :- !,
mult( A, F, Af),
mult( B, F, Bf),
nf_add_2( Af, Bf, Res).
nf_mul_factor_log( N, A0, A2, F, R) :-
P is N>>1,
Q is N-P,
nf_mul_factor_log( P, A0, A1, F, Rp),
nf_mul_factor_log( Q, A1, A2, F, Rq),
nf_add( Rp, Rq, R).
mult( v(Ka,La), v(Kb,Lb), v(Kc,Lc)) :-
arith_eval( Ka*Kb, Kc),
pmerge( La, Lb, Lc).
pmerge( [], Bs, Bs).
pmerge( [A|As], Bs, Cs) :-
pmerge( Bs, A, As, Cs).
:- mode pmerge(+,+,+,-).
%
pmerge( [], A, As, Res) :- Res = [A|As].
pmerge( [B|Bs], A, As, Res) :-
A=Xa^Ka,
B=Xb^Kb,
compare( R, Xa, Xb),
pmerge_case( R, A, As, Res, B, Bs, Ka, Kb, Xa).
:- mode pmerge_case( +, +, +, -, +, +, +, +, ?).
%
pmerge_case( <, A, As, Res, B, Bs, _, _, _) :-
Res = [A|Tail],
pmerge( As, B, Bs, Tail).
pmerge_case( >, A, As, Res, B, Bs, _, _, _) :-
Res = [B|Tail],
pmerge( Bs, A, As, Tail).
pmerge_case( =, _, As, Res, _, Bs, Ka, Kb, Xa) :-
Kc is Ka+Kb,
( Kc=:=0 ->
pmerge( As, Bs, Res)
;
Res = [Xa^Kc|Tail],
pmerge( As, Bs, Tail)
).
nf_div( [], _, _) :- !, zero_division.
nf_div( [v(K,P)], Sum, Res) :- !,
arith_eval( 1/K, Ki),
mult_exp( P, -1, Pi),
nf_mul_factor( v(Ki,Pi), Sum, Res).
nf_div( D, A, [v(One,[(A/D)^1])]) :-
arith_eval( 1, One).
zero_division :- fail. % raise_exception(_) ?
mult_exp( [], _, []).
mult_exp( [X^P|Xs], K, [X^I|Tail]) :-
I is K*P,
mult_exp( Xs, K, Tail).
%
% raise to integer powers
%
% | ?- time({(1+X+Y+Z)^15=0}).
% Timing 00:00:02.610 2.610 iterative
% Timing 00:00:00.660 0.660 binomial
nf_power( N, Sum, Norm) :-
integer( N),
compare( Rel, N, 0),
( Rel = < ->
Pn is -N,
% nf_power_pos( Pn, Sum, Inorm),
binom( Sum, Pn, Inorm),
arith_eval( 1, One),
nf_div( Inorm, [v(One,[])], Norm)
; Rel = > ->
% nf_power_pos( N, Sum, Norm)
binom( Sum, N, Norm)
; Rel = = -> % 0^0 is indeterminate but we say 1
arith_eval( 1, One),
Norm = [v(One,[])]
).
%
% N>0
%
nf_power_pos( 1, Sum, Norm) :- !, Sum = Norm.
nf_power_pos( N, Sum, Norm) :-
N1 is N-1,
nf_power_pos( N1, Sum, Pn1),
nf_mul( Sum, Pn1, Norm).
%
% N>0
%
binom( Sum, 1, Power) :- !, Power = Sum.
binom( [], _, []).
binom( [A|Bs], N, Power) :-
( Bs=[] ->
nf_power_factor( A, N, Ap),
Power = [Ap]
; Bs=[_|_] ->
arith_eval( 1, One),
factor_powers( N, A, v(One,[]), Pas),
sum_powers( N, Bs, [v(One,[])], Pbs, []),
combine_powers( Pas, Pbs, 0, N, 1, [], Power)
).
combine_powers( [], [], _, _, _, Pi, Pi).
combine_powers( [A|As], [B|Bs], L, R, C, Pi, Po) :-
nf_mul( A, B, Ab),
arith_normalize( C, Cn),
nf_mul_k( Ab, Cn, Abc),
nf_add( Abc, Pi, Pii),
L1 is L+1,
R1 is R-1,
C1 is C*R//L1,
combine_powers( As, Bs, L1, R1, C1, Pii, Po).
nf_power_factor( v(K,P), N, v(Kn,Pn)) :-
arith_normalize( N, Nn),
arith_eval( exp(K,Nn), Kn),
mult_exp( P, N, Pn).
factor_powers( 0, _, Prev, [[Prev]]) :- !.
factor_powers( N, F, Prev, [[Prev]|Ps]) :-
N1 is N-1,
mult( Prev, F, Next),
factor_powers( N1, F, Next, Ps).
sum_powers( 0, _, Prev, [Prev|Lt], Lt) :- !.
sum_powers( N, S, Prev, L0, Lt) :-
N1 is N-1,
nf_mul( S, Prev, Next),
sum_powers( N1, S, Next, L0, [Prev|Lt]).
% ------------------------------------------------------------------------------
repair( Sum, Norm) :-
nf_length( Sum, 0, Len),
repair_log( Len, Sum, [], Norm).
repair_log( 0, As, As, []) :- !.
repair_log( 1, [v(Ka,Pa)|As], As, R) :- !,
repair_term( Ka, Pa, R).
repair_log( 2, [v(Ka,Pa),v(Kb,Pb)|As], As, R) :- !,
repair_term( Ka, Pa, Ar),
repair_term( Kb, Pb, Br),
nf_add( Ar, Br, R).
repair_log( N, A0, A2, R) :-
P is N>>1,
Q is N-P,
repair_log( P, A0, A1, Rp),
repair_log( Q, A1, A2, Rq),
nf_add( Rp, Rq, R).
repair_term( K, P, Norm) :-
length( P, Len),
arith_eval( 1, One),
repair_p_log( Len, P, [], Pr, [v(One,[])], Sum),
nf_mul_factor( v(K,Pr), Sum, Norm).
repair_p_log( 0, Ps, Ps, [], L0, L0) :- !.
repair_p_log( 1, [X^P|Ps], Ps, R, L0, L1) :- !,
repair_p( X, P, R, L0, L1).
repair_p_log( 2, [X^Px,Y^Py|Ps], Ps, R, L0,L2) :- !,
repair_p( X, Px, Rx, L0, L1),
repair_p( Y, Py, Ry, L1, L2),
pmerge( Rx, Ry, R).
repair_p_log( N, P0, P2, R, L0, L2) :-
P is N>>1,
Q is N-P,
repair_p_log( P, P0, P1, Rp, L0, L1),
repair_p_log( Q, P1, P2, Rq, L1, L2),
pmerge( Rp, Rq, R).
repair_p( Term, P, [Term^P], L0, L0) :- var( Term).
repair_p( Term, P, [], L0, L1) :- nonvar( Term),
repair_p_one( Term, TermN),
nf_power( P, TermN, TermNP),
nf_mul( TermNP, L0, L1).
%
% An undigested term a/b is distinguished from an
% digested one by the fact that its arguments are
% digested -> cuts after repair of args!
%
repair_p_one( Term, TermN) :-
nf_number( Term, TermN), % freq. shortcut for nf/2 case below
!.
repair_p_one( A1/A2, TermN) :-
repair( A1, A1n),
repair( A2, A2n),
!,
nf_div( A2n, A1n, TermN).
repair_p_one( Term, TermN) :-
nonlin_1( Term, Arg, Skel, Sa),
repair( Arg, An),
!,
nf_nonlin_1( Skel, An, Sa, TermN).
repair_p_one( Term, TermN) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
repair( A1, A1n),
repair( A2, A2n),
!,
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, TermN).
repair_p_one( Term, TermN) :-
nf( Term, TermN).
:- mode nf_length( +, +, -).
%
nf_length( [], Li, Li).
nf_length( [_|R], Li, Lo) :-
Lii is Li+1,
nf_length( R, Lii, Lo).
% ------------------------------------------------------------------------------
nf2term( [], Z) :- arith_eval( 0, Z).
nf2term( [F|Fs], T) :-
f02t( F, T0),
yfx( Fs, T0, T).
yfx( [], T0, T0).
yfx( [F|Fs], T0, TN) :-
fn2t( F, Ft, Op),
T1 =.. [Op,T0,Ft],
yfx( Fs, T1, TN).
f02t( v(K,P), T) :-
( P = [] ->
T = K
; arith_eval( K=:=1) ->
p2term( P, T)
; arith_eval( K=:= -1) ->
T = -Pt,
p2term( P, Pt)
;
T = K*Pt,
p2term( P, Pt)
).
fn2t( v(K,P), Term, Op) :-
( arith_eval( K=:=1) ->
Term = Pt, Op = +
; arith_eval( K=:= -1) ->
Term = Pt, Op = -
; arith_eval( K<0) ->
arith_eval( -K, Kf),
Term = Kf*Pt, Op = -
;
Term = K*Pt, Op = +
),
p2term( P, Pt).
p2term( [X^P|Xs], Term) :-
( Xs=[] ->
pe2term( X, Xt),
exp2term( P, Xt, Term)
; Xs=[_|_] ->
Term = Xst*Xtp,
pe2term( X, Xt),
exp2term( P, Xt, Xtp),
p2term( Xs, Xst)
).
exp2term( 1, X, X) :- !.
exp2term(-1, X, One/X) :- !, arith_eval( 1, One).
exp2term( P, X, Term) :-
arith_normalize( P, Pn),
% Term = exp(X,Pn).
Term = X^Pn.
pe2term( X, Term) :- var(X), Term = X.
pe2term( X, Term) :- nonvar(X),
X =.. [F|Args],
pe2term_args( Args, Argst),
Term =.. [F|Argst].
pe2term_args( [], []).
pe2term_args( [A|As], [T|Ts]) :-
nf2term( A, T),
pe2term_args( As, Ts).

834
CLPQR/clpq/nf.yap
View File

@ -1,834 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: nf.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module( library(terms), [term_variables/2]).
:- use_module( geler).
% -------------------------------------------------------------------------
{ Rel } :- var( Rel), !, raise_exception(instantiation_error({Rel},1)).
{ R,Rs } :- !, {R}, {Rs}.
{ R;Rs } :- !, ({R} ; {Rs}). % for entailment checking
{ L < R } :- !, nf( L-R, Nf), submit_lt( Nf).
{ L > R } :- !, nf( R-L, Nf), submit_lt( Nf).
{ L =< R } :- !, nf( L-R, Nf), submit_le( Nf).
{ <=(L,R) } :- !, nf( L-R, Nf), submit_le( Nf).
{ L >= R } :- !, nf( R-L, Nf), submit_le( Nf).
{ L =\= R } :- !, nf( L-R, Nf), submit_ne( Nf).
{ L =:= R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ L = R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ Rel } :- raise_exception( type_error({Rel},1,'a constraint',Rel)).
%
% s -> c = ~s v c = ~(s /\ ~c)
% where s is the store and c is the constraint for which
% we want to know whether it is entailed.
%
entailed( C) :-
negate( C, Cn),
\+ { Cn }.
negate( Rel, _) :- var( Rel), !, raise_exception(instantiation_error(entailed(Rel),1)).
negate( (A,B), (Na;Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( (A;B), (Na,Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( A<B, A>=B) :- !.
negate( A>B, A=<B) :- !.
negate( A=<B, A>B) :- !.
negate( A>=B, A<B) :- !.
negate( A=:=B, A=\=B) :- !.
negate( A=B, A=\=B) :- !.
negate( A=\=B, A=:=B) :- !.
negate( Rel, _) :- raise_exception( type_error(entailed(Rel),1,'a constraint',Rel)).
/*
Cases: a) Nf=[]
b) Nf=[A]
b1) A=k
b2) invertible(A)
b3) linear -> A=0
b4) nonlinear -> geler
c) Nf=[A,B|Rest]
c1) A=k
c11) B=X^+-1, Rest=[] -> B=
c12) invertible(A,B)
c13) linear(B|Rest)
c14) geler
c2) linear(Nf)
c3) nonlinear -> geler
*/
submit_eq( []). % trivial success
submit_eq( [T|Ts]) :-
submit_eq( Ts, T).
submit_eq( [], A) :- submit_eq_b( A).
submit_eq( [B|Bs], A) :- submit_eq_c( A, B, Bs).
submit_eq_b( v(_,[])) :- !, fail. % b1: trivial failure
submit_eq_b( v(_,[X^P])) :- % b2,b3: n*x^p=0 -> x=0
var( X),
P > 0,
!,
arith_eval( 0, Z),
export_binding( X, Z).
submit_eq_b( v(_,[NL^1])) :- % b2
nonvar( NL),
arith_eval( 0, Z),
nl_invertible( NL, X, Z, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_b( Term) :- % b4
term_variables( Term, Vs),
geler( Vs, resubmit_eq([Term])).
submit_eq_c( v(I,[]), B, Rest) :- !,
submit_eq_c1( Rest, B, I).
submit_eq_c( A, B, Rest) :- % c2
A=v(_,[X^1]), var(X),
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
Hom = [A,B|Rest],
% 'solve_='( Hom).
nf_length( Hom, 0, Len),
log_deref( Len, Hom, [], HomD),
solve( HomD).
submit_eq_c( A, B, Rest) :- % c3
Norm = [A,B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
submit_eq_c1( [], v(K,[X^P]), I) :- % c11
var( X),
( P = 1, !, arith_eval( -I/K, Val), export_binding( X, Val)
; P = -1, !, arith_eval( -K/I, Val), export_binding( X, Val)
).
submit_eq_c1( [], v(K,[NL^P]), I) :- % c12
nonvar( NL),
( P = 1, arith_eval( -I/K, Y)
; P = -1, arith_eval( -K/I, Y)
),
nl_invertible( NL, X, Y, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_c1( Rest, B, I) :- % c13
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
% 'solve_='( [v(I,[]),B|Rest]).
Hom = [B|Rest],
nf_length( Hom, 0, Len),
normalize_scalar( I, Nonvar),
log_deref( Len, Hom, [], HomD),
add_linear_11( Nonvar, HomD, LinD),
solve( LinD).
submit_eq_c1( Rest, B, I) :- % c14
Norm = [v(I,[]),B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
% -----------------------------------------------------------------------
submit_lt( []) :- fail. % trivial failure
submit_lt( [A|As]) :-
submit_lt( As, A).
submit_lt( [], v(K,P)) :- submit_lt_b( P, K).
submit_lt( [B|Bs], A) :- submit_lt_c( Bs, A, B).
submit_lt_b( [], I) :- !, arith_eval( I<0).
submit_lt_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_s_p_0( X)
;
ineq_one_s_n_0( X)
).
submit_lt_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_lt([v(K,P)])).
submit_lt_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( strict, Y, K, I).
submit_lt_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_lt(Norm))
).
submit_le( []). % trivial success
submit_le( [A|As]) :-
submit_le( As, A).
submit_le( [], v(K,P)) :- submit_le_b( P, K).
submit_le( [B|Bs], A) :- submit_le_c( Bs, A, B).
submit_le_b( [], I) :- !, arith_eval( I=<0).
submit_le_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_n_p_0( X)
;
ineq_one_n_n_0( X)
).
submit_le_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_le([v(K,P)])).
submit_le_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( nonstrict, Y, K, I).
submit_le_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_=<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_le(Norm))
).
submit_ne( Norm1) :-
( nf_constant( Norm1, K) ->
arith_eval( K=\=0)
; linear( Norm1) ->
'solve_=\\='( Norm1)
;
term_variables( Norm1, Vs),
geler( Vs, resubmit_ne(Norm1))
).
linear( []).
linear( v(_,Ps)) :- linear_ps( Ps).
linear( [A|As]) :-
linear( A),
linear( As).
linear_ps( []).
linear_ps( [V^1]) :- var( V). % excludes sin(_), ...
%
% Goal delays until Term gets linear.
% At this time, Var will be bound to the normalform of Term.
%
:- meta_predicate wait_linear( ?, ?, :).
%
wait_linear( Term, Var, Goal) :-
nf( Term, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
%
% geler clients
%
resubmit_eq( N) :-
repair( N, Norm),
submit_eq( Norm).
resubmit_lt( N) :-
repair( N, Norm),
submit_lt( Norm).
resubmit_le( N) :-
repair( N, Norm),
submit_le( Norm).
resubmit_ne( N) :-
repair( N, Norm),
submit_ne( Norm).
wait_linear_retry( Nf0, Var, Goal) :-
repair( Nf0, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
% -----------------------------------------------------------------------
/*
invertible( [v(Mone,[]),v(One,[X^Px,Y^Py])], Norm) :-
Px+Py =:= 0,
abs(Px) mod 2 =:= 1, % odd powers only ...
arith_eval( 1, One),
arith_eval( -1, Mone),
!,
( Px < 0 ->
{X=\=0}
;
{Y=\=0}
),
nf( X-Y, Norm). % x=y
*/
nl_invertible( sin(X), X, Y, Res) :- arith_eval( asin(Y), Res).
nl_invertible( cos(X), X, Y, Res) :- arith_eval( acos(Y), Res).
nl_invertible( tan(X), X, Y, Res) :- arith_eval( atan(Y), Res).
nl_invertible( exp(B,C), X, A, Res) :-
( nf_constant( B, Kb) ->
arith_eval(A>0),
arith_eval(Kb>0),
arith_eval(Kb=\=1),
X = C,
arith_eval( log(A)/log(Kb), Res)
; nf_constant( C, Kc),
\+ (arith_eval(A=:=0),arith_eval(Kc=<0)),
X = B,
arith_eval( exp(A,1/Kc), Res)
).
% -----------------------------------------------------------------------
nf( X, Norm) :- var(X), !,
Norm = [v(One,[X^1])],
arith_eval( 1, One).
nf( X, Norm) :- number(X), !,
nf_number( X, Norm).
%
nf( rat(N,D), Norm) :- !,
nf_number( rat(N,D), Norm).
%
nf( #(Const), Norm) :-
monash_constant( Const, Value),
!,
( arith_eval( 1, rat(1,1)) ->
nf_number( Value, Norm) % swallows #(zero) ... ok in Q
;
arith_normalize( Value, N), % in R we want it
Norm = [v(N,[])]
).
%
nf( -A, Norm) :- !,
nf( A, An),
arith_eval( -1, K),
nf_mul_factor( v(K,[]), An, Norm).
nf( +A, Norm) :- !,
nf( A, Norm).
%
nf( A+B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_add( An, Bn, Norm).
nf( A-B, Norm) :- !,
nf( A, An),
nf( -B, Bn),
nf_add( An, Bn, Norm).
%
nf( A*B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_mul( An, Bn, Norm).
nf( A/B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_div( Bn, An, Norm).
%
nf( Term, Norm) :-
nonlin_1( Term, Arg, Skel, Sa1),
!,
nf( Arg, An),
nf_nonlin_1( Skel, An, Sa1, Norm).
nf( Term, Norm) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
!,
nf( A1, A1n),
nf( A2, A2n),
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, Norm).
%
nf( Term, _) :-
raise_exception( type_error(nf(Term,_),1,'a numeric expression',Term)).
nf_number( N, Res) :-
nf_number( N),
arith_normalize( N, Normal),
( arith_eval( Normal=:=0) ->
Res = []
;
Res = [v(Normal,[])]
).
nf_number( N) :- number( N),
!. /* MC 980507 */
nf_number( N) :- compound( N), N=rat(_,_). % sicstus
nonlin_1( abs(X), X, abs(Y), Y).
nonlin_1( sin(X), X, sin(Y), Y).
nonlin_1( cos(X), X, cos(Y), Y).
nonlin_1( tan(X), X, tan(Y), Y).
nonlin_2( min(A,B), A,B, min(X,Y), X, Y).
nonlin_2( max(A,B), A,B, max(X,Y), X, Y).
nonlin_2( exp(A,B), A,B, exp(X,Y), X, Y).
nonlin_2( pow(A,B), A,B, exp(X,Y), X, Y). % pow->exp
nonlin_2( A^B, A,B, exp(X,Y), X, Y).
nf_nonlin_1( Skel, An, S1, Norm) :-
( nf_constant( An, S1) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
;
S1 = An,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nf_nonlin_2( Skel, A1n, A2n, S1, S2, Norm) :-
( nf_constant( A1n, S1),
nf_constant( A2n, S2) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
; Skel=exp(_,_),
nf_constant( A2n, Exp),
integerp( Exp, I) ->
nf_power( I, A1n, Norm)
;
S1 = A1n,
S2 = A2n,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nl_eval( abs(X), R) :- arith_eval( abs(X), R).
nl_eval( sin(X), R) :- arith_eval( sin(X), R).
nl_eval( cos(X), R) :- arith_eval( cos(X), R).
nl_eval( tan(X), R) :- arith_eval( tan(X), R).
%
nl_eval( min(X,Y), R) :- arith_eval( min(X,Y), R).
nl_eval( max(X,Y), R) :- arith_eval( max(X,Y), R).
nl_eval( exp(X,Y), R) :- arith_eval( exp(X,Y), R).
monash_constant( X, _) :- var(X), !, fail.
monash_constant( p, 3.14259265).
monash_constant( pi, 3.14259265).
monash_constant( e, 2.71828182).
monash_constant( zero, Eps) :- arith_eps( Eps).
%
% check if a Nf consists of just a constant
%
nf_constant( [], Z) :- arith_eval( 0, Z).
nf_constant( [v(K,[])], K).
%
% this depends on the polynf ordering, i.e. [] < [X^1] ...
%
split( [], [], Z) :- arith_eval( 0, Z).
split( [First|T], H, I) :-
( First=v(I,[]) ->
H=T
;
arith_eval( 0, I),
H = [First|T]
).
%
% runtime predicate
%
:- mode nf_add( +, +, ?).
%
nf_add( [], Bs, Bs).
nf_add( [A|As], Bs, Cs) :-
nf_add( Bs, A, As, Cs).
:- mode nf_add( +, +, +, ?).
%
nf_add( [], A, As, Cs) :- Cs = [A|As].
nf_add( [B|Bs], A, As, Cs) :-
A = v(Ka,Pa),
B = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_case( Rel, A, As, Cs, B, Bs, Ka, Kb, Pa).
:- mode nf_add_case( +, +, +, -, +, +, +, +, +).
%
nf_add_case( <, A, As, Cs, B, Bs, _, _, _) :-
Cs=[A|Rest],
nf_add( As, B, Bs, Rest).
nf_add_case( >, A, As, Cs, B, Bs, _, _, _) :-
Cs=[B|Rest],
nf_add( Bs, A, As, Rest).
nf_add_case( =, _, As, Cs, _, Bs, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
nf_add( As, Bs, Cs)
;
Cs=[v(Kc,Pa)|Rest],
nf_add( As, Bs, Rest)
).
:- mode nf_mul( +, +, -).
%
nf_mul( A, B, Res) :-
nf_length( A, 0, LenA),
nf_length( B, 0, LenB),
nf_mul_log( LenA, A, [], LenB, B, Res).
nf_mul_log( 0, As, As, _, _, []) :- !.
nf_mul_log( 1, [A|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A, R).
nf_mul_log( 2, [A1,A2|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A1, A1b),
nf_mul_factor_log( Lb, B, [], A2, A2b),
nf_add( A1b, A2b, R).
nf_mul_log( N, A0, A2, Lb, B, R) :-
P is N>>1,
Q is N-P,
nf_mul_log( P, A0, A1, Lb, B, Rp),
nf_mul_log( Q, A1, A2, Lb, B, Rq),
nf_add( Rp, Rq, R).
:- mode nf_add_2( +, +, -).
%
nf_add_2( Af, Bf, Res) :- % unfold: nf_add( [Af], [Bf], Res).
Af = v(Ka,Pa),
Bf = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_2_case( Rel, Af, Bf, Res, Ka, Kb, Pa).
:- mode nf_add_2_case( +, +, +, -, +, +, +).
%
nf_add_2_case( <, Af, Bf, [Af,Bf], _, _, _).
nf_add_2_case( >, Af, Bf, [Bf,Af], _, _, _).
nf_add_2_case( =, _, _, Res, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
Res = []
;
Res=[v(Kc,Pa)]
).
%
% multiply with a scalar =\= 0
%
nf_mul_k( [], _, []).
nf_mul_k( [v(I,P)|Vs], K, [v(Ki,P)|Vks]) :-
arith_eval( K*I, Ki),
nf_mul_k( Vs, K, Vks).
nf_mul_factor( v(K,[]), Sum, Res) :- !, nf_mul_k( Sum, K, Res).
nf_mul_factor( F, Sum, Res) :-
nf_length( Sum, 0, Len),
nf_mul_factor_log( Len, Sum, [], F, Res).
nf_mul_factor_log( 0, As, As, _, []) :- !.
nf_mul_factor_log( 1, [A|As], As, F, [R]) :- !,
mult( A, F, R).
nf_mul_factor_log( 2, [A,B|As], As, F, Res) :- !,
mult( A, F, Af),
mult( B, F, Bf),
nf_add_2( Af, Bf, Res).
nf_mul_factor_log( N, A0, A2, F, R) :-
P is N>>1,
Q is N-P,
nf_mul_factor_log( P, A0, A1, F, Rp),
nf_mul_factor_log( Q, A1, A2, F, Rq),
nf_add( Rp, Rq, R).
mult( v(Ka,La), v(Kb,Lb), v(Kc,Lc)) :-
arith_eval( Ka*Kb, Kc),
pmerge( La, Lb, Lc).
pmerge( [], Bs, Bs).
pmerge( [A|As], Bs, Cs) :-
pmerge( Bs, A, As, Cs).
:- mode pmerge(+,+,+,-).
%
pmerge( [], A, As, Res) :- Res = [A|As].
pmerge( [B|Bs], A, As, Res) :-
A=Xa^Ka,
B=Xb^Kb,
compare( R, Xa, Xb),
pmerge_case( R, A, As, Res, B, Bs, Ka, Kb, Xa).
:- mode pmerge_case( +, +, +, -, +, +, +, +, ?).
%
pmerge_case( <, A, As, Res, B, Bs, _, _, _) :-
Res = [A|Tail],
pmerge( As, B, Bs, Tail).
pmerge_case( >, A, As, Res, B, Bs, _, _, _) :-
Res = [B|Tail],
pmerge( Bs, A, As, Tail).
pmerge_case( =, _, As, Res, _, Bs, Ka, Kb, Xa) :-
Kc is Ka+Kb,
( Kc=:=0 ->
pmerge( As, Bs, Res)
;
Res = [Xa^Kc|Tail],
pmerge( As, Bs, Tail)
).
nf_div( [], _, _) :- !, zero_division.
nf_div( [v(K,P)], Sum, Res) :- !,
arith_eval( 1/K, Ki),
mult_exp( P, -1, Pi),
nf_mul_factor( v(Ki,Pi), Sum, Res).
nf_div( D, A, [v(One,[(A/D)^1])]) :-
arith_eval( 1, One).
zero_division :- fail. % raise_exception(_) ?
mult_exp( [], _, []).
mult_exp( [X^P|Xs], K, [X^I|Tail]) :-
I is K*P,
mult_exp( Xs, K, Tail).
%
% raise to integer powers
%
% | ?- time({(1+X+Y+Z)^15=0}).
% Timing 00:00:02.610 2.610 iterative
% Timing 00:00:00.660 0.660 binomial
nf_power( N, Sum, Norm) :-
integer( N),
compare( Rel, N, 0),
( Rel = < ->
Pn is -N,
% nf_power_pos( Pn, Sum, Inorm),
binom( Sum, Pn, Inorm),
arith_eval( 1, One),
nf_div( Inorm, [v(One,[])], Norm)
; Rel = > ->
% nf_power_pos( N, Sum, Norm)
binom( Sum, N, Norm)
; Rel = = -> % 0^0 is indeterminate but we say 1
arith_eval( 1, One),
Norm = [v(One,[])]
).
%
% N>0
%
nf_power_pos( 1, Sum, Norm) :- !, Sum = Norm.
nf_power_pos( N, Sum, Norm) :-
N1 is N-1,
nf_power_pos( N1, Sum, Pn1),
nf_mul( Sum, Pn1, Norm).
%
% N>0
%
binom( Sum, 1, Power) :- !, Power = Sum.
binom( [], _, []).
binom( [A|Bs], N, Power) :-
( Bs=[] ->
nf_power_factor( A, N, Ap),
Power = [Ap]
; Bs=[_|_] ->
arith_eval( 1, One),
factor_powers( N, A, v(One,[]), Pas),
sum_powers( N, Bs, [v(One,[])], Pbs, []),
combine_powers( Pas, Pbs, 0, N, 1, [], Power)
).
combine_powers( [], [], _, _, _, Pi, Pi).
combine_powers( [A|As], [B|Bs], L, R, C, Pi, Po) :-
nf_mul( A, B, Ab),
arith_normalize( C, Cn),
nf_mul_k( Ab, Cn, Abc),
nf_add( Abc, Pi, Pii),
L1 is L+1,
R1 is R-1,
C1 is C*R//L1,
combine_powers( As, Bs, L1, R1, C1, Pii, Po).
nf_power_factor( v(K,P), N, v(Kn,Pn)) :-
arith_normalize( N, Nn),
arith_eval( exp(K,Nn), Kn),
mult_exp( P, N, Pn).
factor_powers( 0, _, Prev, [[Prev]]) :- !.
factor_powers( N, F, Prev, [[Prev]|Ps]) :-
N1 is N-1,
mult( Prev, F, Next),
factor_powers( N1, F, Next, Ps).
sum_powers( 0, _, Prev, [Prev|Lt], Lt) :- !.
sum_powers( N, S, Prev, L0, Lt) :-
N1 is N-1,
nf_mul( S, Prev, Next),
sum_powers( N1, S, Next, L0, [Prev|Lt]).
% ------------------------------------------------------------------------------
repair( Sum, Norm) :-
nf_length( Sum, 0, Len),
repair_log( Len, Sum, [], Norm).
repair_log( 0, As, As, []) :- !.
repair_log( 1, [v(Ka,Pa)|As], As, R) :- !,
repair_term( Ka, Pa, R).
repair_log( 2, [v(Ka,Pa),v(Kb,Pb)|As], As, R) :- !,
repair_term( Ka, Pa, Ar),
repair_term( Kb, Pb, Br),
nf_add( Ar, Br, R).
repair_log( N, A0, A2, R) :-
P is N>>1,
Q is N-P,
repair_log( P, A0, A1, Rp),
repair_log( Q, A1, A2, Rq),
nf_add( Rp, Rq, R).
repair_term( K, P, Norm) :-
length( P, Len),
arith_eval( 1, One),
repair_p_log( Len, P, [], Pr, [v(One,[])], Sum),
nf_mul_factor( v(K,Pr), Sum, Norm).
repair_p_log( 0, Ps, Ps, [], L0, L0) :- !.
repair_p_log( 1, [X^P|Ps], Ps, R, L0, L1) :- !,
repair_p( X, P, R, L0, L1).
repair_p_log( 2, [X^Px,Y^Py|Ps], Ps, R, L0,L2) :- !,
repair_p( X, Px, Rx, L0, L1),
repair_p( Y, Py, Ry, L1, L2),
pmerge( Rx, Ry, R).
repair_p_log( N, P0, P2, R, L0, L2) :-
P is N>>1,
Q is N-P,
repair_p_log( P, P0, P1, Rp, L0, L1),
repair_p_log( Q, P1, P2, Rq, L1, L2),
pmerge( Rp, Rq, R).
repair_p( Term, P, [Term^P], L0, L0) :- var( Term).
repair_p( Term, P, [], L0, L1) :- nonvar( Term),
repair_p_one( Term, TermN),
nf_power( P, TermN, TermNP),
nf_mul( TermNP, L0, L1).
%
% An undigested term a/b is distinguished from an
% digested one by the fact that its arguments are
% digested -> cuts after repair of args!
%
repair_p_one( Term, TermN) :-
nf_number( Term, TermN), % freq. shortcut for nf/2 case below
!.
repair_p_one( A1/A2, TermN) :-
repair( A1, A1n),
repair( A2, A2n),
!,
nf_div( A2n, A1n, TermN).
repair_p_one( Term, TermN) :-
nonlin_1( Term, Arg, Skel, Sa),
repair( Arg, An),
!,
nf_nonlin_1( Skel, An, Sa, TermN).
repair_p_one( Term, TermN) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
repair( A1, A1n),
repair( A2, A2n),
!,
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, TermN).
repair_p_one( Term, TermN) :-
nf( Term, TermN).
:- mode nf_length( +, +, -).
%
nf_length( [], Li, Li).
nf_length( [_|R], Li, Lo) :-
Lii is Li+1,
nf_length( R, Lii, Lo).
% ------------------------------------------------------------------------------
nf2term( [], Z) :- arith_eval( 0, Z).
nf2term( [F|Fs], T) :-
f02t( F, T0),
yfx( Fs, T0, T).
yfx( [], T0, T0).
yfx( [F|Fs], T0, TN) :-
fn2t( F, Ft, Op),
T1 =.. [Op,T0,Ft],
yfx( Fs, T1, TN).
f02t( v(K,P), T) :-
( P = [] ->
T = K
; arith_eval( K=:=1) ->
p2term( P, T)
; arith_eval( K=:= -1) ->
T = -Pt,
p2term( P, Pt)
;
T = K*Pt,
p2term( P, Pt)
).
fn2t( v(K,P), Term, Op) :-
( arith_eval( K=:=1) ->
Term = Pt, Op = +
; arith_eval( K=:= -1) ->
Term = Pt, Op = -
; arith_eval( K<0) ->
arith_eval( -K, Kf),
Term = Kf*Pt, Op = -
;
Term = K*Pt, Op = +
),
p2term( P, Pt).
p2term( [X^P|Xs], Term) :-
( Xs=[] ->
pe2term( X, Xt),
exp2term( P, Xt, Term)
; Xs=[_|_] ->
Term = Xst*Xtp,
pe2term( X, Xt),
exp2term( P, Xt, Xtp),
p2term( Xs, Xst)
).
exp2term( 1, X, X) :- !.
exp2term(-1, X, One/X) :- !, arith_eval( 1, One).
exp2term( P, X, Term) :-
arith_normalize( P, Pn),
% Term = exp(X,Pn).
Term = X^Pn.
pe2term( X, Term) :- var(X), Term = X.
pe2term( X, Term) :- nonvar(X),
X =.. [F|Args],
pe2term_args( Args, Argst),
Term =.. [F|Argst].
pe2term_args( [], []).
pe2term_args( [A|As], [T|Ts]) :-
nf2term( A, T),
pe2term_args( As, Ts).

136
CLPQR/clpq/ordering.pl
View File

@ -1,136 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: ordering.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Collect ordering constraints
% Produce an arrangement via toplogical sorting
%
%
:- use_module( library(lists), [append/3]).
:- use_module( library(ugraphs),
[
top_sort/2,
add_edges/3,
add_vertices/3
]).
ordering( X) :- var(X), !, fail.
ordering( A>B) :- !, ordering( B<A).
ordering( A<B) :-
join_class( [A,B], Class),
class_get_prio( Class, Ga),
!,
add_edges( [], [A-B], Gb), % [] = empty graph
combine( Ga, Gb, Gc),
class_put_prio( Class, Gc).
ordering( Pb) :- Pb = [_|Xs],
join_class( Pb, Class),
class_get_prio( Class, Ga),
!,
( Xs=[],
add_vertices( [], Pb, Gb)
; Xs=[_|_],
gen_edges( Pb, Es, []),
add_edges( [], Es, Gb)
),
combine( Ga, Gb, Gc),
class_put_prio( Class, Gc).
ordering( _).
arrangement( Class, Arr) :-
class_get_prio( Class, G),
normalize( G, Gn),
top_sort( Gn, Arr),
!.
arrangement( _, _) :-
raise_exception( unsatisfiable_ordering).
join_class( [], _).
join_class( [X|Xs], Class) :-
( var(X), get_or_add_class( X, Class)
; nonvar(X)
),
join_class( Xs, Class).
combine( Ga, Gb, Gc) :-
normalize( Ga, Gan),
normalize( Gb, Gbn),
ugraphs:graph_union( Gan, Gbn, Gc).
%
% both Ga and Gb might have their internal ordering invalidated
% because of bindings and aliasings
%
normalize( [], []).
normalize( G, Gsgn) :-
G=[_|_],
keysort( G, Gs),
group( Gs, Gsg),
normalize_vertices( Gsg, Gsgn).
normalize_vertices( [], []).
normalize_vertices( [X-Xnb|Xs], Res) :-
( normalize_vertex( X, Xnb, Xnorm) ->
Res = [Xnorm|Xsn],
normalize_vertices( Xs, Xsn)
;
normalize_vertices( Xs, Res)
).
%
% get rid of nonvar vertices/edges, and turn V-[V] into V-[]
%
normalize_vertex( X, Nbs, X-Nbsss) :-
var(X),
sort( Nbs, Nbss),
strip_nonvar( Nbss, X, Nbsss).
strip_nonvar( [], _, []).
strip_nonvar( [X|Xs], Y, Res) :-
( X==Y -> strip_nonvar( Xs, Y, Res)
; var(X) ->
Res=[X|Stripped],
strip_nonvar( Xs, Y, Stripped)
; nonvar(X),
Res=[] % because Vars<anything
).
gen_edges( []) --> [].
gen_edges( [X|Xs]) -->
gen_edges( Xs, X),
gen_edges( Xs).
gen_edges( [], _) --> [].
gen_edges( [Y|Ys], X) -->
[ X-Y ],
gen_edges( Ys, X).
%
% map k-La,k-Lb.... into k-LaLb
%
group( [], []).
group( [K-Kl|Ks], Res) :-
group( Ks, K, Kl, Res).
group( [], K, Kl, [K-Kl]).
group( [L-Ll|Ls], K, Kl, Res) :-
( K==L ->
append( Kl, Ll, KLl),
group( Ls, K, KLl, Res)
;
Res = [K-Kl|Tail],
group( Ls, L, Ll, Tail)
).

147
CLPQR/clpq/project.pl
View File

@ -1,147 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: project.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Answer constraint projection
%
:- public project_attributes/2. % xref.pl
%
% interface predicate
%
% May be destructive (either acts on a copy or in a failure loop)
%
project_attributes( TargetVars, Cvas) :-
sort( TargetVars, Tvs), % duplicates ?
sort( Cvas, Avs), % duplicates ?
mark_target( Tvs),
project_nonlin( Tvs, Avs, NlReachable),
( Tvs == [] ->
drop_lin_atts( Avs)
;
redundancy_vars( Avs), % redundancy.pl
make_target_indep( Tvs, Pivots),
mark_target( NlReachable), % after make_indep to express priority
drop_dep( Avs),
fm_elim( Avs, Tvs, Pivots),
impose_ordering( Avs)
).
mark_target( []).
mark_target( [V|Vs]) :-
put_atts( V, target),
mark_target( Vs).
mark_keep( []).
mark_keep( [V|Vs]) :-
put_atts( V, keep),
mark_keep( Vs).
%
% Collect the pivots in reverse order
% We have to protect the target variables pivot partners
% from redundancy eliminations triggered by fm_elim,
% in order to allow for reverse pivoting.
%
make_target_indep( Ts, Ps) :- make_target_indep( Ts, [], Ps).
make_target_indep( [], Ps, Ps).
make_target_indep( [T|Ts], Ps0,Pst) :-
( get_atts( T, [lin(Lin),type(Type)]),
decompose( Lin, H, _, _),
nontarget( H, Nt) ->
Ps1 = [T:Nt|Ps0],
put_atts( Nt, keep),
pivot( T, Nt, Type)
;
Ps1 = Ps0
),
make_target_indep( Ts, Ps1,Pst).
nontarget( [V*_|Vs], Nt) :-
( get_atts( V, [-target,-keep_indep]) ->
Nt = V
;
nontarget( Vs, Nt)
).
drop_dep( Vs) :- var( Vs), !.
drop_dep( []).
drop_dep( [V|Vs]) :-
drop_dep_one( V),
drop_dep( Vs).
drop_dep_one( V) :-
get_atts( V, [lin(Lin),type(t_none),-target,-keep,-nonzero]),
\+ indep( Lin, V),
!,
put_atts( V, [-lin(_),-type(_),-class(_),-order(_),-strictness(_)]).
drop_dep_one( _).
drop_lin_atts( []).
drop_lin_atts( [V|Vs]) :-
put_atts( V, [-lin(_),-type(_),-class(_),-order(_),-strictness(_)]),
drop_lin_atts( Vs).
impose_ordering( Cvas) :-
systems( Cvas, [], Sys),
impose_ordering_sys( Sys).
impose_ordering_sys( []).
impose_ordering_sys( [S|Ss]) :-
arrangement( S, Arr), % ordering.pl
arrange( Arr, S),
impose_ordering_sys( Ss).
arrange( [], _).
arrange( Arr, S) :- Arr = [_|_],
class_allvars( S, All),
order( Arr, 1, N),
order( All, N, _),
renorm_all( All),
arrange_pivot( All).
order( Xs, N, M) :- var(Xs), !, N=M.
order( [], N, N).
order( [X|Xs], N, M) :-
( get_atts( X, order(O)),
var(O) ->
O=N,
N1 is N+1,
order( Xs, N1, M)
;
order( Xs, N, M)
).
renorm_all( Xs) :- var( Xs), !.
renorm_all( [X|Xs]) :-
( get_atts( X, lin(Lin)) ->
renormalize( Lin, New),
put_atts( X, lin(New)),
renorm_all( Xs)
;
renorm_all( Xs)
).
arrange_pivot( Xs) :- var( Xs), !.
arrange_pivot( [X|Xs]) :-
( get_atts( X, [lin(Lin),type(t_none)]),
decompose( Lin, [Y*_|_], _, _),
nf_ordering( Y, X, <) ->
pivot( X, Y, t_none),
arrange_pivot( Xs)
;
arrange_pivot( Xs)
).

157
CLPQR/clpq/redund.pl
View File

@ -1,157 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.2 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: redund.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% redundancy removal (semantic definition)
%
% done:
% +) deal with active bounds
% +) indep t_[lu] -> t_none invalidates invariants (fixed)
%
%
% O(n^2), use sort later
%
systems( [], Si, Si).
systems( [V|Vs], Si, So) :-
( var(V), get_atts( V, class(C)),
not_memq( Si, C) ->
systems( Vs, [C|Si], So)
;
systems( Vs, Si, So)
).
not_memq( [], _).
not_memq( [Y|Ys], X) :-
X \== Y,
not_memq( Ys, X).
redundancy_systems( []).
redundancy_systems( [S|Sys]) :-
class_allvars( S, All),
redundancy_vs( All),
redundancy_systems( Sys).
redundancy_vars( Vs) :- !, redundancy_vs( Vs).
redundancy_vars( Vs) :-
statistics( runtime, [Start|_]),
redundancy_vs( Vs),
statistics( runtime, [End|_]),
Duration is End-Start,
format( user_error, "% Redundancy elimination took ~d msec~n", Duration).
%
% remove redundant bounds from variables
%
redundancy_vs( Vs) :- var( Vs), !.
redundancy_vs( []).
redundancy_vs( [V|Vs]) :-
( get_atts( V, [type(Type),strictness(Strict)]),
redundant( Type, V, Strict) ->
redundancy_vs( Vs)
;
redundancy_vs( Vs)
).
redundant( t_l(L), X, Strict) :-
detach_bounds( X), % drop temporarily
negate_l( Strict, L, X),
red_t_l.
redundant( t_u(U), X, Strict) :-
detach_bounds( X),
negate_u( Strict, U, X),
red_t_u.
redundant( t_lu(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( put_atts( X, [type(t_u(U)),strictness(Su)]),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_u(U), X, Strict) -> true ; true )
; put_atts( X, [type(t_l(L)),strictness(Sl)]),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
redundant( t_L(L), X, Strict) :-
arith_eval( -L, Bound),
intro_at( X, Bound, t_none), % drop temporarily
detach_bounds( X),
negate_l( Strict, L, X),
red_t_L.
redundant( t_U(U), X, Strict) :-
arith_eval( -U, Bound),
intro_at( X, Bound, t_none), % drop temporarily
detach_bounds( X),
negate_u( Strict, U, X),
red_t_U.
redundant( t_Lu(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( arith_eval( -L, Bound),
intro_at( X, Bound, t_u(U)),
put_atts( X, strictness(Su)),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_u(U), X, Strict) -> true ; true )
; put_atts( X, [type(t_L(L)),strictness(Sl)]),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
redundant( t_lU(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( put_atts( X, [type(t_U(U)),strictness(Su)]),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_U(U), X, Strict) -> true ; true )
; arith_eval( -U, Bound),
intro_at( X, Bound, t_l(L)),
put_atts( X, strictness(Sl)),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
strictness_parts( Strict, Lower, Upper) :-
Lower is Strict /\ 2'10,
Upper is Strict /\ 2'01.
%
% encapsulation via \+ (unfolded to avoid metacall)
%
/**/
negate_l( 2'00, L, X) :- { L > X }, !, fail.
negate_l( 2'01, L, X) :- { L > X }, !, fail.
negate_l( 2'10, L, X) :- { L >= X }, !, fail.
negate_l( 2'11, L, X) :- { L >= X }, !, fail.
negate_l( _, _, _).
negate_u( 2'00, U, X) :- { U < X }, !, fail.
negate_u( 2'01, U, X) :- { U =< X }, !, fail.
negate_u( 2'10, U, X) :- { U < X }, !, fail.
negate_u( 2'11, U, X) :- { U =< X }, !, fail.
negate_u( _, _, _).
/**/
%
% profiling
%
red_t_l.
red_t_u.
red_t_L.
red_t_U.

8
CLPQR/clpr/bb.yap → CLPQR/clpqr/bb.yap
View File

@ -50,7 +50,8 @@ bb_loop( Opt, Is, Eps) :-
%
% added ineqs may have led to binding
%
bb_reoptimize( Obj, Inf) :- var( Obj), iterate_dec( Obj, Inf).
%vsc: added ! (01/06/06)
bb_reoptimize( Obj, Inf) :- var( Obj), !, iterate_dec( Obj, Inf).
bb_reoptimize( Obj, Inf) :- nonvar( Obj), Inf = Obj.
bb_better_bound( Inf) :-
@ -59,7 +60,7 @@ bb_better_bound( Inf) :-
arith_eval( Inf < Inc).
bb_better_bound( _).
:- parallel(bb_branch/3).
% :- parallel(bb_branch/3).
bb_branch( V, U, _) :- { V =< U }.
bb_branch( V, _, L) :- { V >= L }.
@ -69,7 +70,8 @@ vertex_value( [X|Xs], [V|Vs]) :-
rhs_value( X, V),
vertex_value( Xs, Vs).
rhs_value( Xn, Value) :- nonvar(Xn), Value=Xn.
%vsc: added ! (01/06/06)
rhs_value( Xn, Value) :- nonvar(Xn), !, Value=Xn.
rhs_value( Xn, Value) :- var(Xn),
deref_var( Xn, Xd),
decompose( Xd, _, R, I),

66
CLPQR/clpr/bv.yap → CLPQR/clpqr/bv.yap
View File

@ -175,7 +175,7 @@ export_binding( [X-Y|Gs]) :-
%
% numerical stabilizer, clp(r) only
%
export_binding( Y, X) :- var(Y), Y=X.
export_binding( Y, X) :- var(Y), !, Y=X. %vsc: added cut here (01/06/06)
export_binding( Y, X) :- nonvar(Y),
( arith_eval( Y=:=0) ->
arith_eval( 0, X)
@ -301,17 +301,19 @@ iterate_dec( OptVar, Opt) :-
% arith_eval( R+I, Now), print(min(Now)), nl,
% dec_step_best( H, Status),
%vsc: added -> (01/06/06)
dec_step( H, Status),
( Status = applied, iterate_dec( OptVar, Opt)
; Status = optimum, arith_eval( R+I, Opt)
( Status = applied -> iterate_dec( OptVar, Opt)
; Status = optimum -> arith_eval( R+I, Opt)
).
iterate_inc( OptVar, Opt) :-
get_atts( OptVar, lin(Lin)),
decompose( Lin, H, R, I),
inc_step( H, Status),
( Status = applied, iterate_inc( OptVar, Opt)
; Status = optimum, arith_eval( R+I, Opt)
%vsc: added -> (01/06/06)
( Status = applied -> iterate_inc( OptVar, Opt)
; Status = optimum -> arith_eval( R+I, Opt)
).
%
@ -323,7 +325,8 @@ iterate_inc( OptVar, Opt) :-
dec_step( [], optimum).
dec_step( [V*K|Vs], Status) :-
get_atts( V, type(W)),
( W = t_U(U),
%vsc: added -> (01/06/06)
( W = t_U(U) ->
( arith_eval( K > 0) ->
( lb( V, Vub-Vb-_) ->
Status = applied,
@ -334,7 +337,7 @@ dec_step( [V*K|Vs], Status) :-
;
dec_step( Vs, Status)
)
; W = t_lU(L,U),
; W = t_lU(L,U) ->
( arith_eval( K > 0) ->
Status = applied,
arith_eval( L-U, Init),
@ -344,7 +347,7 @@ dec_step( [V*K|Vs], Status) :-
;
dec_step( Vs, Status)
)
; W = t_L(L),
; W = t_L(L) ->
( arith_eval( K < 0) ->
( ub( V, Vub-Vb-_) ->
Status = applied,
@ -355,7 +358,7 @@ dec_step( [V*K|Vs], Status) :-
;
dec_step( Vs, Status)
)
; W = t_Lu(L,U),
; W = t_Lu(L,U) ->
( arith_eval( K < 0) ->
Status = applied,
arith_eval( U-L, Init),
@ -365,14 +368,15 @@ dec_step( [V*K|Vs], Status) :-
;
dec_step( Vs, Status)
)
; W = t_none,
; W = t_none ->
Status = unlimited(V,t_none)
).
inc_step( [], optimum).
inc_step( [V*K|Vs], Status) :-
get_atts( V, type(W)),
( W = t_U(U),
%vsc: added -> (01/06/06)
( W = t_U(U) ->
( arith_eval( K < 0) ->
( lb( V, Vub-Vb-_) ->
Status = applied,
@ -383,7 +387,7 @@ inc_step( [V*K|Vs], Status) :-
;
inc_step( Vs, Status)
)
; W = t_lU(L,U),
; W = t_lU(L,U) ->
( arith_eval( K < 0) ->
Status = applied,
arith_eval( L-U, Init),
@ -393,7 +397,7 @@ inc_step( [V*K|Vs], Status) :-
;
inc_step( Vs, Status)
)
; W = t_L(L),
; W = t_L(L) ->
( arith_eval( K > 0) ->
( ub( V, Vub-Vb-_) ->
Status = applied,
@ -404,7 +408,7 @@ inc_step( [V*K|Vs], Status) :-
;
inc_step( Vs, Status)
)
; W = t_Lu(L,U),
; W = t_Lu(L,U) ->
( arith_eval( K > 0) ->
Status = applied,
arith_eval( U-L, Init),
@ -414,7 +418,7 @@ inc_step( [V*K|Vs], Status) :-
;
inc_step( Vs, Status)
)
; W = t_none,
; W = t_none ->
Status = unlimited(V,t_none)
).
@ -635,22 +639,23 @@ solve( Lin) :-
solve( [], _, I, Bind0,Bind0) :-
arith_eval( I=:=0). % redundant or trivially unsat
solve( H, Lin, _, Bind0,BindT) :-
H = [_|_], % indexing
%vsc: changed to list in head (01/06/06)
solve( [HHd|HTl], Lin, _, Bind0,BindT) :-
%
% [] is an empty ord_set, anything will be preferred
% over 9-9
%
sd( H, [],ClassesUniq, 9-9-0,Category-Selected-_, NV,NVT),
sd( [HHd|HTl], [],ClassesUniq, 9-9-0,Category-Selected-_, NV,NVT),
isolate( Selected, Lin, Lin1),
( Category = 1,
%vsc: added -> (01/06/06)
( Category = 1 ->
put_atts( Selected, lin(Lin1)),
decompose( Lin1, Hom, _, Inhom),
bs_collect_binding( Hom, Selected, Inhom, Bind0,BindT),
eq_classes( NV, NVT, ClassesUniq)
; Category = 2,
; Category = 2 ->
get_atts( Selected, class(NewC)),
class_allvars( NewC, Deps),
( ClassesUniq = [_] -> % rank increasing
@ -660,7 +665,7 @@ solve( H, Lin, _, Bind0,BindT) :-
bs( Deps, Selected, Lin1)
),
eq_classes( NV, NVT, ClassesUniq)
; Category = 3,
; Category = 3 ->
put_atts( Selected, lin(Lin1)),
get_atts( Selected, type(Type)),
deactivate_bound( Type, Selected),
@ -670,7 +675,7 @@ solve( H, Lin, _, Bind0,BindT) :-
decompose( Lin1, Hom, _, Inhom),
bs_collect_binding( Hom, Selected, Inhom, Bind0,Bind1),
rcbl( Basis, Bind1,BindT)
; Category = 4,
; Category = 4 ->
get_atts( Selected, [type(Type),class(NewC)]),
class_allvars( NewC, Deps),
( ClassesUniq = [_] -> % rank increasing
@ -750,10 +755,11 @@ preference( A, B, Pref) :-
A = Px-_-_,
B = Py-_-_,
compare( Rel, Px, Py),
( Rel = =, Pref = B
%vsc: added -> (01/06/06)
( Rel = = -> Pref = B
% ( arith_eval(abs(Ka)=<abs(Kb)) -> Pref=A ; Pref=B )
; Rel = <, Pref = A
; Rel = >, Pref = B
; Rel = < -> Pref = A
; Rel = > -> Pref = B
).
%
@ -1123,8 +1129,9 @@ rcbl_opt( l(L), X, Continuation, B0,B1) :-
normalize_scalar( Mop, MopN),
add_linear_11( MopN, Lin, Lin1),
decompose( Lin1, Hom, _, Inhom),
( Hom = [], rcbl( Continuation, B0,B1) % would not callback
; Hom = [_|_], solve( Hom, Lin1, Inhom, B0,B1)
%vsc: added -> (01/06/06)
( Hom = [] -> rcbl( Continuation, B0,B1) % would not callback
; Hom = [_|_] -> solve( Hom, Lin1, Inhom, B0,B1)
)
),
fail
@ -1141,8 +1148,9 @@ rcbl_opt( u(U), X, Continuation, B0,B1) :-
normalize_scalar( Mop, MopN),
add_linear_11( MopN, Lin, Lin1),
decompose( Lin1, Hom, _, Inhom),
( Hom = [], rcbl( Continuation, B0,B1) % would not callback
; Hom = [_|_], solve( Hom, Lin1, Inhom, B0,B1)
%vsc: added -> (01/06/06)
( Hom = [] -> rcbl( Continuation, B0,B1) % would not callback
; Hom = [_|_] -> solve( Hom, Lin1, Inhom, B0,B1)
)
),
(

45
CLPQR/clpr/ineq.pl → CLPQR/clpqr/ineq.yap
View File

@ -162,10 +162,11 @@ ineq_one_s_n_i( X, I) :-
ineq_one_old_s_p_0( [], _, Ix) :-
arith_eval( Ix < 0).
ineq_one_old_s_p_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ix/Ky, Bound),
update_indep( strict, Y, Ky, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udus( Type, X, Lin, Zero, Old)
@ -174,11 +175,12 @@ ineq_one_old_s_p_0( [Y*Ky|Tail], X, Ix) :-
ineq_one_old_s_n_0( [], _, Ix) :-
arith_eval( Ix > 0).
ineq_one_old_s_n_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ky, Coeff),
arith_eval( Ix/Coeff, Bound),
update_indep( strict, Y, Coeff, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udls( Type, X, Lin, Zero, Old)
@ -187,10 +189,11 @@ ineq_one_old_s_n_0( [Y*Ky|Tail], X, Ix) :-
ineq_one_old_s_p_i( [], I, _, Ix) :-
arith_eval( Ix+I < 0).
ineq_one_old_s_p_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -(Ix+I)/Ky, Bound),
update_indep( strict, Y, Ky, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( -I, Bound),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udus( Type, X, Lin, Bound, Old)
@ -199,11 +202,12 @@ ineq_one_old_s_p_i( [Y*Ky|Tail], I, X, Ix) :-
ineq_one_old_s_n_i( [], I, _, Ix) :-
arith_eval( -Ix+I < 0).
ineq_one_old_s_n_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ky, Coeff),
arith_eval( (Ix-I)/Coeff, Bound),
update_indep( strict, Y, Coeff, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udls( Type, X, Lin, I, Old)
).
@ -248,10 +252,11 @@ ineq_one_n_n_i( X, I) :-
ineq_one_old_n_p_0( [], _, Ix) :-
arith_eval( Ix =< 0).
ineq_one_old_n_p_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ix/Ky, Bound),
update_indep( nonstrict, Y, Ky, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udu( Type, X, Lin, Zero, Old)
@ -260,11 +265,12 @@ ineq_one_old_n_p_0( [Y*Ky|Tail], X, Ix) :-
ineq_one_old_n_n_0( [], _, Ix) :-
arith_eval( Ix >= 0).
ineq_one_old_n_n_0( [Y*Ky|Tail], X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ky, Coeff),
arith_eval( Ix/Coeff, Bound),
update_indep( nonstrict, Y, Coeff, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( 0, Zero),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udl( Type, X, Lin, Zero, Old)
@ -273,10 +279,11 @@ ineq_one_old_n_n_0( [Y*Ky|Tail], X, Ix) :-
ineq_one_old_n_p_i( [], I, _, Ix) :-
arith_eval( Ix+I =< 0).
ineq_one_old_n_p_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -(Ix+I)/Ky, Bound),
update_indep( nonstrict, Y, Ky, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
arith_eval( -I, Bound),
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udu( Type, X, Lin, Bound, Old)
@ -285,11 +292,12 @@ ineq_one_old_n_p_i( [Y*Ky|Tail], I, X, Ix) :-
ineq_one_old_n_n_i( [], I, _, Ix) :-
arith_eval( -Ix+I =< 0).
ineq_one_old_n_n_i( [Y*Ky|Tail], I, X, Ix) :-
( Tail = [],
%vsc: added -> (01/06/06)
( Tail = [] ->
arith_eval( -Ky, Coeff),
arith_eval( (Ix-I)/Coeff, Bound),
update_indep( nonstrict, Y, Coeff, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
get_atts( X, [lin(Lin),type(Type),strictness(Old)]),
udl( Type, X, Lin, I, Old)
).
@ -299,11 +307,12 @@ ineq_one_old_n_n_i( [Y*Ky|Tail], I, X, Ix) :-
ineq_more( [], I, _, Strictness) :- ineq_ground( Strictness, I).
ineq_more( [X*K|Tail], Id, Lind, Strictness) :-
( Tail = [], % one var: update bound instead of slack introduction
%vsc: added -> (01/06/06)
( Tail = [] -> % one var: update bound instead of slack introduction
get_or_add_class( X, _),
arith_eval( -Id/K, Bound),
update_indep( Strictness, X, K, Bound)
; Tail = [_|_],
; Tail = [_|_] ->
ineq_more( Strictness, Lind)
).

3
CLPQR/clpr/nf.yap → CLPQR/clpqr/nf.yap
View File

@ -724,7 +724,8 @@ repair_p_log( N, P0, P2, R, L0, L2) :-
pmerge( Rp, Rq, R).
repair_p( Term, P, [Term^P], L0, L0) :- var( Term).
%vsc: added ! (01/06/06)
repair_p( Term, P, [Term^P], L0, L0) :- var( Term), !.
repair_p( Term, P, [], L0, L1) :- nonvar( Term),
repair_p_one( Term, TermN),
nf_power( P, TermN, TermNP),

5
CLPQR/clpr/ordering.pl → CLPQR/clpqr/ordering.yap
View File

@ -74,9 +74,8 @@ combine( Ga, Gb, Gc) :-
% because of bindings and aliasings
%
normalize( [], []).
normalize( G, Gsgn) :-
G=[_|_],
keysort( G, Gs),
normalize( [GH|GT], Gsgn) :- %vsc: added list in argument (01/06/06)
keysort( [GH|GT], Gs),
group( Gs, Gsg),
normalize_vertices( Gsg, Gsgn).

27
CLPQR/clpq/store.pl → CLPQR/clpqr/store.yap
View File

@ -65,17 +65,18 @@ add_linear_ffh( [X*Kx|Xs], Ka, Ys, Kb, Zs) :-
add_linear_ffh( [], X, Kx, Xs, Zs, Ka, _) :- mult_hom( [X*Kx|Xs], Ka, Zs).
add_linear_ffh( [Y*Ky|Ys], X, Kx, Xs, Zs, Ka, Kb) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx*Ka+Ky*Kb, Kz),
%vsc: added -> (01/06/06)
( Rel = = -> arith_eval( Kx*Ka+Ky*Kb, Kz),
( arith_eval(Kz=:=0) ->
add_linear_ffh( Xs, Ka, Ys, Kb, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_ffh( Xs, Ka, Ys, Kb, Ztail)
)
; Rel = <, Zs = [X*Kz|Ztail],
; Rel = < -> Zs = [X*Kz|Ztail],
arith_eval( Kx*Ka, Kz),
add_linear_ffh( Xs, Y, Ky, Ys, Ztail, Kb, Ka)
; Rel = >, Zs = [Y*Kz|Ztail],
; Rel = > -> Zs = [Y*Kz|Ztail],
arith_eval( Ky*Kb, Kz),
add_linear_ffh( Ys, X, Kx, Xs, Ztail, Ka, Kb)
).
@ -95,17 +96,18 @@ add_linear_f1h( [X*Kx|Xs], Ka, Ys, Zs) :-
add_linear_f1h( [], X, Kx, Xs, Zs, Ka) :- mult_hom( [X*Kx|Xs], Ka, Zs).
add_linear_f1h( [Y*Ky|Ys], X, Kx, Xs, Zs, Ka) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx*Ka+Ky, Kz),
%vsc: added -> (01/06/06)
( Rel = = -> arith_eval( Kx*Ka+Ky, Kz),
( arith_eval(Kz=:=0) ->
add_linear_f1h( Xs, Ka, Ys, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_f1h( Xs, Ka, Ys, Ztail)
)
; Rel = <, Zs = [X*Kz|Ztail],
; Rel = < -> Zs = [X*Kz|Ztail],
arith_eval( Kx*Ka, Kz),
add_linear_f1h( Xs, Ka, [Y*Ky|Ys], Ztail)
; Rel = >, Zs = [Y*Ky|Ztail],
; Rel = > -> Zs = [Y*Ky|Ztail],
add_linear_f1h( Ys, X, Kx, Xs, Ztail, Ka)
).
@ -124,15 +126,16 @@ add_linear_11h( [X*Kx|Xs], Ys, Zs) :-
add_linear_11h( [], X, Kx, Xs, [X*Kx|Xs]).
add_linear_11h( [Y*Ky|Ys], X, Kx, Xs, Zs) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx+Ky, Kz),
%vsc: added -> (01/06/06)
( Rel = = -> arith_eval( Kx+Ky, Kz),
( arith_eval(Kz=:=0) ->
add_linear_11h( Xs, Ys, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_11h( Xs, Ys, Ztail)
)
; Rel = <, Zs = [X*Kx|Ztail], add_linear_11h( Xs, Y, Ky, Ys, Ztail)
; Rel = >, Zs = [Y*Ky|Ztail], add_linear_11h( Ys, X, Kx, Xs, Ztail)
; Rel = < -> Zs = [X*Kx|Ztail], add_linear_11h( Xs, Y, Ky, Ys, Ztail)
; Rel = > -> Zs = [Y*Ky|Ztail], add_linear_11h( Ys, X, Kx, Xs, Ztail)
).
mult_linear_factor( Lin, K, Mult) :-
@ -186,10 +189,10 @@ delete_factor( Vid, Lin, Res, Coeff) :-
delete_factor_hom( Vid, [Car|Cdr], RCdr, RKoeff) :-
Car = Var*Koeff,
compare( R, Var, Vid),
( R = =, RCdr = Cdr, RKoeff=Koeff
; R = <, RCdr = [Car|RCdr1],
( R = = -> RCdr = Cdr, RKoeff=Koeff %vsc: added -> (01/06/06)
; R = < -> RCdr = [Car|RCdr1],
delete_factor_hom( Vid, Cdr, RCdr1, RKoeff)
; R = >, RCdr = [Car|RCdr1],
; R = > -> RCdr = [Car|RCdr1],
delete_factor_hom( Vid, Cdr, RCdr1, RKoeff)
).
/**/

668
CLPQR/clpr/arith.pl
View File

@ -1,668 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: arith.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% common code for R,Q, runtime predicates
%
% linearize evaluation, collect vars
%
% Todo: +) limited encoding length option
% +) 2 stage compilation: a) linearization
% b) specialization to R or Q
%
%
l2conj( [], true).
l2conj( [X|Xs], Conj) :-
( Xs = [], Conj = X
; Xs = [_|_], Conj = (X,Xc), l2conj( Xs, Xc)
).
% ----------------------------------------------------------------------
%
% float/1 coercion is allowed only at the outermost level in Q
%
compile_Q( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_Q( Linear, Code, Ct),
( Res = boolean, Ct = []
; Res = float(R), Ct = []
; Res = rat(N,D), Ct = [ putq(D,N,R) ]
).
%
% assumes normalized params and puts a normalized result
%
compile_Qn( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_Qn( Linear, Code, Ct),
( Res = boolean, Ct = []
; Res = float(R), Ct = []
; Res = rat(N,D), Ct = [ putq(D,N,R) ]
).
compile_case_signum_Qn( Term, Lt,Z,Gt, Code) :-
linearize( Term, rat(N,_), Linear),
specialize_Qn( Linear, Code,
[
compare( Rel, N, 0),
( Rel = <, Lt
; Rel = =, Z
; Rel = >, Gt
)
]).
specialize_Qn( []) --> [].
specialize_Qn( [Op|Ops]) -->
specialize_Qn( Op),
specialize_Qn( Ops).
%
specialize_Qn( op_var(rat(N,D),Var)) --> [ Var=rat(N,D) ]. % <--- here is the difference ---
specialize_Qn( op_integer(rat(I,1),I)) --> [].
specialize_Qn( op_rat(rat(N,D),N,D)) --> [].
specialize_Qn( op_float(rat(N,D),X)) --> [], { float_rat( X, N,D) }.
specialize_Qn( apply(R,Func)) -->
specialize_Q_fn( Func, R).
specialize_Q( []) --> [].
specialize_Q( [Op|Ops]) -->
specialize_Q( Op),
specialize_Q( Ops).
%
specialize_Q( op_var(rat(N,D),Var)) --> [ getq(Var,N,D) ].
specialize_Q( op_integer(rat(I,1),I)) --> [].
specialize_Q( op_rat(rat(N,D),N,D)) --> [], { D > 0 }.
specialize_Q( op_float(rat(N,D),X)) --> [], { float_rat( X, N,D) }.
specialize_Q( apply(R,Func)) -->
specialize_Q_fn( Func, R).
specialize_Q_fn( +rat(N,D), rat(N,D)) --> [].
specialize_Q_fn( numer(rat(N,_)), rat(N,1)) --> [].
specialize_Q_fn( denom(rat(_,D)), rat(D,1)) --> [].
specialize_Q_fn( -rat(N0,D), rat(N,D)) --> [ N is -N0 ].
specialize_Q_fn( abs(rat(Nx,Dx)), rat(N,D)) --> [ N is abs(Nx) ], {D=Dx}.
specialize_Q_fn( signum(rat(Nx,Dx)), rat(N,D)) --> [ signumq( Nx,Dx, N,D) ].
specialize_Q_fn( floor(rat(Nx,Dx)), rat(N,D)) --> [ floorq( Nx,Dx, N,D) ].
specialize_Q_fn( ceiling(rat(Nx,Dx)), rat(N,D)) --> [ ceilingq( Nx,Dx, N,D) ].
specialize_Q_fn( truncate(rat(Nx,Dx)), rat(N,D)) --> [ truncateq( Nx,Dx, N,D) ].
specialize_Q_fn( round(rat(Nx,Dx)), rat(N,D)) --> [ roundq( Nx,Dx, N,D) ].
specialize_Q_fn( log(rat(Nx,Dx)), rat(N,D)) --> [ logq( Nx,Dx, N,D) ].
specialize_Q_fn( exp(rat(Nx,Dx)), rat(N,D)) --> [ expq( Nx,Dx, N,D) ].
specialize_Q_fn( sin(rat(Nx,Dx)), rat(N,D)) --> [ sinq( Nx,Dx, N,D) ].
specialize_Q_fn( cos(rat(Nx,Dx)), rat(N,D)) --> [ cosq( Nx,Dx, N,D) ].
specialize_Q_fn( tan(rat(Nx,Dx)), rat(N,D)) --> [ tanq( Nx,Dx, N,D) ].
specialize_Q_fn( asin(rat(Nx,Dx)), rat(N,D)) --> [ asinq( Nx,Dx, N,D) ].
specialize_Q_fn( acos(rat(Nx,Dx)), rat(N,D)) --> [ acosq( Nx,Dx, N,D) ].
specialize_Q_fn( atan(rat(Nx,Dx)), rat(N,D)) --> [ atanq( Nx,Dx, N,D) ].
specialize_Q_fn( float(rat(Nx,Dx)), float(F)) --> [ rat_float( Nx,Dx, F) ].
%
specialize_Q_fn( rat(Nx,Dx)+rat(Ny,Dy), rat(N,D)) --> [ addq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)-rat(Ny,Dy), rat(N,D)) --> [ subq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)*rat(Ny,Dy), rat(N,D)) --> [ mulq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( rat(Nx,Dx)/rat(Ny,Dy), rat(N,D)) --> [ divq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( exp(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ expq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( min(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ minq( Nx,Dx, Ny,Dy, N,D) ].
specialize_Q_fn( max(rat(Nx,Dx),rat(Ny,Dy)), rat(N,D)) --> [ maxq( Nx,Dx, Ny,Dy, N,D) ].
%
specialize_Q_fn( rat(Nx,Dx) < rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, <) ].
specialize_Q_fn( rat(Nx,Dx) > rat(Ny,Dy), boolean) --> [ comq( Ny,Dy, Nx,Dx, <) ].
specialize_Q_fn( rat(Nx,Dx) =< rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, Rel), Rel \== (>) ].
specialize_Q_fn( rat(Nx,Dx) >= rat(Ny,Dy), boolean) --> [ comq( Ny,Dy, Nx,Dx, Rel), Rel \== (>) ].
specialize_Q_fn( rat(Nx,Dx) =\= rat(Ny,Dy), boolean) --> [ comq( Nx,Dx, Ny,Dy, Rel), Rel \== (=) ].
specialize_Q_fn( rat(Nx,Dx) =:= rat(Ny,Dy), boolean) -->
%
% *normalized* rationals
%
( {Nx = Ny} -> [] ; [ Nx = Ny ] ),
( {Dx = Dy} -> [] ; [ Dx = Dy ] ).
% ----------------------------------------------------------------------
compile_R( Term, R, Code) :-
linearize( Term, Res, Linear),
specialize_R( Linear, Code, Ct),
( Res == boolean ->
Ct = [], R = boolean
; float(Res) ->
Ct = [ R=Res ]
;
Ct = [ R is Res ]
).
compile_case_signum_R( Term, Lt,Z,Gt, Code) :-
eps( Eps, NegEps),
linearize( Term, Res, Linear),
specialize_R( Linear, Code,
[
Rv is Res,
( Rv < NegEps -> Lt
; Rv > Eps -> Gt
; Z
)
]).
specialize_R( []) --> [].
specialize_R( [Op|Ops]) -->
specialize_R( Op),
specialize_R( Ops).
%
specialize_R( op_var(Var,Var)) --> [].
specialize_R( op_integer(R,I)) --> [], { R is float(I) }.
specialize_R( op_rat(R,N,D)) --> [], { rat_float( N,D, R) }.
specialize_R( op_float(F,F)) --> [].
specialize_R( apply(R,Func)) -->
specialize_R_fn( Func, R).
specialize_R_fn( signum(X), S) -->
( {var(X)} ->
{Xe=X}
;
[ Xe is X ]
),
{
eps( Eps, NegEps)
},
[
( Xe < NegEps -> S = -1.0
; Xe > Eps -> S = 1.0
; S = 0.0
)
].
specialize_R_fn( +X, X) --> [].
specialize_R_fn( -X, -X) --> [].
specialize_R_fn( abs(X), abs(X)) --> [].
specialize_R_fn( floor(X), float(floor(/*float?*/X))) --> [].
specialize_R_fn( ceiling(X), float(ceiling(/*float?*/X))) --> [].
specialize_R_fn( truncate(X), float(truncate(/*float?*/X))) --> [].
specialize_R_fn( round(X), float(round(/*float?*/X))) --> [].
specialize_R_fn( log(X), log(X)) --> [].
specialize_R_fn( exp(X), exp(X)) --> [].
specialize_R_fn( sin(X), sin(X)) --> [].
specialize_R_fn( cos(X), cos(X)) --> [].
specialize_R_fn( tan(X), tan(X)) --> [].
specialize_R_fn( asin(X), asin(X)) --> [].
specialize_R_fn( acos(X), acos(X)) --> [].
specialize_R_fn( atan(X), atan(X)) --> [].
specialize_R_fn( float(X), float(X)) --> [].
%
specialize_R_fn( X+Y, X+Y) --> [].
specialize_R_fn( X-Y, X-Y) --> [].
specialize_R_fn( X*Y, X*Y) --> [].
specialize_R_fn( X/Y, X/Y) --> [].
specialize_R_fn( exp(X,Y), exp(X,Y)) --> [].
specialize_R_fn( min(X,Y), min(X,Y)) --> [].
specialize_R_fn( max(X,Y), max(X,Y)) --> [].
/**/
%
% An absolute eps is of course not very meaningful.
% An eps scaled by the magnitude of the operands participating
% in the comparison is too expensive to support in Prolog on the
% other hand ...
%
%
% -eps 0 +eps
% ---------------[----|----]----------------
% < 0 > 0
% <-----------] [----------->
% =< 0
% <---------------------]
% >= 0
% [--------------------->
%
%
specialize_R_fn( X < Y, boolean) -->
{
eps( Eps, NegEps)
},
( {X==0} ->
[ Y > Eps ]
; {Y==0} ->
[ X < NegEps ]
;
[ X-Y < NegEps ]
).
specialize_R_fn( X > Y, boolean) --> specialize_R_fn( Y < X, boolean).
specialize_R_fn( X =< Y, boolean) -->
{
eps( Eps, _)
},
[ X-Y < Eps ].
specialize_R_fn( X >= Y, boolean) --> specialize_R_fn( Y =< X, boolean).
specialize_R_fn( X =:= Y, boolean) -->
{
eps( Eps, NegEps)
},
( {X==0} ->
[ Y >= NegEps, Y =< Eps ]
; {Y==0} ->
[ X >= NegEps, X =< Eps ]
;
[
Diff is X-Y,
Diff =< Eps,
Diff >= NegEps
]
).
specialize_R_fn( X =\= Y, boolean) -->
{
eps( Eps, NegEps)
},
[
Diff is X-Y,
( Diff < NegEps -> true ; Diff > Eps )
].
/**/
/**
%
% b30427, pp.218
%
specialize_R_fn( X > Y, boolean) --> specialize_R_fn( Y < X, boolean).
specialize_R_fn( X < Y, boolean) -->
[ scaled_eps(X,Y,E), Y-X > E ].
specialize_R_fn( X >= Y, boolean) --> specialize_R_fn( Y =< X, boolean).
specialize_R_fn( X =< Y, boolean) -->
[ scaled_eps(X,Y,E), X-Y =< E ]. % \+ >
specialize_R_fn( X =:= Y, boolean) -->
[ scaled_eps(X,Y,E), abs(X-Y) =< E ].
specialize_R_fn( X =\= Y, boolean) -->
[ scaled_eps(X,Y,E), abs(X-Y) > E ].
scaled_eps( X, Y, Eps) :-
exponent( X, Ex),
exponent( Y, Ey),
arith_eps( E),
Max is max(Ex,Ey),
( Max < 0 ->
Eps is E/(1<<Max)
;
Eps is E*(1<<Max)
).
exponent( X, E) :-
A is abs(X),
float_rat( A, N, D),
E is msb(N+1)-msb(D).
**/
% ----------------------------------------------------------------------
linearize( Term, Res, Linear) :-
linearize( Term, Res, Vs,[], Lin, []),
keysort( Vs, Vss),
( Vss = [], Linear = Lin
; Vss = [V|Vt], join_vars( Vt, V, Linear, Lin)
).
%
% flatten the evaluation, collect variables, shared by Q,R,...
%
linearize( X, R, [X-R|Vs],Vs) --> {var(X)}, !, [ ].
linearize( X, R, Vs,Vs) --> {integer(X)}, !, [ op_integer(R,X) ].
linearize( X, R, Vs,Vs) --> {float(X)}, !, [ op_float(R,X) ].
linearize( rat(N,D), R, Vs,Vs) --> !, [ op_rat(R,N,D) ].
linearize( Term, R, V0,V1) -->
{
functor( Term, N, A),
functor( Skeleton, N, A)
},
linearize_args( A, Term, Skeleton, V0,V1), [ apply(R,Skeleton) ].
linearize_args( 0, _, _, Vs,Vs) --> [].
linearize_args( N, T, S, V0,V2) -->
{
arg( N, T, Arg),
arg( N, S, Res),
N1 is N-1
},
linearize( Arg, Res, V0,V1),
linearize_args( N1, T, S, V1,V2).
join_vars( [], Y-Ry) --> [ op_var(Ry,Y) ].
join_vars( [X-Rx|Xs], Y-Ry) -->
( {X==Y} ->
{Rx=Ry},
join_vars( Xs, Y-Ry)
;
[ op_var(Ry,Y) ],
join_vars( Xs, X-Rx)
).
% ---------------------------------- runtime system ---------------------------
%
% C candidate
%
limit_encoding_length( 0,D, _, 0,D) :- !. % msb ...
limit_encoding_length( N,D, Bits, Nl,Dl) :-
Shift is min(max(msb(abs(N)),msb(D))-Bits,
min(msb(abs(N)),msb(D))),
Shift > 0,
!,
Ns is N>>Shift,
Ds is D>>Shift,
Gcd is gcd(Ns,Ds),
Nl is Ns//Gcd,
Dl is Ds//Gcd.
limit_encoding_length( N,D, _, N,D).
%
% No longer backconvert to integer
%
% putq( 1, N, N) :- !.
putq( D, N, rat(N,D)).
getq( Exp, N,D) :- var( Exp), !,
raise_exception( instantiation_error(getq(Exp,N,D),1)).
getq( I, I,1) :- integer(I), !.
getq( F, N,D) :- float( F), !, float_rat( F, N,D).
getq( rat(N,D), N,D) :-
integer( N),
integer( D),
D > 0,
1 =:= gcd(N,D).
%
% actually just a joke to have this stuff in Q ...
%
expq( N,D, N1,D1) :- rat_float( N,D, X), F is exp(X), float_rat( F, N1,D1).
logq( N,D, N1,D1) :- rat_float( N,D, X), F is log(X), float_rat( F, N1,D1).
sinq( N,D, N1,D1) :- rat_float( N,D, X), F is sin(X), float_rat( F, N1,D1).
cosq( N,D, N1,D1) :- rat_float( N,D, X), F is cos(X), float_rat( F, N1,D1).
tanq( N,D, N1,D1) :- rat_float( N,D, X), F is tan(X), float_rat( F, N1,D1).
asinq( N,D, N1,D1) :- rat_float( N,D, X), F is asin(X), float_rat( F, N1,D1).
acosq( N,D, N1,D1) :- rat_float( N,D, X), F is acos(X), float_rat( F, N1,D1).
atanq( N,D, N1,D1) :- rat_float( N,D, X), F is atan(X), float_rat( F, N1,D1).
%
% for integer powers we can do it in Q
%
expq( Nx,Dx, Ny,Dy, N,D) :-
( Dy =:= 1 ->
( Ny >= 0 ->
powq( Ny, Nx,Dx, 1,1, N,D)
;
Nabs is -Ny,
powq( Nabs, Nx,Dx, 1,1, N1,D1),
( N1 < 0 ->
N is -D1, D is -N1
;
N = D1, D = N1
)
)
;
rat_float( Nx,Dx, Fx),
rat_float( Ny,Dy, Fy),
F is exp(Fx,Fy),
float_rat( F, N, D)
).
%
% positive integer powers of rational
%
powq( 0, _, _, Nt,Dt, Nt,Dt) :- !.
powq( 1, Nx,Dx, Nt,Dt, Nr,Dr) :- !, mulq( Nx,Dx, Nt,Dt, Nr,Dr).
powq( N, Nx,Dx, Nt,Dt, Nr,Dr) :-
N1 is N >> 1,
( N /\ 1 =:= 0 ->
Nt1 = Nt, Dt1 = Dt
;
mulq( Nx,Dx, Nt,Dt, Nt1,Dt1)
),
mulq( Nx,Dx, Nx,Dx, Nxx,Dxx),
powq( N1, Nxx,Dxx, Nt1,Dt1, Nr,Dr).
/*
%
% the choicepoint ruins the party ...
%
mulq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Db),
( Gcd1 =:= 1 -> Na1=Na,Db1=Db; Na1 is Na//Gcd1,Db1 is Db//Gcd1 ),
Gcd2 is gcd(Nb,Da),
( Gcd2 =:= 1 -> Nb1=Nb,Da1=Da; Nb1 is Nb//Gcd2,Da1 is Da//Gcd2 ),
Nc is Na1 * Nb1,
Dc is Da1 * Db1.
*/
mulq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Db),
Na1 is Na//Gcd1,
Db1 is Db//Gcd1,
Gcd2 is gcd(Nb,Da),
Nb1 is Nb//Gcd2,
Da1 is Da//Gcd2,
Nc is Na1 * Nb1,
Dc is Da1 * Db1.
/*
divq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Nb),
( Gcd1 =:= 1 -> Na1=Na,Nb1=Nb; Na1 is Na//Gcd1,Nb1 is Nb//Gcd1 ),
Gcd2 is gcd(Da,Db),
( Gcd2 =:= 1 -> Da1=Da,Db1=Db; Da1 is Da//Gcd2,Db1 is Db//Gcd2 ),
( Nb1 < 0 -> % keep denom positive !!!
Nc is -(Na1 * Db1),
Dc is Da1 * (-Nb1)
;
Nc is Na1 * Db1,
Dc is Da1 * Nb1
).
*/
divq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Na,Nb),
Na1 is Na//Gcd1,
Nb1 is Nb//Gcd1,
Gcd2 is gcd(Da,Db),
Da1 is Da//Gcd2,
Db1 is Db//Gcd2,
( Nb1 < 0 -> % keep denom positive !!!
Nc is -(Na1 * Db1),
Dc is Da1 * (-Nb1)
;
Nc is Na1 * Db1,
Dc is Da1 * Nb1
).
%
% divq_11( Nb,Db, Nc,Dc) :- divq( 1,1, Nb,Db, Nc,Dc).
%
divq_11( Nb,Db, Nc,Dc) :-
( Nb < 0 -> % keep denom positive !!!
Nc is -Db,
Dc is -Nb
;
Nc is Db,
Dc is Nb
).
'divq_-11'( Nb,Db, Nc,Dc) :-
( Nb < 0 -> % keep denom positive !!!
Nc is Db,
Dc is -Nb
;
Nc is -Db,
Dc is Nb
).
/*
addq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
( Gcd1 =:= 1 -> % This is the case (for random input) with
% probability 6/(pi**2).
Nc is Na*Db + Nb*Da,
Dc is Da*Db
;
T is Na*(Db//Gcd1) + Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2)
).
*/
addq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
T is Na*(Db//Gcd1) + Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2).
/*
subq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
( Gcd1 =:= 1 -> % This is the case (for random input) with
% probability 6/(pi**2).
Nc is Na*Db - Nb*Da,
Dc is Da*Db
;
T is Na*(Db//Gcd1) - Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2)
).
*/
subq( Na,Da, Nb,Db, Nc,Dc) :-
Gcd1 is gcd(Da,Db),
T is Na*(Db//Gcd1) - Nb*(Da//Gcd1),
Gcd2 is gcd(T,Gcd1),
Nc is T//Gcd2,
Dc is (Da//Gcd1) * (Db//Gcd2).
comq( Na,Da, Nb,Db, S) :- % todo: avoid multiplication by looking a signs first !!!
Xa is Na * Db,
Xb is Nb * Da,
compare( S, Xa, Xb).
minq( Na,Da, Nb,Db, N,D) :-
comq( Na,Da, Nb,Db, Rel),
( Rel = =, N=Na, D=Da
; Rel = <, N=Na, D=Da
; Rel = >, N=Nb, D=Db
).
maxq( Na,Da, Nb,Db, N,D) :-
comq( Na,Da, Nb,Db, Rel),
( Rel = =, N=Nb, D=Db
; Rel = <, N=Nb, D=Db
; Rel = >, N=Na, D=Da
).
signumq( N,_, S,1) :-
compare( Rel, N, 0),
rel2sig( Rel, S).
rel2sig( <, -1).
rel2sig( >, 1).
rel2sig( =, 0).
% -----------------------------------------------------------------------------
truncateq( N,D, R,1) :-
R is N // D.
%
% returns the greatest integral value less than or
% equal to x. This corresponds to IEEE rounding toward nega-
% tive infinity
%
floorq( N,1, N,1) :- !.
floorq( N,D, R,1) :-
( N < 0 ->
R is N // D - 1
;
R is N // D
).
%
% returns the least integral value greater than or
% equal to x. This corresponds to IEEE rounding toward posi-
% tive infinity
%
ceilingq( N,1, N,1) :- !.
ceilingq( N,D, R,1) :-
( N > 0 ->
R is N // D + 1
;
R is N // D
).
%
% rounding towards zero
%
roundq( N,D, R,1) :-
% rat_float( N,D, F), % cheating, can do that in Q
% R is integer(round(F)).
I is N//D,
subq( N,D, I,1, Rn,Rd),
Rna is abs(Rn),
( comq( Rna,Rd, 1,2, <) ->
R = I
; I >= 0 ->
R is I+1
;
R is I-1
).
% ------------------------------- rational -> float -------------------------------
%
% The problem here is that SICStus converts BIG fractions N/D into +-nan
% if it does not fit into a float
%
% | ?- X is msb(integer(1.0e+308)).
% X = 1023
%
rat_float( Nx,Dx, F) :-
limit_encoding_length( Nx,Dx, 1023, Nxl,Dxl),
F is Nxl / Dxl.
% ------------------------------- float -> rational -------------------------------
float_rat( F, N, D) :-
float_rat( 100, F, F, 1,0,0,1, N0,D0), % at most 100 iterations
( D0 < 0 -> % sign normalization
D is -D0,
N is -N0
;
D = D0,
N = N0
).
float_rat( 0, _, _, Na,_,Da,_, Na,Da) :- !.
float_rat( _, _, X, Na,_,Da,_, Na,Da) :-
0.0 =:= abs(X-Na/Da),
!.
float_rat( N, F, X, Na,Nb,Da,Db, Nar,Dar) :-
I is integer(F),
( I =:= F -> % guard against zero division
Nar is Na*I+Nb, % 1.0 -> 1/1 and not 0/1 (first iter.) !!!
Dar is Da*I+Db
;
Na1 is Na*I+Nb,
Da1 is Da*I+Db,
F1 is 1/(F-I),
N1 is N-1,
float_rat( N1, F1, X, Na1,Na,Da1,Da, Nar,Dar)
).

128
CLPQR/clpr/bb.pl
View File

@ -1,128 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: bb.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
bb_inf( Is, Term, Inf) :-
bb_inf( Is, Term, Inf, _, 0.001).
bb_inf( Is, Term, Inf, Vertex, Eps) :-
nf( Eps, ENf),
nf_constant( ENf, EpsN),
wait_linear( Term, Nf, bb_inf_internal(Is,Nf,EpsN,Inf,Vertex)).
% ---------------------------------------------------------------------
bb_inf_internal( Is, Lin, Eps, _, _) :-
bb_intern( Is, IsNf),
( bb_delete( incumbent, _) -> true ; true ),
repair( Lin, LinR), % bb_narrow ...
deref( LinR, Lind),
var_with_def_assign( Dep, Lind),
determine_active_dec( Lind),
bb_loop( Dep, IsNf, Eps),
fail.
bb_inf_internal( _, _, _, Inf, Vertex) :-
bb_delete( incumbent, InfVal-Vertex), % GC
{ Inf =:= InfVal }.
bb_loop( Opt, Is, Eps) :-
bb_reoptimize( Opt, Inf),
bb_better_bound( Inf),
vertex_value( Is, Ivs),
( bb_first_nonint( Is, Ivs, Eps, Viol, Floor, Ceiling) ->
bb_branch( Viol, Floor, Ceiling),
bb_loop( Opt, Is, Eps)
;
round_values( Ivs, RoundVertex),
% print( incumbent( Inf-RoundVertex)), nl,
bb_put( incumbent, Inf-RoundVertex)
).
%
% added ineqs may have led to binding
%
bb_reoptimize( Obj, Inf) :- var( Obj), iterate_dec( Obj, Inf).
bb_reoptimize( Obj, Inf) :- nonvar( Obj), Inf = Obj.
bb_better_bound( Inf) :-
bb_get( incumbent, Inc-_),
!,
arith_eval( Inf < Inc).
bb_better_bound( _).
bb_branch( V, U, _) :- { V =< U }.
bb_branch( V, _, L) :- { V >= L }.
vertex_value( [], []).
vertex_value( [X|Xs], [V|Vs]) :-
rhs_value( X, V),
vertex_value( Xs, Vs).
rhs_value( Xn, Value) :- nonvar(Xn), Value=Xn.
rhs_value( Xn, Value) :- var(Xn),
deref_var( Xn, Xd),
decompose( Xd, _, R, I),
arith_eval( R+I, Value).
%
% Need only one as we branch on the first anyway ...
%
bb_first_nonint( [I|Is], [Rhs|Rhss], Eps, Viol, F, C) :-
( arith_eval( floor(Rhs), Floor),
arith_eval( ceiling(Rhs), Ceiling),
arith_eval(min(Rhs-Floor,Ceiling-Rhs) > Eps) ->
Viol = I,
F = Floor,
C = Ceiling
;
bb_first_nonint( Is, Rhss, Eps, Viol, F, C)
).
round_values( [], []).
round_values( [X|Xs], [Y|Ys]) :-
arith_eval( round(X), Y),
round_values( Xs, Ys).
bb_intern( [], []).
bb_intern( [X|Xs], [Xi|Xis]) :-
nf( X, Xnf),
bb_intern( Xnf, Xi, X),
bb_intern( Xs, Xis).
%
% allow more general expressions and conditions? integral(Exp) ???
%
bb_intern( [], X, _) :- !, arith_eval( 0, X).
bb_intern( [v(I,[])], X, _) :- !, X=I.
bb_intern( [v(One,[X^1])], X, _) :-
arith_eval(One=:=1),
!,
get_atts( X, [type(T),strictness(S)]),
bb_narrow( T, S, X).
bb_intern( _, _, Term) :-
raise_exception( instantiation_error(bb_inf(Term,_,_),1)).
bb_narrow( t_l(L), S, V) :-
S /\ 2'10 =\= 0,
!,
arith_eval( floor(1+L), B),
{ V >= B }.
bb_narrow( t_u(U), S, V) :-
S /\ 2'01 =\= 0,
!,
arith_eval( ceiling(U-1), B),
{ V =< B }.
bb_narrow( t_lu(L,U), S, V) :- !,
bb_narrow( t_l(L), S, V),
bb_narrow( t_u(U), S, V).
bb_narrow( _, _, _).

1256
CLPQR/clpr/bv.pl
View File

File diff suppressed because it is too large Load Diff

86
CLPQR/clpr/compenv.pl
View File

@ -1,86 +0,0 @@
% Copyright (C) 1994, Swedish Institute of Computer Science.
% Provides compile time environment for fcompiling clpq/clpr
:- meta_predicate nfq:geler(?,:).
:- meta_predicate nfr:geler(?,:).
:- meta_predicate clpq:wait_linear(?,?,:).
:- meta_predicate clpr:wait_linear(?,?,:).
%
% Don't report export of private predicates from clpq
%
:- multifile
user:portray_message/2.
:- dynamic
user:portray_message/2.
%
user:portray_message( warning, import(_,_,From,private)) :-
clpqr( From).
clpqr( clpq).
clpqr( clpr).
env_fcompile( Name, Arith) :-
compile_time_env( Name, Arith, Module),
fcompile( Module:Name).
compile_time_env(File, Arith, Module) :-
file_mod(Arith, File, Module),
load_expansions(Module, Arith).
load_expansions(user, _).
load_expansions(arith_q, _).
load_expansions(arith_r, _).
load_expansions(classq, _) :- [class]. % atts
load_expansions(classr, _) :- [class]. % atts
load_expansions(geler_q, _) :- [geler]. % atts
load_expansions(geler_r, _) :- [geler]. % atts
load_expansions(nfq, Arith) :-
nfq:[Arith]. % macros
load_expansions(nfr, Arith) :-
nfr:[Arith]. % macros
load_expansions(clpr, Arith) :-
clpr:[Arith], % macros
clpr:[itf3], % atts
clpr:[store]. % macros
load_expansions(clpq, Arith) :-
clpq:[Arith], % macros
clpq:[itf3], % atts
clpq:[store]. % macros
file_mod(arith_q, arith, arith_q).
file_mod(arith_r, arith, arith_r).
file_mod(arith_q, arith_q, arith_q).
file_mod(arith_r, arith_r, arith_r).
file_mod(arith_q, bb, clpq).
file_mod(arith_r, bb, clpr).
file_mod(arith_q, bv, clpq).
file_mod(arith_r, bv, clpr).
file_mod(arith_q, class, classq).
file_mod(arith_r, class, classr).
file_mod(_, compenv, user).
file_mod(arith_q, dump, clpq).
file_mod(arith_r, dump, clpr).
file_mod(arith_q, fourmotz, clpq).
file_mod(arith_r, fourmotz, clpr).
file_mod(arith_q, geler, geler_q).
file_mod(arith_r, geler, geler_r).
file_mod(arith_q, ineq, clpq).
file_mod(arith_r, ineq, clpr).
file_mod(arith_q, itf3, clpq).
file_mod(arith_r, itf3, clpr).
file_mod(arith_q, nf, nfq).
file_mod(arith_r, nf, nfr).
file_mod(arith_q, nfq, nfq).
file_mod(arith_r, nfr, nfr).
file_mod(arith_q, ordering, classq).
file_mod(arith_r, ordering, classr).
file_mod(arith_q, project, clpq).
file_mod(arith_r, project, clpr).
file_mod(arith_q, redund, clpq).
file_mod(arith_r, redund, clpr).
file_mod(arith_q, store, clpq).
file_mod(arith_r, store, clpr).

147
CLPQR/clpr/dump.pl
View File

@ -1,147 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: dump.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
dump( +Target, ?NewVars, ?CodedAnswer)
where Target and NewVars are lists of variables of equal length and
CodedAnswer is the term representation of the projection of constraints
onto the target variables where the target variables are replaced by
the corresponding variables from NewVars.
*/
:- use_module( library(terms), [term_variables/2]).
:- use_module( library(assoc),
[
empty_assoc/1,
get_assoc/3,
put_assoc/4,
assoc_to_list/2
]).
dump( Target, NewVars, Constraints) :-
(
( proper_varlist( Target) ->
true
;
raise_exception(instantiation_error(dump(Target,NewVars,Constraints),1))
),
ordering( Target),
related_linear_vars( Target, All),
nonlin_crux( All, Nonlin),
project_attributes( Target, All),
related_linear_vars( Target, Again), % project drops/adds vars
all_attribute_goals( Again, Gs, Nonlin),
empty_assoc( D0),
mapping( Target, NewVars, D0,D1), % late (AVL suffers from put_atts)
copy( Gs, Copy, D1,_), % strip constraints
bb_put( copy, NewVars/Copy),
fail % undo projection
;
bb_delete( copy, NewVars/Constraints) % garbage collect
).
proper_varlist( X) :- var( X), !, fail.
proper_varlist( []).
proper_varlist( [X|Xs]) :-
var( X),
proper_varlist( Xs).
related_linear_vars( Vs, All) :-
empty_assoc( S0),
related_linear_sys( Vs, S0,Sys),
related_linear_vars( Sys, All, []).
related_linear_sys( [], S0,L0) :- assoc_to_list( S0, L0).
related_linear_sys( [V|Vs], S0,S2) :-
( get_atts( V, class(C)) ->
put_assoc( C, S0, C, S1)
;
S1 = S0
),
related_linear_sys( Vs, S1,S2).
related_linear_vars( []) --> [].
related_linear_vars( [S-_|Ss]) -->
{
class_allvars( S, Otl)
},
cpvars( Otl),
related_linear_vars( Ss).
cpvars( Xs) --> {var(Xs)}, !.
cpvars( [X|Xs]) -->
( {var(X)} -> [X] ; [] ),
cpvars( Xs).
nonlin_crux( All, Gss) :-
collect_nonlin( All, Gs, []), % destructive
this_linear_solver( Solver),
nonlin_strip( Gs, Solver, Gss).
nonlin_strip( [], _, []).
nonlin_strip( [M:What|Gs], Solver, Res) :-
( M == Solver ->
( What = {G} ->
Res = [G|Gss]
;
Res = [What|Gss]
)
;
Res = Gss
),
nonlin_strip( Gs, Solver, Gss).
all_attribute_goals( []) --> [].
all_attribute_goals( [V|Vs]) -->
dump_linear( V, toplevel),
dump_nonzero( V, toplevel),
all_attribute_goals( Vs).
mapping( [], [], D0,D0).
mapping( [T|Ts], [N|Ns], D0,D2) :-
put_assoc( T, D0, N, D1),
mapping( Ts, Ns, D1,D2).
copy( Term, Copy, D0,D1) :- var( Term),
( get_assoc( Term, D0, New) ->
Copy = New,
D1 = D0
;
put_assoc( Term, D0, Copy, D1)
).
copy( Term, Copy, D0,D1) :- nonvar( Term),
functor( Term, N, A),
functor( Copy, N, A),
copy( A, Term, Copy, D0,D1).
copy( 0, _, _, D0,D0) :- !.
copy( 1, T, C, D0,D1) :- !,
arg( 1, T, At1),
arg( 1, C, Ac1),
copy( At1, Ac1, D0,D1).
copy( 2, T, C, D0,D2) :- !,
arg( 1, T, At1),
arg( 1, C, Ac1),
copy( At1, Ac1, D0,D1),
arg( 2, T, At2),
arg( 2, C, Ac2),
copy( At2, Ac2, D1,D2).
copy( N, T, C, D0,D2) :-
arg( N, T, At),
arg( N, C, Ac),
copy( At, Ac, D0,D1),
N1 is N-1,
copy( N1, T, C, D1,D2).
end_of_file.

294
CLPQR/clpr/fourmotz.pl
View File

@ -1,294 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.2 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: fourmotz.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% TODO -) remove syntactic redundancy first ?!!
% -) avoid the construction of the crossproduct list
% +) consider strictness in crossproduct generation !!!
%
fm_elim( Vs, Target, Pivots) :-
prefilter( Vs, Vsf),
fm_elim_int( Vsf, Target, Pivots).
prefilter( [], []).
prefilter( [V|Vs], Res) :-
( get_atts( V, -target),
occurs( V) ->
Res = [V|Tail],
put_atts( V, keep_indep),
prefilter( Vs, Tail)
;
prefilter( Vs, Res)
).
%
% the target variables are marked with an attribute, and we get a list
% of them as an argument too
%
fm_elim_int( [], _, Pivots) :- % done
unkeep( Pivots).
fm_elim_int( Vs, Target, Pivots) :-
Vs = [_|_],
( best( Vs, Best, Rest) ->
occurences( Best, Occ),
elim_min( Best, Occ, Target, Pivots, NewPivots)
; % give up
NewPivots=Pivots, Rest = []
),
fm_elim_int( Rest, Target, NewPivots).
%
% Find the variable with the smallest netto increase on the
% size of the ineq. system after its elimination
%
best( Vs, Best, Rest) :-
findall( Delta-N, fm_cp_filter( Vs, Delta, N), Deltas),
keysort( Deltas, [_-N|_]),
select_nth( Vs, N, Best, Rest).
fm_cp_filter( Vs, Delta, N) :-
length( Vs, Len),
mem( Vs,X,Vst),
get_atts( X, [-target,lin(Lin)]),
indep( Lin, X),
occurences( X, Occ),
Occ = [_|_],
% crossproduct( Occ, New, []),
% length( New, CpLnew),
cp_card( Occ, 0,Lnew),
length( Occ, Locc),
Delta is Lnew-Locc,
length( Vst, Vstl),
N is Len-Vstl.
mem( [X|Xs], X, Xs).
mem( [_|Ys], X, Xs) :- mem( Ys, X, Xs).
select_nth( List, N, Nth, Others) :-
select_nth( List, 1,N, Nth, Others).
select_nth( [X|Xs], N,N, X, Xs) :- !.
select_nth( [Y|Ys], M,N, X, [Y|Xs]) :-
M1 is M+1,
select_nth( Ys, M1,N, X, Xs).
%
% fm_detach + reverse_pivot introduce indep t_none, which
% invalidates the invariants
%
elim_min( V, Occ, Target, Pivots, NewPivots) :-
crossproduct( Occ, New, []),
activate_crossproduct( New),
reverse_pivot( Pivots),
fm_detach( Occ),
% length( Occ, Locc), length( New, Lnew), print( fm(-Locc,+Lnew)), nl,
allvars( V, All),
redundancy_vars( All), % only for New \== []
make_target_indep( Target, NewPivots),
drop_dep( All).
%
% restore NF by reverse pivoting
%
reverse_pivot( []).
reverse_pivot( [I:D|Ps]) :-
get_atts( D, type(Dt)),
put_atts( D, -keep), % no longer
pivot( D, I, Dt),
reverse_pivot( Ps).
unkeep( []).
unkeep( [_:D|Ps]) :-
put_atts( D, -keep),
drop_dep_one( D),
unkeep( Ps).
%
% All we drop are bounds
%
fm_detach( []).
fm_detach( [V:_|Vs]) :-
detach_bounds( V),
fm_detach( Vs).
%
% Todo: maybe bulk_basis_add
%
activate_crossproduct( []).
activate_crossproduct( [lez(Strict,Lin)|News]) :-
arith_eval( 0, Z),
var_with_def_intern( t_u(Z), Var, Lin, Strict),
basis_add( Var, _),
activate_crossproduct( News).
% ------------------------------------------------------------------------------
crossproduct( []) --> [].
crossproduct( [A|As]) -->
crossproduct( As, A),
crossproduct( As).
crossproduct( [], _) --> [].
crossproduct( [B:Kb|Bs], A:Ka) -->
{
get_atts( A, [type(Ta),lin(LinA),strictness(Sa)]),
get_atts( B, [type(Tb),lin(LinB),strictness(Sb)]),
arith_eval( -Kb/Ka, K),
add_linear_f1( LinA, K, LinB, Lin)
},
( { arith_eval( K > 0) } -> % signs were opposite
{ Strict is Sa \/ Sb },
cross_lower( Ta, Tb, K, Lin, Strict),
cross_upper( Ta, Tb, K, Lin, Strict)
; % La =< A =< Ua -> -Ua =< -A =< -La
{
flip( Ta, Taf),
flip_strict( Sa, Saf),
Strict is Saf \/ Sb
},
cross_lower( Taf, Tb, K, Lin, Strict),
cross_upper( Taf, Tb, K, Lin, Strict)
),
crossproduct( Bs, A:Ka).
cross_lower( Ta, Tb, K, Lin, Strict) -->
{
lower( Ta, La),
lower( Tb, Lb),
!,
arith_eval(K*La+Lb,L),
normalize_scalar( L, Ln),
arith_eval( -1, Mone),
add_linear_f1( Lin, Mone, Ln, Lhs),
Sl is Strict >> 1 % normalize to upper bound
},
[ lez(Sl,Lhs) ].
cross_lower( _, _, _, _, _) --> [].
cross_upper( Ta, Tb, K, Lin, Strict) -->
{
upper( Ta, Ua),
upper( Tb, Ub),
!,
arith_eval(-(K*Ua+Ub),U),
normalize_scalar( U, Un),
add_linear_11( Un, Lin, Lhs),
Su is Strict /\ 2'01 % normalize to upper bound
},
[ lez(Su,Lhs) ].
cross_upper( _, _, _, _, _) --> [].
lower( t_l(L), L).
lower( t_lu(L,_), L).
lower( t_L(L), L).
lower( t_Lu(L,_), L).
lower( t_lU(L,_), L).
upper( t_u(U), U).
upper( t_lu(_,U), U).
upper( t_U(U), U).
upper( t_Lu(_,U), U).
upper( t_lU(_,U), U).
flip( t_l(X), t_u(X)).
flip( t_u(X), t_l(X)).
flip( t_lu(X,Y),t_lu(Y,X)).
flip( t_L(X), t_u(X)).
flip( t_U(X), t_l(X)).
flip( t_lU(X,Y),t_lu(Y,X)).
flip( t_Lu(X,Y),t_lu(Y,X)).
flip_strict( 2'00, 2'00).
flip_strict( 2'01, 2'10).
flip_strict( 2'10, 2'01).
flip_strict( 2'11, 2'11).
cp_card( [], Ci,Ci).
cp_card( [A|As], Ci,Co) :-
cp_card( As, A, Ci,Cii),
cp_card( As, Cii,Co).
cp_card( [], _, Ci,Ci).
cp_card( [B:Kb|Bs], A:Ka, Ci,Co) :-
get_atts( A, type(Ta)),
get_atts( B, type(Tb)),
arith_eval( -Kb/Ka, K),
( arith_eval( K > 0) -> % signs were opposite
cp_card_lower( Ta, Tb, Ci,Cii),
cp_card_upper( Ta, Tb, Cii,Ciii)
;
flip( Ta, Taf),
cp_card_lower( Taf, Tb, Ci,Cii),
cp_card_upper( Taf, Tb, Cii,Ciii)
),
cp_card( Bs, A:Ka, Ciii,Co).
cp_card_lower( Ta, Tb, Si,So) :-
lower( Ta, _),
lower( Tb, _),
!,
So is Si+1.
cp_card_lower( _, _, Si,Si).
cp_card_upper( Ta, Tb, Si,So) :-
upper( Ta, _),
upper( Tb, _),
!,
So is Si+1.
cp_card_upper( _, _, Si,Si).
% ------------------------------------------------------------------------------
occurences( V, Occ) :-
allvars( V, All),
occurences( All, V, Occ).
occurences( De, _, []) :- var( De), !.
occurences( [D|De], V, Occ) :-
( get_atts( D, [lin(Lin),type(Type)]),
occ_type_filter( Type),
nf_coeff_of( Lin, V, K) ->
Occ = [D:K|Occt],
occurences( De, V, Occt)
;
occurences( De, V, Occ)
).
occ_type_filter( t_l(_)).
occ_type_filter( t_u(_)).
occ_type_filter( t_lu(_,_)).
occ_type_filter( t_L(_)).
occ_type_filter( t_U(_)).
occ_type_filter( t_lU(_,_)).
occ_type_filter( t_Lu(_,_)).
%
% occurs( V) :- occurences( V, Occ), Occ = [_|_].
%
occurs( V) :-
allvars( V, All),
occurs( All, V).
occurs( De, _) :- var( De), !, fail.
occurs( [D|De], V) :-
( get_atts( D, [lin(Lin),type(Type)]),
occ_type_filter( Type),
nf_coeff_of( Lin, V, _) ->
true
;
occurs( De, V)
).

3
CLPQR/clpr/geler.yap
View File

@ -108,7 +108,8 @@ transg( M:G) --> !,
M:transg( G).
transg( G) --> [ G ].
run( Mutex, _) :- nonvar(Mutex).
%vsc: added ! (01/06/06)
run( Mutex, _) :- nonvar(Mutex), !.
run( Mutex, G) :- var(Mutex), Mutex=done, call( G).
:- meta_predicate geler(+,:).

273
CLPQR/clpr/itf3.pl
View File

@ -1,273 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: itf3.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface to attribute encoding and hooks
%
:- use_module( library(atts)).
:- attribute class/1, order/1, lin/1, forward/1,
type/1, strictness/1, nonzero/0,
target/0, keep_indep/0, keep/0. % project.pl
/* Moved here from store.pl to break cyclic dependencies. --Mats C. */
%
% critical impact on the backsubstitution effort
% AND precision in clp(r)
%
% nf_ordering( A, B, Rel) :-
% get_atts( A, order( Oa)),
% get_atts( B, order( Ob)),
% compare( Rel, Oa, Ob).
:- multifile
user:goal_expansion/3.
:- dynamic
user:goal_expansion/3.
%
user:goal_expansion( nf_ordering(A,B,Rel), Module, Exp) :-
clpqr( Module),
Exp = (
get_atts( A, order(Oa)),
get_atts( B, order(Ob)),
compare( Rel, Oa, Ob)
).
user:goal_expansion( decompose(Lin,H,R,I), Module, Lin=[I,R|H]) :-
clpqr( Module).
clpqr( clpq).
clpqr( clpr).
/* End of code from store.pl */
%
% Parametrize the answer presentation mechanism
% (toplevel,compiler/debugger ...)
%
:- dynamic presentation_context/1.
presentation_context( Old, New) :-
clause( presentation_context(Current), _),
!,
Current = Old,
retractall( presentation_context(_)),
assert( presentation_context( New)).
presentation_context( toplevel, New) :- % default
assert( presentation_context( New)).
%
% attribute_goal( V, V:Atts) :- get_atts( V, Atts).
%
attribute_goal( V, Goal) :-
presentation_context( Cont, Cont),
dump_linear( V, Cont, Goals, Gtail),
dump_nonzero( V, Cont, Gtail, []),
l2wrapped( Goals, Goal).
l2wrapped( [], true).
l2wrapped( [X|Xs], Conj) :-
( Xs = [], wrap( X, Conj)
; Xs = [_|_], wrap( X, Xw),
Conj = (Xw,Xc),
l2wrapped( Xs, Xc)
).
%
% Tests should be pulled out of the loop ...
%
wrap( C, W) :-
prolog_flag(typein_module, Module),
this_linear_solver( Solver),
( Module == Solver ->
W = {C}
; predicate_property( Module:{_}, imported_from(Solver)) ->
W = {C}
;
W = Solver:{C}
).
dump_linear( V, Context) -->
{
get_atts( V, [lin(Lin),type(Type)]),
!,
decompose( Lin, H, _, I)
},
%
% This happens if not all target variables can be made independend
% Example: examples/option.pl:
% | ?- go2(S,W).
%
% W = 21/4,
% S>=0,
% S<50 ? ;
%
% W>5,
% S=221/4-W, this line would be missing !!!
% W=<21/4
%
( { Type=t_none ; get_atts( V, -target) } -> [] ; dump_v( Context, t_none, V, I, H) ),
%
( {Type=t_none, get_atts( V, -target) } -> % nonzero produces such
[]
;
dump_v( Context, Type, V, I, H)
).
dump_linear( _, _) --> [].
dump_v( toplevel, Type, V, I, H) --> dump_var( Type, V, I, H).
dump_v( compiler, Type, V, I, H) --> compiler_dump_var( Type, V, I, H).
dump_nonzero( V, Cont) -->
{
get_atts( V, [nonzero,lin(Lin)]),
!,
decompose( Lin, H, _, I)
},
dump_nz( Cont, V, H, I).
dump_nonzero( _, _) --> [].
dump_nz( toplevel, V, H, I) --> dump_nz( V, H, I).
dump_nz( compiler, V, H, I) --> compiler_dump_nz( V, H, I).
numbers_only( Y, _) :- var(Y), !.
numbers_only( Y, _) :- arith_normalize( Y, Y), !.
numbers_only( Y, X) :-
this_linear_solver( Solver),
( Solver==clpr ->
What = 'a real number'
; Solver==clpq ->
What = 'a rational number'
),
raise_exception( type_error(X=Y,2,What,Y)).
verify_attributes( X, _, []) :-
get_atts(X, [-class(_),-order(_),-lin(_),-forward(_),-type(_),-strictness(_),
-nonzero]),
!.
verify_attributes( X, Y, []) :-
get_atts( X, forward(F)),
!,
fwd_deref( F, Y).
verify_attributes( X, Y, Later) :-
numbers_only( Y, X),
put_atts( X, forward(Y)),
verify_nonzero( X, Y),
verify_type( X, Y, Later, []),
verify_lin( X, Y).
fwd_deref( X, Y) :- nonvar(X), X=Y.
fwd_deref( X, Y) :- var(X),
( get_atts( X, forward(F)) ->
fwd_deref( F, Y)
;
X = Y
).
verify_nonzero( X, Y) :-
get_atts( X, nonzero),
!,
( var(Y) ->
put_atts( Y, nonzero)
;
arith_eval( Y =\= 0)
).
verify_nonzero( _, _).
verify_type( X, Y) -->
{
get_atts( X, [type(Type),strictness(Strict)])
},
!,
verify_type( Y, Type, Strict).
verify_type( _, _) --> [].
verify_type( Y, TypeX, StrictX) --> {var(Y)}, !,
verify_type_var( TypeX, Y, StrictX).
verify_type( Y, TypeX, StrictX) -->
{
verify_type_nonvar( TypeX, Y, StrictX)
}.
verify_type_nonvar( t_none, _, _).
verify_type_nonvar( t_l(L), Value, S) :- lb( S, L, Value).
verify_type_nonvar( t_u(U), Value, S) :- ub( S, U, Value).
verify_type_nonvar( t_lu(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
verify_type_nonvar( t_L(L), Value, S) :- lb( S, L, Value).
verify_type_nonvar( t_U(U), Value, S) :- ub( S, U, Value).
verify_type_nonvar( t_Lu(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
verify_type_nonvar( t_lU(L,U), Value, S) :- lb( S, L, Value), ub( S, U, Value).
lb( S, L, V) :- S /\ 2'10 =:= 0, !, arith_eval( L =< V).
lb( _, L, V) :- arith_eval( L < V).
ub( S, U, V) :- S /\ 2'01 =:= 0, !, arith_eval( V =< U).
ub( _, U, V) :- arith_eval( V < U).
%
% Running some goals after X=Y simplifies the coding. It should be possible
% to run the goals here and taking care not to put_atts/2 on X ...
%
verify_type_var( t_none, _, _) --> [].
verify_type_var( t_l(L), Y, S) --> llb( S, L, Y).
verify_type_var( t_u(U), Y, S) --> lub( S, U, Y).
verify_type_var( t_lu(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
verify_type_var( t_L(L), Y, S) --> llb( S, L, Y).
verify_type_var( t_U(U), Y, S) --> lub( S, U, Y).
verify_type_var( t_Lu(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
verify_type_var( t_lU(L,U), Y, S) --> llb( S, L, Y), lub( S, U, Y).
llb( S, L, V) --> {S /\ 2'10 =:= 0}, !, [ {L =< V} ].
llb( _, L, V) --> [ {L < V} ].
lub( S, U, V) --> {S /\ 2'01 =:= 0}, !, [ {V =< U} ].
lub( _, U, V) --> [ {V < U} ].
%
% We used to drop X from the class/basis to avoid trouble with subsequent
% put_atts/2 on X. Now we could let these dead but harmless updates happen.
% In R however, exported bindings might conflict, e.g. 0 \== 0.0
%
% If X is indep and we do _not_ solve for it, we are in deep shit
% because the ordering is violated.
%
verify_lin( X, Y) :-
get_atts( X, [class(Class),lin(LinX)]),
!,
( indep( LinX, X) ->
detach_bounds( X), % if there were bounds, they are requeued already
class_drop( Class, X),
nf( X-Y, Lin),
deref( Lin, Lind),
( nf_coeff_of( Lind, X, _) ->
solve_x( Lind, X)
;
solve( Lind)
)
;
class_drop( Class, X),
nf( X-Y, Lin),
deref( Lin, Lind),
solve( Lind)
).
verify_lin( _, _).

834
CLPQR/clpr/nf.pl
View File

@ -1,834 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: nf.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module( library(terms), [term_variables/2]).
:- use_module( geler).
% -------------------------------------------------------------------------
{ Rel } :- var( Rel), !, raise_exception(instantiation_error({Rel},1)).
{ R,Rs } :- !, {R}, {Rs}.
{ R;Rs } :- !, ({R} ; {Rs}). % for entailment checking
{ L < R } :- !, nf( L-R, Nf), submit_lt( Nf).
{ L > R } :- !, nf( R-L, Nf), submit_lt( Nf).
{ L =< R } :- !, nf( L-R, Nf), submit_le( Nf).
{ <=(L,R) } :- !, nf( L-R, Nf), submit_le( Nf).
{ L >= R } :- !, nf( R-L, Nf), submit_le( Nf).
{ L =\= R } :- !, nf( L-R, Nf), submit_ne( Nf).
{ L =:= R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ L = R } :- !, nf( L-R, Nf), submit_eq( Nf).
{ Rel } :- raise_exception( type_error({Rel},1,'a constraint',Rel)).
%
% s -> c = ~s v c = ~(s /\ ~c)
% where s is the store and c is the constraint for which
% we want to know whether it is entailed.
%
entailed( C) :-
negate( C, Cn),
\+ { Cn }.
negate( Rel, _) :- var( Rel), !, raise_exception(instantiation_error(entailed(Rel),1)).
negate( (A,B), (Na;Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( (A;B), (Na,Nb)) :- !, negate( A, Na), negate( B, Nb).
negate( A<B, A>=B) :- !.
negate( A>B, A=<B) :- !.
negate( A=<B, A>B) :- !.
negate( A>=B, A<B) :- !.
negate( A=:=B, A=\=B) :- !.
negate( A=B, A=\=B) :- !.
negate( A=\=B, A=:=B) :- !.
negate( Rel, _) :- raise_exception( type_error(entailed(Rel),1,'a constraint',Rel)).
/*
Cases: a) Nf=[]
b) Nf=[A]
b1) A=k
b2) invertible(A)
b3) linear -> A=0
b4) nonlinear -> geler
c) Nf=[A,B|Rest]
c1) A=k
c11) B=X^+-1, Rest=[] -> B=
c12) invertible(A,B)
c13) linear(B|Rest)
c14) geler
c2) linear(Nf)
c3) nonlinear -> geler
*/
submit_eq( []). % trivial success
submit_eq( [T|Ts]) :-
submit_eq( Ts, T).
submit_eq( [], A) :- submit_eq_b( A).
submit_eq( [B|Bs], A) :- submit_eq_c( A, B, Bs).
submit_eq_b( v(_,[])) :- !, fail. % b1: trivial failure
submit_eq_b( v(_,[X^P])) :- % b2,b3: n*x^p=0 -> x=0
var( X),
P > 0,
!,
arith_eval( 0, Z),
export_binding( X, Z).
submit_eq_b( v(_,[NL^1])) :- % b2
nonvar( NL),
arith_eval( 0, Z),
nl_invertible( NL, X, Z, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_b( Term) :- % b4
term_variables( Term, Vs),
geler( Vs, resubmit_eq([Term])).
submit_eq_c( v(I,[]), B, Rest) :- !,
submit_eq_c1( Rest, B, I).
submit_eq_c( A, B, Rest) :- % c2
A=v(_,[X^1]), var(X),
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
Hom = [A,B|Rest],
% 'solve_='( Hom).
nf_length( Hom, 0, Len),
log_deref( Len, Hom, [], HomD),
solve( HomD).
submit_eq_c( A, B, Rest) :- % c3
Norm = [A,B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
submit_eq_c1( [], v(K,[X^P]), I) :- % c11
var( X),
( P = 1, !, arith_eval( -I/K, Val), export_binding( X, Val)
; P = -1, !, arith_eval( -K/I, Val), export_binding( X, Val)
).
submit_eq_c1( [], v(K,[NL^P]), I) :- % c12
nonvar( NL),
( P = 1, arith_eval( -I/K, Y)
; P = -1, arith_eval( -K/I, Y)
),
nl_invertible( NL, X, Y, Inv),
!,
nf( -Inv, S),
nf_add( X, S, New),
submit_eq( New).
submit_eq_c1( Rest, B, I) :- % c13
B=v(_,[Y^1]), var(Y),
linear( Rest),
!,
% 'solve_='( [v(I,[]),B|Rest]).
Hom = [B|Rest],
nf_length( Hom, 0, Len),
normalize_scalar( I, Nonvar),
log_deref( Len, Hom, [], HomD),
add_linear_11( Nonvar, HomD, LinD),
solve( LinD).
submit_eq_c1( Rest, B, I) :- % c14
Norm = [v(I,[]),B|Rest],
term_variables( Norm, Vs),
geler( Vs, resubmit_eq(Norm)).
% -----------------------------------------------------------------------
submit_lt( []) :- fail. % trivial failure
submit_lt( [A|As]) :-
submit_lt( As, A).
submit_lt( [], v(K,P)) :- submit_lt_b( P, K).
submit_lt( [B|Bs], A) :- submit_lt_c( Bs, A, B).
submit_lt_b( [], I) :- !, arith_eval( I<0).
submit_lt_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_s_p_0( X)
;
ineq_one_s_n_0( X)
).
submit_lt_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_lt([v(K,P)])).
submit_lt_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( strict, Y, K, I).
submit_lt_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_lt(Norm))
).
submit_le( []). % trivial success
submit_le( [A|As]) :-
submit_le( As, A).
submit_le( [], v(K,P)) :- submit_le_b( P, K).
submit_le( [B|Bs], A) :- submit_le_c( Bs, A, B).
submit_le_b( [], I) :- !, arith_eval( I=<0).
submit_le_b( [X^1], K) :-
var(X),
!,
( arith_eval( K>0) ->
ineq_one_n_p_0( X)
;
ineq_one_n_n_0( X)
).
submit_le_b( P, K) :-
term_variables( P, Vs),
geler( Vs, resubmit_le([v(K,P)])).
submit_le_c( [], A, B) :-
A=v(I,[]),
B=v(K,[Y^1]), var(Y),
!,
ineq_one( nonstrict, Y, K, I).
submit_le_c( Rest, A, B) :-
Norm = [A,B|Rest],
( linear(Norm) ->
'solve_=<'( Norm)
;
term_variables( Norm, Vs),
geler( Vs, resubmit_le(Norm))
).
submit_ne( Norm1) :-
( nf_constant( Norm1, K) ->
arith_eval( K=\=0)
; linear( Norm1) ->
'solve_=\='( Norm1)
;
term_variables( Norm1, Vs),
geler( Vs, resubmit_ne(Norm1))
).
linear( []).
linear( v(_,Ps)) :- linear_ps( Ps).
linear( [A|As]) :-
linear( A),
linear( As).
linear_ps( []).
linear_ps( [V^1]) :- var( V). % excludes sin(_), ...
%
% Goal delays until Term gets linear.
% At this time, Var will be bound to the normalform of Term.
%
:- meta_predicate wait_linear( ?, ?, :).
%
wait_linear( Term, Var, Goal) :-
nf( Term, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
%
% geler clients
%
resubmit_eq( N) :-
repair( N, Norm),
submit_eq( Norm).
resubmit_lt( N) :-
repair( N, Norm),
submit_lt( Norm).
resubmit_le( N) :-
repair( N, Norm),
submit_le( Norm).
resubmit_ne( N) :-
repair( N, Norm),
submit_ne( Norm).
wait_linear_retry( Nf0, Var, Goal) :-
repair( Nf0, Nf),
( linear( Nf) ->
Var = Nf,
call( Goal)
;
term_variables( Nf, Vars),
geler( Vars, wait_linear_retry(Nf,Var,Goal))
).
% -----------------------------------------------------------------------
/*
invertible( [v(Mone,[]),v(One,[X^Px,Y^Py])], Norm) :-
Px+Py =:= 0,
abs(Px) mod 2 =:= 1, % odd powers only ...
arith_eval( 1, One),
arith_eval( -1, Mone),
!,
( Px < 0 ->
{X=\=0}
;
{Y=\=0}
),
nf( X-Y, Norm). % x=y
*/
nl_invertible( sin(X), X, Y, Res) :- arith_eval( asin(Y), Res).
nl_invertible( cos(X), X, Y, Res) :- arith_eval( acos(Y), Res).
nl_invertible( tan(X), X, Y, Res) :- arith_eval( atan(Y), Res).
nl_invertible( exp(B,C), X, A, Res) :-
( nf_constant( B, Kb) ->
arith_eval(A>0),
arith_eval(Kb>0),
arith_eval(Kb=\=1),
X = C,
arith_eval( log(A)/log(Kb), Res)
; nf_constant( C, Kc),
\+ (arith_eval(A=:=0),arith_eval(Kc=<0)),
X = B,
arith_eval( exp(A,1/Kc), Res)
).
% -----------------------------------------------------------------------
nf( X, Norm) :- var(X), !,
Norm = [v(One,[X^1])],
arith_eval( 1, One).
nf( X, Norm) :- number(X), !,
nf_number( X, Norm).
%
nf( rat(N,D), Norm) :- !,
nf_number( rat(N,D), Norm).
%
nf( #(Const), Norm) :-
monash_constant( Const, Value),
!,
( arith_eval( 1, rat(1,1)) ->
nf_number( Value, Norm) % swallows #(zero) ... ok in Q
;
arith_normalize( Value, N), % in R we want it
Norm = [v(N,[])]
).
%
nf( -A, Norm) :- !,
nf( A, An),
arith_eval( -1, K),
nf_mul_factor( v(K,[]), An, Norm).
nf( +A, Norm) :- !,
nf( A, Norm).
%
nf( A+B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_add( An, Bn, Norm).
nf( A-B, Norm) :- !,
nf( A, An),
nf( -B, Bn),
nf_add( An, Bn, Norm).
%
nf( A*B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_mul( An, Bn, Norm).
nf( A/B, Norm) :- !,
nf( A, An),
nf( B, Bn),
nf_div( Bn, An, Norm).
%
nf( Term, Norm) :-
nonlin_1( Term, Arg, Skel, Sa1),
!,
nf( Arg, An),
nf_nonlin_1( Skel, An, Sa1, Norm).
nf( Term, Norm) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
!,
nf( A1, A1n),
nf( A2, A2n),
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, Norm).
%
nf( Term, _) :-
raise_exception( type_error(nf(Term,_),1,'a numeric expression',Term)).
nf_number( N, Res) :-
nf_number( N),
arith_normalize( N, Normal),
( arith_eval( Normal=:=0) ->
Res = []
;
Res = [v(Normal,[])]
).
nf_number( N) :- number( N),
!. /* MC 980507 */
nf_number( N) :- compound( N), N=rat(_,_). % sicstus
nonlin_1( abs(X), X, abs(Y), Y).
nonlin_1( sin(X), X, sin(Y), Y).
nonlin_1( cos(X), X, cos(Y), Y).
nonlin_1( tan(X), X, tan(Y), Y).
nonlin_2( min(A,B), A,B, min(X,Y), X, Y).
nonlin_2( max(A,B), A,B, max(X,Y), X, Y).
nonlin_2( exp(A,B), A,B, exp(X,Y), X, Y).
nonlin_2( pow(A,B), A,B, exp(X,Y), X, Y). % pow->exp
nonlin_2( A^B, A,B, exp(X,Y), X, Y).
nf_nonlin_1( Skel, An, S1, Norm) :-
( nf_constant( An, S1) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
;
S1 = An,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nf_nonlin_2( Skel, A1n, A2n, S1, S2, Norm) :-
( nf_constant( A1n, S1),
nf_constant( A2n, S2) ->
nl_eval( Skel, Res),
nf_number( Res, Norm)
; Skel=exp(_,_),
nf_constant( A2n, Exp),
integerp( Exp, I) ->
nf_power( I, A1n, Norm)
;
S1 = A1n,
S2 = A2n,
arith_eval( 1, One),
Norm = [v(One,[Skel^1])]
).
nl_eval( abs(X), R) :- arith_eval( abs(X), R).
nl_eval( sin(X), R) :- arith_eval( sin(X), R).
nl_eval( cos(X), R) :- arith_eval( cos(X), R).
nl_eval( tan(X), R) :- arith_eval( tan(X), R).
%
nl_eval( min(X,Y), R) :- arith_eval( min(X,Y), R).
nl_eval( max(X,Y), R) :- arith_eval( max(X,Y), R).
nl_eval( exp(X,Y), R) :- arith_eval( exp(X,Y), R).
monash_constant( X, _) :- var(X), !, fail.
monash_constant( p, 3.14259265).
monash_constant( pi, 3.14259265).
monash_constant( e, 2.71828182).
monash_constant( zero, Eps) :- arith_eps( Eps).
%
% check if a Nf consists of just a constant
%
nf_constant( [], Z) :- arith_eval( 0, Z).
nf_constant( [v(K,[])], K).
%
% this depends on the polynf ordering, i.e. [] < [X^1] ...
%
split( [], [], Z) :- arith_eval( 0, Z).
split( [First|T], H, I) :-
( First=v(I,[]) ->
H=T
;
arith_eval( 0, I),
H = [First|T]
).
%
% runtime predicate
%
:- mode nf_add( +, +, ?).
%
nf_add( [], Bs, Bs).
nf_add( [A|As], Bs, Cs) :-
nf_add( Bs, A, As, Cs).
:- mode nf_add( +, +, +, ?).
%
nf_add( [], A, As, Cs) :- Cs = [A|As].
nf_add( [B|Bs], A, As, Cs) :-
A = v(Ka,Pa),
B = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_case( Rel, A, As, Cs, B, Bs, Ka, Kb, Pa).
:- mode nf_add_case( +, +, +, -, +, +, +, +, +).
%
nf_add_case( <, A, As, Cs, B, Bs, _, _, _) :-
Cs=[A|Rest],
nf_add( As, B, Bs, Rest).
nf_add_case( >, A, As, Cs, B, Bs, _, _, _) :-
Cs=[B|Rest],
nf_add( Bs, A, As, Rest).
nf_add_case( =, _, As, Cs, _, Bs, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
nf_add( As, Bs, Cs)
;
Cs=[v(Kc,Pa)|Rest],
nf_add( As, Bs, Rest)
).
:- mode nf_mul( +, +, -).
%
nf_mul( A, B, Res) :-
nf_length( A, 0, LenA),
nf_length( B, 0, LenB),
nf_mul_log( LenA, A, [], LenB, B, Res).
nf_mul_log( 0, As, As, _, _, []) :- !.
nf_mul_log( 1, [A|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A, R).
nf_mul_log( 2, [A1,A2|As], As, Lb, B, R) :- !,
nf_mul_factor_log( Lb, B, [], A1, A1b),
nf_mul_factor_log( Lb, B, [], A2, A2b),
nf_add( A1b, A2b, R).
nf_mul_log( N, A0, A2, Lb, B, R) :-
P is N>>1,
Q is N-P,
nf_mul_log( P, A0, A1, Lb, B, Rp),
nf_mul_log( Q, A1, A2, Lb, B, Rq),
nf_add( Rp, Rq, R).
:- mode nf_add_2( +, +, -).
%
nf_add_2( Af, Bf, Res) :- % unfold: nf_add( [Af], [Bf], Res).
Af = v(Ka,Pa),
Bf = v(Kb,Pb),
compare( Rel, Pa, Pb),
nf_add_2_case( Rel, Af, Bf, Res, Ka, Kb, Pa).
:- mode nf_add_2_case( +, +, +, -, +, +, +).
%
nf_add_2_case( <, Af, Bf, [Af,Bf], _, _, _).
nf_add_2_case( >, Af, Bf, [Bf,Af], _, _, _).
nf_add_2_case( =, _, _, Res, Ka, Kb, Pa) :-
arith_eval( Ka+Kb, Kc),
( arith_eval( Kc=:=0 ) ->
Res = []
;
Res=[v(Kc,Pa)]
).
%
% multiply with a scalar =\= 0
%
nf_mul_k( [], _, []).
nf_mul_k( [v(I,P)|Vs], K, [v(Ki,P)|Vks]) :-
arith_eval( K*I, Ki),
nf_mul_k( Vs, K, Vks).
nf_mul_factor( v(K,[]), Sum, Res) :- !, nf_mul_k( Sum, K, Res).
nf_mul_factor( F, Sum, Res) :-
nf_length( Sum, 0, Len),
nf_mul_factor_log( Len, Sum, [], F, Res).
nf_mul_factor_log( 0, As, As, _, []) :- !.
nf_mul_factor_log( 1, [A|As], As, F, [R]) :- !,
mult( A, F, R).
nf_mul_factor_log( 2, [A,B|As], As, F, Res) :- !,
mult( A, F, Af),
mult( B, F, Bf),
nf_add_2( Af, Bf, Res).
nf_mul_factor_log( N, A0, A2, F, R) :-
P is N>>1,
Q is N-P,
nf_mul_factor_log( P, A0, A1, F, Rp),
nf_mul_factor_log( Q, A1, A2, F, Rq),
nf_add( Rp, Rq, R).
mult( v(Ka,La), v(Kb,Lb), v(Kc,Lc)) :-
arith_eval( Ka*Kb, Kc),
pmerge( La, Lb, Lc).
pmerge( [], Bs, Bs).
pmerge( [A|As], Bs, Cs) :-
pmerge( Bs, A, As, Cs).
:- mode pmerge(+,+,+,-).
%
pmerge( [], A, As, Res) :- Res = [A|As].
pmerge( [B|Bs], A, As, Res) :-
A=Xa^Ka,
B=Xb^Kb,
compare( R, Xa, Xb),
pmerge_case( R, A, As, Res, B, Bs, Ka, Kb, Xa).
:- mode pmerge_case( +, +, +, -, +, +, +, +, ?).
%
pmerge_case( <, A, As, Res, B, Bs, _, _, _) :-
Res = [A|Tail],
pmerge( As, B, Bs, Tail).
pmerge_case( >, A, As, Res, B, Bs, _, _, _) :-
Res = [B|Tail],
pmerge( Bs, A, As, Tail).
pmerge_case( =, _, As, Res, _, Bs, Ka, Kb, Xa) :-
Kc is Ka+Kb,
( Kc=:=0 ->
pmerge( As, Bs, Res)
;
Res = [Xa^Kc|Tail],
pmerge( As, Bs, Tail)
).
nf_div( [], _, _) :- !, zero_division.
nf_div( [v(K,P)], Sum, Res) :- !,
arith_eval( 1/K, Ki),
mult_exp( P, -1, Pi),
nf_mul_factor( v(Ki,Pi), Sum, Res).
nf_div( D, A, [v(One,[(A/D)^1])]) :-
arith_eval( 1, One).
zero_division :- fail. % raise_exception(_) ?
mult_exp( [], _, []).
mult_exp( [X^P|Xs], K, [X^I|Tail]) :-
I is K*P,
mult_exp( Xs, K, Tail).
%
% raise to integer powers
%
% | ?- time({(1+X+Y+Z)^15=0}).
% Timing 00:00:02.610 2.610 iterative
% Timing 00:00:00.660 0.660 binomial
nf_power( N, Sum, Norm) :-
integer( N),
compare( Rel, N, 0),
( Rel = < ->
Pn is -N,
% nf_power_pos( Pn, Sum, Inorm),
binom( Sum, Pn, Inorm),
arith_eval( 1, One),
nf_div( Inorm, [v(One,[])], Norm)
; Rel = > ->
% nf_power_pos( N, Sum, Norm)
binom( Sum, N, Norm)
; Rel = = -> % 0^0 is indeterminate but we say 1
arith_eval( 1, One),
Norm = [v(One,[])]
).
%
% N>0
%
nf_power_pos( 1, Sum, Norm) :- !, Sum = Norm.
nf_power_pos( N, Sum, Norm) :-
N1 is N-1,
nf_power_pos( N1, Sum, Pn1),
nf_mul( Sum, Pn1, Norm).
%
% N>0
%
binom( Sum, 1, Power) :- !, Power = Sum.
binom( [], _, []).
binom( [A|Bs], N, Power) :-
( Bs=[] ->
nf_power_factor( A, N, Ap),
Power = [Ap]
; Bs=[_|_] ->
arith_eval( 1, One),
factor_powers( N, A, v(One,[]), Pas),
sum_powers( N, Bs, [v(One,[])], Pbs, []),
combine_powers( Pas, Pbs, 0, N, 1, [], Power)
).
combine_powers( [], [], _, _, _, Pi, Pi).
combine_powers( [A|As], [B|Bs], L, R, C, Pi, Po) :-
nf_mul( A, B, Ab),
arith_normalize( C, Cn),
nf_mul_k( Ab, Cn, Abc),
nf_add( Abc, Pi, Pii),
L1 is L+1,
R1 is R-1,
C1 is C*R//L1,
combine_powers( As, Bs, L1, R1, C1, Pii, Po).
nf_power_factor( v(K,P), N, v(Kn,Pn)) :-
arith_normalize( N, Nn),
arith_eval( exp(K,Nn), Kn),
mult_exp( P, N, Pn).
factor_powers( 0, _, Prev, [[Prev]]) :- !.
factor_powers( N, F, Prev, [[Prev]|Ps]) :-
N1 is N-1,
mult( Prev, F, Next),
factor_powers( N1, F, Next, Ps).
sum_powers( 0, _, Prev, [Prev|Lt], Lt) :- !.
sum_powers( N, S, Prev, L0, Lt) :-
N1 is N-1,
nf_mul( S, Prev, Next),
sum_powers( N1, S, Next, L0, [Prev|Lt]).
% ------------------------------------------------------------------------------
repair( Sum, Norm) :-
nf_length( Sum, 0, Len),
repair_log( Len, Sum, [], Norm).
repair_log( 0, As, As, []) :- !.
repair_log( 1, [v(Ka,Pa)|As], As, R) :- !,
repair_term( Ka, Pa, R).
repair_log( 2, [v(Ka,Pa),v(Kb,Pb)|As], As, R) :- !,
repair_term( Ka, Pa, Ar),
repair_term( Kb, Pb, Br),
nf_add( Ar, Br, R).
repair_log( N, A0, A2, R) :-
P is N>>1,
Q is N-P,
repair_log( P, A0, A1, Rp),
repair_log( Q, A1, A2, Rq),
nf_add( Rp, Rq, R).
repair_term( K, P, Norm) :-
length( P, Len),
arith_eval( 1, One),
repair_p_log( Len, P, [], Pr, [v(One,[])], Sum),
nf_mul_factor( v(K,Pr), Sum, Norm).
repair_p_log( 0, Ps, Ps, [], L0, L0) :- !.
repair_p_log( 1, [X^P|Ps], Ps, R, L0, L1) :- !,
repair_p( X, P, R, L0, L1).
repair_p_log( 2, [X^Px,Y^Py|Ps], Ps, R, L0,L2) :- !,
repair_p( X, Px, Rx, L0, L1),
repair_p( Y, Py, Ry, L1, L2),
pmerge( Rx, Ry, R).
repair_p_log( N, P0, P2, R, L0, L2) :-
P is N>>1,
Q is N-P,
repair_p_log( P, P0, P1, Rp, L0, L1),
repair_p_log( Q, P1, P2, Rq, L1, L2),
pmerge( Rp, Rq, R).
repair_p( Term, P, [Term^P], L0, L0) :- var( Term).
repair_p( Term, P, [], L0, L1) :- nonvar( Term),
repair_p_one( Term, TermN),
nf_power( P, TermN, TermNP),
nf_mul( TermNP, L0, L1).
%
% An undigested term a/b is distinguished from an
% digested one by the fact that its arguments are
% digested -> cuts after repair of args!
%
repair_p_one( Term, TermN) :-
nf_number( Term, TermN), % freq. shortcut for nf/2 case below
!.
repair_p_one( A1/A2, TermN) :-
repair( A1, A1n),
repair( A2, A2n),
!,
nf_div( A2n, A1n, TermN).
repair_p_one( Term, TermN) :-
nonlin_1( Term, Arg, Skel, Sa),
repair( Arg, An),
!,
nf_nonlin_1( Skel, An, Sa, TermN).
repair_p_one( Term, TermN) :-
nonlin_2( Term, A1,A2, Skel, Sa1, Sa2),
repair( A1, A1n),
repair( A2, A2n),
!,
nf_nonlin_2( Skel, A1n, A2n, Sa1, Sa2, TermN).
repair_p_one( Term, TermN) :-
nf( Term, TermN).
:- mode nf_length( +, +, -).
%
nf_length( [], Li, Li).
nf_length( [_|R], Li, Lo) :-
Lii is Li+1,
nf_length( R, Lii, Lo).
% ------------------------------------------------------------------------------
nf2term( [], Z) :- arith_eval( 0, Z).
nf2term( [F|Fs], T) :-
f02t( F, T0),
yfx( Fs, T0, T).
yfx( [], T0, T0).
yfx( [F|Fs], T0, TN) :-
fn2t( F, Ft, Op),
T1 =.. [Op,T0,Ft],
yfx( Fs, T1, TN).
f02t( v(K,P), T) :-
( P = [] ->
T = K
; arith_eval( K=:=1) ->
p2term( P, T)
; arith_eval( K=:= -1) ->
T = -Pt,
p2term( P, Pt)
;
T = K*Pt,
p2term( P, Pt)
).
fn2t( v(K,P), Term, Op) :-
( arith_eval( K=:=1) ->
Term = Pt, Op = +
; arith_eval( K=:= -1) ->
Term = Pt, Op = -
; arith_eval( K<0) ->
arith_eval( -K, Kf),
Term = Kf*Pt, Op = -
;
Term = K*Pt, Op = +
),
p2term( P, Pt).
p2term( [X^P|Xs], Term) :-
( Xs=[] ->
pe2term( X, Xt),
exp2term( P, Xt, Term)
; Xs=[_|_] ->
Term = Xst*Xtp,
pe2term( X, Xt),
exp2term( P, Xt, Xtp),
p2term( Xs, Xst)
).
exp2term( 1, X, X) :- !.
exp2term(-1, X, One/X) :- !, arith_eval( 1, One).
exp2term( P, X, Term) :-
arith_normalize( P, Pn),
% Term = exp(X,Pn).
Term = X^Pn.
pe2term( X, Term) :- var(X), Term = X.
pe2term( X, Term) :- nonvar(X),
X =.. [F|Args],
pe2term_args( Args, Argst),
Term =.. [F|Argst].
pe2term_args( [], []).
pe2term_args( [A|As], [T|Ts]) :-
nf2term( A, T),
pe2term_args( As, Ts).

147
CLPQR/clpr/project.pl
View File

@ -1,147 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: project.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Answer constraint projection
%
:- public project_attributes/2. % xref.pl
%
% interface predicate
%
% May be destructive (either acts on a copy or in a failure loop)
%
project_attributes( TargetVars, Cvas) :-
sort( TargetVars, Tvs), % duplicates ?
sort( Cvas, Avs), % duplicates ?
mark_target( Tvs),
project_nonlin( Tvs, Avs, NlReachable),
( Tvs == [] ->
drop_lin_atts( Avs)
;
redundancy_vars( Avs), % redundancy.pl
make_target_indep( Tvs, Pivots),
mark_target( NlReachable), % after make_indep to express priority
drop_dep( Avs),
fm_elim( Avs, Tvs, Pivots),
impose_ordering( Avs)
).
mark_target( []).
mark_target( [V|Vs]) :-
put_atts( V, target),
mark_target( Vs).
mark_keep( []).
mark_keep( [V|Vs]) :-
put_atts( V, keep),
mark_keep( Vs).
%
% Collect the pivots in reverse order
% We have to protect the target variables pivot partners
% from redundancy eliminations triggered by fm_elim,
% in order to allow for reverse pivoting.
%
make_target_indep( Ts, Ps) :- make_target_indep( Ts, [], Ps).
make_target_indep( [], Ps, Ps).
make_target_indep( [T|Ts], Ps0,Pst) :-
( get_atts( T, [lin(Lin),type(Type)]),
decompose( Lin, H, _, _),
nontarget( H, Nt) ->
Ps1 = [T:Nt|Ps0],
put_atts( Nt, keep),
pivot( T, Nt, Type)
;
Ps1 = Ps0
),
make_target_indep( Ts, Ps1,Pst).
nontarget( [V*_|Vs], Nt) :-
( get_atts( V, [-target,-keep_indep]) ->
Nt = V
;
nontarget( Vs, Nt)
).
drop_dep( Vs) :- var( Vs), !.
drop_dep( []).
drop_dep( [V|Vs]) :-
drop_dep_one( V),
drop_dep( Vs).
drop_dep_one( V) :-
get_atts( V, [lin(Lin),type(t_none),-target,-keep,-nonzero]),
\+ indep( Lin, V),
!,
put_atts( V, [-lin(_),-type(_),-class(_),-order(_),-strictness(_)]).
drop_dep_one( _).
drop_lin_atts( []).
drop_lin_atts( [V|Vs]) :-
put_atts( V, [-lin(_),-type(_),-class(_),-order(_),-strictness(_)]),
drop_lin_atts( Vs).
impose_ordering( Cvas) :-
systems( Cvas, [], Sys),
impose_ordering_sys( Sys).
impose_ordering_sys( []).
impose_ordering_sys( [S|Ss]) :-
arrangement( S, Arr), % ordering.pl
arrange( Arr, S),
impose_ordering_sys( Ss).
arrange( [], _).
arrange( Arr, S) :- Arr = [_|_],
class_allvars( S, All),
order( Arr, 1, N),
order( All, N, _),
renorm_all( All),
arrange_pivot( All).
order( Xs, N, M) :- var(Xs), !, N=M.
order( [], N, N).
order( [X|Xs], N, M) :-
( get_atts( X, order(O)),
var(O) ->
O=N,
N1 is N+1,
order( Xs, N1, M)
;
order( Xs, N, M)
).
renorm_all( Xs) :- var( Xs), !.
renorm_all( [X|Xs]) :-
( get_atts( X, lin(Lin)) ->
renormalize( Lin, New),
put_atts( X, lin(New)),
renorm_all( Xs)
;
renorm_all( Xs)
).
arrange_pivot( Xs) :- var( Xs), !.
arrange_pivot( [X|Xs]) :-
( get_atts( X, [lin(Lin),type(t_none)]),
decompose( Lin, [Y*_|_], _, _),
nf_ordering( Y, X, <) ->
pivot( X, Y, t_none),
arrange_pivot( Xs)
;
arrange_pivot( Xs)
).

157
CLPQR/clpr/redund.pl
View File

@ -1,157 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.2 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: redund.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% redundancy removal (semantic definition)
%
% done:
% +) deal with active bounds
% +) indep t_[lu] -> t_none invalidates invariants (fixed)
%
%
% O(n^2), use sort later
%
systems( [], Si, Si).
systems( [V|Vs], Si, So) :-
( var(V), get_atts( V, class(C)),
not_memq( Si, C) ->
systems( Vs, [C|Si], So)
;
systems( Vs, Si, So)
).
not_memq( [], _).
not_memq( [Y|Ys], X) :-
X \== Y,
not_memq( Ys, X).
redundancy_systems( []).
redundancy_systems( [S|Sys]) :-
class_allvars( S, All),
redundancy_vs( All),
redundancy_systems( Sys).
redundancy_vars( Vs) :- !, redundancy_vs( Vs).
redundancy_vars( Vs) :-
statistics( runtime, [Start|_]),
redundancy_vs( Vs),
statistics( runtime, [End|_]),
Duration is End-Start,
format( user_error, "% Redundancy elimination took ~d msec~n", Duration).
%
% remove redundant bounds from variables
%
redundancy_vs( Vs) :- var( Vs), !.
redundancy_vs( []).
redundancy_vs( [V|Vs]) :-
( get_atts( V, [type(Type),strictness(Strict)]),
redundant( Type, V, Strict) ->
redundancy_vs( Vs)
;
redundancy_vs( Vs)
).
redundant( t_l(L), X, Strict) :-
detach_bounds( X), % drop temporarily
negate_l( Strict, L, X),
red_t_l.
redundant( t_u(U), X, Strict) :-
detach_bounds( X),
negate_u( Strict, U, X),
red_t_u.
redundant( t_lu(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( put_atts( X, [type(t_u(U)),strictness(Su)]),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_u(U), X, Strict) -> true ; true )
; put_atts( X, [type(t_l(L)),strictness(Sl)]),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
redundant( t_L(L), X, Strict) :-
arith_eval( -L, Bound),
intro_at( X, Bound, t_none), % drop temporarily
detach_bounds( X),
negate_l( Strict, L, X),
red_t_L.
redundant( t_U(U), X, Strict) :-
arith_eval( -U, Bound),
intro_at( X, Bound, t_none), % drop temporarily
detach_bounds( X),
negate_u( Strict, U, X),
red_t_U.
redundant( t_Lu(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( arith_eval( -L, Bound),
intro_at( X, Bound, t_u(U)),
put_atts( X, strictness(Su)),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_u(U), X, Strict) -> true ; true )
; put_atts( X, [type(t_L(L)),strictness(Sl)]),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
redundant( t_lU(L,U), X, Strict) :-
strictness_parts( Strict, Sl, Su),
( put_atts( X, [type(t_U(U)),strictness(Su)]),
negate_l( Strict, L, X) ->
red_t_l,
( redundant( t_U(U), X, Strict) -> true ; true )
; arith_eval( -U, Bound),
intro_at( X, Bound, t_l(L)),
put_atts( X, strictness(Sl)),
negate_u( Strict, U, X) ->
red_t_u
;
true
).
strictness_parts( Strict, Lower, Upper) :-
Lower is Strict /\ 2'10,
Upper is Strict /\ 2'01.
%
% encapsulation via \+ (unfolded to avoid metacall)
%
/**/
negate_l( 2'00, L, X) :- { L > X }, !, fail.
negate_l( 2'01, L, X) :- { L > X }, !, fail.
negate_l( 2'10, L, X) :- { L >= X }, !, fail.
negate_l( 2'11, L, X) :- { L >= X }, !, fail.
negate_l( _, _, _).
negate_u( 2'00, U, X) :- { U < X }, !, fail.
negate_u( 2'01, U, X) :- { U =< X }, !, fail.
negate_u( 2'10, U, X) :- { U < X }, !, fail.
negate_u( 2'11, U, X) :- { U =< X }, !, fail.
negate_u( _, _, _).
/**/
%
% profiling
%
red_t_l.
red_t_u.
red_t_L.
red_t_U.

279
CLPQR/clpr/store.pl
View File

@ -1,279 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: store.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% All constants to canonical rep.
%
normalize_scalar( S, [N,Z]) :-
arith_normalize( S, N),
arith_eval( 0, Z).
renormalize( List, Lin) :-
decompose( List, Hom, R, I),
length( Hom, Len),
renormalize_log( Len, Hom, [], Lin0),
add_linear_11( [I,R], Lin0, Lin).
renormalize_log( 1, [Term|Xs], Xs, Lin) :- !,
Term = X*_,
renormalize_log_one( X, Term, Lin).
renormalize_log( 2, [A,B|Xs], Xs, Lin) :- !,
A = X*_,
B = Y*_,
renormalize_log_one( X, A, LinA),
renormalize_log_one( Y, B, LinB),
add_linear_11( LinA, LinB, Lin).
renormalize_log( N, L0, L2, Lin) :-
P is N>>1,
Q is N-P,
renormalize_log( P, L0, L1, Lp),
renormalize_log( Q, L1, L2, Lq),
add_linear_11( Lp, Lq, Lin).
renormalize_log_one( X, Term, Res) :- var(X),
arith_eval( 0, Z),
Res = [Z,Z,Term].
renormalize_log_one( X, Term, Res) :- nonvar(X),
Term = X*K,
arith_eval( X*K, Xk),
normalize_scalar( Xk, Res).
% ----------------------------- sparse vector stuff ---------------------------- %
add_linear_ff( LinA, Ka, LinB, Kb, LinC) :-
decompose( LinA, Ha, Ra, Ia),
decompose( LinB, Hb, Rb, Ib),
decompose( LinC, Hc, Rc, Ic),
arith_eval( Ia*Ka+Ib*Kb, Ic),
arith_eval( Ra*Ka+Rb*Kb, Rc),
add_linear_ffh( Ha, Ka, Hb, Kb, Hc).
add_linear_ffh( [], _, Ys, Kb, Zs) :- mult_hom( Ys, Kb, Zs).
add_linear_ffh( [X*Kx|Xs], Ka, Ys, Kb, Zs) :-
add_linear_ffh( Ys, X, Kx, Xs, Zs, Ka, Kb).
add_linear_ffh( [], X, Kx, Xs, Zs, Ka, _) :- mult_hom( [X*Kx|Xs], Ka, Zs).
add_linear_ffh( [Y*Ky|Ys], X, Kx, Xs, Zs, Ka, Kb) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx*Ka+Ky*Kb, Kz),
( arith_eval(Kz=:=0) ->
add_linear_ffh( Xs, Ka, Ys, Kb, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_ffh( Xs, Ka, Ys, Kb, Ztail)
)
; Rel = <, Zs = [X*Kz|Ztail],
arith_eval( Kx*Ka, Kz),
add_linear_ffh( Xs, Y, Ky, Ys, Ztail, Kb, Ka)
; Rel = >, Zs = [Y*Kz|Ztail],
arith_eval( Ky*Kb, Kz),
add_linear_ffh( Ys, X, Kx, Xs, Ztail, Ka, Kb)
).
add_linear_f1( LinA, Ka, LinB, LinC) :-
decompose( LinA, Ha, Ra, Ia),
decompose( LinB, Hb, Rb, Ib),
decompose( LinC, Hc, Rc, Ic),
arith_eval( Ia*Ka+Ib, Ic),
arith_eval( Ra*Ka+Rb, Rc),
add_linear_f1h( Ha, Ka, Hb, Hc).
add_linear_f1h( [], _, Ys, Ys).
add_linear_f1h( [X*Kx|Xs], Ka, Ys, Zs) :-
add_linear_f1h( Ys, X, Kx, Xs, Zs, Ka).
add_linear_f1h( [], X, Kx, Xs, Zs, Ka) :- mult_hom( [X*Kx|Xs], Ka, Zs).
add_linear_f1h( [Y*Ky|Ys], X, Kx, Xs, Zs, Ka) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx*Ka+Ky, Kz),
( arith_eval(Kz=:=0) ->
add_linear_f1h( Xs, Ka, Ys, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_f1h( Xs, Ka, Ys, Ztail)
)
; Rel = <, Zs = [X*Kz|Ztail],
arith_eval( Kx*Ka, Kz),
add_linear_f1h( Xs, Ka, [Y*Ky|Ys], Ztail)
; Rel = >, Zs = [Y*Ky|Ztail],
add_linear_f1h( Ys, X, Kx, Xs, Ztail, Ka)
).
add_linear_11( LinA, LinB, LinC) :-
decompose( LinA, Ha, Ra, Ia),
decompose( LinB, Hb, Rb, Ib),
decompose( LinC, Hc, Rc, Ic),
arith_eval( Ia+Ib, Ic),
arith_eval( Ra+Rb, Rc),
add_linear_11h( Ha, Hb, Hc).
add_linear_11h( [], Ys, Ys).
add_linear_11h( [X*Kx|Xs], Ys, Zs) :-
add_linear_11h( Ys, X, Kx, Xs, Zs).
add_linear_11h( [], X, Kx, Xs, [X*Kx|Xs]).
add_linear_11h( [Y*Ky|Ys], X, Kx, Xs, Zs) :-
nf_ordering( X, Y, Rel),
( Rel = =, arith_eval( Kx+Ky, Kz),
( arith_eval(Kz=:=0) ->
add_linear_11h( Xs, Ys, Zs)
;
Zs = [X*Kz|Ztail],
add_linear_11h( Xs, Ys, Ztail)
)
; Rel = <, Zs = [X*Kx|Ztail], add_linear_11h( Xs, Y, Ky, Ys, Ztail)
; Rel = >, Zs = [Y*Ky|Ztail], add_linear_11h( Ys, X, Kx, Xs, Ztail)
).
mult_linear_factor( Lin, K, Mult) :-
arith_eval( K=:=1 ), % avoid copy
!,
Mult = Lin.
mult_linear_factor( Lin, K, Res) :-
decompose( Lin, Hom, R, I),
decompose( Res, Mult, Rk, Ik),
arith_eval( I*K, Ik),
arith_eval( R*K, Rk),
mult_hom( Hom, K, Mult).
mult_hom( [], _, []).
mult_hom( [A*Fa|As], F, [A*Fan|Afs]) :-
arith_eval( F*Fa, Fan),
mult_hom( As, F, Afs).
/*
%
% slightly stabilizes clp(r) numerically
%
mult_hom( [], _, []).
mult_hom( [X*Kx|Xs], K, Res) :-
arith_eval( K*Kx, C),
( arith_eval( C=:=0) ->
mult_hom( Xs, K, Res)
;
Res = [X*C|Tail],
mult_hom( Xs, K, Tail)
).
*/
%
% Replace V in H by its new definition, Vh+Vi
%
nf_substitute( V, LinV, LinX, LinX1) :-
delete_factor( V, LinX, LinW, K),
add_linear_f1( LinV, K, LinW, LinX1).
delete_factor( Vid, Lin, Res, Coeff) :-
decompose( Lin, Hom, R, I),
decompose( Res, Hdel, R, I),
delete_factor_hom( Vid, Hom, Hdel, Coeff).
/**/
%
% Makes no use of the nf_ordering and is faster ...
% Depends of course on the price of nf_ordering/3
%
delete_factor_hom( Vid, [Car|Cdr], RCdr, RKoeff) :-
Car = Var*Koeff,
compare( R, Var, Vid),
( R = =, RCdr = Cdr, RKoeff=Koeff
; R = <, RCdr = [Car|RCdr1],
delete_factor_hom( Vid, Cdr, RCdr1, RKoeff)
; R = >, RCdr = [Car|RCdr1],
delete_factor_hom( Vid, Cdr, RCdr1, RKoeff)
).
/**/
/**
%
%
%
delete_factor_hom( Vid, [Car|Cdr], RCdr, RKoeff) :-
Car = Var*Koeff,
nf_ordering( Vid, Var, Rel),
( Rel= =,
RCdr = Cdr, RKoeff=Koeff
; Rel= >,
RCdr = [Car|RCdr1],
delete_factor_hom( Vid, Cdr, RCdr1, RKoeff)
).
**/
% nf_coeff_of( Nf, X, Coeff)
% determine the coeff of variable X in Nf
% fails if X is not a member of the Nf
%
nf_coeff_of( Lin, Vid, Coeff) :-
decompose( Lin, Hom, _, _),
get_atts( Vid, order(OVid)), % pulled out of loop
nf_coeff_hom( Hom, OVid, Coeff), !.
nf_coeff_hom( [Var*K|Vs], Vid, Coeff) :-
% nf_ordering( Vid, Var, Rel),
get_atts( Var, order(OVar)),
compare( Rel, Vid, OVar),
( Rel= =, Coeff = K
; Rel= >, nf_coeff_hom( Vs, Vid, Coeff)
).
nf_rhs_x( Lin, X, Rhs,K) :-
decompose( Lin, Tail, R, I),
get_atts( X, order(Ox)), % pulled out of loop
nf_coeff_hom( Tail, Ox, K),
arith_eval( R+I, Rhs). % late because X may not occur in H
%
% solve for New = Lin1
%
isolate( New, Lin, Lin1) :-
delete_factor( New, Lin, Lin0, Coeff),
arith_eval( -1/Coeff, K),
mult_linear_factor( Lin0, K, Lin1).
indep( Lin, X) :-
decompose( Lin, [Y*K], _, I),
X == Y,
arith_eval( K=:=1),
arith_eval( I=:=0).
nf2sum( [], I, I).
nf2sum( [X|Xs], I, Sum) :-
( arith_eval(I=:=0) ->
X = Var*K,
( arith_eval( K=:=1) ->
hom2sum( Xs, Var, Sum)
; arith_eval( K=:= -1) ->
hom2sum( Xs, -Var, Sum)
;
hom2sum( Xs, K*Var, Sum)
)
;
hom2sum( [X|Xs], I, Sum)
).
hom2sum( [], Term, Term).
hom2sum( [Var*K|Cs], Sofar, Term) :-
( arith_eval( K=:=1) ->
Next = Sofar + Var
; arith_eval( K=:= -1) ->
Next = Sofar - Var
; arith_eval( K < 0) ->
arith_eval( -K, Ka),
Next = Sofar - Ka*Var
;
Next = Sofar + K*Var
),
hom2sum( Cs, Next, Term).

8
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.2 2001-04-16 16:41:04 vsc Exp $ *
* version: $Id: Heap.h,v 1.3 2001-06-06 19:10:51 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -237,6 +237,9 @@ typedef struct various_codes {
functor_stream,
functor_stream_pos,
functor_stream_eOS,
functor_change_module,
functor_current_module,
functor_mod_switch,
functor_v_bar,
functor_var;
Term
@ -415,6 +418,9 @@ typedef struct various_codes {
#define FunctorStream heap_regs->functor_stream
#define FunctorStreamPos heap_regs->functor_stream_pos
#define FunctorStreamEOS heap_regs->functor_stream_eOS
#define FunctorChangeModule heap_regs->functor_change_module
#define FunctorCurrentModule heap_regs->functor_current_module
#define FunctorModSwitch heap_regs->functor_mod_switch
#define FunctorVBar heap_regs->functor_v_bar
#define FunctorVar heap_regs->functor_var
#define TermDollarU heap_regs->term_dollar_u

5
H/Regs.h
View File

@ -10,7 +10,7 @@
* File: Regs.h *
* mods: *
* comments: YAP abstract machine registers *
* version: $Id: Regs.h,v 1.2 2001-05-21 20:00:05 vsc Exp $ *
* version: $Id: Regs.h,v 1.3 2001-06-06 19:10:51 vsc Exp $ *
*************************************************************************/
@ -96,6 +96,7 @@ typedef struct
Term TermNil_; /* 20 */
#endif
#endif
CELL *CurrentModulePtr_;
#if (defined(YAPOR) && defined(SBA)) || defined(TABLING)
CELL *H_FZ_;
choiceptr B_FZ_;
@ -630,6 +631,8 @@ EXTERN inline void restore_B(void) {
#ifdef COROUTINING
#define DelayedVars REGS.DelayedVars_
#endif
#define CurrentModulePtr REGS.CurrentModulePtr_
#define CurrentModule IntOfTerm(*REGS.CurrentModulePtr_)
#define REG_SIZE sizeof(REGS)/sizeof(CELL *)

15
Makefile.in
View File

@ -444,11 +444,11 @@ install_unix:
-mkdir -p $(DESTDIR)$(YAPLIBDIR)
$(INSTALL_DATA) -m 644 startup $(DESTDIR)$(YAPLIBDIR)/startup
$(INSTALL_DATA) -m 644 libYap.a $(DESTDIR)$(LIBDIR)/libYap.a
(cd $(srcdir) ; tar cf - library) | (cd $(DESTDIR)$(YAPLIBDIR) ; tar xf -)
(cd library ; make install)
$(INSTALL_DATA) $(srcdir)/LGPL/pillow/icon_address.pl $(DESTDIR)$(YAPLIBDIR)/library
$(INSTALL_DATA) $(srcdir)/LGPL/pillow/pillow.pl $(DESTDIR)$(YAPLIBDIR)/library
(cd $(srcdir)/CLPQR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -)
(cd $(srcdir)/CHR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -)
-(cd CLPQR ; make install)
-(cd CHR ; make install)
@INSTALL_DLLS@ (cd library/regex; make install)
@INSTALL_DLLS@ (cd library/system; make install)
-mkdir -p $(DESTDIR)$(INCLUDEDIR)
@ -467,14 +467,13 @@ install_mingw32:
$(INSTALL) $(HEADERS) $(DESTDIR)$(INCLUDEDIR)
$(INSTALL) $(srcdir)/include/c_interface.h $(DESTDIR)$(INCLUDEDIR)/c_interface.h
$(INSTALL) config.h $(INCLUDEDIR)/config.h
(cd $(srcdir) ; tar cf - library) | (cd $(DESTDIR)$(YAPLIBDIR) ; tar xf -)
(cd library ; make install)
$(INSTALL_DATA) $(srcdir)/LGPL/pillow/icon_address.pl $(DESTDIR)$(YAPLIBDIR)/library
$(INSTALL_DATA) $(srcdir)/LGPL/pillow/pillow.pl $(DESTDIR)$(YAPLIBDIR)/library
(cd $(srcdir)/CLPQR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -)
(cd $(srcdir)/CHR ; tar cf - .) | (cd $(DESTDIR)$(YAPLIBDIR)/library ; tar xf -)
(cd CLPQR ; make install)
(cd CHR ; make install)
(cd library/regex; make install_mingw32)
# (cd library/system; make install_mingw32)
(cd library/system; make install_mingw32)
install_library: libYap.a
$(INSTALL_DATA) -m 644 libYap.a $(DESTDIR)$(LIBDIR)/libYap.a

6
changes4.3.html
View File

@ -16,6 +16,12 @@
<h2>Yap-4.3.19:</h2>
<ul>
<li>FIXED: CHR instalation.</li>
<li>SPEEDUP: avoid unnecessary choice-points with CLPQR.</li>
<li>NEW: inline $mod_switch, $mod_switch now uses
backtrackable updates to modules.</li>
<li>NEW: new method for marking timestamps that simplifies gc</li>
<li>FIXED: bug while collecting multi-assignment variables</li>
<li>FIXED: make yap modules more compatible with SICStus Prolog</li>
<li>NEW: <code>portray_clause/2</code> (request from Nicos Angelopoulos)</li>
<li>FIXED: document <code>absolute_file_name/2</code></li>

6
configure vendored
View File

@ -3824,6 +3824,8 @@ fi
mkdir -p library/regex
mkdir -p library/system
mkdir -p CHR
mkdir -p CLPQR
trap '' 1 2 15
cat > confcache <<\EOF
@ -3926,7 +3928,7 @@ done
ac_given_srcdir=$srcdir
ac_given_INSTALL="$INSTALL"
trap 'rm -fr `echo "Makefile library/regex/Makefile library/system/Makefile .depend config.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
trap 'rm -fr `echo "Makefile library/regex/Makefile library/system/Makefile .depend library/Makefile CHR/Makefile CLPQR/Makefile config.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS <<EOF
@ -4036,7 +4038,7 @@ EOF
cat >> $CONFIG_STATUS <<EOF
CONFIG_FILES=\${CONFIG_FILES-"Makefile library/regex/Makefile library/system/Makefile .depend"}
CONFIG_FILES=\${CONFIG_FILES-"Makefile library/regex/Makefile library/system/Makefile .depend library/Makefile CHR/Makefile CLPQR/Makefile"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then

4
configure.in
View File

@ -592,8 +592,10 @@ fi
mkdir -p library/regex
mkdir -p library/system
mkdir -p CHR
mkdir -p CLPQR
AC_OUTPUT(Makefile library/regex/Makefile library/system/Makefile .depend)
AC_OUTPUT(Makefile library/regex/Makefile library/system/Makefile .depend library/Makefile CHR/Makefile CLPQR/Makefile)
make depend

42
library/Makefile.in Normal file
View File

@ -0,0 +1,42 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for libraries
#
LIBDIR=$(ROOTDIR)/lib/Yap
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
PROGRAMS= $(srcdir)/assoc.yap \
$(srcdir)/atts.yap \
$(srcdir)/avl.yap \
$(srcdir)/charsio.yap \
$(srcdir)/heaps.yap \
$(srcdir)/lists.yap \
$(srcdir)/ordsets.yap \
$(srcdir)/prandom.yap \
$(srcdir)/queues.yap \
$(srcdir)/random.yap \
$(srcdir)/regexp.yap \
$(srcdir)/terms.yap \
$(srcdir)/timeout.yap \
$(srcdir)/trees.yap \
$(srcdir)/ugraphs.yap
install: $(PROGRAMS)
-mkdir $(DESTDIR)$(LIBDIR)/library
$(INSTALL_DATA) $(PROGRAMS) $(DESTDIR)$(LIBDIR)/library

1
m4/Yatom.h.m4
View File

@ -382,7 +382,6 @@ typedef enum {
} db_term_flags;
#define MaxModules 255
extern SMALLUNSGN CurrentModule;
typedef struct {
Prop NextOfPE; /* used to chain properties */

23
pl/boot.yap
View File

@ -662,13 +662,7 @@ incore(G) :- '$execute'(G).
'$call'(M:_,_,G0) :- var(M), !,
throw(error(instantiation_error,call(G0))).
'$call'(M:G,CP,G0) :- !,
( '$current_module'(M) ->
'$call'(G,CP,G0)
;
'$current_module'(Old,M),
( '$call'(G,CP,G0); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$mod_switch'(M,'$call'(G,CP,G0)).
'$call'((A,B),CP,G0) :- !,
'$execute_within'(A,CP,G0),
'$execute_within'(B,CP,G0).
@ -722,14 +716,7 @@ incore(G) :- '$execute'(G).
'$spied_call'(M:_,_,G0) :- var(M), !,
throw(error(instantiation_error,call(G0))).
'$spied_call'(M:G,CP,G0) :- !,
( '$current_module'(M) ->
'$check_callable'(G,M:G),
'$spied_call'(G,CP,G0)
;
'$current_module'(Old,M),
( '$spied_call'(G,CP,G0); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$mod_switch'(M,'$spied_call'(G,CP,G0)).
'$spied_call'((A,B),CP,G0) :- !,
'$execute_within'(A,CP,G0),
'$execute_within'(B,CP,G0).
@ -803,7 +790,7 @@ incore(G) :- '$execute'(G).
'$undefp'([M|G]) :-
functor(G,F,N),
'$recorded'('$import','$import'(S,M,F,N),_),
S\= M, % can't try importing from the module itself.
S \= M, % can't try importing from the module itself.
!,
'$exec_with_expansion'(G, S, M).
'$undefp'([M|G]) :-
@ -894,14 +881,14 @@ break :- '$get_value'('$break',BL), NBL is BL+1,
'$get_value'('$consulting',Old),
'$set_value'('$consulting',true),
'$recorda'('$initialisation','$',_),
( '$get_value'($verbose,on) ->
( '$get_value'('$verbose',on) ->
tab(user_error,LC),
'$format'(user_error, "[ consulting ~w... ]~n", [F])
; true ),
'$loop'(Stream,consult),
'$end_consult',
( LC == 0 -> prompt(_,' |: ') ; true),
( '$get_value'($verbose,on) ->
( '$get_value'('$verbose',on) ->
tab(user_error,LC) ;
true ),
H is heapused-H0, T is cputime-T0,

4
pl/consult.yap
View File

@ -30,7 +30,7 @@ ensure_loaded(V) :-
( '$loaded'(Stream) ->
( $consulting_file_name(Stream,TFN),
'$recorded'('$module','$module'(TFN,M,P),_) ->
$current_module(T,T), '$import'(P,M,T)
$current_module(T), '$import'(P,M,T)
;
true
)
@ -51,7 +51,7 @@ ensure_loaded(V) :-
( '$loaded'(Stream) ->
( '$consulting_file_name'(Stream,TFN),
'$recorded'('$module','$module'(TFN,M,P),_) ->
'$current_module'(T,T), $import(P,M,T)
'$current_module'(T), $import(P,M,T)
;
true
)

8
pl/corout.yap
View File

@ -94,12 +94,12 @@ freeze(_, G) :-
'$freeze_goal'(V,VG) :-
var(VG), !,
'$current_module'(M,M),
'$current_module'(M),
'$freeze'(V, '$redo_freeze'(_Done,V,M:G)).
'$freeze_goal'(V,M:G) :- !,
'$freeze'(V, '$redo_freeze'(_Done,V,M:G)).
'$freeze_goal'(V,G) :-
'$current_module'(M,M),
'$current_module'(M),
'$freeze'(V, '$redo_freeze'(_Done,V,M:G)).
%
@ -213,7 +213,7 @@ dif(_, _).
% support for when/2 built-in
%
when(Conds,Goal) :-
'$current_module'(Mod,Mod),
'$current_module'(Mod),
'$prepare_goal_for_when'(Goal, Mod, ModG),
'$when'(Conds, ModG, Done, [], LG), !,
%write(vsc:freezing(LG,Done)),nl,
@ -240,7 +240,7 @@ when(_,Goal) :-
'$generate_code_for_when'(Conds, G,
( G :- '$when'(Conds, ModG, Done, [], LG), !,
'$suspend_when_goals'(LG, Done)) ) :-
'$current_module'(Mod,Mod),
'$current_module'(Mod),
'$prepare_goal_for_when'(G, Mod, ModG).

30
pl/debug.yap
View File

@ -31,7 +31,7 @@
'$suspy'(M:S,P) :- !,
'$current_module'(Old,M),
('$suspy'(S,P),fail ; true), !,
'$current_module'(_,Old).
'$change_module'(Old).
'$suspy'([],_) :- !.
'$suspy'([F|L],M) :- !, ( '$suspy'(F,M) ; '$suspy'(L,M) ).
'$suspy'(F/N,M) :- !, functor(T,F,N),
@ -233,13 +233,7 @@ debugging :-
'$spy'([Module|G]) :- !,
% write(user_error,$spym(M,G)), nl,
( Module=prolog -> '$spy'(G);
'$current_module'(Module) -> '$spy'(G);
( $current_module(Old,Module),
( '$spy'(G);
$current_module(_,Old), fail
),
( $current_module(_,Old); $current_module(_,Module),fail)
)
'$mod_switch'(Module, '$spy'(G))
).
'$spy'(true) :- !, '$creep'.
'$spy'('$cut_by'(M)) :- !, '$cut_by'(M).
@ -618,9 +612,7 @@ debugging :-
'$creep_call'(R,_) :- db_reference(R), !,
throw(error(type_error(callable,R),meta_call(R))).
'$creep_call'(M:G,CP) :- !,
'$current_module'(Old,M),
( '$creep_call'(G,CP); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail).
'$mod_switch'(M, '$creep_call'(G,CP)),
'$current_module'(Module),
'$spy'([Module|fail]).
'$creep_call'(fail,_) :- !,
@ -767,23 +759,11 @@ debugging :-
abort.
'$creep'([Module|'$trace'(P,G,L)]) :- !,
( Module=prolog -> '$trace'(P,G,L);
$current_module(Module) -> '$trace'(P,G,L);
( $current_module(Old,Module),
( '$trace'(P,G,L);
$current_module(_,Module), fail
),
$current_module(_,Old)
)
'$mod_switch'(Module, '$trace'(P,G,L))
).
'$creep'([Module|'$creep_call'(G,CP)]) :- !,
( Module=prolog -> '$creep_call'(G,CP);
$current_module(Module) -> '$creep_call'(G,CP);
( $current_module(Old,Module),
( '$creep_call'(G,CP);
$current_module(_,Module), fail
),
$current_module(_,Old)
)
'$mod_switch'(Module, '$creep_call'(G,P) )
).
'$creep'([_|'$leave_creep']) :- !.
'$creep'(G) :- '$spy'(G).

15
pl/depth_bound.yap
View File

@ -44,10 +44,8 @@ $old_depth_bound_call(A,D) :-
'$check_callable'(G,M:G),
'$call_depth_limited'(G,CP,D)
;
'$current_module'(Old,M),
'$check_callable'(G,M:G),
( '$call_depth_limited'(G,CP,D); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
'$mod_switch'(M,'$call_depth_limited'(G,CP,D) )
).
'$call_depth_limited'(fail,_,_) :- !, fail.
'$call_depth_limited'(false,_,_) :- !, false.
@ -126,15 +124,8 @@ $old_depth_bound_call(A,D) :-
'$spied_call_depth_limited'(M:G,CP,D) :- !,
( '$current_module'(M) ->
'$check_callable'(G,M:G),
'$spied_call_depth_limited'(G,CP,D)
;
'$current_module'(Old,M),
'$check_callable'(G,M:G),
( '$spied_call_depth_limited'(G,CP,D); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,M), fail)
).
'$check_callable'(G,M:G),
'$mod_switch'(M,'$spied_call_depth_limited'(G,CP,D)).
'$spied_call_depth_limited'(fail,_,_) :- !, fail.
'$spied_call_depth_limited'(false,_,_) :- !, false.
'$spied_call_depth_limited'(true,_,_) :- !.

76
pl/nfr.yap
View File

@ -1,76 +0,0 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% clp(q,r) version 1.3.3 %
% %
% (c) Copyright 1992,1993,1994,1995 %
% Austrian Research Institute for Artificial Intelligence (OFAI) %
% Schottengasse 3 %
% A-1010 Vienna, Austria %
% %
% File: nfr.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module( nfr,
[
{}/1,
entailed/1,
wait_linear/3,
nf/2,
repair/2,
nf_constant/2,
split/3,
transg/3
]).
:- use_module( arith_r).
:- use_module( clpr, '../clpr',
[
'solve_<'/1,
'solve_=<'/1,
'solve_=\\='/1,
add_linear_11/3,
export_binding/2,
ineq_one/4,
ineq_one_n_n_0/1,
ineq_one_n_p_0/1,
ineq_one_s_n_0/1,
ineq_one_s_p_0/1,
log_deref/4,
normalize_scalar/2,
solve/1
]).
:- ensure_loaded( nf).
transg( resubmit_eq(Nf)) -->
{
nf2term( [], Z),
nf2term( Nf, Term)
},
[ clpr:{Term=Z} ].
transg( resubmit_lt(Nf)) -->
{
nf2term( [], Z),
nf2term( Nf, Term)
},
[ clpr:{Term<Z} ].
transg( resubmit_le(Nf)) -->
{
nf2term( [], Z),
nf2term( Nf, Term)
},
[ clpr:{Term=<Z} ].
transg( resubmit_ne(Nf)) -->
{
nf2term( [], Z),
nf2term( Nf, Term)
},
[ clpr:{Term=\=Z} ].
transg( wait_linear_retry(Nf,Res,Goal)) -->
{
nf2term( Nf, Term)
},
[ clpr:{Term=Res}, Goal ].

42
pl/utils.yap
View File

@ -812,48 +812,6 @@ user_defined_directive(Dir,Action) :-
assert_static('$directive'(NDir)),
assert_static(('$exec_directive'(Dir, _) :- Action)).
'$mod_switch'(Mod,Pred) :-
'$current_module'(Mod), !,
'$fast_do'(Pred).
'$mod_switch'(Mod,Pred) :-
'$current_module'(Old,Mod),
( '$fast_do'(Pred); '$current_module'(_,Old), fail ),
( '$current_module'(_,Old); '$current_module'(_,Mod), fail).
'$fast_do'('$execute_command'(G,V,O)) :- '$execute_command'(G,V,O).
'$fast_do'('$go_compile_clause'(G,V,N)) :- '$go_compile_clause'(G,V,N).
'$fast_do'('$multifile'(P)) :- '$multifile'(P).
'$fast_do'('$discontiguous'(P)) :- '$discontiguous'(P).
'$fast_do'('$assert'(C,W,R,P)) :- '$assert'(C,W,R,P).
'$fast_do'('$assert_dynamic'(C,W,R,P)) :- '$assert_dynamic'(C,W,R,P).
'$fast_do'('$assert_static'(C,W,R,P)) :- '$assert_static'(C,W,R,P).
'$fast_do'(clause(P,Q)) :- clause(P,Q).
'$fast_do'(clause(P,Q,R)) :- clause(P,Q,R).
'$fast_do'(retract(C)) :- retract(C).
'$fast_do'(retract(C,R)) :- retract(C,R).
'$fast_do'(retractall(C)) :- retractall(C).
'$fast_do'(abolish(N,A)) :- abolish(N,A).
'$fast_do'('$new_abolish'(P)) :- '$new_abolish'(P).
'$fast_do'('$old_abolish'(P)) :- '$old_abolish'(P).
'$fast_do'('$dynamic'(S)) :- '$dynamic'(S).
'$fast_do'(current_predicate(PS)) :- current_predicate(PS).
'$fast_do'(current_predicate(A,T)) :- current_predicate(A,T).
'$fast_do'('$predicate_property2'(P,T)) :- '$predicate_property2'(P,T).
'$fast_do'(unknown(V,H)) :- unknown(V,H).
'$fast_do'(listing(PE)) :- listing(PE).
'$fast_do'('$Error'(E)) :- '$Error'(E).
'$fast_do'('$LoopError'(E)) :- '$LoopError'(E).
'$fast_do'('$DebugError'(E)) :- '$DebugError'(E).
'$fast_do'('$exec_with_expansion2'(G,M)) :- '$exec_with_expansion2'(G,M).
'$fast_do'('$public'(P)) :- '$public'(P).
'$fast_do'('$module_u_vars'(H,UVars)) :- '$module_u_vars'(H,UVars).
'$fast_do'(M:G) :- '$mod_switch'(M,G).
'$fast_do'('$spycalls'(G,Res)) :- '$spycalls'(G,Res).
'$fast_do'('$profile_data'(P, Parm, Data)) :- '$profile_data'(P, Parm, Data).
'$fast_do'('$ensure_loaded'(F)) :- '$ensure_loaded'(F).
'$fast_do'('$consult'(F)) :- '$consult'(F).
'$fast_do'('$reconsult'(F)) :- '$reconsult'(F).
'$set_toplevel_hook'(_) :-
'$recorded'('$toplevel_hooks',_,R),
erase(R),