From 38247e38fc6690abc966880e60c4a1735a11fd2f Mon Sep 17 00:00:00 2001 From: vsc Date: Wed, 6 Jun 2001 19:10:51 +0000 Subject: [PATCH] cleanup of CLPQR and CHR; simplification of module handling; new timestamp implementation git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@52 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/attvar.c | 50 +- C/bb.c | 20 +- C/cdmgr.c | 8 +- C/compiler.c | 58 +- C/exec.c | 3 + C/grow.c | 4 + C/heapgc.c | 68 +- C/init.c | 15 +- C/load_foreign.c | 4 +- C/mavar.c | 72 +- C/modules.c | 21 +- C/save.c | 9 +- CHR/Makefile.in | 96 ++ CLPQR/Makefile.in | 150 ++ CLPQR/clpq/arith.pl | 668 --------- CLPQR/clpq/bb.pl | 128 -- CLPQR/clpq/bv.pl | 1256 ----------------- CLPQR/clpq/bv.yap | 1256 ----------------- CLPQR/clpq/compenv.pl | 86 -- CLPQR/clpq/dump.pl | 147 -- CLPQR/clpq/fourmotz.pl | 294 ---- CLPQR/clpq/geler.yap | 3 +- CLPQR/clpq/ineq.pl | 984 ------------- CLPQR/clpq/itf3.pl | 273 ---- CLPQR/clpq/nf.pl | 834 ----------- CLPQR/clpq/nf.yap | 834 ----------- CLPQR/clpq/ordering.pl | 136 -- CLPQR/clpq/project.pl | 147 -- CLPQR/clpq/redund.pl | 157 --- CLPQR/{clpr => clpqr}/bb.yap | 8 +- CLPQR/{clpr => clpqr}/bv.yap | 66 +- CLPQR/{clpr/ineq.pl => clpqr/ineq.yap} | 45 +- CLPQR/{clpr => clpqr}/nf.yap | 3 +- .../{clpr/ordering.pl => clpqr/ordering.yap} | 5 +- CLPQR/{clpq/store.pl => clpqr/store.yap} | 27 +- CLPQR/clpr/arith.pl | 668 --------- CLPQR/clpr/bb.pl | 128 -- CLPQR/clpr/bv.pl | 1256 ----------------- CLPQR/clpr/compenv.pl | 86 -- CLPQR/clpr/dump.pl | 147 -- CLPQR/clpr/fourmotz.pl | 294 ---- CLPQR/clpr/geler.yap | 3 +- CLPQR/clpr/itf3.pl | 273 ---- CLPQR/clpr/nf.pl | 834 ----------- CLPQR/clpr/project.pl | 147 -- CLPQR/clpr/redund.pl | 157 --- CLPQR/clpr/store.pl | 279 ---- H/Heap.h | 8 +- H/Regs.h | 5 +- Makefile.in | 15 +- changes4.3.html | 6 + configure | 6 +- configure.in | 4 +- library/Makefile.in | 42 + m4/Yatom.h.m4 | 1 - pl/boot.yap | 23 +- pl/consult.yap | 4 +- pl/corout.yap | 8 +- pl/debug.yap | 30 +- pl/depth_bound.yap | 15 +- pl/nfr.yap | 76 - pl/utils.yap | 42 - 62 files changed, 577 insertions(+), 11915 deletions(-) create mode 100644 CHR/Makefile.in create mode 100644 CLPQR/Makefile.in delete mode 100644 CLPQR/clpq/arith.pl delete mode 100644 CLPQR/clpq/bb.pl delete mode 100644 CLPQR/clpq/bv.pl delete mode 100644 CLPQR/clpq/bv.yap delete mode 100644 CLPQR/clpq/compenv.pl delete mode 100644 CLPQR/clpq/dump.pl delete mode 100644 CLPQR/clpq/fourmotz.pl delete mode 100644 CLPQR/clpq/ineq.pl delete mode 100644 CLPQR/clpq/itf3.pl delete mode 100644 CLPQR/clpq/nf.pl delete mode 100644 CLPQR/clpq/nf.yap delete mode 100644 CLPQR/clpq/ordering.pl delete mode 100644 CLPQR/clpq/project.pl delete mode 100644 CLPQR/clpq/redund.pl rename CLPQR/{clpr => clpqr}/bb.yap (94%) rename CLPQR/{clpr => clpqr}/bv.yap (96%) rename CLPQR/{clpr/ineq.pl => clpqr/ineq.yap} (97%) rename CLPQR/{clpr => clpqr}/nf.yap (99%) rename CLPQR/{clpr/ordering.pl => clpqr/ordering.yap} (97%) rename CLPQR/{clpq/store.pl => clpqr/store.yap} (91%) delete mode 100644 CLPQR/clpr/arith.pl delete mode 100644 CLPQR/clpr/bb.pl delete mode 100644 CLPQR/clpr/bv.pl delete mode 100644 CLPQR/clpr/compenv.pl delete mode 100644 CLPQR/clpr/dump.pl delete mode 100644 CLPQR/clpr/fourmotz.pl delete mode 100644 CLPQR/clpr/itf3.pl delete mode 100644 CLPQR/clpr/nf.pl delete mode 100644 CLPQR/clpr/project.pl delete mode 100644 CLPQR/clpr/redund.pl delete mode 100644 CLPQR/clpr/store.pl create mode 100644 library/Makefile.in delete mode 100644 pl/nfr.yap diff --git a/C/attvar.c b/C/attvar.c index 6f7df3d41..7229dde5e 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -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)); diff --git a/C/bb.c b/C/bb.c index d3bab1488..e0e298715 100644 --- a/C/bb.c +++ b/C/bb.c @@ -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); } diff --git a/C/cdmgr.c b/C/cdmgr.c index c6962fd11..f7a45c940 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -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); diff --git a/C/compiler.c b/C/compiler.c index 2fba1b33e..efa26381d 100644 --- a/C/compiler.c +++ b/C/compiler.c @@ -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); } diff --git a/C/exec.c b/C/exec.c index 5cec63651..31bd748b4 100644 --- a/C/exec.c +++ b/C/exec.c @@ -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; diff --git a/C/grow.c b/C/grow.c index 321cd0ada..f00fef07b 100644 --- a/C/grow.c +++ b/C/grow.c @@ -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 diff --git a/C/heapgc.c b/C/heapgc.c index 07b80ef15..15f55e2a0 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -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); diff --git a/C/init.c b/C/init.c index 89b868242..30d53d8f1 100644 --- a/C/init.c +++ b/C/init.c @@ -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 */ diff --git a/C/load_foreign.c b/C/load_foreign.c index f88c818c3..d96d0c95a 100644 --- a/C/load_foreign.c +++ b/C/load_foreign.c @@ -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); } diff --git a/C/mavar.c b/C/mavar.c index d89e9c276..dc0b03ba6 100644 --- a/C/mavar.c +++ b/C/mavar.c @@ -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); diff --git a/C/modules.c b/C/modules.c index 1a437bfef..6a1283d6a 100644 --- a/C/modules.c +++ b/C/modules.c @@ -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); } diff --git a/C/save.c b/C/save.c index 93c459dc6..5e5cd2345 100644 --- a/C/save.c +++ b/C/save.c @@ -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 diff --git a/CHR/Makefile.in b/CHR/Makefile.in new file mode 100644 index 000000000..dc2aefd1e --- /dev/null +++ b/CHR/Makefile.in @@ -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 + + diff --git a/CLPQR/Makefile.in b/CLPQR/Makefile.in new file mode 100644 index 000000000..b980d4fb4 --- /dev/null +++ b/CLPQR/Makefile.in @@ -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 + + diff --git a/CLPQR/clpq/arith.pl b/CLPQR/clpq/arith.pl deleted file mode 100644 index d30d4380f..000000000 --- a/CLPQR/clpq/arith.pl +++ /dev/null @@ -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< {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) - ). - diff --git a/CLPQR/clpq/bb.pl b/CLPQR/clpq/bb.pl deleted file mode 100644 index 8ccfd93d2..000000000 --- a/CLPQR/clpq/bb.pl +++ /dev/null @@ -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( _, _, _). - diff --git a/CLPQR/clpq/bv.pl b/CLPQR/clpq/bv.pl deleted file mode 100644 index 73769ee47..000000000 --- a/CLPQR/clpq/bv.pl +++ /dev/null @@ -1,1256 +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: bv.pl % -% Author: Christian Holzbaur christian@ai.univie.ac.at % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -% -% simplex with bounded variables, ch, 93/12 -% - -% -% TODO: +) var/bound/state classification and maintainance -% +) inc/dec_step: take the best?, at least find unconstrained var first -% +) trivially implied values -% +) avoid eval_rhs through an extra column (Coeff=Rhs) -% +) if an optimum is encountered, record the value as bound !!! -% +) generalized (transparent) attribute handling -% +) coordinate reconsideration cascades -% +) =\= -% +) strict inequalities via =\= -% -) decompose via nonvar test -> no symbolic constants any more ? -% constants complicate the nonlin solver anyway ... -% +) join t_l,l(L), .... into t_l(L), ... -% +) shortcuts for strict ineqs -% -) extra types for vars with l/u bound zero -% -) occurrence lists for indep vars (with coeffs) ??? -% each solve produces one dep var -> push -% only complication: pivots -% -) *incremental* REVISED simplex ?!! -% -% sicstus2.1.9.clp conversion: -% -% -) stable ordering through extra attribute ... -% interpreted vs compiled yields different var order -% -> nasty in R (need different eps) -% -% -) check determinism again -% -% - -:- public {}/1, maximize/1, minimize/1, sup/2, inf/2, imin/2. % xref.pl - -:- use_module( library(ordsets), [ord_add_element/3]). - -% :- use_module( library(deterministic)). - -% -% For the rhs maint. the following events are important: -% -% -) introduction of an indep var at active bound B -% -) narrowing of active bound -% -) swap active bound -% -) pivot -% - -% -% a variables bound (L/U) can have the states: -% -% -) t_none -% -) t_l has a lower bound (not active yet) -% -) t_u -% -) t_L has an active lower bound -% -) t_U -% -) t_lu -% -) t_Lu -% -) t_lU -% - -% ----------------------------------- deref ------------------------------------ % - -:- mode deref( +, -). -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - length( H, Len), - log_deref( Len, H, [], Restd), - add_linear_11( Nonvar, Restd, Lind). - -:- mode log_deref( +, +, -, -). -% -log_deref( 0, Vs, Vs, Lin) :- !, - arith_eval( 0, Z), - Lin = [Z,Z]. -log_deref( 1, [v(K,[X^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - mult_linear_factor( Lx, K, Lin). -log_deref( 2, [v(Kx,[X^1]),v(Ky,[Y^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - deref_var( Y, Ly), - add_linear_ff( Lx, Kx, Ly, Ky, Lin). -log_deref( N, V0, V2, Lin) :- - P is N >> 1, - Q is N - P, - log_deref( P, V0,V1, Lp), - log_deref( Q, V1,V2, Lq), - add_linear_11( Lp, Lq, Lin). - -/* -% -% tail recursive version -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - lin_deref( H, Nonvar, Lind). - -log_deref( _, Lin, [], Res) :- % called from nf.pl - arith_eval( 0, Z), - lin_deref( Lin, [Z,Z], Res). - -lin_deref( [], Ld, Ld). -lin_deref( [v(K,[X^1])|Vs], Li, Lo) :- - deref_var( X, Lx), - add_linear_f1( Lx, K, Li, Lii), - lin_deref( Vs, Lii, Lo). -*/ - -% -% If we see a nonvar here, this is a fault -% -deref_var( X, Lin) :- - get_atts( X, lin(Lin)), !. -deref_var( X, Lin) :- % create a linear var - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,X*One], - put_atts( X, [order(_),lin(Lin),type(t_none),strictness(2'00)]). - -var_with_def_assign( Var, Lin) :- - decompose( Lin, Hom, _, I), - ( Hom = [], % X=k - Var = I - ; Hom = [V*K|Cs], - ( Cs = [], - arith_eval(K=:=1), - arith_eval(I=:=0) -> % X=Y - Var = V - ; % general case - var_with_def_intern( t_none, Var, Lin, 2'00) - ) - ). - -var_with_def_intern( Type, Var, Lin, Strict) :- - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - decompose( Lin, Hom, _, _), - get_or_add_class( Var, Class), - same_class( Hom, Class). - -var_intern( Type, Var, Strict) :- - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,Var*One], - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - get_or_add_class( Var, _Class). - -% ------------------------------------------------------------------------------ - -% -% [V-Binding]* -% Only place where the linear solver binds variables -% -export_binding( []). -export_binding( [X-Y|Gs]) :- - export_binding( Y, X), - export_binding( Gs). - -% -% numerical stabilizer, clp(r) only -% -export_binding( Y, X) :- var(Y), Y=X. -export_binding( Y, X) :- nonvar(Y), - ( arith_eval( Y=:=0) -> - arith_eval( 0, X) - ; - Y = X - ). - -'solve_='( Nf) :- - deref( Nf, Nfd), - solve( Nfd). - -'solve_=\='( Nf) :- - deref( Nf, Lind), - decompose( Lind, Hom, _, Inhom), - ( Hom = [], arith_eval( Inhom =\= 0) - ; Hom = [_|_], var_with_def_intern( t_none, Nz, Lind, 2'00), - put_atts( Nz, nonzero) - ). - -'solve_<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, strict). - -'solve_=<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, nonstrict). - -maximize( Term) :- - minimize( -Term). - -% -% This is NOT coded as minimize(Expr) :- inf(Expr,Expr). -% -% because the new version of inf/2 only visits -% the vertex where the infimum is assumed and returns -% to the 'current' vertex via backtracking. -% The rationale behind this construction is to eliminate -% all garbage in the solver data structures produced by -% the pivots on the way to the extremal point caused by -% {inf,sup}/{2,4}. -% -% If we are after the infimum/supremum for minimizing/maximizing, -% this strategy may have adverse effects on performance because -% the simplex algorithm is forced to re-discover the -% extremal vertex through the equation {Inf =:= Expr}. -% -% Thus the extra code for {minimize,maximize}/1. -% -% In case someone comes up with an example where -% -% inf(Expr,Expr) -% -% outperforms the provided formulation for minimize - so be it. -% Both forms are available to the user. -% -minimize( Term) :- - wait_linear( Term, Nf, minimize_lin(Nf)). - -minimize_lin( Lin) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - { Dep =:= Inf }. - -sup( Expression, Sup) :- - sup( Expression, Sup, [], []). - -sup( Expression, Sup, Vector, Vertex) :- - inf( -Expression, -Sup, Vector, Vertex). - -inf( Expression, Inf) :- - inf( Expression, Inf, [], []). - -inf( Expression, Inf, Vector, Vertex) :- - wait_linear( Expression, Nf, inf_lin(Nf,Inf,Vector,Vertex)). - -inf_lin( Lin, _, Vector, _) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - vertex_value( Vector, Values), - bb_put( inf, [Inf|Values]), - fail. -inf_lin( _, Infimum, _, Vertex) :- - bb_delete( inf, L), - assign( [Infimum|Vertex], L). - -assign( [], []). -assign( [X|Xs], [Y|Ys]) :- - {X =:= Y}, % more defensive/expressive than X=Y - assign( Xs, Ys). - -% --------------------------------- optimization ------------------------------- % -% -% The _sn(S) =< 0 row might be temporarily infeasible. -% We use reconsider/1 to fix this. -% -% s(S) e [_,0] = d +xi ... -xj, Rhs > 0 so we want to decrease s(S) -% -% positive xi would have to be moved towards their lower bound, -% negative xj would have to be moved towards their upper bound, -% -% the row s(S) does not limit the lower bound of xi -% the row s(S) does not limit the upper bound of xj -% -% a) if some other row R is limiting xk, we pivot(R,xk), -% s(S) will decrease and get more feasible until (b) -% b) if there is no limiting row for some xi: we pivot(s(S),xi) -% xj: we pivot(s(S),xj) -% which cures the infeasibility in one step -% - - -% -% fails if Status = unlimited/2 -% -iterate_dec( OptVar, Opt) :- - get_atts( OptVar, lin(Lin)), - decompose( Lin, H, R, I), - - % arith_eval( R+I, Now), print(min(Now)), nl, - - % dec_step_best( H, Status), - dec_step( H, Status), - ( 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) - ). - -% -% Status = {optimum,unlimited(Indep,DepT),applied} -% If Status = optimum, the tables have not been changed at all. -% Searches left to right, does not try to find the 'best' pivot -% Therefore we might discover unboundedness only after a few pivots -% -dec_step( [], optimum). -dec_step( [V*K|Vs], Status) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; 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), - ( arith_eval( K < 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K > 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_none, - Status = unlimited(V,t_none) - ). - -% ------------------------------ best first heuristic -------------------------- % -% -% A replacement for dec_step/2 that uses a local best first heuristic. -% -% - -dec_step_best( H, Status) :- - dec_eval( H, E), - ( E = unlimited(_,_), - Status = E - ; E = [], - Status = optimum - ; E = [_|_], - Status = applied, - keysort( E, [_-Best|_]), - ( Best = pivot_a(Vub,V,Vb,Wd), pivot_a(Vub,V,Vb,Wd) - ; Best = pivot_b(Vub,V,Vb,Wd), pivot_b(Vub,V,Vb,Wd) - ) - ). - -dec_eval( [], []). -dec_eval( [V*K|Vs], Res) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_u(U)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_u(U)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_l(L)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_l(L)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_none, - Res = unlimited(V,t_none) - ). - -% ------------------------- find the most constraining row --------------------- % -% -% The code for the lower and the upper bound are dual versions of each other. -% The only difference is in the orientation of the comparisons. -% Indeps are ruled out by their types. -% If there is no bound, this fails. -% -% *** The actual lb and ub on an indep variable X are [lu]b + b(X), where b(X) -% is the value of the active bound. -% -% Nota bene: We must NOT consider infeasible rows as candidates to -% leave the basis! -% - -ub( X, Ub) :- - basis( X, Deps), - ub_first( Deps, X, Ub). - -:- mode ub_first( +, ?, -). -% -ub_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - arith_eval( Ub >= 0) -> - ub( Deps, X, Dep-W-Ub, Tightest) - ; - ub_first( Deps, X, Tightest) - ). - -% -% Invariant: Ub >= 0 and decreasing -% -:- mode ub( +, ?, +, -). -% -ub( [], _, T0,T0). -ub( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - T0 = _-Ubb, - arith_eval( Ub < Ubb), - arith_eval( Ub >= 0) -> % rare failure - ub( Deps, X, Dep-W-Ub,T1) - ; - ub( Deps, X, T0,T1) - ). - -lb( X, Lb) :- - basis( X, Deps), - lb_first( Deps, X, Lb). - -:- mode lb_first( +, ?, -). -% -lb_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - arith_eval( Lb =< 0) -> - lb( Deps, X, Dep-W-Lb, Tightest) - ; - lb_first( Deps, X, Tightest) - ). - -% -% Invariant: Lb =< 0 and increasing -% -:- mode lb( +, ?, +, -). -% -lb( [], _, T0,T0). -lb( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - T0 = _-Lbb, - arith_eval( Lb > Lbb), - arith_eval( Lb =< 0) -> % rare failure - lb( Deps, X, Dep-W-Lb,T1) - ; - lb( Deps, X, T0,T1) - ). - -% -% Lb =< 0 for feasible rows -% -:- mode lb_inner( +, ?, +, -, -). -% -lb_inner( t_l(L), X, Lin, t_L(L), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (L-Rhs)/K, Lb). -lb_inner( t_u(U), X, Lin, t_U(U), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (U-Rhs)/K, Lb). -lb_inner( t_lu(L,U), X, Lin, W, Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Lb) - ), - fail, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Lb) - )). - -% -% Ub >= 0 for feasible rows -% -:- mode ub_inner( +, ?, +, -, -). -% -ub_inner( t_l(L), X, Lin, t_L(L), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (L-Rhs)/K, Ub). -ub_inner( t_u(U), X, Lin, t_U(U), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (U-Rhs)/K, Ub). -ub_inner( t_lu(L,U), X, Lin, W, Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Ub) - ), - fail, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Ub) - )). - -% ---------------------------------- equations --------------------------------- % -% -% backsubstitution will not make the system infeasible, if the bounds on the indep -% vars are obeyed, but some implied values might pop up in rows where X occurs -% -) special case X=Y during bs -> get rid of dependend var(s), alias -% - -solve( Lin) :- - decompose( Lin, H, _, I), - solve( H, Lin, I, Bindings, []), - export_binding( Bindings). - -solve( [], _, I, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve( H, Lin, _, Bind0,BindT) :- - H = [_|_], % indexing - % - % [] is an empty ord_set, anything will be preferred - % over 9-9 - % - sd( H, [],ClassesUniq, 9-9-0,Category-Selected-_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( 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, - get_atts( Selected, class(NewC)), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; Category = 3, - put_atts( Selected, lin(Lin1)), - get_atts( Selected, type(Type)), - deactivate_bound( Type, Selected), - eq_classes( NV, NVT, ClassesUniq), - basis_add( Selected, Basis), - undet_active( Lin1), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,Bind1), - rcbl( Basis, Bind1,BindT) - ; Category = 4, - get_atts( Selected, [type(Type),class(NewC)]), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,Bind1) - ; - Bind0 = Bind1, - bs( Deps, Selected, Lin1) - ), - deactivate_bound( Type, Selected), - basis_add( Selected, Basis), - % eq_classes( NV, NVT, ClassesUniq), % 4 -> var(NV) - equate( ClassesUniq, _), - undet_active( Lin1), - rcbl( Basis, Bind1,BindT) - ). - -% -% Much like solve, but we solve for a particular variable of type -% t_none -% -solve_x( Lin, X) :- - decompose( Lin, H, _, I), - solve_x( H, Lin, I, X, Bindings, []), - export_binding( Bindings). - -solve_x( [], _, I, _, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve_x( H, Lin, _, Selected, Bind0,BindT) :- - H = [_|_], % indexing - sd( H, [],ClassesUniq, 9-9-0,_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( get_atts( Selected, class(NewC)) -> - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; - put_atts( Selected, lin(Lin1)), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,BindT), - eq_classes( NV, NVT, ClassesUniq) - ). - - - -sd( [], Class0,Class0, Preference0,Preference0, NV0,NV0). -sd( [X*K|Xs], Class0,ClassN, Preference0,PreferenceN, NV0,NVt) :- - ( get_atts( X, class(Xc)) -> % old - NV0 = NV1, - ord_add_element( Class0, Xc, Class1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 2-X-K, Preference1) - ; - preference( Preference0, 4-X-K, Preference1) - ) - ; % new - Class1 = Class0, - 'C'( NV0, X, NV1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 1-X-K, Preference1) - ; - preference( Preference0, 3-X-K, Preference1) - ) - ), - sd( Xs, Class1,ClassN, Preference1,PreferenceN, NV1,NVt). - -% -% A is best sofar, B is current -% -preference( A, B, Pref) :- - A = Px-_-_, - B = Py-_-_, - compare( Rel, Px, Py), - ( Rel = =, Pref = B - % ( arith_eval(abs(Ka)= Pref=A ; Pref=B ) - ; Rel = <, Pref = A - ; Rel = >, Pref = B - ). - -% -% equate after attach_class because other classes may contribute -% nonvars and will bind the tail of NV -% -eq_classes( NV, _, Cs) :- var( NV), !, - equate( Cs, _). -eq_classes( NV, NVT, Cs) :- - class_new( Su, NV,NVT, []), - attach_class( NV, Su), - equate( Cs, Su). - -equate( [], _). -equate( [X|Xs], X) :- equate( Xs, X). - -% -% assert: none of the Vars has a class attribute yet -% -attach_class( Xs, _) :- var( Xs), !. -attach_class( [X|Xs], Class) :- - put_atts( X, class(Class)), - attach_class( Xs, Class). - -/** -unconstrained( [X*K|Xs], Uc,Kuc, Rest) :- - ( get_atts( X, type(t_none)) -> - Uc = X, - Kuc = K, - Rest = Xs - ; - Rest = [X*K|Tail], - unconstrained( Xs, Uc,Kuc, Tail) - ). -**/ -/**/ -unconstrained( Lin, Uc,Kuc, Rest) :- - decompose( Lin, H, _, _), - sd( H, [],_, 9-9-0,Category-Uc-_, _,_), - Category =< 2, - delete_factor( Uc, Lin, Rest, Kuc). -/**/ - -% -% point the vars in Lin into the same equivalence class -% maybe join some global data -% -same_class( [], _). -same_class( [X*_|Xs], Class) :- - get_or_add_class( X, Class), - same_class( Xs, Class). - -get_or_add_class( X, Class) :- - get_atts( X, class(ClassX)), - !, - ClassX = Class. % explicit =/2 because of cut -get_or_add_class( X, Class) :- - put_atts( X, class(Class)), - class_new( Class, [X|Tail],Tail, []). % initial class atts - -allvars( X, Allvars) :- - get_atts( X, class(C)), - class_allvars( C, Allvars). - -deactivate_bound( t_l(_), _). -deactivate_bound( t_u(_), _). -deactivate_bound( t_lu(_,_), _). -deactivate_bound( t_L(L), X) :- put_atts( X, type(t_l(L))). -deactivate_bound( t_Lu(L,U), X) :- put_atts( X, type(t_lu(L,U))). -deactivate_bound( t_U(U), X) :- put_atts( X, type(t_u(U))). -deactivate_bound( t_lU(L,U), X) :- put_atts( X, type(t_lu(L,U))). - -intro_at( X, Value, Type) :- - put_atts( X, type(Type)), - ( arith_eval( Value =:= 0) -> - true - ; - backsubst_delta( X, Value) - ). - - -% -% The choice t_lu -> t_Lu is arbitrary -% -undet_active( Lin) :- - decompose( Lin, Lin1, _, _), - undet_active_h( Lin1). - -undet_active_h( []). -undet_active_h( [X*_|Xs]) :- - get_atts( X, type(Type)), - undet_active( Type, X), - undet_active_h( Xs). - -undet_active( t_none, _). % type_activity -undet_active( t_L(_), _). -undet_active( t_Lu(_,_), _). -undet_active( t_U(_), _). -undet_active( t_lU(_,_), _). -undet_active( t_l(L), X) :- intro_at( X, L, t_L(L)). -undet_active( t_u(U), X) :- intro_at( X, U, t_U(U)). -undet_active( t_lu(L,U), X) :- intro_at( X, L, t_Lu(L,U)). - -determine_active_dec( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( -1, Mone), - determine_active( Lin1, Mone). - -determine_active_inc( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( 1, One), - determine_active( Lin1, One). - -determine_active( [], _). -determine_active( [X*K|Xs], S) :- - get_atts( X, type(Type)), - determine_active( Type, X, K, S), - determine_active( Xs, S). - -determine_active( t_L(_), _, _, _). -determine_active( t_Lu(_,_), _, _, _). -determine_active( t_U(_), _, _, _). -determine_active( t_lU(_,_), _, _, _). -determine_active( t_l(L), X, _, _) :- intro_at( X, L, t_L(L)). -determine_active( t_u(U), X, _, _) :- intro_at( X, U, t_U(U)). -determine_active( t_lu(L,U), X, K, S) :- - case_signum( K*S, - intro_at( X, L, t_Lu(L,U)), - fail, - intro_at( X, U, t_lU(L,U))). - -% -% Careful when an indep turns into t_none !!! -% -detach_bounds( V) :- - get_atts( V, lin(Lin)), - put_atts( V, [type(t_none),strictness(2'00)]), - ( indep( Lin, V) -> - ( ub( V, Vub-Vb-_) -> % exchange against thightest - basis_drop( Vub), - pivot( Vub, V, Vb) - ; lb( V, Vlb-Vb-_) -> - basis_drop( Vlb), - pivot( Vlb, V, Vb) - ; - true - ) - ; - basis_drop( V) - ). - -% ----------------------------- manipulate the basis --------------------------- % - -basis_drop( X) :- - get_atts( X, class(Cv)), - class_basis_drop( Cv, X). - -basis( X, Basis) :- - get_atts( X, class(Cv)), - class_basis( Cv, Basis). - -basis_add( X, NewBasis) :- - get_atts( X, class(Cv)), - class_basis_add( Cv, X, NewBasis). - -basis_pivot( Leave, Enter) :- - get_atts( Leave, class(Cv)), - class_basis_pivot( Cv, Enter, Leave). - -% ----------------------------------- pivot ------------------------------------ % - -% -% Pivot ignoring rhs and active states -% -pivot( Dep, Indep) :- - get_atts( Dep, lin(H)), - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( -1, Mone), - arith_eval( 0, Z), - add_linear_ff( H0, K, [Z,Z,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - - -pivot_a( Dep, Indep, Vb,Wd) :- - basis_pivot( Dep, Indep), - pivot( Dep, Indep, Vb), - put_atts( Indep, type(Wd)). - -pivot_b( Vub, V, Vb, Wd) :- - ( Vub == V -> - put_atts( V, type(Vb)), - pivot_b_delta( Vb, Delta), % nonzero(Delta) - backsubst_delta( V, Delta) - ; - pivot_a( Vub, V, Vb,Wd) - ). - -pivot_b_delta( t_Lu(L,U), Delta) :- arith_eval( L-U, Delta). -pivot_b_delta( t_lU(L,U), Delta) :- arith_eval( U-L, Delta). - -select_active_bound( t_L(L), L). -select_active_bound( t_Lu(L,_), L). -select_active_bound( t_U(U), U). -select_active_bound( t_lU(_,U), U). -select_active_bound( t_none, Z) :- arith_eval( 0, Z). -% -% for project.pl -% -select_active_bound( t_l(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_u(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_lu(_,_), Z) :- arith_eval( 0, Z). - - -% -% Pivot taking care of rhs and active states -% -pivot( Dep, Indep, IndAct) :- - get_atts( Dep, lin(H)), - put_atts( Dep, type(IndAct)), - select_active_bound( IndAct, Abv), % Dep or Indep - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( 0, Z), - arith_eval( -1, Mone), - arith_eval( -Abv, Abvm), - add_linear_ff( H0, K, [Z,Abvm,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - -backsubst_delta( X, Delta) :- - arith_eval( 1, One), - arith_eval( 0, Z), - backsubst( X, [Z,Delta,X*One]). - -backsubst( X, Lin) :- - allvars( X, Allvars), - bs( Allvars, X, Lin). -% -% valid if nothing will go ground -% -bs( Xs, _, _) :- var( Xs), !. -bs( [X|Xs], V, Lin) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - bs( Xs, V, Lin) - ; - bs( Xs, V, Lin) - ). - - -% -% rank increasing backsubstitution -% -bs_collect_bindings( Xs, _, _, Bind0,BindT) :- var( Xs), !, Bind0=BindT. -bs_collect_bindings( [X|Xs], V, Lin, Bind0,BindT) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - decompose( LinX1, Hom, _, Inhom), - bs_collect_binding( Hom, X, Inhom, Bind0,Bind1), - bs_collect_bindings( Xs, V, Lin, Bind1,BindT) - ; - bs_collect_bindings( Xs, V, Lin, Bind0,BindT) - ). - -% -% The first clause exports bindings, -% the second (no longer) aliasings -% -bs_collect_binding( [], X, Inhom) --> [ X-Inhom ]. -bs_collect_binding( [_|_], _, _) --> []. -/* -bs_collect_binding( [Y*K|Ys], X, Inhom) --> - ( { Ys = [], - Y \== X, - arith_eval( K=:=1), - arith_eval( Inhom=:=0) - } -> - [ X-Y ] - ; - [] - ). -*/ - -% -% reconsider the basis -% -rcbl( [], Bind0,Bind0). -rcbl( [X|Continuation], Bind0,BindT) :- - ( rcb( X, Status, Violated) -> % have a culprit - rcbl_status( Status, X, Continuation, Bind0,BindT, Violated) - ; - rcbl( Continuation, Bind0,BindT) - ). - -% -% reconsider one element of the basis -% later: lift the binds -% -reconsider( X) :- - rcb( X, Status, Violated), - !, - rcbl_status( Status, X, [], Binds,[], Violated), - export_binding( Binds). -reconsider( _). - -% -% Find a basis variable out of its bound or at its bound -% Try to move it into whithin its bound -% a) impossible -> fail -% b) optimum at the bound -> implied value -% c) else look at the remaining basis variables -% -rcb( X, Status, Violated) :- - get_atts( X, [lin(Lin),type(Type)]), - decompose( Lin, H, R, I), - ( Type = t_l(L), - arith_eval( R+I =< L), - Violated = l(L), - inc_step( H, Status) - - ; Type = t_u(U), - arith_eval( R+I >= U), - Violated = u(U), - dec_step( H, Status) - - ; Type = t_lu(L,U), - arith_eval( R+I, At), - ( - arith_eval( At =< L), - Violated = l(L), - inc_step( H, Status) - ; - arith_eval( At >= U), - Violated = u(U), - dec_step( H, Status) - ) - % - % don't care for other types - % - ). - -rcbl_status( optimum, X, Cont, B0,Bt, Violated) :- rcbl_opt( Violated, X, Cont, B0,Bt). -rcbl_status( applied, X, Cont, B0,Bt, Violated) :- rcbl_app( Violated, X, Cont, B0,Bt). -rcbl_status( unlimited(Indep,DepT), X, Cont, B0,Bt, Violated) :- rcbl_unl( Violated, X, Cont, B0,Bt, Indep, DepT). - -% -% Might reach optimum immediately without changing the basis, -% but in general we must assume that there were pivots. -% If the optimum meets the bound, we backsubstitute the implied -% value, solve will call us again to check for further implied -% values or unsatisfiability in the rank increased system. -% -rcbl_opt( l(L), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( L-Opt, - ( - narrow_u( Type, X, Opt), % { X =< Opt } - rcbl( Continuation, B0,B1) - ), - ( - Strict /\ 2'10 =:= 0, % meets lower - arith_eval( -Opt, Mop), - 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) - ) - ), - fail - ). -rcbl_opt( u(U), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( U-Opt, - fail, - ( - Strict /\ 2'01 =:= 0, % meets upper - arith_eval( -Opt, Mop), - 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) - ) - ), - ( - narrow_l( Type, X, Opt), % { X >= Opt } - rcbl( Continuation, B0,B1) - )). - -% -% Basis has already changed when this is called -% -rcbl_app( l(L), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I > L) -> % within bound now - rcbl( Continuation, B0,B1) - ; - % arith_eval( R+I, Val), print( rcbl_app(X:L:Val)), nl, - inc_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, l(L)) - ). -rcbl_app( u(U), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I < U) -> % within bound now - rcbl( Continuation, B0,B1) - ; - dec_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, u(U)) - ). - -% -% This is never called for a t_lu culprit -% -rcbl_unl( l(L), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_L(L), DepT), % changes the basis - rcbl( Continuation, B0,B1). -rcbl_unl( u(U), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_U(U), DepT), % changes the basis - rcbl( Continuation, B0,B1). - -narrow_u( t_u(_), X, U) :- put_atts( X, type(t_u(U))). -narrow_u( t_lu(L,_), X, U) :- put_atts( X, type(t_lu(L,U))). - -narrow_l( t_l(_), X, L) :- put_atts( X, type(t_l(L))). -narrow_l( t_lu(_,U), X, L) :- put_atts( X, type(t_lu(L,U))). - -% ----------------------------------- dump ------------------------------------- - -dump_var( t_none, V, I,H) --> !, - ( { H=[W*K],V==W,arith_eval(I=:=0),arith_eval(K=:=1) } -> % indep var - [] - ; - { nf2sum( H, I, Sum) }, - [ V = Sum ] - ). -dump_var( t_L(L), V, I,H) --> !, dump_var( t_l(L), V, I,H). -dump_var( t_l(L), V, I,H) --> !, - { - H= [_*K|_], % avoid 1 >= 0 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'10, - arith_eval( 1/K, Kr), - arith_eval( Kr*(L-I), Li), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum >= Li, Sum > Li, Result) - ; - dump_strict( Sm, Sum =< Li, Sum < Li, Result) - ) - }, - [ Result ]. -dump_var( t_U(U), V, I,H) --> !, dump_var( t_u(U), V, I,H). -dump_var( t_u(U), V, I,H) --> !, - { - H= [_*K|_], % avoid 0 =< 1 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'01, - arith_eval( 1/K, Kr), - arith_eval( Kr*(U-I), Ui), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum =< Ui, Sum < Ui, Result) - ; - dump_strict( Sm, Sum >= Ui, Sum > Ui, Result) - ) - }, - [ Result ]. -dump_var( t_Lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lU(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( T, V, I,H) --> - [ V:T:I+H ]. - -dump_strict( 0, Result, _, Result). -dump_strict( 1, _, Result, Result). -dump_strict( 2, _, Result, Result). - -dump_nz( _, H, I) --> - { - H = [_*K|_], - arith_eval( 1/K, Kr), - arith_eval( -Kr*I, I1), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum) - }, - [ Sum =\= I1 ]. diff --git a/CLPQR/clpq/bv.yap b/CLPQR/clpq/bv.yap deleted file mode 100644 index 5f44f498f..000000000 --- a/CLPQR/clpq/bv.yap +++ /dev/null @@ -1,1256 +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: bv.pl % -% Author: Christian Holzbaur christian@ai.univie.ac.at % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -% -% simplex with bounded variables, ch, 93/12 -% - -% -% TODO: +) var/bound/state classification and maintainance -% +) inc/dec_step: take the best?, at least find unconstrained var first -% +) trivially implied values -% +) avoid eval_rhs through an extra column (Coeff=Rhs) -% +) if an optimum is encountered, record the value as bound !!! -% +) generalized (transparent) attribute handling -% +) coordinate reconsideration cascades -% +) =\= -% +) strict inequalities via =\= -% -) decompose via nonvar test -> no symbolic constants any more ? -% constants complicate the nonlin solver anyway ... -% +) join t_l,l(L), .... into t_l(L), ... -% +) shortcuts for strict ineqs -% -) extra types for vars with l/u bound zero -% -) occurrence lists for indep vars (with coeffs) ??? -% each solve produces one dep var -> push -% only complication: pivots -% -) *incremental* REVISED simplex ?!! -% -% sicstus2.1.9.clp conversion: -% -% -) stable ordering through extra attribute ... -% interpreted vs compiled yields different var order -% -> nasty in R (need different eps) -% -% -) check determinism again -% -% - -:- public {}/1, maximize/1, minimize/1, sup/2, inf/2, imin/2. % xref.pl - -:- use_module( library(ordsets), [ord_add_element/3]). - -% :- use_module( library(deterministic)). - -% -% For the rhs maint. the following events are important: -% -% -) introduction of an indep var at active bound B -% -) narrowing of active bound -% -) swap active bound -% -) pivot -% - -% -% a variables bound (L/U) can have the states: -% -% -) t_none -% -) t_l has a lower bound (not active yet) -% -) t_u -% -) t_L has an active lower bound -% -) t_U -% -) t_lu -% -) t_Lu -% -) t_lU -% - -% ----------------------------------- deref ------------------------------------ % - -:- mode deref( +, -). -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - length( H, Len), - log_deref( Len, H, [], Restd), - add_linear_11( Nonvar, Restd, Lind). - -:- mode log_deref( +, +, -, -). -% -log_deref( 0, Vs, Vs, Lin) :- !, - arith_eval( 0, Z), - Lin = [Z,Z]. -log_deref( 1, [v(K,[X^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - mult_linear_factor( Lx, K, Lin). -log_deref( 2, [v(Kx,[X^1]),v(Ky,[Y^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - deref_var( Y, Ly), - add_linear_ff( Lx, Kx, Ly, Ky, Lin). -log_deref( N, V0, V2, Lin) :- - P is N >> 1, - Q is N - P, - log_deref( P, V0,V1, Lp), - log_deref( Q, V1,V2, Lq), - add_linear_11( Lp, Lq, Lin). - -/* -% -% tail recursive version -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - lin_deref( H, Nonvar, Lind). - -log_deref( _, Lin, [], Res) :- % called from nf.pl - arith_eval( 0, Z), - lin_deref( Lin, [Z,Z], Res). - -lin_deref( [], Ld, Ld). -lin_deref( [v(K,[X^1])|Vs], Li, Lo) :- - deref_var( X, Lx), - add_linear_f1( Lx, K, Li, Lii), - lin_deref( Vs, Lii, Lo). -*/ - -% -% If we see a nonvar here, this is a fault -% -deref_var( X, Lin) :- - get_atts( X, lin(Lin)), !. -deref_var( X, Lin) :- % create a linear var - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,X*One], - put_atts( X, [order(_),lin(Lin),type(t_none),strictness(2'00)]). - -var_with_def_assign( Var, Lin) :- - decompose( Lin, Hom, _, I), - ( Hom = [], % X=k - Var = I - ; Hom = [V*K|Cs], - ( Cs = [], - arith_eval(K=:=1), - arith_eval(I=:=0) -> % X=Y - Var = V - ; % general case - var_with_def_intern( t_none, Var, Lin, 2'00) - ) - ). - -var_with_def_intern( Type, Var, Lin, Strict) :- - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - decompose( Lin, Hom, _, _), - get_or_add_class( Var, Class), - same_class( Hom, Class). - -var_intern( Type, Var, Strict) :- - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,Var*One], - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - get_or_add_class( Var, _Class). - -% ------------------------------------------------------------------------------ - -% -% [V-Binding]* -% Only place where the linear solver binds variables -% -export_binding( []). -export_binding( [X-Y|Gs]) :- - export_binding( Y, X), - export_binding( Gs). - -% -% numerical stabilizer, clp(r) only -% -export_binding( Y, X) :- var(Y), Y=X. -export_binding( Y, X) :- nonvar(Y), - ( arith_eval( Y=:=0) -> - arith_eval( 0, X) - ; - Y = X - ). - -'solve_='( Nf) :- - deref( Nf, Nfd), - solve( Nfd). - -'solve_=\\='( Nf) :- - deref( Nf, Lind), - decompose( Lind, Hom, _, Inhom), - ( Hom = [], arith_eval( Inhom =\= 0) - ; Hom = [_|_], var_with_def_intern( t_none, Nz, Lind, 2'00), - put_atts( Nz, nonzero) - ). - -'solve_<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, strict). - -'solve_=<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, nonstrict). - -maximize( Term) :- - minimize( -Term). - -% -% This is NOT coded as minimize(Expr) :- inf(Expr,Expr). -% -% because the new version of inf/2 only visits -% the vertex where the infimum is assumed and returns -% to the 'current' vertex via backtracking. -% The rationale behind this construction is to eliminate -% all garbage in the solver data structures produced by -% the pivots on the way to the extremal point caused by -% {inf,sup}/{2,4}. -% -% If we are after the infimum/supremum for minimizing/maximizing, -% this strategy may have adverse effects on performance because -% the simplex algorithm is forced to re-discover the -% extremal vertex through the equation {Inf =:= Expr}. -% -% Thus the extra code for {minimize,maximize}/1. -% -% In case someone comes up with an example where -% -% inf(Expr,Expr) -% -% outperforms the provided formulation for minimize - so be it. -% Both forms are available to the user. -% -minimize( Term) :- - wait_linear( Term, Nf, minimize_lin(Nf)). - -minimize_lin( Lin) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - { Dep =:= Inf }. - -sup( Expression, Sup) :- - sup( Expression, Sup, [], []). - -sup( Expression, Sup, Vector, Vertex) :- - inf( -Expression, -Sup, Vector, Vertex). - -inf( Expression, Inf) :- - inf( Expression, Inf, [], []). - -inf( Expression, Inf, Vector, Vertex) :- - wait_linear( Expression, Nf, inf_lin(Nf,Inf,Vector,Vertex)). - -inf_lin( Lin, _, Vector, _) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - vertex_value( Vector, Values), - bb_put( inf, [Inf|Values]), - fail. -inf_lin( _, Infimum, _, Vertex) :- - bb_delete( inf, L), - assign( [Infimum|Vertex], L). - -assign( [], []). -assign( [X|Xs], [Y|Ys]) :- - {X =:= Y}, % more defensive/expressive than X=Y - assign( Xs, Ys). - -% --------------------------------- optimization ------------------------------- % -% -% The _sn(S) =< 0 row might be temporarily infeasible. -% We use reconsider/1 to fix this. -% -% s(S) e [_,0] = d +xi ... -xj, Rhs > 0 so we want to decrease s(S) -% -% positive xi would have to be moved towards their lower bound, -% negative xj would have to be moved towards their upper bound, -% -% the row s(S) does not limit the lower bound of xi -% the row s(S) does not limit the upper bound of xj -% -% a) if some other row R is limiting xk, we pivot(R,xk), -% s(S) will decrease and get more feasible until (b) -% b) if there is no limiting row for some xi: we pivot(s(S),xi) -% xj: we pivot(s(S),xj) -% which cures the infeasibility in one step -% - - -% -% fails if Status = unlimited/2 -% -iterate_dec( OptVar, Opt) :- - get_atts( OptVar, lin(Lin)), - decompose( Lin, H, R, I), - - % arith_eval( R+I, Now), print(min(Now)), nl, - - % dec_step_best( H, Status), - dec_step( H, Status), - ( 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) - ). - -% -% Status = {optimum,unlimited(Indep,DepT),applied} -% If Status = optimum, the tables have not been changed at all. -% Searches left to right, does not try to find the 'best' pivot -% Therefore we might discover unboundedness only after a few pivots -% -dec_step( [], optimum). -dec_step( [V*K|Vs], Status) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; 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), - ( arith_eval( K < 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K > 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_none, - Status = unlimited(V,t_none) - ). - -% ------------------------------ best first heuristic -------------------------- % -% -% A replacement for dec_step/2 that uses a local best first heuristic. -% -% - -dec_step_best( H, Status) :- - dec_eval( H, E), - ( E = unlimited(_,_), - Status = E - ; E = [], - Status = optimum - ; E = [_|_], - Status = applied, - keysort( E, [_-Best|_]), - ( Best = pivot_a(Vub,V,Vb,Wd), pivot_a(Vub,V,Vb,Wd) - ; Best = pivot_b(Vub,V,Vb,Wd), pivot_b(Vub,V,Vb,Wd) - ) - ). - -dec_eval( [], []). -dec_eval( [V*K|Vs], Res) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_u(U)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_u(U)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_l(L)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_l(L)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_none, - Res = unlimited(V,t_none) - ). - -% ------------------------- find the most constraining row --------------------- % -% -% The code for the lower and the upper bound are dual versions of each other. -% The only difference is in the orientation of the comparisons. -% Indeps are ruled out by their types. -% If there is no bound, this fails. -% -% *** The actual lb and ub on an indep variable X are [lu]b + b(X), where b(X) -% is the value of the active bound. -% -% Nota bene: We must NOT consider infeasible rows as candidates to -% leave the basis! -% - -ub( X, Ub) :- - basis( X, Deps), - ub_first( Deps, X, Ub). - -:- mode ub_first( +, ?, -). -% -ub_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - arith_eval( Ub >= 0) -> - ub( Deps, X, Dep-W-Ub, Tightest) - ; - ub_first( Deps, X, Tightest) - ). - -% -% Invariant: Ub >= 0 and decreasing -% -:- mode ub( +, ?, +, -). -% -ub( [], _, T0,T0). -ub( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - T0 = _-Ubb, - arith_eval( Ub < Ubb), - arith_eval( Ub >= 0) -> % rare failure - ub( Deps, X, Dep-W-Ub,T1) - ; - ub( Deps, X, T0,T1) - ). - -lb( X, Lb) :- - basis( X, Deps), - lb_first( Deps, X, Lb). - -:- mode lb_first( +, ?, -). -% -lb_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - arith_eval( Lb =< 0) -> - lb( Deps, X, Dep-W-Lb, Tightest) - ; - lb_first( Deps, X, Tightest) - ). - -% -% Invariant: Lb =< 0 and increasing -% -:- mode lb( +, ?, +, -). -% -lb( [], _, T0,T0). -lb( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - T0 = _-Lbb, - arith_eval( Lb > Lbb), - arith_eval( Lb =< 0) -> % rare failure - lb( Deps, X, Dep-W-Lb,T1) - ; - lb( Deps, X, T0,T1) - ). - -% -% Lb =< 0 for feasible rows -% -:- mode lb_inner( +, ?, +, -, -). -% -lb_inner( t_l(L), X, Lin, t_L(L), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (L-Rhs)/K, Lb). -lb_inner( t_u(U), X, Lin, t_U(U), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (U-Rhs)/K, Lb). -lb_inner( t_lu(L,U), X, Lin, W, Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Lb) - ), - fail, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Lb) - )). - -% -% Ub >= 0 for feasible rows -% -:- mode ub_inner( +, ?, +, -, -). -% -ub_inner( t_l(L), X, Lin, t_L(L), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (L-Rhs)/K, Ub). -ub_inner( t_u(U), X, Lin, t_U(U), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (U-Rhs)/K, Ub). -ub_inner( t_lu(L,U), X, Lin, W, Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Ub) - ), - fail, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Ub) - )). - -% ---------------------------------- equations --------------------------------- % -% -% backsubstitution will not make the system infeasible, if the bounds on the indep -% vars are obeyed, but some implied values might pop up in rows where X occurs -% -) special case X=Y during bs -> get rid of dependend var(s), alias -% - -solve( Lin) :- - decompose( Lin, H, _, I), - solve( H, Lin, I, Bindings, []), - export_binding( Bindings). - -solve( [], _, I, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve( H, Lin, _, Bind0,BindT) :- - H = [_|_], % indexing - % - % [] is an empty ord_set, anything will be preferred - % over 9-9 - % - sd( H, [],ClassesUniq, 9-9-0,Category-Selected-_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( 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, - get_atts( Selected, class(NewC)), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; Category = 3, - put_atts( Selected, lin(Lin1)), - get_atts( Selected, type(Type)), - deactivate_bound( Type, Selected), - eq_classes( NV, NVT, ClassesUniq), - basis_add( Selected, Basis), - undet_active( Lin1), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,Bind1), - rcbl( Basis, Bind1,BindT) - ; Category = 4, - get_atts( Selected, [type(Type),class(NewC)]), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,Bind1) - ; - Bind0 = Bind1, - bs( Deps, Selected, Lin1) - ), - deactivate_bound( Type, Selected), - basis_add( Selected, Basis), - % eq_classes( NV, NVT, ClassesUniq), % 4 -> var(NV) - equate( ClassesUniq, _), - undet_active( Lin1), - rcbl( Basis, Bind1,BindT) - ). - -% -% Much like solve, but we solve for a particular variable of type -% t_none -% -solve_x( Lin, X) :- - decompose( Lin, H, _, I), - solve_x( H, Lin, I, X, Bindings, []), - export_binding( Bindings). - -solve_x( [], _, I, _, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve_x( H, Lin, _, Selected, Bind0,BindT) :- - H = [_|_], % indexing - sd( H, [],ClassesUniq, 9-9-0,_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( get_atts( Selected, class(NewC)) -> - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; - put_atts( Selected, lin(Lin1)), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,BindT), - eq_classes( NV, NVT, ClassesUniq) - ). - - - -sd( [], Class0,Class0, Preference0,Preference0, NV0,NV0). -sd( [X*K|Xs], Class0,ClassN, Preference0,PreferenceN, NV0,NVt) :- - ( get_atts( X, class(Xc)) -> % old - NV0 = NV1, - ord_add_element( Class0, Xc, Class1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 2-X-K, Preference1) - ; - preference( Preference0, 4-X-K, Preference1) - ) - ; % new - Class1 = Class0, - 'C'( NV0, X, NV1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 1-X-K, Preference1) - ; - preference( Preference0, 3-X-K, Preference1) - ) - ), - sd( Xs, Class1,ClassN, Preference1,PreferenceN, NV1,NVt). - -% -% A is best sofar, B is current -% -preference( A, B, Pref) :- - A = Px-_-_, - B = Py-_-_, - compare( Rel, Px, Py), - ( Rel = =, Pref = B - % ( arith_eval(abs(Ka)= Pref=A ; Pref=B ) - ; Rel = <, Pref = A - ; Rel = >, Pref = B - ). - -% -% equate after attach_class because other classes may contribute -% nonvars and will bind the tail of NV -% -eq_classes( NV, _, Cs) :- var( NV), !, - equate( Cs, _). -eq_classes( NV, NVT, Cs) :- - class_new( Su, NV,NVT, []), - attach_class( NV, Su), - equate( Cs, Su). - -equate( [], _). -equate( [X|Xs], X) :- equate( Xs, X). - -% -% assert: none of the Vars has a class attribute yet -% -attach_class( Xs, _) :- var( Xs), !. -attach_class( [X|Xs], Class) :- - put_atts( X, class(Class)), - attach_class( Xs, Class). - -/** -unconstrained( [X*K|Xs], Uc,Kuc, Rest) :- - ( get_atts( X, type(t_none)) -> - Uc = X, - Kuc = K, - Rest = Xs - ; - Rest = [X*K|Tail], - unconstrained( Xs, Uc,Kuc, Tail) - ). -**/ -/**/ -unconstrained( Lin, Uc,Kuc, Rest) :- - decompose( Lin, H, _, _), - sd( H, [],_, 9-9-0,Category-Uc-_, _,_), - Category =< 2, - delete_factor( Uc, Lin, Rest, Kuc). -/**/ - -% -% point the vars in Lin into the same equivalence class -% maybe join some global data -% -same_class( [], _). -same_class( [X*_|Xs], Class) :- - get_or_add_class( X, Class), - same_class( Xs, Class). - -get_or_add_class( X, Class) :- - get_atts( X, class(ClassX)), - !, - ClassX = Class. % explicit =/2 because of cut -get_or_add_class( X, Class) :- - put_atts( X, class(Class)), - class_new( Class, [X|Tail],Tail, []). % initial class atts - -allvars( X, Allvars) :- - get_atts( X, class(C)), - class_allvars( C, Allvars). - -deactivate_bound( t_l(_), _). -deactivate_bound( t_u(_), _). -deactivate_bound( t_lu(_,_), _). -deactivate_bound( t_L(L), X) :- put_atts( X, type(t_l(L))). -deactivate_bound( t_Lu(L,U), X) :- put_atts( X, type(t_lu(L,U))). -deactivate_bound( t_U(U), X) :- put_atts( X, type(t_u(U))). -deactivate_bound( t_lU(L,U), X) :- put_atts( X, type(t_lu(L,U))). - -intro_at( X, Value, Type) :- - put_atts( X, type(Type)), - ( arith_eval( Value =:= 0) -> - true - ; - backsubst_delta( X, Value) - ). - - -% -% The choice t_lu -> t_Lu is arbitrary -% -undet_active( Lin) :- - decompose( Lin, Lin1, _, _), - undet_active_h( Lin1). - -undet_active_h( []). -undet_active_h( [X*_|Xs]) :- - get_atts( X, type(Type)), - undet_active( Type, X), - undet_active_h( Xs). - -undet_active( t_none, _). % type_activity -undet_active( t_L(_), _). -undet_active( t_Lu(_,_), _). -undet_active( t_U(_), _). -undet_active( t_lU(_,_), _). -undet_active( t_l(L), X) :- intro_at( X, L, t_L(L)). -undet_active( t_u(U), X) :- intro_at( X, U, t_U(U)). -undet_active( t_lu(L,U), X) :- intro_at( X, L, t_Lu(L,U)). - -determine_active_dec( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( -1, Mone), - determine_active( Lin1, Mone). - -determine_active_inc( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( 1, One), - determine_active( Lin1, One). - -determine_active( [], _). -determine_active( [X*K|Xs], S) :- - get_atts( X, type(Type)), - determine_active( Type, X, K, S), - determine_active( Xs, S). - -determine_active( t_L(_), _, _, _). -determine_active( t_Lu(_,_), _, _, _). -determine_active( t_U(_), _, _, _). -determine_active( t_lU(_,_), _, _, _). -determine_active( t_l(L), X, _, _) :- intro_at( X, L, t_L(L)). -determine_active( t_u(U), X, _, _) :- intro_at( X, U, t_U(U)). -determine_active( t_lu(L,U), X, K, S) :- - case_signum( K*S, - intro_at( X, L, t_Lu(L,U)), - fail, - intro_at( X, U, t_lU(L,U))). - -% -% Careful when an indep turns into t_none !!! -% -detach_bounds( V) :- - get_atts( V, lin(Lin)), - put_atts( V, [type(t_none),strictness(2'00)]), - ( indep( Lin, V) -> - ( ub( V, Vub-Vb-_) -> % exchange against thightest - basis_drop( Vub), - pivot( Vub, V, Vb) - ; lb( V, Vlb-Vb-_) -> - basis_drop( Vlb), - pivot( Vlb, V, Vb) - ; - true - ) - ; - basis_drop( V) - ). - -% ----------------------------- manipulate the basis --------------------------- % - -basis_drop( X) :- - get_atts( X, class(Cv)), - class_basis_drop( Cv, X). - -basis( X, Basis) :- - get_atts( X, class(Cv)), - class_basis( Cv, Basis). - -basis_add( X, NewBasis) :- - get_atts( X, class(Cv)), - class_basis_add( Cv, X, NewBasis). - -basis_pivot( Leave, Enter) :- - get_atts( Leave, class(Cv)), - class_basis_pivot( Cv, Enter, Leave). - -% ----------------------------------- pivot ------------------------------------ % - -% -% Pivot ignoring rhs and active states -% -pivot( Dep, Indep) :- - get_atts( Dep, lin(H)), - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( -1, Mone), - arith_eval( 0, Z), - add_linear_ff( H0, K, [Z,Z,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - - -pivot_a( Dep, Indep, Vb,Wd) :- - basis_pivot( Dep, Indep), - pivot( Dep, Indep, Vb), - put_atts( Indep, type(Wd)). - -pivot_b( Vub, V, Vb, Wd) :- - ( Vub == V -> - put_atts( V, type(Vb)), - pivot_b_delta( Vb, Delta), % nonzero(Delta) - backsubst_delta( V, Delta) - ; - pivot_a( Vub, V, Vb,Wd) - ). - -pivot_b_delta( t_Lu(L,U), Delta) :- arith_eval( L-U, Delta). -pivot_b_delta( t_lU(L,U), Delta) :- arith_eval( U-L, Delta). - -select_active_bound( t_L(L), L). -select_active_bound( t_Lu(L,_), L). -select_active_bound( t_U(U), U). -select_active_bound( t_lU(_,U), U). -select_active_bound( t_none, Z) :- arith_eval( 0, Z). -% -% for project.pl -% -select_active_bound( t_l(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_u(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_lu(_,_), Z) :- arith_eval( 0, Z). - - -% -% Pivot taking care of rhs and active states -% -pivot( Dep, Indep, IndAct) :- - get_atts( Dep, lin(H)), - put_atts( Dep, type(IndAct)), - select_active_bound( IndAct, Abv), % Dep or Indep - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( 0, Z), - arith_eval( -1, Mone), - arith_eval( -Abv, Abvm), - add_linear_ff( H0, K, [Z,Abvm,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - -backsubst_delta( X, Delta) :- - arith_eval( 1, One), - arith_eval( 0, Z), - backsubst( X, [Z,Delta,X*One]). - -backsubst( X, Lin) :- - allvars( X, Allvars), - bs( Allvars, X, Lin). -% -% valid if nothing will go ground -% -bs( Xs, _, _) :- var( Xs), !. -bs( [X|Xs], V, Lin) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - bs( Xs, V, Lin) - ; - bs( Xs, V, Lin) - ). - - -% -% rank increasing backsubstitution -% -bs_collect_bindings( Xs, _, _, Bind0,BindT) :- var( Xs), !, Bind0=BindT. -bs_collect_bindings( [X|Xs], V, Lin, Bind0,BindT) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - decompose( LinX1, Hom, _, Inhom), - bs_collect_binding( Hom, X, Inhom, Bind0,Bind1), - bs_collect_bindings( Xs, V, Lin, Bind1,BindT) - ; - bs_collect_bindings( Xs, V, Lin, Bind0,BindT) - ). - -% -% The first clause exports bindings, -% the second (no longer) aliasings -% -bs_collect_binding( [], X, Inhom) --> [ X-Inhom ]. -bs_collect_binding( [_|_], _, _) --> []. -/* -bs_collect_binding( [Y*K|Ys], X, Inhom) --> - ( { Ys = [], - Y \== X, - arith_eval( K=:=1), - arith_eval( Inhom=:=0) - } -> - [ X-Y ] - ; - [] - ). -*/ - -% -% reconsider the basis -% -rcbl( [], Bind0,Bind0). -rcbl( [X|Continuation], Bind0,BindT) :- - ( rcb( X, Status, Violated) -> % have a culprit - rcbl_status( Status, X, Continuation, Bind0,BindT, Violated) - ; - rcbl( Continuation, Bind0,BindT) - ). - -% -% reconsider one element of the basis -% later: lift the binds -% -reconsider( X) :- - rcb( X, Status, Violated), - !, - rcbl_status( Status, X, [], Binds,[], Violated), - export_binding( Binds). -reconsider( _). - -% -% Find a basis variable out of its bound or at its bound -% Try to move it into whithin its bound -% a) impossible -> fail -% b) optimum at the bound -> implied value -% c) else look at the remaining basis variables -% -rcb( X, Status, Violated) :- - get_atts( X, [lin(Lin),type(Type)]), - decompose( Lin, H, R, I), - ( Type = t_l(L), - arith_eval( R+I =< L), - Violated = l(L), - inc_step( H, Status) - - ; Type = t_u(U), - arith_eval( R+I >= U), - Violated = u(U), - dec_step( H, Status) - - ; Type = t_lu(L,U), - arith_eval( R+I, At), - ( - arith_eval( At =< L), - Violated = l(L), - inc_step( H, Status) - ; - arith_eval( At >= U), - Violated = u(U), - dec_step( H, Status) - ) - % - % don't care for other types - % - ). - -rcbl_status( optimum, X, Cont, B0,Bt, Violated) :- rcbl_opt( Violated, X, Cont, B0,Bt). -rcbl_status( applied, X, Cont, B0,Bt, Violated) :- rcbl_app( Violated, X, Cont, B0,Bt). -rcbl_status( unlimited(Indep,DepT), X, Cont, B0,Bt, Violated) :- rcbl_unl( Violated, X, Cont, B0,Bt, Indep, DepT). - -% -% Might reach optimum immediately without changing the basis, -% but in general we must assume that there were pivots. -% If the optimum meets the bound, we backsubstitute the implied -% value, solve will call us again to check for further implied -% values or unsatisfiability in the rank increased system. -% -rcbl_opt( l(L), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( L-Opt, - ( - narrow_u( Type, X, Opt), % { X =< Opt } - rcbl( Continuation, B0,B1) - ), - ( - Strict /\ 2'10 =:= 0, % meets lower - arith_eval( -Opt, Mop), - 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) - ) - ), - fail - ). -rcbl_opt( u(U), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( U-Opt, - fail, - ( - Strict /\ 2'01 =:= 0, % meets upper - arith_eval( -Opt, Mop), - 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) - ) - ), - ( - narrow_l( Type, X, Opt), % { X >= Opt } - rcbl( Continuation, B0,B1) - )). - -% -% Basis has already changed when this is called -% -rcbl_app( l(L), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I > L) -> % within bound now - rcbl( Continuation, B0,B1) - ; - % arith_eval( R+I, Val), print( rcbl_app(X:L:Val)), nl, - inc_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, l(L)) - ). -rcbl_app( u(U), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I < U) -> % within bound now - rcbl( Continuation, B0,B1) - ; - dec_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, u(U)) - ). - -% -% This is never called for a t_lu culprit -% -rcbl_unl( l(L), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_L(L), DepT), % changes the basis - rcbl( Continuation, B0,B1). -rcbl_unl( u(U), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_U(U), DepT), % changes the basis - rcbl( Continuation, B0,B1). - -narrow_u( t_u(_), X, U) :- put_atts( X, type(t_u(U))). -narrow_u( t_lu(L,_), X, U) :- put_atts( X, type(t_lu(L,U))). - -narrow_l( t_l(_), X, L) :- put_atts( X, type(t_l(L))). -narrow_l( t_lu(_,U), X, L) :- put_atts( X, type(t_lu(L,U))). - -% ----------------------------------- dump ------------------------------------- - -dump_var( t_none, V, I,H) --> !, - ( { H=[W*K],V==W,arith_eval(I=:=0),arith_eval(K=:=1) } -> % indep var - [] - ; - { nf2sum( H, I, Sum) }, - [ V = Sum ] - ). -dump_var( t_L(L), V, I,H) --> !, dump_var( t_l(L), V, I,H). -dump_var( t_l(L), V, I,H) --> !, - { - H= [_*K|_], % avoid 1 >= 0 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'10, - arith_eval( 1/K, Kr), - arith_eval( Kr*(L-I), Li), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum >= Li, Sum > Li, Result) - ; - dump_strict( Sm, Sum =< Li, Sum < Li, Result) - ) - }, - [ Result ]. -dump_var( t_U(U), V, I,H) --> !, dump_var( t_u(U), V, I,H). -dump_var( t_u(U), V, I,H) --> !, - { - H= [_*K|_], % avoid 0 =< 1 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'01, - arith_eval( 1/K, Kr), - arith_eval( Kr*(U-I), Ui), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum =< Ui, Sum < Ui, Result) - ; - dump_strict( Sm, Sum >= Ui, Sum > Ui, Result) - ) - }, - [ Result ]. -dump_var( t_Lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lU(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( T, V, I,H) --> - [ V:T:I+H ]. - -dump_strict( 0, Result, _, Result). -dump_strict( 1, _, Result, Result). -dump_strict( 2, _, Result, Result). - -dump_nz( _, H, I) --> - { - H = [_*K|_], - arith_eval( 1/K, Kr), - arith_eval( -Kr*I, I1), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum) - }, - [ Sum =\= I1 ]. diff --git a/CLPQR/clpq/compenv.pl b/CLPQR/clpq/compenv.pl deleted file mode 100644 index e91933936..000000000 --- a/CLPQR/clpq/compenv.pl +++ /dev/null @@ -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). - diff --git a/CLPQR/clpq/dump.pl b/CLPQR/clpq/dump.pl deleted file mode 100644 index 54e957c7b..000000000 --- a/CLPQR/clpq/dump.pl +++ /dev/null @@ -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. diff --git a/CLPQR/clpq/fourmotz.pl b/CLPQR/clpq/fourmotz.pl deleted file mode 100644 index c0dd77f29..000000000 --- a/CLPQR/clpq/fourmotz.pl +++ /dev/null @@ -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) - ). diff --git a/CLPQR/clpq/geler.yap b/CLPQR/clpq/geler.yap index e8a9884b3..7ddda9800 100644 --- a/CLPQR/clpq/geler.yap +++ b/CLPQR/clpq/geler.yap @@ -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(+,:). diff --git a/CLPQR/clpq/ineq.pl b/CLPQR/clpq/ineq.pl deleted file mode 100644 index 1456bb279..000000000 --- a/CLPQR/clpq/ineq.pl +++ /dev/null @@ -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). diff --git a/CLPQR/clpq/itf3.pl b/CLPQR/clpq/itf3.pl deleted file mode 100644 index 823e58d50..000000000 --- a/CLPQR/clpq/itf3.pl +++ /dev/null @@ -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( _, _). - - - - - - - diff --git a/CLPQR/clpq/nf.pl b/CLPQR/clpq/nf.pl deleted file mode 100644 index fc2b3a257..000000000 --- a/CLPQR/clpq/nf.pl +++ /dev/null @@ -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) :- !. -negate( A>B, A=B) :- !. -negate( A>=B, A 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). - diff --git a/CLPQR/clpq/nf.yap b/CLPQR/clpq/nf.yap deleted file mode 100644 index fc2b3a257..000000000 --- a/CLPQR/clpq/nf.yap +++ /dev/null @@ -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) :- !. -negate( A>B, A=B) :- !. -negate( A>=B, A 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). - diff --git a/CLPQR/clpq/ordering.pl b/CLPQR/clpq/ordering.pl deleted file mode 100644 index 3a0df5cac..000000000 --- a/CLPQR/clpq/ordering.pl +++ /dev/null @@ -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 - 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 []. -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) - ). - diff --git a/CLPQR/clpq/project.pl b/CLPQR/clpq/project.pl deleted file mode 100644 index 972788fa1..000000000 --- a/CLPQR/clpq/project.pl +++ /dev/null @@ -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) - ). - diff --git a/CLPQR/clpq/redund.pl b/CLPQR/clpq/redund.pl deleted file mode 100644 index 1c7c807ec..000000000 --- a/CLPQR/clpq/redund.pl +++ /dev/null @@ -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. - - diff --git a/CLPQR/clpr/bb.yap b/CLPQR/clpqr/bb.yap similarity index 94% rename from CLPQR/clpr/bb.yap rename to CLPQR/clpqr/bb.yap index 0b697b0d9..7ef330b7d 100644 --- a/CLPQR/clpr/bb.yap +++ b/CLPQR/clpqr/bb.yap @@ -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), diff --git a/CLPQR/clpr/bv.yap b/CLPQR/clpqr/bv.yap similarity index 96% rename from CLPQR/clpr/bv.yap rename to CLPQR/clpqr/bv.yap index 31633fd72..cade3506c 100644 --- a/CLPQR/clpr/bv.yap +++ b/CLPQR/clpqr/bv.yap @@ -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)= 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) ) ), ( diff --git a/CLPQR/clpr/ineq.pl b/CLPQR/clpqr/ineq.yap similarity index 97% rename from CLPQR/clpr/ineq.pl rename to CLPQR/clpqr/ineq.yap index 1456bb279..e4812aa77 100644 --- a/CLPQR/clpr/ineq.pl +++ b/CLPQR/clpqr/ineq.yap @@ -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) ). diff --git a/CLPQR/clpr/nf.yap b/CLPQR/clpqr/nf.yap similarity index 99% rename from CLPQR/clpr/nf.yap rename to CLPQR/clpqr/nf.yap index fc2b3a257..0ecf530d3 100644 --- a/CLPQR/clpr/nf.yap +++ b/CLPQR/clpqr/nf.yap @@ -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), diff --git a/CLPQR/clpr/ordering.pl b/CLPQR/clpqr/ordering.yap similarity index 97% rename from CLPQR/clpr/ordering.pl rename to CLPQR/clpqr/ordering.yap index 3a0df5cac..e728943b2 100644 --- a/CLPQR/clpr/ordering.pl +++ b/CLPQR/clpqr/ordering.yap @@ -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). diff --git a/CLPQR/clpq/store.pl b/CLPQR/clpqr/store.yap similarity index 91% rename from CLPQR/clpq/store.pl rename to CLPQR/clpqr/store.yap index a87463401..517dfc8f9 100644 --- a/CLPQR/clpq/store.pl +++ b/CLPQR/clpqr/store.yap @@ -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) ). /**/ diff --git a/CLPQR/clpr/arith.pl b/CLPQR/clpr/arith.pl deleted file mode 100644 index d30d4380f..000000000 --- a/CLPQR/clpr/arith.pl +++ /dev/null @@ -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< {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) - ). - diff --git a/CLPQR/clpr/bb.pl b/CLPQR/clpr/bb.pl deleted file mode 100644 index 8ccfd93d2..000000000 --- a/CLPQR/clpr/bb.pl +++ /dev/null @@ -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( _, _, _). - diff --git a/CLPQR/clpr/bv.pl b/CLPQR/clpr/bv.pl deleted file mode 100644 index 73769ee47..000000000 --- a/CLPQR/clpr/bv.pl +++ /dev/null @@ -1,1256 +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: bv.pl % -% Author: Christian Holzbaur christian@ai.univie.ac.at % -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - -% -% simplex with bounded variables, ch, 93/12 -% - -% -% TODO: +) var/bound/state classification and maintainance -% +) inc/dec_step: take the best?, at least find unconstrained var first -% +) trivially implied values -% +) avoid eval_rhs through an extra column (Coeff=Rhs) -% +) if an optimum is encountered, record the value as bound !!! -% +) generalized (transparent) attribute handling -% +) coordinate reconsideration cascades -% +) =\= -% +) strict inequalities via =\= -% -) decompose via nonvar test -> no symbolic constants any more ? -% constants complicate the nonlin solver anyway ... -% +) join t_l,l(L), .... into t_l(L), ... -% +) shortcuts for strict ineqs -% -) extra types for vars with l/u bound zero -% -) occurrence lists for indep vars (with coeffs) ??? -% each solve produces one dep var -> push -% only complication: pivots -% -) *incremental* REVISED simplex ?!! -% -% sicstus2.1.9.clp conversion: -% -% -) stable ordering through extra attribute ... -% interpreted vs compiled yields different var order -% -> nasty in R (need different eps) -% -% -) check determinism again -% -% - -:- public {}/1, maximize/1, minimize/1, sup/2, inf/2, imin/2. % xref.pl - -:- use_module( library(ordsets), [ord_add_element/3]). - -% :- use_module( library(deterministic)). - -% -% For the rhs maint. the following events are important: -% -% -) introduction of an indep var at active bound B -% -) narrowing of active bound -% -) swap active bound -% -) pivot -% - -% -% a variables bound (L/U) can have the states: -% -% -) t_none -% -) t_l has a lower bound (not active yet) -% -) t_u -% -) t_L has an active lower bound -% -) t_U -% -) t_lu -% -) t_Lu -% -) t_lU -% - -% ----------------------------------- deref ------------------------------------ % - -:- mode deref( +, -). -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - length( H, Len), - log_deref( Len, H, [], Restd), - add_linear_11( Nonvar, Restd, Lind). - -:- mode log_deref( +, +, -, -). -% -log_deref( 0, Vs, Vs, Lin) :- !, - arith_eval( 0, Z), - Lin = [Z,Z]. -log_deref( 1, [v(K,[X^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - mult_linear_factor( Lx, K, Lin). -log_deref( 2, [v(Kx,[X^1]),v(Ky,[Y^1])|Vs], Vs, Lin) :- !, - deref_var( X, Lx), - deref_var( Y, Ly), - add_linear_ff( Lx, Kx, Ly, Ky, Lin). -log_deref( N, V0, V2, Lin) :- - P is N >> 1, - Q is N - P, - log_deref( P, V0,V1, Lp), - log_deref( Q, V1,V2, Lq), - add_linear_11( Lp, Lq, Lin). - -/* -% -% tail recursive version -% -deref( Lin, Lind) :- - split( Lin, H, I), - normalize_scalar( I, Nonvar), - lin_deref( H, Nonvar, Lind). - -log_deref( _, Lin, [], Res) :- % called from nf.pl - arith_eval( 0, Z), - lin_deref( Lin, [Z,Z], Res). - -lin_deref( [], Ld, Ld). -lin_deref( [v(K,[X^1])|Vs], Li, Lo) :- - deref_var( X, Lx), - add_linear_f1( Lx, K, Li, Lii), - lin_deref( Vs, Lii, Lo). -*/ - -% -% If we see a nonvar here, this is a fault -% -deref_var( X, Lin) :- - get_atts( X, lin(Lin)), !. -deref_var( X, Lin) :- % create a linear var - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,X*One], - put_atts( X, [order(_),lin(Lin),type(t_none),strictness(2'00)]). - -var_with_def_assign( Var, Lin) :- - decompose( Lin, Hom, _, I), - ( Hom = [], % X=k - Var = I - ; Hom = [V*K|Cs], - ( Cs = [], - arith_eval(K=:=1), - arith_eval(I=:=0) -> % X=Y - Var = V - ; % general case - var_with_def_intern( t_none, Var, Lin, 2'00) - ) - ). - -var_with_def_intern( Type, Var, Lin, Strict) :- - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - decompose( Lin, Hom, _, _), - get_or_add_class( Var, Class), - same_class( Hom, Class). - -var_intern( Type, Var, Strict) :- - arith_eval( 0, Z), - arith_eval( 1, One), - Lin = [Z,Z,Var*One], - put_atts( Var, [order(_),lin(Lin),type(Type),strictness(Strict)]), - get_or_add_class( Var, _Class). - -% ------------------------------------------------------------------------------ - -% -% [V-Binding]* -% Only place where the linear solver binds variables -% -export_binding( []). -export_binding( [X-Y|Gs]) :- - export_binding( Y, X), - export_binding( Gs). - -% -% numerical stabilizer, clp(r) only -% -export_binding( Y, X) :- var(Y), Y=X. -export_binding( Y, X) :- nonvar(Y), - ( arith_eval( Y=:=0) -> - arith_eval( 0, X) - ; - Y = X - ). - -'solve_='( Nf) :- - deref( Nf, Nfd), - solve( Nfd). - -'solve_=\='( Nf) :- - deref( Nf, Lind), - decompose( Lind, Hom, _, Inhom), - ( Hom = [], arith_eval( Inhom =\= 0) - ; Hom = [_|_], var_with_def_intern( t_none, Nz, Lind, 2'00), - put_atts( Nz, nonzero) - ). - -'solve_<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, strict). - -'solve_=<'( Nf) :- - split( Nf, H, I), - ineq( H, I, Nf, nonstrict). - -maximize( Term) :- - minimize( -Term). - -% -% This is NOT coded as minimize(Expr) :- inf(Expr,Expr). -% -% because the new version of inf/2 only visits -% the vertex where the infimum is assumed and returns -% to the 'current' vertex via backtracking. -% The rationale behind this construction is to eliminate -% all garbage in the solver data structures produced by -% the pivots on the way to the extremal point caused by -% {inf,sup}/{2,4}. -% -% If we are after the infimum/supremum for minimizing/maximizing, -% this strategy may have adverse effects on performance because -% the simplex algorithm is forced to re-discover the -% extremal vertex through the equation {Inf =:= Expr}. -% -% Thus the extra code for {minimize,maximize}/1. -% -% In case someone comes up with an example where -% -% inf(Expr,Expr) -% -% outperforms the provided formulation for minimize - so be it. -% Both forms are available to the user. -% -minimize( Term) :- - wait_linear( Term, Nf, minimize_lin(Nf)). - -minimize_lin( Lin) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - { Dep =:= Inf }. - -sup( Expression, Sup) :- - sup( Expression, Sup, [], []). - -sup( Expression, Sup, Vector, Vertex) :- - inf( -Expression, -Sup, Vector, Vertex). - -inf( Expression, Inf) :- - inf( Expression, Inf, [], []). - -inf( Expression, Inf, Vector, Vertex) :- - wait_linear( Expression, Nf, inf_lin(Nf,Inf,Vector,Vertex)). - -inf_lin( Lin, _, Vector, _) :- - deref( Lin, Lind), - var_with_def_intern( t_none, Dep, Lind, 2'00), - determine_active_dec( Lind), - iterate_dec( Dep, Inf), - vertex_value( Vector, Values), - bb_put( inf, [Inf|Values]), - fail. -inf_lin( _, Infimum, _, Vertex) :- - bb_delete( inf, L), - assign( [Infimum|Vertex], L). - -assign( [], []). -assign( [X|Xs], [Y|Ys]) :- - {X =:= Y}, % more defensive/expressive than X=Y - assign( Xs, Ys). - -% --------------------------------- optimization ------------------------------- % -% -% The _sn(S) =< 0 row might be temporarily infeasible. -% We use reconsider/1 to fix this. -% -% s(S) e [_,0] = d +xi ... -xj, Rhs > 0 so we want to decrease s(S) -% -% positive xi would have to be moved towards their lower bound, -% negative xj would have to be moved towards their upper bound, -% -% the row s(S) does not limit the lower bound of xi -% the row s(S) does not limit the upper bound of xj -% -% a) if some other row R is limiting xk, we pivot(R,xk), -% s(S) will decrease and get more feasible until (b) -% b) if there is no limiting row for some xi: we pivot(s(S),xi) -% xj: we pivot(s(S),xj) -% which cures the infeasibility in one step -% - - -% -% fails if Status = unlimited/2 -% -iterate_dec( OptVar, Opt) :- - get_atts( OptVar, lin(Lin)), - decompose( Lin, H, R, I), - - % arith_eval( R+I, Now), print(min(Now)), nl, - - % dec_step_best( H, Status), - dec_step( H, Status), - ( 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) - ). - -% -% Status = {optimum,unlimited(Indep,DepT),applied} -% If Status = optimum, the tables have not been changed at all. -% Searches left to right, does not try to find the 'best' pivot -% Therefore we might discover unboundedness only after a few pivots -% -dec_step( [], optimum). -dec_step( [V*K|Vs], Status) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - dec_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - dec_step( Vs, Status) - ) - ; 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), - ( arith_eval( K < 0) -> - ( lb( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_u(U)) - ; - Status = unlimited(V,t_u(U)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_lU(L,U), - ( arith_eval( K < 0) -> - Status = applied, - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_L(L), - ( arith_eval( K > 0) -> - ( ub( V, Vub-Vb-_) -> - Status = applied, - pivot_a(Vub,V,Vb,t_l(L)) - ; - Status = unlimited(V,t_l(L)) - ) - ; - inc_step( Vs, Status) - ) - ; W = t_Lu(L,U), - ( arith_eval( K > 0) -> - Status = applied, - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-_), - pivot_b(Vub,V,Vb,t_lu(L,U)) - ; - inc_step( Vs, Status) - ) - ; W = t_none, - Status = unlimited(V,t_none) - ). - -% ------------------------------ best first heuristic -------------------------- % -% -% A replacement for dec_step/2 that uses a local best first heuristic. -% -% - -dec_step_best( H, Status) :- - dec_eval( H, E), - ( E = unlimited(_,_), - Status = E - ; E = [], - Status = optimum - ; E = [_|_], - Status = applied, - keysort( E, [_-Best|_]), - ( Best = pivot_a(Vub,V,Vb,Wd), pivot_a(Vub,V,Vb,Wd) - ; Best = pivot_b(Vub,V,Vb,Wd), pivot_b(Vub,V,Vb,Wd) - ) - ). - -dec_eval( [], []). -dec_eval( [V*K|Vs], Res) :- - get_atts( V, type(W)), - ( W = t_U(U), - ( arith_eval( K > 0) -> - ( lb( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_u(U)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_u(U)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_lU(L,U), - ( arith_eval( K > 0) -> - arith_eval( L-U, Init), - basis( V, Deps), - lb( Deps, V, V-t_Lu(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_L(L), - ( arith_eval( K < 0) -> - ( ub( V, Vub-Vb-Limit) -> - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_a(Vub,V,Vb,t_l(L)) | Tail], - dec_eval( Vs, Tail) - ; - Res = unlimited(V,t_l(L)) - ) - ; - dec_eval( Vs, Res) - ) - ; W = t_Lu(L,U), - ( arith_eval( K < 0) -> - arith_eval( U-L, Init), - basis( V, Deps), - ub( Deps, V, V-t_lU(L,U)-Init, Vub-Vb-Limit), - arith_eval( float(Limit*K), Delta), - Res = [Delta-pivot_b(Vub,V,Vb,t_lu(L,U)) | Tail], - dec_eval( Vs, Tail) - ; - dec_eval( Vs, Res) - ) - ; W = t_none, - Res = unlimited(V,t_none) - ). - -% ------------------------- find the most constraining row --------------------- % -% -% The code for the lower and the upper bound are dual versions of each other. -% The only difference is in the orientation of the comparisons. -% Indeps are ruled out by their types. -% If there is no bound, this fails. -% -% *** The actual lb and ub on an indep variable X are [lu]b + b(X), where b(X) -% is the value of the active bound. -% -% Nota bene: We must NOT consider infeasible rows as candidates to -% leave the basis! -% - -ub( X, Ub) :- - basis( X, Deps), - ub_first( Deps, X, Ub). - -:- mode ub_first( +, ?, -). -% -ub_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - arith_eval( Ub >= 0) -> - ub( Deps, X, Dep-W-Ub, Tightest) - ; - ub_first( Deps, X, Tightest) - ). - -% -% Invariant: Ub >= 0 and decreasing -% -:- mode ub( +, ?, +, -). -% -ub( [], _, T0,T0). -ub( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - ub_inner( Type, X, Lin, W, Ub), - T0 = _-Ubb, - arith_eval( Ub < Ubb), - arith_eval( Ub >= 0) -> % rare failure - ub( Deps, X, Dep-W-Ub,T1) - ; - ub( Deps, X, T0,T1) - ). - -lb( X, Lb) :- - basis( X, Deps), - lb_first( Deps, X, Lb). - -:- mode lb_first( +, ?, -). -% -lb_first( [Dep|Deps], X, Tightest) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - arith_eval( Lb =< 0) -> - lb( Deps, X, Dep-W-Lb, Tightest) - ; - lb_first( Deps, X, Tightest) - ). - -% -% Invariant: Lb =< 0 and increasing -% -:- mode lb( +, ?, +, -). -% -lb( [], _, T0,T0). -lb( [Dep|Deps], X, T0,T1) :- - ( get_atts( Dep, [lin(Lin),type(Type)]), - lb_inner( Type, X, Lin, W, Lb), - T0 = _-Lbb, - arith_eval( Lb > Lbb), - arith_eval( Lb =< 0) -> % rare failure - lb( Deps, X, Dep-W-Lb,T1) - ; - lb( Deps, X, T0,T1) - ). - -% -% Lb =< 0 for feasible rows -% -:- mode lb_inner( +, ?, +, -, -). -% -lb_inner( t_l(L), X, Lin, t_L(L), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (L-Rhs)/K, Lb). -lb_inner( t_u(U), X, Lin, t_U(U), Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (U-Rhs)/K, Lb). -lb_inner( t_lu(L,U), X, Lin, W, Lb) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Lb) - ), - fail, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Lb) - )). - -% -% Ub >= 0 for feasible rows -% -:- mode ub_inner( +, ?, +, -, -). -% -ub_inner( t_l(L), X, Lin, t_L(L), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K < 0), - arith_eval( (L-Rhs)/K, Ub). -ub_inner( t_u(U), X, Lin, t_U(U), Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - arith_eval( K > 0), - arith_eval( (U-Rhs)/K, Ub). -ub_inner( t_lu(L,U), X, Lin, W, Ub) :- - nf_rhs_x( Lin, X, Rhs, K), - case_signum( K, - ( - W = t_Lu(L,U), - arith_eval( (L-Rhs)/K, Ub) - ), - fail, - ( - W = t_lU(L,U), - arith_eval( (U-Rhs)/K, Ub) - )). - -% ---------------------------------- equations --------------------------------- % -% -% backsubstitution will not make the system infeasible, if the bounds on the indep -% vars are obeyed, but some implied values might pop up in rows where X occurs -% -) special case X=Y during bs -> get rid of dependend var(s), alias -% - -solve( Lin) :- - decompose( Lin, H, _, I), - solve( H, Lin, I, Bindings, []), - export_binding( Bindings). - -solve( [], _, I, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve( H, Lin, _, Bind0,BindT) :- - H = [_|_], % indexing - % - % [] is an empty ord_set, anything will be preferred - % over 9-9 - % - sd( H, [],ClassesUniq, 9-9-0,Category-Selected-_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( 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, - get_atts( Selected, class(NewC)), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; Category = 3, - put_atts( Selected, lin(Lin1)), - get_atts( Selected, type(Type)), - deactivate_bound( Type, Selected), - eq_classes( NV, NVT, ClassesUniq), - basis_add( Selected, Basis), - undet_active( Lin1), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,Bind1), - rcbl( Basis, Bind1,BindT) - ; Category = 4, - get_atts( Selected, [type(Type),class(NewC)]), - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,Bind1) - ; - Bind0 = Bind1, - bs( Deps, Selected, Lin1) - ), - deactivate_bound( Type, Selected), - basis_add( Selected, Basis), - % eq_classes( NV, NVT, ClassesUniq), % 4 -> var(NV) - equate( ClassesUniq, _), - undet_active( Lin1), - rcbl( Basis, Bind1,BindT) - ). - -% -% Much like solve, but we solve for a particular variable of type -% t_none -% -solve_x( Lin, X) :- - decompose( Lin, H, _, I), - solve_x( H, Lin, I, X, Bindings, []), - export_binding( Bindings). - -solve_x( [], _, I, _, Bind0,Bind0) :- - arith_eval( I=:=0). % redundant or trivially unsat -solve_x( H, Lin, _, Selected, Bind0,BindT) :- - H = [_|_], % indexing - sd( H, [],ClassesUniq, 9-9-0,_, NV,NVT), - - isolate( Selected, Lin, Lin1), - - ( get_atts( Selected, class(NewC)) -> - class_allvars( NewC, Deps), - ( ClassesUniq = [_] -> % rank increasing - bs_collect_bindings( Deps, Selected, Lin1, Bind0,BindT) - ; - Bind0 = BindT, - bs( Deps, Selected, Lin1) - ), - eq_classes( NV, NVT, ClassesUniq) - ; - put_atts( Selected, lin(Lin1)), - decompose( Lin1, Hom, _, Inhom), - bs_collect_binding( Hom, Selected, Inhom, Bind0,BindT), - eq_classes( NV, NVT, ClassesUniq) - ). - - - -sd( [], Class0,Class0, Preference0,Preference0, NV0,NV0). -sd( [X*K|Xs], Class0,ClassN, Preference0,PreferenceN, NV0,NVt) :- - ( get_atts( X, class(Xc)) -> % old - NV0 = NV1, - ord_add_element( Class0, Xc, Class1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 2-X-K, Preference1) - ; - preference( Preference0, 4-X-K, Preference1) - ) - ; % new - Class1 = Class0, - 'C'( NV0, X, NV1), - ( get_atts( X, type(t_none)) -> - preference( Preference0, 1-X-K, Preference1) - ; - preference( Preference0, 3-X-K, Preference1) - ) - ), - sd( Xs, Class1,ClassN, Preference1,PreferenceN, NV1,NVt). - -% -% A is best sofar, B is current -% -preference( A, B, Pref) :- - A = Px-_-_, - B = Py-_-_, - compare( Rel, Px, Py), - ( Rel = =, Pref = B - % ( arith_eval(abs(Ka)= Pref=A ; Pref=B ) - ; Rel = <, Pref = A - ; Rel = >, Pref = B - ). - -% -% equate after attach_class because other classes may contribute -% nonvars and will bind the tail of NV -% -eq_classes( NV, _, Cs) :- var( NV), !, - equate( Cs, _). -eq_classes( NV, NVT, Cs) :- - class_new( Su, NV,NVT, []), - attach_class( NV, Su), - equate( Cs, Su). - -equate( [], _). -equate( [X|Xs], X) :- equate( Xs, X). - -% -% assert: none of the Vars has a class attribute yet -% -attach_class( Xs, _) :- var( Xs), !. -attach_class( [X|Xs], Class) :- - put_atts( X, class(Class)), - attach_class( Xs, Class). - -/** -unconstrained( [X*K|Xs], Uc,Kuc, Rest) :- - ( get_atts( X, type(t_none)) -> - Uc = X, - Kuc = K, - Rest = Xs - ; - Rest = [X*K|Tail], - unconstrained( Xs, Uc,Kuc, Tail) - ). -**/ -/**/ -unconstrained( Lin, Uc,Kuc, Rest) :- - decompose( Lin, H, _, _), - sd( H, [],_, 9-9-0,Category-Uc-_, _,_), - Category =< 2, - delete_factor( Uc, Lin, Rest, Kuc). -/**/ - -% -% point the vars in Lin into the same equivalence class -% maybe join some global data -% -same_class( [], _). -same_class( [X*_|Xs], Class) :- - get_or_add_class( X, Class), - same_class( Xs, Class). - -get_or_add_class( X, Class) :- - get_atts( X, class(ClassX)), - !, - ClassX = Class. % explicit =/2 because of cut -get_or_add_class( X, Class) :- - put_atts( X, class(Class)), - class_new( Class, [X|Tail],Tail, []). % initial class atts - -allvars( X, Allvars) :- - get_atts( X, class(C)), - class_allvars( C, Allvars). - -deactivate_bound( t_l(_), _). -deactivate_bound( t_u(_), _). -deactivate_bound( t_lu(_,_), _). -deactivate_bound( t_L(L), X) :- put_atts( X, type(t_l(L))). -deactivate_bound( t_Lu(L,U), X) :- put_atts( X, type(t_lu(L,U))). -deactivate_bound( t_U(U), X) :- put_atts( X, type(t_u(U))). -deactivate_bound( t_lU(L,U), X) :- put_atts( X, type(t_lu(L,U))). - -intro_at( X, Value, Type) :- - put_atts( X, type(Type)), - ( arith_eval( Value =:= 0) -> - true - ; - backsubst_delta( X, Value) - ). - - -% -% The choice t_lu -> t_Lu is arbitrary -% -undet_active( Lin) :- - decompose( Lin, Lin1, _, _), - undet_active_h( Lin1). - -undet_active_h( []). -undet_active_h( [X*_|Xs]) :- - get_atts( X, type(Type)), - undet_active( Type, X), - undet_active_h( Xs). - -undet_active( t_none, _). % type_activity -undet_active( t_L(_), _). -undet_active( t_Lu(_,_), _). -undet_active( t_U(_), _). -undet_active( t_lU(_,_), _). -undet_active( t_l(L), X) :- intro_at( X, L, t_L(L)). -undet_active( t_u(U), X) :- intro_at( X, U, t_U(U)). -undet_active( t_lu(L,U), X) :- intro_at( X, L, t_Lu(L,U)). - -determine_active_dec( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( -1, Mone), - determine_active( Lin1, Mone). - -determine_active_inc( Lin) :- - decompose( Lin, Lin1, _, _), - arith_eval( 1, One), - determine_active( Lin1, One). - -determine_active( [], _). -determine_active( [X*K|Xs], S) :- - get_atts( X, type(Type)), - determine_active( Type, X, K, S), - determine_active( Xs, S). - -determine_active( t_L(_), _, _, _). -determine_active( t_Lu(_,_), _, _, _). -determine_active( t_U(_), _, _, _). -determine_active( t_lU(_,_), _, _, _). -determine_active( t_l(L), X, _, _) :- intro_at( X, L, t_L(L)). -determine_active( t_u(U), X, _, _) :- intro_at( X, U, t_U(U)). -determine_active( t_lu(L,U), X, K, S) :- - case_signum( K*S, - intro_at( X, L, t_Lu(L,U)), - fail, - intro_at( X, U, t_lU(L,U))). - -% -% Careful when an indep turns into t_none !!! -% -detach_bounds( V) :- - get_atts( V, lin(Lin)), - put_atts( V, [type(t_none),strictness(2'00)]), - ( indep( Lin, V) -> - ( ub( V, Vub-Vb-_) -> % exchange against thightest - basis_drop( Vub), - pivot( Vub, V, Vb) - ; lb( V, Vlb-Vb-_) -> - basis_drop( Vlb), - pivot( Vlb, V, Vb) - ; - true - ) - ; - basis_drop( V) - ). - -% ----------------------------- manipulate the basis --------------------------- % - -basis_drop( X) :- - get_atts( X, class(Cv)), - class_basis_drop( Cv, X). - -basis( X, Basis) :- - get_atts( X, class(Cv)), - class_basis( Cv, Basis). - -basis_add( X, NewBasis) :- - get_atts( X, class(Cv)), - class_basis_add( Cv, X, NewBasis). - -basis_pivot( Leave, Enter) :- - get_atts( Leave, class(Cv)), - class_basis_pivot( Cv, Enter, Leave). - -% ----------------------------------- pivot ------------------------------------ % - -% -% Pivot ignoring rhs and active states -% -pivot( Dep, Indep) :- - get_atts( Dep, lin(H)), - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( -1, Mone), - arith_eval( 0, Z), - add_linear_ff( H0, K, [Z,Z,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - - -pivot_a( Dep, Indep, Vb,Wd) :- - basis_pivot( Dep, Indep), - pivot( Dep, Indep, Vb), - put_atts( Indep, type(Wd)). - -pivot_b( Vub, V, Vb, Wd) :- - ( Vub == V -> - put_atts( V, type(Vb)), - pivot_b_delta( Vb, Delta), % nonzero(Delta) - backsubst_delta( V, Delta) - ; - pivot_a( Vub, V, Vb,Wd) - ). - -pivot_b_delta( t_Lu(L,U), Delta) :- arith_eval( L-U, Delta). -pivot_b_delta( t_lU(L,U), Delta) :- arith_eval( U-L, Delta). - -select_active_bound( t_L(L), L). -select_active_bound( t_Lu(L,_), L). -select_active_bound( t_U(U), U). -select_active_bound( t_lU(_,U), U). -select_active_bound( t_none, Z) :- arith_eval( 0, Z). -% -% for project.pl -% -select_active_bound( t_l(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_u(_), Z) :- arith_eval( 0, Z). -select_active_bound( t_lu(_,_), Z) :- arith_eval( 0, Z). - - -% -% Pivot taking care of rhs and active states -% -pivot( Dep, Indep, IndAct) :- - get_atts( Dep, lin(H)), - put_atts( Dep, type(IndAct)), - select_active_bound( IndAct, Abv), % Dep or Indep - delete_factor( Indep, H, H0, Coeff), - arith_eval( -1/Coeff, K), - arith_eval( 0, Z), - arith_eval( -1, Mone), - arith_eval( -Abv, Abvm), - add_linear_ff( H0, K, [Z,Abvm,Dep*Mone], K, Lin), - backsubst( Indep, Lin). - -backsubst_delta( X, Delta) :- - arith_eval( 1, One), - arith_eval( 0, Z), - backsubst( X, [Z,Delta,X*One]). - -backsubst( X, Lin) :- - allvars( X, Allvars), - bs( Allvars, X, Lin). -% -% valid if nothing will go ground -% -bs( Xs, _, _) :- var( Xs), !. -bs( [X|Xs], V, Lin) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - bs( Xs, V, Lin) - ; - bs( Xs, V, Lin) - ). - - -% -% rank increasing backsubstitution -% -bs_collect_bindings( Xs, _, _, Bind0,BindT) :- var( Xs), !, Bind0=BindT. -bs_collect_bindings( [X|Xs], V, Lin, Bind0,BindT) :- - ( get_atts( X, lin(LinX)), - nf_substitute( V, Lin, LinX, LinX1) -> - put_atts( X, lin(LinX1)), - decompose( LinX1, Hom, _, Inhom), - bs_collect_binding( Hom, X, Inhom, Bind0,Bind1), - bs_collect_bindings( Xs, V, Lin, Bind1,BindT) - ; - bs_collect_bindings( Xs, V, Lin, Bind0,BindT) - ). - -% -% The first clause exports bindings, -% the second (no longer) aliasings -% -bs_collect_binding( [], X, Inhom) --> [ X-Inhom ]. -bs_collect_binding( [_|_], _, _) --> []. -/* -bs_collect_binding( [Y*K|Ys], X, Inhom) --> - ( { Ys = [], - Y \== X, - arith_eval( K=:=1), - arith_eval( Inhom=:=0) - } -> - [ X-Y ] - ; - [] - ). -*/ - -% -% reconsider the basis -% -rcbl( [], Bind0,Bind0). -rcbl( [X|Continuation], Bind0,BindT) :- - ( rcb( X, Status, Violated) -> % have a culprit - rcbl_status( Status, X, Continuation, Bind0,BindT, Violated) - ; - rcbl( Continuation, Bind0,BindT) - ). - -% -% reconsider one element of the basis -% later: lift the binds -% -reconsider( X) :- - rcb( X, Status, Violated), - !, - rcbl_status( Status, X, [], Binds,[], Violated), - export_binding( Binds). -reconsider( _). - -% -% Find a basis variable out of its bound or at its bound -% Try to move it into whithin its bound -% a) impossible -> fail -% b) optimum at the bound -> implied value -% c) else look at the remaining basis variables -% -rcb( X, Status, Violated) :- - get_atts( X, [lin(Lin),type(Type)]), - decompose( Lin, H, R, I), - ( Type = t_l(L), - arith_eval( R+I =< L), - Violated = l(L), - inc_step( H, Status) - - ; Type = t_u(U), - arith_eval( R+I >= U), - Violated = u(U), - dec_step( H, Status) - - ; Type = t_lu(L,U), - arith_eval( R+I, At), - ( - arith_eval( At =< L), - Violated = l(L), - inc_step( H, Status) - ; - arith_eval( At >= U), - Violated = u(U), - dec_step( H, Status) - ) - % - % don't care for other types - % - ). - -rcbl_status( optimum, X, Cont, B0,Bt, Violated) :- rcbl_opt( Violated, X, Cont, B0,Bt). -rcbl_status( applied, X, Cont, B0,Bt, Violated) :- rcbl_app( Violated, X, Cont, B0,Bt). -rcbl_status( unlimited(Indep,DepT), X, Cont, B0,Bt, Violated) :- rcbl_unl( Violated, X, Cont, B0,Bt, Indep, DepT). - -% -% Might reach optimum immediately without changing the basis, -% but in general we must assume that there were pivots. -% If the optimum meets the bound, we backsubstitute the implied -% value, solve will call us again to check for further implied -% values or unsatisfiability in the rank increased system. -% -rcbl_opt( l(L), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( L-Opt, - ( - narrow_u( Type, X, Opt), % { X =< Opt } - rcbl( Continuation, B0,B1) - ), - ( - Strict /\ 2'10 =:= 0, % meets lower - arith_eval( -Opt, Mop), - 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) - ) - ), - fail - ). -rcbl_opt( u(U), X, Continuation, B0,B1) :- - get_atts( X, [lin(Lin),strictness(Strict),type(Type)]), - decompose( Lin, _, R, I), - arith_eval( R+I, Opt), - case_signum( U-Opt, - fail, - ( - Strict /\ 2'01 =:= 0, % meets upper - arith_eval( -Opt, Mop), - 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) - ) - ), - ( - narrow_l( Type, X, Opt), % { X >= Opt } - rcbl( Continuation, B0,B1) - )). - -% -% Basis has already changed when this is called -% -rcbl_app( l(L), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I > L) -> % within bound now - rcbl( Continuation, B0,B1) - ; - % arith_eval( R+I, Val), print( rcbl_app(X:L:Val)), nl, - inc_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, l(L)) - ). -rcbl_app( u(U), X, Continuation, B0,B1) :- - get_atts( X, lin(Lin)), - decompose( Lin, H, R, I), - ( arith_eval( R+I < U) -> % within bound now - rcbl( Continuation, B0,B1) - ; - dec_step( H, Status), - rcbl_status( Status, X, Continuation, B0,B1, u(U)) - ). - -% -% This is never called for a t_lu culprit -% -rcbl_unl( l(L), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_L(L), DepT), % changes the basis - rcbl( Continuation, B0,B1). -rcbl_unl( u(U), X, Continuation, B0,B1, Indep, DepT) :- - pivot_a( X, Indep, t_U(U), DepT), % changes the basis - rcbl( Continuation, B0,B1). - -narrow_u( t_u(_), X, U) :- put_atts( X, type(t_u(U))). -narrow_u( t_lu(L,_), X, U) :- put_atts( X, type(t_lu(L,U))). - -narrow_l( t_l(_), X, L) :- put_atts( X, type(t_l(L))). -narrow_l( t_lu(_,U), X, L) :- put_atts( X, type(t_lu(L,U))). - -% ----------------------------------- dump ------------------------------------- - -dump_var( t_none, V, I,H) --> !, - ( { H=[W*K],V==W,arith_eval(I=:=0),arith_eval(K=:=1) } -> % indep var - [] - ; - { nf2sum( H, I, Sum) }, - [ V = Sum ] - ). -dump_var( t_L(L), V, I,H) --> !, dump_var( t_l(L), V, I,H). -dump_var( t_l(L), V, I,H) --> !, - { - H= [_*K|_], % avoid 1 >= 0 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'10, - arith_eval( 1/K, Kr), - arith_eval( Kr*(L-I), Li), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum >= Li, Sum > Li, Result) - ; - dump_strict( Sm, Sum =< Li, Sum < Li, Result) - ) - }, - [ Result ]. -dump_var( t_U(U), V, I,H) --> !, dump_var( t_u(U), V, I,H). -dump_var( t_u(U), V, I,H) --> !, - { - H= [_*K|_], % avoid 0 =< 1 - get_atts( V, strictness(Strict)), - Sm is Strict /\ 2'01, - arith_eval( 1/K, Kr), - arith_eval( Kr*(U-I), Ui), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum), - ( arith_eval( K > 0) -> - dump_strict( Sm, Sum =< Ui, Sum < Ui, Result) - ; - dump_strict( Sm, Sum >= Ui, Sum > Ui, Result) - ) - }, - [ Result ]. -dump_var( t_Lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lU(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( t_lu(L,U), V, I,H) --> !, dump_var( t_l(L), V,I,H), - dump_var( t_U(U), V,I,H). -dump_var( T, V, I,H) --> - [ V:T:I+H ]. - -dump_strict( 0, Result, _, Result). -dump_strict( 1, _, Result, Result). -dump_strict( 2, _, Result, Result). - -dump_nz( _, H, I) --> - { - H = [_*K|_], - arith_eval( 1/K, Kr), - arith_eval( -Kr*I, I1), - mult_hom( H, Kr, H1), - arith_eval( 0, Z), nf2sum( H1, Z, Sum) - }, - [ Sum =\= I1 ]. diff --git a/CLPQR/clpr/compenv.pl b/CLPQR/clpr/compenv.pl deleted file mode 100644 index e91933936..000000000 --- a/CLPQR/clpr/compenv.pl +++ /dev/null @@ -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). - diff --git a/CLPQR/clpr/dump.pl b/CLPQR/clpr/dump.pl deleted file mode 100644 index 54e957c7b..000000000 --- a/CLPQR/clpr/dump.pl +++ /dev/null @@ -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. diff --git a/CLPQR/clpr/fourmotz.pl b/CLPQR/clpr/fourmotz.pl deleted file mode 100644 index c0dd77f29..000000000 --- a/CLPQR/clpr/fourmotz.pl +++ /dev/null @@ -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) - ). diff --git a/CLPQR/clpr/geler.yap b/CLPQR/clpr/geler.yap index c98b31585..441e6deed 100644 --- a/CLPQR/clpr/geler.yap +++ b/CLPQR/clpr/geler.yap @@ -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(+,:). diff --git a/CLPQR/clpr/itf3.pl b/CLPQR/clpr/itf3.pl deleted file mode 100644 index 823e58d50..000000000 --- a/CLPQR/clpr/itf3.pl +++ /dev/null @@ -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( _, _). - - - - - - - diff --git a/CLPQR/clpr/nf.pl b/CLPQR/clpr/nf.pl deleted file mode 100644 index 156ccac64..000000000 --- a/CLPQR/clpr/nf.pl +++ /dev/null @@ -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) :- !. -negate( A>B, A=B) :- !. -negate( A>=B, A 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). - diff --git a/CLPQR/clpr/project.pl b/CLPQR/clpr/project.pl deleted file mode 100644 index 972788fa1..000000000 --- a/CLPQR/clpr/project.pl +++ /dev/null @@ -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) - ). - diff --git a/CLPQR/clpr/redund.pl b/CLPQR/clpr/redund.pl deleted file mode 100644 index 1c7c807ec..000000000 --- a/CLPQR/clpr/redund.pl +++ /dev/null @@ -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. - - diff --git a/CLPQR/clpr/store.pl b/CLPQR/clpr/store.pl deleted file mode 100644 index a87463401..000000000 --- a/CLPQR/clpr/store.pl +++ /dev/null @@ -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). - - diff --git a/H/Heap.h b/H/Heap.h index 9a1cee26c..2cac88622 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -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 diff --git a/H/Regs.h b/H/Regs.h index b3644cd1c..9035fa262 100644 --- a/H/Regs.h +++ b/H/Regs.h @@ -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 *) diff --git a/Makefile.in b/Makefile.in index 2e6d4d615..14e17ab0a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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 diff --git a/changes4.3.html b/changes4.3.html index 0d2d931a8..f5b29b1ec 100644 --- a/changes4.3.html +++ b/changes4.3.html @@ -16,6 +16,12 @@

Yap-4.3.19:

    +
  • FIXED: CHR instalation.
    • +
  • SPEEDUP: avoid unnecessary choice-points with CLPQR.
    • +
  • NEW: inline $mod_switch, $mod_switch now uses + backtrackable updates to modules.
    • +
  • NEW: new method for marking timestamps that simplifies gc
    • +
  • FIXED: bug while collecting multi-assignment variables
  • FIXED: make yap modules more compatible with SICStus Prolog
  • NEW: portray_clause/2 (request from Nicos Angelopoulos)
  • FIXED: document absolute_file_name/2
    • diff --git a/configure b/configure index 96cc6b10d..7ecf5c568 100755 --- a/configure +++ b/configure @@ -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 <> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then diff --git a/configure.in b/configure.in index a686fbd79..8882b0b70 100644 --- a/configure.in +++ b/configure.in @@ -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 diff --git a/library/Makefile.in b/library/Makefile.in new file mode 100644 index 000000000..1e9a51060 --- /dev/null +++ b/library/Makefile.in @@ -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 + + diff --git a/m4/Yatom.h.m4 b/m4/Yatom.h.m4 index c146292fe..3de286f26 100644 --- a/m4/Yatom.h.m4 +++ b/m4/Yatom.h.m4 @@ -382,7 +382,6 @@ typedef enum { } db_term_flags; #define MaxModules 255 -extern SMALLUNSGN CurrentModule; typedef struct { Prop NextOfPE; /* used to chain properties */ diff --git a/pl/boot.yap b/pl/boot.yap index 41d4089d0..aeaae30a8 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -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, diff --git a/pl/consult.yap b/pl/consult.yap index 12eadbece..396e5039b 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -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 ) diff --git a/pl/corout.yap b/pl/corout.yap index 5546637ab..2184e48ce 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -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). diff --git a/pl/debug.yap b/pl/debug.yap index 559047fa7..c2633b74a 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -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). diff --git a/pl/depth_bound.yap b/pl/depth_bound.yap index 803e83e1d..01a87582a 100644 --- a/pl/depth_bound.yap +++ b/pl/depth_bound.yap @@ -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,_,_) :- !. diff --git a/pl/nfr.yap b/pl/nfr.yap deleted file mode 100644 index ec236bd35..000000000 --- a/pl/nfr.yap +++ /dev/null @@ -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 - { - nf2term( [], Z), - nf2term( Nf, Term) - }, - [ clpr:{Term= - { - nf2term( [], Z), - nf2term( Nf, Term) - }, - [ clpr:{Term=\=Z} ]. -transg( wait_linear_retry(Nf,Res,Goal)) --> - { - nf2term( Nf, Term) - }, - [ clpr:{Term=Res}, Goal ]. diff --git a/pl/utils.yap b/pl/utils.yap index 356ca25a4..90594dd94 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -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),