This commit was generated by cvs2svn to compensate for changes in r4,
which included commits to RCS files with non-trunk default branches. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
parent
9a8ee05f1f
commit
e5f4633c39
|
@ -0,0 +1,555 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: adtdefs.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: abstract machine definitions *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
|
||||
#endif
|
||||
|
||||
#define ADTDEFS_C
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include <stdio.h>
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
/* this routine must be run at least having a read lock on ae */
|
||||
static Prop
|
||||
GetFunctorProp(AtomEntry *ae, unsigned int arity)
|
||||
{ /* look property list of atom a for kind */
|
||||
FunctorEntry *pp;
|
||||
|
||||
pp = RepFunctorProp(ae->PropOfAE);
|
||||
while (!EndOfPAEntr(pp) &&
|
||||
(!IsFunctorProperty(pp->KindOfPE) ||
|
||||
pp->ArityOfFE != arity))
|
||||
pp = RepFunctorProp(pp->NextOfPE);
|
||||
return (AbsFunctorProp(pp));
|
||||
}
|
||||
|
||||
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
|
||||
static inline Functor
|
||||
InlinedUnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
|
||||
{
|
||||
FunctorEntry *p;
|
||||
Prop p0;
|
||||
|
||||
p0 = GetFunctorProp(ae, arity);
|
||||
if (p0 != NIL) {
|
||||
return ((Functor) RepProp(p0));
|
||||
}
|
||||
p = (FunctorEntry *) AllocAtomSpace(sizeof(*p));
|
||||
p->KindOfPE = FunctorProperty;
|
||||
p->NameOfFE = AbsAtom(ae);
|
||||
p->ArityOfFE = arity;
|
||||
p->NextOfPE = ae->PropOfAE;
|
||||
ae->PropOfAE = AbsProp((PropEntry *) p);
|
||||
return ((Functor) p);
|
||||
}
|
||||
|
||||
Functor
|
||||
UnlockedMkFunctor(AtomEntry *ae, unsigned int arity)
|
||||
{
|
||||
return(InlinedUnlockedMkFunctor(ae, arity));
|
||||
}
|
||||
|
||||
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
|
||||
Functor
|
||||
MkFunctor(Atom ap, unsigned int arity)
|
||||
{
|
||||
AtomEntry *ae = RepAtom(ap);
|
||||
Functor f;
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
f = InlinedUnlockedMkFunctor(ae, arity);
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
return (f);
|
||||
}
|
||||
|
||||
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
|
||||
void
|
||||
MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p)
|
||||
{
|
||||
AtomEntry *ae = RepAtom(ap);
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
p->KindOfPE = FunctorProperty;
|
||||
p->NameOfFE = ap;
|
||||
p->ArityOfFE = arity;
|
||||
p->NextOfPE = RepAtom(ap)->PropOfAE;
|
||||
ae->PropOfAE = AbsProp((PropEntry *) p);
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
}
|
||||
|
||||
inline static Atom
|
||||
SearchInInvisible(char *atom)
|
||||
{
|
||||
AtomEntry *chain;
|
||||
|
||||
READ_LOCK(INVISIBLECHAIN.AERWLock);
|
||||
chain = RepAtom(INVISIBLECHAIN.Entry);
|
||||
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom) != 0) {
|
||||
chain = RepAtom(chain->NextOfAE);
|
||||
}
|
||||
READ_UNLOCK(INVISIBLECHAIN.AERWLock);
|
||||
if (EndOfPAEntr(chain))
|
||||
return (NIL);
|
||||
else
|
||||
return(AbsAtom(chain));
|
||||
}
|
||||
|
||||
static inline Atom
|
||||
SearchAtom(unsigned char *p, Atom a) {
|
||||
AtomEntry *ae;
|
||||
|
||||
/* search atom in chain */
|
||||
while (a != NIL) {
|
||||
ae = RepAtom(a);
|
||||
if (strcmp(ae->StrOfAE, (const char *)p) == 0) {
|
||||
return(a);
|
||||
}
|
||||
a = ae->NextOfAE;
|
||||
}
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
Atom
|
||||
LookupAtom(char *atom)
|
||||
{ /* lookup atom in atom table */
|
||||
register CELL hash;
|
||||
register unsigned char *p;
|
||||
Atom a;
|
||||
AtomEntry *ae;
|
||||
|
||||
/* compute hash */
|
||||
p = (unsigned char *)atom;
|
||||
HashFunction(p, hash);
|
||||
WRITE_LOCK(HashChain[hash].AERWLock);
|
||||
a = HashChain[hash].Entry;
|
||||
/* search atom in chain */
|
||||
a = SearchAtom((unsigned char *)atom, a);
|
||||
if (a != NIL) {
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
return(a);
|
||||
}
|
||||
/* add new atom to start of chain */
|
||||
ae = (AtomEntry *) AllocAtomSpace((sizeof *ae) + strlen(atom));
|
||||
a = AbsAtom(ae);
|
||||
ae->NextOfAE = HashChain[hash].Entry;
|
||||
HashChain[hash].Entry = a;
|
||||
ae->PropOfAE = NIL;
|
||||
if (ae->StrOfAE != atom)
|
||||
strcpy(ae->StrOfAE, atom);
|
||||
INIT_RWLOCK(ae->ARWLock);
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
return (a);
|
||||
}
|
||||
|
||||
Atom
|
||||
FullLookupAtom(char *atom)
|
||||
{ /* lookup atom in atom table */
|
||||
Atom t;
|
||||
|
||||
if ((t = SearchInInvisible(atom)) != NIL) {
|
||||
return (t);
|
||||
}
|
||||
return(LookupAtom(atom));
|
||||
}
|
||||
|
||||
void
|
||||
LookupAtomWithAddress(char *atom, AtomEntry *ae)
|
||||
{ /* lookup atom in atom table */
|
||||
register CELL hash;
|
||||
register unsigned char *p;
|
||||
Atom a;
|
||||
|
||||
/* compute hash */
|
||||
p = (unsigned char *)atom;
|
||||
HashFunction(p, hash);
|
||||
/* ask for a WRITE lock because it is highly unlikely we shall find anything */
|
||||
WRITE_LOCK(HashChain[hash].AERWLock);
|
||||
a = HashChain[hash].Entry;
|
||||
/* search atom in chain */
|
||||
if (SearchAtom(p, a) != NIL) {
|
||||
Error(FATAL_ERROR,TermNil,"repeated initialisation for atom %s", ae);
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
return;
|
||||
}
|
||||
/* add new atom to start of chain */
|
||||
ae->NextOfAE = a;
|
||||
HashChain[hash].Entry = AbsAtom(ae);
|
||||
ae->PropOfAE = NIL;
|
||||
strcpy(ae->StrOfAE, atom);
|
||||
INIT_RWLOCK(ae->ARWLock);
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
}
|
||||
|
||||
void
|
||||
ReleaseAtom(Atom atom)
|
||||
{ /* Releases an atom from the hash chain */
|
||||
register Int hash;
|
||||
register unsigned char *p;
|
||||
AtomEntry *inChain;
|
||||
AtomEntry *ap = RepAtom(atom);
|
||||
char *name = ap->StrOfAE;
|
||||
|
||||
/* compute hash */
|
||||
p = (unsigned char *)name;
|
||||
HashFunction(p, hash);
|
||||
WRITE_LOCK(HashChain[hash].AERWLock);
|
||||
if (HashChain[hash].Entry == atom) {
|
||||
HashChain[hash].Entry = ap->NextOfAE;
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
return;
|
||||
}
|
||||
/* else */
|
||||
inChain = RepAtom(HashChain[hash].Entry);
|
||||
while (inChain->NextOfAE != atom)
|
||||
inChain = RepAtom(inChain->NextOfAE);
|
||||
WRITE_LOCK(inChain->ARWLock);
|
||||
inChain->NextOfAE = ap->NextOfAE;
|
||||
WRITE_UNLOCK(inChain->ARWLock);
|
||||
WRITE_UNLOCK(HashChain[hash].AERWLock);
|
||||
}
|
||||
|
||||
static Prop
|
||||
StaticLockedGetAProp(AtomEntry *ae, PropFlags kind)
|
||||
{ /* look property list of atom a for kind */
|
||||
PropEntry *pp;
|
||||
|
||||
pp = RepProp(ae->PropOfAE);
|
||||
while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
|
||||
pp = RepProp(pp->NextOfPE);
|
||||
return (AbsProp(pp));
|
||||
}
|
||||
|
||||
Prop
|
||||
LockedGetAProp(AtomEntry *ae, PropFlags kind)
|
||||
{ /* look property list of atom a for kind */
|
||||
return (StaticLockedGetAProp(ae,kind));
|
||||
}
|
||||
|
||||
Prop
|
||||
GetAProp(Atom a, PropFlags kind)
|
||||
{ /* look property list of atom a for kind */
|
||||
AtomEntry *ae = RepAtom(a);
|
||||
Prop out;
|
||||
|
||||
READ_LOCK(ae->ARWLock);
|
||||
out = StaticLockedGetAProp(ae, kind);
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
return (out);
|
||||
}
|
||||
|
||||
Prop
|
||||
GetPredProp(Atom ap, unsigned int arity)
|
||||
/* get predicate entry for ap/arity; */
|
||||
{
|
||||
Prop p0;
|
||||
AtomEntry *ae = RepAtom(ap);
|
||||
PredEntry *p;
|
||||
|
||||
READ_LOCK(ae->ARWLock);
|
||||
p = RepPredProp(p0 = ae->PropOfAE);
|
||||
while (p0 && (p->KindOfPE != PEProp || p->ArityOfPE != arity ||
|
||||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
|
||||
p = RepPredProp(p0 = p->NextOfPE);
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
return (p0);
|
||||
}
|
||||
|
||||
Prop
|
||||
LockedGetPredProp(Atom ap, unsigned int arity)
|
||||
/* get predicate entry for ap/arity; */
|
||||
{
|
||||
Prop p0;
|
||||
AtomEntry *ae = RepAtom(ap);
|
||||
PredEntry *p;
|
||||
|
||||
p = RepPredProp(p0 = ae->PropOfAE);
|
||||
while (p0 && (p->KindOfPE != PEProp || p->ArityOfPE != arity ||
|
||||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
|
||||
p = RepPredProp(p0 = p->NextOfPE);
|
||||
return (p0);
|
||||
}
|
||||
|
||||
/* get expression entry for at/arity; */
|
||||
Prop
|
||||
GetExpProp(Atom at, unsigned int arity)
|
||||
{
|
||||
Prop p0;
|
||||
AtomEntry *ae = RepAtom(at);
|
||||
ExpEntry *p;
|
||||
|
||||
READ_LOCK(ae->ARWLock);
|
||||
p = RepExpProp(p0 = ae->PropOfAE);
|
||||
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
|
||||
p = RepExpProp(p0 = p->NextOfPE);
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
return (p0);
|
||||
}
|
||||
|
||||
/* get expression entry for at/arity, at is already locked; */
|
||||
Prop
|
||||
LockedGetExpProp(AtomEntry *ae, unsigned int arity)
|
||||
{
|
||||
Prop p0;
|
||||
ExpEntry *p;
|
||||
|
||||
p = RepExpProp(p0 = ae->PropOfAE);
|
||||
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
|
||||
p = RepExpProp(p0 = p->NextOfPE);
|
||||
return (p0);
|
||||
}
|
||||
|
||||
Prop
|
||||
PredProp(Atom ap, unsigned int arity)
|
||||
/* get predicate entry for ap/arity; create it if neccessary. */
|
||||
{
|
||||
Prop p0;
|
||||
AtomEntry *ae = RepAtom(ap);
|
||||
PredEntry *p;
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
p = RepPredProp(p0 = RepAtom(ap)->PropOfAE);
|
||||
while (p0 && (p->KindOfPE != 0 || p->ArityOfPE != arity ||
|
||||
(p->ModuleOfPred && p->ModuleOfPred != CurrentModule)))
|
||||
p = RepPredProp(p0 = p->NextOfPE);
|
||||
|
||||
if (p0 != NIL) {
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
return (p0);
|
||||
}
|
||||
p = (PredEntry *) AllocAtomSpace(sizeof(*p));
|
||||
INIT_RWLOCK(p->PRWLock);
|
||||
p->KindOfPE = PEProp;
|
||||
p->ArityOfPE = arity;
|
||||
p->FirstClause = p->LastClause = NIL;
|
||||
p->PredFlags = 0L;
|
||||
p->StateOfPred = 0;
|
||||
p->OwnerFile = AtomNil;
|
||||
p->OpcodeOfPred = UNDEF_OPCODE;
|
||||
p->TrueCodeOfPred = p->CodeOfPred = (CODEADDR)(&(p->OpcodeOfPred));
|
||||
p->ModuleOfPred = CurrentModule;
|
||||
INIT_LOCK(p->StatisticsForPred.lock);
|
||||
p->StatisticsForPred.NOfEntries = 0;
|
||||
p->StatisticsForPred.NOfHeadSuccesses = 0;
|
||||
p->StatisticsForPred.NOfRetries = 0;
|
||||
#ifdef TABLING
|
||||
p->TableOfPred = NULL;
|
||||
#endif /* TABLING */
|
||||
/* careful that they don't cross MkFunctor */
|
||||
p->NextOfPE = ae->PropOfAE;
|
||||
ae->PropOfAE = p0 = AbsPredProp(p);
|
||||
if (arity == 0)
|
||||
p->FunctorOfPred = (Functor) ap;
|
||||
else {
|
||||
p->FunctorOfPred = InlinedUnlockedMkFunctor(ae, arity);
|
||||
}
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
return (p0);
|
||||
}
|
||||
|
||||
Term
|
||||
GetValue(Atom a)
|
||||
{
|
||||
Prop p0 = GetAProp(a, ValProperty);
|
||||
Term out;
|
||||
|
||||
if (p0 == NIL)
|
||||
return (TermNil);
|
||||
READ_LOCK(RepValProp(p0)->VRWLock);
|
||||
out = RepValProp(p0)->ValueOfVE;
|
||||
READ_UNLOCK(RepValProp(p0)->VRWLock);
|
||||
return (out);
|
||||
}
|
||||
|
||||
void
|
||||
PutValue(Atom a, Term v)
|
||||
{
|
||||
AtomEntry *ae = RepAtom(a);
|
||||
Prop p0;
|
||||
ValEntry *p;
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
p0 = LockedGetAProp(ae, ValProperty);
|
||||
if (p0 != NIL) {
|
||||
p = RepValProp(p0);
|
||||
WRITE_LOCK(p->VRWLock);
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
} else {
|
||||
p = (ValEntry *) AllocAtomSpace(sizeof(ValEntry));
|
||||
p->NextOfPE = RepAtom(a)->PropOfAE;
|
||||
RepAtom(a)->PropOfAE = AbsValProp(p);
|
||||
p->KindOfPE = ValProperty;
|
||||
/* take care that the lock for the property will be inited even
|
||||
if someone else searches for the property */
|
||||
INIT_RWLOCK(p->VRWLock);
|
||||
WRITE_LOCK(p->VRWLock);
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
}
|
||||
if (IsFloatTerm(v)) {
|
||||
/* store a float in code space, so that we can access the property */
|
||||
union {
|
||||
Float f;
|
||||
CELL ar[sizeof(Float) / sizeof(CELL)];
|
||||
} un;
|
||||
CELL *pt, *iptr;
|
||||
unsigned int i;
|
||||
|
||||
un.f = FloatOfTerm(v);
|
||||
if (p0 != NIL && IsApplTerm(p->ValueOfVE))
|
||||
pt = RepAppl(p->ValueOfVE);
|
||||
else {
|
||||
pt = (CELL *) AllocAtomSpace(sizeof(CELL)*(1 + 2*sizeof(Float)/sizeof(CELL)));
|
||||
}
|
||||
|
||||
pt[0] = (CELL)FunctorDouble;
|
||||
iptr = pt+1;
|
||||
for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
|
||||
*iptr++ = MkIntTerm(un.ar[i]/65536);
|
||||
*iptr++ = MkIntTerm(un.ar[i]%65536);
|
||||
}
|
||||
p->ValueOfVE = AbsAppl(pt);
|
||||
} else if (IsLongIntTerm(v)) {
|
||||
CELL *pt;
|
||||
Int val = LongIntOfTerm(v);
|
||||
if (p0 != NIL && IsApplTerm(p->ValueOfVE)) {
|
||||
pt = RepAppl(p->ValueOfVE);
|
||||
} else {
|
||||
pt = (CELL *) AllocAtomSpace(3 * sizeof(CELL));
|
||||
}
|
||||
pt[0] = (CELL)FunctorLongInt;
|
||||
pt[1] = MkIntTerm(val/65536);
|
||||
pt[2] = MkIntTerm(val%65536);
|
||||
p->ValueOfVE = AbsAppl(pt);
|
||||
} else {
|
||||
if (p0 != NIL && IsApplTerm(p->ValueOfVE)) {
|
||||
/* recover space */
|
||||
FreeCodeSpace((char *) (RepAppl(p->ValueOfVE)));
|
||||
}
|
||||
p->ValueOfVE = v;
|
||||
}
|
||||
WRITE_UNLOCK(p->VRWLock);
|
||||
}
|
||||
|
||||
Term
|
||||
StringToList(char *s)
|
||||
{
|
||||
register Term t;
|
||||
register unsigned char *cp = (unsigned char *)s + strlen(s);
|
||||
|
||||
t = MkAtomTerm(AtomNil);
|
||||
while (cp > (unsigned char *)s) {
|
||||
t = MkPairTerm(MkIntTerm(*--cp), t);
|
||||
}
|
||||
return (t);
|
||||
}
|
||||
|
||||
Term
|
||||
StringToListOfAtoms(char *s)
|
||||
{
|
||||
register Term t;
|
||||
char so[2];
|
||||
register unsigned char *cp = (unsigned char *)s + strlen(s);
|
||||
|
||||
so[1] = '\0';
|
||||
t = MkAtomTerm(AtomNil);
|
||||
while (cp > (unsigned char *)s) {
|
||||
so[0] = *--cp;
|
||||
t = MkPairTerm(MkAtomTerm(LookupAtom(so)), t);
|
||||
}
|
||||
return (t);
|
||||
}
|
||||
|
||||
Term
|
||||
ArrayToList(register Term *tp, int nof)
|
||||
{
|
||||
register Term *pt = tp + nof;
|
||||
register Term t;
|
||||
|
||||
t = MkAtomTerm(AtomNil);
|
||||
while (pt > tp) {
|
||||
Term tm = *--pt;
|
||||
#if SBA
|
||||
if (tm == 0)
|
||||
t = MkPairTerm((CELL)pt, t);
|
||||
else
|
||||
#endif
|
||||
t = MkPairTerm(tm, t);
|
||||
}
|
||||
return (t);
|
||||
}
|
||||
|
||||
int
|
||||
GetName(char *s, Term t)
|
||||
{
|
||||
register Term Head;
|
||||
register Int i;
|
||||
|
||||
if (IsVarTerm(t) || !IsPairTerm(t))
|
||||
return (FALSE);
|
||||
while (IsPairTerm(t)) {
|
||||
Head = HeadOfTerm(t);
|
||||
if (!IsNumTerm(Head))
|
||||
return (FALSE);
|
||||
i = IntOfTerm(Head);
|
||||
if (i < 0 || i > 255)
|
||||
return (FALSE);
|
||||
*s++ = i;
|
||||
t = TailOfTerm(t);
|
||||
}
|
||||
*s = '\0';
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
#ifdef SFUNC
|
||||
|
||||
Term
|
||||
MkSFTerm(Functor f, int n, Term *a, empty_value)
|
||||
{
|
||||
Term t, p = AbsAppl(H);
|
||||
int i;
|
||||
|
||||
*H++ = f;
|
||||
RESET_VARIABLE(H);
|
||||
++H;
|
||||
for (i = 1; i <= n; ++i) {
|
||||
t = Derefa(a++);
|
||||
if (t != empty_value) {
|
||||
*H++ = i;
|
||||
*H++ = t;
|
||||
}
|
||||
}
|
||||
*H++ = 0;
|
||||
return (p);
|
||||
}
|
||||
|
||||
CELL *
|
||||
ArgsOfSFTerm(Term t)
|
||||
{
|
||||
CELL *p = RepAppl(t) + 1;
|
||||
|
||||
while (*p != (CELL) p)
|
||||
p = CellPtr(*p) + 1;
|
||||
return (p + 1);
|
||||
}
|
||||
|
||||
#endif
|
|
@ -0,0 +1,935 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: alloc.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: allocating space *
|
||||
* version:$Id: alloc.c,v 1.1.1.1 2001-04-09 19:53:30 vsc Exp $ *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "alloc.h"
|
||||
#include "yapio.h"
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
#if HAVE_MEMORY_H
|
||||
#include <memory.h>
|
||||
#endif
|
||||
#if HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
|
||||
#if __simplescalar__
|
||||
#ifdef USE_MMAP
|
||||
#undef USE_MMAP
|
||||
#endif
|
||||
#ifdef USE_SBRK
|
||||
#undef USE_SBRK
|
||||
#endif
|
||||
#endif
|
||||
|
||||
STATIC_PROTO(void FreeBlock, (BlockHeader *));
|
||||
STATIC_PROTO(BlockHeader *GetBlock, (unsigned int));
|
||||
STATIC_PROTO(char *AllocHeap, (unsigned int));
|
||||
STATIC_PROTO(void RemoveFromFreeList, (BlockHeader *));
|
||||
STATIC_PROTO(void AddToFreeList, (BlockHeader *));
|
||||
|
||||
#ifdef LIGHT
|
||||
#include <stdlib.h>
|
||||
#endif
|
||||
|
||||
#define K ((Int) 1024)
|
||||
|
||||
#define MinHGap 256*K
|
||||
|
||||
/************************************************************************/
|
||||
/* Yap workspace management */
|
||||
|
||||
int
|
||||
SizeOfBlock(CODEADDR p)
|
||||
{
|
||||
BlockHeader *b = (BlockHeader *) (p - sizeof(YAP_SEG_SIZE));
|
||||
YAP_SEG_SIZE s = (b->b_size) & ~InUseFlag;
|
||||
return ((s - 1) * sizeof(YAP_SEG_SIZE));
|
||||
}
|
||||
|
||||
static void
|
||||
RemoveFromFreeList(BlockHeader *b)
|
||||
{
|
||||
BlockHeader *p;
|
||||
|
||||
p = b->b_next_size;
|
||||
LOCK(HeapUsedLock);
|
||||
HeapUsed += (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
|
||||
UNLOCK(HeapUsedLock);
|
||||
|
||||
if (p && b->b_size == p->b_size) {
|
||||
b = b->b_next;
|
||||
p->b_next = b;
|
||||
if (b)
|
||||
b->b_next_size = p;
|
||||
}
|
||||
else {
|
||||
BlockHeader **q = (BlockHeader **) &FreeBlocks;
|
||||
|
||||
while ((*q) != b)
|
||||
q = &((*q)->b_next_size);
|
||||
if (b->b_next) {
|
||||
p = b->b_next;
|
||||
*q = p;
|
||||
p->b_next_size = b->b_next_size;
|
||||
}
|
||||
else {
|
||||
*q = b->b_next_size;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
AddToFreeList(BlockHeader *b)
|
||||
{
|
||||
BlockHeader **q, *p;
|
||||
YAP_SEG_SIZE *sp;
|
||||
|
||||
/* insert on list of free blocks */
|
||||
q = (BlockHeader **) &FreeBlocks;
|
||||
sp = &(b->b_size) + b->b_size;
|
||||
*sp = b->b_size;
|
||||
LOCK(HeapUsedLock);
|
||||
HeapUsed -= (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
|
||||
UNLOCK(HeapUsedLock);
|
||||
|
||||
while ((p = *q) && p->b_size < b->b_size)
|
||||
q = &p->b_next_size;
|
||||
if (p && p->b_size == b->b_size) {
|
||||
b->b_next = p;
|
||||
b->b_next_size = p->b_next_size;
|
||||
p->b_next_size = b;
|
||||
}
|
||||
else {
|
||||
b->b_next = NIL;
|
||||
b->b_next_size = p;
|
||||
}
|
||||
*q = b;
|
||||
}
|
||||
|
||||
long int call_counter;
|
||||
|
||||
static void
|
||||
FreeBlock(BlockHeader *b)
|
||||
{
|
||||
BlockHeader *p;
|
||||
YAP_SEG_SIZE *sp;
|
||||
|
||||
/* sanity check */
|
||||
sp = &(b->b_size) + (b->b_size & ~InUseFlag);
|
||||
if (*sp != b->b_size) {
|
||||
#if !SHORT_INTS
|
||||
YP_fprintf(YP_stderr, "** sanity check failed in FreeBlock %p %x %x\n",
|
||||
b, b->b_size, Unsigned(*sp));
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "** sanity check failed in FreeBlock %p %lx %lx\n",
|
||||
b, b->b_size, *sp);
|
||||
#endif
|
||||
return;
|
||||
}
|
||||
b->b_size &= ~InUseFlag;
|
||||
LOCK(FreeBlocksLock);
|
||||
LOCK(GLOBAL_LOCKS_alloc_block);
|
||||
/* check if we can collapse with other blocsks */
|
||||
/* check previous */
|
||||
sp = &(b->b_size) - 1;
|
||||
if (!(*sp & InUseFlag)) { /* previous block is free */
|
||||
p = (BlockHeader *) (sp - *sp);
|
||||
RemoveFromFreeList(p);
|
||||
p->b_size += b->b_size + 1;
|
||||
b = p;
|
||||
}
|
||||
/* check following */
|
||||
sp = &(b->b_size) + b->b_size + 1;
|
||||
if (!(*sp & InUseFlag)) { /* following block is free */
|
||||
p = (BlockHeader *) sp;
|
||||
RemoveFromFreeList(p);
|
||||
b->b_size += p->b_size + 1;
|
||||
}
|
||||
/* insert on list of free blocks */
|
||||
AddToFreeList(b);
|
||||
UNLOCK(GLOBAL_LOCKS_alloc_block);
|
||||
UNLOCK(FreeBlocksLock);
|
||||
}
|
||||
|
||||
static BlockHeader *
|
||||
GetBlock(unsigned int n)
|
||||
{ /* get free block with size at least n */
|
||||
register BlockHeader **p, *b, *r;
|
||||
|
||||
if (FreeBlocks == NIL)
|
||||
return (NIL);
|
||||
p = (BlockHeader **) &FreeBlocks;
|
||||
while (((b = *p) != NIL) && b->b_size < n)
|
||||
p = &b->b_next_size;
|
||||
if (b == NIL || b->b_size < n)
|
||||
return (NIL);
|
||||
if ((r = b->b_next) == NIL)
|
||||
*p = b->b_next_size;
|
||||
else {
|
||||
r->b_next_size = b->b_next_size;
|
||||
*p = r;
|
||||
}
|
||||
LOCK(HeapUsedLock);
|
||||
HeapUsed += (b->b_size + 1) * sizeof(YAP_SEG_SIZE);
|
||||
if (HeapUsed > HeapMax)
|
||||
HeapMax = HeapUsed;
|
||||
UNLOCK(HeapUsedLock);
|
||||
return (b);
|
||||
}
|
||||
|
||||
static char *
|
||||
AllocHeap(unsigned int size)
|
||||
{
|
||||
BlockHeader *b, *n;
|
||||
YAP_SEG_SIZE *sp;
|
||||
|
||||
#if SIZEOF_INT_P==4
|
||||
size = (((size + 7) & 0xffffff8) >> 2) + 2; /* size in dwords + 2 */
|
||||
#endif
|
||||
#if SIZEOF_INT_P==8
|
||||
size = (((size + 7) & 0xffffff8) >> 3) + 2; /* size in dwords + 2 */
|
||||
#endif
|
||||
if (size < 6)
|
||||
size = 6;
|
||||
LOCK(FreeBlocksLock);
|
||||
LOCK(GLOBAL_LOCKS_alloc_block);
|
||||
if ((b = GetBlock(size))) {
|
||||
if (b->b_size >= size + 6 + 1) {
|
||||
n = (BlockHeader *) (((YAP_SEG_SIZE *) b) + size + 1);
|
||||
n->b_size = b->b_size - size - 1;
|
||||
b->b_size = size;
|
||||
AddToFreeList(n);
|
||||
}
|
||||
sp = &(b->b_size) + b->b_size;
|
||||
*sp = b->b_size | InUseFlag;
|
||||
b->b_size |= InUseFlag;
|
||||
UNLOCK(GLOBAL_LOCKS_alloc_block);
|
||||
UNLOCK(FreeBlocksLock);
|
||||
return (Addr(b) + sizeof(YAP_SEG_SIZE));
|
||||
}
|
||||
UNLOCK(FreeBlocksLock);
|
||||
if (!HEAPTOP_OWNER(worker_id)) {
|
||||
LOCK(HeapTopLock);
|
||||
}
|
||||
b = (BlockHeader *) HeapTop;
|
||||
HeapTop += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
LOCK(HeapUsedLock);
|
||||
HeapUsed += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
|
||||
#ifdef YAPOR
|
||||
if (HeapTop > Addr(GlobalBase) - MinHeapGap) {
|
||||
abort_optyap("No heap left in function AllocHeap");
|
||||
}
|
||||
#else
|
||||
if (HeapTop > Addr(AuxSp) - MinHeapGap) {
|
||||
HeapTop -= size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
HeapUsed -= size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
if (HeapTop > Addr(AuxSp)) {
|
||||
UNLOCK(HeapUsedLock);
|
||||
if (!HEAPTOP_OWNER(worker_id)) {
|
||||
UNLOCK(HeapTopLock);
|
||||
}
|
||||
/* we destroyed the stack */
|
||||
Abort("Stack Crashed against Heap...");
|
||||
return(NULL);
|
||||
} else {
|
||||
if (HeapTop + size * sizeof(CELL) + sizeof(YAP_SEG_SIZE) < Addr(AuxSp)) {
|
||||
/* small allocations, we can wait */
|
||||
HeapTop += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
HeapUsed += size * sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
UNLOCK(HeapUsedLock);
|
||||
if (!HEAPTOP_OWNER(worker_id)) {
|
||||
UNLOCK(HeapTopLock);
|
||||
}
|
||||
CreepFlag = Unsigned(LCL0) - Unsigned(H0);
|
||||
} else {
|
||||
if (size > SizeOfOverflow)
|
||||
SizeOfOverflow = size*sizeof(CELL) + sizeof(YAP_SEG_SIZE);
|
||||
/* big allocations, the caller must handle the problem */
|
||||
UNLOCK(HeapUsedLock);
|
||||
if (!HEAPTOP_OWNER(worker_id)) {
|
||||
UNLOCK(HeapTopLock);
|
||||
}
|
||||
return(NULL);
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif /* YAPOR */
|
||||
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
|
||||
if (HeapUsed > HeapMax)
|
||||
HeapMax = HeapUsed;
|
||||
HeapPlus = HeapTop + MinHGap / CellSize;
|
||||
UNLOCK(GLOBAL_LOCKS_alloc_block);
|
||||
UNLOCK(HeapUsedLock);
|
||||
b->b_size = size | InUseFlag;
|
||||
sp = &(b->b_size) + size;
|
||||
*sp = b->b_size;
|
||||
if (!HEAPTOP_OWNER(worker_id)) {
|
||||
UNLOCK(HeapTopLock);
|
||||
}
|
||||
return (Addr(b) + sizeof(YAP_SEG_SIZE));
|
||||
}
|
||||
|
||||
/* If you need to dinamically allocate space from the heap, this is
|
||||
* the macro you should use */
|
||||
ADDR
|
||||
PreAllocCodeSpace(void)
|
||||
{
|
||||
LOCK(HeapTopLock);
|
||||
HEAPTOP_OWN(worker_id);
|
||||
return (Addr(HeapTop) + sizeof(YAP_SEG_SIZE));
|
||||
}
|
||||
|
||||
#if defined(YAPOR) || defined(THREADS)
|
||||
/* Grabbing the HeapTop is an excellent idea for a sequential system,
|
||||
but does work as well in parallel systems. Anyway, this will do for now */
|
||||
void
|
||||
ReleasePreAllocCodeSpace(ADDR ptr)
|
||||
{
|
||||
HEAPTOP_DISOWN(worker_id);
|
||||
UNLOCK(HeapTopLock);
|
||||
}
|
||||
#endif
|
||||
|
||||
/* If you need to dinamically allocate space from the heap, this is
|
||||
* the macro you should use */
|
||||
void
|
||||
FreeCodeSpace(char *p)
|
||||
{
|
||||
FreeBlock(((BlockHeader *) (p - sizeof(YAP_SEG_SIZE))));
|
||||
}
|
||||
|
||||
char *
|
||||
AllocAtomSpace(unsigned int size)
|
||||
{
|
||||
return (AllocHeap(size));
|
||||
}
|
||||
|
||||
void
|
||||
FreeAtomSpace(char *p)
|
||||
{
|
||||
FreeCodeSpace(p);
|
||||
}
|
||||
|
||||
char *
|
||||
AllocCodeSpace(unsigned int size)
|
||||
{
|
||||
if (size < SmallSize + 2 * OpCodeSize + 3 * CellSize)
|
||||
return (AllocHeap(SmallSize + 2 * OpCodeSize + 3 * CellSize));
|
||||
return (AllocHeap(size));
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* Workspace allocation */
|
||||
/* */
|
||||
/* We provide four alternatives for workspace allocation. */
|
||||
/* - use 'mmap' */
|
||||
/* - use 'shmat' */
|
||||
/* - use 'sbrk' and provide a replacement to the 'malloc' library */
|
||||
/* - use 'malloc' */
|
||||
/* */
|
||||
/* In any of the alternatives the interface is through the following */
|
||||
/* functions: */
|
||||
/* void *InitWorkSpace(int s) - initial workspace allocation */
|
||||
/* int ExtendWorkSpace(int s) - extend workspace */
|
||||
/* int FreeWorkSpace() - release workspace */
|
||||
/************************************************************************/
|
||||
|
||||
#ifdef _WIN32
|
||||
|
||||
#include "windows.h"
|
||||
|
||||
#define BASE_ADDRESS ((LPVOID) MMAP_ADDR)
|
||||
#define MAX_WORKSPACE 0x20000000L
|
||||
|
||||
static LPVOID brk;
|
||||
|
||||
int
|
||||
ExtendWorkSpace(Int s)
|
||||
{
|
||||
LPVOID b;
|
||||
s = ((s-1)/page_size+1)*page_size;
|
||||
b = VirtualAlloc(brk, s, MEM_COMMIT, PAGE_READWRITE);
|
||||
if (b) {
|
||||
brk = (LPVOID) ((Int) brk + s);
|
||||
return TRUE;
|
||||
}
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
MALLOC_T
|
||||
InitWorkSpace(Int s)
|
||||
{
|
||||
SYSTEM_INFO si;
|
||||
LPVOID b;
|
||||
|
||||
GetSystemInfo(&si);
|
||||
page_size = si.dwPageSize;
|
||||
b = VirtualAlloc(BASE_ADDRESS, MAX_WORKSPACE, MEM_RESERVE, PAGE_NOACCESS);
|
||||
if (b==NULL) {
|
||||
YP_fprintf(YP_stderr,"[ Warning: YAP reserving space at a variable address ]\n");
|
||||
b = VirtualAlloc(0x0, MAX_WORKSPACE, MEM_RESERVE, PAGE_NOACCESS);
|
||||
if (b == NULL) {
|
||||
YP_fprintf(YP_stderr,"[ FATAL ERROR: YAP failed to reserve space ]\n");
|
||||
exit(1);
|
||||
}
|
||||
}
|
||||
brk = BASE_ADDRESS;
|
||||
|
||||
if (ExtendWorkSpace(s)) {
|
||||
return BASE_ADDRESS;
|
||||
} else {
|
||||
YP_fprintf(YP_stderr,"[ FATAL ERROR: YAP failed to reserve space ]\n");
|
||||
exit(1);
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
FreeWorkSpace(void)
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
#elif USE_MMAP
|
||||
|
||||
#if HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
#if HAVE_SYS_MMAN_H
|
||||
#include <sys/mman.h>
|
||||
#endif
|
||||
#if HAVE_SYS_TYPES_H
|
||||
#include <sys/types.h>
|
||||
#endif
|
||||
#if HAVE_FCNTL_H
|
||||
#include <fcntl.h>
|
||||
#endif
|
||||
|
||||
#ifdef MMAP_ADDR
|
||||
#define USE_FIXED 1
|
||||
#endif
|
||||
|
||||
static MALLOC_T WorkSpaceTop;
|
||||
|
||||
MALLOC_T
|
||||
InitWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T a;
|
||||
#if !defined(_AIX) && !defined(__APPLE__) && !__hpux
|
||||
int fd;
|
||||
#endif
|
||||
|
||||
#if defined(_AIX)
|
||||
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_ANONYMOUS | MAP_VARIABLE, -1, 0);
|
||||
#elif __hpux
|
||||
a = mmap(((void *)MMAP_ADDR), (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED, -1, 0);
|
||||
#elif defined(__APPLE__)
|
||||
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_ANON, -1, 0);
|
||||
#else
|
||||
fd = open("/dev/zero", O_RDWR);
|
||||
if (fd < 0) {
|
||||
#if HAVE_MKSTEMP
|
||||
char file[256];
|
||||
strncpy(file,"/tmp/YAP.TMPXXXXXX", 256);
|
||||
if (mkstemp(file) == -1) {
|
||||
#if HAVE_STRERROR
|
||||
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s (%s)", file, strerror(errno));
|
||||
#else
|
||||
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s", file);
|
||||
#endif
|
||||
return FALSE;
|
||||
}
|
||||
#else
|
||||
#if HAVE_TMPNAM
|
||||
char *file = tmpnam(NULL);
|
||||
#else
|
||||
char file[YAP_FILENAME_MAX];
|
||||
strcpy(file,"/tmp/mapfile");
|
||||
itos(getpid(), &file[12]);
|
||||
#endif /* HAVE_TMPNAM */
|
||||
#endif /* HAVE_MKSTEMP */
|
||||
fd = open(file, O_CREAT|O_RDWR);
|
||||
if (fd < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not open %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (lseek(fd, s, SEEK_SET) < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not lseek in mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (write(fd, "", 1) < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not write in mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (unlink(file) < 0) {
|
||||
Error(SYSTEM_ERROR,TermNil, "mmap could not unlink mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
#if USE_FIXED
|
||||
a = mmap(((void *)MMAP_ADDR), (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_FIXED, fd, 0);
|
||||
#else
|
||||
a = mmap(0, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE, fd, 0);
|
||||
if ((CELL)a & YAP_PROTECTED_MASK) {
|
||||
close(fd);
|
||||
Error(FATAL_ERROR, TermNil, "mmapped address %p collides with YAP tags ***", a);
|
||||
}
|
||||
if (close(fd) == -1) {
|
||||
Error(SYSTEM_ERROR, TermNil, "while closing mmaped file ***");
|
||||
return FALSE;
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
if
|
||||
#ifdef MMAP_FAILED
|
||||
(a == (MALLOC_T) MMAP_FAILED)
|
||||
#else
|
||||
(a == (MALLOC_T) - 1)
|
||||
#endif
|
||||
{
|
||||
Error(FATAL_ERROR, TermNil, "mmap cannot allocate memory ***");
|
||||
return(NULL);
|
||||
}
|
||||
WorkSpaceTop = (char *) a + s;
|
||||
return (void *) a;
|
||||
}
|
||||
|
||||
int
|
||||
ExtendWorkSpace(Int s)
|
||||
{
|
||||
#ifdef YAPOR
|
||||
abort_optyap("function ExtendWorkSpace called");
|
||||
#else
|
||||
|
||||
MALLOC_T a;
|
||||
|
||||
#if defined(_AIX) || defined(__hpux)
|
||||
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
|
||||
|
||||
#elif defined(__APPLE__)
|
||||
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_ANON, -1, 0);
|
||||
#else
|
||||
int fd;
|
||||
fd = open("/dev/zero", O_RDWR);
|
||||
if (fd < 0) {
|
||||
#if HAVE_MKSTEMP
|
||||
char file[256];
|
||||
strncpy(file,"/tmp/YAP.TMPXXXXXX",256);
|
||||
if (mkstemp(file) == -1) {
|
||||
#if HAVE_STRERROR
|
||||
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s (%s)", file, strerror(errno));
|
||||
#else
|
||||
Error(SYSTEM_ERROR, TermNil, "mkstemp could not create temporary file %s", file);
|
||||
#endif
|
||||
return FALSE;
|
||||
}
|
||||
#else
|
||||
#if HAVE_TMPNAM
|
||||
char *file = tmpnam(NULL);
|
||||
#else
|
||||
char file[YAP_FILENAME_MAX];
|
||||
strcpy(file,"/tmp/mapfile");
|
||||
itos(getpid(), &file[12]);
|
||||
#endif /* HAVE_TMPNAM */
|
||||
#endif /* HAVE_MKSTEMP */
|
||||
fd = open(file, O_CREAT|O_RDWR);
|
||||
if (fd < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not open %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (lseek(fd, s, SEEK_SET) < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not lseek in mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (write(fd, "", 1) < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not write in mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
if (unlink(file) < 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not unlink mmapped file %s", file);
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
a = mmap(WorkSpaceTop, (size_t) s, PROT_READ | PROT_WRITE | PROT_EXEC,
|
||||
MAP_PRIVATE | MAP_FIXED, fd, 0);
|
||||
|
||||
if (close(fd) == -1) {
|
||||
#if HAVE_STRERROR
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not close file (%s) ]\n", strerror(errno));
|
||||
#else
|
||||
Error(SYSTEM_ERROR, TermNil, "mmap could not close file ]\n");
|
||||
#endif
|
||||
return FALSE;
|
||||
}
|
||||
#endif
|
||||
|
||||
if (a == (MALLOC_T) - 1) {
|
||||
#if HAVE_STRERROR
|
||||
Error(SYSTEM_ERROR, TermNil, "could not allocate %d bytes (%s)", (int)s, strerror(errno));
|
||||
#else
|
||||
Error(SYSTEM_ERROR, TermNil, "could not allocate %d bytes", (int)s);
|
||||
#endif
|
||||
return FALSE;
|
||||
}
|
||||
WorkSpaceTop = (char *) a + s;
|
||||
#endif /* YAPOR */
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
int
|
||||
FreeWorkSpace(void)
|
||||
{
|
||||
return 1;
|
||||
}
|
||||
|
||||
#elif USE_SHM
|
||||
|
||||
#if HAVE_SYS_SHM_H
|
||||
#include <sys/shm.h>
|
||||
#endif
|
||||
|
||||
#ifndef MMAP_ADDR
|
||||
#define MMAP_ADDR 0x0L
|
||||
#endif
|
||||
|
||||
static MALLOC_T WorkSpaceTop;
|
||||
|
||||
MALLOC_T
|
||||
InitWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr;
|
||||
int shm_id;
|
||||
|
||||
/* mapping heap area */
|
||||
if((shm_id = shmget(IPC_PRIVATE, (size_t)s, SHM_R|SHM_W)) == -1) {
|
||||
Error(FATAL_ERROR, TermNil, "could not shmget %d bytes", s);
|
||||
return(NULL);
|
||||
}
|
||||
if((ptr = (MALLOC_T)shmat(shm_id, (void *) MMAP_ADDR, 0)) == (MALLOC_T) -1) {
|
||||
Error(FATAL_ERROR, TermNil, "could not shmat at %p", MMAP_ADDR);
|
||||
return(NULL);
|
||||
}
|
||||
if (shmctl(shm_id, IPC_RMID, 0) != 0) {
|
||||
Error(FATAL_ERROR, TermNil, "could not remove shm segment", shm_id);
|
||||
return(NULL);
|
||||
}
|
||||
WorkSpaceTop = (char *) ptr + s;
|
||||
return(ptr);
|
||||
}
|
||||
|
||||
int
|
||||
ExtendWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr;
|
||||
int shm_id;
|
||||
|
||||
/* mapping heap area */
|
||||
if((shm_id = shmget(IPC_PRIVATE, (size_t)s, SHM_R|SHM_W)) == -1) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not shmget %d bytes", s);
|
||||
return(FALSE);
|
||||
}
|
||||
if((ptr = (MALLOC_T)shmat(shm_id, WorkSpaceTop, 0)) == (MALLOC_T) -1) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not shmat at %p", MMAP_ADDR);
|
||||
return(FALSE);
|
||||
}
|
||||
if (shmctl(shm_id, IPC_RMID, 0) != 0) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not remove shm segment", shm_id);
|
||||
return(FALSE);
|
||||
}
|
||||
WorkSpaceTop = (char *) ptr + s;
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
int
|
||||
FreeWorkSpace(void)
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
#elif USE_SBRK
|
||||
|
||||
/***********************************************************************\
|
||||
* Worspace allocation based on 'sbrk' *
|
||||
* We have to provide a replacement for the 'malloc' functions. *
|
||||
* The situation is further complicated by the need to provide *
|
||||
* temporary 'malloc' space when restoring a previously saved state. *
|
||||
\***********************************************************************/
|
||||
|
||||
#ifdef _AIX
|
||||
char *STD_PROTO(sbrk, (int));
|
||||
|
||||
#endif
|
||||
|
||||
int in_limbo; /* non-zero when restoring a saved state */
|
||||
|
||||
#ifndef LIMBO_SIZE
|
||||
#define LIMBO_SIZE 32*K
|
||||
#endif
|
||||
|
||||
static char limbo_space[LIMBO_SIZE]; /* temporary malloc space */
|
||||
static char *limbo_p = limbo_space, *limbo_pp = 0;
|
||||
|
||||
MALLOC_T
|
||||
InitWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr = (MALLOC_T)sbrk(s);
|
||||
|
||||
if (ptr == ((MALLOC_T) - 1)) {
|
||||
Error(FATAL_ERROR, TermNil, "could not allocate %d bytes", s);
|
||||
return(NULL);
|
||||
}
|
||||
return(ptr);
|
||||
}
|
||||
|
||||
int
|
||||
ExtendWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr = (MALLOC_T)sbrk(s);
|
||||
if (ptr == ((MALLOC_T) - 1)) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not expand stacks over %d bytes", s);
|
||||
return(FALSE);
|
||||
}
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
int
|
||||
FreeWorkSpace(void)
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
MALLOC_T
|
||||
malloc(size_t size)
|
||||
{
|
||||
if (in_limbo) {
|
||||
limbo_pp = limbo_p;
|
||||
limbo_p += (size + 7) & 0xffff8;
|
||||
if (limbo_p >= &limbo_space[LIMBO_SIZE])
|
||||
return(NULL);
|
||||
return (limbo_pp);
|
||||
}
|
||||
else {
|
||||
CODEADDR codep = (CODEADDR)AllocCodeSpace(size + 2*sizeof(void *));
|
||||
if (codep == NIL)
|
||||
return(NIL);
|
||||
else
|
||||
return(codep + 2*sizeof(void *));
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
free(MALLOC_T ptr)
|
||||
{
|
||||
BlockHeader *b = (BlockHeader *) (((char *) ptr) - 2*sizeof(void *) - sizeof(YAP_SEG_SIZE));
|
||||
|
||||
if (ptr == limbo_pp) {
|
||||
limbo_p = limbo_pp;
|
||||
return;
|
||||
}
|
||||
if (!ptr)
|
||||
return;
|
||||
if ((char *) ptr < HeapBase || (char *) ptr > HeapTop)
|
||||
return;
|
||||
if (!(b->b_size & InUseFlag))
|
||||
return;
|
||||
FreeCodeSpace((char *) ptr - 2*sizeof(void *));
|
||||
}
|
||||
|
||||
MALLOC_T
|
||||
realloc(MALLOC_T ptr, size_t size)
|
||||
{
|
||||
MALLOC_T new = malloc(size);
|
||||
|
||||
if (ptr)
|
||||
memcpy(new, ptr, size);
|
||||
free(ptr);
|
||||
return (new);
|
||||
}
|
||||
|
||||
MALLOC_T
|
||||
calloc(size_t n, size_t e)
|
||||
{
|
||||
unsigned k = n * e;
|
||||
MALLOC_T p = malloc(k);
|
||||
|
||||
memset(p, 0, k);
|
||||
return (p);
|
||||
}
|
||||
|
||||
#ifdef M_MXFAST
|
||||
int
|
||||
mallopt(cmd, value)
|
||||
{
|
||||
return (value);
|
||||
}
|
||||
|
||||
static struct mallinfo xmall;
|
||||
|
||||
struct mallinfo
|
||||
mallinfo(void)
|
||||
{
|
||||
return (xmall);
|
||||
}
|
||||
#endif
|
||||
|
||||
#else
|
||||
|
||||
/* use malloc to initiliase memory */
|
||||
|
||||
/* user should ask for a lot of memory first */
|
||||
|
||||
static int total_space;
|
||||
|
||||
MALLOC_T
|
||||
InitWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr = (MALLOC_T)malloc(s);
|
||||
total_space = s;
|
||||
|
||||
if (ptr == ((MALLOC_T) - 1)) {
|
||||
Error(FATAL_ERROR, TermNil, "could not allocate %d bytes", s);
|
||||
return(NULL);
|
||||
}
|
||||
return(ptr);
|
||||
}
|
||||
|
||||
int
|
||||
ExtendWorkSpace(Int s)
|
||||
{
|
||||
MALLOC_T ptr;
|
||||
total_space += s;
|
||||
|
||||
ptr = (MALLOC_T)realloc((void *)HeapBase, total_space);
|
||||
if (ptr == ((MALLOC_T) - 1)) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not expand stacks %d bytes", s);
|
||||
return(FALSE);
|
||||
}
|
||||
if (ptr != (MALLOC_T)HeapBase) {
|
||||
Error(SYSTEM_ERROR, TermNil, "could not expand contiguous stacks %d bytes", s);
|
||||
return(FALSE);
|
||||
}
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
int
|
||||
FreeWorkSpace(void)
|
||||
{
|
||||
return TRUE;
|
||||
}
|
||||
#endif
|
||||
|
||||
void
|
||||
YAP_InitHeap(void *heap_addr)
|
||||
{
|
||||
/* allocate space */
|
||||
HeapBase = heap_addr;
|
||||
|
||||
/* reserve space for specially allocated functors and atoms so that
|
||||
their values can be known statically */
|
||||
HeapTop = HeapBase + AdjustSize(sizeof(all_heap_codes));
|
||||
|
||||
HeapMax = HeapUsed = HeapTop-HeapBase;
|
||||
|
||||
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
|
||||
HeapTop = HeapTop + sizeof(YAP_SEG_SIZE);
|
||||
*((YAP_SEG_SIZE *) HeapTop) = InUseFlag;
|
||||
|
||||
HeapPlus = HeapTop + MinHGap / CellSize;
|
||||
FreeBlocks = NIL;
|
||||
HEAPTOP_DISOWN(worker_id);
|
||||
|
||||
#if defined(YAPOR) || defined(TABLING)
|
||||
#ifdef USE_HEAP
|
||||
/* Try to make the system to crash */
|
||||
BaseAllocArea = NULL;
|
||||
TopAllocArea = BaseAllocArea;
|
||||
#else
|
||||
BaseAllocArea = AllocCodeSpace(OPT_CHUNK_SIZE);
|
||||
TopAllocArea = BaseAllocArea;
|
||||
#endif
|
||||
|
||||
LOCAL = REMOTE; /* point to the first area */
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
void
|
||||
InitMemory(int Trail, int Heap, int Stack)
|
||||
{
|
||||
Int pm, sa, ta;
|
||||
|
||||
Trail = AdjustPageSize(Trail * K);
|
||||
Stack = AdjustPageSize(Stack * K);
|
||||
Heap = AdjustPageSize(Heap * K);
|
||||
|
||||
pm = (Trail + Heap + Stack); /* memory to be
|
||||
* requested */
|
||||
sa = Stack; /* stack area size */
|
||||
ta = Trail; /* trail area size */
|
||||
|
||||
YAP_InitHeap(InitWorkSpace(pm));
|
||||
|
||||
TrailTop = HeapBase + pm;
|
||||
LocalBase = TrailTop - ta;
|
||||
TrailBase = LocalBase + sizeof(CELL);
|
||||
|
||||
GlobalBase = LocalBase - sa;
|
||||
AuxTop = GlobalBase - CellSize; /* avoid confusions while
|
||||
* * restoring */
|
||||
AuxSp = (CELL *) AuxTop;
|
||||
|
||||
#ifdef DEBUG
|
||||
#if SIZEOF_INT_P!=SIZEOF_INT
|
||||
if (output_msg) {
|
||||
YP_fprintf(YP_stderr, "HeapBase = %p GlobalBase = %p\n LocalBase = %p TrailTop = %p\n",
|
||||
HeapBase, GlobalBase, LocalBase, TrailTop);
|
||||
#else
|
||||
if (output_msg) {
|
||||
YP_fprintf(YP_stderr, "HeapBase = %x GlobalBase = %x\n LocalBase = %x TrailTop = %x\n",
|
||||
(UInt) HeapBase, (UInt) GlobalBase,
|
||||
(UInt) LocalBase, (UInt) TrailTop);
|
||||
#endif
|
||||
|
||||
#if !SHORT_INTS
|
||||
YP_fprintf(YP_stderr, "Heap+Aux: %d\tLocal+Global: %d\tTrail: %d\n",
|
||||
pm - sa - ta, sa, ta);
|
||||
#else /* SHORT_INTS */
|
||||
YP_fprintf(YP_stderr, "Heap+Aux: %ld\tLocal+Global: %ld\tTrail: %ld\n",
|
||||
pm - sa - ta, sa, ta);
|
||||
#endif /* SHORT_INTS */
|
||||
}
|
||||
#endif /* DEBUG */
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,823 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: analyst.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: Tracing the abstract machine *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef ANALYST
|
||||
#include "Yatom.h"
|
||||
#include "yapio.h"
|
||||
#ifdef HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
STATIC_PROTO(Int p_reset_op_counters, (void));
|
||||
STATIC_PROTO(Int p_show_op_counters, (void));
|
||||
STATIC_PROTO(Int p_show_ops_by_group, (void));
|
||||
|
||||
int opcount[_std_top + 1];
|
||||
|
||||
static char *op_names[_std_top + 1] =
|
||||
{
|
||||
#define OPCODE(OP,TYPE) #OP
|
||||
#include "YapOpcodes.h"
|
||||
#undef OPCODE
|
||||
};
|
||||
|
||||
static Int
|
||||
p_reset_op_counters()
|
||||
{
|
||||
int i;
|
||||
|
||||
for (i = 0; i <= _std_top; ++i)
|
||||
opcount[i] = 0;
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
static void
|
||||
print_instruction(int inst)
|
||||
{
|
||||
int j;
|
||||
|
||||
YP_fprintf(YP_stderr, "%s", op_names[inst]);
|
||||
for (j = strlen(op_names[inst]); j < 25; j++)
|
||||
YP_putc(' ', YP_stderr);
|
||||
j = opcount[inst];
|
||||
if (j < 100000000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 10000000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 1000000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 100000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 10000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 1000) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 100) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
if (j < 10) {
|
||||
YP_putc(' ', YP_stderr);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
YP_fprintf(YP_stderr, "%d\n", opcount[inst]);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_show_op_counters()
|
||||
{
|
||||
int i;
|
||||
char *program;
|
||||
Term t1 = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t1) || !IsAtomTerm(t1))
|
||||
return (FALSE);
|
||||
else
|
||||
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Instructions Executed in %s \n", program);
|
||||
for (i = 0; i <= _std_top; ++i)
|
||||
print_instruction(i);
|
||||
YP_fprintf(YP_stderr, "\n Control Instructions \n");
|
||||
print_instruction(_op_fail);
|
||||
print_instruction(_execute);
|
||||
print_instruction(_dexecute);
|
||||
print_instruction(_call);
|
||||
print_instruction(_fcall);
|
||||
print_instruction(_call_cpred);
|
||||
print_instruction(_call_c_wfail);
|
||||
print_instruction(_procceed);
|
||||
print_instruction(_allocate);
|
||||
print_instruction(_deallocate);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Choice Point Manipulation Instructions\n");
|
||||
print_instruction(_try_me);
|
||||
print_instruction(_retry_me);
|
||||
print_instruction(_trust_me);
|
||||
print_instruction(_try_me0);
|
||||
print_instruction(_retry_me0);
|
||||
print_instruction(_trust_me0);
|
||||
print_instruction(_try_me1);
|
||||
print_instruction(_retry_me1);
|
||||
print_instruction(_trust_me1);
|
||||
print_instruction(_try_me2);
|
||||
print_instruction(_retry_me2);
|
||||
print_instruction(_trust_me2);
|
||||
print_instruction(_try_me3);
|
||||
print_instruction(_retry_me3);
|
||||
print_instruction(_trust_me3);
|
||||
print_instruction(_try_me4);
|
||||
print_instruction(_retry_me4);
|
||||
print_instruction(_trust_me4);
|
||||
print_instruction(_try_clause);
|
||||
print_instruction(_try_in);
|
||||
print_instruction(_retry);
|
||||
print_instruction(_trust_in);
|
||||
print_instruction(_trust);
|
||||
print_instruction(_retry_first);
|
||||
print_instruction(_trust_first_in);
|
||||
print_instruction(_trust_first);
|
||||
print_instruction(_retry_tail);
|
||||
print_instruction(_trust_tail_in);
|
||||
print_instruction(_trust_tail);
|
||||
print_instruction(_retry_head);
|
||||
print_instruction(_trust_head_in);
|
||||
print_instruction(_trust_head);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Disjunction Instructions\n");
|
||||
print_instruction(_either);
|
||||
print_instruction(_or_else);
|
||||
print_instruction(_or_last);
|
||||
print_instruction(_jump);
|
||||
print_instruction(_move_back);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Dynamic Predicates Choicepoint Instructions\n");
|
||||
print_instruction(_try_and_mark);
|
||||
print_instruction(_retry_and_mark);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n C Predicates Choicepoint Instructions\n");
|
||||
print_instruction(_try_c);
|
||||
print_instruction(_retry_c);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Indexing Instructions\n");
|
||||
YP_fprintf(YP_stderr, "\n Switch on Type\n");
|
||||
print_instruction(_switch_on_type);
|
||||
print_instruction(_switch_on_nonv);
|
||||
print_instruction(_switch_last);
|
||||
print_instruction(_switch_on_head);
|
||||
print_instruction(_switch_list_nl);
|
||||
print_instruction(_switch_list_nl_prefetch);
|
||||
print_instruction(_switch_nv_list);
|
||||
print_instruction(_switch_l_list);
|
||||
YP_fprintf(YP_stderr, "\n Switch on Value\n");
|
||||
print_instruction(_if_cons);
|
||||
print_instruction(_go_on_cons);
|
||||
print_instruction(_switch_on_cons);
|
||||
print_instruction(_if_func);
|
||||
print_instruction(_go_on_func);
|
||||
print_instruction(_switch_on_func);
|
||||
YP_fprintf(YP_stderr, "\n Other Switches\n");
|
||||
print_instruction(_if_not_then);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Get Instructions\n");
|
||||
print_instruction(_get_x_var);
|
||||
print_instruction(_get_y_var);
|
||||
print_instruction(_get_x_val);
|
||||
print_instruction(_get_y_val);
|
||||
print_instruction(_get_atom);
|
||||
print_instruction(_get_list);
|
||||
print_instruction(_get_struct);
|
||||
YP_fprintf(YP_stderr, "\n Optimised Get Instructions\n");
|
||||
print_instruction(_glist_valx);
|
||||
print_instruction(_glist_valy);
|
||||
print_instruction(_gl_void_varx);
|
||||
print_instruction(_gl_void_vary);
|
||||
print_instruction(_gl_void_valx);
|
||||
print_instruction(_gl_void_valy);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Unify Read Instructions\n");
|
||||
print_instruction(_unify_x_var);
|
||||
print_instruction(_unify_x_var2);
|
||||
print_instruction(_unify_y_var);
|
||||
print_instruction(_unify_x_val);
|
||||
print_instruction(_unify_y_val);
|
||||
print_instruction(_unify_x_loc);
|
||||
print_instruction(_unify_y_loc);
|
||||
print_instruction(_unify_atom);
|
||||
print_instruction(_unify_n_atoms);
|
||||
print_instruction(_unify_n_voids);
|
||||
print_instruction(_unify_list);
|
||||
print_instruction(_unify_struct);
|
||||
YP_fprintf(YP_stderr, "\n Unify Last Read Instructions\n");
|
||||
print_instruction(_unify_l_x_var);
|
||||
print_instruction(_unify_l_x_var2);
|
||||
print_instruction(_unify_l_y_var);
|
||||
print_instruction(_unify_l_x_val);
|
||||
print_instruction(_unify_l_y_val);
|
||||
print_instruction(_unify_l_x_loc);
|
||||
print_instruction(_unify_l_y_loc);
|
||||
print_instruction(_unify_l_atom);
|
||||
print_instruction(_unify_l_n_voids);
|
||||
print_instruction(_unify_l_list);
|
||||
print_instruction(_unify_l_struc);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Unify Write Instructions\n");
|
||||
print_instruction(_unify_x_var_write);
|
||||
print_instruction(_unify_x_var2_write);
|
||||
print_instruction(_unify_y_var_write);
|
||||
print_instruction(_unify_x_val_write);
|
||||
print_instruction(_unify_y_val_write);
|
||||
print_instruction(_unify_x_loc_write);
|
||||
print_instruction(_unify_y_loc_write);
|
||||
print_instruction(_unify_atom_write);
|
||||
print_instruction(_unify_n_atoms_write);
|
||||
print_instruction(_unify_n_voids_write);
|
||||
print_instruction(_unify_list_write);
|
||||
print_instruction(_unify_struct_write);
|
||||
YP_fprintf(YP_stderr, "\n Unify Last Read Instructions\n");
|
||||
print_instruction(_unify_l_x_var_write);
|
||||
print_instruction(_unify_l_x_var2_write);
|
||||
print_instruction(_unify_l_y_var_write);
|
||||
print_instruction(_unify_l_x_val_write);
|
||||
print_instruction(_unify_l_y_val_write);
|
||||
print_instruction(_unify_l_x_loc_write);
|
||||
print_instruction(_unify_l_y_loc_write);
|
||||
print_instruction(_unify_l_atom_write);
|
||||
print_instruction(_unify_l_n_voids_write);
|
||||
print_instruction(_unify_l_list_write);
|
||||
print_instruction(_unify_l_struc_write);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Put Instructions\n");
|
||||
print_instruction(_put_x_var);
|
||||
print_instruction(_put_y_var);
|
||||
print_instruction(_put_x_val);
|
||||
print_instruction(_put_y_val);
|
||||
print_instruction(_put_unsafe);
|
||||
print_instruction(_put_atom);
|
||||
print_instruction(_put_list);
|
||||
print_instruction(_put_struct);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Write Instructions\n");
|
||||
print_instruction(_write_x_var);
|
||||
print_instruction(_write_y_var);
|
||||
print_instruction(_write_x_val);
|
||||
print_instruction(_write_y_val);
|
||||
print_instruction(_write_x_loc);
|
||||
print_instruction(_write_y_loc);
|
||||
print_instruction(_write_atom);
|
||||
print_instruction(_write_n_atoms);
|
||||
print_instruction(_write_n_voids);
|
||||
print_instruction(_write_list);
|
||||
print_instruction(_write_struct);
|
||||
YP_fprintf(YP_stderr, "\n Last Write Instructions\n");
|
||||
print_instruction(_write_l_list);
|
||||
print_instruction(_write_l_struc);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Miscellaneous Instructions\n");
|
||||
print_instruction(_cut);
|
||||
print_instruction(_cut_t);
|
||||
print_instruction(_cut_e);
|
||||
print_instruction(_skip);
|
||||
print_instruction(_pop);
|
||||
print_instruction(_pop_n);
|
||||
print_instruction(_trust_fail);
|
||||
print_instruction(_index_pred);
|
||||
print_instruction(_save_b_x);
|
||||
print_instruction(_save_b_y);
|
||||
print_instruction(_save_pair_x);
|
||||
print_instruction(_save_pair_y);
|
||||
print_instruction(_save_pair_x_write);
|
||||
print_instruction(_save_pair_y_write);
|
||||
print_instruction(_save_appl_x);
|
||||
print_instruction(_save_appl_y);
|
||||
print_instruction(_save_appl_x_write);
|
||||
print_instruction(_save_appl_y_write);
|
||||
print_instruction(_Ystop);
|
||||
print_instruction(_Nstop);
|
||||
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
typedef struct {
|
||||
int nxvar, nxval, nyvar, nyval, ncons, nlist, nstru, nmisc;
|
||||
} uopcount;
|
||||
|
||||
typedef struct {
|
||||
int ncalls, nexecs, nproceeds, ncallbips, ncuts, nallocs, ndeallocs;
|
||||
} copcount;
|
||||
|
||||
typedef struct {
|
||||
int ntries, nretries, ntrusts;
|
||||
} ccpcount;
|
||||
|
||||
static Int
|
||||
p_show_ops_by_group(void)
|
||||
{
|
||||
|
||||
uopcount c_get, c_unify, c_put, c_write;
|
||||
copcount c_control;
|
||||
ccpcount c_cp;
|
||||
int gets, unifies, puts, writes, controls, choice_pts, indexes, misc,
|
||||
total;
|
||||
char *program;
|
||||
Term t1;
|
||||
|
||||
t1 = Deref(ARG1);
|
||||
if (IsVarTerm(t1) || !IsAtomTerm(t1))
|
||||
return (FALSE);
|
||||
else
|
||||
program = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
||||
|
||||
c_get.nxvar =
|
||||
opcount[_get_x_var];
|
||||
c_get.nyvar =
|
||||
opcount[_get_y_var];
|
||||
c_get.nxval =
|
||||
opcount[_get_x_val];
|
||||
c_get.nyval =
|
||||
opcount[_get_y_val];
|
||||
c_get.ncons =
|
||||
opcount[_get_atom];
|
||||
c_get.nlist =
|
||||
opcount[_get_list] +
|
||||
opcount[_glist_valx] +
|
||||
opcount[_glist_valy] +
|
||||
opcount[_gl_void_varx] +
|
||||
opcount[_gl_void_vary] +
|
||||
opcount[_gl_void_valx] +
|
||||
opcount[_gl_void_valy];
|
||||
c_get.nstru =
|
||||
opcount[_get_struct];
|
||||
|
||||
gets = c_get.nxvar + c_get.nyvar + c_get.nxval + c_get.nyval +
|
||||
c_get.ncons + c_get.nlist + c_get.nstru;
|
||||
|
||||
c_unify.nxvar =
|
||||
opcount[_unify_x_var] +
|
||||
opcount[_unify_void] +
|
||||
opcount[_unify_n_voids] +
|
||||
2 * opcount[_unify_x_var2] +
|
||||
2 * opcount[_gl_void_varx] +
|
||||
opcount[_gl_void_vary] +
|
||||
opcount[_gl_void_valx] +
|
||||
opcount[_unify_l_x_var] +
|
||||
opcount[_unify_l_void] +
|
||||
opcount[_unify_l_n_voids] +
|
||||
2 * opcount[_unify_l_x_var2] +
|
||||
opcount[_unify_x_var_write] +
|
||||
opcount[_unify_void_write] +
|
||||
opcount[_unify_n_voids_write] +
|
||||
2 * opcount[_unify_x_var2_write] +
|
||||
opcount[_unify_l_x_var_write] +
|
||||
opcount[_unify_l_void_write] +
|
||||
opcount[_unify_l_n_voids_write] +
|
||||
2 * opcount[_unify_l_x_var2_write];
|
||||
c_unify.nyvar =
|
||||
opcount[_unify_y_var] +
|
||||
opcount[_gl_void_vary] +
|
||||
opcount[_unify_l_y_var] +
|
||||
opcount[_unify_y_var_write] +
|
||||
opcount[_unify_l_y_var_write];
|
||||
c_unify.nxval =
|
||||
opcount[_unify_x_val] +
|
||||
opcount[_unify_x_loc] +
|
||||
opcount[_glist_valx] +
|
||||
opcount[_gl_void_valx] +
|
||||
opcount[_unify_l_x_val] +
|
||||
opcount[_unify_l_x_loc] +
|
||||
opcount[_unify_x_val_write] +
|
||||
opcount[_unify_x_loc_write] +
|
||||
opcount[_unify_l_x_val_write] +
|
||||
opcount[_unify_l_x_loc_write];
|
||||
c_unify.nyval =
|
||||
opcount[_unify_y_val] +
|
||||
opcount[_unify_y_loc] +
|
||||
opcount[_glist_valy] +
|
||||
opcount[_gl_void_valy] +
|
||||
opcount[_unify_l_y_val] +
|
||||
opcount[_unify_l_y_loc] +
|
||||
opcount[_unify_y_val_write] +
|
||||
opcount[_unify_y_loc_write] +
|
||||
opcount[_unify_l_y_val_write] +
|
||||
opcount[_unify_l_y_loc_write];
|
||||
c_unify.ncons =
|
||||
opcount[_unify_atom] +
|
||||
opcount[_unify_n_atoms] +
|
||||
opcount[_unify_l_atom] +
|
||||
opcount[_unify_atom_write] +
|
||||
opcount[_unify_n_atoms_write] +
|
||||
opcount[_unify_l_atom_write];
|
||||
c_unify.nlist =
|
||||
opcount[_unify_list] +
|
||||
opcount[_unify_l_list] +
|
||||
opcount[_unify_list_write] +
|
||||
opcount[_unify_l_list_write];
|
||||
c_unify.nstru =
|
||||
opcount[_unify_struct] +
|
||||
opcount[_unify_l_struc] +
|
||||
opcount[_unify_struct_write] +
|
||||
opcount[_unify_l_struc_write];
|
||||
c_unify.nmisc =
|
||||
opcount[_pop] +
|
||||
opcount[_pop_n];
|
||||
|
||||
unifies = c_unify.nxvar + c_unify.nyvar + c_unify.nxval + c_unify.nyval +
|
||||
c_unify.ncons + c_unify.nlist + c_unify.nstru + c_unify.nmisc;
|
||||
|
||||
c_put.nxvar =
|
||||
opcount[_put_x_var];
|
||||
c_put.nyvar =
|
||||
opcount[_put_y_var];
|
||||
c_put.nxval =
|
||||
opcount[_put_x_val];
|
||||
c_put.nyval =
|
||||
opcount[_put_y_val];
|
||||
c_put.ncons =
|
||||
opcount[_put_atom];
|
||||
c_put.nlist =
|
||||
opcount[_put_list];
|
||||
c_put.nstru =
|
||||
opcount[_put_struct];
|
||||
|
||||
puts = c_put.nxvar + c_put.nyvar + c_put.nxval + c_put.nyval +
|
||||
c_put.ncons + c_put.nlist + c_put.nstru;
|
||||
|
||||
c_write.nxvar =
|
||||
opcount[_write_x_var] +
|
||||
opcount[_write_void] +
|
||||
opcount[_write_n_voids];
|
||||
c_write.nyvar =
|
||||
opcount[_write_y_var];
|
||||
c_write.nxval =
|
||||
opcount[_write_x_val];
|
||||
c_write.nyval =
|
||||
opcount[_write_y_val];
|
||||
c_write.ncons =
|
||||
opcount[_write_atom];
|
||||
c_write.nlist =
|
||||
opcount[_write_list];
|
||||
c_write.nstru =
|
||||
opcount[_write_struct];
|
||||
|
||||
writes = c_write.nxvar + c_write.nyvar + c_write.nxval + c_write.nyval +
|
||||
c_write.ncons + c_write.nlist + c_write.nstru;
|
||||
|
||||
c_control.nexecs =
|
||||
opcount[_execute] +
|
||||
opcount[_dexecute];
|
||||
|
||||
c_control.ncalls =
|
||||
opcount[_call] +
|
||||
opcount[_fcall];
|
||||
|
||||
c_control.nproceeds =
|
||||
opcount[_procceed];
|
||||
|
||||
c_control.ncallbips =
|
||||
opcount[_call_cpred] +
|
||||
opcount[_call_c_wfail] +
|
||||
opcount[_try_c] +
|
||||
opcount[_retry_c] +
|
||||
opcount[_op_fail] +
|
||||
opcount[_trust_fail] +
|
||||
opcount[_p_atom_x] +
|
||||
opcount[_p_atom_y] +
|
||||
opcount[_p_atomic_x] +
|
||||
opcount[_p_atomic_y] +
|
||||
opcount[_p_compound_x] +
|
||||
opcount[_p_compound_y] +
|
||||
opcount[_p_float_x] +
|
||||
opcount[_p_float_y] +
|
||||
opcount[_p_integer_x] +
|
||||
opcount[_p_integer_y] +
|
||||
opcount[_p_nonvar_x] +
|
||||
opcount[_p_nonvar_y] +
|
||||
opcount[_p_number_x] +
|
||||
opcount[_p_number_y] +
|
||||
opcount[_p_var_x] +
|
||||
opcount[_p_var_y] +
|
||||
opcount[_p_db_ref_x] +
|
||||
opcount[_p_db_ref_y] +
|
||||
opcount[_p_cut_by_x] +
|
||||
opcount[_p_cut_by_y] +
|
||||
opcount[_p_primitive_x] +
|
||||
opcount[_p_primitive_y] +
|
||||
opcount[_p_equal] +
|
||||
opcount[_p_plus_vv] +
|
||||
opcount[_p_plus_vc] +
|
||||
opcount[_p_plus_y_vv] +
|
||||
opcount[_p_plus_y_vc] +
|
||||
opcount[_p_minus_vv] +
|
||||
opcount[_p_minus_cv] +
|
||||
opcount[_p_minus_y_vv] +
|
||||
opcount[_p_minus_y_cv] +
|
||||
opcount[_p_times_vv] +
|
||||
opcount[_p_times_vc] +
|
||||
opcount[_p_times_y_vv] +
|
||||
opcount[_p_times_y_vc] +
|
||||
opcount[_p_div_vv] +
|
||||
opcount[_p_div_vc] +
|
||||
opcount[_p_div_cv] +
|
||||
opcount[_p_div_y_vv] +
|
||||
opcount[_p_div_y_vc] +
|
||||
opcount[_p_div_y_cv] +
|
||||
opcount[_p_or_vv] +
|
||||
opcount[_p_or_vc] +
|
||||
opcount[_p_or_y_vv] +
|
||||
opcount[_p_or_y_vc] +
|
||||
opcount[_p_and_vv] +
|
||||
opcount[_p_and_vc] +
|
||||
opcount[_p_and_y_vv] +
|
||||
opcount[_p_and_y_vc] +
|
||||
opcount[_p_sll_vv] +
|
||||
opcount[_p_sll_vc] +
|
||||
opcount[_p_sll_y_vv] +
|
||||
opcount[_p_sll_y_vc] +
|
||||
opcount[_p_slr_vv] +
|
||||
opcount[_p_slr_vc] +
|
||||
opcount[_p_slr_y_vv] +
|
||||
opcount[_p_slr_y_vc] +
|
||||
opcount[_p_dif] +
|
||||
opcount[_p_eq] +
|
||||
opcount[_p_arg] +
|
||||
opcount[_p_functor];
|
||||
|
||||
c_control.ncuts =
|
||||
opcount[_cut] +
|
||||
opcount[_cut_t] +
|
||||
opcount[_cut_e] +
|
||||
opcount[_comit_b_x] +
|
||||
opcount[_comit_b_y];
|
||||
|
||||
c_control.nallocs =
|
||||
opcount[_allocate] +
|
||||
opcount[_fcall];
|
||||
|
||||
c_control.ndeallocs =
|
||||
opcount[_dexecute] +
|
||||
opcount[_deallocate];
|
||||
|
||||
controls =
|
||||
c_control.nexecs +
|
||||
c_control.ncalls +
|
||||
c_control.nproceeds +
|
||||
c_control.ncuts +
|
||||
c_control.nallocs +
|
||||
c_control.ndeallocs +
|
||||
opcount[_jump] +
|
||||
opcount[_move_back] +
|
||||
opcount[_try_in];
|
||||
|
||||
|
||||
|
||||
c_cp.ntries =
|
||||
opcount[_try_me] +
|
||||
opcount[_try_me0] +
|
||||
opcount[_try_me1] +
|
||||
opcount[_try_me2] +
|
||||
opcount[_try_me3] +
|
||||
opcount[_try_me4] +
|
||||
opcount[_try_and_mark] +
|
||||
opcount[_try_c] +
|
||||
opcount[_try_clause] +
|
||||
opcount[_either];
|
||||
|
||||
c_cp.nretries =
|
||||
opcount[_retry_me] +
|
||||
opcount[_retry_me0] +
|
||||
opcount[_retry_me1] +
|
||||
opcount[_retry_me2] +
|
||||
opcount[_retry_me3] +
|
||||
opcount[_retry_me4] +
|
||||
opcount[_retry_and_mark] +
|
||||
opcount[_retry_c] +
|
||||
opcount[_retry] +
|
||||
opcount[_trust_in] +
|
||||
opcount[_retry_first] +
|
||||
opcount[_trust_first_in] +
|
||||
opcount[_retry_tail] +
|
||||
opcount[_trust_tail_in] +
|
||||
opcount[_retry_head] +
|
||||
opcount[_trust_head_in] +
|
||||
opcount[_or_else];
|
||||
|
||||
c_cp.ntrusts =
|
||||
opcount[_trust_me] +
|
||||
opcount[_trust_me0] +
|
||||
opcount[_trust_me1] +
|
||||
opcount[_trust_me2] +
|
||||
opcount[_trust_me3] +
|
||||
opcount[_trust_me4] +
|
||||
opcount[_trust] +
|
||||
opcount[_trust_first] +
|
||||
opcount[_trust_tail] +
|
||||
opcount[_trust_head] +
|
||||
opcount[_or_last];
|
||||
|
||||
choice_pts =
|
||||
c_cp.ntries +
|
||||
c_cp.nretries +
|
||||
c_cp.ntrusts;
|
||||
|
||||
indexes =
|
||||
opcount[_jump_if_var] +
|
||||
opcount[_switch_on_type] +
|
||||
opcount[_switch_on_nonv] +
|
||||
opcount[_switch_last] +
|
||||
opcount[_switch_on_head] +
|
||||
opcount[_switch_list_nl] +
|
||||
opcount[_switch_list_nl_prefetch] +
|
||||
opcount[_switch_nv_list] +
|
||||
opcount[_switch_l_list] +
|
||||
opcount[_switch_on_cons] +
|
||||
opcount[_go_on_cons] +
|
||||
opcount[_if_cons] +
|
||||
opcount[_switch_on_func] +
|
||||
opcount[_go_on_func] +
|
||||
opcount[_if_func] +
|
||||
opcount[_if_not_then];
|
||||
misc =
|
||||
c_control.ncallbips +
|
||||
opcount[_Ystop] +
|
||||
opcount[_Nstop] +
|
||||
opcount[_index_pred] +
|
||||
opcount[_save_b_x] +
|
||||
opcount[_save_b_y] +
|
||||
opcount[_undef_p] +
|
||||
opcount[_spy_pred] +
|
||||
opcount[_spy_or_trymark] +
|
||||
opcount[_save_pair_x] +
|
||||
opcount[_save_pair_y] +
|
||||
opcount[_save_pair_x_write] +
|
||||
opcount[_save_pair_y_write] +
|
||||
opcount[_save_appl_x] +
|
||||
opcount[_save_appl_y] +
|
||||
opcount[_save_appl_x_write] +
|
||||
opcount[_save_appl_y_write];
|
||||
total = gets + unifies + puts + writes + controls + choice_pts + indexes + misc;
|
||||
|
||||
/* for (i = 0; i <= _std_top; ++i)
|
||||
* print_instruction(i);
|
||||
*/
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Instructions Executed in %s\n", program);
|
||||
YP_fprintf(YP_stderr, "Groups are\n\n");
|
||||
YP_fprintf(YP_stderr, " GET instructions: %8d (%3d%%)\n", gets,
|
||||
(gets * 100) / total);
|
||||
YP_fprintf(YP_stderr, " UNIFY instructions: %8d (%3d%%)\n", unifies,
|
||||
(unifies * 100) / total);
|
||||
YP_fprintf(YP_stderr, " PUT instructions: %8d (%3d%%)\n", puts,
|
||||
(puts * 100) / total);
|
||||
YP_fprintf(YP_stderr, " WRITE instructions: %8d (%3d%%)\n", writes,
|
||||
(writes * 100) / total);
|
||||
YP_fprintf(YP_stderr, " CONTROL instructions: %8d (%3d%%)\n", controls,
|
||||
(controls * 100) / total);
|
||||
YP_fprintf(YP_stderr, " CHOICE POINT instructions: %8d (%3d%%)\n", choice_pts,
|
||||
(choice_pts * 100) / total);
|
||||
YP_fprintf(YP_stderr, " INDEXING instructions: %8d (%3d%%)\n", indexes,
|
||||
(indexes * 100) / total);
|
||||
YP_fprintf(YP_stderr, " MISCELLANEOUS instructions: %8d (%3d%%)\n", misc,
|
||||
(misc * 100) / total);
|
||||
YP_fprintf(YP_stderr, "_______________________________________________\n");
|
||||
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
|
||||
(total * 100) / total);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Analysis of Unification Instructions in %s \n", program);
|
||||
YP_fprintf(YP_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
|
||||
YP_fprintf(YP_stderr, " GET: %8d %8d %8d %8d %8d %8d %8d\n",
|
||||
c_get.nxvar,
|
||||
c_get.nyvar,
|
||||
c_get.nxval,
|
||||
c_get.nyval,
|
||||
c_get.ncons,
|
||||
c_get.nlist,
|
||||
c_get.nstru);
|
||||
YP_fprintf(YP_stderr, "UNIFY: %8d %8d %8d %8d %8d %8d %8d\n",
|
||||
c_unify.nxvar,
|
||||
c_unify.nyvar,
|
||||
c_unify.nxval,
|
||||
c_unify.nyval,
|
||||
c_unify.ncons,
|
||||
c_unify.nlist,
|
||||
c_unify.nstru);
|
||||
YP_fprintf(YP_stderr, " PUT: %8d %8d %8d %8d %8d %8d %8d\n",
|
||||
c_put.nxvar,
|
||||
c_put.nyvar,
|
||||
c_put.nxval,
|
||||
c_put.nyval,
|
||||
c_put.ncons,
|
||||
c_put.nlist,
|
||||
c_put.nstru);
|
||||
YP_fprintf(YP_stderr, "WRITE: %8d %8d %8d %8d %8d %8d %8d\n",
|
||||
c_write.nxvar,
|
||||
c_write.nyvar,
|
||||
c_write.nxval,
|
||||
c_write.nyval,
|
||||
c_write.ncons,
|
||||
c_write.nlist,
|
||||
c_write.nstru);
|
||||
YP_fprintf(YP_stderr, " ___________________________________________________\n");
|
||||
YP_fprintf(YP_stderr, "TOTAL: %8d %8d %8d %8d %8d %8d %8d\n",
|
||||
c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar,
|
||||
c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar,
|
||||
c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval,
|
||||
c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval,
|
||||
c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons,
|
||||
c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist,
|
||||
c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru
|
||||
);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Analysis of Unification Instructions in %s \n", program);
|
||||
YP_fprintf(YP_stderr, " XVAR, YVAR, XVAL, YVAL, CONS, LIST, STRUCT\n");
|
||||
YP_fprintf(YP_stderr, " GET: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
|
||||
(((double) c_get.nxvar) * 100) / total,
|
||||
(((double) c_get.nyvar) * 100) / total,
|
||||
(((double) c_get.nxval) * 100) / total,
|
||||
(((double) c_get.nyval) * 100) / total,
|
||||
(((double) c_get.ncons) * 100) / total,
|
||||
(((double) c_get.nlist) * 100) / total,
|
||||
(((double) c_get.nstru) * 100) / total);
|
||||
YP_fprintf(YP_stderr, "UNIFY: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
|
||||
(((double) c_unify.nxvar) * 100) / total,
|
||||
(((double) c_unify.nyvar) * 100) / total,
|
||||
(((double) c_unify.nxval) * 100) / total,
|
||||
(((double) c_unify.nyval) * 100) / total,
|
||||
(((double) c_unify.ncons) * 100) / total,
|
||||
(((double) c_unify.nlist) * 100) / total,
|
||||
(((double) c_unify.nstru) * 100) / total);
|
||||
YP_fprintf(YP_stderr, " PUT: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
|
||||
(((double) c_put.nxvar) * 100) / total,
|
||||
(((double) c_put.nyvar) * 100) / total,
|
||||
(((double) c_put.nxval) * 100) / total,
|
||||
(((double) c_put.nyval) * 100) / total,
|
||||
(((double) c_put.ncons) * 100) / total,
|
||||
(((double) c_put.nlist) * 100) / total,
|
||||
(((double) c_put.nstru) * 100) / total);
|
||||
YP_fprintf(YP_stderr, "WRITE: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
|
||||
(((double) c_write.nxvar) * 100) / total,
|
||||
(((double) c_write.nyvar) * 100) / total,
|
||||
(((double) c_write.nxval) * 100) / total,
|
||||
(((double) c_write.nyval) * 100) / total,
|
||||
(((double) c_write.ncons) * 100) / total,
|
||||
(((double) c_write.nlist) * 100) / total,
|
||||
(((double) c_write.nstru) * 100) / total);
|
||||
YP_fprintf(YP_stderr, " ___________________________________________________\n");
|
||||
YP_fprintf(YP_stderr, "TOTAL: %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%% %3.2f%%\n",
|
||||
(((double) c_get.nxvar + c_unify.nxvar + c_put.nxvar + c_write.nxvar) * 100) / total,
|
||||
(((double) c_get.nyvar + c_unify.nyvar + c_put.nyvar + c_write.nyvar) * 100) / total,
|
||||
(((double) c_get.nxval + c_unify.nxval + c_put.nxval + c_write.nxval) * 100) / total,
|
||||
(((double) c_get.nyval + c_unify.nyval + c_put.nyval + c_write.nyval) * 100) / total,
|
||||
(((double) c_get.ncons + c_unify.ncons + c_put.ncons + c_write.ncons) * 100) / total,
|
||||
(((double) c_get.nlist + c_unify.nlist + c_put.nlist + c_write.nlist) * 100) / total,
|
||||
(((double) c_get.nstru + c_unify.nstru + c_put.nstru + c_write.nstru) * 100) / total
|
||||
);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Control Instructions Executed in %s \n", program);
|
||||
YP_fprintf(YP_stderr, "Grouped as\n\n");
|
||||
YP_fprintf(YP_stderr, " CALL instructions: %8d (%3d%%)\n",
|
||||
c_control.ncalls, (c_control.ncalls * 100) / total);
|
||||
YP_fprintf(YP_stderr, " PROCEED instructions: %8d (%3d%%)\n",
|
||||
c_control.nproceeds, (c_control.nproceeds * 100) / total);
|
||||
YP_fprintf(YP_stderr, " EXECUTE instructions: %8d (%3d%%)\n",
|
||||
c_control.nexecs, (c_control.nexecs * 100) / total);
|
||||
YP_fprintf(YP_stderr, " CUT instructions: %8d (%3d%%)\n",
|
||||
c_control.ncuts, (c_control.ncuts * 100) / total);
|
||||
YP_fprintf(YP_stderr, " CALL_BIP instructions: %8d (%3d%%)\n",
|
||||
c_control.ncallbips, (c_control.ncallbips * 100) / total);
|
||||
YP_fprintf(YP_stderr, " ALLOCATE instructions: %8d (%3d%%)\n",
|
||||
c_control.nallocs, (c_control.nallocs * 100) / total);
|
||||
YP_fprintf(YP_stderr, " DEALLOCATE instructions: %8d (%3d%%)\n",
|
||||
c_control.ndeallocs, (c_control.ndeallocs * 100) / total);
|
||||
YP_fprintf(YP_stderr, "_______________________________________________\n");
|
||||
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
|
||||
(total * 100) / total);
|
||||
|
||||
YP_fprintf(YP_stderr, "\n Choice Point Manipulation Instructions Executed in %s \n", program);
|
||||
YP_fprintf(YP_stderr, "Grouped as\n\n");
|
||||
YP_fprintf(YP_stderr, " TRY instructions: %8d (%3d%%)\n",
|
||||
c_cp.ntries, (c_cp.ntries * 100) / total);
|
||||
YP_fprintf(YP_stderr, " RETRY instructions: %8d (%3d%%)\n",
|
||||
c_cp.nretries, (c_cp.nretries * 100) / total);
|
||||
YP_fprintf(YP_stderr, " TRUST instructions: %8d (%3d%%)\n",
|
||||
c_cp.ntrusts, (c_cp.ntrusts * 100) / total);
|
||||
YP_fprintf(YP_stderr, "_______________________________________________\n");
|
||||
YP_fprintf(YP_stderr, " TOTAL instructions: %8d (%3d%%)\n\n", total,
|
||||
(total * 100) / total);
|
||||
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
void
|
||||
InitAnalystPreds(void)
|
||||
{
|
||||
InitCPred("reset_op_counters", 0, p_reset_op_counters, SafePredFlag |SyncPredFlag);
|
||||
InitCPred("show_op_counters", 1, p_show_op_counters, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("show_ops_by_group", 1, p_show_ops_by_group, SafePredFlag |SyncPredFlag);
|
||||
|
||||
}
|
||||
|
||||
#endif /* ANALYST */
|
|
@ -0,0 +1,227 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: eval.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: arithmetical expression evaluation *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
/*
|
||||
* This file implements arithmetic operations
|
||||
*
|
||||
*/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "eval.h"
|
||||
|
||||
|
||||
#define E_FUNC blob_type
|
||||
#define E_ARGS arith_retptr o
|
||||
|
||||
#define RINT(v) (o)->Int = v; return(long_int_e)
|
||||
#define RFLOAT(v) (o)->dbl = v; return(double_e)
|
||||
#define RERROR() return(db_ref_e)
|
||||
|
||||
#ifndef PI
|
||||
#ifdef M_PI
|
||||
#define PI M_PI
|
||||
#else
|
||||
#define PI 3.14159265358979323846
|
||||
#endif
|
||||
#endif
|
||||
|
||||
static E_FUNC
|
||||
p_pi(E_ARGS)
|
||||
{
|
||||
RFLOAT(PI);
|
||||
}
|
||||
|
||||
#ifndef M_E
|
||||
#define M_E 2.7182818284590452354
|
||||
#endif
|
||||
|
||||
static E_FUNC
|
||||
p_e(E_ARGS)
|
||||
{
|
||||
RFLOAT(M_E);
|
||||
}
|
||||
|
||||
#ifndef INFINITY
|
||||
#define INFINITY (1.0/0.0)
|
||||
#endif
|
||||
|
||||
static E_FUNC
|
||||
p_inf(E_ARGS)
|
||||
{
|
||||
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
|
||||
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
#else
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {/* iso */
|
||||
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
} else {
|
||||
RFLOAT(INFINITY);
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
||||
#ifndef NAN
|
||||
#define NAN (0.0/0.0)
|
||||
#endif
|
||||
|
||||
static E_FUNC
|
||||
p_nan(E_ARGS)
|
||||
{
|
||||
#ifdef _MSC_VER /* Microsoft's Visual C++ Compiler */
|
||||
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating infinity");
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
#else
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) {/* iso */
|
||||
Error(TYPE_ERROR_EVALUABLE, TermNil, "evaluating not-a-number");
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
} else {
|
||||
RFLOAT(NAN);
|
||||
}
|
||||
#endif
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_random(E_ARGS)
|
||||
{
|
||||
RFLOAT(yap_random());
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_cputime(E_ARGS)
|
||||
{
|
||||
RFLOAT((Float)cputime()/1000.0);
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_heapused(E_ARGS)
|
||||
{
|
||||
RINT(HeapUsed);
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_localsp(E_ARGS)
|
||||
{
|
||||
#if SBA
|
||||
RINT((Int)ASP);
|
||||
#else
|
||||
RINT(LCL0 - ASP);
|
||||
#endif
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_b(E_ARGS)
|
||||
{
|
||||
#if SBA
|
||||
RINT((Int)B);
|
||||
#else
|
||||
RINT(LCL0 - (CELL *)B);
|
||||
#endif
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_globalsp(E_ARGS)
|
||||
{
|
||||
#if SBA
|
||||
RINT((Int)H);
|
||||
#else
|
||||
RINT(H - H0);
|
||||
#endif
|
||||
}
|
||||
|
||||
static E_FUNC
|
||||
p_stackfree(E_ARGS)
|
||||
{
|
||||
RINT(Unsigned(ASP) - Unsigned(H));
|
||||
}
|
||||
|
||||
typedef blob_type (*f_constexp)(arith_retptr);
|
||||
|
||||
typedef struct init_const_eval {
|
||||
char *OpName;
|
||||
f_constexp f;
|
||||
} InitConstEntry;
|
||||
|
||||
|
||||
static InitConstEntry InitConstTab[] = {
|
||||
{"pi", p_pi},
|
||||
{"e", p_e},
|
||||
{"inf", p_inf},
|
||||
{"nan", p_nan},
|
||||
{"random", p_random},
|
||||
{"cputime", p_cputime},
|
||||
{"heapused", p_heapused},
|
||||
{"local_sp", p_localsp},
|
||||
{"global_sp", p_globalsp},
|
||||
{"$last_choice_pt", p_b},
|
||||
{"stackfree", p_stackfree},
|
||||
};
|
||||
|
||||
void
|
||||
InitConstExps(void)
|
||||
{
|
||||
unsigned int i;
|
||||
ExpEntry *p;
|
||||
|
||||
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
|
||||
AtomEntry *ae = RepAtom(LookupAtom(InitConstTab[i].OpName));
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
if (LockedGetExpProp(ae, 0)) {
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
break;
|
||||
}
|
||||
p = (ExpEntry *) AllocAtomSpace(sizeof(ExpEntry));
|
||||
p->KindOfPE = ExpProperty;
|
||||
p->ArityOfEE = 0;
|
||||
p->ENoOfEE = 0;
|
||||
p->FOfEE.constant = InitConstTab[i].f;
|
||||
p->NextOfPE = ae->PropOfAE;
|
||||
ae->PropOfAE = AbsExpProp(p);
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
}
|
||||
}
|
||||
|
||||
/* This routine is called from Restore to make sure we have the same arithmetic operators */
|
||||
int
|
||||
ReInitConstExps(void)
|
||||
{
|
||||
unsigned int i;
|
||||
Prop p;
|
||||
|
||||
for (i = 0; i < sizeof(InitConstTab)/sizeof(InitConstEntry); ++i) {
|
||||
AtomEntry *ae = RepAtom(FullLookupAtom(InitConstTab[i].OpName));
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
if ((p = LockedGetExpProp(ae, 0)) == NULL) {
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
return(FALSE);
|
||||
}
|
||||
RepExpProp(p)->FOfEE.constant = InitConstTab[i].f;
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,552 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: attvar.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: YAP support for attributed vars *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[]="%W% %G%";
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef COROUTINING
|
||||
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "heapgc.h"
|
||||
#include "attvar.h"
|
||||
#ifndef NULL
|
||||
#define NULL (void *)0
|
||||
#endif
|
||||
|
||||
STATIC_PROTO(Int InitVarTime, (void));
|
||||
STATIC_PROTO(Int CurrentTime, (void));
|
||||
|
||||
static CELL *
|
||||
AddToQueue(attvar_record *attv)
|
||||
{
|
||||
Term t[2];
|
||||
sus_record *WGs;
|
||||
sus_record *new;
|
||||
|
||||
t[0] = (CELL)&(attv->Done);
|
||||
t[1] = attv->Value;
|
||||
/* follow the chain */
|
||||
WGs = (sus_record *)ReadTimedVar(WokenGoals);
|
||||
new = (sus_record *)H;
|
||||
H = (CELL *)(new+1);
|
||||
new->NR = (sus_record *)(&(new->NR));
|
||||
new->SG = MkApplTerm(FunctorAttGoal, 2, t);
|
||||
new->NS = new;
|
||||
|
||||
if ((Term)WGs == TermNil) {
|
||||
UpdateTimedVar(WokenGoals, (CELL)new);
|
||||
/* from now on, we have to start waking up goals */
|
||||
if (CreepFlag != Unsigned(LCL0) - Unsigned(H0))
|
||||
CreepFlag = Unsigned(LCL0);
|
||||
} else {
|
||||
/* add to the end of the current list of suspended goals */
|
||||
CELL *where_to = (CELL *)Deref((CELL)WGs);
|
||||
Bind_Global(where_to, (CELL)new);
|
||||
}
|
||||
return(RepAppl(new->SG)+2);
|
||||
}
|
||||
|
||||
static CELL *
|
||||
AddFailToQueue(void)
|
||||
{
|
||||
sus_record *WGs;
|
||||
sus_record *new;
|
||||
|
||||
/* follow the chain */
|
||||
WGs = (sus_record *)ReadTimedVar(WokenGoals);
|
||||
new = (sus_record *)H;
|
||||
H = (CELL *)(new+1);
|
||||
new->NR = (sus_record *)(&(new->NR));
|
||||
new->SG = MkAtomTerm(AtomFail);
|
||||
new->NS = new;
|
||||
|
||||
if ((Term)WGs == TermNil) {
|
||||
UpdateTimedVar(WokenGoals, (CELL)new);
|
||||
/* from now on, we have to start waking up goals */
|
||||
if (CreepFlag != Unsigned(LCL0) - Unsigned(H0))
|
||||
CreepFlag = Unsigned(LCL0);
|
||||
} else {
|
||||
/* add to the end of the current list of suspended goals */
|
||||
CELL *where_to = (CELL *)Deref((CELL)WGs);
|
||||
Bind_Global(where_to, (CELL)new);
|
||||
}
|
||||
return(RepAppl(new->SG)+2);
|
||||
}
|
||||
|
||||
static int
|
||||
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;
|
||||
|
||||
/* add a new attributed variable */
|
||||
newv = (attvar_record *)ReadTimedVar(DelayedVars);
|
||||
if (H0 - (CELL *)newv < 1024+(2*NUM_OF_ATTS))
|
||||
return(FALSE);
|
||||
RESET_VARIABLE(&(newv->Done));
|
||||
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;
|
||||
to_visit[0] = attv->Atts+2*j;
|
||||
to_visit[1] = attv->Atts+2*j+1;
|
||||
to_visit[2] = newv->Atts+2*j+1;
|
||||
to_visit += 3;
|
||||
}
|
||||
*to_visit_ptr = to_visit;
|
||||
UpdateTimedVar(DelayedVars, (CELL)(newv->Atts+2*j));
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static void
|
||||
WakeAttVar(CELL* pt1, CELL reg2)
|
||||
{
|
||||
|
||||
/* if bound to someone else, follow until we find the last one */
|
||||
attvar_record *attv = (attvar_record *)pt1;
|
||||
CELL *myH = H;
|
||||
CELL *bind_ptr;
|
||||
|
||||
if (!IsVarTerm(attv->Value) || !IsUnboundVar(attv->Value)) {
|
||||
/* oops, our goal is on the queue to be woken */
|
||||
if (!unify(attv->Value, reg2)) {
|
||||
AddFailToQueue();
|
||||
}
|
||||
return;
|
||||
}
|
||||
if (IsVarTerm(reg2)) {
|
||||
if (IsAttachedTerm(reg2)) {
|
||||
attvar_record *susp2 = (attvar_record *)VarOfTerm(reg2);
|
||||
|
||||
/* binding two suspended variables, be careful */
|
||||
if (susp2->sus_id != attvars_ext) {
|
||||
/* joining two different kinds of suspensions */
|
||||
Error(SYSTEM_ERROR, TermNil, "joining two different suspensions not implemented");
|
||||
return;
|
||||
}
|
||||
if (susp2 >= attv) {
|
||||
if (susp2 == attv) return;
|
||||
if (!IsVarTerm(susp2->Value) || !IsUnboundVar(susp2->Value)) {
|
||||
/* oops, our goal is on the queue to be woken */
|
||||
if (!unify(susp2->Value, (CELL)pt1)) {
|
||||
AddFailToQueue();
|
||||
}
|
||||
}
|
||||
Bind_Global(&(susp2->Value), (CELL)pt1);
|
||||
AddToQueue(susp2);
|
||||
return;
|
||||
}
|
||||
} else {
|
||||
Bind(VarOfTerm(reg2), (CELL)pt1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
bind_ptr = AddToQueue(attv);
|
||||
if (IsNonVarTerm(reg2)) {
|
||||
if (IsPairTerm(reg2) && RepPair(reg2) == myH)
|
||||
reg2 = AbsPair(H);
|
||||
else if (IsApplTerm(reg2) && RepAppl(reg2) == myH)
|
||||
reg2 = AbsAppl(H);
|
||||
}
|
||||
*bind_ptr = reg2;
|
||||
Bind_Global(&(attv->Value), reg2);
|
||||
}
|
||||
|
||||
#ifndef FIXED_STACKS
|
||||
|
||||
static void
|
||||
mark_attvar(CELL *orig)
|
||||
{
|
||||
register attvar_record *attv = (attvar_record *)orig;
|
||||
Int i;
|
||||
|
||||
mark_external_reference(&(attv->Value));
|
||||
mark_external_reference(&(attv->Done));
|
||||
for (i = 0; i < NUM_OF_ATTS; i++) {
|
||||
mark_external_reference(attv->Atts+2*i+1);
|
||||
}
|
||||
}
|
||||
|
||||
#endif /* FIXED_STACKS */
|
||||
|
||||
static Int
|
||||
CurrentTime(void) {
|
||||
return((CELL *)(TR)-(CELL *)TrailBase);
|
||||
}
|
||||
|
||||
static Int
|
||||
InitVarTime(void) {
|
||||
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);
|
||||
}
|
||||
|
||||
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
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
&& timestmp <= TR
|
||||
#endif
|
||||
) {
|
||||
#if defined(SBA)
|
||||
if (Unsigned((Int)(attv)-(Int)(H_FZ)) >
|
||||
Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
|
||||
CELL *ptr = STACK_TO_SBA(attv->Atts+pos+1);
|
||||
*ptr = tatt;
|
||||
} else
|
||||
#endif
|
||||
attv->Atts[pos+1] = tatt;
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
|
||||
Unsigned(BBREG)-(Int)(HBREG))
|
||||
TrailVal(timestmp-1) = tatt;
|
||||
#endif
|
||||
} else {
|
||||
Term tnewt;
|
||||
MaBind(attv->Atts+pos+1, tatt);
|
||||
tnewt = MkIntegerTerm(CurrentTime());
|
||||
MaBind(attv->Atts+pos, tnewt);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
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
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
&& timestmp <= TR
|
||||
#endif
|
||||
) {
|
||||
RESET_VARIABLE(attv->Atts+(pos+1));
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
if (Unsigned((Int)(attv)-(Int)(HBREG)) >
|
||||
Unsigned(BBREG)-(Int)(HBREG))
|
||||
TrailVal(timestmp-1) = attv->Atts[pos+1];
|
||||
#endif
|
||||
} else {
|
||||
/* reset the variable */
|
||||
Term tnewt;
|
||||
#ifdef SBA
|
||||
MaBind(attv->Atts+(pos+1), 0L);
|
||||
#else
|
||||
MaBind(attv->Atts+(pos+1), (CELL)(attv->Atts+(pos+1)));
|
||||
#endif
|
||||
tnewt = MkIntegerTerm(CurrentTime());
|
||||
MaBind(attv->Atts+pos, tnewt);
|
||||
}
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static Int
|
||||
BuildNewAttVar(Term t, Int i, Term tatt)
|
||||
{
|
||||
/* allocate space in Heap */
|
||||
Term time = InitVarTime();
|
||||
int j;
|
||||
Term ttime;
|
||||
|
||||
attvar_record *attv = (attvar_record *)ReadTimedVar(DelayedVars);
|
||||
if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
|
||||
ARG1 = t;
|
||||
ARG2 = tatt;
|
||||
growglobal();
|
||||
t = ARG1;
|
||||
tatt = ARG2;
|
||||
}
|
||||
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;
|
||||
RESET_VARIABLE(attv->Atts+2*j+1);
|
||||
}
|
||||
attv->NS = UpdateTimedVar(AttsMutableList, (CELL)&(attv->Done));
|
||||
Bind((CELL *)t,(CELL)attv);
|
||||
UpdateTimedVar(DelayedVars,(CELL)(attv->Atts+2*j));
|
||||
return(PutAtt(attv, i, tatt));
|
||||
}
|
||||
|
||||
static Int
|
||||
GetAtt(attvar_record *attv, int i) {
|
||||
Int pos = i *2;
|
||||
#if SBA
|
||||
if (IsUnboundVar(attv->Atts[pos+1]))
|
||||
return((CELL)&(attv->Atts[pos+1]));
|
||||
#endif
|
||||
return(attv->Atts[pos+1]);
|
||||
}
|
||||
|
||||
static Int
|
||||
FreeAtt(attvar_record *attv, int i) {
|
||||
Int pos = i *2;
|
||||
return(IsVarTerm(attv->Atts[pos+1]));
|
||||
}
|
||||
|
||||
static Int
|
||||
BindAttVar(attvar_record *attv) {
|
||||
if (IsVarTerm(attv->Done) && IsUnboundVar(attv->Done)) {
|
||||
Bind_Global(&(attv->Done), attv->Value);
|
||||
return(TRUE);
|
||||
} else {
|
||||
Error(SYSTEM_ERROR,(CELL)&(attv->Done),"attvar was bound when set");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Term
|
||||
GetAllAtts(attvar_record *attv) {
|
||||
Int i;
|
||||
Term t = TermNil;
|
||||
for (i = NUM_OF_ATTS-1; i >= 0; i --) {
|
||||
if (!IsVarTerm(attv->Atts[2*i+1]))
|
||||
t = MkPairTerm(MkPairTerm(MkIntegerTerm(i),attv->Atts[2*i+1]), t);
|
||||
}
|
||||
return(t);
|
||||
}
|
||||
|
||||
static Term
|
||||
AllAttVars(Term t) {
|
||||
if (t == TermNil) {
|
||||
return(t);
|
||||
} else {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(t);
|
||||
if (!IsVarTerm(attv->Done) || !IsUnboundVar(attv->Done))
|
||||
return(AllAttVars(attv->NS));
|
||||
else return(MkPairTerm(t,AllAttVars(attv->NS)));
|
||||
}
|
||||
}
|
||||
|
||||
Term
|
||||
CurrentAttVars(void) {
|
||||
return(AllAttVars(ReadTimedVar(AttsMutableList)));
|
||||
|
||||
}
|
||||
|
||||
static Int
|
||||
p_put_att(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
exts id = (exts)attv->sus_id;
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
|
||||
return(FALSE);
|
||||
}
|
||||
return(PutAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
|
||||
}
|
||||
return(BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_rm_att(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
exts id = (exts)attv->sus_id;
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
|
||||
return(FALSE);
|
||||
}
|
||||
return(RmAtt(attv, IntegerOfTerm(Deref(ARG2))));
|
||||
}
|
||||
return(TRUE);
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"delete_attribute/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_get_att(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
Term out;
|
||||
exts id = (exts)attv->sus_id;
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
out = GetAtt(attv,IntegerOfTerm(Deref(ARG2)));
|
||||
return(!IsVarTerm(out) && unify(ARG3,out));
|
||||
}
|
||||
/* Error(INSTANTIATION_ERROR,inp,"get_att/2");*/
|
||||
return(FALSE);
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_free_att(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
exts id = (exts)attv->sus_id;
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
return(FreeAtt(attv,IntegerOfTerm(Deref(ARG2))));
|
||||
}
|
||||
return(TRUE);
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"free_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_bind_attvar(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
exts id = (exts)attv->sus_id;
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
return(BindAttVar(attv));
|
||||
}
|
||||
return(TRUE);
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"bind_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_get_all_atts(void) {
|
||||
/* receive a variable in ARG1 */
|
||||
Term inp = Deref(ARG1);
|
||||
/* if this is unbound, ok */
|
||||
if (IsVarTerm(inp)) {
|
||||
if (IsAttachedTerm(inp)) {
|
||||
attvar_record *attv = (attvar_record *)VarOfTerm(inp);
|
||||
exts id = (exts)(attv->sus_id);
|
||||
|
||||
if (id != attvars_ext) {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
return(unify(ARG2,GetAllAtts(attv)));
|
||||
}
|
||||
return(TRUE);
|
||||
} else {
|
||||
Error(TYPE_ERROR_VARIABLE,inp,"get_att/2");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_inc_atts(void)
|
||||
{
|
||||
Term t = MkIntegerTerm(NUM_OF_ATTS);
|
||||
NUM_OF_ATTS++;
|
||||
return(unify(ARG1,t));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_n_atts(void)
|
||||
{
|
||||
Term t = MkIntegerTerm(NUM_OF_ATTS);
|
||||
return(unify(ARG1,t));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_all_attvars(void)
|
||||
{
|
||||
Term t = ReadTimedVar(AttsMutableList);
|
||||
return(unify(ARG1,AllAttVars(t)));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_is_attvar(void)
|
||||
{
|
||||
Term t = Deref(ARG1);
|
||||
return(IsVarTerm(t) &&
|
||||
IsAttachedTerm(t) &&
|
||||
((attvar_record *)VarOfTerm(t))->sus_id == attvars_ext);
|
||||
}
|
||||
|
||||
void InitAttVarPreds(void)
|
||||
{
|
||||
attas[attvars_ext].bind_op = WakeAttVar;
|
||||
attas[attvars_ext].copy_term_op = CopyAttVar;
|
||||
#ifndef FIXED_STACKS
|
||||
attas[attvars_ext].mark_op = mark_attvar;
|
||||
#endif
|
||||
InitCPred("get_att", 3, p_get_att, SafePredFlag);
|
||||
InitCPred("get_all_atts", 2, p_get_all_atts, SafePredFlag);
|
||||
InitCPred("free_att", 2, p_free_att, SafePredFlag);
|
||||
InitCPred("put_att", 3, p_put_att, 0);
|
||||
InitCPred("rm_att", 2, p_rm_att, SafePredFlag);
|
||||
InitCPred("inc_n_of_atts", 1, p_inc_atts, SafePredFlag);
|
||||
InitCPred("n_of_atts", 1, p_n_atts, SafePredFlag);
|
||||
InitCPred("bind_attvar", 1, p_bind_attvar, SafePredFlag);
|
||||
InitCPred("$all_attvars", 1, p_all_attvars, SafePredFlag);
|
||||
InitCPred("$is_att_variable", 1, p_is_attvar, SafePredFlag);
|
||||
}
|
||||
|
||||
#endif /* COROUTINING */
|
||||
|
||||
|
|
@ -0,0 +1,352 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: bb.c *
|
||||
* Last rev: 12/29/99 *
|
||||
* mods: *
|
||||
* comments: YAP's blackboard routines *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#ifndef NULL
|
||||
#define NULL (void *)0
|
||||
#endif
|
||||
|
||||
static BBProp
|
||||
PutBBProp(AtomEntry *ae) /* get BBentry for at; */
|
||||
{
|
||||
Prop p0;
|
||||
BBProp p;
|
||||
|
||||
WRITE_LOCK(ae->ARWLock);
|
||||
p = RepBBProp(p0 = ae->PropOfAE);
|
||||
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
|
||||
(p->ModuleOfBB != CurrentModule))) {
|
||||
p = RepBBProp(p0 = p->NextOfPE);
|
||||
}
|
||||
if (p0 == NIL) {
|
||||
p = (BBProp)AllocAtomSpace(sizeof(*p));
|
||||
if (p == NULL) {
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
|
||||
return(NULL);
|
||||
}
|
||||
p->NextOfPE = ae->PropOfAE;
|
||||
ae->PropOfAE = AbsBBProp(p);
|
||||
p->ModuleOfBB = CurrentModule;
|
||||
p->Element = NULL;
|
||||
p->KeyOfBB = AbsAtom(ae);
|
||||
p->KindOfPE = BBProperty;
|
||||
INIT_RWLOCK(p->BBRWLock);
|
||||
}
|
||||
WRITE_UNLOCK(ae->ARWLock);
|
||||
return (p);
|
||||
}
|
||||
|
||||
static BBProp
|
||||
PutIntBBProp(Int key) /* get BBentry for at; */
|
||||
{
|
||||
Prop p0;
|
||||
BBProp p;
|
||||
UInt hash_key;
|
||||
|
||||
if (INT_BB_KEYS == NULL) {
|
||||
INT_BB_KEYS = (Prop *)AllocCodeSpace(sizeof(Prop)*INT_BB_KEYS_SIZE);
|
||||
if (INT_BB_KEYS != NULL) {
|
||||
UInt i = 0;
|
||||
Prop *pp = INT_BB_KEYS;
|
||||
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
|
||||
pp[0] = NIL;
|
||||
pp++;
|
||||
}
|
||||
} else {
|
||||
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
|
||||
return(NULL);
|
||||
}
|
||||
}
|
||||
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
|
||||
p0 = INT_BB_KEYS[hash_key];
|
||||
p = RepBBProp(p0);
|
||||
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
|
||||
key != (Int)(p->KeyOfBB) ||
|
||||
(p->ModuleOfBB != CurrentModule))) {
|
||||
p = RepBBProp(p0 = p->NextOfPE);
|
||||
}
|
||||
if (p0 == NIL) {
|
||||
YAPEnterCriticalSection();
|
||||
p = (BBProp)AllocAtomSpace(sizeof(*p));
|
||||
if (p == NULL) {
|
||||
YAPLeaveCriticalSection();
|
||||
Error(SYSTEM_ERROR,ARG1,"could not allocate space in bb_put/2");
|
||||
return(NULL);
|
||||
}
|
||||
p->ModuleOfBB = CurrentModule;
|
||||
p->Element = NULL;
|
||||
p->KeyOfBB = (Atom)key;
|
||||
p->KindOfPE = BBProperty;
|
||||
p->NextOfPE = INT_BB_KEYS[hash_key];
|
||||
INT_BB_KEYS[hash_key] = AbsBBProp(p);
|
||||
YAPLeaveCriticalSection();
|
||||
}
|
||||
return (p);
|
||||
}
|
||||
|
||||
static BBProp
|
||||
GetBBProp(AtomEntry *ae) /* get BBentry for at; */
|
||||
{
|
||||
Prop p0;
|
||||
BBProp p;
|
||||
|
||||
READ_LOCK(ae->ARWLock);
|
||||
p = RepBBProp(p0 = ae->PropOfAE);
|
||||
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
|
||||
(p->ModuleOfBB != CurrentModule))) {
|
||||
p = RepBBProp(p0 = p->NextOfPE);
|
||||
}
|
||||
READ_UNLOCK(ae->ARWLock);
|
||||
if (p0 == NIL) {
|
||||
return(NULL);
|
||||
}
|
||||
return (p);
|
||||
}
|
||||
|
||||
static BBProp
|
||||
GetIntBBProp(Int key) /* get BBentry for at; */
|
||||
{
|
||||
Prop p0;
|
||||
BBProp p;
|
||||
UInt hash_key;
|
||||
|
||||
if (INT_BB_KEYS == NULL)
|
||||
return(NULL);
|
||||
hash_key = (CELL)key % INT_BB_KEYS_SIZE;
|
||||
p0 = INT_BB_KEYS[hash_key];
|
||||
p = RepBBProp(p0);
|
||||
while (p0 != NIL && (!IsBBProperty(p->KindOfPE) ||
|
||||
key != (Int)(p->KeyOfBB) ||
|
||||
(p->ModuleOfBB != CurrentModule))) {
|
||||
p = RepBBProp(p0 = p->NextOfPE);
|
||||
}
|
||||
if (p0 == NIL) {
|
||||
return(NULL);
|
||||
}
|
||||
return (p);
|
||||
}
|
||||
|
||||
static int
|
||||
resize_bb_int_keys(UInt new_size) {
|
||||
Prop *new;
|
||||
UInt i;
|
||||
|
||||
YAPEnterCriticalSection();
|
||||
if (INT_BB_KEYS == NULL) {
|
||||
INT_BB_KEYS_SIZE = new_size;
|
||||
YAPLeaveCriticalSection();
|
||||
return(TRUE);
|
||||
}
|
||||
new = (Prop *)AllocCodeSpace(sizeof(Prop)*new_size);
|
||||
if (new == NULL) {
|
||||
YAPLeaveCriticalSection();
|
||||
Error(SYSTEM_ERROR,ARG1,"could not allocate space");
|
||||
return(FALSE);
|
||||
}
|
||||
for (i = 0; i < new_size; i++) {
|
||||
new[i] = NIL;
|
||||
}
|
||||
for (i = 0; i < INT_BB_KEYS_SIZE; i++) {
|
||||
if (INT_BB_KEYS[i] != NIL) {
|
||||
Prop p0 = INT_BB_KEYS[i];
|
||||
while (p0 != NIL) {
|
||||
BBProp p = RepBBProp(p0);
|
||||
CELL key = (CELL)(p->KeyOfBB);
|
||||
UInt hash_key = (CELL)key % new_size;
|
||||
p0 = p->NextOfPE;
|
||||
p->NextOfPE = new[hash_key];
|
||||
new[hash_key] = AbsBBProp(p);
|
||||
}
|
||||
}
|
||||
}
|
||||
FreeCodeSpace((char *)INT_BB_KEYS);
|
||||
INT_BB_KEYS = new;
|
||||
INT_BB_KEYS_SIZE = new_size;
|
||||
YAPLeaveCriticalSection();
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static BBProp
|
||||
AddBBProp(Term t1, char *msg)
|
||||
{
|
||||
SMALLUNSGN old_module = CurrentModule;
|
||||
BBProp p;
|
||||
|
||||
if (IsVarTerm(t1)) {
|
||||
Error(INSTANTIATION_ERROR, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
} if (IsAtomTerm(t1)) {
|
||||
p = PutBBProp(RepAtom(AtomOfTerm(t1)));
|
||||
} else if (IsIntegerTerm(t1)) {
|
||||
p = PutIntBBProp(IntegerOfTerm(t1));
|
||||
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
|
||||
Term mod = ArgOfTerm(1, t1);
|
||||
if (!IsVarTerm(mod) ) {
|
||||
CurrentModule = LookupModule(mod);
|
||||
t1 = ArgOfTerm(2, t1);
|
||||
p = AddBBProp(t1, msg);
|
||||
} else {
|
||||
Error(INSTANTIATION_ERROR, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
}
|
||||
} else {
|
||||
Error(TYPE_ERROR_ATOM, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
}
|
||||
CurrentModule = old_module;
|
||||
return(p);
|
||||
}
|
||||
|
||||
static BBProp
|
||||
FetchBBProp(Term t1, char *msg)
|
||||
{
|
||||
SMALLUNSGN old_module = CurrentModule;
|
||||
BBProp p;
|
||||
|
||||
if (IsVarTerm(t1)) {
|
||||
Error(INSTANTIATION_ERROR, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
} if (IsAtomTerm(t1)) {
|
||||
p = GetBBProp(RepAtom(AtomOfTerm(t1)));
|
||||
} else if (IsIntegerTerm(t1)) {
|
||||
p = GetIntBBProp(IntegerOfTerm(t1));
|
||||
} else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorModule) {
|
||||
Term mod = ArgOfTerm(1, t1);
|
||||
if (!IsVarTerm(mod) ) {
|
||||
CurrentModule = LookupModule(mod);
|
||||
t1 = ArgOfTerm(2, t1);
|
||||
p = FetchBBProp(t1, msg);
|
||||
} else {
|
||||
Error(INSTANTIATION_ERROR, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
}
|
||||
} else {
|
||||
Error(TYPE_ERROR_ATOM, t1, msg);
|
||||
CurrentModule = old_module;
|
||||
return(NULL);
|
||||
}
|
||||
CurrentModule = old_module;
|
||||
return(p);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_bb_put(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
BBProp p = AddBBProp(t1, "bb_put/2");
|
||||
if (p == NULL)
|
||||
return(FALSE);
|
||||
WRITE_LOCK(p->BBRWLock);
|
||||
if (p->Element != NULL) {
|
||||
ReleaseTermFromDB(p->Element);
|
||||
}
|
||||
p->Element = StoreTermInDB(Deref(ARG2),3);
|
||||
WRITE_UNLOCK(p->BBRWLock);
|
||||
return(p->Element != NULL);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_bb_get(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
BBProp p = FetchBBProp(t1, "bb_get/2");
|
||||
Term out;
|
||||
if (p == NULL || p->Element == NULL)
|
||||
return(FALSE);
|
||||
READ_LOCK(p->BBRWLock);
|
||||
out = FetchTermFromDB(p->Element,3);
|
||||
READ_UNLOCK(p->BBRWLock);
|
||||
return(unify(ARG2,out));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_bb_delete(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
BBProp p;
|
||||
Term out;
|
||||
|
||||
p = FetchBBProp(t1, "bb_delete/2");
|
||||
if (p == NULL || p->Element == NULL)
|
||||
return(FALSE);
|
||||
out = FetchTermFromDB(p->Element,3);
|
||||
WRITE_LOCK(p->BBRWLock);
|
||||
ReleaseTermFromDB(p->Element);
|
||||
p->Element = NULL;
|
||||
WRITE_UNLOCK(p->BBRWLock);
|
||||
return(unify(ARG2,out));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_bb_update(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
BBProp p;
|
||||
Term out;
|
||||
|
||||
p = FetchBBProp(t1, "bb_update/3");
|
||||
if (p == NULL || p->Element == NULL)
|
||||
return(FALSE);
|
||||
WRITE_LOCK(p->BBRWLock);
|
||||
out = FetchTermFromDB(p->Element,3);
|
||||
if (!unify(ARG2,out)) {
|
||||
WRITE_UNLOCK(p->BBRWLock);
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
ReleaseTermFromDB(p->Element);
|
||||
p->Element = StoreTermInDB(Deref(ARG3),3);
|
||||
|
||||
WRITE_UNLOCK(p->BBRWLock);
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_resize_bb_int_keys(void)
|
||||
{
|
||||
Term t1 = Deref(ARG1);
|
||||
if (IsVarTerm(t1)) {
|
||||
return(unify(ARG1,MkIntegerTerm((Int)INT_BB_KEYS_SIZE)));
|
||||
}
|
||||
if (!IsIntegerTerm(t1)) {
|
||||
Error(TYPE_ERROR_INTEGER, t1, "yap_flag(resize_bb_int_keys,T)");
|
||||
return(FALSE);
|
||||
}
|
||||
return(resize_bb_int_keys(IntegerOfTerm(t1)));
|
||||
}
|
||||
|
||||
void
|
||||
InitBBPreds(void)
|
||||
{
|
||||
InitCPred("bb_put", 2, p_bb_put, 0);
|
||||
InitCPred("bb_get", 2, p_bb_get, 0);
|
||||
InitCPred("bb_delete", 2, p_bb_delete, 0);
|
||||
InitCPred("bb_update", 3, p_bb_update, 0);
|
||||
InitCPred("$resize_bb_int_keys", 1, p_resize_bb_int_keys, SafePredFlag|SyncPredFlag);
|
||||
}
|
||||
|
|
@ -0,0 +1,216 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: arith1.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: bignum support through gmp *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
|
||||
#ifdef USE_GMP
|
||||
|
||||
#include "Heap.h"
|
||||
#include "eval.h"
|
||||
#include "alloc.h"
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
/* This global variable tells how things are going */
|
||||
|
||||
static CELL *pre_alloc_base = NULL, *alloc_ptr;
|
||||
|
||||
MP_INT *
|
||||
PreAllocBigNum(void)
|
||||
{
|
||||
MP_INT *ret;
|
||||
|
||||
if (pre_alloc_base != H) {
|
||||
/* inform where we are allocating */
|
||||
alloc_ptr = pre_alloc_base = H;
|
||||
}
|
||||
ret = (MP_INT *)(alloc_ptr+1);
|
||||
/* first reserve space for the functor */
|
||||
alloc_ptr[0] = 0L;
|
||||
/* now allocate space for mpz_t */
|
||||
alloc_ptr = (CELL *)(ret+1);
|
||||
/* initialise the fields */
|
||||
mpz_init(ret);
|
||||
return(ret);
|
||||
}
|
||||
|
||||
MP_INT *
|
||||
InitBigNum(Int in)
|
||||
{
|
||||
MP_INT *ret;
|
||||
|
||||
if (pre_alloc_base == NULL) {
|
||||
/* inform where we are allocating */
|
||||
alloc_ptr = pre_alloc_base = H;
|
||||
}
|
||||
ret = (MP_INT *)(alloc_ptr+1);
|
||||
/* first reserve space for the functor */
|
||||
/* I use a 0 to indicate this is the first time
|
||||
we are building the bignum */
|
||||
alloc_ptr[0] = 0L;
|
||||
/* now allocate space for mpz_t */
|
||||
alloc_ptr = (CELL *)(ret+1);
|
||||
/* initialise the fields */
|
||||
mpz_init_set_si(ret, in);
|
||||
return(ret);
|
||||
}
|
||||
|
||||
/* This is a trivial allocator that use the global space:
|
||||
|
||||
Each unit has a:
|
||||
size;
|
||||
nof elements;
|
||||
*/
|
||||
static void *
|
||||
AllocBigNumSpace(size_t size)
|
||||
{
|
||||
void *ret = (void *)(alloc_ptr+1);
|
||||
|
||||
size = AdjustSize(size)/CellSize;
|
||||
alloc_ptr[0] = size;
|
||||
alloc_ptr += size+1;
|
||||
if (alloc_ptr > ASP-1024)
|
||||
Error(SYSTEM_ERROR,TermNil,"no space for bignum");
|
||||
return(ret);
|
||||
}
|
||||
|
||||
static void *
|
||||
ReAllocBigNumSpace(void *optr, size_t osize, size_t size)
|
||||
{
|
||||
void *out;
|
||||
|
||||
size = AdjustSize(size)/CellSize;
|
||||
osize = AdjustSize(osize)/CellSize;
|
||||
if (((CELL *)optr)+osize == alloc_ptr) {
|
||||
alloc_ptr += (size-osize);
|
||||
((CELL *)optr)[-1] = size;
|
||||
if (alloc_ptr > ASP-1024)
|
||||
Error(SYSTEM_ERROR,TermNil,"no space for bignum");
|
||||
return(optr);
|
||||
}
|
||||
out = AllocBigNumSpace(size);
|
||||
memcpy(out, (const void *)optr, size*CellSize);
|
||||
return(out);
|
||||
}
|
||||
|
||||
static void
|
||||
FreeBigNumSpace(void *optr, size_t size)
|
||||
{
|
||||
CELL *bp = (CELL *)optr;
|
||||
|
||||
size = AdjustSize(size)/CellSize;
|
||||
if (bp+size == alloc_ptr) {
|
||||
alloc_ptr = bp-1;
|
||||
return;
|
||||
}
|
||||
/* just say it is free */
|
||||
bp[-1] = -bp[-1];
|
||||
}
|
||||
|
||||
/* This can be done in several different situations:
|
||||
- we did BigIntOf and want to recover now (check through ret[0]);
|
||||
- we have done PreAlloc() and then a lot happened in between:
|
||||
o our final computation fits in an Int;
|
||||
o our final computation is the first we PreAlloced();
|
||||
o our final computation is not the first term we PreAlloced();
|
||||
|
||||
The result may be an Int, the old BigInt, or a BigInt moved to
|
||||
pre_alloc_base;
|
||||
*/
|
||||
Term
|
||||
MkBigIntTerm(MP_INT *big)
|
||||
{
|
||||
CELL *new = (CELL *)(big+1);
|
||||
Int nlimbs = (big->_mp_alloc)*(sizeof(mp_limb_t)/CellSize);
|
||||
Int sz;
|
||||
CELL *ret = ((CELL *)big)-1;
|
||||
|
||||
sz = mpz_sizeinbase(big, 2);
|
||||
/* was already there */
|
||||
if (ret[0] == (CELL)FunctorBigInt) {
|
||||
/* don't need to do no nothing */
|
||||
return(AbsAppl(ret));
|
||||
}
|
||||
if (sz < SIZEOF_LONG_INT*8-1) {
|
||||
Int out;
|
||||
|
||||
H = pre_alloc_base;
|
||||
pre_alloc_base = NULL;
|
||||
out = mpz_get_si(big);
|
||||
return(MkIntegerTerm(out));
|
||||
} else {
|
||||
/* we may have created a lot of bignums since we did the first
|
||||
PreAlloc(). We want to recover the space, not leave "holes" on
|
||||
the global stack */
|
||||
if (pre_alloc_base != ret) {
|
||||
/* copy everything to the start of the temp area */
|
||||
MP_INT *dst = (MP_INT *)(pre_alloc_base+1);
|
||||
|
||||
dst->_mp_size = big->_mp_size;
|
||||
dst->_mp_alloc = big->_mp_alloc;
|
||||
new = (CELL *)(dst+1);
|
||||
ret = pre_alloc_base;
|
||||
}
|
||||
ret[0] = (CELL)FunctorBigInt;
|
||||
memmove((void *)new, (const void *)(big->_mp_d), nlimbs*CellSize);
|
||||
H = (CELL *)(new+nlimbs);
|
||||
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
|
||||
H++;
|
||||
pre_alloc_base = NULL;
|
||||
return(AbsAppl(ret));
|
||||
}
|
||||
}
|
||||
|
||||
MP_INT *
|
||||
BigIntOfTerm(Term t)
|
||||
{
|
||||
MP_INT *new = (MP_INT *)(RepAppl(t)+1);
|
||||
|
||||
new->_mp_d = (mp_limb_t *)(new+1);
|
||||
return(new);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
static Int
|
||||
p_is_bignum(void)
|
||||
{
|
||||
#ifdef USE_GMP
|
||||
Term t = Deref(ARG1);
|
||||
return(IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt);
|
||||
#else
|
||||
return(FALSE);
|
||||
#endif
|
||||
}
|
||||
|
||||
void
|
||||
InitBigNums(void)
|
||||
{
|
||||
#ifdef USE_GMP
|
||||
/* YAP style memory allocation */
|
||||
mp_set_memory_functions(
|
||||
AllocBigNumSpace,
|
||||
ReAllocBigNumSpace,
|
||||
FreeBigNumSpace);
|
||||
#endif
|
||||
InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
|
||||
}
|
|
@ -0,0 +1,744 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog %W% %G% *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: c_interface.c *
|
||||
* Last rev: 19/2/88 *
|
||||
* mods: *
|
||||
* comments: c_interface primitives definition *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#define Bool int
|
||||
#define flt double
|
||||
#define C_INTERFACE
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#define HAS_YAP_H 1
|
||||
#include "yap_structs.h"
|
||||
#ifdef YAPOR
|
||||
#include "or.macros.h"
|
||||
#endif /* YAPOR */
|
||||
|
||||
#define YAP_BOOT_FROM_PROLOG 0
|
||||
#define YAP_BOOT_FROM_SAVED_CODE 1
|
||||
#define YAP_BOOT_FROM_SAVED_STACKS 2
|
||||
#define YAP_BOOT_FROM_SAVED_ERROR -1
|
||||
|
||||
#if defined(_MSC_VER) && defined(YAPDLL_EXPORTS)
|
||||
#define X_API __declspec(dllexport)
|
||||
#else
|
||||
#define X_API
|
||||
#endif
|
||||
|
||||
X_API Term STD_PROTO(YapA,(int));
|
||||
X_API Term STD_PROTO(YapMkVarTerm,(void));
|
||||
X_API Bool STD_PROTO(YapIsVarTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsNonVarTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsIntTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsFloatTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsDbRefTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsAtomTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsPairTerm,(Term));
|
||||
X_API Bool STD_PROTO(YapIsApplTerm,(Term));
|
||||
X_API Term STD_PROTO(YapMkIntTerm,(Int));
|
||||
X_API Int STD_PROTO(YapIntOfTerm,(Term));
|
||||
X_API Term STD_PROTO(YapMkFloatTerm,(flt));
|
||||
X_API flt STD_PROTO(YapFloatOfTerm,(Term));
|
||||
X_API Term STD_PROTO(YapMkAtomTerm,(Atom));
|
||||
X_API Atom STD_PROTO(YapAtomOfTerm,(Term));
|
||||
X_API Atom STD_PROTO(YapLookupAtom,(char *));
|
||||
X_API Atom STD_PROTO(YapFullLookupAtom,(char *));
|
||||
X_API char *STD_PROTO(YapAtomName,(Atom));
|
||||
X_API Term STD_PROTO(YapMkPairTerm,(Term,Term));
|
||||
X_API Term STD_PROTO(YapHeadOfTerm,(Term));
|
||||
X_API Term STD_PROTO(YapTailOfTerm,(Term));
|
||||
X_API Term STD_PROTO(YapMkApplTerm,(Functor,unsigned int,Term *));
|
||||
X_API Functor STD_PROTO(YapFunctorOfTerm,(Term));
|
||||
X_API Term STD_PROTO(YapArgOfTerm,(Int,Term));
|
||||
X_API Functor STD_PROTO(YapMkFunctor,(Atom,Int));
|
||||
X_API Atom STD_PROTO(YapNameOfFunctor,(Functor));
|
||||
X_API Int STD_PROTO(YapArityOfFunctor,(Functor));
|
||||
X_API void *STD_PROTO(YapExtraSpace,(void));
|
||||
X_API Int STD_PROTO(Yapcut_fail,(void));
|
||||
X_API Int STD_PROTO(Yapcut_succeed,(void));
|
||||
X_API Int STD_PROTO(YapUnify,(Term,Term));
|
||||
X_API Int STD_PROTO(YapUnify,(Term,Term));
|
||||
Int STD_PROTO(YapExecute,(CPredicate));
|
||||
X_API int STD_PROTO(YapReset,(void));
|
||||
X_API Int STD_PROTO(YapInit,(yap_init_args *));
|
||||
X_API Int STD_PROTO(YapFastInit,(char *));
|
||||
X_API Int STD_PROTO(YapCallProlog,(Term));
|
||||
X_API void *STD_PROTO(YapAllocSpaceFromYap,(unsigned int));
|
||||
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
|
||||
X_API void STD_PROTO(YapFreeSpaceFromYap,(void *));
|
||||
X_API int STD_PROTO(YapStringToBuffer, (Term, char *, unsigned int));
|
||||
X_API void STD_PROTO(YapError,(char *));
|
||||
X_API int STD_PROTO(YapRunGoal,(Term));
|
||||
X_API int STD_PROTO(YapRestartGoal,(void));
|
||||
X_API int STD_PROTO(YapContinueGoal,(void));
|
||||
X_API void STD_PROTO(YapInitConsult,(int, char *));
|
||||
X_API void STD_PROTO(YapEndConsult,(void));
|
||||
X_API Term STD_PROTO(YapRead, (int (*)(void)));
|
||||
X_API void STD_PROTO(YapWrite, (Term, void (*)(int), int));
|
||||
X_API char *STD_PROTO(YapCompileClause, (Term));
|
||||
X_API void STD_PROTO(YapPutValue, (Atom,Term));
|
||||
X_API Term STD_PROTO(YapGetValue, (Atom));
|
||||
X_API int STD_PROTO(YapReset, (void));
|
||||
X_API void STD_PROTO(YapExit, (int));
|
||||
X_API void STD_PROTO(YapInitSocks, (char *, long));
|
||||
X_API void STD_PROTO(YapSetOutputMessage, (void));
|
||||
|
||||
X_API Term
|
||||
YapA(int i)
|
||||
{
|
||||
|
||||
return(Deref(XREGS[i]));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsIntTerm(Term t)
|
||||
{
|
||||
return (IsIntTerm(t) || IsLongIntTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsVarTerm(Term t)
|
||||
{
|
||||
return (IsVarTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsNonVarTerm(Term t)
|
||||
{
|
||||
return (IsNonVarTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsFloatTerm(Term t)
|
||||
{
|
||||
return (IsFloatTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsDbRefTerm(Term t)
|
||||
{
|
||||
return (IsDBRefTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsAtomTerm(Term t)
|
||||
{
|
||||
return (IsAtomTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsPairTerm(Term t)
|
||||
{
|
||||
return (IsPairTerm(t));
|
||||
}
|
||||
|
||||
X_API Bool
|
||||
YapIsApplTerm(Term t)
|
||||
{
|
||||
return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t)));
|
||||
}
|
||||
|
||||
|
||||
X_API Term
|
||||
YapMkIntTerm(Int n)
|
||||
{
|
||||
Term I;
|
||||
BACKUP_H();
|
||||
|
||||
I = MkIntegerTerm(n);
|
||||
RECOVER_H();
|
||||
return(I);
|
||||
}
|
||||
|
||||
X_API Int
|
||||
YapIntOfTerm(Term t)
|
||||
{
|
||||
if (!IsApplTerm(t))
|
||||
return (IntOfTerm(t));
|
||||
else
|
||||
return(LongIntOfTerm(t));
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapMkFloatTerm(double n)
|
||||
{
|
||||
Term t;
|
||||
BACKUP_H();
|
||||
|
||||
t = MkFloatTerm(n);
|
||||
|
||||
RECOVER_H();
|
||||
return(t);
|
||||
}
|
||||
|
||||
X_API flt
|
||||
YapFloatOfTerm(Term t)
|
||||
{
|
||||
return (FloatOfTerm(t));
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapMkAtomTerm(Atom n)
|
||||
{
|
||||
Term t;
|
||||
|
||||
t = MkAtomTerm(n);
|
||||
return(t);
|
||||
}
|
||||
|
||||
X_API Atom
|
||||
YapAtomOfTerm(Term t)
|
||||
{
|
||||
return (AtomOfTerm(t));
|
||||
}
|
||||
|
||||
|
||||
X_API char *
|
||||
YapAtomName(Atom a)
|
||||
{
|
||||
char *o;
|
||||
|
||||
o = AtomName(a);
|
||||
return(o);
|
||||
}
|
||||
|
||||
X_API Atom
|
||||
YapLookupAtom(char *c)
|
||||
{
|
||||
return(LookupAtom(c));
|
||||
}
|
||||
|
||||
X_API Atom
|
||||
YapFullLookupAtom(char *c)
|
||||
{
|
||||
Atom at;
|
||||
|
||||
at = FullLookupAtom(c);
|
||||
return(at);
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapMkVarTerm(void)
|
||||
{
|
||||
CELL t;
|
||||
BACKUP_H();
|
||||
|
||||
t = MkVarTerm();
|
||||
|
||||
RECOVER_H();
|
||||
return(t);
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapMkPairTerm(Term t1, Term t2)
|
||||
{
|
||||
Term t;
|
||||
BACKUP_H();
|
||||
|
||||
t = MkPairTerm(t1, t2);
|
||||
|
||||
RECOVER_H();
|
||||
return(t);
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapHeadOfTerm(Term t)
|
||||
{
|
||||
return (HeadOfTerm(t));
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapTailOfTerm(Term t)
|
||||
{
|
||||
return (TailOfTerm(t));
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapMkApplTerm(Functor f,unsigned int arity, Term args[])
|
||||
{
|
||||
Term t;
|
||||
BACKUP_H();
|
||||
|
||||
t = MkApplTerm(f, arity, args);
|
||||
|
||||
RECOVER_H();
|
||||
return(t);
|
||||
}
|
||||
|
||||
X_API Functor
|
||||
YapFunctorOfTerm(Term t)
|
||||
{
|
||||
return (FunctorOfTerm(t));
|
||||
}
|
||||
|
||||
|
||||
X_API Term
|
||||
YapArgOfTerm(Int n, Term t)
|
||||
{
|
||||
return (ArgOfTerm(n, t));
|
||||
}
|
||||
|
||||
|
||||
|
||||
X_API Functor
|
||||
YapMkFunctor(Atom a, Int n)
|
||||
{
|
||||
return (MkFunctor(a, n));
|
||||
}
|
||||
|
||||
X_API Atom
|
||||
YapNameOfFunctor(Functor f)
|
||||
{
|
||||
return (NameOfFunctor(f));
|
||||
}
|
||||
|
||||
X_API Int
|
||||
YapArityOfFunctor(Functor f)
|
||||
{
|
||||
return (ArityOfFunctor(f));
|
||||
}
|
||||
|
||||
X_API void *
|
||||
YapExtraSpace(void)
|
||||
{
|
||||
void *ptr;
|
||||
BACKUP_B();
|
||||
|
||||
/* find a pointer to extra space allocable */
|
||||
ptr = (void *)((CELL *)(B+1)+P->u.lds.s);
|
||||
|
||||
RECOVER_B();
|
||||
return(ptr);
|
||||
}
|
||||
|
||||
X_API Int
|
||||
Yapcut_fail(void)
|
||||
{
|
||||
BACKUP_B();
|
||||
|
||||
B = B->cp_b; /* cut_fail */
|
||||
|
||||
RECOVER_B();
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
X_API Int
|
||||
Yapcut_succeed(void)
|
||||
{
|
||||
BACKUP_B();
|
||||
|
||||
B = B->cp_b;
|
||||
|
||||
RECOVER_B();
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
X_API Int
|
||||
YapUnify(Term pt1, Term pt2)
|
||||
{
|
||||
Int out;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
out = unify(pt1, pt2);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(out);
|
||||
}
|
||||
|
||||
Int YapExecute(CPredicate code)
|
||||
{
|
||||
return((code)());
|
||||
}
|
||||
|
||||
X_API Int YapCallProlog(Term t)
|
||||
{
|
||||
Int out;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
out = execute_goal(t,0);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(out);
|
||||
}
|
||||
|
||||
X_API void *YapAllocSpaceFromYap(unsigned int size)
|
||||
{
|
||||
void *ptr;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
if ((ptr = AllocCodeSpace(size)) == NULL) {
|
||||
if (!growheap(FALSE)) {
|
||||
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
|
||||
return(NULL);
|
||||
}
|
||||
}
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(ptr);
|
||||
}
|
||||
|
||||
X_API void YapFreeSpaceFromYap(void *ptr)
|
||||
{
|
||||
FreeCodeSpace(ptr);
|
||||
}
|
||||
|
||||
/* copy a string to a buffer */
|
||||
X_API int YapStringToBuffer(Term t, char *buf, unsigned int bufsize)
|
||||
{
|
||||
unsigned int j = 0;
|
||||
|
||||
while (t != TermNil) {
|
||||
register Term Head;
|
||||
register Int i;
|
||||
|
||||
Head = HeadOfTerm(t);
|
||||
if (IsVarTerm(Head)) {
|
||||
Error(INSTANTIATION_ERROR,Head,"user defined procedure");
|
||||
return(FALSE);
|
||||
} else if (!IsIntTerm(Head)) {
|
||||
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
|
||||
return(FALSE);
|
||||
}
|
||||
i = IntOfTerm(Head);
|
||||
if (i < 0 || i > 255) {
|
||||
Error(REPRESENTATION_ERROR_CHARACTER_CODE,Head,"user defined procedure");
|
||||
return(FALSE);
|
||||
}
|
||||
buf[j++] = i;
|
||||
if (j > bufsize) return(FALSE);
|
||||
t = TailOfTerm(t);
|
||||
if (IsVarTerm(t)) {
|
||||
Error(INSTANTIATION_ERROR,t,"user defined procedure");
|
||||
return(FALSE);
|
||||
} else if (!IsPairTerm(t) && t != TermNil) {
|
||||
Error(TYPE_ERROR_LIST, t, "user defined procedure");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
buf[j] = '\0';
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
X_API void
|
||||
YapError(char *buf)
|
||||
{
|
||||
Error(SYSTEM_ERROR,TermNil,buf);
|
||||
}
|
||||
|
||||
X_API int
|
||||
YapRunGoal(Term t)
|
||||
{
|
||||
int out;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
InitYaamRegs();
|
||||
out = RunTopGoal(t);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(out);
|
||||
}
|
||||
|
||||
X_API int
|
||||
YapRestartGoal(void)
|
||||
{
|
||||
int out;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
P = (yamop *)FAILCODE;
|
||||
out = exec_absmi(TRUE);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(out);
|
||||
}
|
||||
|
||||
X_API int
|
||||
YapContinueGoal(void)
|
||||
{
|
||||
int out;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
out = exec_absmi(TRUE);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(out);
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapInitConsult(int mode, char *filename)
|
||||
{
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
if (mode == YAP_CONSULT_MODE)
|
||||
init_consult(FALSE, filename);
|
||||
else
|
||||
init_consult(TRUE, filename);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapEndConsult(void)
|
||||
{
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
end_consult();
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
}
|
||||
|
||||
static int (*do_getf)(void);
|
||||
|
||||
static int do_yap_getc(int streamno) {
|
||||
return(do_getf());
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapRead(int (*mygetc)(void))
|
||||
{
|
||||
Term t;
|
||||
tr_fr_ptr old_TR;
|
||||
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
do_getf = mygetc;
|
||||
old_TR = TR;
|
||||
tokptr = toktide = tokenizer(do_yap_getc, do_yap_getc);
|
||||
if (ErrorMessage)
|
||||
{
|
||||
TR = old_TR;
|
||||
save_machine_regs();
|
||||
return(0);
|
||||
}
|
||||
t = Parse();
|
||||
TR = old_TR;
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(t);
|
||||
}
|
||||
|
||||
static void (*do_putcf)(int);
|
||||
|
||||
static int do_yap_putc(int streamno,int ch) {
|
||||
do_putcf(ch);
|
||||
return(ch);
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapWrite(Term t, void (*myputc)(int), int flags)
|
||||
{
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
do_putcf = myputc;
|
||||
plwrite (t, do_yap_putc, flags);
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
}
|
||||
|
||||
X_API char *
|
||||
YapCompileClause(Term t)
|
||||
{
|
||||
char *ErrorMessage;
|
||||
CODEADDR codeaddr;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
ErrorMessage = NULL;
|
||||
ARG1 = t;
|
||||
codeaddr = cclause (t,0);
|
||||
if (codeaddr != NULL) {
|
||||
t = Deref(ARG1); /* just in case there was an heap overflow */
|
||||
addclause (t, codeaddr, TRUE);
|
||||
}
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(ErrorMessage);
|
||||
}
|
||||
|
||||
/* this routine is supposed to be called from an external program
|
||||
that wants to control Yap */
|
||||
|
||||
X_API Int
|
||||
YapInit(yap_init_args *yap_init)
|
||||
{
|
||||
int restore_result;
|
||||
int Trail = 0, Stack = 0, Heap = 0;
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
yap_args = yap_init->Argv;
|
||||
yap_argc = yap_init->Argc;
|
||||
if (yap_init->SavedState != NULL) {
|
||||
if (SavedInfo (yap_init->SavedState, &Trail, &Stack, &Heap, yap_init->YapLibDir) != 1) {
|
||||
return(YAP_BOOT_FROM_SAVED_ERROR);
|
||||
}
|
||||
}
|
||||
if (yap_init->TrailSize == 0) {
|
||||
if (Trail == 0)
|
||||
Trail = DefTrailSpace;
|
||||
} else {
|
||||
Trail = yap_init->TrailSize;
|
||||
}
|
||||
if (yap_init->StackSize == 0) {
|
||||
if (Stack == 0)
|
||||
Stack = DefStackSpace;
|
||||
} else {
|
||||
Stack = yap_init->StackSize;
|
||||
}
|
||||
if (yap_init->HeapSize == 0) {
|
||||
if (Heap == 0)
|
||||
Heap = DefHeapSpace;
|
||||
} else {
|
||||
Heap = yap_init->HeapSize;
|
||||
}
|
||||
InitStacks (Heap, Stack, Trail,
|
||||
yap_init->NumberWorkers,
|
||||
yap_init->SchedulerLoop,
|
||||
yap_init->DelayedReleaseLoad
|
||||
);
|
||||
InitYaamRegs();
|
||||
if (yap_init->YapPrologBootFile != NULL) {
|
||||
/*
|
||||
This must be done before restore, otherwise
|
||||
restore will print out messages ....
|
||||
*/
|
||||
yap_flags[HALT_AFTER_CONSULT_FLAG] = yap_init->HaltAfterConsult;
|
||||
}
|
||||
if (yap_init->SavedState != NULL) {
|
||||
restore_result = Restore(yap_init->SavedState);
|
||||
} else {
|
||||
restore_result = FAIL_RESTORE;
|
||||
}
|
||||
#if defined(YAPOR) || defined(TABLING)
|
||||
make_root_frames();
|
||||
#ifdef YAPOR
|
||||
init_workers();
|
||||
#endif /* YAPOR */
|
||||
init_local();
|
||||
#ifdef YAPOR
|
||||
if (worker_id != 0) {
|
||||
#if SBA
|
||||
/*
|
||||
In the SBA we cannot just happily inherit registers
|
||||
from the other workers
|
||||
*/
|
||||
InitYaamRegs();
|
||||
#endif
|
||||
/* slaves, waiting for work */
|
||||
CurrentModule = 1;
|
||||
P = GETWORK_FIRST_TIME;
|
||||
exec_absmi(FALSE);
|
||||
abort_optyap("abstract machine unexpected exit");
|
||||
}
|
||||
#endif /* YAPOR */
|
||||
#endif /* YAPOR || TABLING */
|
||||
RECOVER_MACHINE_REGS();
|
||||
|
||||
if (yap_init->YapPrologBootFile != NULL) {
|
||||
PutValue(FullLookupAtom("$consult_on_boot"), MkAtomTerm(LookupAtom(yap_init->YapPrologBootFile)));
|
||||
/*
|
||||
This must be done again after restore, as yap_flags
|
||||
has been overwritten ....
|
||||
*/
|
||||
yap_flags[HALT_AFTER_CONSULT_FLAG] = yap_init->HaltAfterConsult;
|
||||
}
|
||||
if (yap_init->SavedState != NULL) {
|
||||
|
||||
if (restore_result == FAIL_RESTORE)
|
||||
return(YAP_BOOT_FROM_SAVED_ERROR);
|
||||
if (restore_result == DO_ONLY_CODE) {
|
||||
return(YAP_BOOT_FROM_SAVED_CODE);
|
||||
} else {
|
||||
return(YAP_BOOT_FROM_SAVED_STACKS);
|
||||
}
|
||||
}
|
||||
return(YAP_BOOT_FROM_PROLOG);
|
||||
}
|
||||
|
||||
X_API Int
|
||||
YapFastInit(char saved_state[])
|
||||
{
|
||||
yap_init_args init_args;
|
||||
|
||||
init_args.SavedState = saved_state;
|
||||
init_args.HeapSize = 0;
|
||||
init_args.StackSize = 0;
|
||||
init_args.TrailSize = 0;
|
||||
init_args.YapLibDir = NULL;
|
||||
init_args.YapPrologBootFile = NULL;
|
||||
init_args.HaltAfterConsult = FALSE;
|
||||
init_args.NumberWorkers = 1;
|
||||
init_args.SchedulerLoop = 10;
|
||||
init_args.DelayedReleaseLoad = 3;
|
||||
init_args.Argc = 0;
|
||||
init_args.Argv = NULL;
|
||||
|
||||
return(YapInit(&init_args));
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapPutValue(Atom at, Term t)
|
||||
{
|
||||
PutValue(at, t);
|
||||
}
|
||||
|
||||
X_API Term
|
||||
YapGetValue(Atom at)
|
||||
{
|
||||
return(GetValue(at));
|
||||
}
|
||||
|
||||
X_API int
|
||||
YapReset(void)
|
||||
{
|
||||
BACKUP_MACHINE_REGS();
|
||||
|
||||
/* first, backtrack to the root */
|
||||
if (B != NULL) {
|
||||
while (B->cp_b != NULL)
|
||||
B = B->cp_b;
|
||||
P = (yamop *)FAILCODE;
|
||||
if (exec_absmi(0) != 0)
|
||||
return(FALSE);
|
||||
}
|
||||
/* reinitialise the engine */
|
||||
InitYaamRegs();
|
||||
|
||||
RECOVER_MACHINE_REGS();
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapExit(int retval)
|
||||
{
|
||||
exit_yap(retval, NULL);
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapInitSocks(char *host, long port)
|
||||
{
|
||||
#if USE_SOCKET
|
||||
init_socks(host, port);
|
||||
#endif
|
||||
}
|
||||
|
||||
X_API void
|
||||
YapSetOutputMessage(void)
|
||||
{
|
||||
#if DEBUG
|
||||
output_msg = TRUE;
|
||||
#endif
|
||||
}
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,652 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: computils.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: some useful routines for YAP's compiler *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
/*
|
||||
* This file includes a set of utilities, useful to the several compilation
|
||||
* modules
|
||||
*/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "compile.h"
|
||||
#include "yapio.h"
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
#ifdef DEBUG
|
||||
STATIC_PROTO (void ShowOp, (char *));
|
||||
#endif /* DEBUG */
|
||||
|
||||
/*
|
||||
* The compiler creates an instruction chain which will be assembled after
|
||||
* afterwards
|
||||
*/
|
||||
|
||||
char *freep, *freep0;
|
||||
|
||||
Int arg, rn;
|
||||
|
||||
compiler_vm_op ic;
|
||||
|
||||
CELL *cptr;
|
||||
|
||||
char *
|
||||
AllocCMem (int size)
|
||||
{
|
||||
char *p;
|
||||
p = freep;
|
||||
#if SIZEOF_INT_P==8
|
||||
size = (size + 7) & 0xfffffffffffffff8L;
|
||||
#else
|
||||
size = (size + 3) & 0xfffffffcL;
|
||||
#endif
|
||||
freep += size;
|
||||
if (ASP <= CellPtr (freep) + 256) {
|
||||
save_machine_regs();
|
||||
longjmp(CompilerBotch,3);
|
||||
}
|
||||
return (p);
|
||||
}
|
||||
|
||||
int
|
||||
is_a_test_pred (Term arg)
|
||||
{
|
||||
Atom At;
|
||||
int arity;
|
||||
if (IsVarTerm (arg))
|
||||
return (FALSE);
|
||||
else if (IsAtomTerm (arg))
|
||||
{
|
||||
At = AtomOfTerm (arg);
|
||||
arity = 0;
|
||||
}
|
||||
else if (IsApplTerm (arg))
|
||||
{
|
||||
Functor f = FunctorOfTerm (arg);
|
||||
At = NameOfFunctor (f);
|
||||
arity = ArityOfFunctor (f);
|
||||
}
|
||||
else
|
||||
return (FALSE);
|
||||
if (RepPredProp (PredProp (At, arity)) == NULL)
|
||||
return (FALSE);
|
||||
return (RepPredProp (PredProp (At, arity))->PredFlags & TestPredFlag);
|
||||
}
|
||||
|
||||
void
|
||||
emit (compiler_vm_op o, Int r1, CELL r2)
|
||||
{
|
||||
PInstr *p;
|
||||
p = (PInstr *) AllocCMem (sizeof (*p));
|
||||
p->op = o;
|
||||
p->rnd1 = r1;
|
||||
p->rnd2 = r2;
|
||||
p->nextInst = NIL;
|
||||
if (cpc == NIL)
|
||||
cpc = CodeStart = p;
|
||||
else
|
||||
{
|
||||
cpc->nextInst = p;
|
||||
cpc = p;
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
emit_3ops (compiler_vm_op o, CELL r1, CELL r2, CELL r3)
|
||||
{
|
||||
PInstr *p;
|
||||
p = (PInstr *) AllocCMem (sizeof (*p)+sizeof(CELL));
|
||||
p->op = o;
|
||||
p->rnd1 = r1;
|
||||
p->rnd2 = r2;
|
||||
p->rnd3 = r3;
|
||||
p->nextInst = NIL;
|
||||
if (cpc == NIL)
|
||||
cpc = CodeStart = p;
|
||||
else
|
||||
{
|
||||
cpc->nextInst = p;
|
||||
cpc = p;
|
||||
}
|
||||
}
|
||||
|
||||
CELL *
|
||||
emit_extra_size (compiler_vm_op o, CELL r1, int size)
|
||||
{
|
||||
PInstr *p;
|
||||
p = (PInstr *) AllocCMem (sizeof (*p) + size - CellSize);
|
||||
p->op = o;
|
||||
p->rnd1 = r1;
|
||||
p->nextInst = NIL;
|
||||
if (cpc == NIL)
|
||||
cpc = CodeStart = p;
|
||||
else
|
||||
{
|
||||
cpc->nextInst = p;
|
||||
cpc = p;
|
||||
}
|
||||
return (p->arnds);
|
||||
}
|
||||
|
||||
void
|
||||
bip_name(Int op, char *s)
|
||||
{
|
||||
switch (op) {
|
||||
case _atom:
|
||||
strcpy(s,"atom");
|
||||
break;
|
||||
case _atomic:
|
||||
strcpy(s,"atomic");
|
||||
break;
|
||||
case _integer:
|
||||
strcpy(s,"integer");
|
||||
break;
|
||||
case _nonvar:
|
||||
strcpy(s,"nonvar");
|
||||
break;
|
||||
case _number:
|
||||
strcpy(s,"number");
|
||||
break;
|
||||
case _var:
|
||||
strcpy(s,"var");
|
||||
break;
|
||||
case _cut_by:
|
||||
strcpy(s,"cut_by");
|
||||
break;
|
||||
case _db_ref:
|
||||
strcpy(s,"db_ref");
|
||||
break;
|
||||
case _compound:
|
||||
strcpy(s,"compound");
|
||||
break;
|
||||
case _float:
|
||||
strcpy(s,"float");
|
||||
break;
|
||||
case _primitive:
|
||||
strcpy(s,"primitive");
|
||||
break;
|
||||
case _equal:
|
||||
strcpy(s,"equal");
|
||||
break;
|
||||
case _dif:
|
||||
strcpy(s,"dif");
|
||||
break;
|
||||
case _eq:
|
||||
strcpy(s,"eq");
|
||||
break;
|
||||
case _arg:
|
||||
strcpy(s,"arg");
|
||||
break;
|
||||
case _functor:
|
||||
strcpy(s,"functor");
|
||||
break;
|
||||
case _plus:
|
||||
strcpy(s,"plus");
|
||||
break;
|
||||
case _minus:
|
||||
strcpy(s,"minus");
|
||||
break;
|
||||
case _times:
|
||||
strcpy(s,"times");
|
||||
break;
|
||||
case _div:
|
||||
strcpy(s,"div");
|
||||
break;
|
||||
case _and:
|
||||
strcpy(s,"and");
|
||||
break;
|
||||
case _or:
|
||||
strcpy(s,"or");
|
||||
break;
|
||||
case _sll:
|
||||
strcpy(s,"sll");
|
||||
break;
|
||||
case _slr:
|
||||
strcpy(s,"slr");
|
||||
break;
|
||||
default:
|
||||
strcpy(s,"");
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef DEBUG
|
||||
|
||||
static void
|
||||
ShowOp (f)
|
||||
char *f;
|
||||
{
|
||||
char ch;
|
||||
while ((ch = *f++) != 0)
|
||||
{
|
||||
if (ch == '%')
|
||||
switch (ch = *f++)
|
||||
{
|
||||
case 'a':
|
||||
case 'n':
|
||||
plwrite ((Term) arg, DebugPutc, 0);
|
||||
break;
|
||||
case 'b':
|
||||
/* write a variable bitmap for a call */
|
||||
{
|
||||
int max = arg/(8*sizeof(CELL)), i;
|
||||
CELL *ptr = cptr;
|
||||
for (i = 0; i <= max; i++) {
|
||||
plwrite(MkIntegerTerm((Int)(*ptr++)), DebugPutc, 0);
|
||||
}
|
||||
}
|
||||
break;
|
||||
case 'l':
|
||||
plwrite (MkIntTerm (arg), DebugPutc, 0);
|
||||
break;
|
||||
case 'B':
|
||||
{
|
||||
char s[32];
|
||||
|
||||
bip_name(rn,s);
|
||||
plwrite (MkAtomTerm(LookupAtom(s)), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'd':
|
||||
plwrite (MkIntTerm (rn), DebugPutc, 0);
|
||||
break;
|
||||
case 'z':
|
||||
plwrite (MkIntTerm (cpc->rnd3), DebugPutc, 0);
|
||||
break;
|
||||
case 'v':
|
||||
{
|
||||
Ventry *v = (Ventry *) arg;
|
||||
DebugPutc (c_output_stream,v->KindOfVE == PermVar ? 'Y' : 'X');
|
||||
plwrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'N':
|
||||
{
|
||||
Ventry *v;
|
||||
|
||||
cpc = cpc->nextInst;
|
||||
arg = cpc->rnd1;
|
||||
v = (Ventry *) arg;
|
||||
DebugPutc (c_output_stream,v->KindOfVE == PermVar ? 'Y' : 'X');
|
||||
plwrite (MkIntTerm ((v->NoOfVE) & MaskVarAdrs), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'm':
|
||||
plwrite (MkAtomTerm ((Atom) arg), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite (MkIntTerm (rn), DebugPutc, 0);
|
||||
break;
|
||||
case 'p':
|
||||
{
|
||||
PredEntry *p = RepPredProp ((Prop) arg);
|
||||
Functor f = p->FunctorOfPred;
|
||||
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,':');
|
||||
if (p->ArityOfPE == 0)
|
||||
f = MkFunctor ((Atom) f, 0);
|
||||
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'P':
|
||||
{
|
||||
PredEntry *p = RepPredProp((Prop) rn);
|
||||
Functor f = p->FunctorOfPred;
|
||||
plwrite (ModuleName[p->ModuleOfPred], DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,':');
|
||||
if (p->ArityOfPE == 0)
|
||||
f = MkFunctor ((Atom) f, 0);
|
||||
plwrite (MkAtomTerm (NameOfFunctor (f)), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite (MkIntTerm (ArityOfFunctor (f)), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'f':
|
||||
if (IsExtensionFunctor((Functor)arg)) {
|
||||
if ((Functor)arg == FunctorDBRef) {
|
||||
plwrite(MkAtomTerm(LookupAtom("DBRef")), DebugPutc, 0);
|
||||
} else if ((Functor)arg == FunctorLongInt) {
|
||||
plwrite(MkAtomTerm(LookupAtom("LongInt")), DebugPutc, 0);
|
||||
} else if ((Functor)arg == FunctorDouble) {
|
||||
plwrite(MkAtomTerm(LookupAtom("Double")), DebugPutc, 0);
|
||||
}
|
||||
} else {
|
||||
plwrite(MkAtomTerm(NameOfFunctor ((Functor) arg)), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite(MkIntTerm(ArityOfFunctor ((Functor) arg)), DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'r':
|
||||
DebugPutc (c_output_stream,'A');
|
||||
plwrite (MkIntTerm (rn), DebugPutc, 0);
|
||||
break;
|
||||
case 'h':
|
||||
{
|
||||
CELL my_arg = *cptr++;
|
||||
if (my_arg & 1)
|
||||
plwrite (MkIntTerm (my_arg),
|
||||
DebugPutc, 0);
|
||||
else if (my_arg == (CELL) FAILCODE)
|
||||
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
|
||||
else
|
||||
plwrite (MkIntegerTerm ((Int) my_arg),
|
||||
DebugPutc, 0);
|
||||
}
|
||||
break;
|
||||
case 'g':
|
||||
if (arg & 1)
|
||||
plwrite (MkIntTerm (arg),
|
||||
DebugPutc, 0);
|
||||
else if (arg == (CELL) FAILCODE)
|
||||
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
|
||||
else
|
||||
plwrite (MkIntegerTerm ((Int) arg), DebugPutc, 0);
|
||||
break;
|
||||
case 'i':
|
||||
plwrite (MkIntTerm (arg), DebugPutc, 0);
|
||||
break;
|
||||
case 'j':
|
||||
{
|
||||
Functor fun = (Functor)*cptr++;
|
||||
if (IsExtensionFunctor(fun)) {
|
||||
if (fun == FunctorDBRef) {
|
||||
plwrite(MkAtomTerm(LookupAtom("DBRef")), DebugPutc, 0);
|
||||
} else if (fun == FunctorLongInt) {
|
||||
plwrite(MkAtomTerm(LookupAtom("LongInt")), DebugPutc, 0);
|
||||
} else if (fun == FunctorDouble) {
|
||||
plwrite(MkAtomTerm(LookupAtom("Double")), DebugPutc, 0);
|
||||
}
|
||||
} else {
|
||||
plwrite (MkAtomTerm(NameOfFunctor(fun)), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite (MkIntTerm(ArityOfFunctor(fun)), DebugPutc, 0);
|
||||
}
|
||||
}
|
||||
break;
|
||||
case 'O':
|
||||
plwrite(AbsAppl(cptr), DebugPutc, 0);
|
||||
break;
|
||||
case 'x':
|
||||
plwrite (MkIntTerm (rn >> 1), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'\t');
|
||||
plwrite (MkIntTerm (rn & 1), DebugPutc, 0);
|
||||
break;
|
||||
case 'o':
|
||||
plwrite ((Term) * cptr++, DebugPutc, 0);
|
||||
case 'c':
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < arg; ++i)
|
||||
{
|
||||
CELL my_arg;
|
||||
if (*cptr)
|
||||
{
|
||||
plwrite ((Term) * cptr++, DebugPutc, 0);
|
||||
}
|
||||
else
|
||||
{
|
||||
plwrite (MkIntTerm (0), DebugPutc, 0);
|
||||
cptr++;
|
||||
}
|
||||
DebugPutc (c_output_stream,'\t');
|
||||
my_arg = *cptr++;
|
||||
if (my_arg & 1)
|
||||
plwrite (MkIntTerm (my_arg),
|
||||
DebugPutc, 0);
|
||||
else if (my_arg == (CELL) FAILCODE)
|
||||
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
|
||||
else
|
||||
plwrite (MkIntegerTerm ((Int) my_arg), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'\n');
|
||||
}
|
||||
}
|
||||
break;
|
||||
case 'e':
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < arg; ++i)
|
||||
{
|
||||
CELL my_arg;
|
||||
if (*cptr)
|
||||
{
|
||||
plwrite (MkAtomTerm (NameOfFunctor ((Functor) * cptr)), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'/');
|
||||
plwrite (MkIntTerm (ArityOfFunctor ((Functor) * cptr++)), DebugPutc, 0);
|
||||
}
|
||||
else
|
||||
{
|
||||
plwrite (MkIntTerm (0), DebugPutc, 0);
|
||||
cptr++;
|
||||
}
|
||||
DebugPutc (c_output_stream,'\t');
|
||||
my_arg = *cptr++;
|
||||
if (my_arg & 1)
|
||||
plwrite (MkIntTerm (my_arg),
|
||||
DebugPutc, 0);
|
||||
else if (my_arg == (CELL) FAILCODE)
|
||||
plwrite (MkAtomTerm (AtomFail), DebugPutc, 0);
|
||||
else
|
||||
plwrite (MkIntegerTerm ((Int) my_arg), DebugPutc, 0);
|
||||
DebugPutc (c_output_stream,'\n');
|
||||
}
|
||||
}
|
||||
break;
|
||||
default:
|
||||
DebugPutc (c_output_stream,'%');
|
||||
DebugPutc (c_output_stream,ch);
|
||||
}
|
||||
else
|
||||
DebugPutc (c_output_stream,ch);
|
||||
}
|
||||
DebugPutc (c_output_stream,'\n');
|
||||
}
|
||||
|
||||
static char *opformat[] =
|
||||
{
|
||||
"nop",
|
||||
"get_var\t\t%v,%r",
|
||||
"put_var\t\t%v,%r",
|
||||
"get_val\t\t%v,%r",
|
||||
"put_val\t\t%v,%r",
|
||||
"get_atom\t%a,%r",
|
||||
"put_atom\t%a,%r",
|
||||
"get_num\t\t%n,%r",
|
||||
"put_num\t\t%n,%r",
|
||||
"get_float\t\t%l,%r",
|
||||
"put_float\t\t%l,%r",
|
||||
"get_longint\t\t%l,%r",
|
||||
"put_longint\t\t%l,%r",
|
||||
"get_bigint\t\t%l,%r",
|
||||
"put_bigint\t\t%l,%r",
|
||||
"get_list\t%r",
|
||||
"put_list\t%r",
|
||||
"get_struct\t%f,%r",
|
||||
"put_struct\t%f,%r",
|
||||
"put_unsafe\t%v,%r",
|
||||
"unify_var\t%v",
|
||||
"write_var\t%v",
|
||||
"unify_val\t%v",
|
||||
"write_val\t%v",
|
||||
"unify_atom\t%a",
|
||||
"write_atom\t%a",
|
||||
"unify_num\t%n",
|
||||
"write_num\t%n",
|
||||
"unify_float\t%l",
|
||||
"write_float\t%l",
|
||||
"unify_longint\t%l",
|
||||
"write_longint\t%l",
|
||||
"unify_bigint\t%l",
|
||||
"write_bigint\t%l",
|
||||
"unify_list",
|
||||
"write_list",
|
||||
"unify_struct\t%f",
|
||||
"write_struct\t%f",
|
||||
"write_unsafe\t%v",
|
||||
"fail",
|
||||
"cut",
|
||||
"cutexit",
|
||||
"allocate",
|
||||
"deallocate",
|
||||
"try_me_else\t\t%l\t%x",
|
||||
"jump\t\t%l",
|
||||
"procceed",
|
||||
"call\t\t%p,%d,%z",
|
||||
"execute\t\t%p",
|
||||
"sys\t\t%p",
|
||||
"%l:",
|
||||
"name\t\t%m,%d",
|
||||
"pop\t\t%l",
|
||||
"retry_me_else\t\t%l\t%x",
|
||||
"trust_me_else_fail\t%x",
|
||||
"either_me\t\t%l,%d,%z",
|
||||
"or_else\t\t%l,%z",
|
||||
"or_last",
|
||||
"push_or",
|
||||
"pushpop_or",
|
||||
"pop_or",
|
||||
"save_by\t\t%v",
|
||||
"comit_by\t\t%v",
|
||||
"patch_by\t\t%v",
|
||||
"try\t\t%g\t%x",
|
||||
"retry\t\t%g\t%x",
|
||||
"trust\t\t%g\t%x",
|
||||
"try_in\t\t%g\t%x",
|
||||
"retry_in\t\t%g\t%x",
|
||||
"trust_in\t\t%g\t%x",
|
||||
"try_first\t\t%g\t%x",
|
||||
"retry_first\t\t%g\t%x",
|
||||
"trust_first\t\t%g\t%x",
|
||||
"try_first in\t\t%g\t%x",
|
||||
"retry_first in\t\t%g\t%x",
|
||||
"trust_first in\t\t%g\t%x",
|
||||
"try_tail\t\t%g\t%x",
|
||||
"retry_tail\t\t%g\t%x",
|
||||
"trust_tail\t\t%g\t%x",
|
||||
"try_tail_in\t\t%g\t%x",
|
||||
"retry_tail_in\t\t%g\t%x",
|
||||
"trust_tail_in\t\t%g\t%x",
|
||||
"try_head\t\t%g\t%x",
|
||||
"retry_head\t\t%g\t%x",
|
||||
"trust_head\t\t%g\t%x",
|
||||
"try_head_in\t\t%g\t%x",
|
||||
"retry_head_in\t\t%g\t%x",
|
||||
"trust_head_in\t\t%g\t%x",
|
||||
"try_last_first\t\t%g\t%x",
|
||||
"try_last_head\t\t%g\t%x",
|
||||
"jump_if_var\t\t%g",
|
||||
"switch_on_type\t%h\t%h\t%h\t%h",
|
||||
"switch_on_type_if_nonvar\t%h\t%h\t%h",
|
||||
"switch_on_type_of_last\t%h\t%h\t%h",
|
||||
"switch_on_type_of_head\t%h\t%h\t%h\t%h",
|
||||
"switch_on_list_or_nil\t%h\t%h\t%h\t%h",
|
||||
"switch_if_list_or_nil\t%h\t%h\t%h",
|
||||
"switch_on_last_list_or_nil\t%h\t%h\t%h",
|
||||
"switch_on_constant\t%i\n%c",
|
||||
"if_a_constant\t%i\t%h\n%c",
|
||||
"go_if_ equals_constant\t%o\t%h\t%h",
|
||||
"switch_on_functor\t%i\n%e",
|
||||
"if_a_functor\t%i\t%h\n%e",
|
||||
"go_if_equals_functor\t%j\t%h\t%h",
|
||||
"if_not_then\t%i\t%h\t%h\t%h",
|
||||
"save_pair\t%v",
|
||||
"save_appl\t%v",
|
||||
"fail_label\t%l",
|
||||
"unify_local\t%v",
|
||||
"write local\t%v",
|
||||
"unify_last_list",
|
||||
"write_last_list",
|
||||
"unify_last_struct\t%f",
|
||||
"write_last_struct\t%f",
|
||||
"unify_last_var\t%v",
|
||||
"unify_last_val\t%v",
|
||||
"unify_last_local\t%v",
|
||||
"unify_last_atom\t%a",
|
||||
"unify_last_num\t%n",
|
||||
"unify_last_float\t%l",
|
||||
"unify_last_longint\t%l",
|
||||
"unify_last_bigint\t%l",
|
||||
"pvar_bitmap\t%l,%b",
|
||||
"pvar_live_regs\t%l,%b",
|
||||
"fetch_reg1_reg2\t%N,%N",
|
||||
"fetch_constant_reg\t%l,%N",
|
||||
"fetch_reg_constant\t%l,%N",
|
||||
"function_to_var\t%v,%B",
|
||||
"function_to_al\t%v,%B",
|
||||
"enter_profiling\t\t%g",
|
||||
"retry_profiled\t\t%g",
|
||||
"restore_temps\t\t%l",
|
||||
"restore_temps_and_skip\t\t%l",
|
||||
"empty_call\t\t%l,%d",
|
||||
#ifdef TABLING
|
||||
"table_new_answer",
|
||||
#endif /* TABLING */
|
||||
#ifdef YAPOR
|
||||
"sync",
|
||||
#endif /* YAPOR */
|
||||
"fetch_args_for_bccall\t%v",
|
||||
"binary_cfunc\t\t%v,%P",
|
||||
"blob\t%O"
|
||||
#ifdef SFUNC
|
||||
,
|
||||
"get_s_f_op\t%f,%r",
|
||||
"put_s_f_op\t%f,%r",
|
||||
"unify_s_f_op\t%f",
|
||||
"write_s_f_op\t%f",
|
||||
"unify_s_var\t%v,%r",
|
||||
"write_s_var\t%v,%r",
|
||||
"unify_s_val\t%v,%r",
|
||||
"write_s_val\t%v,%r",
|
||||
"unify_s_a\t%a,%r",
|
||||
"write_s_a\t%a,%r",
|
||||
"get_s_end",
|
||||
"put_s_end",
|
||||
"unify_s_end",
|
||||
"write_s_end"
|
||||
#endif
|
||||
};
|
||||
|
||||
|
||||
void
|
||||
ShowCode ()
|
||||
{
|
||||
CELL *OldH = H;
|
||||
|
||||
cpc = CodeStart;
|
||||
/* MkIntTerm and friends may build terms in the global stack */
|
||||
H = (CELL *)freep;
|
||||
while (cpc)
|
||||
{
|
||||
ic = cpc->op;
|
||||
arg = cpc->rnd1;
|
||||
rn = cpc->rnd2;
|
||||
cptr = cpc->arnds;
|
||||
if (ic != nop_op)
|
||||
ShowOp (opformat[ic]);
|
||||
cpc = cpc->nextInst;
|
||||
}
|
||||
DebugPutc (c_output_stream,'\n');
|
||||
H = OldH;
|
||||
}
|
||||
|
||||
#endif /* DEBUG */
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,60 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: it_deep.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: Support for Iterative Deepening *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif /* SCCS */
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef DEPTH_LIMIT
|
||||
|
||||
#include "Yatom.h"
|
||||
|
||||
STD_PROTO(static Int p_get_depth_limit, (void));
|
||||
STD_PROTO(static Int p_set_depth_limit, (void));
|
||||
|
||||
static Int p_get_depth_limit(void)
|
||||
{
|
||||
return(unify_constant(ARG1, MkIntTerm(IntOfTerm(DEPTH/2))));
|
||||
}
|
||||
|
||||
static Int p_set_depth_limit(void)
|
||||
{
|
||||
Term d = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(d)) {
|
||||
Error(INSTANTIATION_ERROR, d, "set-depth_limit");
|
||||
return(FALSE);
|
||||
} else if (!IsIntegerTerm(d)) {
|
||||
Error(TYPE_ERROR_INTEGER, d, "set-depth_limit");
|
||||
return(FALSE);
|
||||
}
|
||||
d = MkIntTerm(IntegerOfTerm(d)*2);
|
||||
|
||||
YENV[E_DEPTH] = d;
|
||||
DEPTH = d;
|
||||
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
void InitItDeepenPreds(void)
|
||||
{
|
||||
InitCPred("get_depth_limit", 1, p_get_depth_limit, SafePredFlag);
|
||||
InitCPred("$set_depth_limit", 1, p_set_depth_limit, 0);
|
||||
}
|
||||
|
||||
#endif
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,145 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: eval.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: arithmetical expression evaluation *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
/*
|
||||
* This file implements arithmetic operations
|
||||
*
|
||||
*/
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "eval.h"
|
||||
|
||||
yap_error_number YAP_matherror = NO_ERROR;
|
||||
|
||||
#define E_FUNC blob_type
|
||||
#define E_ARGS arith_retptr o
|
||||
#define USE_E_ARGS o
|
||||
#define RBIG(v) (o)->big = v; return(big_int_e)
|
||||
|
||||
#define RINT(v) (o)->Int = v; return(long_int_e)
|
||||
#define RFLOAT(v) (o)->dbl = v; return(double_e)
|
||||
#define RERROR() return(db_ref_e)
|
||||
|
||||
static Term
|
||||
EvalToTerm(blob_type bt, union arith_ret *res)
|
||||
{
|
||||
switch (bt) {
|
||||
case long_int_e:
|
||||
return(MkIntegerTerm(res->Int));
|
||||
case double_e:
|
||||
return(MkFloatTerm(res->dbl));
|
||||
#ifdef USE_GMP
|
||||
case big_int_e:
|
||||
return(MkBigIntTerm(res->big));
|
||||
#endif
|
||||
default:
|
||||
return(TermNil);
|
||||
}
|
||||
}
|
||||
|
||||
E_FUNC
|
||||
Eval(Term t, E_ARGS)
|
||||
{
|
||||
if (IsVarTerm(t)) {
|
||||
Error(INSTANTIATION_ERROR,TermNil,"in arithmetic");
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
}
|
||||
if (IsApplTerm(t)) {
|
||||
Functor fun = FunctorOfTerm(t);
|
||||
switch ((CELL)fun) {
|
||||
case (CELL)FunctorLongInt:
|
||||
RINT(LongIntOfTerm(t));
|
||||
case (CELL)FunctorDouble:
|
||||
RFLOAT(FloatOfTerm(t));
|
||||
#ifdef USE_GMP
|
||||
case (CELL)FunctorBigInt:
|
||||
RBIG(BigIntOfTerm(t));
|
||||
#endif
|
||||
default:
|
||||
{
|
||||
Int n = ArityOfFunctor(fun);
|
||||
Atom name = NameOfFunctor(fun);
|
||||
ExpEntry *p;
|
||||
|
||||
if (EndOfPAEntr(p = RepExpProp(GetExpProp(name, n)))) {
|
||||
Term ti[2];
|
||||
|
||||
/* error */
|
||||
ti[0] = t;
|
||||
ti[1] = MkIntegerTerm(n);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"functor %s/%d for arithmetic expression",
|
||||
RepAtom(name)->StrOfAE,n);
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
}
|
||||
if (n == 1)
|
||||
return(p->FOfEE.unary(ArgOfTerm(1,t), USE_E_ARGS));
|
||||
return(p->FOfEE.binary(ArgOfTerm(1,t),ArgOfTerm(2,t), USE_E_ARGS));
|
||||
}
|
||||
}
|
||||
} else if (IsPairTerm(t)) {
|
||||
return(Eval(HeadOfTerm(t), USE_E_ARGS));
|
||||
} else if (IsIntTerm(t)) {
|
||||
RINT(IntOfTerm(t));
|
||||
} else {
|
||||
Atom name = AtomOfTerm(t);
|
||||
ExpEntry *p;
|
||||
|
||||
if (EndOfPAEntr(p = RepExpProp(GetExpProp(name, 0)))) {
|
||||
Term ti[2];
|
||||
|
||||
/* error */
|
||||
ti[0] = t;
|
||||
ti[1] = MkIntTerm(0);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"functor %s/%d for arithmetic expression",
|
||||
RepAtom(name)->StrOfAE,0);
|
||||
P = (yamop *)FAILCODE;
|
||||
RERROR();
|
||||
}
|
||||
return(p->FOfEE.constant(USE_E_ARGS));
|
||||
}
|
||||
}
|
||||
|
||||
static Int
|
||||
p_is(void)
|
||||
{ /* X is Y */
|
||||
union arith_ret res;
|
||||
blob_type bt;
|
||||
|
||||
bt = Eval(Deref(ARG2), &res);
|
||||
return (unify_constant(ARG1,EvalToTerm(bt,&res)));
|
||||
}
|
||||
|
||||
void
|
||||
InitEval(void)
|
||||
{
|
||||
/* here are the arithmetical predicates */
|
||||
InitConstExps();
|
||||
InitUnaryExps();
|
||||
InitBinaryExps();
|
||||
InitCPred("is", 2, p_is, TestPredFlag | SafePredFlag);
|
||||
}
|
||||
|
|
@ -0,0 +1,233 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: evalis.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: is/3 predicate *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif /* SCCS */
|
||||
|
||||
/*
|
||||
* This predicates had to be developed here because of a bug in the MPW
|
||||
* compiler, which was not able to compile the original eval.c
|
||||
*/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "eval.h"
|
||||
|
||||
|
||||
int
|
||||
UnEvalInt(BITS16 op, Int i1)
|
||||
{
|
||||
switch(op) {
|
||||
case e_uminus:
|
||||
REvalInt(-i1);
|
||||
case e_abs:
|
||||
#if SHORT_INTS
|
||||
#if HAVE_LABS
|
||||
REvalInt((Int)labs((long int)i1));
|
||||
#else
|
||||
REvalInt((i1 >= 0 ? i1 : -i1));
|
||||
#endif
|
||||
#else
|
||||
REvalInt(abs(i1));
|
||||
#endif
|
||||
case e_msb:
|
||||
REvalInt(msb(i1));
|
||||
case e_uplus:
|
||||
REvalInt(i1);
|
||||
case e_not:
|
||||
REvalInt(~i1);
|
||||
case e_exp:
|
||||
REvalFl(exp(FL(i1)));
|
||||
case e_log:
|
||||
REvalFl(log(FL(i1)));
|
||||
case e_log10:
|
||||
REvalFl(log10(FL(i1)));
|
||||
case e_sqrt:
|
||||
REvalFl(sqrt(FL(i1)));
|
||||
case e_sin:
|
||||
REvalFl(sin(FL(i1)));
|
||||
case e_cos:
|
||||
REvalFl(cos(FL(i1)));
|
||||
case e_tan:
|
||||
REvalFl(tan(FL(i1)));
|
||||
case e_sinh:
|
||||
REvalFl(sinh(FL(i1)));
|
||||
case e_cosh:
|
||||
REvalFl(cosh(FL(i1)));
|
||||
case e_tanh:
|
||||
REvalFl(tanh(FL(i1)));
|
||||
case e_asin:
|
||||
REvalFl(asin(FL(i1)));
|
||||
case e_acos:
|
||||
REvalFl(acos(FL(i1)));
|
||||
case e_atan:
|
||||
REvalFl(atan(FL(i1)));
|
||||
case e_asinh:
|
||||
REvalFl(asinh(FL(i1)));
|
||||
case e_acosh:
|
||||
REvalFl(acosh(FL(i1)));
|
||||
case e_atanh:
|
||||
REvalFl(atanh(FL(i1)));
|
||||
case e_floor:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "floor/1");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(i1));
|
||||
}
|
||||
case e_round:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "round/1");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(i1));
|
||||
}
|
||||
case e_ceiling:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "floor/1");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(i1));
|
||||
}
|
||||
case e_truncate:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
Error(TYPE_ERROR_FLOAT, MkIntegerTerm(i1), "truncate/1");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(i1));
|
||||
}
|
||||
case e_integer:
|
||||
REvalInt(i1);
|
||||
case e_float:
|
||||
REvalFl(FL(i1));
|
||||
case e_fmodf:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
Error(TYPE_ERROR_FLOAT,MkIntegerTerm(i1),"mod/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(0.0));
|
||||
}
|
||||
case e_imodf:
|
||||
if (yap_flags[LANGUAGE_MODE_FLAG] == 1) { /* iso */
|
||||
/* iso does not allow integer arguments to this procedure */
|
||||
Error(TYPE_ERROR_FLOAT,MkIntegerTerm(i1),"mod/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
} else {
|
||||
REvalFl(FL(i1));
|
||||
}
|
||||
case e_sign:
|
||||
if (i1 < 0) {
|
||||
REvalInt(-1);
|
||||
} else if (i1 == 0) {
|
||||
REvalInt(0);
|
||||
} else {
|
||||
REvalInt(1);
|
||||
}
|
||||
default:
|
||||
{
|
||||
Term t, ti[2];
|
||||
|
||||
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
|
||||
ti[1] = MkIntegerTerm(1);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),1), 1, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"arithmetic expression %s/%d",
|
||||
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
|
||||
2
|
||||
);
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
Int
|
||||
p_unary_is(void)
|
||||
{
|
||||
register BITS16 OpNum;
|
||||
Term t2, t3;
|
||||
int flag;
|
||||
|
||||
current_eval_term = MkIntTerm(1);
|
||||
t2 = Deref(ARG2);
|
||||
if (IsVarTerm(t2)) {
|
||||
Error(INSTANTIATION_ERROR, t2, "operation for is/3");
|
||||
P = (yamop *)FAILCODE;
|
||||
return(FALSE);
|
||||
}
|
||||
if (IsAtomTerm(t2)) {
|
||||
Atom name;
|
||||
Prop p;
|
||||
name = AtomOfTerm(t2);
|
||||
if ((p = GetExpProp(name, 1)) == NIL) {
|
||||
Term t, ti[2];
|
||||
|
||||
ti[0] = MkAtomTerm(name);
|
||||
ti[1] = MkIntegerTerm(1);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"arithmetic expression %s/%d",
|
||||
RepAtom(name)->StrOfAE,
|
||||
1
|
||||
);
|
||||
P = (yamop *)FAILCODE;
|
||||
return(FALSE);
|
||||
}
|
||||
OpNum = RepExpProp(p)->ENoOfEE;
|
||||
} else if (IsIntTerm(t2))
|
||||
OpNum = IntOfTerm(t2);
|
||||
else
|
||||
return (FALSE);
|
||||
t3 = Deref(ARG3);
|
||||
if (IsVarTerm(t3)) {
|
||||
int op = 0;
|
||||
|
||||
while (InitTab[op].eno != OpNum) op++;
|
||||
Error(INSTANTIATION_ERROR, t3, "arithmetic expression %s/1", InitTab[op].OpName);
|
||||
P = (yamop *)FAILCODE;
|
||||
return(FALSE);
|
||||
}
|
||||
if (IsIntegerTerm(t3)) {
|
||||
flag = UnEvalInt(OpNum, IntegerOfTerm(t3));
|
||||
} else if (IsFloatTerm(t3)) {
|
||||
flag = UnEvalFl(OpNum, FloatOfTerm(t3));
|
||||
} else {
|
||||
int aflag = Eval(t3);
|
||||
if (aflag == FError) {
|
||||
return(FALSE);
|
||||
} else if (aflag == FInt) {
|
||||
flag = UnEvalInt(OpNum, eval_int);
|
||||
} else {
|
||||
flag = UnEvalFl(OpNum, eval_flt);
|
||||
}
|
||||
}
|
||||
if (flag == FError) {
|
||||
return(FALSE);
|
||||
} else if (flag == FInt) {
|
||||
return(unify_constant(ARG1,MkIntegerTerm(eval_int)));
|
||||
} else {
|
||||
return(unify_constant(ARG1,MkFloatTerm(eval_flt)));
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,301 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: evaltwo.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: is/4 predicate *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
/*
|
||||
* This predicates had to be developed here because of a bug in the MPW
|
||||
* compiler, which was not able to compile the original eval.c
|
||||
*/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "eval.h"
|
||||
|
||||
#define IntRes(X) return(unify_constant(ARG1,MkIntegerTerm(X)))
|
||||
#define FloatRes(X) return(unify_constant(ARG1,MkEvalFl(X)))
|
||||
|
||||
int
|
||||
BinEvalInt(BITS16 op, Int i1, Int i2)
|
||||
{
|
||||
switch(op) {
|
||||
case e_plus:
|
||||
REvalInt(i1 + i2);
|
||||
case e_dif:
|
||||
REvalInt(i1 - i2);
|
||||
case e_times:
|
||||
REvalInt(i1 * i2);
|
||||
case e_div:
|
||||
#ifdef TRY_TO_CONVERT_FLOATS_TO_INTS
|
||||
if (i1 % i2 == 0)
|
||||
REvalInt(i1 / i2);
|
||||
#endif
|
||||
REvalFl(FL(i1) / FL(i2));
|
||||
case e_and:
|
||||
REvalInt(i1 & i2);
|
||||
case e_xor:
|
||||
REvalInt(i1 ^ i2);
|
||||
case e_or:
|
||||
REvalInt(i1 | i2);
|
||||
case e_lshift:
|
||||
REvalInt(i1 << i2);
|
||||
case e_rshift:
|
||||
REvalInt(i1 >> i2);
|
||||
case e_mod:
|
||||
REvalInt(i1 % i2);
|
||||
case e_idiv:
|
||||
REvalInt(i1 / i2);
|
||||
case e_gcd:
|
||||
REvalInt(gcd(abs(i1),abs(i2)));
|
||||
case e_gcdmult:
|
||||
{
|
||||
Int i;
|
||||
REvalInt(gcdmult(abs(i1),abs(i2), &i));
|
||||
}
|
||||
case e_min:
|
||||
REvalInt((i1 < i2 ? i1 : i2));
|
||||
case e_max:
|
||||
REvalInt((i1 > i2 ? i1 : i2));
|
||||
case e_power:
|
||||
REvalFl(pow(FL(i1), FL(i2)));
|
||||
case e_atan2:
|
||||
REvalFl(atan2(FL(i1), FL(i2)));
|
||||
default:
|
||||
{
|
||||
Term t, ti[2];
|
||||
|
||||
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
|
||||
ti[1] = MkIntegerTerm(2);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"in arithmetic expression %s(%d,%d)",
|
||||
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
|
||||
i1,
|
||||
i2
|
||||
);
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
BinEvalFl(BITS16 op, Float f1, Float f2, int flts)
|
||||
{
|
||||
switch(op) {
|
||||
case e_plus:
|
||||
REvalFl(f1 + f2);
|
||||
case e_dif:
|
||||
REvalFl(f1 - f2);
|
||||
case e_times:
|
||||
REvalFl(f1 * f2);
|
||||
case e_div:
|
||||
REvalFl(f1 / f2);
|
||||
case e_power:
|
||||
REvalFl(pow(f1, f2));
|
||||
case e_atan2:
|
||||
REvalFl(atan2(f1, f2));
|
||||
case e_min:
|
||||
REvalFl((f1 < f2 ? f1 : f2));
|
||||
case e_max:
|
||||
REvalFl((f1 > f2 ? f1 : f2));
|
||||
case e_lshift:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "<</2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "<</2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_rshift:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), ">>/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), ">>/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_and:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "/\\/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "/\\/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_xor:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "#/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "#/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_or:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "\\/ /2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "\\/ /2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_mod:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "mod/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "mod/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_idiv:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "/ /2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "/ /2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_gcd:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "gcd/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "gcd/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
case e_gcdmult:
|
||||
if (flts & 1)
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f1), "gcdmult/2");
|
||||
else
|
||||
Error(TYPE_ERROR_INTEGER, MkFloatTerm(f2), "gcdmult/2");
|
||||
P = (yamop *)FAILCODE;
|
||||
REvalError();
|
||||
default:
|
||||
{
|
||||
Term t, ti[2];
|
||||
|
||||
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(current_eval_term)));
|
||||
ti[1] = MkIntegerTerm(2);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"in arithmetic expression %s(%d,%d)",
|
||||
RepAtom(NameOfFunctor(FunctorOfTerm(current_eval_term)))->StrOfAE,
|
||||
f1,
|
||||
f2
|
||||
);
|
||||
P = (yamop *)FAILCODE;
|
||||
}
|
||||
REvalError();
|
||||
}
|
||||
}
|
||||
|
||||
Int
|
||||
p_binary_is(void)
|
||||
{
|
||||
register BITS16 OpNum;
|
||||
Term t2,t3,t4;
|
||||
Int i1;
|
||||
Float f1;
|
||||
int flag;
|
||||
|
||||
current_eval_term = MkIntTerm(2);
|
||||
t2 = Deref(ARG2);
|
||||
if (IsVarTerm(t2)) {
|
||||
Error(INSTANTIATION_ERROR, t2, "operation for is/4");
|
||||
P = (yamop *)FAILCODE;
|
||||
return(FALSE);
|
||||
}
|
||||
if (IsIntTerm(t2))
|
||||
OpNum = IntOfTerm(t2);
|
||||
else if (IsAtomTerm(t2)) {
|
||||
Atom name = AtomOfTerm(t2);
|
||||
Prop p;
|
||||
if ((p = GetExpProp(name, 2)) == NIL) {
|
||||
Term t, ti[2];
|
||||
|
||||
ti[0] = MkIntegerTerm(2);
|
||||
ti[0] = MkAtomTerm(name);
|
||||
t = MkApplTerm(MkFunctor(LookupAtom("/"),2), 2, ti);
|
||||
Error(TYPE_ERROR_EVALUABLE, t,
|
||||
"arithmetic expression %s/%d",
|
||||
RepAtom(name)->StrOfAE,
|
||||
2
|
||||
);
|
||||
P = (yamop *)FAILCODE;
|
||||
return(FALSE);
|
||||
}
|
||||
OpNum = RepExpProp(p)->ENoOfEE;
|
||||
} else
|
||||
return (FALSE);
|
||||
t3 = Deref(ARG3);
|
||||
t4 = Deref(ARG4);
|
||||
if (IsVarTerm(t3) || IsVarTerm(t4)) {
|
||||
int op = 0;
|
||||
|
||||
while (InitTab[op].eno != OpNum) op++;
|
||||
Error(INSTANTIATION_ERROR, (IsVarTerm(t3) ? t3 : t4),
|
||||
"arithmetic expression %s/2", InitTab[op].OpName);
|
||||
return(FALSE);
|
||||
}
|
||||
if (IsIntegerTerm(t3)) {
|
||||
i1 = IntegerOfTerm(t3);
|
||||
t3_int:
|
||||
if (IsIntegerTerm(t4)) {
|
||||
flag = BinEvalInt(OpNum, i1, IntegerOfTerm(t4));
|
||||
} else if (IsFloatTerm(t4)) {
|
||||
flag = BinEvalFl(OpNum, FL(i1), FloatOfTerm(t4), 2);
|
||||
} else {
|
||||
int aflag = Eval(t4);
|
||||
if (aflag == FError) {
|
||||
return(FALSE);
|
||||
} else if (aflag == FInt) {
|
||||
flag = BinEvalInt(OpNum, i1, eval_int);
|
||||
} else {
|
||||
flag = BinEvalFl(OpNum, FL(i1), eval_flt, 2);
|
||||
}
|
||||
}
|
||||
} else if (IsFloatTerm(t3)) {
|
||||
f1 = FloatOfTerm(t3);
|
||||
t3_flt:
|
||||
if (IsIntegerTerm(t4)) {
|
||||
flag = BinEvalFl(OpNum, f1, FL(IntegerOfTerm(t4)), 1);
|
||||
} else if (IsFloatTerm(t4)) {
|
||||
flag = BinEvalFl(OpNum, f1, FloatOfTerm(t4), 3);
|
||||
} else {
|
||||
int aflag = Eval(t4);
|
||||
if (aflag == FError) {
|
||||
return(FALSE);
|
||||
} else if (aflag == FInt) {
|
||||
flag = BinEvalFl(OpNum, f1, eval_int, 1);
|
||||
} else {
|
||||
flag = BinEvalFl(OpNum, f1, eval_flt, 3);
|
||||
}
|
||||
}
|
||||
} else {
|
||||
int aflag = Eval(t3);
|
||||
if (aflag == FError) {
|
||||
return(FALSE);
|
||||
} else if (aflag == FInt) {
|
||||
i1 = eval_int;
|
||||
goto t3_int;
|
||||
} else {
|
||||
f1 = eval_flt;
|
||||
goto t3_flt;
|
||||
}
|
||||
}
|
||||
if (flag == FError) {
|
||||
return(FALSE);
|
||||
} else if (flag == FInt) {
|
||||
return(unify_constant(ARG1,MkIntegerTerm(eval_int)));
|
||||
} else {
|
||||
return(unify_constant(ARG1,MkFloatTerm(eval_flt)));
|
||||
}
|
||||
}
|
|
@ -0,0 +1,949 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: grow.c *
|
||||
* Last rev: Thu Feb 23 1989 vv *
|
||||
* mods: *
|
||||
* comments: Shifting the stacks *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include "alloc.h"
|
||||
#include "sshift.h"
|
||||
#include "compile.h"
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
static int heap_overflows = 0;
|
||||
static Int total_heap_overflow_time = 0;
|
||||
|
||||
int stack_overflows = 0;
|
||||
static Int total_stack_overflow_time = 0;
|
||||
|
||||
int delay_overflows = 0;
|
||||
static Int total_delay_overflow_time = 0;
|
||||
|
||||
static int trail_overflows = 0;
|
||||
static Int total_trail_overflow_time = 0;
|
||||
|
||||
STATIC_PROTO(Int p_growheap, (void));
|
||||
STATIC_PROTO(Int p_growstack, (void));
|
||||
STATIC_PROTO(Int p_inform_trail_overflows, (void));
|
||||
STATIC_PROTO(Int p_inform_heap_overflows, (void));
|
||||
STATIC_PROTO(Int p_inform_stack_overflows, (void));
|
||||
|
||||
/* #define undf7 */
|
||||
/* #define undf5 */
|
||||
|
||||
STATIC_PROTO(void MoveGlobal, (void));
|
||||
STATIC_PROTO(void MoveLocalAndTrail, (void));
|
||||
STATIC_PROTO(void SetHeapRegs, (void));
|
||||
STATIC_PROTO(void SetStackRegs, (void));
|
||||
STATIC_PROTO(void AdjustTrail, (int));
|
||||
STATIC_PROTO(void AdjustLocal, (void));
|
||||
STATIC_PROTO(void AdjustGlobal, (void));
|
||||
STATIC_PROTO(void AdjustGrowStack, (void));
|
||||
STATIC_PROTO(int local_growheap, (long,int));
|
||||
STATIC_PROTO(void cpcellsd, (CELL *, CELL *, CELL));
|
||||
STATIC_PROTO(CELL AdjustAppl, (CELL));
|
||||
STATIC_PROTO(CELL AdjustPair, (CELL));
|
||||
|
||||
static void
|
||||
cpcellsd(register CELL *Dest, register CELL *Org, CELL NOf)
|
||||
{
|
||||
#if HAVE_MEMMOVE
|
||||
memmove((void *)Dest, (void *)Org, NOf*sizeof(CELL));
|
||||
#else
|
||||
register Int n_of = NOf;
|
||||
for (; n_of >= 0; n_of--)
|
||||
*--Dest = *--Org;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
/* The old stack pointers */
|
||||
CELL *OldASP, *OldLCL0;
|
||||
tr_fr_ptr OldTR;
|
||||
CELL *OldGlobalBase, *OldH, *OldH0;
|
||||
ADDR OldTrailBase, OldTrailTop;
|
||||
ADDR OldHeapBase, OldHeapTop;
|
||||
|
||||
Int
|
||||
GDiff,
|
||||
HDiff,
|
||||
LDiff,
|
||||
TrDiff,
|
||||
XDiff,
|
||||
DelayDiff;
|
||||
|
||||
static void
|
||||
SetHeapRegs(void)
|
||||
{
|
||||
#ifdef undf7
|
||||
YP_fprintf(YP_stderr,"HeapBase = %x\tHeapTop=%x\nGlobalBase=%x\tGlobalTop=%x\nLocalBase=%x\tLocatTop=%x\n", HeapBase, HeapTop, GlobalBase, H, LCL0, ASP);
|
||||
#endif
|
||||
/* The old stack pointers */
|
||||
OldLCL0 = LCL0;
|
||||
OldASP = ASP;
|
||||
OldGlobalBase = (CELL *)GlobalBase;
|
||||
OldH = H;
|
||||
OldH0 = H0;
|
||||
OldTrailBase = TrailBase;
|
||||
OldTrailTop = TrailTop;
|
||||
OldTR = TR;
|
||||
OldHeapBase = HeapBase;
|
||||
OldHeapTop = HeapTop;
|
||||
/* Adjust stack addresses */
|
||||
TrailBase = TrailAddrAdjust(TrailBase);
|
||||
TrailTop = TrailAddrAdjust(TrailTop);
|
||||
GlobalBase = DelayAddrAdjust(GlobalBase);
|
||||
LocalBase = LocalAddrAdjust(LocalBase);
|
||||
AuxSp = PtoDelayAdjust(AuxSp);
|
||||
AuxTop = DelayAddrAdjust(AuxTop);
|
||||
/* The registers pointing to one of the stacks */
|
||||
ENV = PtoLocAdjust(ENV);
|
||||
ASP = PtoLocAdjust(ASP);
|
||||
H0 = PtoGloAdjust(H0);
|
||||
LCL0 = PtoLocAdjust(LCL0);
|
||||
H = PtoGloAdjust(H);
|
||||
HB = PtoGloAdjust(HB);
|
||||
B = ChoicePtrAdjust(B);
|
||||
if (TopB != NULL)
|
||||
TopB = ChoicePtrAdjust(TopB);
|
||||
if (DelayedB != NULL)
|
||||
DelayedB = ChoicePtrAdjust(DelayedB);
|
||||
#ifdef TABLING
|
||||
B_FZ = ChoicePtrAdjust(B_FZ);
|
||||
BB = ChoicePtrAdjust(BB);
|
||||
H_FZ = PtoGloAdjust(H_FZ);
|
||||
TR_FZ = PtoTRAdjust(TR_FZ);
|
||||
#endif
|
||||
TR = PtoTRAdjust(TR);
|
||||
YENV = PtoLocAdjust(YENV);
|
||||
if (IsOldGlobalPtr(S))
|
||||
S = PtoGloAdjust(S);
|
||||
if (MyTR)
|
||||
MyTR = PtoTRAdjust(MyTR);
|
||||
#ifdef COROUTINING
|
||||
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
|
||||
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
|
||||
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
|
||||
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
|
||||
#endif
|
||||
}
|
||||
|
||||
static void
|
||||
SetStackRegs(void)
|
||||
{
|
||||
/* The old local stack pointers */
|
||||
OldLCL0 = LCL0;
|
||||
OldASP = ASP;
|
||||
OldH = H;
|
||||
OldH0 = H0;
|
||||
OldGlobalBase = (CELL *)GlobalBase;
|
||||
OldTrailTop = TrailTop;
|
||||
OldTrailBase = TrailBase;
|
||||
OldTR = TR;
|
||||
OldHeapBase = HeapBase;
|
||||
OldHeapTop = HeapTop;
|
||||
/* The local and aux stack addresses */
|
||||
TrailBase = TrailAddrAdjust(TrailBase);
|
||||
TrailTop = TrailAddrAdjust(TrailTop);
|
||||
LocalBase = LocalAddrAdjust(LocalBase);
|
||||
TR = PtoTRAdjust(TR);
|
||||
/* The registers pointing to the local stack */
|
||||
ENV = PtoLocAdjust(ENV);
|
||||
ASP = PtoLocAdjust(ASP);
|
||||
LCL0 = PtoLocAdjust(LCL0);
|
||||
B = ChoicePtrAdjust(B);
|
||||
if (TopB != NULL)
|
||||
TopB = ChoicePtrAdjust(TopB);
|
||||
if (DelayedB != NULL)
|
||||
DelayedB = ChoicePtrAdjust(DelayedB);
|
||||
#ifdef TABLING
|
||||
B_FZ = ChoicePtrAdjust(B_FZ);
|
||||
BB = ChoicePtrAdjust(BB);
|
||||
TR_FZ = PtoTRAdjust(TR_FZ);
|
||||
#endif
|
||||
YENV = PtoLocAdjust(YENV);
|
||||
if (MyTR)
|
||||
MyTR = PtoTRAdjust(MyTR);
|
||||
}
|
||||
|
||||
static void
|
||||
MoveLocalAndTrail(void)
|
||||
{
|
||||
/* cpcellsd(To,From,NOfCells) - copy the cells downwards */
|
||||
#if HAVE_MEMMOVE
|
||||
cpcellsd(ASP, OldASP, (CELL *)OldTR - OldASP);
|
||||
#else
|
||||
cpcellsd((CELL *)TR, (CELL *)OldTR, (CELL *)OldTR - OldASP);
|
||||
#endif
|
||||
}
|
||||
|
||||
static void
|
||||
MoveGlobal(void)
|
||||
{
|
||||
/*
|
||||
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
|
||||
* absmi.asm
|
||||
*/
|
||||
#if HAVE_MEMMOVE
|
||||
cpcellsd((CELL *)GlobalBase, (CELL *)OldGlobalBase, OldH - (CELL *)OldGlobalBase);
|
||||
#else
|
||||
cpcellsd(H, OldH, OldH - (CELL *)OldGlobalBase);
|
||||
#endif
|
||||
}
|
||||
|
||||
static void
|
||||
MoveGlobalOnly(void)
|
||||
{
|
||||
/*
|
||||
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
|
||||
* absmi.asm
|
||||
*/
|
||||
#if HAVE_MEMMOVE
|
||||
cpcellsd(H0, OldH0, OldH - OldH0);
|
||||
#else
|
||||
cpcellsd(H, OldH, OldH - OldH0);
|
||||
#endif
|
||||
}
|
||||
|
||||
static inline CELL
|
||||
AdjustAppl(register CELL t0)
|
||||
{
|
||||
register CELL *t = RepAppl(t0);
|
||||
|
||||
if (IsOldGlobalPtr(t))
|
||||
return (AbsAppl(PtoGloAdjust(t)));
|
||||
else if (IsOldDelayPtr(t))
|
||||
return (AbsAppl(PtoDelayAdjust(t)));
|
||||
else if (IsOldTrailPtr(t))
|
||||
return (AbsAppl(CellPtoTRAdjust(t)));
|
||||
else if (IsHeapP(t))
|
||||
return (AbsAppl(CellPtoHeapAdjust(t)));
|
||||
#ifdef DEBUG
|
||||
else {
|
||||
/* strange cell */
|
||||
/* YP_fprintf(YP_stderr,"[ garbage appl %lx found in stacks by stack shifter ]\n", t0);*/
|
||||
}
|
||||
#endif
|
||||
return(t0);
|
||||
}
|
||||
|
||||
static inline CELL
|
||||
AdjustPair(register CELL t0)
|
||||
{
|
||||
register CELL *t = RepPair(t0);
|
||||
|
||||
if (IsOldGlobalPtr(t))
|
||||
return (AbsPair(PtoGloAdjust(t)));
|
||||
if (IsOldDelayPtr(t))
|
||||
return (AbsPair(PtoDelayAdjust(t)));
|
||||
if (IsOldTrailPtr(t))
|
||||
return (AbsPair(CellPtoTRAdjust(t)));
|
||||
else if (IsHeapP(t))
|
||||
return (AbsPair(CellPtoHeapAdjust(t)));
|
||||
#ifdef DEBUG
|
||||
/* YP_fprintf(YP_stderr,"[ garbage pair %lx found in stacks by stack shifter ]\n", t0);*/
|
||||
#endif
|
||||
return(t0);
|
||||
}
|
||||
|
||||
static void
|
||||
AdjustTrail(int adjusting_heap)
|
||||
{
|
||||
register tr_fr_ptr ptt;
|
||||
|
||||
ptt = TR;
|
||||
/* moving the trail is simple */
|
||||
while (ptt != (tr_fr_ptr)TrailBase) {
|
||||
register CELL reg = TrailTerm(ptt-1);
|
||||
|
||||
ptt--;
|
||||
if (IsVarTerm(reg)) {
|
||||
if (IsOldLocalInTR(reg))
|
||||
TrailTerm(ptt) = LocalAdjust(reg);
|
||||
else if (IsOldGlobal(reg))
|
||||
TrailTerm(ptt) = GlobalAdjust(reg);
|
||||
else if (IsOldDelay(reg))
|
||||
TrailTerm(ptt) = DelayAdjust(reg);
|
||||
else if (IsOldTrail(reg))
|
||||
TrailTerm(ptt) = TrailAdjust(reg);
|
||||
else if (IsOldCode(reg)) {
|
||||
CELL *ptr;
|
||||
TrailTerm(ptt) = reg = CodeAdjust(reg);
|
||||
ptr = (CELL *)reg;
|
||||
if (IsApplTerm(*ptr)) {
|
||||
*ptr = AdjustAppl(*ptr);
|
||||
} else if (IsPairTerm(*ptr)) {
|
||||
*ptr = AdjustAppl(*ptr);
|
||||
}
|
||||
#ifdef DEBUG
|
||||
else
|
||||
YP_fprintf(YP_stderr,"[ garbage heap ptr %p to %lx found in trail at %p by stack shifter ]\n", ptr, (unsigned long int)*ptr, ptt);
|
||||
#endif
|
||||
}
|
||||
} else if (IsPairTerm(reg)) {
|
||||
TrailTerm(ptt) = AdjustPair(reg);
|
||||
#ifdef MULTI_ASSIGNMENT_VARIABLES /* does not work with new structures */
|
||||
/* check it whether we are protecting a
|
||||
multi-assignment */
|
||||
} else if (IsApplTerm(reg)) {
|
||||
TrailTerm(ptt) = AdjustAppl(reg);
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
static void
|
||||
AdjustLocal(void)
|
||||
{
|
||||
register CELL reg, *pt;
|
||||
|
||||
/* Adjusting the local */
|
||||
pt = LCL0;
|
||||
while (pt > ASP) {
|
||||
reg = *--pt;
|
||||
if (IsVarTerm(reg)) {
|
||||
if (IsOldLocal(reg))
|
||||
*pt = LocalAdjust(reg);
|
||||
else if (IsOldGlobal(reg))
|
||||
*pt = GlobalAdjust(reg);
|
||||
else if (IsOldDelay(reg))
|
||||
*pt = DelayAdjust(reg);
|
||||
else if (IsOldTrail(reg))
|
||||
*pt = TrailAdjust(reg);
|
||||
else if (IsOldCode(reg))
|
||||
*pt = CodeAdjust(reg);
|
||||
} else if (IsApplTerm(reg)) {
|
||||
*pt = AdjustAppl(reg);
|
||||
} else if (IsPairTerm(reg)) {
|
||||
*pt = AdjustPair(reg);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
static void
|
||||
AdjustGlobal(void)
|
||||
{
|
||||
register CELL *pt;
|
||||
|
||||
/*
|
||||
* to clean the global now that functors are just variables pointing to
|
||||
* the code
|
||||
*/
|
||||
pt = CellPtr(GlobalBase);
|
||||
while (pt < H) {
|
||||
register CELL reg;
|
||||
|
||||
reg = *pt;
|
||||
if (IsVarTerm(reg)) {
|
||||
if (IsOldGlobal(reg))
|
||||
*pt = GlobalAdjust(reg);
|
||||
if (IsOldDelay(reg))
|
||||
*pt = DelayAdjust(reg);
|
||||
else if (IsOldLocal(reg))
|
||||
*pt = LocalAdjust(reg);
|
||||
else if (IsOldCode(reg)) {
|
||||
Functor f;
|
||||
f = (Functor)(*pt = CodeAdjust(reg));
|
||||
if (f <= FunctorDouble && f >= FunctorLongInt) {
|
||||
/* skip bitmaps */
|
||||
switch((CELL)f) {
|
||||
case (CELL)FunctorDouble:
|
||||
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
|
||||
pt += 3;
|
||||
#else
|
||||
pt += 2;
|
||||
#endif
|
||||
break;
|
||||
#if USE_GMP
|
||||
case (CELL)FunctorBigInt:
|
||||
{
|
||||
Int sz = 1+
|
||||
sizeof(MP_INT)+
|
||||
(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
|
||||
pt += sz;
|
||||
}
|
||||
break;
|
||||
#endif
|
||||
case (CELL)FunctorLongInt:
|
||||
default:
|
||||
pt += 2;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
||||
else if (IsOldTrail(reg))
|
||||
*pt = TrailAdjust(reg);
|
||||
#endif
|
||||
} else if (IsApplTerm(reg))
|
||||
*pt = AdjustAppl(reg);
|
||||
else if (IsPairTerm(reg))
|
||||
*pt = AdjustPair(reg);
|
||||
else if (IsAtomTerm(reg))
|
||||
*pt = AtomTermAdjust(reg);
|
||||
pt++;
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* When growing the stack we need to adjust: the local stack cells pointing
|
||||
* to the local; the local stack cells and the X terms pointing to the global
|
||||
* (just once) the trail cells pointing both to the global and to the local
|
||||
*/
|
||||
void
|
||||
AdjustStacksAndTrail(void)
|
||||
{
|
||||
AdjustTrail(TRUE);
|
||||
AdjustLocal();
|
||||
AdjustGlobal();
|
||||
}
|
||||
|
||||
/*
|
||||
* When growing the stack we need to adjust: the local cells pointing to the
|
||||
* local; the trail cells pointing to the local
|
||||
*/
|
||||
static void
|
||||
AdjustGrowStack(void)
|
||||
{
|
||||
AdjustTrail(FALSE);
|
||||
AdjustLocal();
|
||||
}
|
||||
|
||||
void
|
||||
AdjustRegs(int n)
|
||||
{
|
||||
int i;
|
||||
CELL reg;
|
||||
|
||||
for (i = 1; i < n; ++i) {
|
||||
reg = (CELL) XREGS[i];
|
||||
if (IsVarTerm(reg)) {
|
||||
if (IsOldLocal(reg))
|
||||
reg = LocalAdjust(reg);
|
||||
else if (IsOldGlobal(reg))
|
||||
reg = GlobalAdjust(reg);
|
||||
else if (IsOldDelay(reg))
|
||||
reg = DelayAdjust(reg);
|
||||
else if (IsOldTrail(reg))
|
||||
reg = TrailAdjust(reg);
|
||||
else if (IsOldCode(reg))
|
||||
reg = CodeAdjust(reg);
|
||||
} else if (IsApplTerm(reg))
|
||||
reg = AdjustAppl(reg);
|
||||
else if (IsPairTerm(reg))
|
||||
reg = AdjustPair(reg);
|
||||
XREGS[i] = (Term) reg;
|
||||
}
|
||||
}
|
||||
|
||||
/* Used by do_goal() when we're short of heap space */
|
||||
static int
|
||||
local_growheap(long size, int fix_code)
|
||||
{
|
||||
Int start_growth_time, growth_time;
|
||||
int gc_verbose;
|
||||
|
||||
/* adjust to a multiple of 256) */
|
||||
size = AdjustPageSize(size);
|
||||
if (!ExtendWorkSpace(size)) {
|
||||
return(FALSE);
|
||||
}
|
||||
start_growth_time = cputime();
|
||||
gc_verbose = is_gc_verbose();
|
||||
heap_overflows++;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[HO] Heap overflow %d\n", heap_overflows);
|
||||
YP_fprintf(YP_stderr, "[HO] growing the heap %ld bytes\n", size);
|
||||
}
|
||||
ASP -= 256;
|
||||
TrDiff = LDiff = GDiff = DelayDiff = size;
|
||||
XDiff = HDiff = 0;
|
||||
YAPEnterCriticalSection();
|
||||
SetHeapRegs();
|
||||
MoveLocalAndTrail();
|
||||
if (fix_code) {
|
||||
CELL *SaveOldH = OldH;
|
||||
OldH = (CELL *)freep;
|
||||
MoveGlobal();
|
||||
OldH = SaveOldH;
|
||||
} else {
|
||||
MoveGlobal();
|
||||
}
|
||||
AdjustStacksAndTrail();
|
||||
AdjustRegs(MaxTemps);
|
||||
YAPLeaveCriticalSection();
|
||||
ASP += 256;
|
||||
growth_time = cputime()-start_growth_time;
|
||||
total_heap_overflow_time += growth_time;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[HO] took %g sec\n", (double)growth_time/1000);
|
||||
YP_fprintf(YP_stderr, "[HO] Total of %g sec expanding heap \n", (double)total_heap_overflow_time/1000);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/* Used by do_goal() when we're short of heap space */
|
||||
static int
|
||||
local_growglobal(long size)
|
||||
{
|
||||
Int start_growth_time, growth_time;
|
||||
int gc_verbose;
|
||||
|
||||
/* adjust to a multiple of 256) */
|
||||
size = AdjustPageSize(size);
|
||||
if (!ExtendWorkSpace(size)) {
|
||||
return(FALSE);
|
||||
}
|
||||
start_growth_time = cputime();
|
||||
gc_verbose = is_gc_verbose();
|
||||
delay_overflows++;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[DO] Delay overflow %d\n", delay_overflows);
|
||||
YP_fprintf(YP_stderr, "[DO] growing the stacks %ld bytes\n", size);
|
||||
}
|
||||
ASP -= 256;
|
||||
TrDiff = LDiff = GDiff = size;
|
||||
XDiff = HDiff = DelayDiff = 0;
|
||||
YAPEnterCriticalSection();
|
||||
SetHeapRegs();
|
||||
MoveLocalAndTrail();
|
||||
MoveGlobalOnly();
|
||||
AdjustStacksAndTrail();
|
||||
AdjustRegs(MaxTemps);
|
||||
YAPLeaveCriticalSection();
|
||||
ASP += 256;
|
||||
growth_time = cputime()-start_growth_time;
|
||||
total_delay_overflow_time += growth_time;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[DO] took %g sec\n", (double)growth_time/1000);
|
||||
YP_fprintf(YP_stderr, "[DO] Total of %g sec expanding stacks \n", (double)total_delay_overflow_time/1000);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
fix_compiler_instructions(PInstr *cpc)
|
||||
{
|
||||
while (cpc != NULL) {
|
||||
PInstr *ncpc = cpc->nextInst;
|
||||
|
||||
switch(cpc->op) {
|
||||
/* check c_var for functions that point at variables */
|
||||
case get_var_op:
|
||||
case get_val_op:
|
||||
case unify_var_op:
|
||||
case unify_last_var_op:
|
||||
case unify_val_op:
|
||||
case unify_last_val_op:
|
||||
case put_var_op:
|
||||
case put_val_op:
|
||||
case write_var_op:
|
||||
case write_val_op:
|
||||
case f_var_op:
|
||||
case f_val_op:
|
||||
case fetch_args_for_bccall:
|
||||
case bccall_op:
|
||||
case save_pair_op:
|
||||
case save_appl_op:
|
||||
case save_b_op:
|
||||
case comit_b_op:
|
||||
cpc->rnd1 = GlobalAdjust(cpc->rnd1);
|
||||
break;
|
||||
default:
|
||||
/* hopefully nothing to do */
|
||||
break;
|
||||
}
|
||||
if (ncpc != NULL) {
|
||||
ncpc = (PInstr *)GlobalAddrAdjust((ADDR)(cpc->nextInst));
|
||||
cpc->nextInst = ncpc;
|
||||
}
|
||||
cpc = ncpc;
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef TABLING
|
||||
static void
|
||||
fix_tabling_info(void)
|
||||
{
|
||||
/* we must fix the dependency frames and the subgoal frames, as they are
|
||||
pointing back to the global stack. */
|
||||
struct dependency_frame *df;
|
||||
struct subgoal_frame *sg;
|
||||
|
||||
df = LOCAL_top_dep_fr;
|
||||
while (df != NULL) {
|
||||
if (DepFr_backchain_cp(df))
|
||||
DepFr_backchain_cp(df) = ChoicePtrAdjust(DepFr_backchain_cp(df));
|
||||
DepFr_leader_cp(df) = ChoicePtrAdjust(DepFr_leader_cp(df));
|
||||
DepFr_cons_cp(df) = ConsumerChoicePtrAdjust(DepFr_cons_cp(df));
|
||||
df = DepFr_next(df);
|
||||
}
|
||||
sg = LOCAL_top_sg_fr;
|
||||
while (sg != NULL) {
|
||||
SgFr_gen_cp(sg) = GeneratorChoicePtrAdjust(SgFr_gen_cp(sg));
|
||||
sg = SgFr_next(sg);
|
||||
}
|
||||
}
|
||||
#endif /* TABLING */
|
||||
|
||||
int
|
||||
growheap(int fix_code)
|
||||
{
|
||||
unsigned long size = sizeof(CELL) * 16 * 1024L;
|
||||
int shift_factor = (heap_overflows > 8 ? 8 : heap_overflows);
|
||||
unsigned long sz = size << shift_factor;
|
||||
|
||||
#ifdef FIXED_STACKS
|
||||
abort_optyap("noheapleft in function absmi");
|
||||
#endif
|
||||
if (SizeOfOverflow > sz)
|
||||
sz = AdjustPageSize(SizeOfOverflow);
|
||||
while(sz >= sizeof(CELL) * 16 * 1024L && !local_growheap(sz, fix_code)) {
|
||||
size = size/2;
|
||||
sz = size << shift_factor;
|
||||
}
|
||||
/* we must fix an instruction chain */
|
||||
if (fix_code) {
|
||||
PInstr *cpc = CodeStart;
|
||||
if (cpc != NULL) {
|
||||
CodeStart = cpc = (PInstr *)GlobalAddrAdjust((ADDR)cpc);
|
||||
}
|
||||
fix_compiler_instructions(cpc);
|
||||
cpc = BlobsStart;
|
||||
if (cpc != NULL) {
|
||||
BlobsStart = cpc = (PInstr *)GlobalAddrAdjust((ADDR)cpc);
|
||||
}
|
||||
fix_compiler_instructions(cpc);
|
||||
}
|
||||
#ifdef TABLING
|
||||
fix_tabling_info();
|
||||
#endif
|
||||
return(sz >= sizeof(CELL) * 16 * 1024L);
|
||||
}
|
||||
|
||||
int
|
||||
growglobal(void)
|
||||
{
|
||||
unsigned long sz = sizeof(CELL) * 16 * 1024L;
|
||||
|
||||
#ifdef FIXED_STACKS
|
||||
abort_optyap("noheapleft in function absmi");
|
||||
#endif
|
||||
if (!local_growglobal(sz))
|
||||
return(FALSE);
|
||||
#ifdef TABLING
|
||||
fix_tabling_info();
|
||||
#endif
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
/* Used by do_goal() when we're short of stack space */
|
||||
int
|
||||
growstack(long size)
|
||||
{
|
||||
Int start_growth_time, growth_time;
|
||||
int gc_verbose;
|
||||
|
||||
#ifdef FIXED_STACKS
|
||||
abort_optyap("nostackleft in function absmi");
|
||||
#endif
|
||||
/* adjust to a multiple of 256) */
|
||||
size = AdjustPageSize(size);
|
||||
if (!ExtendWorkSpace(size)) {
|
||||
return(FALSE);
|
||||
}
|
||||
start_growth_time = cputime();
|
||||
gc_verbose = is_gc_verbose();
|
||||
stack_overflows++;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[SO] Stack overflow %d\n", stack_overflows);
|
||||
YP_fprintf(YP_stderr, "[SO] Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)GlobalBase),GlobalBase,H);
|
||||
YP_fprintf(YP_stderr, "[SO] Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
|
||||
YP_fprintf(YP_stderr, "[SO] Trail:%8ld cells (%p-%p)\n",
|
||||
(unsigned long int)(TR-(tr_fr_ptr)TrailBase),TrailBase,TR);
|
||||
YP_fprintf(YP_stderr, "[SO] growing the stacks %ld bytes\n", size);
|
||||
}
|
||||
TrDiff = LDiff = size;
|
||||
XDiff = HDiff = GDiff = DelayDiff = 0;
|
||||
ASP -= 256;
|
||||
YAPEnterCriticalSection();
|
||||
SetStackRegs();
|
||||
MoveLocalAndTrail();
|
||||
AdjustGrowStack();
|
||||
AdjustRegs(MaxTemps);
|
||||
#ifdef TABLING
|
||||
fix_tabling_info();
|
||||
#endif
|
||||
YAPLeaveCriticalSection();
|
||||
CreepFlag = MinStackGap*(stack_overflows+1);
|
||||
ASP += 256;
|
||||
growth_time = cputime()-start_growth_time;
|
||||
total_stack_overflow_time += growth_time;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[SO] took %g sec\n", (double)growth_time/1000);
|
||||
YP_fprintf(YP_stderr, "[SO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static void
|
||||
AdjustVarTable(VarEntry *ves)
|
||||
{
|
||||
ves->VarAdr = TermNil;
|
||||
if (ves->VarRight != NULL) {
|
||||
ves->VarRight = (VarEntry *)TrailAddrAdjust((ADDR)(ves->VarRight));
|
||||
AdjustVarTable(ves->VarRight);
|
||||
}
|
||||
if (ves->VarLeft != NULL) {
|
||||
ves->VarLeft = (VarEntry *)TrailAddrAdjust((ADDR)(ves->VarLeft));
|
||||
AdjustVarTable(ves->VarLeft);
|
||||
}
|
||||
}
|
||||
|
||||
/*
|
||||
If we have to shift while we are scanning we need to adjust all
|
||||
pointers created by the scanner (Tokens and Variables)
|
||||
*/
|
||||
static void
|
||||
AdjustScannerStacks(TokEntry **tksp, VarEntry **vep)
|
||||
{
|
||||
TokEntry *tks = *tksp;
|
||||
VarEntry *ves = *vep;
|
||||
|
||||
if (tks != NULL) {
|
||||
tks = *tksp = (TokEntry *)TrailAddrAdjust((ADDR)tks);
|
||||
}
|
||||
while (tks != NULL) {
|
||||
TokEntry *tktmp;
|
||||
|
||||
switch (tks->Tok) {
|
||||
case Var_tok:
|
||||
case String_tok:
|
||||
tks->TokInfo = TrailAdjust(tks->TokInfo);
|
||||
break;
|
||||
case Name_tok:
|
||||
tks->TokInfo = (Term)AtomAdjust((Atom)(tks->TokInfo));
|
||||
break;
|
||||
default:
|
||||
break;
|
||||
}
|
||||
tktmp = tks->TokNext;
|
||||
if (tktmp != NULL) {
|
||||
tktmp = (TokEntry *)TrailAddrAdjust((ADDR)tktmp);
|
||||
tks->TokNext = tktmp;
|
||||
}
|
||||
tks = tktmp;
|
||||
}
|
||||
if (ves != NULL) {
|
||||
ves = *vep = (VarEntry *)TrailAddrAdjust((ADDR)ves);
|
||||
AdjustVarTable(ves);
|
||||
}
|
||||
ves = AnonVarTable;
|
||||
if (ves != NULL) {
|
||||
ves = AnonVarTable = (VarEntry *)TrailAddrAdjust((ADDR)ves);
|
||||
}
|
||||
while (ves != NULL) {
|
||||
VarEntry *vetmp = ves->VarLeft;
|
||||
if (vetmp != NULL) {
|
||||
vetmp = (VarEntry *)TrailAddrAdjust((ADDR)vetmp);
|
||||
ves->VarLeft = vetmp;
|
||||
}
|
||||
ves->VarAdr = TermNil;
|
||||
ves = vetmp;
|
||||
}
|
||||
}
|
||||
|
||||
/* Used by parser when we're short of stack space */
|
||||
int
|
||||
growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep)
|
||||
{
|
||||
Int start_growth_time, growth_time;
|
||||
int gc_verbose;
|
||||
long size = sizeof(CELL)*(LCL0-(CELL *)GlobalBase);
|
||||
|
||||
#ifdef FIXED_STACKS
|
||||
abort_optyap("nostackleft in parser");
|
||||
#endif
|
||||
/* adjust to a multiple of 256) */
|
||||
size = AdjustPageSize(size);
|
||||
if (!ExtendWorkSpace(size)) {
|
||||
return(FALSE);
|
||||
}
|
||||
start_growth_time = cputime();
|
||||
gc_verbose = is_gc_verbose();
|
||||
stack_overflows++;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[SO] Stack overflow %d\n", stack_overflows);
|
||||
YP_fprintf(YP_stderr, "[SO] Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)GlobalBase),(CELL *)GlobalBase,H);
|
||||
YP_fprintf(YP_stderr, "[SO] Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
|
||||
YP_fprintf(YP_stderr, "[SO] Trail:%8ld cells (%p-%p)\n",
|
||||
(unsigned long int)(TR-(tr_fr_ptr)TrailBase),TrailBase,TR);
|
||||
YP_fprintf(YP_stderr, "[SO] growing the stacks %ld bytes\n", size);
|
||||
}
|
||||
TrDiff = LDiff = size;
|
||||
XDiff = HDiff = GDiff = DelayDiff = 0;
|
||||
ASP -= 256;
|
||||
YAPEnterCriticalSection();
|
||||
SetStackRegs();
|
||||
MoveLocalAndTrail();
|
||||
AdjustScannerStacks(tksp, vep);
|
||||
{
|
||||
tr_fr_ptr nTR = TR;
|
||||
*old_trp = TR = PtoTRAdjust(*old_trp);
|
||||
AdjustGrowStack();
|
||||
TR = nTR;
|
||||
}
|
||||
AdjustRegs(MaxTemps);
|
||||
YAPLeaveCriticalSection();
|
||||
CreepFlag = MinStackGap*(stack_overflows+1);
|
||||
ASP += 256;
|
||||
growth_time = cputime()-start_growth_time;
|
||||
total_stack_overflow_time += growth_time;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[SO] took %g sec\n", (double)growth_time/1000);
|
||||
YP_fprintf(YP_stderr, "[SO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
/* Used by do_goal() when we're short of stack space */
|
||||
int
|
||||
growtrail(long size)
|
||||
{
|
||||
Int start_growth_time = cputime(), growth_time;
|
||||
int gc_verbose = is_gc_verbose();
|
||||
|
||||
#ifdef FIXED_STACKS
|
||||
abort_optyap("notrailleft in function absmi");
|
||||
#endif
|
||||
/* adjust to a multiple of 256) */
|
||||
size = AdjustPageSize(size);
|
||||
trail_overflows++;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[TO] Trail overflow %d\n", trail_overflows);
|
||||
YP_fprintf(YP_stderr, "[TO] growing the trail %ld bytes\n", size);
|
||||
}
|
||||
if (!ExtendWorkSpace(size)) {
|
||||
return(FALSE);
|
||||
}
|
||||
YAPEnterCriticalSection();
|
||||
TrailTop += size;
|
||||
YAPLeaveCriticalSection();
|
||||
growth_time = cputime()-start_growth_time;
|
||||
total_trail_overflow_time += growth_time;
|
||||
if (gc_verbose) {
|
||||
YP_fprintf(YP_stderr, "[TO] took %g sec\n", (double)growth_time/1000);
|
||||
YP_fprintf(YP_stderr, "[TO] Total of %g sec expanding stacks \n", (double)total_stack_overflow_time/1000);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
static Int
|
||||
p_inform_trail_overflows(void)
|
||||
{
|
||||
Term tn = MkIntTerm(trail_overflows);
|
||||
Term tt = MkIntegerTerm(total_trail_overflow_time);
|
||||
|
||||
return(unify(tn, ARG1) && unify(tt, ARG2));
|
||||
}
|
||||
|
||||
/* :- grow_heap(Size) */
|
||||
static Int
|
||||
p_growheap(void)
|
||||
{
|
||||
Int diff;
|
||||
Term t1 = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t1)) {
|
||||
Error(INSTANTIATION_ERROR, t1, "grow_heap/1");
|
||||
return(FALSE);
|
||||
} else if (!IsIntTerm(t1)) {
|
||||
Error(TYPE_ERROR_INTEGER, t1, "grow_heap/1");
|
||||
return(FALSE);
|
||||
}
|
||||
diff = IntOfTerm(t1);
|
||||
if (diff < 0) {
|
||||
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t1, "grow_heap/1");
|
||||
}
|
||||
return(local_growheap(diff, FALSE));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_inform_heap_overflows(void)
|
||||
{
|
||||
Term tn = MkIntTerm(heap_overflows);
|
||||
Term tt = MkIntegerTerm(total_heap_overflow_time);
|
||||
|
||||
return(unify(tn, ARG1) && unify(tt, ARG2));
|
||||
}
|
||||
|
||||
/* :- grow_stack(Size) */
|
||||
static Int
|
||||
p_growstack(void)
|
||||
{
|
||||
Int diff;
|
||||
Term t1 = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t1)) {
|
||||
Error(INSTANTIATION_ERROR, t1, "grow_stack/1");
|
||||
return(FALSE);
|
||||
} else if (!IsIntTerm(t1)) {
|
||||
Error(TYPE_ERROR_INTEGER, t1, "grow_stack/1");
|
||||
return(FALSE);
|
||||
}
|
||||
diff = IntOfTerm(t1);
|
||||
if (diff < 0) {
|
||||
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, t1, "grow_stack/1");
|
||||
}
|
||||
return(growstack(diff));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_inform_stack_overflows(void)
|
||||
{
|
||||
Term tn = MkIntTerm(stack_overflows);
|
||||
Term tt = MkIntegerTerm(total_stack_overflow_time);
|
||||
|
||||
return(unify(tn, ARG1) && unify(tt, ARG2));
|
||||
|
||||
}
|
||||
|
||||
Int total_stack_shift_time(void)
|
||||
{
|
||||
return(total_heap_overflow_time+
|
||||
total_stack_overflow_time+
|
||||
total_trail_overflow_time);
|
||||
}
|
||||
|
||||
void
|
||||
InitGrowPreds(void)
|
||||
{
|
||||
InitCPred("$grow_heap", 1, p_growheap, SafePredFlag);
|
||||
InitCPred("$grow_stack", 1, p_growstack, SafePredFlag);
|
||||
InitCPred("$inform_trail_overflows", 2, p_inform_trail_overflows, SafePredFlag);
|
||||
InitCPred("$inform_heap_overflows", 2, p_inform_heap_overflows, SafePredFlag);
|
||||
InitCPred("$inform_stack_overflows", 2, p_inform_stack_overflows, SafePredFlag);
|
||||
init_gc();
|
||||
}
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,81 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_dl.c *
|
||||
* comments: dl based dynamic loaderr of external routines *
|
||||
* tested on i486-linuxelf *
|
||||
*************************************************************************/
|
||||
|
||||
#ifdef _AIX
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "yapio.h"
|
||||
#include "Foreign.h"
|
||||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
|
||||
/*
|
||||
* FindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
/* not really needed for dl version */
|
||||
strcpy(YapExecutable,"./yap");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
Int
|
||||
LoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
|
||||
extern char *sys_errlist[ ];
|
||||
|
||||
/* load wants to follow the LIBRARY_PATH */
|
||||
if (ofiles->next != NULL || libs != NULL) {
|
||||
strcpy(LoadMsg," Load Failed: in AIX you must load a single object file");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if (!TrueFileName(ofiles->s, FileNameBuf, TRUE)) {
|
||||
strcpy(LoadMsg, " Trying to open unexisting file in LoadForeign ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* In AIX, just call load and everything will go in */
|
||||
if ((*init_proc=((YapInitProc *)load(FileNameBuf,0,NULL))) == NULL) {
|
||||
strcpy(LoadMsg,sys_errlist[errno]);
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
#endif /* _AIX */
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,259 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_aout.c *
|
||||
* comments: aout based dynamic loader of external routines *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "yapio.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#ifdef A_OUT
|
||||
|
||||
#include <stdio.h>
|
||||
#if STDC_HEADERS
|
||||
#include <stdlib.h>
|
||||
#endif
|
||||
#if HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
#if HAVE_FCNTL_H
|
||||
#include <fcntl.h>
|
||||
#endif
|
||||
#if HAVE_SYS_TYPES_H
|
||||
#include <sys/types.h>
|
||||
#endif
|
||||
#if HAVE_SYS_FILE_H
|
||||
#include <sys/file.h>
|
||||
#endif
|
||||
#if HAVE_SYS_PARAM_H
|
||||
#include <sys/param.h>
|
||||
#endif
|
||||
#if HAVE_SYS_STAT_H
|
||||
#include <sys/stat.h>
|
||||
#endif
|
||||
#include <a.out.h>
|
||||
|
||||
#define oktox(n) \
|
||||
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
|
||||
#define oktow(n) \
|
||||
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
register char *cp, *cp2;
|
||||
struct stat stbuf;
|
||||
|
||||
|
||||
cp = (char *)getenv("PATH");
|
||||
if (cp == NULL)
|
||||
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
|
||||
if (*yap_args[0] == '/') {
|
||||
if (oktox(yap_args[0])) {
|
||||
strcpy(FileNameBuf, yap_args[0]);
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
return;
|
||||
}
|
||||
}
|
||||
if (*cp == ':')
|
||||
cp++;
|
||||
for (; *cp;) {
|
||||
/*
|
||||
* copy over current directory and then append
|
||||
* argv[0]
|
||||
*/
|
||||
|
||||
for (cp2 = FileNameBuf; (*cp) != 0 && (*cp) != ':';)
|
||||
*cp2++ = *cp++;
|
||||
*cp2++ = '/';
|
||||
strcpy(cp2, yap_args[0]);
|
||||
if (*cp)
|
||||
cp++;
|
||||
if (!oktox(FileNameBuf))
|
||||
continue;
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
return;
|
||||
}
|
||||
/* one last try for dual systems */
|
||||
strcpy(FileNameBuf, yap_args[0]);
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
if (oktox(YapExecutable))
|
||||
return;
|
||||
else
|
||||
Error(SYSTEM_ERROR,MkAtomTerm(LookupAtom(YapExecutable)),
|
||||
"cannot find file being executed");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
int
|
||||
LoadForeign(StringList ofiles,
|
||||
StringList libs,
|
||||
char *proc_name,
|
||||
YapInitProc *init_proc)
|
||||
{
|
||||
char command[2*MAXPATHLEN];
|
||||
char o_files[1024]; /* list of objects we want to load
|
||||
*/
|
||||
char l_files[1024]; /* list of libraries we want to
|
||||
load */
|
||||
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
|
||||
mktemp */
|
||||
char *tfile; /* name of temporary file */
|
||||
int fildes; /* temp file descriptor */
|
||||
struct exec header; /* header for loaded file */
|
||||
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
|
||||
char *FCodeBase; /* where we load foreign code */
|
||||
|
||||
/*
|
||||
* put in a string the names of the files you want to load and of any
|
||||
* libraries you want to use
|
||||
*/
|
||||
/* files first */
|
||||
*o_files = '\0';
|
||||
{
|
||||
StringList tmp = ofiles;
|
||||
|
||||
while(tmp != NULL) {
|
||||
strcat(o_files," ");
|
||||
strcat(o_files,tmp->s);
|
||||
tmp = tmp->next;
|
||||
}
|
||||
}
|
||||
/* same_trick for libraries */
|
||||
*l_files = '\0';
|
||||
{
|
||||
StringList tmp = libs;
|
||||
|
||||
while(tmp != NULL) {
|
||||
strcat(l_files," ");
|
||||
strcat(l_files,tmp->s);
|
||||
tmp = tmp->next;
|
||||
}
|
||||
}
|
||||
/* next, create a temp file to serve as loader output */
|
||||
tfile = mktemp(tmp_buff);
|
||||
|
||||
/* prepare the magic */
|
||||
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
|
||||
strlen(YapExecutable) > 2*MAXPATHLEN) {
|
||||
strcpy(LoadMsg, " too many parameters in load_foreign/3 ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
sprintf(command, "/usr/bin/ld -N -A %s -o %s -u _%s %s %s -lc",
|
||||
YapExecutable,
|
||||
tfile, proc_name, o_files, l_files);
|
||||
/* now, do the magic */
|
||||
if (system(command) != 0) {
|
||||
unlink(tfile);
|
||||
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* now check the music has played */
|
||||
if ((fildes = open(tfile, O_RDONLY)) < 0) {
|
||||
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* it did, get the mice */
|
||||
/* first, get the header */
|
||||
read(fildes, (char *) &header, sizeof(header));
|
||||
close(fildes);
|
||||
/* get the full size of what we need to load */
|
||||
loadImageSize = header.a_text + header.a_data + header.a_bss;
|
||||
/* add 16 just to play it safe */
|
||||
loadImageSize += 16;
|
||||
/* keep this copy */
|
||||
firstloadImSz = loadImageSize;
|
||||
/* now fetch the space we need */
|
||||
if (!(FCodeBase = AllocCodeSpace((int) loadImageSize))) {
|
||||
strcpy(LoadMsg," unable to allocate space for external code ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* now, a new incantation to load the new foreign code */
|
||||
sprintf(command, "/usr/bin/ld -N -A %s -T %lx -o %s -u _%s %s %s -lc",
|
||||
YapExecutable,
|
||||
(unsigned long) FCodeBase,
|
||||
tfile, proc_name, o_files, l_files);
|
||||
/* and do it */
|
||||
if (system(command) != 0) {
|
||||
unlink(tfile);
|
||||
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if ((fildes = open(tfile, O_RDONLY)) < 0) {
|
||||
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
read(fildes, (char *) &header, sizeof(header));
|
||||
loadImageSize = header.a_text + header.a_data + header.a_bss;
|
||||
if (firstloadImSz < loadImageSize) {
|
||||
strcpy(LoadMsg," miscalculation in load_foreign/3 ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* now search for our init function */
|
||||
{
|
||||
char entry_fun[256];
|
||||
struct nlist func_info[2];
|
||||
sprintf(entry_fun, "_%s", proc_name);
|
||||
func_info[0].n_un.n_name = entry_fun;
|
||||
func_info[1].n_un.n_name = NULL;
|
||||
if (nlist(tfile, func_info) == -1) {
|
||||
strcpy(LoadMsg," in nlist(3) ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if (func_info[0].n_type == 0) {
|
||||
strcpy(LoadMsg," in nlist(3) ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
*init_proc = (YapInitProc)(func_info[0].n_value);
|
||||
}
|
||||
/* ok, we got our init point */
|
||||
/* now read our text */
|
||||
lseek(fildes, (long)(N_TXTOFF(header)), 0);
|
||||
{
|
||||
unsigned int u1 = header.a_text + header.a_data;
|
||||
read(fildes, (char *) FCodeBase, u1);
|
||||
/* zero the BSS segment */
|
||||
while (u1 < loadImageSize)
|
||||
FCodeBase[u1++] = 0;
|
||||
}
|
||||
close(fildes);
|
||||
unlink(tfile);
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,309 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_coff.c *
|
||||
* comments: coff based dynamic loader of external routines *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#ifdef COFF
|
||||
|
||||
#include <stdio.h>
|
||||
#include <fcntl.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/file.h>
|
||||
#include <sys/param.h>
|
||||
#include <sys/stat.h>
|
||||
#include <a.out.h>
|
||||
|
||||
#define oktox(n) \
|
||||
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFREG&&0==access(n,X_OK))
|
||||
#define oktow(n) \
|
||||
(0==stat(n,&stbuf)&&(stbuf.st_mode&S_IFMT)==S_IFDIR&&0==access(n,W_OK))
|
||||
|
||||
#ifdef mips
|
||||
#define MAXSECTIONS 100
|
||||
#else
|
||||
#define MAXSECTIONS 20
|
||||
#endif /* mips */
|
||||
|
||||
#ifdef sgi
|
||||
#include <symbol.h>
|
||||
#endif /* sgi */
|
||||
|
||||
#define N_TXTOFF(x) (sizeof(struct filehdr)+(x).f_opthdr+(x).f_nscns*sizeof(struct scnhdr))
|
||||
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
register char *cp, *cp2;
|
||||
struct stat stbuf;
|
||||
|
||||
|
||||
cp = (char *)getenv("PATH");
|
||||
if (cp == NULL)
|
||||
cp = ".:/usr/ucb:/bin:/usr/bin:/usr/local/bin";
|
||||
if (*yap_args[0] == '/') {
|
||||
if (oktox(yap_args[0])) {
|
||||
strcpy(FileNameBuf, yap_args[0]);
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
return;
|
||||
}
|
||||
}
|
||||
if (*cp == ':')
|
||||
cp++;
|
||||
for (; *cp;) {
|
||||
/*
|
||||
* copy over current directory and then append
|
||||
* argv[0]
|
||||
*/
|
||||
|
||||
for (cp2 = FileNameBuf; (*cp) != 0 && (*cp) != ':';)
|
||||
*cp2++ = *cp++;
|
||||
*cp2++ = '/';
|
||||
strcpy(cp2, yap_args[0]);
|
||||
if (*cp)
|
||||
cp++;
|
||||
if (!oktox(FileNameBuf))
|
||||
continue;
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
return;
|
||||
}
|
||||
/* one last try for dual systems */
|
||||
strcpy(FileNameBuf, yap_args[0]);
|
||||
TrueFileName(FileNameBuf, YapExecutable, TRUE);
|
||||
if (oktox(YapExecutable))
|
||||
return;
|
||||
else
|
||||
Error(SYSTEM_ERROR,MkAtomTerm(LookupAtom(YapExecutable)),
|
||||
"cannot find file being executed");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
int
|
||||
LoadForeign(StringList ofiles,
|
||||
StringList libs,
|
||||
char *proc_name,
|
||||
YapInitProc *init_proc)
|
||||
{
|
||||
char command[2*MAXPATHLEN];
|
||||
char o_files[1024]; /* list of objects we want to load
|
||||
*/
|
||||
char l_files[1024]; /* list of libraries we want to
|
||||
load */
|
||||
char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for
|
||||
mktemp */
|
||||
char *tfile; /* name of temporary file */
|
||||
int fildes; /* temp file descriptor */
|
||||
struct aouthdr sysHeader;
|
||||
struct filehdr fileHeader;
|
||||
struct scnhdr sectionHeader[MAXSECTIONS];
|
||||
struct exec header; /* header for loaded file */
|
||||
unsigned long loadImageSize, firstloadImSz; /* size of image we will load */
|
||||
char *FCodeBase; /* where we load foreign code */
|
||||
|
||||
/*
|
||||
* put in a string the names of the files you want to load and of any
|
||||
* libraries you want to use
|
||||
*/
|
||||
/* files first */
|
||||
*o_files = '\0';
|
||||
{
|
||||
StringList tmp = ofiles;
|
||||
|
||||
while(tmp != NULL) {
|
||||
strcat(o_files," ");
|
||||
strcat(o_files,tmp->s);
|
||||
tmp = tmp->next;
|
||||
}
|
||||
}
|
||||
/* same_trick for libraries */
|
||||
*l_files = '\0';
|
||||
{
|
||||
StringList tmp = libs;
|
||||
|
||||
while(tmp != NULL) {
|
||||
strcat(l_files," ");
|
||||
strcat(l_files,tmp->s);
|
||||
tmp = tmp->next;
|
||||
}
|
||||
}
|
||||
/* next, create a temp file to serve as loader output */
|
||||
tfile = mktemp(tmp_buff);
|
||||
|
||||
/* prepare the magic */
|
||||
if (strlen(o_files) + strlen(l_files) + strlen(proc_name) +
|
||||
strlen(YapExecutable) > 2*MAXPATHLEN) {
|
||||
strcpy(LoadMsg, " too many parameters in load_foreign/3 ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
sprintf(command, "/usr/bin/ld -N -A %s -o %s %s %s -lc",
|
||||
YapExecutable,
|
||||
tfile, o_files, l_files);
|
||||
/* now, do the magic */
|
||||
if (system(command) != 0) {
|
||||
unlink(tfile);
|
||||
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* now check the music has played */
|
||||
if ((fildes = open(tfile, O_RDONLY)) < 0) {
|
||||
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* it did, get the mice */
|
||||
/* first, get the header */
|
||||
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
|
||||
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
|
||||
{ int i;
|
||||
for (i = 0; i < fileHeader.f_nscns; i++)
|
||||
read(fildes, (char *) §ionHeader[i],
|
||||
sizeof(*sectionHeader));
|
||||
}
|
||||
close(fildes);
|
||||
/* get the full size of what we need to load */
|
||||
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
|
||||
#ifdef mips
|
||||
/* add an extra page in mips machines */
|
||||
loadImageSize += 4095 + 16;
|
||||
#else
|
||||
/* add 16 just to play it safe */
|
||||
loadImageSize += 16;
|
||||
#endif
|
||||
/* keep this copy */
|
||||
firstloadImSz = loadImageSize;
|
||||
/* now fetch the space we need */
|
||||
if (!(FCodeBase = AllocCodeSpace((int) loadImageSize))
|
||||
#ifdef pyr
|
||||
|| activate_code(ForeignCodeBase, u1)
|
||||
#endif /* pyr */
|
||||
) {
|
||||
strcpy(LoadMsg," unable to allocate space for external code ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
#ifdef mips
|
||||
FCodeBase = (char *) (Unsigned(FCodeBase + PAGESIZE - 1) & ~(PAGESIZE - 1));
|
||||
#endif
|
||||
|
||||
/* now, a new incantation to load the new foreign code */
|
||||
#ifdef convex
|
||||
/* No -N flag in the Convex loader */
|
||||
/* -T option does not want MallocBase bit set */
|
||||
sprintf(command, "ld -x -A %s -T %lx -o %s -u %s %s %s -lc",
|
||||
ostabf,
|
||||
((unsigned long) (((unsigned long) (ForeignCodeBase)) &
|
||||
((unsigned long) (~HeapBase))
|
||||
)
|
||||
), tfile, entry_point, o_files, l_files);
|
||||
#else
|
||||
#ifdef mips
|
||||
sprintf(command, "ld -systype bsd43 -N -A %s -T %lx -o %s -u %s %s %s -lc",
|
||||
ostabf,
|
||||
(unsigned long) ForeignCodeBase,
|
||||
tfile, entry_point, o_files, l_files);
|
||||
#else
|
||||
sprintf(command, "ld -N -A %s -T %lx -o %s -e %s -u _%s %s -lc",
|
||||
ostabf,
|
||||
(unsigned long) ForeignCodeBase,
|
||||
tfile, entry_point, o_files, l_files);
|
||||
#endif /* mips */
|
||||
#endif /* convex */
|
||||
/* and do it */
|
||||
if (system(command) != 0) {
|
||||
unlink(tfile);
|
||||
strcpy(LoadMsg," ld returned error status in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if ((fildes = open(tfile, O_RDONLY)) < 0) {
|
||||
strcpy(LoadMsg," unable to open temp file in load_foreign_files ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
read(fildes, (char *) &fileHeader, sizeof(fileHeader));
|
||||
read(fildes, (char *) &sysHeader, sizeof(sysHeader));
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < fileHeader.f_nscns; i++)
|
||||
read(fildes, (char *) §ionHeader[i], sizeof(*sectionHeader));
|
||||
}
|
||||
loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize;
|
||||
if (firstloadImSz < loadImageSize) {
|
||||
strcpy(LoadMsg," miscalculation in load_foreign/3 ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
/* now search for our init function */
|
||||
{
|
||||
char entry_fun[256];
|
||||
struct nlist func_info[2];
|
||||
#if defined(mips) || defined(I386)
|
||||
char NAME1[128], NAME2[128];
|
||||
func_info[0].n_name = NAME1;
|
||||
func_info[1].n_name = NAME2;
|
||||
#endif /* COFF */
|
||||
sprintf(entry_fun, "_%s", proc_name);
|
||||
func_info[0].n_name = entry_fun;
|
||||
func_info[1].n_name = NULL;
|
||||
if (nlist(tfile, func_info) == -1) {
|
||||
strcpy(LoadMsg," in nlist(3) ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if (func_info[0].n_type == 0) {
|
||||
strcpy(LoadMsg," in nlist(3) ");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
*init_proc = (YapInitProc)(func_info[0].n_value);
|
||||
}
|
||||
/* ok, we got our init point */
|
||||
/* now read our text */
|
||||
lseek(fildes, (long)(N_TXTOFF(header)), 0);
|
||||
{
|
||||
unsigned int u1 = header.a_text + header.a_data;
|
||||
read(fildes, (char *) FCodeBase, u1);
|
||||
/* zero the BSS segment */
|
||||
while (u1 < loadImageSize)
|
||||
FCodeBase[u1++] = 0;
|
||||
}
|
||||
close(fildes);
|
||||
unlink(tfile);
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,159 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_dl.c *
|
||||
* comments: dl based dynamic loaderr of external routines *
|
||||
* tested on i486-linuxelf *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#if LOAD_DL
|
||||
|
||||
#include <dlfcn.h>
|
||||
#include <string.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
/* not really needed for dl version */
|
||||
strcpy(YapExecutable,"yap");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
Int
|
||||
LoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
|
||||
while (ofiles) {
|
||||
void *handle;
|
||||
|
||||
/* dlopen wants to follow the LD_CONFIG_PATH */
|
||||
if (!TrueFileName(ofiles->s, FileNameBuf, TRUE)) {
|
||||
strcpy(LoadMsg, "[ Trying to open unexisting file in LoadForeign ]");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
#ifdef __osf__
|
||||
if((handle=dlopen(FileNameBuf,RTLD_LAZY)) == 0)
|
||||
#else
|
||||
if((handle=dlopen(FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == 0)
|
||||
#endif
|
||||
{
|
||||
fprintf(stderr,"calling dlopen with error %s\n", dlerror());
|
||||
/* strcpy(LoadMsg,dlerror());*/
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
ofiles->handle = handle;
|
||||
|
||||
if (!*init_proc)
|
||||
*init_proc = (YapInitProc) dlsym(handle,proc_name);
|
||||
|
||||
ofiles = ofiles->next;
|
||||
}
|
||||
|
||||
if(! *init_proc) {
|
||||
strcpy(LoadMsg,"Could not locate initialization routine");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
/* load libraries first so that their symbols are available to
|
||||
other routines */
|
||||
while (libs) {
|
||||
|
||||
if (libs->s[0] == '-') {
|
||||
strcpy(FileNameBuf,"lib");
|
||||
strcat(FileNameBuf,libs->s+2);
|
||||
strcat(FileNameBuf,".so");
|
||||
} else {
|
||||
strcpy(FileNameBuf,libs->s);
|
||||
}
|
||||
|
||||
#ifdef __osf__
|
||||
if((libs->handle=dlopen(FileNameBuf,RTLD_LAZY)) == NULL)
|
||||
#else
|
||||
if((libs->handle=dlopen(FileNameBuf,RTLD_LAZY|RTLD_GLOBAL)) == NULL)
|
||||
#endif
|
||||
{
|
||||
strcpy(LoadMsg,dlerror());
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
libs = libs->next;
|
||||
}
|
||||
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
ForeignObj *f_code;
|
||||
|
||||
f_code = ForeignCodeLoaded;
|
||||
while (f_code != NULL) {
|
||||
StringList objs, libs;
|
||||
|
||||
objs = f_code->objs;
|
||||
while (objs != NULL) {
|
||||
if (dlclose(objs->handle) != 0)
|
||||
return; /* ERROR */
|
||||
objs = objs->next;
|
||||
}
|
||||
libs = f_code->libs;
|
||||
while (libs != NULL) {
|
||||
if (dlclose(libs->handle) != 0)
|
||||
return; /* ERROR */
|
||||
objs = libs->next;
|
||||
}
|
||||
f_code = f_code->next;
|
||||
}
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
#if SIMICS
|
||||
|
||||
void dlopen(void)
|
||||
{
|
||||
}
|
||||
|
||||
void dlclose(void)
|
||||
{
|
||||
}
|
||||
|
||||
void dlsym(void)
|
||||
{
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_dld.c *
|
||||
* comments: dld based dynamic loaderr of external routines *
|
||||
* tested on i486-linuxaout *
|
||||
*************************************************************************/
|
||||
|
||||
#if defined(linux) && !defined(__ELF__) && !defined(__LCC__)
|
||||
|
||||
#include "Foreign.h"
|
||||
#include <dld.h>
|
||||
#include <malloc.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
/* use dld_find_executable */
|
||||
char *res;
|
||||
if(name != NULL && (res=dld_find_executable(name))) {
|
||||
strcpy(YapExecutable,res);
|
||||
} else {
|
||||
strcpy(YapExecutable,"./yap");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
int
|
||||
LoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
static int firstTime = 1;
|
||||
int error;
|
||||
|
||||
if(firstTime) {
|
||||
error = dld_init(YapExecutable);
|
||||
if(error) {
|
||||
strcpy(LoadMsg,dld_strerror(error));
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
firstTime=0;
|
||||
}
|
||||
|
||||
while (ofiles) {
|
||||
if((error=dld_link(ofiles->s)) !=0) {
|
||||
strcpy(LoadMsg,dld_strerror(error));
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
ofiles = ofiles->next;
|
||||
}
|
||||
|
||||
|
||||
/* TODO: handle libs */
|
||||
*init_proc = (YapInitProc) dld_get_func(proc_name);
|
||||
if(! *init_proc) {
|
||||
strcpy(LoadMsg,"Could not locate initialization routine");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
if(!dld_function_executable_p(proc_name)) {
|
||||
char **undefs = dld_list_undefined_sym();
|
||||
char **p = undefs;
|
||||
int k = dld_undefined_sym_count;
|
||||
strcpy(LoadMsg,"Could not resolve all symbols");
|
||||
while(k) {
|
||||
YP_printf("[undefined symbol %s]\n",*p++);
|
||||
--k;
|
||||
}
|
||||
free(undefs);
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
#endif
|
|
@ -0,0 +1,104 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_dl.c *
|
||||
* comments: dl based dynamic loader of external routines *
|
||||
* tested on i486-linuxelf *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#if LOAD_DLL
|
||||
|
||||
#include <windows.h>
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
/* not really needed for dl version */
|
||||
strcpy(YapExecutable,"yap");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
Int
|
||||
LoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
|
||||
while (ofiles) {
|
||||
HINSTANCE handle;
|
||||
|
||||
if (TrueFileName(ofiles->s, FileNameBuf, TRUE) &&
|
||||
(handle=LoadLibrary(FileNameBuf)) != 0)
|
||||
{
|
||||
if (*init_proc == NULL)
|
||||
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
|
||||
}
|
||||
ofiles = ofiles->next;
|
||||
}
|
||||
|
||||
/* load libraries first so that their symbols are available to
|
||||
other routines */
|
||||
while (libs) {
|
||||
HINSTANCE handle;
|
||||
|
||||
if (libs->s[0] == '-') {
|
||||
strcat(FileNameBuf,libs->s+2);
|
||||
strcat(FileNameBuf,".dll");
|
||||
} else {
|
||||
strcpy(FileNameBuf,libs->s);
|
||||
}
|
||||
|
||||
if((handle=LoadLibrary(FileNameBuf)) == 0)
|
||||
{
|
||||
/* strcpy(LoadMsg,dlerror());*/
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
if (*init_proc == NULL)
|
||||
*init_proc = (YapInitProc)GetProcAddress((HMODULE)handle, proc_name);
|
||||
|
||||
libs = libs->next;
|
||||
}
|
||||
|
||||
if(*init_proc == NULL) {
|
||||
strcpy(LoadMsg,"Could not locate initialization routine");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_foreign.c *
|
||||
* comments: dynamic loader of external routines *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%.2";
|
||||
#endif
|
||||
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include <stdlib.h>
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
#include "Foreign.h"
|
||||
|
||||
#if _WIN32
|
||||
#ifndef SHLIB_SUFFIX
|
||||
#define SHLIB_SUFFIX "dll"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
char LoadMsg[512];
|
||||
char YapExecutable[YAP_FILENAME_MAX];
|
||||
|
||||
STD_PROTO(Int p_load_foreign, (void));
|
||||
|
||||
Int
|
||||
p_load_foreign(void)
|
||||
{
|
||||
StringList ofiles = NIL;
|
||||
StringList libs = NIL;
|
||||
char *InitProcName;
|
||||
YapInitProc InitProc = NULL;
|
||||
Term t, t1;
|
||||
StringList new;
|
||||
Int returncode = FALSE;
|
||||
|
||||
strcpy(LoadMsg,"Invalid arguments");
|
||||
|
||||
/* collect the list of object files */
|
||||
t = Deref(ARG1);
|
||||
while(1) {
|
||||
if (t == TermNil) break;
|
||||
t1 = HeadOfTerm(t);
|
||||
t = TailOfTerm(t);
|
||||
new = (StringList) AllocCodeSpace(sizeof(StringListItem));
|
||||
new->next = ofiles;
|
||||
new->s = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
||||
ofiles = new;
|
||||
}
|
||||
|
||||
/* collect the list of library files */
|
||||
t = Deref(ARG2);
|
||||
while(1) {
|
||||
if (t == TermNil) break;
|
||||
t1 = HeadOfTerm(t);
|
||||
t = TailOfTerm(t);
|
||||
new = (StringList) AllocCodeSpace(sizeof(StringListItem));
|
||||
new->next = libs;
|
||||
new->s = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
||||
libs = new;
|
||||
}
|
||||
|
||||
/* get the initialization function name */
|
||||
t1 = Deref(ARG3);
|
||||
InitProcName = RepAtom(AtomOfTerm(t1))->StrOfAE;
|
||||
|
||||
|
||||
|
||||
/* call the OS specific function for dynamic loading */
|
||||
if(LoadForeign(ofiles,libs,InitProcName,&InitProc)==LOAD_SUCCEEDED) {
|
||||
(*InitProc)();
|
||||
returncode = TRUE;
|
||||
}
|
||||
|
||||
/* I should recover space if load foreign fails */
|
||||
if (returncode == TRUE) {
|
||||
ForeignObj *f_code = (ForeignObj *)AllocCodeSpace(sizeof(ForeignObj));
|
||||
f_code->objs = ofiles;
|
||||
f_code->libs = libs;
|
||||
f_code->f = InitProcName;
|
||||
f_code->next = ForeignCodeLoaded;
|
||||
f_code->module = CurrentModule;
|
||||
ForeignCodeLoaded = (void *)f_code;
|
||||
}
|
||||
return returncode;
|
||||
}
|
||||
|
||||
static Int
|
||||
p_obj_suffix(void) {
|
||||
return(unify(StringToList(SHLIB_SUFFIX),ARG1));
|
||||
}
|
||||
|
||||
void
|
||||
InitLoadForeign(void)
|
||||
{
|
||||
if (yap_args == NULL)
|
||||
YAPFindExecutable(NULL);
|
||||
else
|
||||
YAPFindExecutable(yap_args[0]);
|
||||
InitCPred("$load_foreign_files", 3, p_load_foreign, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$obj_suffix", 1, p_obj_suffix, SafePredFlag);
|
||||
}
|
||||
|
||||
void
|
||||
ReOpenLoadForeign(void)
|
||||
{
|
||||
ForeignObj *f_code = ForeignCodeLoaded;
|
||||
int OldModule = CurrentModule;
|
||||
YapInitProc InitProc = NULL;
|
||||
|
||||
while (f_code != NULL) {
|
||||
CurrentModule = 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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: load_none.c *
|
||||
* comments: dummy dynamic loaderr of external routines *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#ifdef NO_DYN
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
void
|
||||
YAPFindExecutable(char *name)
|
||||
{
|
||||
/* signal name not found */
|
||||
strcpy(YapExecutable,"./yap");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(file_name,proc_name,init_proc) dynamically loads a foreign
|
||||
* code file and locates an initialization routine
|
||||
*/
|
||||
Int
|
||||
LoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
strcpy(LoadMsg,"load_foreign not supported in this version of Yap");
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
void
|
||||
ShutdownLoadForeign(void)
|
||||
{
|
||||
}
|
||||
|
||||
Int
|
||||
ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
return(LoadForeign(ofiles,libs, proc_name, init_proc));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#include "Foreign.h"
|
||||
|
||||
#if LOAD_SHL
|
||||
|
||||
#include <dl.h>
|
||||
#include <malloc.h>
|
||||
#include <stdio.h>
|
||||
|
||||
/*
|
||||
* YAPFindExecutable(argv[0]) should be called on yap initialization to
|
||||
* locate the executable of Yap
|
||||
*/
|
||||
|
||||
void YAPFindExecutable(char *name)
|
||||
{
|
||||
/* not really needed for shl version */
|
||||
strcpy( YapExecutable, "yap" );
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign
|
||||
* code files and libraries and locates an initialization routine
|
||||
*/
|
||||
|
||||
Int LoadForeign( StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc )
|
||||
{
|
||||
|
||||
/* *init_proc is initialised to NULL in load_foreign.c */
|
||||
int init_missing = -1;
|
||||
|
||||
int n, i;
|
||||
struct shl_symbol *p;
|
||||
|
||||
while( ofiles ) {
|
||||
int valid_fname;
|
||||
|
||||
/* shl_load wants to follow the LD_CONFIG_PATH */
|
||||
valid_fname = TrueFileName( ofiles->s, FileNameBuf, TRUE );
|
||||
|
||||
if( !valid_fname ) {
|
||||
strcpy( LoadMsg, "[ Trying to open non-existing file in LoadForeign ]" );
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
ofiles->handle = malloc( sizeof(shl_t) );
|
||||
*(shl_t *)ofiles->handle = shl_load( FileNameBuf, BIND_DEFERRED, 0 );
|
||||
if( *(shl_t *)ofiles->handle == NULL ) {
|
||||
strerror_r( errno, LoadMsg, 512 );
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
if( init_missing ) {
|
||||
init_missing = shl_findsym( ofiles->handle, proc_name,
|
||||
TYPE_PROCEDURE, init_proc );
|
||||
}
|
||||
|
||||
ofiles = ofiles->next;
|
||||
}
|
||||
|
||||
if( init_missing ) {
|
||||
strcpy( LoadMsg, "Could not locate initialization routine" );
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
while( libs ) {
|
||||
|
||||
if( libs->s[0] == '-' ) {
|
||||
strcpy( FileNameBuf, "lib" );
|
||||
strcat( FileNameBuf, libs->s+2 );
|
||||
strcat( FileNameBuf, ".sl" );
|
||||
}
|
||||
else {
|
||||
strcpy( FileNameBuf, libs->s );
|
||||
}
|
||||
|
||||
*(shl_t *)libs->handle = shl_load( FileNameBuf, BIND_DEFERRED, 0 );
|
||||
if( *(shl_t *)libs->handle == NULL ) {
|
||||
strerror_r( errno, LoadMsg, 512 );
|
||||
return LOAD_FAILLED;
|
||||
}
|
||||
|
||||
libs = libs->next;
|
||||
}
|
||||
|
||||
return LOAD_SUCCEEDED;
|
||||
}
|
||||
|
||||
|
||||
void ShutdownLoadForeign( void )
|
||||
{
|
||||
ForeignObj *f_code;
|
||||
int err;
|
||||
|
||||
f_code = ForeignCodeLoaded;
|
||||
while( f_code != NULL ) {
|
||||
StringList objs, libs;
|
||||
|
||||
objs = f_code->objs;
|
||||
while( objs ) {
|
||||
err = shl_unload( *(shl_t *)objs->handle );
|
||||
if( err ) {
|
||||
/* dunno how to properly report an error here */
|
||||
perror( NULL );
|
||||
return;
|
||||
}
|
||||
free( objs->handle );
|
||||
objs = objs->next;
|
||||
}
|
||||
|
||||
libs = f_code->libs;
|
||||
while( libs ) {
|
||||
err = shl_unload( *(shl_t *)libs->handle );
|
||||
if( err ) {
|
||||
/* dunno how to properly report an error here */
|
||||
perror( NULL );
|
||||
return;
|
||||
}
|
||||
free( libs->handle );
|
||||
libs = libs->next;
|
||||
}
|
||||
f_code = f_code->next;
|
||||
}
|
||||
}
|
||||
|
||||
Int ReLoadForeign(StringList ofiles, StringList libs,
|
||||
char *proc_name, YapInitProc *init_proc)
|
||||
{
|
||||
ShutdownLoadForeign();
|
||||
return( LoadForeign( ofiles, libs, proc_name, init_proc ) );
|
||||
}
|
||||
|
||||
/*
|
||||
dunno what this one is supposed to do, no load_* defines it
|
||||
void STD_PROTO(ReOpenLoadForeign,(void));
|
||||
*/
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,276 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: mavar.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: support from multiple assignment variables in YAP *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
||||
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#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));
|
||||
STD_PROTO(static Int p_is_mutable, (void));
|
||||
|
||||
static Int
|
||||
p_setarg(void)
|
||||
{
|
||||
CELL ti = Deref(ARG1), ts = Deref(ARG2);
|
||||
Int i;
|
||||
if (IsVarTerm(ti)) {
|
||||
Error(INSTANTIATION_ERROR,ti,"setarg/3");
|
||||
return(FALSE);
|
||||
} else {
|
||||
if (IsIntTerm(ti))
|
||||
i = IntOfTerm(ti);
|
||||
else {
|
||||
union arith_ret v;
|
||||
if (Eval(ti, &v) == long_int_e) {
|
||||
i = v.Int;
|
||||
} else {
|
||||
Error(TYPE_ERROR_INTEGER,ti,"setarg/3");
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (IsVarTerm(ts)) {
|
||||
Error(INSTANTIATION_ERROR,ts,"setarg/3");
|
||||
} else if(IsApplTerm(ts)) {
|
||||
CELL *pt;
|
||||
if (IsExtensionFunctor(FunctorOfTerm(ts))) {
|
||||
Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
|
||||
return(FALSE);
|
||||
}
|
||||
if (i < 0 || i > (Int)ArityOfFunctor(FunctorOfTerm(ts))) {
|
||||
if (i<0)
|
||||
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
|
||||
return(FALSE);
|
||||
}
|
||||
pt = RepAppl(ts)+i;
|
||||
/* the evil deed is to be done now */
|
||||
MaBind(pt, Deref(ARG3));
|
||||
} else if(IsPairTerm(ts)) {
|
||||
CELL *pt;
|
||||
if (i != 1 || i != 2) {
|
||||
if (i<0)
|
||||
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
|
||||
return(FALSE);
|
||||
}
|
||||
pt = RepPair(ts)+i-1;
|
||||
/* the evil deed is to be done now */
|
||||
MaBind(pt, Deref(ARG3));
|
||||
} else {
|
||||
Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
|
||||
return(FALSE);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
|
||||
/* One problem with MAVars is that they you always trail on
|
||||
non-determinate bindings. This is not cool if you have a long
|
||||
determinate computation. One alternative could be to use
|
||||
timestamps.
|
||||
|
||||
Because of !, the only timestamp one can trust is the trailpointer
|
||||
(ouch..). The trail is not reclaimed during backtracking. Also, if
|
||||
there was a conditional binding, the trail is sure to have been
|
||||
increased since the last choicepoint. For maximum effect, we can
|
||||
actually store the current value of TR in the timestamp field,
|
||||
giving a way to actually follow a link of all trailings for these
|
||||
variables.
|
||||
|
||||
*/
|
||||
|
||||
/* create and initialise a new timed var. The problem is: how to set
|
||||
the clock?
|
||||
|
||||
If I give it the current value of B->TR, we may have trouble if no
|
||||
non-determinate bindings are made before the next
|
||||
choice-point. Just to make sure this doesn't cause trouble, if (TR
|
||||
== B->TR) we will add a little something ;-).
|
||||
*/
|
||||
|
||||
static void
|
||||
CreateTimedVar(Term val)
|
||||
{
|
||||
timed_var *tv = (timed_var *)H;
|
||||
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));
|
||||
}
|
||||
tv->value = val;
|
||||
H += sizeof(timed_var)/sizeof(CELL);
|
||||
}
|
||||
|
||||
static void
|
||||
CreateEmptyTimedVar(void)
|
||||
{
|
||||
timed_var *tv = (timed_var *)H;
|
||||
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));
|
||||
}
|
||||
RESET_VARIABLE(&(tv->value));
|
||||
H += sizeof(timed_var)/sizeof(CELL);
|
||||
}
|
||||
|
||||
Term NewTimedVar(CELL val)
|
||||
{
|
||||
Term t = AbsAppl(H);
|
||||
*H++ = (CELL)FunctorMutable;
|
||||
CreateTimedVar(val);
|
||||
return(t);
|
||||
}
|
||||
|
||||
Term NewEmptyTimedVar(void)
|
||||
{
|
||||
Term t = AbsAppl(H);
|
||||
*H++ = (CELL)FunctorMutable;
|
||||
CreateEmptyTimedVar();
|
||||
return(t);
|
||||
}
|
||||
|
||||
Term ReadTimedVar(Term inv)
|
||||
{
|
||||
timed_var *tv = (timed_var *)(RepAppl(inv)+1);
|
||||
return(tv->value);
|
||||
}
|
||||
|
||||
|
||||
/* update a timed var with a new value */
|
||||
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));
|
||||
|
||||
if (B->cp_tr <= timestmp
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
&& timestmp <= TR
|
||||
#endif
|
||||
) {
|
||||
/* last assignment more recent than last B */
|
||||
#if SBA
|
||||
if (Unsigned((Int)(tv)-(Int)(H_FZ)) >
|
||||
Unsigned((Int)(B_FZ)-(Int)(H_FZ)))
|
||||
*STACK_TO_SBA(&(tv->value)) = new;
|
||||
else
|
||||
#endif
|
||||
tv->value = new;
|
||||
#if defined(SBA) || defined(TABLING)
|
||||
if (Unsigned((Int)(tv)-(Int)(HBREG)) >
|
||||
Unsigned(BBREG)-(Int)(HBREG))
|
||||
TrailVal(timestmp-1) = new;
|
||||
#endif
|
||||
} else {
|
||||
Term nclock;
|
||||
MaBind(&(tv->value), new);
|
||||
nclock = MkIntegerTerm((Int)((CELL *)TR-(CELL *)TrailBase));
|
||||
MaBind(&(tv->clock), nclock);
|
||||
}
|
||||
return(t);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_create_mutable(void)
|
||||
{
|
||||
Term t = NewTimedVar(Deref(ARG1));
|
||||
return(unify(ARG2,t));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_get_mutable(void)
|
||||
{
|
||||
Term t = Deref(ARG2);
|
||||
if (IsVarTerm(t)) {
|
||||
Error(INSTANTIATION_ERROR, t, "get_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
if (!IsApplTerm(t)) {
|
||||
Error(TYPE_ERROR_COMPOUND,t,"get_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
if (FunctorOfTerm(t) != FunctorMutable) {
|
||||
Error(DOMAIN_ERROR_MUTABLE,t,"get_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
t = ReadTimedVar(t);
|
||||
return(unify(ARG1, t));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_update_mutable(void)
|
||||
{
|
||||
Term t = Deref(ARG2);
|
||||
if (IsVarTerm(t)) {
|
||||
Error(INSTANTIATION_ERROR, t, "update_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
if (!IsApplTerm(t)) {
|
||||
Error(TYPE_ERROR_COMPOUND,t,"update_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
if (FunctorOfTerm(t) != FunctorMutable) {
|
||||
Error(DOMAIN_ERROR_MUTABLE,t,"update_mutable/3");
|
||||
return(FALSE);
|
||||
}
|
||||
UpdateTimedVar(t, Deref(ARG1));
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_is_mutable(void)
|
||||
{
|
||||
Term t = Deref(ARG1);
|
||||
if (IsVarTerm(t)) {
|
||||
return(FALSE);
|
||||
}
|
||||
if (!IsApplTerm(t)) {
|
||||
return(FALSE);
|
||||
}
|
||||
if (FunctorOfTerm(t) != FunctorMutable) {
|
||||
return(FALSE);
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
void
|
||||
InitMaVarCPreds(void)
|
||||
{
|
||||
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
||||
/* The most famous contributions of SICStus to the Prolog language */
|
||||
InitCPred("setarg", 3, p_setarg, SafePredFlag);
|
||||
InitCPred("create_mutable", 2, p_create_mutable, SafePredFlag);
|
||||
InitCPred("get_mutable", 2, p_get_mutable, SafePredFlag);
|
||||
InitCPred("update_mutable", 2, p_update_mutable, SafePredFlag);
|
||||
InitCPred("is_mutable", 1, p_is_mutable, SafePredFlag);
|
||||
#endif
|
||||
}
|
|
@ -0,0 +1,96 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
File: modules.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: module support *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
|
||||
STATIC_PROTO(Int p_current_module, (void));
|
||||
STATIC_PROTO(Int p_current_module1, (void));
|
||||
STD_PROTO(void InitModules, (void));
|
||||
|
||||
#define ByteAdr(X) ((char *) &(X))
|
||||
Term
|
||||
Module_Name(CODEADDR cap)
|
||||
{
|
||||
PredEntry *ap = (PredEntry *)cap;
|
||||
|
||||
if (!ap->ModuleOfPred)
|
||||
/* If the system predicate is a metacall I should return the
|
||||
module for the metacall, which I will suppose has to be
|
||||
reachable from the current module anyway.
|
||||
|
||||
So I will return the current module in case the system
|
||||
predicate is a meta-call. Otherwise it will still work.
|
||||
*/
|
||||
return(ModuleName[CurrentModule]);
|
||||
else
|
||||
return (ModuleName[ap->ModuleOfPred]);
|
||||
}
|
||||
|
||||
int
|
||||
LookupModule(Term a)
|
||||
{
|
||||
unsigned int i;
|
||||
|
||||
for (i = 0; i < NoOfModules; ++i)
|
||||
if (ModuleName[i] == a)
|
||||
return (i);
|
||||
ModuleName[i = NoOfModules++] = a;
|
||||
return (i);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_current_module(void)
|
||||
{ /* $current_module(Old,New) */
|
||||
Term t;
|
||||
unsigned int i;
|
||||
|
||||
if (!unify_constant(ARG1, ModuleName[CurrentModule]))
|
||||
return (0);
|
||||
t = Deref(ARG2);
|
||||
if (IsVarTerm(t) || !IsAtomTerm(t))
|
||||
return (0);
|
||||
for (i = 0; i < NoOfModules; ++i)
|
||||
if (ModuleName[i] == t) {
|
||||
CurrentModule = i;
|
||||
return (1);
|
||||
}
|
||||
ModuleName[CurrentModule = NoOfModules++] = t;
|
||||
return (1);
|
||||
}
|
||||
|
||||
static Int
|
||||
p_current_module1(void)
|
||||
{ /* $current_module(Old) */
|
||||
if (!unify_constant(ARG1, ModuleName[CurrentModule]))
|
||||
return (0);
|
||||
return (1);
|
||||
}
|
||||
|
||||
void
|
||||
InitModules(void)
|
||||
{
|
||||
ModuleName[CurrentModule = PrimitivesModule = 0] =
|
||||
MkAtomTerm(LookupAtom("prolog"));
|
||||
ModuleName[1] = MkAtomTerm(LookupAtom("user"));
|
||||
InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
|
||||
}
|
|
@ -0,0 +1,52 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: other.c *
|
||||
* Last rev: Dec/90 *
|
||||
* mods: *
|
||||
* comments: extra routines *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
|
||||
Term
|
||||
MkPairTerm(Term head, Term tail)
|
||||
{
|
||||
register CELL *p = H;
|
||||
|
||||
*H++ = (CELL) (head);
|
||||
*H++ = (CELL) (tail);
|
||||
return (AbsPair(p));
|
||||
}
|
||||
|
||||
|
||||
Term
|
||||
MkApplTerm(Functor f, unsigned int n, register Term *a)
|
||||
/* build compound term with functor f and n
|
||||
* args a */
|
||||
{
|
||||
CELL *t = H;
|
||||
|
||||
if (n == 0)
|
||||
return (MkAtomTerm(NameOfFunctor(f)));
|
||||
if (f == FunctorList)
|
||||
return (MkPairTerm(a[0], a[1]));
|
||||
*H++ = (CELL) f;
|
||||
while (n--)
|
||||
*H++ = (CELL) * a++;
|
||||
return (AbsAppl(t));
|
||||
}
|
|
@ -0,0 +1,580 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: parser.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: Prolog's parser *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
/*
|
||||
* Description:
|
||||
*
|
||||
* parser: produces a prolog term from an array of tokens
|
||||
*
|
||||
* parser usage: the parser takes its input from an array of token descriptions
|
||||
* addressed by the global variable 'tokptr' and produces a Term as result. A
|
||||
* macro 'NextToken' should be defined in 'yap.h' for advancing 'tokptr' from
|
||||
* one token to the next. In the distributed version this macro also updates
|
||||
* a variable named 'toktide' for keeping track of how far the parser went
|
||||
* before failling with a syntax error. The parser should be invoked with
|
||||
* 'tokptr' pointing to the first token. The last token should have type
|
||||
* 'eot_tok'. The parser return either a Term. Syntactic errors are signaled
|
||||
* by a return value 0. The parser builds new terms on the 'global stack' and
|
||||
* also uses an auxiliary stack pointed to by 'AuxSp'. In the distributed
|
||||
* version this auxiliary stack is assumed to grow downwards. This
|
||||
* assumption, however, is only relevant to routine 'ParseArgs', and to the
|
||||
* variable toktide. conclusion: set tokptr pointing to first token set AuxSp
|
||||
* Call Parse
|
||||
*
|
||||
* VSC: Working whithout known bugs in 87/4/6
|
||||
*
|
||||
* LD: -I or +I evaluated by parser 87/4/28
|
||||
*
|
||||
* LD: parser extended 87/4/28
|
||||
*
|
||||
*/
|
||||
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
#ifdef __STDC__XXX
|
||||
#define Volatile volatile
|
||||
#else
|
||||
#define Volatile
|
||||
#endif
|
||||
|
||||
|
||||
STATIC_PROTO(void GNextToken, (void));
|
||||
STATIC_PROTO(void checkfor, (Term));
|
||||
STATIC_PROTO(Term ParseArgs, (Atom));
|
||||
STATIC_PROTO(Term ParseList, (void));
|
||||
STATIC_PROTO(Term ParseTerm, (int));
|
||||
|
||||
|
||||
/* weak backtraking mechanism based on long_jump */
|
||||
|
||||
typedef struct {
|
||||
jmp_buf JmpBuff;
|
||||
} JMPBUFF;
|
||||
|
||||
static JMPBUFF FailBuff;
|
||||
|
||||
|
||||
#define TRY(S,P) \
|
||||
{ Volatile JMPBUFF saveenv;\
|
||||
Volatile TokEntry *saveT=tokptr; \
|
||||
Volatile CELL *saveH=H;\
|
||||
Volatile int savecurprio=curprio;\
|
||||
saveenv=FailBuff;\
|
||||
if(!setjmp(FailBuff.JmpBuff)) {\
|
||||
S;\
|
||||
FailBuff=saveenv;\
|
||||
P;\
|
||||
}\
|
||||
else { FailBuff=saveenv; \
|
||||
H=saveH; \
|
||||
curprio = savecurprio; \
|
||||
tokptr=saveT; \
|
||||
}\
|
||||
}\
|
||||
|
||||
#define TRY3(S,P,F) \
|
||||
{ Volatile JMPBUFF saveenv;\
|
||||
Volatile TokEntry *saveT=tokptr; Volatile CELL *saveH=H;\
|
||||
saveenv=FailBuff;\
|
||||
if(!setjmp(FailBuff.JmpBuff)) {\
|
||||
S;\
|
||||
FailBuff=saveenv;\
|
||||
P;\
|
||||
}\
|
||||
else { FailBuff=saveenv; H=saveH; tokptr=saveT; F }\
|
||||
}\
|
||||
|
||||
#define FAIL longjmp(FailBuff.JmpBuff,1)
|
||||
|
||||
TokEntry *tokptr, *toktide;
|
||||
VarEntry *VarTable, *AnonVarTable;
|
||||
|
||||
VarEntry *
|
||||
LookupVar(char *var) /* lookup variable in variables table */
|
||||
{
|
||||
VarEntry *p;
|
||||
|
||||
#ifdef DEBUG
|
||||
if (Option[4])
|
||||
YP_fprintf(YP_stderr,"[LookupVar %s]", var);
|
||||
#endif
|
||||
if (var[0] != '_' || var[1] != '\0') {
|
||||
VarEntry **op = &VarTable;
|
||||
unsigned char *vp = (unsigned char *)var;
|
||||
CELL hv;
|
||||
|
||||
p = VarTable;
|
||||
HashFunction(vp, hv);
|
||||
while (p != NULL) {
|
||||
CELL hpv = p->hv;
|
||||
if (hv == hpv) {
|
||||
Int scmp;
|
||||
if ((scmp = strcmp(var, p->VarRep)) == 0) {
|
||||
return(p);
|
||||
} else if (scmp < 0) {
|
||||
op = &(p->VarLeft);
|
||||
p = p->VarLeft;
|
||||
} else {
|
||||
op = &(p->VarRight);
|
||||
p = p->VarRight;
|
||||
}
|
||||
} else if (hv < hpv) {
|
||||
op = &(p->VarLeft);
|
||||
p = p->VarLeft;
|
||||
} else {
|
||||
op = &(p->VarRight);
|
||||
p = p->VarRight;
|
||||
}
|
||||
}
|
||||
p = (VarEntry *) AllocScannerMemory(strlen(var) + sizeof(VarEntry));
|
||||
*op = p;
|
||||
p->VarLeft = p->VarRight = NULL;
|
||||
p->hv = hv;
|
||||
strcpy(p->VarRep, var);
|
||||
} else {
|
||||
/* anon var */
|
||||
p = (VarEntry *) AllocScannerMemory(sizeof(VarEntry) + 2);
|
||||
p->VarLeft = AnonVarTable;
|
||||
AnonVarTable = p;
|
||||
p->VarRight = NULL;
|
||||
p->hv = 0L;
|
||||
p->VarRep[0] = '_';
|
||||
p->VarRep[1] = '\0';
|
||||
}
|
||||
p->VarAdr = TermNil;
|
||||
return (p);
|
||||
}
|
||||
|
||||
Term
|
||||
VarNames(VarEntry *p,Term l)
|
||||
{
|
||||
if (p != NULL) {
|
||||
if (strcmp(p->VarRep, "_") != 0) {
|
||||
Term o = MkPairTerm(MkPairTerm(StringToList(p->VarRep), p->VarAdr),
|
||||
VarNames(p->VarRight,
|
||||
VarNames(p->VarLeft,l)));
|
||||
if (H > ASP-4096) {
|
||||
longjmp(IOBotch,1);
|
||||
}
|
||||
return(o);
|
||||
} else {
|
||||
return(VarNames(p->VarRight,VarNames(p->VarLeft,l)));
|
||||
}
|
||||
} else {
|
||||
return (l);
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
IsPrefixOp(Prop opinfo,int *pptr, int *rpptr)
|
||||
{
|
||||
int p;
|
||||
|
||||
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
if ((p = RepOpProp(opinfo)->Prefix) != 0) {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
*pptr = *rpptr = p & MaskPrio;
|
||||
if (p & DcrrpFlag)
|
||||
--* rpptr;
|
||||
return (TRUE);
|
||||
} else {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
return (FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
IsInfixOp(Prop opinfo, int *pptr, int *lpptr, int *rpptr)
|
||||
{
|
||||
int p;
|
||||
|
||||
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
if ((p = RepOpProp(opinfo)->Infix) != 0) {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
*pptr = *rpptr = *lpptr = p & MaskPrio;
|
||||
if (p & DcrrpFlag)
|
||||
--* rpptr;
|
||||
if (p & DcrlpFlag)
|
||||
--* lpptr;
|
||||
return (TRUE);
|
||||
} else {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
return (FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
IsPosfixOp(Prop opinfo, int *pptr, int *lpptr)
|
||||
{
|
||||
int p;
|
||||
READ_LOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
if ((p = RepOpProp(opinfo)->Posfix) != 0) {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
*pptr = *lpptr = p & MaskPrio;
|
||||
if (p & DcrlpFlag)
|
||||
--* lpptr;
|
||||
return (TRUE);
|
||||
} else {
|
||||
READ_UNLOCK(RepOpProp(opinfo)->OpRWLock);
|
||||
return (FALSE);
|
||||
}
|
||||
}
|
||||
|
||||
inline static void
|
||||
GNextToken(void)
|
||||
{
|
||||
if (tokptr->Tok == Ord(eot_tok))
|
||||
return;
|
||||
#ifdef EMACS
|
||||
if ((tokptr = tokptr->TokNext)->TokPos > toktide->TokPos)
|
||||
toktide = tokptr;
|
||||
#else
|
||||
if (tokptr == toktide)
|
||||
toktide = tokptr = tokptr->TokNext;
|
||||
else
|
||||
tokptr = tokptr->TokNext;
|
||||
#endif
|
||||
}
|
||||
|
||||
inline static void
|
||||
checkfor(Term c)
|
||||
{
|
||||
if (tokptr->Tok != Ord(Ponctuation_tok)
|
||||
|| tokptr->TokInfo != c)
|
||||
FAIL;
|
||||
NextToken;
|
||||
}
|
||||
|
||||
static Term
|
||||
ParseArgs(Atom a)
|
||||
{
|
||||
int nargs = 0;
|
||||
Term *p, t;
|
||||
#ifdef SFUNC
|
||||
SFEntry *pe = (SFEntry *) GetAProp(a, SFProperty);
|
||||
#endif
|
||||
|
||||
NextToken;
|
||||
p = (Term *) ParserAuxSp;
|
||||
while (1) {
|
||||
Term *tp = (Term *)ParserAuxSp;
|
||||
*tp++ = Unsigned(ParseTerm(999));
|
||||
ParserAuxSp = (tr_fr_ptr)tp;
|
||||
++nargs;
|
||||
if (tokptr->Tok != Ord(Ponctuation_tok))
|
||||
break;
|
||||
if (((int) tokptr->TokInfo) != ',')
|
||||
break;
|
||||
NextToken;
|
||||
}
|
||||
ParserAuxSp = (tr_fr_ptr)p;
|
||||
/*
|
||||
* Needed because the arguments for the functor are placed in reverse
|
||||
* order
|
||||
*/
|
||||
#ifdef SFUNC
|
||||
if (pe)
|
||||
t = MkSFTerm(MkFunctor(a, SFArity), nargs, p, pe->NilValue);
|
||||
else
|
||||
t = MkApplTerm(MkFunctor(a, nargs), nargs, p);
|
||||
#else
|
||||
t = MkApplTerm(MkFunctor(a, nargs), nargs, p);
|
||||
#endif
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
checkfor((Term) ')');
|
||||
return (t);
|
||||
}
|
||||
|
||||
|
||||
static Term
|
||||
ParseList(void)
|
||||
{
|
||||
Term t, s;
|
||||
t = ParseTerm(999);
|
||||
if (tokptr->Tok == Ord(Ponctuation_tok)) {
|
||||
if (((int) tokptr->TokInfo) == ',') {
|
||||
NextToken;
|
||||
if (tokptr->Tok == Ord(Name_tok)
|
||||
&& strcmp(RepAtom((Atom)(tokptr->TokInfo))->StrOfAE, "..") == 0) {
|
||||
NextToken;
|
||||
s = ParseTerm(999);
|
||||
} else
|
||||
s = ParseList();
|
||||
} else if (((int) tokptr->TokInfo) == '|') {
|
||||
NextToken;
|
||||
s = ParseTerm(999);
|
||||
} else
|
||||
s = MkAtomTerm(AtomNil);
|
||||
t = MkPairTerm(t, s);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
} else
|
||||
FAIL;
|
||||
return (t);
|
||||
}
|
||||
|
||||
static Term
|
||||
ParseTerm(int prio)
|
||||
{
|
||||
/* parse term with priority prio */
|
||||
Volatile Prop opinfo;
|
||||
Volatile Term t;
|
||||
Volatile Functor func;
|
||||
Volatile VarEntry *varinfo;
|
||||
Volatile int curprio = 0, opprio, oplprio, oprprio;
|
||||
|
||||
switch (tokptr->Tok) {
|
||||
case Name_tok:
|
||||
t = tokptr->TokInfo;
|
||||
NextToken;
|
||||
if ((tokptr->Tok != Ord(Ponctuation_tok)
|
||||
|| Unsigned(tokptr->TokInfo) != 'l')
|
||||
&& (opinfo = GetAProp((Atom) t, OpProperty))
|
||||
&& IsPrefixOp(opinfo, &opprio, &oprprio)
|
||||
) {
|
||||
/* special rules apply for +1, -2.3, etc... */
|
||||
if (tokptr->Tok == Number_tok) {
|
||||
if ((Atom)t == AtomMinus) {
|
||||
t = tokptr->TokInfo;
|
||||
if (IsIntTerm(t))
|
||||
t = MkIntTerm(-IntOfTerm(t));
|
||||
else if (IsFloatTerm(t))
|
||||
t = MkFloatTerm(-FloatOfTerm(t));
|
||||
#ifdef USE_GMP
|
||||
else if (IsBigIntTerm(t)) {
|
||||
MP_INT *new = PreAllocBigNum();
|
||||
|
||||
mpz_neg(new, BigIntOfTerm(t));
|
||||
t = MkBigIntTerm(new);
|
||||
}
|
||||
#endif
|
||||
else
|
||||
t = MkLongIntTerm(-LongIntOfTerm(t));
|
||||
NextToken;
|
||||
break;
|
||||
} else if ((Atom)t == AtomPlus) {
|
||||
t = tokptr->TokInfo;
|
||||
NextToken;
|
||||
break;
|
||||
}
|
||||
}
|
||||
if (opprio <= prio) {
|
||||
/* try to parse as a prefix operator */
|
||||
TRY(
|
||||
/* build appl on the heap */
|
||||
func = MkFunctor((Atom) t, 1);
|
||||
t = ParseTerm(oprprio);
|
||||
t = MkApplTerm(func, 1, &t);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
curprio = opprio;
|
||||
,
|
||||
break;
|
||||
)
|
||||
}
|
||||
}
|
||||
if (tokptr->Tok == Ord(Ponctuation_tok)
|
||||
&& Unsigned(tokptr->TokInfo) == 'l')
|
||||
t = ParseArgs((Atom) t);
|
||||
else
|
||||
t = MkAtomTerm((Atom)t);
|
||||
break;
|
||||
|
||||
case Number_tok:
|
||||
t = tokptr->TokInfo;
|
||||
NextToken;
|
||||
break;
|
||||
|
||||
case String_tok: /* build list on the heap */
|
||||
{
|
||||
Volatile char *p = (char *) tokptr->TokInfo;
|
||||
if (*p == 0)
|
||||
t = MkAtomTerm(AtomNil);
|
||||
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_CHARS)
|
||||
t = StringToListOfAtoms(p);
|
||||
else if (yap_flags[YAP_DOUBLE_QUOTES_FLAG] == STRING_AS_ATOM)
|
||||
t = MkAtomTerm(LookupAtom(p));
|
||||
else
|
||||
t = StringToList(p);
|
||||
NextToken;
|
||||
}
|
||||
break;
|
||||
|
||||
case Var_tok:
|
||||
varinfo = (VarEntry *) (tokptr->TokInfo);
|
||||
if ((t = varinfo->VarAdr) == TermNil) {
|
||||
t = varinfo->VarAdr = MkVarTerm();
|
||||
}
|
||||
NextToken;
|
||||
break;
|
||||
|
||||
case Ponctuation_tok:
|
||||
switch ((int) tokptr->TokInfo) {
|
||||
case '(':
|
||||
case 'l': /* non solo ( */
|
||||
NextToken;
|
||||
t = ParseTerm(1200);
|
||||
checkfor((Term) ')');
|
||||
break;
|
||||
case '[':
|
||||
NextToken;
|
||||
t = ParseList();
|
||||
checkfor((Term) ']');
|
||||
break;
|
||||
case '{':
|
||||
NextToken;
|
||||
if (tokptr->Tok == Ord(Ponctuation_tok) &&
|
||||
Unsigned(tokptr->TokInfo) == '}') {
|
||||
t = MkAtomTerm(NameOfFunctor(FunctorBraces));
|
||||
NextToken;
|
||||
} else {
|
||||
t = ParseTerm(1200);
|
||||
t = MkApplTerm(FunctorBraces, 1, &t);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
checkfor((Term) '}');
|
||||
}
|
||||
break;
|
||||
default:
|
||||
FAIL;
|
||||
}
|
||||
break;
|
||||
|
||||
default:
|
||||
|
||||
FAIL;
|
||||
}
|
||||
|
||||
/* main loop to parse infix and posfix operators starts here */
|
||||
while (TRUE) {
|
||||
if (tokptr->Tok == Ord(Name_tok)
|
||||
&& (opinfo = GetAProp((Atom)(tokptr->TokInfo), OpProperty))) {
|
||||
Prop save_opinfo = opinfo;
|
||||
if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio)
|
||||
&& opprio <= prio && oplprio >= curprio) {
|
||||
/* try parsing as infix operator */
|
||||
Volatile int oldprio = curprio;
|
||||
TRY3(
|
||||
func = MkFunctor((Atom) tokptr->TokInfo, 2);
|
||||
NextToken;
|
||||
{
|
||||
Term args[2];
|
||||
args[0] = t;
|
||||
args[1] = ParseTerm(oprprio);
|
||||
t = MkApplTerm(func, 2, args);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
},
|
||||
curprio = opprio;
|
||||
opinfo = save_opinfo;
|
||||
continue;
|
||||
,
|
||||
opinfo = save_opinfo;
|
||||
curprio = oldprio;
|
||||
)
|
||||
}
|
||||
if (IsPosfixOp(opinfo, &opprio, &oplprio)
|
||||
&& opprio <= prio && oplprio >= curprio) {
|
||||
/* parse as posfix operator */
|
||||
t = MkApplTerm(MkFunctor((Atom) tokptr->TokInfo, 1), 1, &t);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
curprio = opprio;
|
||||
NextToken;
|
||||
continue;
|
||||
}
|
||||
break;
|
||||
}
|
||||
if (tokptr->Tok == Ord(Ponctuation_tok)) {
|
||||
if (Unsigned(tokptr->TokInfo) == ',' &&
|
||||
prio >= 1000 && curprio <= 999) {
|
||||
Volatile Term args[2];
|
||||
NextToken;
|
||||
args[0] = t;
|
||||
args[1] = ParseTerm(1000);
|
||||
t = MkApplTerm(MkFunctor(AtomComma, 2), 2, args);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
curprio = 1000;
|
||||
continue;
|
||||
} else if (Unsigned(tokptr->TokInfo) == '|' && prio >= 1100 &&
|
||||
curprio <= 1099) {
|
||||
Volatile Term args[2];
|
||||
NextToken;
|
||||
args[0] = t;
|
||||
args[1] = ParseTerm(1100);
|
||||
t = MkApplTerm(FunctorVBar, 2, args);
|
||||
/* check for possible overflow against local stack */
|
||||
if (H > ASP-4096) {
|
||||
ErrorMessage = "Stack Overflow";
|
||||
FAIL;
|
||||
}
|
||||
curprio = 1100;
|
||||
continue;
|
||||
}
|
||||
}
|
||||
if (tokptr->Tok <= Ord(String_tok))
|
||||
FAIL;
|
||||
break;
|
||||
}
|
||||
return (t);
|
||||
}
|
||||
|
||||
|
||||
Term
|
||||
Parse(void)
|
||||
{
|
||||
Volatile Term t;
|
||||
if (!setjmp(FailBuff.JmpBuff)) {
|
||||
t = ParseTerm(1200);
|
||||
if (tokptr->Tok != Ord(eot_tok))
|
||||
return (0L);
|
||||
return (t);
|
||||
} else
|
||||
return (0);
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,421 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: sort.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: sorting in Prolog *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
/* for the moment, follow Prolog's traditional mergesort */
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#ifndef NULL
|
||||
#define NULL (void *)0
|
||||
#endif
|
||||
|
||||
/* fill in the even or the odd elements */
|
||||
#define M_EVEN 0
|
||||
#define M_ODD 1
|
||||
|
||||
STATIC_PROTO(Int build_new_list, (CELL *, Term));
|
||||
STATIC_PROTO(void simple_mergesort, (CELL *, Int, int));
|
||||
STATIC_PROTO(Int compact_mergesort, (CELL *, Int, int));
|
||||
STATIC_PROTO(int key_mergesort, (CELL *, Int, int, Functor));
|
||||
STATIC_PROTO(void adjust_vector, (CELL *, Int));
|
||||
STATIC_PROTO(Int p_sort, (void));
|
||||
STATIC_PROTO(Int p_msort, (void));
|
||||
STATIC_PROTO(Int p_ksort, (void));
|
||||
|
||||
/* copy to a new list of terms */
|
||||
static Int
|
||||
build_new_list(CELL *pt, Term t)
|
||||
{
|
||||
Int out = 0;
|
||||
if (IsVarTerm(t))
|
||||
return(-1);
|
||||
if (t == TermNil)
|
||||
return(0);
|
||||
restart:
|
||||
while (IsPairTerm(t)) {
|
||||
out++;
|
||||
pt[0] = HeadOfTerm(t);
|
||||
t = TailOfTerm(t);
|
||||
if (IsVarTerm(t))
|
||||
return(-1);
|
||||
if (t == TermNil) {
|
||||
return(out);
|
||||
}
|
||||
pt += 2;
|
||||
if (pt > ASP - 4096) {
|
||||
if (!gc(2, ENV, P)) {
|
||||
Error(SYSTEM_ERROR, TermNil, "YAP could not grow stack in sort/2");
|
||||
return(FALSE);
|
||||
}
|
||||
t = Deref(ARG1);
|
||||
pt = H;
|
||||
out = 0;
|
||||
goto restart;
|
||||
}
|
||||
}
|
||||
return(-1);
|
||||
}
|
||||
|
||||
/* copy to a new list of terms */
|
||||
static
|
||||
void simple_mergesort(CELL *pt, Int size, int my_p)
|
||||
{
|
||||
|
||||
if (size > 2) {
|
||||
Int half_size = size / 2;
|
||||
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
|
||||
int left_p, right_p;
|
||||
|
||||
pt_right = pt + half_size*2;
|
||||
left_p = my_p^1;
|
||||
right_p = my_p;
|
||||
simple_mergesort(pt, half_size, left_p);
|
||||
simple_mergesort(pt_right, size-half_size, right_p);
|
||||
/* now implement a simple merge routine */
|
||||
|
||||
/* pointer to after the end of the list */
|
||||
end_pt = pt + 2*size;
|
||||
/* pointer to the element after the last element to the left */
|
||||
end_pt_left = pt+half_size*2;
|
||||
/* where is left list */
|
||||
pt_left = pt+left_p;
|
||||
/* where is right list */
|
||||
pt_right += right_p;
|
||||
/* where is new list */
|
||||
pt += my_p;
|
||||
/* while there are elements in the left or right vector do compares */
|
||||
while (pt_left < end_pt_left && pt_right < end_pt) {
|
||||
/* if the element to the left is larger than the one to the right */
|
||||
if (compare_terms(pt_left[0], pt_right[0]) <= 0) {
|
||||
/* copy the one to the left */
|
||||
pt[0] = pt_left[0];
|
||||
/* and avance the two pointers */
|
||||
pt += 2;
|
||||
pt_left += 2;
|
||||
} else {
|
||||
/* otherwise, copy the one to the right */
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
}
|
||||
}
|
||||
/* if any elements were left in the left vector just copy them */
|
||||
while (pt_left < end_pt_left) {
|
||||
pt[0] = pt_left[0];
|
||||
pt += 2;
|
||||
pt_left += 2;
|
||||
}
|
||||
/* if any elements were left in the right vector
|
||||
and they are in the wrong place, just copy them */
|
||||
if (my_p != right_p) {
|
||||
while(pt_right < end_pt) {
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (size > 1 && (compare_terms(pt[0],pt[2]) > 0)) {
|
||||
CELL t = pt[2];
|
||||
pt[2+my_p] = pt[0];
|
||||
pt[my_p] = t;
|
||||
} else if (my_p) {
|
||||
pt[1] = pt[0];
|
||||
if (size > 1)
|
||||
pt[3] = pt[2];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* copy to a new list of terms */
|
||||
static
|
||||
int key_mergesort(CELL *pt, Int size, int my_p, Functor FuncDMinus)
|
||||
{
|
||||
|
||||
if (size > 2) {
|
||||
Int half_size = size / 2;
|
||||
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
|
||||
int left_p, right_p;
|
||||
|
||||
pt_right = pt + half_size*2;
|
||||
left_p = my_p^1;
|
||||
right_p = my_p;
|
||||
if (!key_mergesort(pt, half_size, left_p, FuncDMinus))
|
||||
return(FALSE);
|
||||
if (!key_mergesort(pt_right, size-half_size, right_p, FuncDMinus))
|
||||
return(FALSE);
|
||||
/* now implement a simple merge routine */
|
||||
|
||||
/* pointer to after the end of the list */
|
||||
end_pt = pt + 2*size;
|
||||
/* pointer to the element after the last element to the left */
|
||||
end_pt_left = pt+half_size*2;
|
||||
/* where is left list */
|
||||
pt_left = pt+left_p;
|
||||
/* where is right list */
|
||||
pt_right += right_p;
|
||||
/* where is new list */
|
||||
pt += my_p;
|
||||
/* while there are elements in the left or right vector do compares */
|
||||
while (pt_left < end_pt_left && pt_right < end_pt) {
|
||||
/* if the element to the left is larger than the one to the right */
|
||||
Term t0 = pt_left[0] , t1 = pt_right[0];
|
||||
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
|
||||
return(FALSE);
|
||||
t0 = ArgOfTerm(1,t0);
|
||||
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
|
||||
return(FALSE);
|
||||
t1 = ArgOfTerm(1,t1);
|
||||
if (compare_terms(t0, t1) <= 0) {
|
||||
/* copy the one to the left */
|
||||
pt[0] = pt_left[0];
|
||||
/* and avance the two pointers */
|
||||
pt += 2;
|
||||
pt_left += 2;
|
||||
} else {
|
||||
/* otherwise, copy the one to the right */
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
}
|
||||
}
|
||||
/* if any elements were left in the left vector just copy them */
|
||||
while (pt_left < end_pt_left) {
|
||||
pt[0] = pt_left[0];
|
||||
pt += 2;
|
||||
pt_left += 2;
|
||||
}
|
||||
/* if any elements were left in the right vector
|
||||
and they are in the wrong place, just copy them */
|
||||
if (my_p != right_p) {
|
||||
while(pt_right < end_pt) {
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if (size > 1) {
|
||||
Term t0 = pt[0], t1 = pt[2];
|
||||
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
|
||||
return(FALSE);
|
||||
t0 = ArgOfTerm(1,t0);
|
||||
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
|
||||
return(FALSE);
|
||||
t1 = ArgOfTerm(1,t1);
|
||||
if (compare_terms(t0,t1) > 0) {
|
||||
CELL t = pt[2];
|
||||
pt[2+my_p] = pt[0];
|
||||
pt[my_p] = t;
|
||||
} else if (my_p) {
|
||||
pt[1] = pt[0];
|
||||
pt[3] = pt[2];
|
||||
}
|
||||
} else {
|
||||
if (my_p)
|
||||
pt[1] = pt[0];
|
||||
}
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
/* copy to a new list of terms and compress duplicates */
|
||||
static
|
||||
Int compact_mergesort(CELL *pt, Int size, int my_p)
|
||||
{
|
||||
|
||||
if (size > 2) {
|
||||
Int half_size = size / 2;
|
||||
CELL *pt_left, *pt_right, *end_pt_right, *end_pt_left;
|
||||
int left_p, right_p;
|
||||
Int lsize, rsize;
|
||||
|
||||
pt_right = pt + half_size*2;
|
||||
left_p = my_p^1;
|
||||
right_p = my_p;
|
||||
lsize = compact_mergesort(pt, half_size, left_p);
|
||||
rsize = compact_mergesort(pt_right, size-half_size, right_p);
|
||||
/* now implement a simple merge routine */
|
||||
|
||||
/* where is left list */
|
||||
pt_left = pt+left_p;
|
||||
/* pointer to the element after the last element to the left */
|
||||
end_pt_left = pt+2*lsize;
|
||||
/* where is right list */
|
||||
pt_right += right_p;
|
||||
/* pointer to after the end of the list */
|
||||
end_pt_right = pt_right + 2*rsize;
|
||||
/* where is new list */
|
||||
pt += my_p;
|
||||
size = 0;
|
||||
/* while there are elements in the left or right vector do compares */
|
||||
while (pt_left < end_pt_left && pt_right < end_pt_right) {
|
||||
/* if the element to the left is larger than the one to the right */
|
||||
Int cmp = compare_terms(pt_left[0], pt_right[0]);
|
||||
if (cmp < 0) {
|
||||
/* copy the one to the left */
|
||||
pt[0] = pt_left[0];
|
||||
/* and avance the two pointers */
|
||||
pt += 2;
|
||||
size ++;
|
||||
pt_left += 2;
|
||||
} else if (cmp == 0) {
|
||||
/* otherwise, just skip one of them, anyone */
|
||||
pt_left += 2;
|
||||
} else {
|
||||
/* otherwise, copy the one to the right */
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
size++;
|
||||
}
|
||||
}
|
||||
/* if any elements were left in the left vector just copy them */
|
||||
while (pt_left < end_pt_left) {
|
||||
pt[0] = pt_left[0];
|
||||
pt += 2;
|
||||
pt_left += 2;
|
||||
size++;
|
||||
}
|
||||
/* if any elements were left in the right vector
|
||||
and they are in the wrong place, just copy them */
|
||||
while(pt_right < end_pt_right) {
|
||||
pt[0] = pt_right[0];
|
||||
pt += 2;
|
||||
pt_right += 2;
|
||||
size++;
|
||||
}
|
||||
return(size);
|
||||
} else if (size == 2) {
|
||||
Int cmp = compare_terms(pt[0],pt[2]);
|
||||
if (cmp > 0) {
|
||||
/* swap */
|
||||
CELL t = pt[2];
|
||||
pt[2+my_p] = pt[0];
|
||||
pt[my_p] = t;
|
||||
return(2);
|
||||
} else if (cmp == 0) {
|
||||
if (my_p)
|
||||
pt[1] = pt[0];
|
||||
return(1);
|
||||
} else {
|
||||
if (my_p) {
|
||||
pt[1] = pt[0];
|
||||
pt[3] = pt[2];
|
||||
}
|
||||
return(2);
|
||||
}
|
||||
} else {
|
||||
/* size = 1 */
|
||||
if (my_p)
|
||||
pt[1] = pt[0];
|
||||
return(1);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
adjust_vector(CELL *pt, Int size)
|
||||
{
|
||||
/* the elements are where they should be */
|
||||
CELL *ptf = pt + 2*(size-1);
|
||||
pt ++;
|
||||
while (pt < ptf) {
|
||||
pt[0] = AbsPair(pt+1);
|
||||
pt += 2;
|
||||
}
|
||||
/* close the list */
|
||||
pt[0] = TermNil;
|
||||
}
|
||||
|
||||
static Int
|
||||
p_sort(void)
|
||||
{
|
||||
/* use the heap to build a new list */
|
||||
CELL *pt = H;
|
||||
Term out;
|
||||
/* list size */
|
||||
Int size;
|
||||
size = build_new_list(pt, Deref(ARG1));
|
||||
if (size < 0)
|
||||
return(FALSE);
|
||||
if (size < 2)
|
||||
return(unify(ARG1, ARG2));
|
||||
pt = H; /* because of possible garbage collection */
|
||||
/* make sure no one writes on our temp data structure */
|
||||
H += size*2;
|
||||
/* reserve the necessary space */
|
||||
size = compact_mergesort(pt, size, M_EVEN);
|
||||
/* reajust space */
|
||||
H = pt+size*2;
|
||||
adjust_vector(pt, size);
|
||||
out = AbsPair(pt);
|
||||
return(unify(out, ARG2));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_msort(void)
|
||||
{
|
||||
/* use the heap to build a new list */
|
||||
CELL *pt = H;
|
||||
Term out;
|
||||
/* list size */
|
||||
Int size;
|
||||
size = build_new_list(pt, Deref(ARG1));
|
||||
if (size < 0)
|
||||
return(FALSE);
|
||||
if (size < 2)
|
||||
return(unify(ARG1, ARG2));
|
||||
pt = H; /* because of possible garbage collection */
|
||||
/* reserve the necessary space */
|
||||
H += size*2;
|
||||
simple_mergesort(pt, size, M_EVEN);
|
||||
adjust_vector(pt, size);
|
||||
out = AbsPair(pt);
|
||||
return(unify(out, ARG2));
|
||||
}
|
||||
|
||||
static Int
|
||||
p_ksort(void)
|
||||
{
|
||||
/* use the heap to build a new list */
|
||||
CELL *pt = H;
|
||||
Term out;
|
||||
/* list size */
|
||||
Int size;
|
||||
size = build_new_list(pt, Deref(ARG1));
|
||||
if (size < 0)
|
||||
return(FALSE);
|
||||
if (size < 2)
|
||||
return(unify(ARG1, ARG2));
|
||||
/* reserve the necessary space */
|
||||
pt = H; /* because of possible garbage collection */
|
||||
H += size*2;
|
||||
if (!key_mergesort(pt, size, M_EVEN, MkFunctor(AtomMinus,2)))
|
||||
return(FALSE);
|
||||
adjust_vector(pt, size);
|
||||
out = AbsPair(pt);
|
||||
return(unify(out, ARG2));
|
||||
}
|
||||
|
||||
void
|
||||
InitSortPreds(void)
|
||||
{
|
||||
InitCPred("$sort", 2, p_sort, 0);
|
||||
InitCPred("$msort", 2, p_msort, 0);
|
||||
InitCPred("$keysort", 2, p_ksort, 0);
|
||||
}
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,236 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog @(#)amidefs.h 1.3 3/15/90
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: tracer.h *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: definitions for low level tracer *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef LOW_LEVEL_TRACER
|
||||
|
||||
#include "Yatom.h"
|
||||
#include "yapio.h"
|
||||
#include "tracer.h"
|
||||
|
||||
STATIC_PROTO(int TracePutchar, (int, int));
|
||||
STATIC_PROTO(void send_tracer_message, (char *, char *, Int, char *, CELL *));
|
||||
|
||||
int do_low_level_trace = FALSE;
|
||||
static int do_trace_primitives = TRUE;
|
||||
|
||||
int
|
||||
TracePutchar(int sno, int ch)
|
||||
{
|
||||
return(YP_putc(ch, stderr)); /* use standard error stream, which is supposed to be 2*/
|
||||
}
|
||||
|
||||
static void
|
||||
send_tracer_message(char *start, char *name, Int arity, char *mname, CELL *args)
|
||||
{
|
||||
if (name == NULL) {
|
||||
#ifdef YAPOR
|
||||
#ifdef DEPTH_LIMIT
|
||||
YP_fprintf(YP_stderr, "(%d)%s (D:%d)", worker_id, start, (CELL)IntegerOfTerm(DEPTH)/2);
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "(%d)%s", worker_id, start);
|
||||
#endif
|
||||
#else
|
||||
#ifdef DEPTH_LIMIT
|
||||
YP_fprintf(YP_stderr, "%s (D:%d)", start, (CELL)IntegerOfTerm(DEPTH)/2);
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "%s", start);
|
||||
#endif
|
||||
#endif
|
||||
} else {
|
||||
int i;
|
||||
|
||||
if (arity) {
|
||||
#ifdef DEPTH_LIMIT
|
||||
YP_fprintf(YP_stderr, "%s (D:%d) %s:%s(", start, (CELL)IntegerOfTerm(DEPTH)/2, mname, name);
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "%s %s:%s(", start, mname, name);
|
||||
#endif
|
||||
} else {
|
||||
#ifdef DEPTH_LIMIT
|
||||
YP_fprintf(YP_stderr, "%s (D:%d) %s:%s", start, (CELL)IntegerOfTerm(DEPTH)/2, mname, name);
|
||||
#else
|
||||
YP_fprintf(YP_stderr, "%s %s:%s", start, mname, name);
|
||||
#endif
|
||||
}
|
||||
for (i= 0; i < arity; i++) {
|
||||
if (i > 0) YP_fprintf(YP_stderr, ",");
|
||||
#if DEBUG
|
||||
#if COROUTINING
|
||||
Portray_delays = TRUE;
|
||||
#endif
|
||||
#endif
|
||||
plwrite(args[i], TracePutchar, 4);
|
||||
#if DEBUG
|
||||
#if COROUTINING
|
||||
Portray_delays = FALSE;
|
||||
#endif
|
||||
#endif
|
||||
}
|
||||
if (arity) YP_fprintf(YP_stderr, ")");
|
||||
}
|
||||
YP_fprintf(YP_stderr, "\n");
|
||||
}
|
||||
|
||||
unsigned long vsc_count;
|
||||
|
||||
/*
|
||||
static int
|
||||
check_trail_consistency(void) {
|
||||
tr_fr_ptr ptr = TR;
|
||||
while (ptr > (CELL *)TrailBase) {
|
||||
ptr = --ptr;
|
||||
if (!IsVarTerm(TrailTerm(ptr))) {
|
||||
if (IsApplTerm(TrailTerm(ptr))) {
|
||||
CELL *cptr = (CELL *)ptr;
|
||||
ptr = (tr_fr_ptr)(cptr-1);
|
||||
} else {
|
||||
if (IsPairTerm(TrailTerm(ptr))) {
|
||||
CELL *p = RepPair(TrailTerm(ptr));
|
||||
if (p < H0) continue;
|
||||
}
|
||||
printf("Oops at call %ld, B->cp(%p) TR(%p) pt(%p)\n", vsc_count,B->cp_tr, TR, ptr);
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
}
|
||||
return(TRUE);
|
||||
}
|
||||
*/
|
||||
|
||||
void
|
||||
low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
|
||||
{
|
||||
char *s;
|
||||
char *mname;
|
||||
Int arity;
|
||||
extern int gc_calls;
|
||||
|
||||
vsc_count++;
|
||||
/* if (vsc_count < 420430) return; */
|
||||
/* if (vsc_count > 500000) exit(0); */
|
||||
/* if (gc_calls < 1) return;*/
|
||||
YP_fprintf(YP_stderr,"%lu ",vsc_count);
|
||||
/* check_trail_consistency(); */
|
||||
if (pred == NULL) {
|
||||
return;
|
||||
}
|
||||
if (pred->ModuleOfPred == 0 && !do_trace_primitives) {
|
||||
return;
|
||||
}
|
||||
switch (port) {
|
||||
case enter_pred:
|
||||
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
|
||||
arity = pred->ArityOfPE;
|
||||
if (arity == 0) {
|
||||
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
|
||||
} else {
|
||||
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
|
||||
}
|
||||
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
|
||||
return; */
|
||||
send_tracer_message("CALL: ", s, arity, mname, args);
|
||||
break;
|
||||
case try_or:
|
||||
send_tracer_message("TRY_OR ", NULL, 0, NULL, args);
|
||||
break;
|
||||
case retry_or:
|
||||
send_tracer_message("FAIL ", NULL, 0, NULL, args);
|
||||
send_tracer_message("RETRY_OR ", NULL, 0, NULL, args);
|
||||
break;
|
||||
case retry_table_producer:
|
||||
send_tracer_message("FAIL ", NULL, 0, NULL, args);
|
||||
/* HANDLE METACALLS */
|
||||
if (pred == NULL) {
|
||||
send_tracer_message("RETRY TABLE: ", NULL, 0, NULL, args);
|
||||
} else {
|
||||
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
|
||||
arity = pred->ArityOfPE;
|
||||
if (arity == 0) {
|
||||
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
|
||||
} else {
|
||||
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
|
||||
}
|
||||
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
|
||||
return; */
|
||||
send_tracer_message("RETRY PRODUCER: ", s, 0, mname, NULL);
|
||||
}
|
||||
break;
|
||||
case retry_table_consumer:
|
||||
send_tracer_message("FAIL ", NULL, 0, NULL, args);
|
||||
/* HANDLE METACALLS */
|
||||
if (pred == NULL) {
|
||||
send_tracer_message("RETRY TABLE: ", NULL, 0, NULL, args);
|
||||
} else {
|
||||
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
|
||||
arity = pred->ArityOfPE;
|
||||
if (arity == 0) {
|
||||
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
|
||||
} else {
|
||||
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
|
||||
}
|
||||
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
|
||||
return; */
|
||||
send_tracer_message("RETRY CONSUMER: ", s, 0, mname, NULL);
|
||||
}
|
||||
break;
|
||||
case retry_pred:
|
||||
mname = RepAtom(AtomOfTerm(Module_Name((CODEADDR)pred)))->StrOfAE;
|
||||
arity = pred->ArityOfPE;
|
||||
if (arity == 0) {
|
||||
s = RepAtom((Atom)(pred->FunctorOfPred))->StrOfAE;
|
||||
} else {
|
||||
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
|
||||
}
|
||||
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
|
||||
return; */
|
||||
send_tracer_message("FAIL ", NULL, 0, NULL, args);
|
||||
send_tracer_message("RETRY: ", s, arity, mname, args);
|
||||
break;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
void
|
||||
toggle_low_level_trace(void)
|
||||
{
|
||||
do_low_level_trace = !do_low_level_trace;
|
||||
}
|
||||
|
||||
static Int p_start_low_level_trace(void)
|
||||
{
|
||||
do_low_level_trace = TRUE;
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static Int p_stop_low_level_trace(void)
|
||||
{
|
||||
do_low_level_trace = FALSE;
|
||||
do_trace_primitives = TRUE;
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
void
|
||||
InitLowLevelTrace(void)
|
||||
{
|
||||
InitCPred("start_low_level_trace", 0, p_start_low_level_trace, SafePredFlag);
|
||||
InitCPred("stop_low_level_trace", 0, p_stop_low_level_trace, SafePredFlag);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
@ -0,0 +1,352 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: unify.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: Unification and other auxiliary routines for absmi *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
int
|
||||
IUnify_complex(register CELL *pt0, register CELL *pt0_end,
|
||||
register CELL *pt1
|
||||
)
|
||||
{
|
||||
#if SHADOW_REGS
|
||||
#if defined(B) || defined(TR)
|
||||
register REGSTORE *regp = ®S;
|
||||
|
||||
#define REGS (*regp)
|
||||
#endif /* defined(B) || defined(TR) || defined(HB) */
|
||||
#endif
|
||||
|
||||
#if SHADOW_HB
|
||||
register CELL *HBREG = HB;
|
||||
#endif /* SHADOW_HB */
|
||||
|
||||
CELL **to_visit = (CELL **)H;
|
||||
|
||||
loop:
|
||||
while (pt0 < pt0_end) {
|
||||
register CELL *ptd0 = pt0+1;
|
||||
register CELL d0;
|
||||
|
||||
++pt1;
|
||||
pt0 = ptd0;
|
||||
d0 = *ptd0;
|
||||
deref_head(d0, unify_comp_unk);
|
||||
unify_comp_nvar:
|
||||
{
|
||||
register CELL *ptd1 = pt1;
|
||||
register CELL d1 = *ptd1;
|
||||
|
||||
deref_head(d1, unify_comp_nvar_unk);
|
||||
unify_comp_nvar_nvar:
|
||||
if (d0 == d1)
|
||||
continue;
|
||||
if (IsPairTerm(d0)) {
|
||||
if (!IsPairTerm(d1)) {
|
||||
goto cufail;
|
||||
}
|
||||
#ifdef RATIONAL_TREES
|
||||
/* now link the two structures so that no one else will */
|
||||
/* come here */
|
||||
if (pt0 < pt1) {
|
||||
to_visit[0] = pt0;
|
||||
to_visit[1] = pt0_end;
|
||||
to_visit[2] = pt1;
|
||||
to_visit[3] = (CELL *)d0;
|
||||
to_visit += 4;
|
||||
*pt0 = d1;
|
||||
}
|
||||
else {
|
||||
to_visit[0] = pt1;
|
||||
to_visit[1] = pt1+(pt0_end-pt0);
|
||||
to_visit[2] = pt0;
|
||||
to_visit[3] = (CELL *)d1;
|
||||
to_visit += 4;
|
||||
*pt1 = d0;
|
||||
}
|
||||
#else
|
||||
/* store the terms to visit */
|
||||
if (pt0 < pt0_end) {
|
||||
to_visit[0] = pt0;
|
||||
to_visit[1] = pt0_end;
|
||||
to_visit[2] = pt1;
|
||||
to_visit += 3;
|
||||
}
|
||||
|
||||
#endif
|
||||
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
|
||||
pt1 = RepPair(d1) - 1;
|
||||
continue;
|
||||
}
|
||||
if (IsApplTerm(d0)) {
|
||||
register Functor f;
|
||||
register CELL *ap2, *ap3;
|
||||
|
||||
if (!IsApplTerm(d1)) {
|
||||
goto cufail;
|
||||
}
|
||||
/* store the terms to visit */
|
||||
ap2 = RepAppl(d0);
|
||||
ap3 = RepAppl(d1);
|
||||
f = (Functor) (*ap2);
|
||||
/* compare functors */
|
||||
if (f != (Functor) *ap3)
|
||||
goto cufail;
|
||||
if (IsExtensionFunctor(f)) {
|
||||
if (unify_extension(f, d0, ap2, d1))
|
||||
continue;
|
||||
goto cufail;
|
||||
}
|
||||
#ifdef RATIONAL_TREES
|
||||
/* now link the two structures so that no one else will */
|
||||
/* come here */
|
||||
if (pt0 < pt1) {
|
||||
to_visit[0] = pt0;
|
||||
to_visit[1] = pt0_end;
|
||||
to_visit[2] = pt1;
|
||||
to_visit[3] = (CELL *)d0;
|
||||
to_visit += 4;
|
||||
*pt0 = d1;
|
||||
}
|
||||
else {
|
||||
to_visit[0] = pt1;
|
||||
to_visit[1] = pt1+(pt0_end-pt0);
|
||||
to_visit[2] = pt0;
|
||||
to_visit[3] = (CELL *)d1;
|
||||
to_visit += 4;
|
||||
*pt1 = d0;
|
||||
}
|
||||
#else
|
||||
/* store the terms to visit */
|
||||
if (pt0 < pt0_end) {
|
||||
to_visit[0] = pt0;
|
||||
to_visit[1] = pt0_end;
|
||||
to_visit[2] = pt1;
|
||||
to_visit += 3;
|
||||
}
|
||||
#endif
|
||||
d0 = ArityOfFunctor(f);
|
||||
pt0 = ap2;
|
||||
pt0_end = ap2 + d0;
|
||||
pt1 = ap3;
|
||||
continue;
|
||||
}
|
||||
goto cufail;
|
||||
|
||||
derefa_body(d1, ptd1, unify_comp_nvar_unk, unify_comp_nvar_nvar);
|
||||
/* d1 and pt2 have the unbound value, whereas d0 is bound */
|
||||
Bind_Global(ptd1, d0, bind_unify1);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(ptd1, d0);
|
||||
if (ptd1 < H0) WakeUp(ptd1);
|
||||
bind_unify1:
|
||||
#endif
|
||||
continue;
|
||||
}
|
||||
|
||||
derefa_body(d0, ptd0, unify_comp_unk, unify_comp_nvar);
|
||||
{
|
||||
register CELL d1;
|
||||
register CELL *ptd1;
|
||||
|
||||
d1 = pt1[0];
|
||||
/* pt2 is unbound */
|
||||
ptd1 = pt1;
|
||||
deref_head(d1, unify_comp_var_unk);
|
||||
unify_comp_var_nvar:
|
||||
/* pt2 is unbound and d1 is bound */
|
||||
Bind_Global(ptd0, d1, bind_unify2);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(ptd0, d1);
|
||||
if (ptd0 < H0) WakeUp(ptd0);
|
||||
bind_unify2:
|
||||
#endif
|
||||
continue;
|
||||
|
||||
{
|
||||
|
||||
derefa_body(d1, ptd1, unify_comp_var_unk, unify_comp_var_nvar);
|
||||
/* ptd0 and ptd1 are unbound */
|
||||
UnifyGlobalCells(ptd0, ptd1, ugc1, ugc2);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(ptd0, (CELL)ptd1);
|
||||
if (ptd0 < H0) WakeUp(ptd0);
|
||||
ugc1:
|
||||
#endif
|
||||
continue;
|
||||
#ifdef COROUTINING
|
||||
ugc2:
|
||||
DO_TRAIL(ptd1, (CELL)ptd0);
|
||||
if (ptd1 < H0) WakeUp(ptd1);
|
||||
continue;
|
||||
#endif
|
||||
}
|
||||
}
|
||||
}
|
||||
/* Do we still have compound terms to visit */
|
||||
if (to_visit > (CELL **) H) {
|
||||
#ifdef RATIONAL_TREES
|
||||
to_visit -= 4;
|
||||
pt0 = to_visit[0];
|
||||
pt0_end = to_visit[1];
|
||||
pt1 = to_visit[2];
|
||||
*pt0 = (CELL)to_visit[3];
|
||||
#else
|
||||
to_visit -= 3;
|
||||
pt0 = to_visit[0];
|
||||
pt0_end = to_visit[1];
|
||||
pt1 = to_visit[2];
|
||||
#endif
|
||||
goto loop;
|
||||
}
|
||||
return (TRUE);
|
||||
|
||||
cufail:
|
||||
#ifdef RATIONAL_TREES
|
||||
/* failure */
|
||||
while (to_visit > (CELL **) H) {
|
||||
CELL *pt0;
|
||||
to_visit -= 4;
|
||||
pt0 = to_visit[0];
|
||||
*pt0 = (CELL)to_visit[3];
|
||||
}
|
||||
#endif
|
||||
return (FALSE);
|
||||
#if SHADOW_REGS
|
||||
#if defined(B) || defined(TR)
|
||||
#undef REGS
|
||||
#endif /* defined(B) || defined(TR) */
|
||||
#endif
|
||||
}
|
||||
|
||||
int
|
||||
IUnify(register CELL d0, register CELL d1)
|
||||
{
|
||||
#if SHADOW_REGS
|
||||
#if defined(B) || defined(TR)
|
||||
register REGSTORE *regp = ®S;
|
||||
|
||||
#define REGS (*regp)
|
||||
#endif /* defined(B) || defined(TR) */
|
||||
#endif
|
||||
|
||||
#if SHADOW_HB
|
||||
register CELL *HBREG = HB;
|
||||
#endif
|
||||
|
||||
register CELL *pt0, *pt1;
|
||||
|
||||
deref_head(d0, unify_unk);
|
||||
|
||||
unify_nvar:
|
||||
/* d0 is bound */
|
||||
deref_head(d1, unify_nvar_unk);
|
||||
unify_nvar_nvar:
|
||||
/* both arguments are bound */
|
||||
if (d0 == d1)
|
||||
return (TRUE);
|
||||
if (IsPairTerm(d0)) {
|
||||
if (!IsPairTerm(d1)) {
|
||||
return (FALSE);
|
||||
}
|
||||
pt0 = RepPair(d0);
|
||||
pt1 = RepPair(d1);
|
||||
return (IUnify_complex(pt0 - 1, pt0 + 1, pt1 - 1));
|
||||
}
|
||||
else if (IsApplTerm(d0)) {
|
||||
pt0 = RepAppl(d0);
|
||||
d0 = *pt0;
|
||||
if (!IsApplTerm(d1))
|
||||
return (FALSE);
|
||||
pt1 = RepAppl(d1);
|
||||
d1 = *pt1;
|
||||
if (d0 != d1) {
|
||||
return (FALSE);
|
||||
} else {
|
||||
if (IsExtensionFunctor((Functor)d0)) {
|
||||
switch(d0) {
|
||||
case (CELL)FunctorDBRef:
|
||||
return(pt0 == pt1);
|
||||
case (CELL)FunctorLongInt:
|
||||
return(pt0[1] == pt1[1]);
|
||||
case (CELL)FunctorDouble:
|
||||
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
|
||||
#ifdef USE_GMP
|
||||
case (CELL)FunctorBigInt:
|
||||
return(mpz_cmp(BigIntOfTerm(AbsAppl(pt0)),BigIntOfTerm(AbsAppl(pt0))) == 0);
|
||||
#endif /* USE_GMP */
|
||||
default:
|
||||
return(FALSE);
|
||||
}
|
||||
}
|
||||
return (IUnify_complex(pt0, pt0 + ArityOfFunctor((Functor) d0),
|
||||
pt1));
|
||||
}
|
||||
} else {
|
||||
return (FALSE);
|
||||
}
|
||||
|
||||
deref_body(d1, pt1, unify_nvar_unk, unify_nvar_nvar);
|
||||
/* d0 is bound and d1 is unbound */
|
||||
Bind(pt1, d0, bind_unify3);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(pt1, d0);
|
||||
if (pt1 < H0) WakeUp(pt1);
|
||||
bind_unify3:
|
||||
#endif
|
||||
return (TRUE);
|
||||
|
||||
deref_body(d0, pt0, unify_unk, unify_nvar);
|
||||
/* pt0 is unbound */
|
||||
deref_head(d1, unify_var_unk);
|
||||
unify_var_nvar:
|
||||
/* pt0 is unbound and d1 is bound */
|
||||
Bind(pt0, d1, bind_unify4);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(pt0, d1);
|
||||
if (pt0 < H0) WakeUp(pt0);
|
||||
bind_unify4:
|
||||
#endif
|
||||
return (TRUE);
|
||||
|
||||
#if TRAILING_REQUIRES_BRANCH
|
||||
unify_var_nvar_trail:
|
||||
DO_TRAIL(pt0);
|
||||
return (TRUE);
|
||||
#endif
|
||||
|
||||
deref_body(d1, pt1, unify_var_unk, unify_var_nvar);
|
||||
/* d0 and pt1 are unbound */
|
||||
UnifyCells(pt0, pt1, uc1, uc2);
|
||||
#ifdef COROUTINING
|
||||
DO_TRAIL(pt0, (CELL)pt1);
|
||||
if (pt0 < H0) WakeUp(pt0);
|
||||
uc1:
|
||||
#endif
|
||||
return (TRUE);
|
||||
#ifdef COROUTINING
|
||||
uc2:
|
||||
DO_TRAIL(pt1, (CELL)pt0);
|
||||
if (pt1 < H0) {
|
||||
WakeUp(pt1);
|
||||
}
|
||||
return (TRUE);
|
||||
#endif
|
||||
#if SHADOW_REGS
|
||||
#if defined(B) || defined(TR)
|
||||
#undef REGS
|
||||
#endif /* defined(B) || defined(TR) */
|
||||
#endif
|
||||
}
|
||||
|
|
@ -0,0 +1,734 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: userpreds.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: an entry for user defined predicates *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
/*
|
||||
* This file is an entry for user defined C-predicates.
|
||||
*
|
||||
* There are two sorts of C-Predicates: deterministic - which should be defined
|
||||
* in the function InitUserCPreds().
|
||||
*
|
||||
* backtrackable - they include a start and a continuation function, the first
|
||||
* one called by the first invocation, the last one called after a fail. This
|
||||
* can be seen as: pred :- init ; repeat, cont. These predicates should be
|
||||
* defined in the function InitUserBacks()
|
||||
*
|
||||
* These two functions are called after any "restore" operation.
|
||||
*
|
||||
* The function InitUserExtensions() is called once, when starting the execution
|
||||
* of the program, and should be used to initialize any user-defined
|
||||
* extensions (like the execution environment or interfaces to other
|
||||
* programs).
|
||||
*
|
||||
*/
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#if EUROTRA
|
||||
#include "yapio.h"
|
||||
#if HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
#endif
|
||||
|
||||
/* You should include here the prototypes for all static functions */
|
||||
|
||||
#ifdef EUROTRA
|
||||
STATIC_PROTO(int p_clean, (void));
|
||||
STATIC_PROTO(int p_namelength, (void));
|
||||
STATIC_PROTO(int p_getpid, (void));
|
||||
STATIC_PROTO(int p_exit, (void));
|
||||
STATIC_PROTO(int p_incrcounter, (void));
|
||||
STATIC_PROTO(int p_setcounter, (void));
|
||||
STATIC_PROTO(int p_trapsignal, (void));
|
||||
STATIC_PROTO(int subsumes, (Term, Term));
|
||||
STATIC_PROTO(int p_subsumes, (void));
|
||||
STATIC_PROTO(int p_grab_tokens, (void));
|
||||
/* int PlGetchar(Int *); */
|
||||
#endif
|
||||
#ifdef MACYAP
|
||||
STATIC_PROTO(typedef int, (*SignalProc) ());
|
||||
STATIC_PROTO(SignalProc skel_signal, (int, SignalProc));
|
||||
STATIC_PROTO(int chdir, (char *));
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef SFUNC
|
||||
STATIC_PROTO(int p_softfunctor, (void));
|
||||
#endif /* SFUNC */
|
||||
|
||||
|
||||
|
||||
#ifdef USERPREDS
|
||||
/* These are some examples of user-defined functions */
|
||||
|
||||
/*
|
||||
* unify(A,B) --> unification with occurs-check it uses the functions
|
||||
* full_unification and occurs_in
|
||||
*
|
||||
* occurs_check(V,S) :- var(S), !, S \== V. occurs_check(V,S) :- primitive(S),
|
||||
* !. occurs_check(V,[H|T]) :- !, occurs_check(V,H), occurs_check(V,T).
|
||||
* occurs_check(V,St) :- functor(T,_,N), occurs_check_struct(N,V,St).
|
||||
*
|
||||
* occurs_check_struct(1,V,T) :- !, arg(1,T,A), occurs_check(V,A).
|
||||
* occurs_check_struct(N,V,T) :- N1 is N-1, occurs_check_structure(N1,V,T),
|
||||
* arg(N,T,A), occurs_check(V,A).
|
||||
*
|
||||
* unify(X,Y) :- var(X), var(Y), !, X = Y. unify(X,Y) :- var(X), !,
|
||||
* occurs_check(X,Y), X = Y. unify(X,Y) :- var(Y), !, occurs_check(Y,X), X =
|
||||
* Y. unify([H0|T0],[H1|T1]) :- !, unify(H0,H1), unify(T0,T1). unify(X,Y) :-
|
||||
* functor(X,A,N), functor(Y,A,N), unify_structs(N,X,Y).
|
||||
*
|
||||
* unify_structs(1,X,Y) :- !, arg(1,X,A), arg(1,Y,B), unify(A,B).
|
||||
* unify_structs(N,Y,Z) :- N1 is N-1, unify_structs(N1,X,Y), arg(N,X,A),
|
||||
* arg(N,Y,B), unify(A,B).
|
||||
*/
|
||||
|
||||
/* occurs-in --> checks if the variable V occurs in term S */
|
||||
|
||||
static int
|
||||
occurs_check(V, T)
|
||||
Term V, T;
|
||||
{
|
||||
/* V and S are always derefed */
|
||||
if (IsVarTerm(T)) {
|
||||
return (V != T);
|
||||
} else if (IsPrimitiveTerm(T)) {
|
||||
return (TRUE);
|
||||
} else if (IsPairTerm(T)) {
|
||||
return (occurs_check(V, HeadOfTerm(T))
|
||||
&& occurs_check(V, TailOfTerm(T)));
|
||||
} else if (IsApplTerm(T)) {
|
||||
unsigned int i;
|
||||
unsigned int arity = ArityOfFunctor(FunctorOfTerm(T));
|
||||
|
||||
for (i = 1; i <= arity; ++i)
|
||||
if (!occurs_check(V, ArgOfTerm(i, T)))
|
||||
return (FALSE);
|
||||
return (TRUE);
|
||||
}
|
||||
return (FALSE);
|
||||
}
|
||||
|
||||
/*
|
||||
If you worry about coroutining the routine must receive the
|
||||
arguments before dereferencing, otherwise unify() won't be
|
||||
to wake possible bound variables
|
||||
*/
|
||||
static int
|
||||
full_unification(T1, T2)
|
||||
Term T1, T2;
|
||||
{
|
||||
Term t1 = Deref(T1);
|
||||
Term t2 = Deref(T2);
|
||||
if (IsVarTerm(t1)) { /* Testing for variables should be done first */
|
||||
if (IsVarTerm(t2) || IsPrimitiveTerm(t2))
|
||||
return (unify(T1, t2));
|
||||
if (occurs_check(t1, t2))
|
||||
return (unify(T1, t2));
|
||||
return (FALSE);
|
||||
}
|
||||
if (IsVarTerm(t2)) {
|
||||
if (occurs_check(t2, t1))
|
||||
return (unify(T2, t1));
|
||||
return (FALSE);
|
||||
}
|
||||
if (IsPrimitiveTerm(t1)) {
|
||||
if (IsFloatTerm(t1))
|
||||
return(IsFloatTerm(t2) && FloatOfTerm(t1) == FloatOfTerm(t2));
|
||||
else if (IsRefTerm(t1))
|
||||
return(IsRefTerm(t2) && RefOfTerm(t1) == RefOfTerm(t2));
|
||||
if (IsLongIntTerm(t1))
|
||||
return(IsLongIntTerm(t2) && LongIntOfTerm(t1) == LongIntOfTerm(t2));
|
||||
else
|
||||
return (t1 == t2);
|
||||
}
|
||||
if (IsPairTerm(t1)) {
|
||||
if (!IsPairTerm(t2))
|
||||
return (FALSE);
|
||||
return (full_unification(HeadOfTermCell(t1), HeadOfTermCell(t2)) &&
|
||||
full_unification(TailOfTermCell(t1), TailOfTermCell(t2)));
|
||||
}
|
||||
if (IsApplTerm(t1)) {
|
||||
unsigned int i, arity;
|
||||
if (!IsApplTerm(t2))
|
||||
return (FALSE);
|
||||
if (FunctorOfTerm(t1) != FunctorOfTerm(t2))
|
||||
return (FALSE);
|
||||
arity = ArityOfFunctor(FunctorOfTerm(t1));
|
||||
for (i = 1; i <= arity; ++i)
|
||||
if (!full_unification(ArgOfTermCell(i, t1), ArgOfTerm(i, t2)))
|
||||
return (FALSE);
|
||||
return (TRUE);
|
||||
}
|
||||
#ifdef lint
|
||||
return (FALSE);
|
||||
#endif
|
||||
}
|
||||
|
||||
static int
|
||||
p_occurs_check()
|
||||
{ /* occurs_check(?,?) */
|
||||
return (occurs_check(Deref(ARG1), Deref(DARG2)));
|
||||
}
|
||||
|
||||
/* Out of date, use unify_with_occurs_check instead*/
|
||||
static int
|
||||
p_unify()
|
||||
{ /* unify(?,?) */
|
||||
/* routines that perform unification must receive the original arguments */
|
||||
return (full_unification(ARG1, ARG2));
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* One example of a counter using the atom value functions counter(Atom,M,N)
|
||||
*
|
||||
* If the second argument is uninstantiated, then it will be unified with the
|
||||
* current value of the counter, otherwyse the counter will be set to its
|
||||
* value. The third argument then be unified with the next integer, which
|
||||
* will become the current counter value.
|
||||
*/
|
||||
static int
|
||||
p_counter()
|
||||
{ /* counter(+Atom,?Number,?Next) */
|
||||
Term TCount, TNext, T1, T2;
|
||||
Atom a;
|
||||
/* Int -> an YAP integer */
|
||||
Int val;
|
||||
T1 = Deref(ARG1);
|
||||
ARG2 = Deref(ARG2);
|
||||
|
||||
/* No need to deref ARG3, we don't want to know what's in there */
|
||||
if (IsVarTerm(T1) || !IsAtomTerm(T1))
|
||||
return (FALSE);
|
||||
a = AtomOfTerm(T1);
|
||||
if (IsVarTerm(T2)) {
|
||||
TCount = GetValue(a);
|
||||
if (!IsIntTerm(TCount))
|
||||
return (FALSE);
|
||||
unify_constant(ARG2, TCount); /* always succeeds */
|
||||
val = IntOfTerm(TCount);
|
||||
} else {
|
||||
if (!IsIntTerm(T2))
|
||||
return (FALSE);
|
||||
val = IntOfTerm(T2);
|
||||
}
|
||||
val++;
|
||||
/* The atom will now take the incremented value */
|
||||
PutValue(a, TNext = MkIntTerm(val));
|
||||
return (unify_constant(ARG3, TNext));
|
||||
}
|
||||
|
||||
/*
|
||||
* Concatenate an instantiated list to another list, and unify with third
|
||||
* argument
|
||||
*/
|
||||
|
||||
/*
|
||||
* In order to be more efficient, iconcat instead of unifying the terms in
|
||||
* the old structure with the ones in the new one just copies them. This is a
|
||||
* dangerous behaviour, though acceptable in this case, and you should try to
|
||||
* avoid it whenever possible
|
||||
*/
|
||||
#ifdef COMMENT
|
||||
static int
|
||||
p_iconcat()
|
||||
{ /* iconcat(+L1,+L2,-L) */
|
||||
Term Tkeep[1025]; /* Will do it just for lists less
|
||||
* than 1024 elements long */
|
||||
register Term *Tkp = Tkeep;
|
||||
register Term L0, L1;
|
||||
Term T2;
|
||||
|
||||
L0 = Deref(ARG1);
|
||||
*Tkp++ = Unsigned(0);
|
||||
L1 = TermNil;
|
||||
while (L0 != L1) {
|
||||
/*
|
||||
* Usually you should test if L1 a var, if (!IsPairTerm(L0))
|
||||
* return(FALSE);
|
||||
*/
|
||||
*Tkp++ = HeadOfTerm(L0);
|
||||
L0 = TailOfTerm(L0);
|
||||
}
|
||||
L1 = Deref(ARG2);
|
||||
while (L0 = *--Tkp)
|
||||
L1 = MkPairTerm(L0, L1);
|
||||
T2 = L1;
|
||||
return (unify(T2, ARG3));
|
||||
}
|
||||
#endif /* COMMENT */
|
||||
|
||||
static int
|
||||
p_iconcat()
|
||||
{ /* iconcat(+L1,+L2,-L) */
|
||||
register Term *Tkp = H, *tp;
|
||||
register Term L0, L1;
|
||||
Term T2;
|
||||
|
||||
L0 = Deref(ARG1);
|
||||
L1 = TermNil;
|
||||
while (L0 != L1) {
|
||||
/* if (!IsPairTerm(L0)) return(FALSE); */
|
||||
tp = Tkp;
|
||||
*tp = AbsPair(++Tkp);
|
||||
*Tkp++ = HeadOfTerm(L0);
|
||||
L0 = TailOfTerm(L0);
|
||||
}
|
||||
*Tkp++ = Deref(ARG2);
|
||||
T2 = *H;
|
||||
H = Tkp;
|
||||
return (unify(T2, ARG3));
|
||||
}
|
||||
|
||||
#endif /* USERPREDS */
|
||||
|
||||
#ifdef EUROTRA
|
||||
|
||||
static int
|
||||
p_clean() /* predicate clean for ets */
|
||||
/*
|
||||
* clean(FB,CFB) :- FB =.. [fb|L],!, clean1(L,CL), CFB =.. [fb|CL].
|
||||
* clean(FB,CFB) :- var(FB).
|
||||
*
|
||||
* clean1([],[]) :- !. clean1([H|T],[CH|CT]) :- H==$u,!, clean1(T,CT).
|
||||
* clean1([H|T],[H|CT]) :- clean1(T,CT).
|
||||
*/
|
||||
{
|
||||
unsigned int arity, i;
|
||||
Term t, Args[255];
|
||||
Term t1 = Deref(ARG1);
|
||||
|
||||
if (IsVarTerm(t1))
|
||||
return (TRUE);
|
||||
if (!(IsApplTerm(t1)
|
||||
&& NameOfFunctor(FunctorOfTerm(t1)) == AtomFB))
|
||||
return (FALSE);
|
||||
arity = ArityOfFunctor(FunctorOfTerm(t1));
|
||||
#ifdef SFUNC
|
||||
if (arity == SFArity) {
|
||||
CELL *pt = H, *ntp = ArgsOfSFTerm(t1);
|
||||
Term tn = AbsAppl(H);
|
||||
*pt++ = FunctorOfTerm(t1);
|
||||
RESET_VARIABLE(pt);
|
||||
pt++;
|
||||
while (*pt++ = *ntp++)
|
||||
if ((*pt++ = *ntp++) == MkAtomTerm(AtomDollarUndef))
|
||||
pt -= 2;
|
||||
H = pt;
|
||||
return (unify(tn, ARG2));
|
||||
}
|
||||
#endif
|
||||
for (i = 1; i <= arity; ++i) {
|
||||
if ((t = ArgOfTerm(i, t1)) == TermDollarU)
|
||||
t = MkVarTerm();
|
||||
Args[i - 1] = t;
|
||||
}
|
||||
t = MkApplTerm(FunctorOfTerm(t1), arity, Args);
|
||||
return (unify(ARG2, t));
|
||||
}
|
||||
|
||||
static Term *subs_table;
|
||||
static int subs_entries;
|
||||
#define SUBS_TABLE_SIZE 500
|
||||
|
||||
static int
|
||||
subsumes(T1, T2)
|
||||
Term T1, T2;
|
||||
{
|
||||
int i;
|
||||
|
||||
if (IsVarTerm(T1)) {
|
||||
if (!IsVarTerm(T2))
|
||||
return (FALSE);
|
||||
if (T1 == T2)
|
||||
return (TRUE);
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == T2)
|
||||
return (FALSE);
|
||||
if (T2 < T1) { /* T1 gets instantiated with T2 */
|
||||
unify(T1, T2);
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == T1) {
|
||||
subs_table[i] = T2;
|
||||
return (TRUE);
|
||||
}
|
||||
subs_table[subs_entries++] = T2;
|
||||
return (TRUE);
|
||||
}
|
||||
/* T2 gets instantiated with T1 */
|
||||
unify(T1, T2);
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == T1)
|
||||
return (TRUE);
|
||||
subs_table[subs_entries++] = T1;
|
||||
return (TRUE);
|
||||
}
|
||||
if (IsVarTerm(T2)) {
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == T2)
|
||||
return (FALSE);
|
||||
return (unify(T1, T2));
|
||||
}
|
||||
if (IsPrimitiveTerm(T1)) {
|
||||
if (IsFloatTerm(T1))
|
||||
return(IsFloatTerm(T2) && FloatOfTerm(T1) == FloatOfTerm(T2));
|
||||
else if (IsRefTerm(T1))
|
||||
return(IsRefTerm(T2) && RefOfTerm(T1) == RefOfTerm(T2));
|
||||
else if (IsLongIntTerm(T1))
|
||||
return(IsLongIntTerm(T2) && LongIntOfTerm(T1) == LongIntOfTerm(T2));
|
||||
else
|
||||
return (T1 == T2);
|
||||
}
|
||||
if (IsPairTerm(T1)) {
|
||||
if (!IsPairTerm(T2))
|
||||
return (FALSE);
|
||||
return (subsumes(HeadOfTerm(T1), HeadOfTerm(T2)) &&
|
||||
subsumes(TailOfTerm(T1), TailOfTerm(T2)));
|
||||
}
|
||||
if (IsApplTerm(T1)) {
|
||||
int arity;
|
||||
if (!IsApplTerm(T2))
|
||||
return (FALSE);
|
||||
if (FunctorOfTerm(T1) != FunctorOfTerm(T2))
|
||||
return (FALSE);
|
||||
arity = ArityOfFunctor(FunctorOfTerm(T1));
|
||||
#ifdef SFUNC
|
||||
if (arity == SFArity) {
|
||||
CELL *a1a = ArgsOfSFTerm(T1), *a2a = ArgsOfSFTerm(T2);
|
||||
CELL *a1p = a1a - 1, *a2p = a2a - 1;
|
||||
CELL *pt = H;
|
||||
int flags = 0;
|
||||
Term t1, t2;
|
||||
*pt++ = FunctorOfTerm(T1);
|
||||
RESET_VARIABLE(pt);
|
||||
pt++;
|
||||
while (1) {
|
||||
if (*a2a < *a1a || *a1a == 0) {
|
||||
if (*a2a) {
|
||||
*pt++ = *a2a++;
|
||||
t2 = Derefa(a2a);
|
||||
++a2a;
|
||||
if (!IsVarTerm(t2))
|
||||
return (FALSE);
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == t2)
|
||||
return (FALSE);
|
||||
subs_table[subs_entries++] = t2;
|
||||
*pt++ = t2;
|
||||
flags |= 1;
|
||||
} else { /* T2 is finished */
|
||||
if ((flags & 1) == 0) { /* containned in first */
|
||||
*a2p = Unsigned(a1p - 1);
|
||||
if (a2p < HB)
|
||||
*TR++ = Unsigned(a2p);
|
||||
return (TRUE);
|
||||
}
|
||||
while ((*pt++ = *a1a++));
|
||||
*a1p = Unsigned(H);
|
||||
if (a1p < HB)
|
||||
*TR++ = Unsigned(a1p);
|
||||
*a2p = Unsigned(H);
|
||||
if (a2p < HB)
|
||||
*TR++ = Unsigned(a2p);
|
||||
H = pt;
|
||||
return (TRUE);
|
||||
}
|
||||
} else if (*a2a > *a1a || *a2a == 0) {
|
||||
*pt++ = *a1a++;
|
||||
t1 = Derefa(a1a);
|
||||
++a1a;
|
||||
if (IsVarTerm(t1)) {
|
||||
for (i = 0; i < subs_entries; ++i)
|
||||
if (subs_table[i] == t1)
|
||||
break;
|
||||
if (i >= subs_entries)
|
||||
subs_table[subs_entries++] = t1;
|
||||
}
|
||||
*pt++ = t1;
|
||||
flags |= 2;
|
||||
} else if (*a1a == *a2a) {
|
||||
*pt++ = *a1a++;
|
||||
++a2a;
|
||||
t1 = Derefa(a1a);
|
||||
++a1a;
|
||||
t2 = Derefa(a2a);
|
||||
++a2a;
|
||||
*pt++ = t1;
|
||||
if (!subsumes(t1, t2))
|
||||
return (FALSE);
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
for (i = 1; i <= arity; ++i)
|
||||
if (!subsumes(ArgOfTerm(i, T1), ArgOfTerm(i, T2)))
|
||||
return (FALSE);
|
||||
return (TRUE);
|
||||
}
|
||||
return (FALSE);
|
||||
}
|
||||
|
||||
static int
|
||||
p_subsumes()
|
||||
{
|
||||
Term work_space[SUBS_TABLE_SIZE];
|
||||
subs_table = work_space;
|
||||
subs_entries = 0;
|
||||
return (subsumes(Deref(ARG1), Deref(ARG2)));
|
||||
}
|
||||
|
||||
static int
|
||||
p_namelength()
|
||||
{
|
||||
register Term t = Deref(ARG1);
|
||||
Term tf;
|
||||
|
||||
if (IsVarTerm(t)) {
|
||||
return (FALSE);
|
||||
}
|
||||
if (IsAtomTerm(t)) {
|
||||
Term tf = MkIntTerm(strlen(RepAtom(AtomOfTerm(t))->StrOfAE));
|
||||
return (unify_constant(ARG2, tf));
|
||||
} else if (IsIntTerm(t)) {
|
||||
register int i = 1, k = IntOfTerm(t);
|
||||
if (k < 0)
|
||||
++i, k = -k;
|
||||
while (k > 10)
|
||||
++i, k /= 10;
|
||||
tf = MkIntTerm(i);
|
||||
return (unify_constant(ARG2, tf));
|
||||
} else
|
||||
return (FALSE);
|
||||
}
|
||||
|
||||
static int
|
||||
p_getpid()
|
||||
{
|
||||
#ifndef MPW
|
||||
Term t = MkIntTerm(getpid());
|
||||
#else
|
||||
Term t = MkIntTerm(1);
|
||||
#endif
|
||||
return (unify_constant(ARG1, t));
|
||||
}
|
||||
|
||||
static int
|
||||
p_exit()
|
||||
{
|
||||
register Term t = Deref(ARG1);
|
||||
if (IsVarTerm(t) || !IsIntTerm(t))
|
||||
return (FALSE);
|
||||
exit_yap((int) IntOfTerm(t), NIL);
|
||||
return(FALSE);
|
||||
}
|
||||
|
||||
static int current_pos;
|
||||
|
||||
static int
|
||||
p_incrcounter()
|
||||
{
|
||||
register Term t = Deref(ARG1);
|
||||
if (IsVarTerm(t) || !IsIntTerm(t))
|
||||
return (FALSE);
|
||||
current_pos += IntOfTerm(t);
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
static int
|
||||
p_setcounter()
|
||||
{
|
||||
register Term t = Deref(ARG1);
|
||||
if (IsVarTerm(t) || !IsIntTerm(t)) {
|
||||
return (unify_constant(ARG1, MkIntTerm(current_pos)));
|
||||
} else {
|
||||
current_pos = IntOfTerm(t);
|
||||
return (TRUE);
|
||||
}
|
||||
}
|
||||
|
||||
#include <signal.h>
|
||||
#ifdef MACYAP
|
||||
#define signal(A,B) skel_signal(A,B)
|
||||
#endif
|
||||
|
||||
#ifndef EOF
|
||||
#define EOF -1
|
||||
#endif
|
||||
|
||||
static int
|
||||
p_trapsignal(void)
|
||||
{
|
||||
#ifndef MPW
|
||||
signal(SIGINT, SIG_IGN);
|
||||
#endif
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
|
||||
#define varstarter(ch) ((ch>='A' && ch<='Z') || ch=='_')
|
||||
#define idstarter(ch) (ch>='a' && ch<='z')
|
||||
#define idchar(ch) ((ch>='0' && ch<='9') || (ch>='A' && ch<='Z') || \
|
||||
(ch>='a' && ch<='z') || ch=='_')
|
||||
|
||||
static int
|
||||
p_grab_tokens()
|
||||
{
|
||||
Term *p = ASP - 20, *p0, t;
|
||||
Atom IdAtom, VarAtom;
|
||||
Functor IdFunctor, VarFunctor;
|
||||
char ch, IdChars[255], *chp;
|
||||
|
||||
IdAtom = LookupAtom("id");
|
||||
IdFunctor = MkFunctor(IdAtom, 1);
|
||||
VarAtom = LookupAtom("var");
|
||||
VarFunctor = MkFunctor(VarAtom, 1);
|
||||
p0 = p;
|
||||
ch = PlGetchar();
|
||||
while (1) {
|
||||
while (ch <= ' ' && ch != EOF)
|
||||
ch = PlGetchar();
|
||||
if (ch == '.' || ch == EOF)
|
||||
break;
|
||||
if (ch == '%') {
|
||||
while ((ch = PlGetchar()) != 10);
|
||||
ch = PlGetchar();
|
||||
continue;
|
||||
}
|
||||
if (ch == '\'') {
|
||||
chp = IdChars;
|
||||
while (1) {
|
||||
ch = PlGetchar();
|
||||
if (ch == '\'')
|
||||
break;
|
||||
*chp++ = ch;
|
||||
}
|
||||
*chp = 0;
|
||||
t = MkAtomTerm(LookupAtom(IdChars));
|
||||
*p-- = MkApplTerm(IdFunctor, 1, &t);
|
||||
ch = PlGetchar();
|
||||
continue;
|
||||
|
||||
}
|
||||
if (varstarter(ch)) {
|
||||
chp = IdChars;
|
||||
*chp++ = ch;
|
||||
while (1) {
|
||||
ch = PlGetchar();
|
||||
if (!idchar(ch))
|
||||
break;
|
||||
*chp++ = ch;
|
||||
}
|
||||
*chp = 0;
|
||||
t = MkAtomTerm(LookupAtom(IdChars));
|
||||
*p-- = MkApplTerm(VarFunctor, 1, &t);
|
||||
continue;
|
||||
}
|
||||
if (idstarter(ch)) {
|
||||
chp = IdChars;
|
||||
*chp++ = ch;
|
||||
while (1) {
|
||||
ch = PlGetchar();
|
||||
if (!idchar(ch))
|
||||
break;
|
||||
*chp++ = ch;
|
||||
}
|
||||
*chp = 0;
|
||||
t = MkAtomTerm(LookupAtom(IdChars));
|
||||
*p-- = MkApplTerm(IdFunctor, 1, &t);
|
||||
continue;
|
||||
}
|
||||
IdChars[0] = ch;
|
||||
IdChars[1] = 0;
|
||||
*p-- = MkAtomTerm(LookupAtom(IdChars));
|
||||
ch = PlGetchar();
|
||||
}
|
||||
t = MkAtomTerm(AtomNil);
|
||||
while (p != p0) {
|
||||
t = MkPairTerm(*++p, t);
|
||||
}
|
||||
return (unify(ARG1, t));
|
||||
}
|
||||
|
||||
#endif /* EUROTRA */
|
||||
|
||||
#ifdef SFUNC
|
||||
|
||||
static
|
||||
p_softfunctor()
|
||||
{
|
||||
Term nilvalue = 0;
|
||||
SFEntry *pe;
|
||||
Prop p0;
|
||||
Atom a;
|
||||
Term t1 = Deref(ARG1);
|
||||
Term t2 = Deref(ARG2);
|
||||
|
||||
if (IsAtomTerm(t2))
|
||||
nilvalue = t2;
|
||||
if (!IsAtomTerm(t1))
|
||||
return (FALSE);
|
||||
a = AtomOfTerm(t1);
|
||||
WRITE_LOCK(RepAtom(a)->ARWLock);
|
||||
if ((p0 = GetAProp(a, SFProperty)) == NIL) {
|
||||
pe = (SFEntry *) AllocAtomSpace(sizeof(*pe));
|
||||
pe->NextOfPE = RepAtom(a)->PropOfAE;
|
||||
pe->KindOfPE = SFProperty;
|
||||
RepAtom(a)->PropOfAE = AbsSFProp(pe);
|
||||
} else
|
||||
pe = RepSFProp(p0);
|
||||
WRITE_UNLOCK(RepAtom(a)->ARWLock);
|
||||
pe->NilValue = nilvalue;
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
#endif /* SFUNC */
|
||||
|
||||
void
|
||||
InitUserCPreds(void)
|
||||
{
|
||||
#ifdef XINTERFACE
|
||||
InitXPreds();
|
||||
#endif
|
||||
#ifdef EUROTRA
|
||||
InitCPred("clean", 2, p_clean, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("name_length", 2, p_namelength, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("get_pid", 1, p_getpid, SafePredFlag);
|
||||
InitCPred("exit", 1, p_exit, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("incr_counter", 1, p_incrcounter, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("set_counter", 1, p_setcounter, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("trap_signal", 0, p_trapsignal, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("mark2_grab_tokens", 1, p_grab_tokens, SafePredFlag|SyncPredFlag);
|
||||
InitCPred("subsumes", 2, p_subsumes, SafePredFlag);
|
||||
#endif
|
||||
#ifdef SFUNC
|
||||
InitCPred("sparse_functor", 2, p_softfunctor, SafePredFlag);
|
||||
#endif /* SFUNC */
|
||||
/* InitCPred("unify",2,p_unify,SafePredFlag); */
|
||||
/* InitCPred("occurs_check",2,p_occurs_check,SafePredFlag); */
|
||||
/* InitCPred("counter",3,p_counter,SafePredFlag); */
|
||||
/* InitCPred("iconcat",3,p_iconcat,SafePredFlag); */
|
||||
}
|
||||
|
||||
void
|
||||
InitUserBacks(void)
|
||||
{
|
||||
}
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,654 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog *
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: write.c *
|
||||
* Last rev: *
|
||||
* mods: *
|
||||
* comments: Writing a Prolog Term *
|
||||
* *
|
||||
*************************************************************************/
|
||||
#ifdef SCCS
|
||||
static char SccsId[] = "%W% %G%";
|
||||
#endif
|
||||
|
||||
#include "Yap.h"
|
||||
#include "Yatom.h"
|
||||
#include "Heap.h"
|
||||
#include "yapio.h"
|
||||
#if DEBUG
|
||||
#if COROUTINING
|
||||
#include "attvar.h"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#if HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
#if HAVE_CTYPE_H
|
||||
#include <ctype.h>
|
||||
#endif
|
||||
|
||||
/* describe the type of the previous term to have been written */
|
||||
typedef enum {
|
||||
separator, /* the previous term was a separator like ',', ')', ... */
|
||||
alphanum, /* the previous term was an atom or number */
|
||||
symbol /* the previous term was a symbol like +, -, *, .... */
|
||||
} wtype;
|
||||
|
||||
static wtype lastw;
|
||||
|
||||
STATIC_PROTO(void wrputn, (Int));
|
||||
STATIC_PROTO(void wrputs, (char *));
|
||||
STATIC_PROTO(void wrputf, (Float));
|
||||
STATIC_PROTO(void wrputref, (CODEADDR));
|
||||
STATIC_PROTO(int legalAtom, (char *));
|
||||
STATIC_PROTO(int LeftOpToProtect, (Atom, int));
|
||||
STATIC_PROTO(int RightOpToProtect, (Atom, int));
|
||||
STATIC_PROTO(wtype AtomIsSymbols, (char *));
|
||||
STATIC_PROTO(void putAtom, (Atom));
|
||||
STATIC_PROTO(void writeTerm, (Term, int, int, int));
|
||||
|
||||
static int (*writech) (int, int);
|
||||
static int Quote_illegal, Ignore_ops, Handle_vars, Use_portray;
|
||||
|
||||
|
||||
#define Quote_illegal_f 1
|
||||
#define Ignore_ops_f 2
|
||||
#define Handle_vars_f 4
|
||||
#define Use_portray_f 8
|
||||
|
||||
#if DEBUG
|
||||
#if COROUTINING
|
||||
int Portray_delays = FALSE;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#define wrputc(X) ((*writech)(c_output_stream,X)) /* writes a character */
|
||||
|
||||
static void
|
||||
wrputn(Int n) /* writes an integer */
|
||||
|
||||
{
|
||||
char s[256], *s1=s; /* that should be enough for most integers */
|
||||
if (n < 0) {
|
||||
if (lastw == symbol)
|
||||
wrputc(' ');
|
||||
} else {
|
||||
if (lastw == alphanum)
|
||||
wrputc(' ');
|
||||
}
|
||||
#if HAVE_SNPRINTF
|
||||
#if SHORT_INTS
|
||||
snprintf(s, 256, "%ld", n);
|
||||
#else
|
||||
snprintf(s, 256, "%d", n);
|
||||
#endif
|
||||
#else
|
||||
#if SHORT_INTS
|
||||
sprintf(s, "%ld", n);
|
||||
#else
|
||||
sprintf(s, "%d", n);
|
||||
#endif
|
||||
#endif
|
||||
while (*s1)
|
||||
wrputc(*s1++);
|
||||
lastw = alphanum;
|
||||
}
|
||||
|
||||
static void
|
||||
wrputs(char *s) /* writes a string */
|
||||
{
|
||||
while (*s)
|
||||
wrputc(*s++);
|
||||
}
|
||||
|
||||
static void
|
||||
wrputf(Float f) /* writes a float */
|
||||
|
||||
{
|
||||
char s[255], *pt = s, ch;
|
||||
|
||||
if (f < 0) {
|
||||
if (lastw == symbol)
|
||||
wrputc(' ');
|
||||
} else {
|
||||
if (lastw == alphanum)
|
||||
wrputc(' ');
|
||||
}
|
||||
lastw = alphanum;
|
||||
sprintf(s, "%.6g", f);
|
||||
while (*pt == ' ')
|
||||
pt++;
|
||||
wrputs(pt);
|
||||
if (*pt == '-') pt++;
|
||||
while ((ch = *pt) != '\0') {
|
||||
if (ch < '0' || ch > '9')
|
||||
return;
|
||||
pt++;
|
||||
}
|
||||
wrputs(".0");
|
||||
}
|
||||
|
||||
static void
|
||||
wrputref(CODEADDR ref) /* writes a data base reference */
|
||||
|
||||
{
|
||||
char s[256];
|
||||
|
||||
#if SHORT_INTS
|
||||
sprintf(s, "0x%p", ref);
|
||||
#else
|
||||
#ifdef linux
|
||||
sprintf(s, "%p", ref);
|
||||
#else
|
||||
sprintf(s, "0x%p", ref);
|
||||
#endif
|
||||
#endif
|
||||
wrputs(s);
|
||||
lastw = alphanum;
|
||||
}
|
||||
|
||||
static int
|
||||
legalAtom(char *s) /* Is this a legal atom ? */
|
||||
|
||||
{
|
||||
register int ch = *s;
|
||||
if (ch == '\0')
|
||||
return(FALSE);
|
||||
if (chtype[ch] != LC) {
|
||||
if (ch == '[')
|
||||
return (*++s == ']' && !(*++s));
|
||||
else if (ch == '{')
|
||||
return (*++s == '}' && !(*++s));
|
||||
else if (chtype[ch] == SL)
|
||||
return (!*++s);
|
||||
else if ((ch == ',' || ch == '.') && !s[1])
|
||||
return (FALSE);
|
||||
else
|
||||
while (ch) {
|
||||
if (chtype[ch] != SY) return (FALSE);
|
||||
ch = *++s;
|
||||
}
|
||||
return (TRUE);
|
||||
} else
|
||||
while ((ch = *++s) != 0)
|
||||
if (chtype[ch] > NU)
|
||||
return (FALSE);
|
||||
return (TRUE);
|
||||
}
|
||||
|
||||
static int LeftOpToProtect(Atom at, int p)
|
||||
{
|
||||
int op, rp;
|
||||
Prop opinfo = GetAProp(at, OpProperty);
|
||||
return(opinfo && IsPrefixOp(opinfo, &op, &rp) );
|
||||
}
|
||||
|
||||
static int RightOpToProtect(Atom at, int p)
|
||||
{
|
||||
int op, lp;
|
||||
Prop opinfo = GetAProp(at, OpProperty);
|
||||
return(opinfo && IsPosfixOp(opinfo, &op, &lp) );
|
||||
}
|
||||
|
||||
static wtype
|
||||
AtomIsSymbols(char *s) /* Is this atom just formed by symbols ? */
|
||||
{
|
||||
int ch;
|
||||
if (chtype[(int)s[0]] == SL && s[1] == '\0')
|
||||
return(separator);
|
||||
while ((ch = *s++) != '\0') {
|
||||
if (chtype[ch] != SY)
|
||||
return(alphanum);
|
||||
}
|
||||
return(symbol);
|
||||
}
|
||||
|
||||
static void
|
||||
putAtom(Atom atom) /* writes an atom */
|
||||
|
||||
{
|
||||
char *s = RepAtom(atom)->StrOfAE;
|
||||
wtype atom_or_symbol = AtomIsSymbols(s);
|
||||
|
||||
if (lastw == atom_or_symbol && atom_or_symbol != separator /* solo */)
|
||||
wrputc(' ');
|
||||
lastw = atom_or_symbol;
|
||||
if (!legalAtom(s) && Quote_illegal) {
|
||||
wrputc('\'');
|
||||
while (*s) {
|
||||
int ch = *s++;
|
||||
wrputc(ch);
|
||||
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
|
||||
wrputc('\\'); /* be careful about backslashes */
|
||||
else if (ch == '\'')
|
||||
wrputc('\''); /* be careful about quotes */
|
||||
}
|
||||
wrputc('\'');
|
||||
} else {
|
||||
wrputs(s);
|
||||
}
|
||||
}
|
||||
|
||||
static int
|
||||
IsStringTerm(Term string) /* checks whether this is a string */
|
||||
{
|
||||
if (IsVarTerm(string)) return(FALSE);
|
||||
do {
|
||||
Term hd;
|
||||
int ch;
|
||||
|
||||
if (!IsPairTerm(string)) return(FALSE);
|
||||
hd = HeadOfTerm(string);
|
||||
if (IsVarTerm(hd)) return(FALSE);
|
||||
if (!IsIntTerm(hd)) return(FALSE);
|
||||
ch = IntOfTerm(HeadOfTerm(string));
|
||||
if (ch < 0 || ch > 255)
|
||||
return(FALSE);
|
||||
string = TailOfTerm(string);
|
||||
if (IsVarTerm(string)) return(FALSE);
|
||||
} while (string != TermNil);
|
||||
return(TRUE);
|
||||
}
|
||||
|
||||
static void
|
||||
putString(Term string) /* writes a string */
|
||||
|
||||
{
|
||||
wrputc('"');
|
||||
while (string != TermNil) {
|
||||
int ch = IntOfTerm(HeadOfTerm(string));
|
||||
wrputc(ch);
|
||||
if (ch == '\\' && yap_flags[CHARACTER_ESCAPE_FLAG] != CPROLOG_CHARACTER_ESCAPES)
|
||||
wrputc('\\'); /* be careful about backslashes */
|
||||
else if (ch == '"')
|
||||
wrputc('"'); /* be careful about quotes */
|
||||
string = TailOfTerm(string);
|
||||
}
|
||||
wrputc('"');
|
||||
lastw = alphanum;
|
||||
}
|
||||
|
||||
static void
|
||||
putUnquotedString(Term string) /* writes a string */
|
||||
|
||||
{
|
||||
while (string != TermNil) {
|
||||
int ch = IntOfTerm(HeadOfTerm(string));
|
||||
wrputc(ch);
|
||||
string = TailOfTerm(string);
|
||||
}
|
||||
lastw = alphanum;
|
||||
}
|
||||
|
||||
|
||||
static void
|
||||
write_var(CELL *t)
|
||||
{
|
||||
if (lastw == alphanum) {
|
||||
wrputc(' ');
|
||||
}
|
||||
wrputc('_');
|
||||
/* make sure we don't get no creepy spaces where they shouldn't be */
|
||||
lastw = separator;
|
||||
if (CellPtr(t) < H0) {
|
||||
#if COROUTINING
|
||||
#if DEBUG
|
||||
if (Portray_delays) {
|
||||
exts ext = ExtFromCell(t);
|
||||
|
||||
Portray_delays = FALSE;
|
||||
if (ext == susp_ext) {
|
||||
wrputs("$DL(");
|
||||
write_var(t);
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
} else if (ext == attvars_ext) {
|
||||
attvar_record *attv = (attvar_record *)t;
|
||||
int i;
|
||||
|
||||
wrputs("$AT(");
|
||||
write_var(t);
|
||||
wrputc(',');
|
||||
writeTerm((Term)&(attv->Value), 999, 1, FALSE);
|
||||
for (i = 0; i < NUM_OF_ATTS; i ++) {
|
||||
if (!IsVarTerm(attv->Atts[2*i+1])) {
|
||||
wrputc(',');
|
||||
writeTerm((Term)&(attv->Atts[2*i+1]), 999, 1, FALSE);
|
||||
}
|
||||
}
|
||||
wrputc(')');
|
||||
}
|
||||
Portray_delays = TRUE;
|
||||
return;
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
wrputc('D');
|
||||
wrputn(((Int) (t- CellPtr(GlobalBase))));
|
||||
} else {
|
||||
wrputn(((Int) (t- H0)));
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
writeTerm(Term t, int p, int depth, int rinfixarg)
|
||||
/* term to write */
|
||||
/* context priority */
|
||||
|
||||
{
|
||||
if (*max_depth != 0 && depth > *max_depth) {
|
||||
putAtom(LookupAtom("..."));
|
||||
return;
|
||||
}
|
||||
t = Deref(t);
|
||||
if (IsVarTerm(t)) {
|
||||
write_var((CELL *)t);
|
||||
} else if (IsIntTerm(t)) {
|
||||
wrputn((Int) IntOfTerm(t));
|
||||
} else if (IsAtomTerm(t)) {
|
||||
putAtom(AtomOfTerm(t));
|
||||
} else if (IsFloatTerm(t)) {
|
||||
wrputf(FloatOfTerm(t));
|
||||
} else if (IsRefTerm(t)) {
|
||||
wrputref(RefOfTerm(t));
|
||||
} else if (IsLongIntTerm(t)) {
|
||||
wrputn(LongIntOfTerm(t));
|
||||
#ifdef USE_GMP
|
||||
} else if (IsBigIntTerm(t)) {
|
||||
char *s = (char *)TR;
|
||||
while (s+2+mpz_sizeinbase(BigIntOfTerm(t), 10) > (char *)TrailTop)
|
||||
growtrail(64*1024);
|
||||
mpz_get_str(s, 10, BigIntOfTerm(t));
|
||||
wrputs(s);
|
||||
#endif
|
||||
} else if (IsPairTerm(t)) {
|
||||
int eldepth = 1;
|
||||
Term ti;
|
||||
|
||||
if (Use_portray) {
|
||||
Term targs[1];
|
||||
targs[0] = t;
|
||||
PutValue(AtomPortray, MkAtomTerm(AtomNil));
|
||||
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
|
||||
Use_portray = TRUE;
|
||||
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
|
||||
return;
|
||||
}
|
||||
if (yap_flags[WRITE_QUOTED_STRING_FLAG] && IsStringTerm(t)) {
|
||||
putString(t);
|
||||
} else {
|
||||
wrputc('[');
|
||||
lastw = separator;
|
||||
while (1) {
|
||||
int new_depth = depth + 1;
|
||||
|
||||
if (*max_list && eldepth > *max_list) {
|
||||
putAtom(LookupAtom("..."));
|
||||
wrputc(']');
|
||||
lastw = separator;
|
||||
return;
|
||||
} else
|
||||
eldepth++;
|
||||
writeTerm(HeadOfTermCell(t), 999, new_depth, FALSE);
|
||||
ti = TailOfTerm(t);
|
||||
if (IsVarTerm(ti))
|
||||
break;
|
||||
if (!IsPairTerm(ti))
|
||||
break;
|
||||
t = ti;
|
||||
wrputc(',');
|
||||
lastw = separator;
|
||||
}
|
||||
if (ti != MkAtomTerm(AtomNil)) {
|
||||
wrputc('|');
|
||||
lastw = separator;
|
||||
writeTerm(TailOfTermCell(t), 999, depth + 1, FALSE);
|
||||
}
|
||||
wrputc(']');
|
||||
lastw = separator;
|
||||
}
|
||||
} else { /* compound term */
|
||||
Functor functor = FunctorOfTerm(t);
|
||||
int Arity;
|
||||
Atom atom;
|
||||
Prop opinfo;
|
||||
int op, lp, rp;
|
||||
|
||||
Arity = ArityOfFunctor(functor);
|
||||
atom = NameOfFunctor(functor);
|
||||
opinfo = GetAProp(atom, OpProperty);
|
||||
#ifdef SFUNC
|
||||
if (Arity == SFArity) {
|
||||
int argno = 1;
|
||||
CELL *p = ArgsOfSFTerm(t);
|
||||
putAtom(atom);
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
while (*p) {
|
||||
while (argno < *p) {
|
||||
wrputc('_'), wrputc(',');
|
||||
++argno;
|
||||
}
|
||||
*p++;
|
||||
lastw = separator;
|
||||
/* cannot use the term directly with the SBA */
|
||||
writeTerm(Deref(p++), 999, depth + 1, FALSE);
|
||||
if (*p)
|
||||
wrputc(',');
|
||||
argno++;
|
||||
}
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
return;
|
||||
}
|
||||
#endif
|
||||
if (Use_portray) {
|
||||
Term targs[1];
|
||||
targs[0] = t;
|
||||
PutValue(AtomPortray, MkAtomTerm(AtomNil));
|
||||
execute_goal(MkApplTerm(FunctorPortray, 1, targs),0);
|
||||
Use_portray = TRUE;
|
||||
if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
|
||||
return;
|
||||
}
|
||||
if (!Ignore_ops &&
|
||||
Arity == 1 && opinfo && IsPrefixOp(opinfo, &op,
|
||||
&rp)
|
||||
#ifdef DO_NOT_WRITE_PLUS_AND_MINUS_AS_PREFIX
|
||||
&&
|
||||
/* never write '+' and '-' as infix
|
||||
operators */
|
||||
( (RepAtom(atom)->StrOfAE[0] != '+' &&
|
||||
RepAtom(atom)->StrOfAE[0] != '-') ||
|
||||
RepAtom(atom)->StrOfAE[1] )
|
||||
#endif /* DO_NOT_WRITE_PLUS_AND_MINUS_AS_PREFIX */
|
||||
) {
|
||||
Term tright = ArgOfTerm(1, t);
|
||||
int bracket_right =
|
||||
!IsVarTerm(tright) && IsAtomTerm(tright) &&
|
||||
RightOpToProtect(AtomOfTerm(tright), rp);
|
||||
if (op > p) {
|
||||
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
|
||||
if (lastw != separator && !rinfixarg)
|
||||
wrputc(' ');
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
putAtom(atom);
|
||||
if (bracket_right) {
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
writeTerm(ArgOfTermCell(1,t), rp, depth + 1, FALSE);
|
||||
if (bracket_right) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
if (op > p) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
} else if (!Ignore_ops &&
|
||||
Arity == 1 && opinfo && IsPosfixOp(opinfo, &op, &lp)) {
|
||||
Term tleft = ArgOfTerm(1, t);
|
||||
int bracket_left =
|
||||
!IsVarTerm(tleft) && IsAtomTerm(tleft) &&
|
||||
LeftOpToProtect(AtomOfTerm(tleft), lp);
|
||||
if (op > p) {
|
||||
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
|
||||
if (lastw != separator && !rinfixarg)
|
||||
wrputc(' ');
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
if (bracket_left) {
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
writeTerm(ArgOfTermCell(1,t), lp, depth + 1, rinfixarg);
|
||||
if (bracket_left) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
putAtom(atom);
|
||||
if (op > p) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
} else if (!Ignore_ops &&
|
||||
Arity == 2 && opinfo && IsInfixOp(opinfo, &op, &lp,
|
||||
&rp) ) {
|
||||
Term tleft = ArgOfTerm(1, t);
|
||||
Term tright = ArgOfTerm(2, t);
|
||||
int bracket_left =
|
||||
!IsVarTerm(tleft) && IsAtomTerm(tleft) &&
|
||||
LeftOpToProtect(AtomOfTerm(tleft), lp);
|
||||
int bracket_right =
|
||||
!IsVarTerm(tright) && IsAtomTerm(tright) &&
|
||||
RightOpToProtect(AtomOfTerm(tright), rp);
|
||||
|
||||
if (op > p) {
|
||||
/* avoid stuff such as \+ (a,b) being written as \+(a,b) */
|
||||
if (lastw != separator && !rinfixarg)
|
||||
wrputc(' ');
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
if (bracket_left) {
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
writeTerm(ArgOfTermCell(1, t), lp, depth + 1, rinfixarg);
|
||||
if (bracket_left) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
/* avoid quoting commas */
|
||||
if (strcmp(RepAtom(atom)->StrOfAE,","))
|
||||
putAtom(atom);
|
||||
else {
|
||||
wrputc(',');
|
||||
lastw = separator;
|
||||
}
|
||||
if (bracket_right) {
|
||||
wrputc('(');
|
||||
lastw = separator;
|
||||
}
|
||||
writeTerm(ArgOfTermCell(2, t), rp, depth + 1, TRUE);
|
||||
if (bracket_right) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
if (op > p) {
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
} else if (Handle_vars && functor == FunctorVar) {
|
||||
Term ti = ArgOfTerm(1, t);
|
||||
if (lastw == alphanum) {
|
||||
wrputc(' ');
|
||||
}
|
||||
if (!IsVarTerm(ti) && (IsIntTerm(ti) || IsStringTerm(ti))) {
|
||||
if (IsIntTerm(ti)) {
|
||||
Int k = IntOfTerm(ti);
|
||||
if (k == -1) {
|
||||
wrputc('_');
|
||||
lastw = alphanum;
|
||||
return;
|
||||
} else {
|
||||
wrputc((k % 26) + 'A');
|
||||
if (k >= 26) {
|
||||
/* make sure we don't get confused about our context */
|
||||
lastw = separator;
|
||||
wrputn( k / 26 );
|
||||
} else
|
||||
lastw = alphanum;
|
||||
}
|
||||
} else {
|
||||
putUnquotedString(ti);
|
||||
}
|
||||
} else {
|
||||
wrputs("'$VAR'(");
|
||||
lastw = separator;
|
||||
writeTerm(ArgOfTermCell(1,t), 999, depth + 1, FALSE);
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
} else if (functor == FunctorBraces) {
|
||||
wrputc('{');
|
||||
lastw = separator;
|
||||
writeTerm(ArgOfTermCell(1, t), 1200, depth + 1, FALSE);
|
||||
wrputc('}');
|
||||
lastw = separator;
|
||||
} else if (atom == AtomArray) {
|
||||
wrputc('{');
|
||||
lastw = separator;
|
||||
for (op = 1; op <= Arity; ++op) {
|
||||
writeTerm(ArgOfTermCell(op, t), 999, depth + 1, FALSE);
|
||||
if (op != Arity) {
|
||||
wrputc(',');
|
||||
lastw = separator;
|
||||
}
|
||||
}
|
||||
wrputc('}');
|
||||
lastw = separator;
|
||||
} else {
|
||||
putAtom(atom);
|
||||
lastw = separator;
|
||||
wrputc('(');
|
||||
for (op = 1; op <= Arity; ++op) {
|
||||
writeTerm(ArgOfTermCell(op, t), 999, depth + 1, FALSE);
|
||||
if (op != Arity) {
|
||||
wrputc(',');
|
||||
lastw = separator;
|
||||
}
|
||||
}
|
||||
wrputc(')');
|
||||
lastw = separator;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
plwrite(Term t, int (*mywrite) (int, int), int flags)
|
||||
/* term to be written */
|
||||
/* consumer */
|
||||
/* write options */
|
||||
{
|
||||
writech = mywrite;
|
||||
lastw = separator;
|
||||
Quote_illegal = flags & Quote_illegal_f;
|
||||
Handle_vars = flags & Handle_vars_f;
|
||||
Use_portray = flags & Use_portray_f;
|
||||
Ignore_ops = flags & Ignore_ops_f;
|
||||
writeTerm(t, 1200, 1, FALSE);
|
||||
}
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,307 @@
|
|||
/*************************************************************************
|
||||
* *
|
||||
* YAP Prolog %W% %G%
|
||||
* *
|
||||
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
||||
* *
|
||||
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
||||
* *
|
||||
**************************************************************************
|
||||
* *
|
||||
* File: io.h *
|
||||
* Last rev: 19/2/88 *
|
||||
* mods: *
|
||||
* comments: simple replacement for stdio *
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
#include "Yap.h"
|
||||
|
||||
#ifdef YAP_STDIO
|
||||
|
||||
#include <malloc.h>
|
||||
|
||||
#if HAVE_FCNTL_H
|
||||
#include <fcntl.h>
|
||||
#endif
|
||||
#if HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
#if WINDOWS
|
||||
#include <io.h>
|
||||
#endif
|
||||
#include <stdarg.h>
|
||||
|
||||
#ifndef O_BINARY
|
||||
#define O_BINARY 0
|
||||
#endif
|
||||
|
||||
YP_FILE yp_iob[YP_MAX_FILES];
|
||||
|
||||
static void
|
||||
clear_iob(YP_FILE *f)
|
||||
{
|
||||
f->flags = f->cnt = 0;
|
||||
f->buflen = 1;
|
||||
f->ptr = f->base = (char *) &f->buf;
|
||||
f->close = close;
|
||||
f->read = read;
|
||||
f->write = write;
|
||||
}
|
||||
|
||||
void
|
||||
init_yp_stdio()
|
||||
{
|
||||
int i;
|
||||
/* mark all descriptors as free */
|
||||
for(i=0; i<YP_MAX_FILES; ++i) {
|
||||
yp_iob[i].check = i;
|
||||
clear_iob(&yp_iob[i]);
|
||||
}
|
||||
/* initialize standard ones */
|
||||
yp_iob[0].fd = 0;
|
||||
yp_iob[0].flags = _YP_IO_FILE | _YP_IO_READ;
|
||||
yp_iob[1].fd = 1;
|
||||
yp_iob[1].flags = _YP_IO_FILE | _YP_IO_WRITE;
|
||||
yp_iob[2].fd = 2;
|
||||
yp_iob[2].flags = _YP_IO_FILE | _YP_IO_WRITE;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fillbuf(YP_FILE *f)
|
||||
{
|
||||
if (!(f->flags & _YP_IO_READ)||(f->flags & (_YP_IO_ERR|_YP_IO_EOF)))
|
||||
return -1;
|
||||
if ((f->cnt = (f->read)(f->fd,f->base,f->buflen)) < 0) {
|
||||
f->flags |= _YP_IO_ERR;
|
||||
return -1;
|
||||
}
|
||||
if (f->cnt==0) {
|
||||
f->flags |= _YP_IO_EOF;
|
||||
return -1;
|
||||
}
|
||||
f->ptr = f->base;
|
||||
return YP_getc(f);
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
YP_flushbuf(int c,YP_FILE *f)
|
||||
{
|
||||
if(!(f->flags & _YP_IO_WRITE)||(f->flags & _YP_IO_ERR)) return -1;
|
||||
*(f->ptr++) = c;
|
||||
{
|
||||
int cnt = f->ptr-f->base;
|
||||
int r = (f->write)(f->fd,f->base,cnt);
|
||||
f->ptr = f->base;
|
||||
if (r!=cnt) {
|
||||
f->flags |= _YP_IO_ERR;
|
||||
return -1;
|
||||
}
|
||||
f->ptr = f->base;
|
||||
f->cnt = f->buflen-1;
|
||||
}
|
||||
return c;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fflush(YP_FILE *f)
|
||||
{
|
||||
if(!(f->flags & _YP_IO_WRITE)||(f->flags & _YP_IO_ERR)) return -1;
|
||||
if (f->ptr==f->base) return 0;
|
||||
{
|
||||
int cnt = f->ptr-f->base;
|
||||
int r = (f->write)(f->fd,f->base,cnt);
|
||||
f->ptr = f->base;
|
||||
if (r!=cnt) {
|
||||
f->flags |= _YP_IO_ERR;
|
||||
return -1;
|
||||
}
|
||||
f->ptr = f->base;
|
||||
f->cnt = f->buflen-1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fputs(char *s, YP_FILE *f)
|
||||
{
|
||||
int count = 0;
|
||||
while (*s) {
|
||||
if (YP_putc(*s++,f)<0) return -1;
|
||||
++count;
|
||||
}
|
||||
return count;
|
||||
}
|
||||
|
||||
int
|
||||
YP_puts(char *s)
|
||||
{
|
||||
return YP_fputs(s,YP_stdout);
|
||||
}
|
||||
|
||||
|
||||
char *
|
||||
YP_fgets(char *s, int n, YP_FILE *f)
|
||||
{
|
||||
char *p=s;
|
||||
if (f->flags & _YP_IO_ERR) return 0;
|
||||
while(--n) {
|
||||
int ch = YP_getc(f);
|
||||
if (ch<0) return 0;
|
||||
*p++ = ch;
|
||||
if (ch=='\n') break;
|
||||
}
|
||||
*p = 0;
|
||||
return s;
|
||||
}
|
||||
|
||||
char *
|
||||
YP_gets(char *s)
|
||||
{
|
||||
char *p=s;
|
||||
while(1) {
|
||||
int ch = YP_getchar();
|
||||
if (ch<0) return 0;
|
||||
if (ch=='\n') break;
|
||||
*p++ = ch;
|
||||
}
|
||||
*p = 0;
|
||||
return s;
|
||||
}
|
||||
|
||||
|
||||
YP_FILE*
|
||||
YP_fopen(char *path, char *mode)
|
||||
{
|
||||
YP_FILE *f = 0;
|
||||
int i, fd, flags, ch1, ch2;
|
||||
for(i=3; i<YP_MAX_FILES; ++i)
|
||||
if (!yp_iob[i].flags) {
|
||||
f = &yp_iob[i];
|
||||
break;
|
||||
}
|
||||
if (!f) return f;
|
||||
/* try to open the file */
|
||||
flags = 0;
|
||||
ch1 = *mode++;
|
||||
ch2 = *mode;
|
||||
if(ch2=='b') {
|
||||
flags = O_BINARY;
|
||||
ch2 = *++mode;
|
||||
}
|
||||
if (ch2) return 0;
|
||||
switch (ch1) {
|
||||
case 'r':
|
||||
flags |= O_RDONLY;
|
||||
break;
|
||||
case 'w':
|
||||
flags |= O_WRONLY | O_TRUNC | O_CREAT;
|
||||
break;
|
||||
case 'a':
|
||||
flags |= O_WRONLY | O_CREAT | O_APPEND;
|
||||
break;
|
||||
default:
|
||||
return 0;
|
||||
}
|
||||
if ((fd=open(path,flags,0644))<0) return 0;
|
||||
f->fd = fd;
|
||||
f->flags = _YP_IO_FILE | (ch1=='r' ? _YP_IO_READ : _YP_IO_WRITE);
|
||||
f->ptr = f->base;
|
||||
/* todo: add buffers */
|
||||
f->cnt = 0;
|
||||
f->close = close;
|
||||
f->read = read;
|
||||
f->write = write;
|
||||
return f;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fclose(YP_FILE *f)
|
||||
{
|
||||
if (f != &yp_iob[f->check]) return -1;
|
||||
if (f->flags & _YP_IO_WRITE) {
|
||||
YP_fflush(f);
|
||||
}
|
||||
(f->close)(f->fd);
|
||||
/* todo: release buffers */
|
||||
clear_iob(f);
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
#define MAXBSIZE 32768
|
||||
|
||||
int
|
||||
YP_printf(char *format,...)
|
||||
{
|
||||
va_list ap;
|
||||
char *buf = (char *) alloca(MAXBSIZE);
|
||||
int r;
|
||||
|
||||
va_start(ap,format);
|
||||
vsprintf(buf,format,ap);
|
||||
r = YP_puts(buf);
|
||||
|
||||
va_end(ap);
|
||||
|
||||
return r;
|
||||
}
|
||||
|
||||
|
||||
int
|
||||
YP_fprintf(YP_FILE *f, char *format,...)
|
||||
{
|
||||
va_list ap;
|
||||
char *buf = (char *) alloca(MAXBSIZE);
|
||||
int r;
|
||||
|
||||
va_start(ap,format);
|
||||
vsprintf(buf,format,ap);
|
||||
r = YP_fputs(buf,f);
|
||||
|
||||
va_end(ap);
|
||||
|
||||
return r;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fileno(YP_FILE *f)
|
||||
{
|
||||
return f->fd;
|
||||
}
|
||||
|
||||
int
|
||||
YP_clearerr(YP_FILE *f)
|
||||
{
|
||||
f->flags &= ~ _YP_IO_ERR | _YP_IO_EOF;
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
YP_feof(YP_FILE *f)
|
||||
{
|
||||
return f->flags & _YP_IO_EOF ? 1 : 0;
|
||||
}
|
||||
|
||||
int
|
||||
YP_setbuf(YP_FILE *f, char *b)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
YP_fseek(YP_FILE *f, int offset, int whence)
|
||||
{
|
||||
/* todo: implement fseek */
|
||||
return 0;
|
||||
}
|
||||
|
||||
int
|
||||
YP_ftell(YP_FILE*f)
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
#endif /* YAP_STDIO */
|
||||
|
|
@ -0,0 +1,208 @@
|
|||
------------------------------------------------------------------------
|
||||
LMU COPYRIGHT NOTICE ---------------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
(c) Copyright 1996,1997
|
||||
Ludwig-Maximilians-Universitaet Muenchen (LMU)
|
||||
Institut fuer Informatik
|
||||
Lehr- und Forschungseinheit fuer Programmierung und Softwaretechnik
|
||||
Oettingenstrasse 67
|
||||
D-80538 Munich, Germany
|
||||
|
||||
Contact:
|
||||
Dr. Fruehwirth Thom
|
||||
<<mailto:fruehwir@informatik.uni-muenchen.de
|
||||
<<http://www.pst.informatik.uni-muenchen.de/personen/fruehwir/
|
||||
Tel: +(49) 89 2178-2181
|
||||
Fax: +(49) 89 2178-2175
|
||||
|
||||
------------------------------------------------------------------------
|
||||
RESEARCH SOFTWARE DISCLAIMER -------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
As unestablished, research software, this program is provided
|
||||
free of charge on an "as is" basis without warranty of any kind,
|
||||
either
|
||||
expressed or implied, including but not limited to implied
|
||||
warranties of merchantability and fitness for a particular purpose.
|
||||
LMU does not warrant that the functions contained in this program will
|
||||
meet the user's
|
||||
requirements or that the operation of this program will be
|
||||
uninterrupted or error-free. Acceptance and use of this program
|
||||
constitutes the user's
|
||||
understanding that he will have no recourse to LMU for any
|
||||
actual or
|
||||
consequential damages, including, but not limited to, lost
|
||||
profits or savings, arising out of the use or inability to use this
|
||||
program. Even if the user informs LMU of the possibility of such
|
||||
damages, LMU expects the user of this program to accept the risk of
|
||||
any harm arising out of the use of this program, or the user shall not
|
||||
attempt to use this
|
||||
program for any purpose.
|
||||
|
||||
------------------------------------------------------------------------
|
||||
USER AGREEMENT ---------------------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
BY ACCEPTANCE AND USE OF THIS EXPERIMENTAL PROGRAM
|
||||
THE USER AGREES TO THE FOLLOWING:
|
||||
|
||||
a. This program is provided for the user's personal,
|
||||
non-commercial,
|
||||
experimental use and the user is granted permission to copy this
|
||||
program to the extent reasonably required for such use.
|
||||
|
||||
b. All title, ownership and rights to this program and any copies
|
||||
remain with LMU, irrespective of the ownership of the media on
|
||||
which the program resides.
|
||||
|
||||
c. The user is permitted to create derivative works to this
|
||||
program.
|
||||
However, all copies of the program and its derivative works must
|
||||
contain the LMU COPYRIGHT NOTICE, the UNESTABLISHED SOFTWARE
|
||||
DISCLAIMER and this USER AGREEMENT.
|
||||
|
||||
d. By furnishing this program to the user, LMU does NOT grant
|
||||
either
|
||||
directly or by implication, estoppel, or otherwise any license
|
||||
under any patents, patent applications, trademarks, copyrights
|
||||
or other
|
||||
rights belonging to LMU or to any third party, except as
|
||||
expressly provided herein.
|
||||
|
||||
e. The user understands and agrees that this program and any
|
||||
derivative
|
||||
works are to be used solely for experimental uses and are not to be
|
||||
sold, distributed to a commercial organization, or be
|
||||
commercially
|
||||
exploited in any manner.
|
||||
|
||||
f. LMU requests that the user supply to LMU a copy of any changes,
|
||||
enhancements, or derivative works which the user may create.
|
||||
The user
|
||||
grants LMU and its subsidiaries an irrevocable, nonexclusive,
|
||||
worldwide and
|
||||
royalty-free license to use, execute, reproduce,
|
||||
display, perform, prepare derivative works based upon, and
|
||||
distribute, internally and externally copies of any and all
|
||||
such
|
||||
materials and derivative works thereof, and to sublicense others to
|
||||
do any, some, or
|
||||
all of the foregoing, including supporting
|
||||
documentation.
|
||||
|
||||
g. For users willing to sell software containing this program or any
|
||||
program code resulting from using it, a one time fee and/or a
|
||||
percentage of the sale price chosen by the user shall be negotiated
|
||||
and paid to LMU as royalties.
|
||||
|
||||
h. This agreement shall be governed by German law.
|
||||
|
||||
|
||||
------------------------------------------------------------------------
|
||||
LMU COPYRIGHT NOTICE
|
||||
---------------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
(c) Copyright 1996,1997
|
||||
Ludwig-Maximilians-Universitaet Muenchen (LMU)
|
||||
Institut fuer Informatik
|
||||
Lehr- und Forschungseinheit fuer Programmierung und Softwaretechnik
|
||||
Oettingenstrasse 67
|
||||
D-80538 Munich, Germany
|
||||
|
||||
Contact:
|
||||
Dr. Fruehwirth Thom
|
||||
<mailto:fruehwir@informatik.uni-muenchen.de
|
||||
<http://www.pst.informatik.uni-muenchen.de/personen/fruehwir/
|
||||
Tel: +(49) 89 2178-2181
|
||||
Fax: +(49) 89 2178-2175
|
||||
|
||||
------------------------------------------------------------------------
|
||||
RESEARCH SOFTWARE DISCLAIMER
|
||||
-------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
As unestablished, research software, this program is provided free
|
||||
of charge on an
|
||||
"as is" basis without warranty of any kind, either
|
||||
expressed or implied, including but not limited to implied
|
||||
warranties of
|
||||
merchantability and fitness for a particular purpose. LMU does not
|
||||
warrant that the
|
||||
functions contained in this program will meet the user's
|
||||
requirements or that the operation of this program will be
|
||||
uninterrupted or
|
||||
error-free. Acceptance and use of this program constitutes the user's
|
||||
understanding that he will have no recourse to LMU for any actual or
|
||||
consequential damages, including, but not limited to, lost profits
|
||||
or savings,
|
||||
arising out of the use or inability to use this program. Even if the
|
||||
user informs LMU of
|
||||
the possibility of such damages, LMU expects the user of this program to
|
||||
accept the risk of
|
||||
any harm arising out of the use of this program, or the user shall not
|
||||
attempt to use this
|
||||
program for any purpose.
|
||||
|
||||
------------------------------------------------------------------------
|
||||
USER AGREEMENT
|
||||
---------------------------------------------------------
|
||||
------------------------------------------------------------------------
|
||||
|
||||
BY ACCEPTANCE AND USE OF THIS EXPERIMENTAL PROGRAM
|
||||
THE USER AGREES TO THE FOLLOWING:
|
||||
|
||||
a. This program is provided for the user's personal,
|
||||
non-commercial,
|
||||
experimental use and the user is granted permission to copy this
|
||||
program to the extent reasonably required for such use.
|
||||
|
||||
b. All title, ownership and rights to this program and any copies
|
||||
remain with LMU, irrespective of the ownership of the media on
|
||||
which the program resides.
|
||||
|
||||
c. The user is permitted to create derivative works to this
|
||||
program.
|
||||
However, all copies of the program and its derivative works must
|
||||
contain the LMU COPYRIGHT NOTICE, the UNESTABLISHED SOFTWARE
|
||||
DISCLAIMER and this USER AGREEMENT.
|
||||
|
||||
d. By furnishing this program to the user, LMU does NOT grant
|
||||
either
|
||||
directly or by implication, estoppel, or otherwise any license
|
||||
under any patents, patent applications, trademarks, copyrights
|
||||
or other
|
||||
rights belonging to LMU or to any third party, except as
|
||||
expressly provided herein.
|
||||
|
||||
e. The user understands and agrees that this program and any
|
||||
derivative
|
||||
works are to be used solely for experimental uses and are not to be
|
||||
sold, distributed to a commercial organization, or be
|
||||
commercially
|
||||
exploited in any manner.
|
||||
|
||||
f. LMU requests that the user supply to LMU a copy of any changes,
|
||||
enhancements, or derivative works which the user may create.
|
||||
The user
|
||||
grants LMU and its subsidiaries an irrevocable, nonexclusive,
|
||||
worldwide and
|
||||
royalty-free license to use, execute, reproduce,
|
||||
display, perform, prepare derivative works based upon, and
|
||||
distribute, internally and externally copies of any and all
|
||||
such
|
||||
materials and derivative works thereof, and to sublicense others to
|
||||
do any, some, or
|
||||
all of the foregoing, including supporting
|
||||
documentation.
|
||||
|
||||
g. For users willing to sell software containing this program or any
|
||||
program code resulting from using it, a one time fee and/or a
|
||||
percentage of the sale price chosen by the user shall be negotiated
|
||||
and paid to LMU as royalties.
|
||||
|
||||
h. This agreement shall be governed by German law.
|
||||
|
||||
========================================================================
|
||||
=======================================================================
|
|
@ -0,0 +1,893 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Constraint Handling Rules version 2.2 %
|
||||
% %
|
||||
% (c) Copyright 1996-98 %
|
||||
% LMU, Muenchen %
|
||||
% %
|
||||
% File: chr.pl %
|
||||
% Author: Christian Holzbaur christian@ai.univie.ac.at %
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%
|
||||
% The CHR runtime system,
|
||||
% the constraint store.
|
||||
%
|
||||
% Two functions: a) storage b) reactivation triggered by bindings
|
||||
%
|
||||
% Reactivation is symmetric: if two variables with suspensions
|
||||
% are unified, both suspensions run. (Both variables got more
|
||||
% constrained)
|
||||
%
|
||||
% *** Sequence of wakeups determines termination of handler leq ***
|
||||
%
|
||||
% Another sequence that could matter is the one
|
||||
% generated by the iterators
|
||||
%
|
||||
% Layout:
|
||||
%
|
||||
% suspension(Id,State,Closure,Generation,PropagationHistory,F|Args)
|
||||
%
|
||||
% Id is 1st to allow for direct comparisons (sort) and avoids
|
||||
% unifiability if the Id is nonvar.
|
||||
% F is the constraint functor
|
||||
%
|
||||
%
|
||||
|
||||
:- module( chr,
|
||||
[
|
||||
find_constraint/2,
|
||||
find_constraint/3,
|
||||
findall_constraints/2,
|
||||
findall_constraints/3,
|
||||
remove_constraint/1,
|
||||
current_handler/2,
|
||||
current_constraint/2,
|
||||
unconstrained/1,
|
||||
notify_constrained/1,
|
||||
|
||||
chr_trace/0, chr_notrace/0,
|
||||
chr_debug/0, chr_nodebug/0, chr_debugging/0,
|
||||
chr_leash/1, chr_spy/1, chr_nospy/1
|
||||
]).
|
||||
|
||||
:- use_module( library('chr/getval')).
|
||||
|
||||
:- use_module( library(lists),
|
||||
[
|
||||
append/3,
|
||||
member/2,
|
||||
is_list/1,
|
||||
nth/3,
|
||||
select/3
|
||||
]).
|
||||
|
||||
:- use_module( library(terms),
|
||||
[
|
||||
term_variables/2,
|
||||
subsumes_chk/2,
|
||||
subsumes/2
|
||||
]).
|
||||
|
||||
:- use_module( library(assoc), % propagation history
|
||||
[
|
||||
empty_assoc/1,
|
||||
put_assoc/4,
|
||||
get_assoc/3,
|
||||
assoc_to_list/2
|
||||
]).
|
||||
|
||||
:- use_module(library('chr/sbag')). % link to sbag_l.pl or sbag_a.pl
|
||||
:- use_module(library('chr/chrcmp')).
|
||||
:- use_module(library('chr/trace')).
|
||||
|
||||
:- use_module(library(atts)).
|
||||
|
||||
:- attribute locked/0, exposed/1, dbg_state/1.
|
||||
|
||||
%
|
||||
% Problem with cyclic structures:
|
||||
% error reporters seem to use write ...
|
||||
%
|
||||
:- multifile
|
||||
user:portray/1,
|
||||
user:portray_message/2,
|
||||
user:goal_expansion/3.
|
||||
|
||||
:- dynamic
|
||||
user:portray/1,
|
||||
user:portray_message/2,
|
||||
user:goal_expansion/3.
|
||||
|
||||
%
|
||||
user:portray( Susp) :-
|
||||
Susp =.. [suspension,Id,Mref,_,_,_,_|_],
|
||||
nonvar( Mref),
|
||||
!,
|
||||
write('<c'), write(Id), write('>'). % (c)onstraint
|
||||
%
|
||||
user:portray( '$want_duplicates'(_,Term)) :- !, % cf. attribute_goal/2
|
||||
prolog_flag( toplevel_print_options, Options),
|
||||
write_term( Term, Options).
|
||||
|
||||
:- initialization
|
||||
setval( id, 0). % counter for portray/debugger
|
||||
|
||||
%
|
||||
user:portray_message( error, chr(multiple_handlers(Old,New,Module))) :- !,
|
||||
format( user_error, '{CHR ERROR: registering ~p, module ~p already hosts ~p}~n',
|
||||
[New,Module,Old]).
|
||||
|
||||
% -----------------------------------------------------------------
|
||||
|
||||
%
|
||||
% *** MACROS ***
|
||||
%
|
||||
%
|
||||
user:goal_expansion( lock_some(L), chr, Exp) :- is_list(L),
|
||||
unravel( L, lock, Exp).
|
||||
user:goal_expansion( unlock_some(L), chr, Exp) :- is_list(L),
|
||||
unravel( L, unlock, Exp).
|
||||
user:goal_expansion( via([],V), chr, global_term_ref_1(V)).
|
||||
user:goal_expansion( via([X],V), chr, via_1(X,V)).
|
||||
user:goal_expansion( via([X,Y],V), chr, via_2(X,Y,V)).
|
||||
user:goal_expansion( via([X,Y,Z],V), chr, via_3(X,Y,Z,V)).
|
||||
user:goal_expansion( load_args(S,State,Args), chr, Exp) :-
|
||||
is_list( Args),
|
||||
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
||||
Exp = ( S=Susp, get_mutable( State, Mref) ).
|
||||
%
|
||||
%
|
||||
%
|
||||
user:goal_expansion( nd_init_iteration(V,_,_,Att,S), _, Exp) :-
|
||||
arg( 1, Att, Stack),
|
||||
Exp = ( get_atts(V,Att), chr:sbag_member(S,Stack) ).
|
||||
%
|
||||
user:goal_expansion( init_iteration(V,_,_,Att,L), _, Exp) :-
|
||||
arg( 1, Att, Stack),
|
||||
Exp = ( get_atts(V,Att), chr:iter_init(Stack,L) ).
|
||||
|
||||
unravel( [], _, true).
|
||||
unravel( [X|Xs], F, (G,Gs)) :-
|
||||
G =.. [F,X],
|
||||
unravel( Xs, F, Gs).
|
||||
|
||||
% ----------------------- runtime user predicates -----------------
|
||||
|
||||
remove_constraint( Susp) :-
|
||||
nonvar( Susp),
|
||||
functor( Susp, suspension, N),
|
||||
N >= 6,
|
||||
!,
|
||||
debug_event( remove(Susp)),
|
||||
remove_constraint_internal( Susp, Vars),
|
||||
arg( 3, Susp, Module:_),
|
||||
arg( 6, Susp, F),
|
||||
A is N-6,
|
||||
Module:detach( F/A, Susp, Vars).
|
||||
remove_constraint( S) :-
|
||||
raise_exception( type_error(remove_constraint(S),1,'a constraint object',S)).
|
||||
|
||||
find_constraint( Term, Susp) :-
|
||||
global_term_ref_1( Global),
|
||||
find_constraint( Global, Term, Susp).
|
||||
|
||||
find_constraint( V, Term, Susp) :- var( V), !,
|
||||
find_constraint_internal( V, Term, Susp, active, _).
|
||||
find_constraint( A, B, C) :-
|
||||
raise_exception( instantiation_error( find_constraint(A,B,C), 1)).
|
||||
|
||||
find_constraint_internal( V, Term, Susp, State, Module) :-
|
||||
constraint( Handler, F/A, Att),
|
||||
functor( Term, F, A), % prune some
|
||||
arg( 1, Att, Stack),
|
||||
current_handler( Handler, Module),
|
||||
Module:get_atts( V, Att),
|
||||
length( Args, A),
|
||||
Try =.. [F|Args],
|
||||
sbag_member( Susp, Stack),
|
||||
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
||||
get_mutable( State, Mref),
|
||||
subsumes( Term, Try).
|
||||
|
||||
%
|
||||
% Test for unconstrained var
|
||||
% Used by some math solvers
|
||||
%
|
||||
unconstrained( X) :-
|
||||
% var(X), prolog:'$get_cva'(X,[],_).
|
||||
find_constraint( X, _, _), !, fail.
|
||||
unconstrained( _).
|
||||
|
||||
findall_constraints( C, L) :-
|
||||
global_term_ref_1( Global),
|
||||
findall_constraints( Global, C, L).
|
||||
|
||||
findall_constraints( V, C, L) :- var( V), !,
|
||||
findall( M:Att, (
|
||||
constraint( H, F/A, Att),
|
||||
functor( C, F, A),
|
||||
current_handler( H, M)
|
||||
),
|
||||
Agenda),
|
||||
findall_constraints( Agenda, C, V, L, []).
|
||||
findall_constraints( V, C, L) :-
|
||||
raise_exception( instantiation_error( findall_constraints(V,C,L), 1)).
|
||||
|
||||
findall_constraints( [], _, _) --> [].
|
||||
findall_constraints( [Module:Att|Agenda], C, V) -->
|
||||
( {
|
||||
arg( 1, Att, Stack),
|
||||
Module:get_atts( V, Att),
|
||||
iter_init( Stack, State)
|
||||
} ->
|
||||
findall_constraints_( State, C, Module)
|
||||
;
|
||||
[]
|
||||
),
|
||||
findall_constraints( Agenda, C, V).
|
||||
|
||||
findall_constraints_( State, _, _) --> {iter_last(State)}.
|
||||
findall_constraints_( State, General, Module) -->
|
||||
{
|
||||
iter_next( State, S, Next)
|
||||
},
|
||||
( {
|
||||
S =.. [suspension,_,Mref,_,_,_,F|Args],
|
||||
get_mutable( active, Mref),
|
||||
Term =.. [F|Args],
|
||||
subsumes_chk( General, Term)
|
||||
} ->
|
||||
[ Term#S ]
|
||||
;
|
||||
[]
|
||||
),
|
||||
findall_constraints_( Next, General, Module).
|
||||
|
||||
%
|
||||
% Decorate a constraint Term from Module
|
||||
% with a module prefix if needed.
|
||||
%
|
||||
module_wrap( Term, Module, Wrapped) :-
|
||||
prolog_flag( typein_module, Typein),
|
||||
( Module == Typein ->
|
||||
Wrapped = Term
|
||||
; predicate_property( Typein:Term, imported_from(_)) ->
|
||||
Wrapped = Term
|
||||
;
|
||||
Wrapped = Module:Term
|
||||
).
|
||||
|
||||
% -----------------------------------------------------------------
|
||||
/*
|
||||
|
||||
Two namespaces handler/module actually only justified if there
|
||||
can be more than one handler per module ...
|
||||
|
||||
*/
|
||||
|
||||
:- dynamic handler/2.
|
||||
:- dynamic constraint/3.
|
||||
|
||||
current_handler( Handler, Module) :-
|
||||
handler( Handler, Module).
|
||||
|
||||
current_constraint( Handler, C) :-
|
||||
constraint( Handler, C, _).
|
||||
|
||||
register_handler( Handler, Cs, Slots) :-
|
||||
prolog_load_context( module, Module),
|
||||
( handler(Other,Module),
|
||||
Other \== Handler ->
|
||||
raise_exception( chr(multiple_handlers(Other,Handler,Module)))
|
||||
; handler( Handler, Module) ->
|
||||
true % simple reload
|
||||
;
|
||||
assert( handler(Handler,Module))
|
||||
),
|
||||
retractall( constraint(Handler,_,_)),
|
||||
reg_handler( Cs, Slots, Handler).
|
||||
|
||||
reg_handler( [], [], _).
|
||||
reg_handler( [C|Cs], [S|Ss], Handler) :-
|
||||
assert( constraint(Handler,C,S)),
|
||||
reg_handler( Cs, Ss, Handler).
|
||||
|
||||
% ----------------------------------------------------------------
|
||||
|
||||
notify_constrained( X) :- var( X),
|
||||
findall( M, handler(_,M), Modules),
|
||||
notify_constrained( Modules, X).
|
||||
notify_constrained( X) :- nonvar( X),
|
||||
raise_exception( instantitation_error( notify_constrained(X),1)).
|
||||
|
||||
notify_constrained( [], _).
|
||||
notify_constrained( [M|Ms], X) :-
|
||||
M:get_suspensions( X, S),
|
||||
run_suspensions( S),
|
||||
notify_constrained( Ms, X).
|
||||
|
||||
%
|
||||
% support for verify_attributes/3, notify_constrained/1
|
||||
%
|
||||
% Approximation because debug state might change between calls ...
|
||||
%
|
||||
run_suspensions( Slots) :-
|
||||
getval( debug, State),
|
||||
( State == off ->
|
||||
run_suspensions_loop( Slots)
|
||||
;
|
||||
run_suspensions_loop_d( Slots)
|
||||
),
|
||||
true.
|
||||
|
||||
run_suspensions_loop( []).
|
||||
run_suspensions_loop( [A|As]) :-
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State),
|
||||
run_suspensions_( State),
|
||||
run_suspensions_loop( As).
|
||||
|
||||
run_suspensions_loop_d( []).
|
||||
run_suspensions_loop_d( [A|As]) :-
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State),
|
||||
run_suspensions_d( State),
|
||||
run_suspensions_loop_d( As).
|
||||
|
||||
%
|
||||
% Transition active->triggered->removed instead of
|
||||
% active->removed is to avoid early gc of suspensions.
|
||||
% The suspension's generation is incremented to signal
|
||||
% to the revive scheme that the constraint has been
|
||||
% processed already.
|
||||
%
|
||||
run_suspensions_( State) :- iter_last( State).
|
||||
run_suspensions_( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Mref),
|
||||
get_mutable( Status, Mref),
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
call( Goal),
|
||||
get_mutable( Post, Mref),
|
||||
( Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_( Next).
|
||||
|
||||
run_suspensions_d( State) :- iter_last( State).
|
||||
run_suspensions_d( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Mref),
|
||||
get_mutable( Status, Mref),
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
byrd( S, Goal),
|
||||
get_mutable( Post, Mref),
|
||||
( Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_d( Next).
|
||||
|
||||
byrd( Self, Goal) :-
|
||||
( debug_event( wake(Self)), call( Goal)
|
||||
; debug_event( fail(Self)), !, fail
|
||||
),
|
||||
( debug_event( exit(Self))
|
||||
; debug_event( redo(Self)), fail
|
||||
).
|
||||
|
||||
%
|
||||
% Merge 2 sorted lists of Name/1 terms.
|
||||
% The argument of each term is a sbag.
|
||||
%
|
||||
merge_attributes( [], Bs, Bs).
|
||||
merge_attributes( [A|As], Bs, Cs) :-
|
||||
merge_attributes( Bs, Cs, A, As).
|
||||
|
||||
merge_attributes( [], [A|As], A, As).
|
||||
merge_attributes( [B|Bs], Cs, A, As) :-
|
||||
functor( A, NameA, 1),
|
||||
functor( B, NameB, 1),
|
||||
compare( R, NameA, NameB),
|
||||
( R == < -> Cs = [A|Css], merge_attributes( As, Css, B, Bs)
|
||||
; R == > -> Cs = [B|Css], merge_attributes( Bs, Css, A, As)
|
||||
;
|
||||
Cs = [C|Css],
|
||||
functor( C, NameA, 1),
|
||||
arg( 1, A, StackA),
|
||||
arg( 1, B, StackB),
|
||||
arg( 1, C, StackC),
|
||||
sbag_union( StackA, StackB, StackC),
|
||||
merge_attributes( As, Bs, Css)
|
||||
).
|
||||
|
||||
show_bag( Bag) :-
|
||||
iter_init( Bag, State),
|
||||
show_bag_( State),
|
||||
nl.
|
||||
|
||||
show_bag_( State) :- iter_last( State).
|
||||
show_bag_( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Ref),
|
||||
get_mutable( St, Ref),
|
||||
format( ' ~p:~p', [S,St]),
|
||||
show_bag_( Next).
|
||||
|
||||
%
|
||||
% Support for attribute_goal/2.
|
||||
%
|
||||
% Complication: the Sicstus kernel removes duplicates
|
||||
% via call_residue/2 - that includes the toplevel.
|
||||
% We may want to see them ->
|
||||
% tag Term with Suspension, 'untag' via portray/1
|
||||
%
|
||||
% Called with a list of slots once per module
|
||||
%
|
||||
attribute_goals( L, Goal, Module) :-
|
||||
attribute_goal_loop( L, Module, GL, []),
|
||||
l2c( GL, Goal).
|
||||
|
||||
attribute_goal_loop( [], _) --> [].
|
||||
attribute_goal_loop( [A|As], Mod) -->
|
||||
{
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State)
|
||||
},
|
||||
attgs_( State, Mod),
|
||||
attribute_goal_loop( As, Mod).
|
||||
|
||||
attgs_( State, _) --> {iter_last( State)}.
|
||||
attgs_( State, Module) -->
|
||||
{
|
||||
iter_next( State, S, Next),
|
||||
S =.. [suspension,_,Mref,_,_,_,F|Args]
|
||||
},
|
||||
( {get_mutable(active,Mref)} ->
|
||||
{
|
||||
Term =.. [F|Args],
|
||||
module_wrap( Term, Module, Wrapped)
|
||||
},
|
||||
[ '$want_duplicates'(S,Wrapped) ]
|
||||
;
|
||||
[]
|
||||
),
|
||||
attgs_( Next, Module).
|
||||
|
||||
%
|
||||
% fail for empty list
|
||||
%
|
||||
l2c( [C], C) :- !.
|
||||
l2c( [C|Cs], (C,Cj)) :-
|
||||
l2c( Cs, Cj).
|
||||
|
||||
%
|
||||
% Unlink removed constraints cleanly from all chains
|
||||
% Still need gc state because of wake,
|
||||
% but re-insertion = insert because of complete removal.
|
||||
%
|
||||
chr_gc :-
|
||||
global_term_ref_1( Global),
|
||||
findall( M, handler(_,M), Modules),
|
||||
chr_gcm( Modules, Global).
|
||||
|
||||
chr_gcm( [], _).
|
||||
chr_gcm( [M|Ms], Global) :-
|
||||
M:get_suspensions( Global, AllS),
|
||||
term_variables( [Global|AllS], Vars), % AllS may be ground
|
||||
chr_gcv( Vars, M),
|
||||
chr_gcm( Ms, Global).
|
||||
|
||||
%
|
||||
% Have compiler generated support?
|
||||
%
|
||||
chr_gcv( [], _).
|
||||
chr_gcv( [V|Vs], M) :-
|
||||
M:get_suspensions( V, Old),
|
||||
chr_gcb( Old, New),
|
||||
M:put_suspensions( V, New),
|
||||
chr_gcv( Vs, M).
|
||||
|
||||
chr_gcb( [], []).
|
||||
chr_gcb( [S|Ss], [Sgc|Ts]) :-
|
||||
arg( 1, S, Bag),
|
||||
iter_init( Bag, State),
|
||||
functor( S, N, 1),
|
||||
functor( T, N, 1),
|
||||
gc_bag( State, Lgc),
|
||||
( Lgc==[] ->
|
||||
Sgc = -T
|
||||
;
|
||||
Sgc = T,
|
||||
list_to_sbag( Lgc, BagGc),
|
||||
arg( 1, T, BagGc)
|
||||
),
|
||||
chr_gcb( Ss, Ts).
|
||||
|
||||
gc_bag( State, []) :- iter_last( State).
|
||||
gc_bag( State, L) :-
|
||||
iter_next( State, Susp, Next),
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( SuspState, Mref),
|
||||
( SuspState==removed ->
|
||||
L = Tail,
|
||||
update_mutable( gc, Mref)
|
||||
; SuspState==gc ->
|
||||
L = Tail
|
||||
;
|
||||
L = [Susp|Tail]
|
||||
),
|
||||
gc_bag( Next, Tail).
|
||||
|
||||
% --------------------------------------------------------------------
|
||||
%
|
||||
% Incremental allocation & activation of constraints.
|
||||
% Attachment code of closures to variables is generated
|
||||
% by the compiler.
|
||||
%
|
||||
% States {passive(Term),inactive,triggered,active,removed,gc}
|
||||
%
|
||||
%
|
||||
|
||||
:- meta_predicate allocate_constraint(:,-,+,+).
|
||||
%
|
||||
allocate_constraint( Closure, Self, F, Args) :-
|
||||
empty_history( History),
|
||||
create_mutable( passive(Args), Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
%
|
||||
% activate_constraint( -, +, -).
|
||||
%
|
||||
% The transition gc->active should be rare
|
||||
%
|
||||
activate_constraint( Vars, Susp, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
update_mutable( active, Mref),
|
||||
( nonvar(Generation) -> % aih
|
||||
true
|
||||
;
|
||||
arg( 4, Susp, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref)
|
||||
),
|
||||
( compound(State) -> % passive/1
|
||||
term_variables( State, Vs),
|
||||
none_locked( Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
; State==gc -> % removed from all chains
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
; State==removed -> % the price for eager removal ...
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
;
|
||||
Vars = []
|
||||
).
|
||||
|
||||
%
|
||||
% Combination of the prev. two
|
||||
%
|
||||
:- meta_predicate insert_constraint_internal(-,-,:,+,+).
|
||||
%
|
||||
insert_constraint_internal( [Global|Vars], Self, Closure, F, Args) :-
|
||||
term_variables( Args, Vars),
|
||||
none_locked( Vars),
|
||||
global_term_ref_1( Global),
|
||||
empty_history( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
:- meta_predicate insert_constraint_internal(-,-,?,:,+,+).
|
||||
%
|
||||
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
|
||||
term_variables( Term, Vars),
|
||||
none_locked( Vars),
|
||||
global_term_ref_1( Global),
|
||||
empty_history( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
gen_id( Id) :-
|
||||
incval( id, Id).
|
||||
/* no undo/1 in sicstus3.7
|
||||
( Id =:= 1 -> % first time called
|
||||
undo( setval(id,0))
|
||||
;
|
||||
true
|
||||
).
|
||||
*/
|
||||
|
||||
%
|
||||
% Eager removal from all chains.
|
||||
%
|
||||
remove_constraint_internal( Susp, Agenda) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
update_mutable( removed, Mref), % mark in any case
|
||||
( compound(State) -> % passive/1
|
||||
Agenda = []
|
||||
; State==removed ->
|
||||
Agenda = []
|
||||
; State==triggered ->
|
||||
Agenda = []
|
||||
;
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vars),
|
||||
global_term_ref_1( Global),
|
||||
Agenda = [Global|Vars]
|
||||
).
|
||||
|
||||
%
|
||||
% Protect the goal against any binding
|
||||
% or attachment of constraints. The latter is
|
||||
% via the notify_constrained/1 convention.
|
||||
%
|
||||
lock( T) :- var(T), put_atts( T, locked).
|
||||
lock( T) :- nonvar( T),
|
||||
functor( T, _, N),
|
||||
lock_arg( N, T).
|
||||
|
||||
lock_arg( 0, _) :- !.
|
||||
lock_arg( 1, T) :- !, arg( 1, T, A), lock( A).
|
||||
lock_arg( 2, T) :- !, arg( 1, T, A), lock( A), arg( 2, T, B), lock( B).
|
||||
lock_arg( N, T) :-
|
||||
arg( N, T, A),
|
||||
lock( A),
|
||||
M is N-1,
|
||||
lock_arg( M, T).
|
||||
|
||||
unlock( T) :- var(T), put_atts( T, -locked).
|
||||
unlock( T) :- nonvar( T),
|
||||
functor( T, _, N),
|
||||
unlock_arg( N, T).
|
||||
|
||||
unlock_arg( 0, _) :- !.
|
||||
unlock_arg( 1, T) :- !, arg( 1, T, A), unlock( A).
|
||||
unlock_arg( 2, T) :- !, arg( 1, T, A), unlock( A), arg( 2, T, B), unlock( B).
|
||||
unlock_arg( N, T) :-
|
||||
arg( N, T, A),
|
||||
unlock( A),
|
||||
M is N-1,
|
||||
unlock_arg( M, T).
|
||||
|
||||
verify_attributes( X, Y, []) :-
|
||||
get_atts( X, locked),
|
||||
!,
|
||||
var(Y),
|
||||
get_atts( Y, -locked),
|
||||
put_atts( Y, locked).
|
||||
verify_attributes( _, _, []).
|
||||
|
||||
none_locked( []).
|
||||
none_locked( [V|Vs]) :-
|
||||
not_locked( V),
|
||||
none_locked( Vs).
|
||||
|
||||
not_locked( V) :- var( V), get_atts( V, -locked).
|
||||
not_locked( V) :- nonvar( V).
|
||||
|
||||
% -------------------------- access to constraints ------------------
|
||||
|
||||
%
|
||||
% Try a list of candidates. V may be nonvar but
|
||||
% bound to a term with variables in it.
|
||||
%
|
||||
via( L, V) :-
|
||||
member( X, L),
|
||||
var( X),
|
||||
!,
|
||||
V = X.
|
||||
via( L, V) :-
|
||||
compound( L),
|
||||
nonground( L, V),
|
||||
!.
|
||||
via( _, V) :-
|
||||
global_term_ref_1( V).
|
||||
|
||||
%
|
||||
% specialization(s)
|
||||
%
|
||||
via_1( X, V) :- var(X), !, X=V.
|
||||
via_1( T, V) :- compound(T), nonground( T, V), !.
|
||||
via_1( _, V) :- global_term_ref_1( V).
|
||||
|
||||
via_2( X, _, V) :- var(X), !, X=V.
|
||||
via_2( _, Y, V) :- var(Y), !, Y=V.
|
||||
via_2( T, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_2( _, T, V) :- compound(T), nonground( T, V), !.
|
||||
via_2( _, _, V) :- global_term_ref_1( V).
|
||||
|
||||
via_3( X, _, _, V) :- var(X), !, X=V.
|
||||
via_3( _, Y, _, V) :- var(Y), !, Y=V.
|
||||
via_3( _, _, Z, V) :- var(Z), !, Z=V.
|
||||
via_3( T, _, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, T, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, _, T, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, _, _, V) :- global_term_ref_1( V).
|
||||
|
||||
|
||||
%
|
||||
% The second arg is a witness.
|
||||
% The formulation with term_variables/2 is
|
||||
% cycle safe, but it finds a list of all vars.
|
||||
% We need only one, and no list in particular.
|
||||
%
|
||||
nonground( Term, V) :-
|
||||
term_variables( Term, Vs),
|
||||
Vs = [V|_].
|
||||
|
||||
/*
|
||||
nonground( Term, V) :- var( Term), V=Term.
|
||||
nonground( Term, V) :- compound( Term),
|
||||
functor( Term, _, N),
|
||||
nonground( N, Term, V).
|
||||
|
||||
%
|
||||
% assert: N > 0
|
||||
%
|
||||
nonground( 1, Term, V) :- !,
|
||||
arg( 1, Term, Arg),
|
||||
nonground( Arg, V).
|
||||
nonground( 2, Term, V) :- !,
|
||||
arg( 2, Term, Arg2),
|
||||
( nonground( Arg2, V) ->
|
||||
true
|
||||
;
|
||||
arg( 1, Term, Arg1),
|
||||
nonground( Arg1, V)
|
||||
).
|
||||
nonground( N, Term, V) :-
|
||||
arg( N, Term, Arg),
|
||||
( nonground( Arg, V) ->
|
||||
true
|
||||
;
|
||||
M is N-1,
|
||||
nonground( M, Term, V)
|
||||
).
|
||||
*/
|
||||
|
||||
constraint_generation( Susp, State, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
arg( 4, Susp, Gref),
|
||||
get_mutable( Generation, Gref). % not incremented meanwhile
|
||||
|
||||
change_state( Susp, State) :-
|
||||
arg( 2, Susp, Mref),
|
||||
update_mutable( State, Mref).
|
||||
|
||||
:- meta_predicate expose(-,+,+,+,:).
|
||||
%
|
||||
expose_active( Ref, Head, Tid, Heads, Continuation) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
update_mutable( [active(Head,Tid,Heads,Continuation)|Exposed], Ref).
|
||||
|
||||
expose_passive( Ref, Heads) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
update_mutable( [passive(Heads)|Exposed], Ref).
|
||||
|
||||
de_expose( Ref) :-
|
||||
get_mutable( [_|Exposed], Ref),
|
||||
update_mutable( Exposed, Ref).
|
||||
|
||||
%
|
||||
% Prefer passive over active (cheaper to deal with).
|
||||
%
|
||||
is_exposed( Constraint, Suspension, Continuation) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
is_exposed( Exposed, Constraint, Suspension, Continuation).
|
||||
|
||||
is_exposed( [E|Es], Constraint, Suspension, Continuation) :-
|
||||
is_exposed( E, Constraint, Suspension, Continuation, Es).
|
||||
|
||||
is_exposed( active(Head,Susp,Heads,Cont), Constraint, Suspension, Continuation, Es) :-
|
||||
( member( C#Suspension, Heads),
|
||||
Constraint == C ->
|
||||
Continuation = true
|
||||
; Constraint == Head ->
|
||||
( is_exposed( Es, Constraint, Suspension, true) -> % prefer
|
||||
Continuation = true
|
||||
;
|
||||
Continuation = Cont,
|
||||
Suspension = Susp
|
||||
)
|
||||
;
|
||||
is_exposed( Es, Constraint, Suspension, Continuation)
|
||||
).
|
||||
is_exposed( passive(Heads), Constraint, Suspension, Continuation, Es) :-
|
||||
( member( C#Suspension, Heads),
|
||||
Constraint == C ->
|
||||
Continuation = true
|
||||
;
|
||||
is_exposed( Es, Constraint, Suspension, Continuation)
|
||||
).
|
||||
|
||||
get_exposed( Ref) :-
|
||||
global_term_ref_1( Global),
|
||||
( get_atts( Global, exposed(Ref)) ->
|
||||
true
|
||||
;
|
||||
create_mutable( [], Ref),
|
||||
put_atts( Global, exposed(Ref))
|
||||
).
|
||||
|
||||
get_dbg_state( Ref) :-
|
||||
global_term_ref_1( Global),
|
||||
( get_atts( Global, dbg_state(Ref)) ->
|
||||
true
|
||||
;
|
||||
create_mutable( [], Ref),
|
||||
put_atts( Global, dbg_state(Ref))
|
||||
).
|
||||
|
||||
% ------------------- abstract data type for propagation rules -------------
|
||||
|
||||
empty_history( E) :- empty_assoc( E).
|
||||
|
||||
%
|
||||
% assert: constraints/tuples are comparable directly
|
||||
%
|
||||
novel_production( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
get_mutable( History, Ref),
|
||||
( get_assoc( Tuple, History, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%
|
||||
% Not folded with novel_production/2 because guard checking
|
||||
% goes in between the two calls.
|
||||
%
|
||||
extend_history( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
get_mutable( History, Ref),
|
||||
put_assoc( Tuple, History, x, NewHistory),
|
||||
update_mutable( NewHistory, Ref).
|
||||
|
||||
:- load_foreign_resource(library(system(chr))).
|
||||
|
||||
end_of_file.
|
||||
|
|
@ -0,0 +1,907 @@
|
|||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
% Constraint Handling Rules version 2.2 %
|
||||
% %
|
||||
% (c) Copyright 1996-98 %
|
||||
% LMU, Muenchen %
|
||||
% %
|
||||
% File: chr.pl %
|
||||
% Author: Christian Holzbaur christian@ai.univie.ac.at %
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%
|
||||
% The CHR runtime system,
|
||||
% the constraint store.
|
||||
%
|
||||
% Two functions: a) storage b) reactivation triggered by bindings
|
||||
%
|
||||
% Reactivation is symmetric: if two variables with suspensions
|
||||
% are unified, both suspensions run. (Both variables got more
|
||||
% constrained)
|
||||
%
|
||||
% *** Sequence of wakeups determines termination of handler leq ***
|
||||
%
|
||||
% Another sequence that could matter is the one
|
||||
% generated by the iterators
|
||||
%
|
||||
% Layout:
|
||||
%
|
||||
% suspension(Id,State,Closure,Generation,PropagationHistory,F|Args)
|
||||
%
|
||||
% Id is 1st to allow for direct comparisons (sort) and avoids
|
||||
% unifiability if the Id is nonvar.
|
||||
% F is the constraint functor
|
||||
%
|
||||
%
|
||||
|
||||
:- module( chr,
|
||||
[
|
||||
find_constraint/2,
|
||||
find_constraint/3,
|
||||
findall_constraints/2,
|
||||
findall_constraints/3,
|
||||
remove_constraint/1,
|
||||
current_handler/2,
|
||||
current_constraint/2,
|
||||
unconstrained/1,
|
||||
notify_constrained/1,
|
||||
|
||||
chr_trace/0, chr_notrace/0,
|
||||
chr_debug/0, chr_nodebug/0, chr_debugging/0,
|
||||
chr_leash/1, chr_spy/1, chr_nospy/1
|
||||
]).
|
||||
|
||||
:- use_module( library('chr/getval')).
|
||||
|
||||
:- use_module( library(lists),
|
||||
[
|
||||
append/3,
|
||||
member/2,
|
||||
is_list/1,
|
||||
nth/3,
|
||||
select/3
|
||||
]).
|
||||
|
||||
:- use_module( library(terms),
|
||||
[
|
||||
term_variables/2,
|
||||
subsumes_chk/2,
|
||||
subsumes/2
|
||||
]).
|
||||
|
||||
:- use_module( library(assoc), % propagation history
|
||||
[
|
||||
empty_assoc/1,
|
||||
put_assoc/4,
|
||||
get_assoc/3,
|
||||
assoc_to_list/2
|
||||
]).
|
||||
|
||||
:- use_module(library('chr/sbag')). % link to sbag_l.pl or sbag_a.pl
|
||||
:- use_module(library('chr/chrcmp')).
|
||||
:- use_module(library('chr/trace')).
|
||||
|
||||
:- use_module(library(atts)).
|
||||
|
||||
:- attribute locked/0, exposed/1, dbg_state/1.
|
||||
|
||||
%
|
||||
% Problem with cyclic structures:
|
||||
% error reporters seem to use write ...
|
||||
%
|
||||
:- multifile
|
||||
user:portray/1,
|
||||
user:portray_message/2,
|
||||
user:goal_expansion/3.
|
||||
|
||||
:- dynamic
|
||||
user:portray/1,
|
||||
user:portray_message/2,
|
||||
user:goal_expansion/3.
|
||||
|
||||
%
|
||||
user:portray( Susp) :-
|
||||
Susp =.. [suspension,Id,Mref,_,_,_,_|_],
|
||||
nonvar( Mref),
|
||||
!,
|
||||
write('<c'), write(Id), write('>'). % (c)onstraint
|
||||
%
|
||||
user:portray( '$want_duplicates'(_,Term)) :- !, % cf. attribute_goal/2
|
||||
prolog_flag( toplevel_print_options, Options),
|
||||
write_term( Term, Options).
|
||||
|
||||
:- initialization
|
||||
setval( id, 0). % counter for portray/debugger
|
||||
|
||||
%
|
||||
user:portray_message( error, chr(multiple_handlers(Old,New,Module))) :- !,
|
||||
format( user_error, '{CHR ERROR: registering ~p, module ~p already hosts ~p}~n',
|
||||
[New,Module,Old]).
|
||||
|
||||
% -----------------------------------------------------------------
|
||||
|
||||
%
|
||||
% *** MACROS ***
|
||||
%
|
||||
%
|
||||
user:goal_expansion( lock_some(L), chr, Exp) :- is_list(L),
|
||||
unravel( L, lock, Exp).
|
||||
user:goal_expansion( unlock_some(L), chr, Exp) :- is_list(L),
|
||||
unravel( L, unlock, Exp).
|
||||
user:goal_expansion( via([],V), chr, global_term_ref_1(V)).
|
||||
user:goal_expansion( via([X],V), chr, via_1(X,V)).
|
||||
user:goal_expansion( via([X,Y],V), chr, via_2(X,Y,V)).
|
||||
user:goal_expansion( via([X,Y,Z],V), chr, via_3(X,Y,Z,V)).
|
||||
user:goal_expansion( load_args(S,State,Args), chr, Exp) :-
|
||||
is_list( Args),
|
||||
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
||||
Exp = ( S=Susp, get_mutable( State, Mref) ).
|
||||
%
|
||||
%
|
||||
%
|
||||
user:goal_expansion( nd_init_iteration(V,_,_,Att,S), _, Exp) :-
|
||||
arg( 1, Att, Stack),
|
||||
Exp = ( get_atts(V,Att), chr:sbag_member(S,Stack) ).
|
||||
%
|
||||
user:goal_expansion( init_iteration(V,_,_,Att,L), _, Exp) :-
|
||||
arg( 1, Att, Stack),
|
||||
Exp = ( get_atts(V,Att), chr:iter_init(Stack,L) ).
|
||||
|
||||
unravel( [], _, true).
|
||||
unravel( [X|Xs], F, (G,Gs)) :-
|
||||
G =.. [F,X],
|
||||
unravel( Xs, F, Gs).
|
||||
|
||||
% ----------------------- runtime user predicates -----------------
|
||||
|
||||
remove_constraint( Susp) :-
|
||||
nonvar( Susp),
|
||||
functor( Susp, suspension, N),
|
||||
N >= 6,
|
||||
!,
|
||||
debug_event( remove(Susp)),
|
||||
remove_constraint_internal( Susp, Vars),
|
||||
arg( 3, Susp, Module:_),
|
||||
arg( 6, Susp, F),
|
||||
A is N-6,
|
||||
Module:detach( F/A, Susp, Vars).
|
||||
remove_constraint( S) :-
|
||||
raise_exception( type_error(remove_constraint(S),1,'a constraint object',S)).
|
||||
|
||||
find_constraint( Term, Susp) :-
|
||||
global_term_ref_1( Global),
|
||||
find_constraint( Global, Term, Susp).
|
||||
|
||||
find_constraint( V, Term, Susp) :- var( V), !,
|
||||
find_constraint_internal( V, Term, Susp, active, _).
|
||||
find_constraint( A, B, C) :-
|
||||
raise_exception( instantiation_error( find_constraint(A,B,C), 1)).
|
||||
|
||||
find_constraint_internal( V, Term, Susp, State, Module) :-
|
||||
constraint( Handler, F/A, Att),
|
||||
functor( Term, F, A), % prune some
|
||||
arg( 1, Att, Stack),
|
||||
current_handler( Handler, Module),
|
||||
Module:get_atts( V, Att),
|
||||
length( Args, A),
|
||||
Try =.. [F|Args],
|
||||
sbag_member( Susp, Stack),
|
||||
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
||||
get_mutable( State, Mref),
|
||||
subsumes( Term, Try).
|
||||
|
||||
%
|
||||
% Test for unconstrained var
|
||||
% Used by some math solvers
|
||||
%
|
||||
unconstrained( X) :-
|
||||
% var(X), prolog:'$get_cva'(X,[],_).
|
||||
find_constraint( X, _, _), !, fail.
|
||||
unconstrained( _).
|
||||
|
||||
findall_constraints( C, L) :-
|
||||
global_term_ref_1( Global),
|
||||
findall_constraints( Global, C, L).
|
||||
|
||||
findall_constraints( V, C, L) :- var( V), !,
|
||||
findall( M:Att, (
|
||||
constraint( H, F/A, Att),
|
||||
functor( C, F, A),
|
||||
current_handler( H, M)
|
||||
),
|
||||
Agenda),
|
||||
findall_constraints( Agenda, C, V, L, []).
|
||||
findall_constraints( V, C, L) :-
|
||||
raise_exception( instantiation_error( findall_constraints(V,C,L), 1)).
|
||||
|
||||
findall_constraints( [], _, _) --> [].
|
||||
findall_constraints( [Module:Att|Agenda], C, V) -->
|
||||
( {
|
||||
arg( 1, Att, Stack),
|
||||
Module:get_atts( V, Att),
|
||||
iter_init( Stack, State)
|
||||
} ->
|
||||
findall_constraints_( State, C, Module)
|
||||
;
|
||||
[]
|
||||
),
|
||||
findall_constraints( Agenda, C, V).
|
||||
|
||||
findall_constraints_( State, _, _) --> {iter_last(State)}.
|
||||
findall_constraints_( State, General, Module) -->
|
||||
{
|
||||
iter_next( State, S, Next)
|
||||
},
|
||||
( {
|
||||
S =.. [suspension,_,Mref,_,_,_,F|Args],
|
||||
get_mutable( active, Mref),
|
||||
Term =.. [F|Args],
|
||||
subsumes_chk( General, Term)
|
||||
} ->
|
||||
[ Term#S ]
|
||||
;
|
||||
[]
|
||||
),
|
||||
findall_constraints_( Next, General, Module).
|
||||
|
||||
%
|
||||
% Decorate a constraint Term from Module
|
||||
% with a module prefix if needed.
|
||||
%
|
||||
module_wrap( Term, Module, Wrapped) :-
|
||||
prolog_flag( typein_module, Typein),
|
||||
( Module == Typein ->
|
||||
Wrapped = Term
|
||||
; predicate_property( Typein:Term, imported_from(_)) ->
|
||||
Wrapped = Term
|
||||
;
|
||||
Wrapped = Module:Term
|
||||
).
|
||||
|
||||
% -----------------------------------------------------------------
|
||||
/*
|
||||
|
||||
Two namespaces handler/module actually only justified if there
|
||||
can be more than one handler per module ...
|
||||
|
||||
*/
|
||||
|
||||
:- dynamic handler/2.
|
||||
:- dynamic constraint/3.
|
||||
|
||||
current_handler( Handler, Module) :-
|
||||
handler( Handler, Module).
|
||||
|
||||
current_constraint( Handler, C) :-
|
||||
constraint( Handler, C, _).
|
||||
|
||||
register_handler( Handler, Cs, Slots) :-
|
||||
prolog_load_context( module, Module),
|
||||
( handler(Other,Module),
|
||||
Other \== Handler ->
|
||||
raise_exception( chr(multiple_handlers(Other,Handler,Module)))
|
||||
; handler( Handler, Module) ->
|
||||
true % simple reload
|
||||
;
|
||||
assert( handler(Handler,Module))
|
||||
),
|
||||
retractall( constraint(Handler,_,_)),
|
||||
reg_handler( Cs, Slots, Handler).
|
||||
|
||||
reg_handler( [], [], _).
|
||||
reg_handler( [C|Cs], [S|Ss], Handler) :-
|
||||
assert( constraint(Handler,C,S)),
|
||||
reg_handler( Cs, Ss, Handler).
|
||||
|
||||
% ----------------------------------------------------------------
|
||||
|
||||
notify_constrained( X) :- var( X),
|
||||
findall( M, handler(_,M), Modules),
|
||||
notify_constrained( Modules, X).
|
||||
notify_constrained( X) :- nonvar( X),
|
||||
raise_exception( instantitation_error( notify_constrained(X),1)).
|
||||
|
||||
notify_constrained( [], _).
|
||||
notify_constrained( [M|Ms], X) :-
|
||||
M:get_suspensions( X, S),
|
||||
run_suspensions( S),
|
||||
notify_constrained( Ms, X).
|
||||
|
||||
%
|
||||
% support for verify_attributes/3, notify_constrained/1
|
||||
%
|
||||
% Approximation because debug state might change between calls ...
|
||||
%
|
||||
run_suspensions( Slots) :-
|
||||
getval( debug, State),
|
||||
( State == off ->
|
||||
run_suspensions_loop( Slots)
|
||||
;
|
||||
run_suspensions_loop_d( Slots)
|
||||
),
|
||||
true.
|
||||
|
||||
run_suspensions_loop( []).
|
||||
run_suspensions_loop( [A|As]) :-
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State),
|
||||
run_suspensions_( State),
|
||||
run_suspensions_loop( As).
|
||||
|
||||
run_suspensions_loop_d( []).
|
||||
run_suspensions_loop_d( [A|As]) :-
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State),
|
||||
run_suspensions_d( State),
|
||||
run_suspensions_loop_d( As).
|
||||
|
||||
%
|
||||
% Transition active->triggered->removed instead of
|
||||
% active->removed is to avoid early gc of suspensions.
|
||||
% The suspension's generation is incremented to signal
|
||||
% to the revive scheme that the constraint has been
|
||||
% processed already.
|
||||
%
|
||||
run_suspensions_( State) :- iter_last( State).
|
||||
run_suspensions_( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Mref),
|
||||
get_mutable( Status, Mref),
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
call( Goal),
|
||||
get_mutable( Post, Mref),
|
||||
( Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_( Next).
|
||||
|
||||
run_suspensions_d( State) :- iter_last( State).
|
||||
run_suspensions_d( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Mref),
|
||||
get_mutable( Status, Mref),
|
||||
( Status==active ->
|
||||
update_mutable( triggered, Mref),
|
||||
arg( 4, S, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref),
|
||||
arg( 3, S, Goal),
|
||||
byrd( S, Goal),
|
||||
get_mutable( Post, Mref),
|
||||
( Post==triggered ->
|
||||
update_mutable( removed, Mref)
|
||||
;
|
||||
true
|
||||
)
|
||||
;
|
||||
true
|
||||
),
|
||||
run_suspensions_d( Next).
|
||||
|
||||
byrd( Self, Goal) :-
|
||||
( debug_event( wake(Self)), call( Goal)
|
||||
; debug_event( fail(Self)), !, fail
|
||||
),
|
||||
( debug_event( exit(Self))
|
||||
; debug_event( redo(Self)), fail
|
||||
).
|
||||
|
||||
%
|
||||
% Merge 2 sorted lists of Name/1 terms.
|
||||
% The argument of each term is a sbag.
|
||||
%
|
||||
merge_attributes( [], Bs, Bs).
|
||||
merge_attributes( [A|As], Bs, Cs) :-
|
||||
merge_attributes( Bs, Cs, A, As).
|
||||
|
||||
merge_attributes( [], [A|As], A, As).
|
||||
merge_attributes( [B|Bs], Cs, A, As) :-
|
||||
functor( A, NameA, 1),
|
||||
functor( B, NameB, 1),
|
||||
compare( R, NameA, NameB),
|
||||
( R == < -> Cs = [A|Css], merge_attributes( As, Css, B, Bs)
|
||||
; R == > -> Cs = [B|Css], merge_attributes( Bs, Css, A, As)
|
||||
;
|
||||
Cs = [C|Css],
|
||||
functor( C, NameA, 1),
|
||||
arg( 1, A, StackA),
|
||||
arg( 1, B, StackB),
|
||||
arg( 1, C, StackC),
|
||||
sbag_union( StackA, StackB, StackC),
|
||||
merge_attributes( As, Bs, Css)
|
||||
).
|
||||
|
||||
show_bag( Bag) :-
|
||||
iter_init( Bag, State),
|
||||
show_bag_( State),
|
||||
nl.
|
||||
|
||||
show_bag_( State) :- iter_last( State).
|
||||
show_bag_( State) :-
|
||||
iter_next( State, S, Next),
|
||||
arg( 2, S, Ref),
|
||||
get_mutable( St, Ref),
|
||||
format( ' ~p:~p', [S,St]),
|
||||
show_bag_( Next).
|
||||
|
||||
%
|
||||
% Support for attribute_goal/2.
|
||||
%
|
||||
% Complication: the Sicstus kernel removes duplicates
|
||||
% via call_residue/2 - that includes the toplevel.
|
||||
% We may want to see them ->
|
||||
% tag Term with Suspension, 'untag' via portray/1
|
||||
%
|
||||
% Called with a list of slots once per module
|
||||
%
|
||||
attribute_goals( L, Goal, Module) :-
|
||||
attribute_goal_loop( L, Module, GL, []),
|
||||
l2c( GL, Goal).
|
||||
|
||||
attribute_goal_loop( [], _) --> [].
|
||||
attribute_goal_loop( [A|As], Mod) -->
|
||||
{
|
||||
arg( 1, A, Stack),
|
||||
iter_init( Stack, State)
|
||||
},
|
||||
attgs_( State, Mod),
|
||||
attribute_goal_loop( As, Mod).
|
||||
|
||||
attgs_( State, _) --> {iter_last( State)}.
|
||||
attgs_( State, Module) -->
|
||||
{
|
||||
iter_next( State, S, Next),
|
||||
S =.. [suspension,_,Mref,_,_,_,F|Args]
|
||||
},
|
||||
( {get_mutable(active,Mref)} ->
|
||||
{
|
||||
Term =.. [F|Args],
|
||||
module_wrap( Term, Module, Wrapped)
|
||||
},
|
||||
[ '$want_duplicates'(S,Wrapped) ]
|
||||
;
|
||||
[]
|
||||
),
|
||||
attgs_( Next, Module).
|
||||
|
||||
%
|
||||
% fail for empty list
|
||||
%
|
||||
l2c( [C], C) :- !.
|
||||
l2c( [C|Cs], (C,Cj)) :-
|
||||
l2c( Cs, Cj).
|
||||
|
||||
%
|
||||
% Unlink removed constraints cleanly from all chains
|
||||
% Still need gc state because of wake,
|
||||
% but re-insertion = insert because of complete removal.
|
||||
%
|
||||
chr_gc :-
|
||||
global_term_ref_1( Global),
|
||||
findall( M, handler(_,M), Modules),
|
||||
chr_gcm( Modules, Global).
|
||||
|
||||
chr_gcm( [], _).
|
||||
chr_gcm( [M|Ms], Global) :-
|
||||
M:get_suspensions( Global, AllS),
|
||||
term_variables( [Global|AllS], Vars), % AllS may be ground
|
||||
chr_gcv( Vars, M),
|
||||
chr_gcm( Ms, Global).
|
||||
|
||||
%
|
||||
% Have compiler generated support?
|
||||
%
|
||||
chr_gcv( [], _).
|
||||
chr_gcv( [V|Vs], M) :-
|
||||
M:get_suspensions( V, Old),
|
||||
chr_gcb( Old, New),
|
||||
M:put_suspensions( V, New),
|
||||
chr_gcv( Vs, M).
|
||||
|
||||
chr_gcb( [], []).
|
||||
chr_gcb( [S|Ss], [Sgc|Ts]) :-
|
||||
arg( 1, S, Bag),
|
||||
iter_init( Bag, State),
|
||||
functor( S, N, 1),
|
||||
functor( T, N, 1),
|
||||
gc_bag( State, Lgc),
|
||||
( Lgc==[] ->
|
||||
Sgc = -T
|
||||
;
|
||||
Sgc = T,
|
||||
list_to_sbag( Lgc, BagGc),
|
||||
arg( 1, T, BagGc)
|
||||
),
|
||||
chr_gcb( Ss, Ts).
|
||||
|
||||
gc_bag( State, []) :- iter_last( State).
|
||||
gc_bag( State, L) :-
|
||||
iter_next( State, Susp, Next),
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( SuspState, Mref),
|
||||
( SuspState==removed ->
|
||||
L = Tail,
|
||||
update_mutable( gc, Mref)
|
||||
; SuspState==gc ->
|
||||
L = Tail
|
||||
;
|
||||
L = [Susp|Tail]
|
||||
),
|
||||
gc_bag( Next, Tail).
|
||||
|
||||
% --------------------------------------------------------------------
|
||||
%
|
||||
% Incremental allocation & activation of constraints.
|
||||
% Attachment code of closures to variables is generated
|
||||
% by the compiler.
|
||||
%
|
||||
% States {passive(Term),inactive,triggered,active,removed,gc}
|
||||
%
|
||||
%
|
||||
|
||||
:- meta_predicate allocate_constraint(:,-,+,+).
|
||||
%
|
||||
allocate_constraint( Closure, Self, F, Args) :-
|
||||
empty_history( History),
|
||||
create_mutable( passive(Args), Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
%
|
||||
% activate_constraint( -, +, -).
|
||||
%
|
||||
% The transition gc->active should be rare
|
||||
%
|
||||
activate_constraint( Vars, Susp, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
update_mutable( active, Mref),
|
||||
( nonvar(Generation) -> % aih
|
||||
true
|
||||
;
|
||||
arg( 4, Susp, Gref),
|
||||
get_mutable( Gen, Gref),
|
||||
Generation is Gen+1,
|
||||
update_mutable( Generation, Gref)
|
||||
),
|
||||
( compound(State) -> % passive/1
|
||||
term_variables( State, Vs),
|
||||
none_locked( Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
; State==gc -> % removed from all chains
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
; State==removed -> % the price for eager removal ...
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vs),
|
||||
global_term_ref_1( Global),
|
||||
Vars = [Global|Vs]
|
||||
;
|
||||
Vars = []
|
||||
).
|
||||
|
||||
%
|
||||
% Combination of the prev. two
|
||||
%
|
||||
:- meta_predicate insert_constraint_internal(-,-,:,+,+).
|
||||
%
|
||||
insert_constraint_internal( [Global|Vars], Self, Closure, F, Args) :-
|
||||
term_variables( Args, Vars),
|
||||
none_locked( Vars),
|
||||
global_term_ref_1( Global),
|
||||
empty_history( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
:- meta_predicate insert_constraint_internal(-,-,?,:,+,+).
|
||||
%
|
||||
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
|
||||
term_variables( Term, Vars),
|
||||
none_locked( Vars),
|
||||
global_term_ref_1( Global),
|
||||
empty_history( History),
|
||||
create_mutable( active, Mref),
|
||||
create_mutable( 0, Gref),
|
||||
create_mutable( History, Href),
|
||||
gen_id( Id),
|
||||
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
||||
|
||||
gen_id( Id) :-
|
||||
incval( id, Id).
|
||||
/* no undo/1 in sicstus3.7
|
||||
( Id =:= 1 -> % first time called
|
||||
undo( setval(id,0))
|
||||
;
|
||||
true
|
||||
).
|
||||
*/
|
||||
|
||||
%
|
||||
% Eager removal from all chains.
|
||||
%
|
||||
remove_constraint_internal( Susp, Agenda) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
update_mutable( removed, Mref), % mark in any case
|
||||
( compound(State) -> % passive/1
|
||||
Agenda = []
|
||||
; State==removed ->
|
||||
Agenda = []
|
||||
; State==triggered ->
|
||||
Agenda = []
|
||||
;
|
||||
Susp =.. [_,_,_,_,_,_,_|Args],
|
||||
term_variables( Args, Vars),
|
||||
global_term_ref_1( Global),
|
||||
Agenda = [Global|Vars]
|
||||
).
|
||||
|
||||
%
|
||||
% Protect the goal against any binding
|
||||
% or attachment of constraints. The latter is
|
||||
% via the notify_constrained/1 convention.
|
||||
%
|
||||
lock( T) :- var(T), put_atts( T, locked).
|
||||
lock( T) :- nonvar( T),
|
||||
functor( T, _, N),
|
||||
lock_arg( N, T).
|
||||
|
||||
lock_arg( 0, _) :- !.
|
||||
lock_arg( 1, T) :- !, arg( 1, T, A), lock( A).
|
||||
lock_arg( 2, T) :- !, arg( 1, T, A), lock( A), arg( 2, T, B), lock( B).
|
||||
lock_arg( N, T) :-
|
||||
arg( N, T, A),
|
||||
lock( A),
|
||||
M is N-1,
|
||||
lock_arg( M, T).
|
||||
|
||||
unlock( T) :- var(T), put_atts( T, -locked).
|
||||
unlock( T) :- nonvar( T),
|
||||
functor( T, _, N),
|
||||
unlock_arg( N, T).
|
||||
|
||||
unlock_arg( 0, _) :- !.
|
||||
unlock_arg( 1, T) :- !, arg( 1, T, A), unlock( A).
|
||||
unlock_arg( 2, T) :- !, arg( 1, T, A), unlock( A), arg( 2, T, B), unlock( B).
|
||||
unlock_arg( N, T) :-
|
||||
arg( N, T, A),
|
||||
unlock( A),
|
||||
M is N-1,
|
||||
unlock_arg( M, T).
|
||||
|
||||
verify_attributes( X, Y, []) :-
|
||||
get_atts( X, locked),
|
||||
!,
|
||||
var(Y),
|
||||
get_atts( Y, -locked),
|
||||
put_atts( Y, locked).
|
||||
verify_attributes( _, _, []).
|
||||
|
||||
none_locked( []).
|
||||
none_locked( [V|Vs]) :-
|
||||
not_locked( V),
|
||||
none_locked( Vs).
|
||||
|
||||
not_locked( V) :- var( V), get_atts( V, -locked).
|
||||
not_locked( V) :- nonvar( V).
|
||||
|
||||
% -------------------------- access to constraints ------------------
|
||||
|
||||
%
|
||||
% Try a list of candidates. V may be nonvar but
|
||||
% bound to a term with variables in it.
|
||||
%
|
||||
via( L, V) :-
|
||||
member( X, L),
|
||||
var( X),
|
||||
!,
|
||||
V = X.
|
||||
via( L, V) :-
|
||||
compound( L),
|
||||
nonground( L, V),
|
||||
!.
|
||||
via( _, V) :-
|
||||
global_term_ref_1( V).
|
||||
|
||||
%
|
||||
% specialization(s)
|
||||
%
|
||||
via_1( X, V) :- var(X), !, X=V.
|
||||
via_1( T, V) :- compound(T), nonground( T, V), !.
|
||||
via_1( _, V) :- global_term_ref_1( V).
|
||||
|
||||
via_2( X, _, V) :- var(X), !, X=V.
|
||||
via_2( _, Y, V) :- var(Y), !, Y=V.
|
||||
via_2( T, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_2( _, T, V) :- compound(T), nonground( T, V), !.
|
||||
via_2( _, _, V) :- global_term_ref_1( V).
|
||||
|
||||
via_3( X, _, _, V) :- var(X), !, X=V.
|
||||
via_3( _, Y, _, V) :- var(Y), !, Y=V.
|
||||
via_3( _, _, Z, V) :- var(Z), !, Z=V.
|
||||
via_3( T, _, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, T, _, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, _, T, V) :- compound(T), nonground( T, V), !.
|
||||
via_3( _, _, _, V) :- global_term_ref_1( V).
|
||||
|
||||
|
||||
%
|
||||
% The second arg is a witness.
|
||||
% The formulation with term_variables/2 is
|
||||
% cycle safe, but it finds a list of all vars.
|
||||
% We need only one, and no list in particular.
|
||||
%
|
||||
nonground( Term, V) :-
|
||||
term_variables( Term, Vs),
|
||||
Vs = [V|_].
|
||||
|
||||
/*
|
||||
nonground( Term, V) :- var( Term), V=Term.
|
||||
nonground( Term, V) :- compound( Term),
|
||||
functor( Term, _, N),
|
||||
nonground( N, Term, V).
|
||||
|
||||
%
|
||||
% assert: N > 0
|
||||
%
|
||||
nonground( 1, Term, V) :- !,
|
||||
arg( 1, Term, Arg),
|
||||
nonground( Arg, V).
|
||||
nonground( 2, Term, V) :- !,
|
||||
arg( 2, Term, Arg2),
|
||||
( nonground( Arg2, V) ->
|
||||
true
|
||||
;
|
||||
arg( 1, Term, Arg1),
|
||||
nonground( Arg1, V)
|
||||
).
|
||||
nonground( N, Term, V) :-
|
||||
arg( N, Term, Arg),
|
||||
( nonground( Arg, V) ->
|
||||
true
|
||||
;
|
||||
M is N-1,
|
||||
nonground( M, Term, V)
|
||||
).
|
||||
*/
|
||||
|
||||
constraint_generation( Susp, State, Generation) :-
|
||||
arg( 2, Susp, Mref),
|
||||
get_mutable( State, Mref),
|
||||
arg( 4, Susp, Gref),
|
||||
get_mutable( Generation, Gref). % not incremented meanwhile
|
||||
|
||||
change_state( Susp, State) :-
|
||||
arg( 2, Susp, Mref),
|
||||
update_mutable( State, Mref).
|
||||
|
||||
:- meta_predicate expose(-,+,+,+,:).
|
||||
%
|
||||
expose_active( Ref, Head, Tid, Heads, Continuation) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
update_mutable( [active(Head,Tid,Heads,Continuation)|Exposed], Ref).
|
||||
|
||||
expose_passive( Ref, Heads) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
update_mutable( [passive(Heads)|Exposed], Ref).
|
||||
|
||||
de_expose( Ref) :-
|
||||
get_mutable( [_|Exposed], Ref),
|
||||
update_mutable( Exposed, Ref).
|
||||
|
||||
%
|
||||
% Prefer passive over active (cheaper to deal with).
|
||||
%
|
||||
is_exposed( Constraint, Suspension, Continuation) :-
|
||||
get_exposed( Ref),
|
||||
get_mutable( Exposed, Ref),
|
||||
is_exposed( Exposed, Constraint, Suspension, Continuation).
|
||||
|
||||
is_exposed( [E|Es], Constraint, Suspension, Continuation) :-
|
||||
is_exposed( E, Constraint, Suspension, Continuation, Es).
|
||||
|
||||
is_exposed( active(Head,Susp,Heads,Cont), Constraint, Suspension, Continuation, Es) :-
|
||||
( member( C#Suspension, Heads),
|
||||
Constraint == C ->
|
||||
Continuation = true
|
||||
; Constraint == Head ->
|
||||
( is_exposed( Es, Constraint, Suspension, true) -> % prefer
|
||||
Continuation = true
|
||||
;
|
||||
Continuation = Cont,
|
||||
Suspension = Susp
|
||||
)
|
||||
;
|
||||
is_exposed( Es, Constraint, Suspension, Continuation)
|
||||
).
|
||||
is_exposed( passive(Heads), Constraint, Suspension, Continuation, Es) :-
|
||||
( member( C#Suspension, Heads),
|
||||
Constraint == C ->
|
||||
Continuation = true
|
||||
;
|
||||
is_exposed( Es, Constraint, Suspension, Continuation)
|
||||
).
|
||||
|
||||
get_exposed( Ref) :-
|
||||
global_term_ref_1( Global),
|
||||
( get_atts( Global, exposed(Ref)) ->
|
||||
true
|
||||
;
|
||||
create_mutable( [], Ref),
|
||||
put_atts( Global, exposed(Ref))
|
||||
).
|
||||
|
||||
get_dbg_state( Ref) :-
|
||||
global_term_ref_1( Global),
|
||||
( get_atts( Global, dbg_state(Ref)) ->
|
||||
true
|
||||
;
|
||||
create_mutable( [], Ref),
|
||||
put_atts( Global, dbg_state(Ref))
|
||||
).
|
||||
|
||||
% ------------------- abstract data type for propagation rules -------------
|
||||
|
||||
empty_history( E) :- empty_assoc( E).
|
||||
|
||||
%
|
||||
% assert: constraints/tuples are comparable directly
|
||||
%
|
||||
novel_production( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
get_mutable( History, Ref),
|
||||
( get_assoc( Tuple, History, _) ->
|
||||
fail
|
||||
;
|
||||
true
|
||||
).
|
||||
|
||||
%
|
||||
% Not folded with novel_production/2 because guard checking
|
||||
% goes in between the two calls.
|
||||
%
|
||||
extend_history( Self, Tuple) :-
|
||||
arg( 5, Self, Ref),
|
||||
get_mutable( History, Ref),
|
||||
put_assoc( Tuple, History, x, NewHistory),
|
||||
update_mutable( NewHistory, Ref).
|
||||
|
||||
% vsc
|
||||
%
|
||||
global_term_ref(I,X) :- array_element(global_term_ref, I, X).
|
||||
global_term_ref_0(X) :- array_element(global_term_ref, 0, X).
|
||||
global_term_ref_1(X) :- array_element(global_term_ref, 1, X).
|
||||
|
||||
:- yap_flag(toplevel_hook,chr:create_global_array).
|
||||
|
||||
create_global_array :- ( array(global_term_ref,2) -> true ; true).
|
||||
|
||||
|
||||
%
|
||||
% vsc
|
||||
%
|
||||
%:- load_foreign_resource(library(system(chr))).
|
||||
|
||||
end_of_file.
|
||||
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,29 @@
|
|||
%
|
||||
% Provides compile time environment for fcompiling CHR
|
||||
%
|
||||
|
||||
env_fcompile( File) :-
|
||||
( file_mod( File, Module) ->
|
||||
fcompile( Module:File)
|
||||
; File = library(File0), file_mod( File0, Module ) ->
|
||||
fcompile( Module:File)
|
||||
; fcompile( File)
|
||||
).
|
||||
|
||||
file_mod( chr, chr) :-
|
||||
use_module( library(atts)),
|
||||
use_module( getval),
|
||||
use_module( sbag).
|
||||
file_mod( trace, chr) :-
|
||||
use_module( getval).
|
||||
file_mod( operator, chrcmp).
|
||||
file_mod( chrcmp, chrcmp) :-
|
||||
[library(operator)],
|
||||
use_module( matching),
|
||||
use_module( getval).
|
||||
file_mod( ordering, ordering) :-
|
||||
use_module( library(atts)).
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
|
||||
|
||||
:- module( concat, [concat_name/2]).
|
||||
|
||||
concat_name( List, Name) :- List=[_|_],
|
||||
conc_parts( List, Chs, []),
|
||||
atom_codes( Name, Chs).
|
||||
concat_name( F/A, Name) :-
|
||||
conc_part( F/A, Chs, []),
|
||||
atom_codes( Name, Chs).
|
||||
|
||||
conc_parts( []) --> [].
|
||||
conc_parts( [P]) --> !, conc_part( P).
|
||||
conc_parts( [P|Ps]) -->
|
||||
conc_part( P),
|
||||
"_",
|
||||
conc_parts( Ps).
|
||||
|
||||
conc_part( F/A) --> !, name( F), "/", name( A).
|
||||
conc_part( X ) --> name( X).
|
||||
|
||||
name( A) --> {name(A,Chars)}, copy( Chars).
|
||||
|
||||
copy( []) --> [].
|
||||
copy( [C|Cs]) --> [ C ], copy( Cs).
|
||||
|
|
@ -0,0 +1,411 @@
|
|||
cons_tri(1, 1, 1).
|
||||
cons_tri(1, 2, 1).
|
||||
cons_tri(1, 2, 2).
|
||||
cons_tri(1, 2, 3).
|
||||
cons_tri(1, 2, 4).
|
||||
cons_tri(1, 2, 5).
|
||||
cons_tri(1, 2, 6).
|
||||
cons_tri(1, 2, 7).
|
||||
cons_tri(1, 2, 8).
|
||||
cons_tri(1, 2, 9).
|
||||
cons_tri(1, 2, 10).
|
||||
cons_tri(1, 2, 11).
|
||||
cons_tri(1, 2, 12).
|
||||
cons_tri(1, 2, 13).
|
||||
cons_tri(1, 3, 1).
|
||||
cons_tri(1, 3, 3).
|
||||
cons_tri(1, 3, 5).
|
||||
cons_tri(1, 3, 7).
|
||||
cons_tri(1, 3, 9).
|
||||
cons_tri(1, 4, 1).
|
||||
cons_tri(1, 5, 1).
|
||||
cons_tri(1, 6, 1).
|
||||
cons_tri(1, 6, 3).
|
||||
cons_tri(1, 6, 5).
|
||||
cons_tri(1, 6, 7).
|
||||
cons_tri(1, 6, 9).
|
||||
cons_tri(1, 7, 1).
|
||||
cons_tri(1, 8, 1).
|
||||
cons_tri(1, 8, 3).
|
||||
cons_tri(1, 8, 5).
|
||||
cons_tri(1, 8, 7).
|
||||
cons_tri(1, 8, 9).
|
||||
cons_tri(1, 9, 1).
|
||||
cons_tri(1, 10, 1).
|
||||
cons_tri(1, 11, 1).
|
||||
cons_tri(1, 11, 3).
|
||||
cons_tri(1, 11, 5).
|
||||
cons_tri(1, 11, 7).
|
||||
cons_tri(1, 11, 9).
|
||||
cons_tri(1, 12, 1).
|
||||
cons_tri(2, 1, 1).
|
||||
cons_tri(2, 1, 2).
|
||||
cons_tri(2, 1, 3).
|
||||
cons_tri(2, 1, 4).
|
||||
cons_tri(2, 1, 5).
|
||||
cons_tri(2, 1, 6).
|
||||
cons_tri(2, 1, 7).
|
||||
cons_tri(2, 1, 8).
|
||||
cons_tri(2, 1, 9).
|
||||
cons_tri(2, 1, 10).
|
||||
cons_tri(2, 1, 11).
|
||||
cons_tri(2, 1, 12).
|
||||
cons_tri(2, 1, 13).
|
||||
cons_tri(2, 2, 2).
|
||||
cons_tri(2, 3, 2).
|
||||
cons_tri(2, 3, 3).
|
||||
cons_tri(2, 3, 6).
|
||||
cons_tri(2, 3, 8).
|
||||
cons_tri(2, 3, 11).
|
||||
cons_tri(2, 4, 2).
|
||||
cons_tri(2, 5, 2).
|
||||
cons_tri(2, 5, 3).
|
||||
cons_tri(2, 5, 6).
|
||||
cons_tri(2, 5, 8).
|
||||
cons_tri(2, 5, 11).
|
||||
cons_tri(2, 6, 2).
|
||||
cons_tri(2, 7, 2).
|
||||
cons_tri(2, 7, 3).
|
||||
cons_tri(2, 7, 6).
|
||||
cons_tri(2, 7, 8).
|
||||
cons_tri(2, 7, 11).
|
||||
cons_tri(2, 8, 2).
|
||||
cons_tri(2, 9, 2).
|
||||
cons_tri(2, 9, 3).
|
||||
cons_tri(2, 9, 6).
|
||||
cons_tri(2, 9, 8).
|
||||
cons_tri(2, 9, 11).
|
||||
cons_tri(2, 10, 2).
|
||||
cons_tri(2, 11, 2).
|
||||
cons_tri(2, 12, 2).
|
||||
cons_tri(3, 1, 1).
|
||||
cons_tri(3, 2, 2).
|
||||
cons_tri(3, 3, 3).
|
||||
cons_tri(3, 4, 1).
|
||||
cons_tri(3, 4, 2).
|
||||
cons_tri(3, 4, 3).
|
||||
cons_tri(3, 4, 4).
|
||||
cons_tri(3, 4, 5).
|
||||
cons_tri(3, 4, 6).
|
||||
cons_tri(3, 4, 7).
|
||||
cons_tri(3, 4, 8).
|
||||
cons_tri(3, 4, 9).
|
||||
cons_tri(3, 4, 10).
|
||||
cons_tri(3, 4, 11).
|
||||
cons_tri(3, 4, 12).
|
||||
cons_tri(3, 4, 13).
|
||||
cons_tri(3, 5, 1).
|
||||
cons_tri(3, 5, 3).
|
||||
cons_tri(3, 5, 5).
|
||||
cons_tri(3, 5, 7).
|
||||
cons_tri(3, 5, 9).
|
||||
cons_tri(3, 6, 2).
|
||||
cons_tri(3, 6, 3).
|
||||
cons_tri(3, 6, 6).
|
||||
cons_tri(3, 6, 8).
|
||||
cons_tri(3, 6, 11).
|
||||
cons_tri(3, 7, 1).
|
||||
cons_tri(3, 8, 2).
|
||||
cons_tri(3, 9, 3).
|
||||
cons_tri(3, 10, 2).
|
||||
cons_tri(3, 10, 3).
|
||||
cons_tri(3, 10, 6).
|
||||
cons_tri(3, 10, 8).
|
||||
cons_tri(3, 10, 11).
|
||||
cons_tri(3, 11, 3).
|
||||
cons_tri(3, 12, 1).
|
||||
cons_tri(3, 12, 3).
|
||||
cons_tri(3, 12, 5).
|
||||
cons_tri(3, 12, 7).
|
||||
cons_tri(3, 12, 9).
|
||||
cons_tri(4, 1, 1).
|
||||
cons_tri(4, 1, 4).
|
||||
cons_tri(4, 1, 5).
|
||||
cons_tri(4, 1, 7).
|
||||
cons_tri(4, 1, 12).
|
||||
cons_tri(4, 2, 2).
|
||||
cons_tri(4, 2, 4).
|
||||
cons_tri(4, 2, 6).
|
||||
cons_tri(4, 2, 8).
|
||||
cons_tri(4, 2, 10).
|
||||
cons_tri(4, 3, 3).
|
||||
cons_tri(4, 3, 4).
|
||||
cons_tri(4, 3, 5).
|
||||
cons_tri(4, 3, 6).
|
||||
cons_tri(4, 3, 9).
|
||||
cons_tri(4, 3, 10).
|
||||
cons_tri(4, 3, 11).
|
||||
cons_tri(4, 3, 12).
|
||||
cons_tri(4, 3, 13).
|
||||
cons_tri(4, 4, 4).
|
||||
cons_tri(4, 5, 4).
|
||||
cons_tri(4, 5, 5).
|
||||
cons_tri(4, 5, 12).
|
||||
cons_tri(4, 6, 4).
|
||||
cons_tri(4, 6, 6).
|
||||
cons_tri(4, 6, 10).
|
||||
cons_tri(4, 7, 4).
|
||||
cons_tri(4, 7, 5).
|
||||
cons_tri(4, 7, 12).
|
||||
cons_tri(4, 8, 4).
|
||||
cons_tri(4, 8, 6).
|
||||
cons_tri(4, 8, 10).
|
||||
cons_tri(4, 9, 4).
|
||||
cons_tri(4, 9, 5).
|
||||
cons_tri(4, 9, 12).
|
||||
cons_tri(4, 10, 4).
|
||||
cons_tri(4, 11, 4).
|
||||
cons_tri(4, 11, 6).
|
||||
cons_tri(4, 11, 10).
|
||||
cons_tri(4, 12, 4).
|
||||
cons_tri(5, 1, 1).
|
||||
cons_tri(5, 2, 2).
|
||||
cons_tri(5, 2, 4).
|
||||
cons_tri(5, 2, 6).
|
||||
cons_tri(5, 2, 8).
|
||||
cons_tri(5, 2, 10).
|
||||
cons_tri(5, 3, 3).
|
||||
cons_tri(5, 3, 5).
|
||||
cons_tri(5, 3, 9).
|
||||
cons_tri(5, 4, 1).
|
||||
cons_tri(5, 4, 4).
|
||||
cons_tri(5, 4, 5).
|
||||
cons_tri(5, 4, 7).
|
||||
cons_tri(5, 4, 12).
|
||||
cons_tri(5, 5, 1).
|
||||
cons_tri(5, 5, 5).
|
||||
cons_tri(5, 5, 7).
|
||||
cons_tri(5, 6, 3).
|
||||
cons_tri(5, 6, 4).
|
||||
cons_tri(5, 6, 5).
|
||||
cons_tri(5, 6, 6).
|
||||
cons_tri(5, 6, 9).
|
||||
cons_tri(5, 6, 10).
|
||||
cons_tri(5, 6, 11).
|
||||
cons_tri(5, 6, 12).
|
||||
cons_tri(5, 6, 13).
|
||||
cons_tri(5, 7, 1).
|
||||
cons_tri(5, 8, 4).
|
||||
cons_tri(5, 8, 6).
|
||||
cons_tri(5, 8, 10).
|
||||
cons_tri(5, 9, 5).
|
||||
cons_tri(5, 10, 4).
|
||||
cons_tri(5, 10, 5).
|
||||
cons_tri(5, 10, 12).
|
||||
cons_tri(5, 11, 3).
|
||||
cons_tri(5, 11, 5).
|
||||
cons_tri(5, 11, 9).
|
||||
cons_tri(5, 12, 1).
|
||||
cons_tri(5, 12, 5).
|
||||
cons_tri(5, 12, 7).
|
||||
cons_tri(6, 1, 1).
|
||||
cons_tri(6, 1, 4).
|
||||
cons_tri(6, 1, 5).
|
||||
cons_tri(6, 1, 7).
|
||||
cons_tri(6, 1, 12).
|
||||
cons_tri(6, 2, 2).
|
||||
cons_tri(6, 3, 3).
|
||||
cons_tri(6, 3, 6).
|
||||
cons_tri(6, 3, 11).
|
||||
cons_tri(6, 4, 2).
|
||||
cons_tri(6, 4, 4).
|
||||
cons_tri(6, 4, 6).
|
||||
cons_tri(6, 4, 8).
|
||||
cons_tri(6, 4, 10).
|
||||
cons_tri(6, 5, 3).
|
||||
cons_tri(6, 5, 4).
|
||||
cons_tri(6, 5, 5).
|
||||
cons_tri(6, 5, 6).
|
||||
cons_tri(6, 5, 9).
|
||||
cons_tri(6, 5, 10).
|
||||
cons_tri(6, 5, 11).
|
||||
cons_tri(6, 5, 12).
|
||||
cons_tri(6, 5, 13).
|
||||
cons_tri(6, 6, 2).
|
||||
cons_tri(6, 6, 6).
|
||||
cons_tri(6, 6, 8).
|
||||
cons_tri(6, 7, 4).
|
||||
cons_tri(6, 7, 5).
|
||||
cons_tri(6, 7, 12).
|
||||
cons_tri(6, 8, 2).
|
||||
cons_tri(6, 9, 3).
|
||||
cons_tri(6, 9, 6).
|
||||
cons_tri(6, 9, 11).
|
||||
cons_tri(6, 10, 2).
|
||||
cons_tri(6, 10, 6).
|
||||
cons_tri(6, 10, 8).
|
||||
cons_tri(6, 11, 6).
|
||||
cons_tri(6, 12, 4).
|
||||
cons_tri(6, 12, 6).
|
||||
cons_tri(6, 12, 10).
|
||||
cons_tri(7, 1, 1).
|
||||
cons_tri(7, 2, 2).
|
||||
cons_tri(7, 2, 4).
|
||||
cons_tri(7, 2, 6).
|
||||
cons_tri(7, 2, 8).
|
||||
cons_tri(7, 2, 10).
|
||||
cons_tri(7, 3, 3).
|
||||
cons_tri(7, 3, 5).
|
||||
cons_tri(7, 3, 9).
|
||||
cons_tri(7, 4, 1).
|
||||
cons_tri(7, 5, 1).
|
||||
cons_tri(7, 6, 3).
|
||||
cons_tri(7, 6, 5).
|
||||
cons_tri(7, 6, 9).
|
||||
cons_tri(7, 7, 1).
|
||||
cons_tri(7, 8, 11).
|
||||
cons_tri(7, 8, 12).
|
||||
cons_tri(7, 8, 13).
|
||||
cons_tri(7, 9, 7).
|
||||
cons_tri(7, 10, 7).
|
||||
cons_tri(7, 11, 3).
|
||||
cons_tri(7, 11, 5).
|
||||
cons_tri(7, 11, 9).
|
||||
cons_tri(7, 12, 1).
|
||||
cons_tri(8, 1, 1).
|
||||
cons_tri(8, 1, 4).
|
||||
cons_tri(8, 1, 5).
|
||||
cons_tri(8, 1, 7).
|
||||
cons_tri(8, 1, 12).
|
||||
cons_tri(8, 2, 2).
|
||||
cons_tri(8, 3, 3).
|
||||
cons_tri(8, 3, 6).
|
||||
cons_tri(8, 3, 11).
|
||||
cons_tri(8, 4, 2).
|
||||
cons_tri(8, 5, 3).
|
||||
cons_tri(8, 5, 6).
|
||||
cons_tri(8, 5, 11).
|
||||
cons_tri(8, 6, 1).
|
||||
cons_tri(8, 6, 3).
|
||||
cons_tri(8, 7, 9).
|
||||
cons_tri(8, 7, 10).
|
||||
cons_tri(8, 7, 13).
|
||||
cons_tri(8, 8, 2).
|
||||
cons_tri(8, 9, 3).
|
||||
cons_tri(8, 9, 6).
|
||||
cons_tri(8, 9, 11).
|
||||
cons_tri(8, 10, 2).
|
||||
cons_tri(8, 11, 8).
|
||||
cons_tri(8, 12, 8).
|
||||
cons_tri(9, 1, 1).
|
||||
cons_tri(9, 2, 2).
|
||||
cons_tri(9, 3, 3).
|
||||
cons_tri(9, 4, 1).
|
||||
cons_tri(9, 4, 4).
|
||||
cons_tri(9, 4, 5).
|
||||
cons_tri(9, 4, 7).
|
||||
cons_tri(9, 4, 12).
|
||||
cons_tri(9, 5, 1).
|
||||
cons_tri(9, 5, 5).
|
||||
cons_tri(9, 5, 7).
|
||||
cons_tri(9, 6, 3).
|
||||
cons_tri(9, 6, 6).
|
||||
cons_tri(9, 6, 11).
|
||||
cons_tri(9, 7, 1).
|
||||
cons_tri(9, 8, 8).
|
||||
cons_tri(9, 9, 9).
|
||||
cons_tri(9, 10, 9).
|
||||
cons_tri(9, 10, 10).
|
||||
cons_tri(9, 10, 13).
|
||||
cons_tri(9, 11, 3).
|
||||
cons_tri(9, 12, 1).
|
||||
cons_tri(9, 12, 5).
|
||||
cons_tri(9, 12, 7).
|
||||
cons_tri(10, 1, 1).
|
||||
cons_tri(10, 1, 4).
|
||||
cons_tri(10, 1, 5).
|
||||
cons_tri(10, 1, 7).
|
||||
cons_tri(10, 1, 12).
|
||||
cons_tri(10, 2, 2).
|
||||
cons_tri(10, 3, 3).
|
||||
cons_tri(10, 3, 6).
|
||||
cons_tri(10, 3, 11).
|
||||
cons_tri(10, 4, 4).
|
||||
cons_tri(10, 5, 4).
|
||||
cons_tri(10, 5, 5).
|
||||
cons_tri(10, 5, 12).
|
||||
cons_tri(10, 6, 6).
|
||||
cons_tri(10, 7, 4).
|
||||
cons_tri(10, 7, 5).
|
||||
cons_tri(10, 7, 12).
|
||||
cons_tri(10, 8, 8).
|
||||
cons_tri(10, 9, 9).
|
||||
cons_tri(10, 9, 10).
|
||||
cons_tri(10, 9, 13).
|
||||
cons_tri(10, 10, 10).
|
||||
cons_tri(10, 11, 6).
|
||||
cons_tri(10, 12, 4).
|
||||
cons_tri(11, 1, 1).
|
||||
cons_tri(11, 2, 2).
|
||||
cons_tri(11, 3, 3).
|
||||
cons_tri(11, 4, 2).
|
||||
cons_tri(11, 4, 4).
|
||||
cons_tri(11, 4, 6).
|
||||
cons_tri(11, 4, 8).
|
||||
cons_tri(11, 4, 10).
|
||||
cons_tri(11, 5, 3).
|
||||
cons_tri(11, 5, 5).
|
||||
cons_tri(11, 5, 9).
|
||||
cons_tri(11, 6, 2).
|
||||
cons_tri(11, 6, 6).
|
||||
cons_tri(11, 6, 8).
|
||||
cons_tri(11, 7, 7).
|
||||
cons_tri(11, 8, 2).
|
||||
cons_tri(11, 9, 3).
|
||||
cons_tri(11, 10, 2).
|
||||
cons_tri(11, 10, 6).
|
||||
cons_tri(11, 10, 8).
|
||||
cons_tri(11, 11, 11).
|
||||
cons_tri(11, 12, 11).
|
||||
cons_tri(11, 12, 12).
|
||||
cons_tri(11, 12, 13).
|
||||
cons_tri(12, 1, 1).
|
||||
cons_tri(12, 2, 2).
|
||||
cons_tri(12, 2, 4).
|
||||
cons_tri(12, 2, 6).
|
||||
cons_tri(12, 2, 8).
|
||||
cons_tri(12, 2, 10).
|
||||
cons_tri(12, 3, 3).
|
||||
cons_tri(12, 3, 5).
|
||||
cons_tri(12, 3, 9).
|
||||
cons_tri(12, 4, 4).
|
||||
cons_tri(12, 5, 5).
|
||||
cons_tri(12, 6, 4).
|
||||
cons_tri(12, 6, 6).
|
||||
cons_tri(12, 6, 10).
|
||||
cons_tri(12, 7, 7).
|
||||
cons_tri(12, 8, 4).
|
||||
cons_tri(12, 8, 6).
|
||||
cons_tri(12, 8, 10).
|
||||
cons_tri(12, 9, 5).
|
||||
cons_tri(12, 10, 4).
|
||||
cons_tri(12, 11, 11).
|
||||
cons_tri(12, 11, 12).
|
||||
cons_tri(12, 11, 13).
|
||||
cons_tri(12, 12, 12).
|
||||
cons_tri(13, 1, 1).
|
||||
cons_tri(13, 2, 2).
|
||||
cons_tri(13, 3, 3).
|
||||
cons_tri(13, 4, 4).
|
||||
cons_tri(13, 5, 5).
|
||||
cons_tri(13, 6, 6).
|
||||
cons_tri(13, 7, 7).
|
||||
cons_tri(13, 8, 8).
|
||||
cons_tri(13, 9, 9).
|
||||
cons_tri(13, 10, 10).
|
||||
cons_tri(13, 11, 11).
|
||||
cons_tri(13, 12, 12).
|
||||
cons_tri(13, 13, 13).
|
||||
cons_tri(1, 13, 1).
|
||||
cons_tri(2, 13, 2).
|
||||
cons_tri(3, 13, 3).
|
||||
cons_tri(4, 13, 4).
|
||||
cons_tri(5, 13, 5).
|
||||
cons_tri(6, 13, 6).
|
||||
cons_tri(7, 13, 7).
|
||||
cons_tri(8, 13, 8).
|
||||
cons_tri(9, 13, 9).
|
||||
cons_tri(10, 13, 10).
|
||||
cons_tri(11, 13, 11).
|
||||
cons_tri(12, 13, 12).
|
||||
cons_tri(13, 13, 13).
|
|
@ -0,0 +1,86 @@
|
|||
% arc-consistency
|
||||
% thom fruehwirth, ECRC 941128, LMU 980312
|
||||
|
||||
:- use_module( library(chr)).
|
||||
:- use_module( library(lists), [member/2]).
|
||||
|
||||
delete( X, [X|L], L).
|
||||
delete( Y, [X|Xs], [X|Xt]) :-
|
||||
delete( Y, Xs, Xt).
|
||||
|
||||
handler arc.
|
||||
|
||||
constraints dom/2, con/3.
|
||||
% dom(X,D) variable X can take values from finite domain D, a ground list
|
||||
% con(C,X,Y) there is a constraint C between variables X and Y
|
||||
|
||||
dom(X,[Y]) ==> X=Y. % only to make unique solutions visible as bindings
|
||||
|
||||
con(C,X,Y) \ dom(X,XD), dom(Y,YD) <=>
|
||||
reduce(x_y,X,XD,Y,YD,C, NYD),
|
||||
reduce(y_x,Y,YD,X,XD,C, NXD),
|
||||
\+ (XD=NXD,YD=NYD)
|
||||
|
|
||||
dom(X,NXD),dom(Y,NYD).
|
||||
|
||||
reduce(CXY,X,XD,Y,YD,C, NYD):- % try to reduce domain by one element
|
||||
delete(GY,YD,NYD1),
|
||||
\+ (member(GX,XD),test(CXY,C,GX,GY))
|
||||
-> reduce(CXY,X,XD,Y,NYD1,C, NYD)
|
||||
;
|
||||
YD=NYD.
|
||||
|
||||
test(x_y,C,GX,GY):-
|
||||
test(C,GX,GY).
|
||||
test(y_x,C,GX,GY):-
|
||||
test(C,GY,GX).
|
||||
|
||||
|
||||
% An Instance: Santa Claus Example (in German)
|
||||
|
||||
example([anna-Anna,berta-Berta,carola-Carola,carl-Carl]):-
|
||||
dom(Anna,[laetzchen,schlafmuetze,filzpantoffel]),
|
||||
dom(Berta,[laetzchen,schlafmuetze,filzpantoffel]),
|
||||
dom(Carola,[laetzchen,schlafmuetze,filzpantoffel]),
|
||||
dom(Carl,[schlafmuetze,filzpantoffel]),
|
||||
con(mehr_als,Carl,Anna),
|
||||
con(mehr_als,Berta,Carl),
|
||||
con(mehr_als,Berta,Carola),
|
||||
con(mindestens_wie,Berta,Carola),
|
||||
con(gleich_wie,Carl,Carola).
|
||||
|
||||
test(mehr_als,Geschenk,Geschenk1) :-
|
||||
preis(Geschenk,Preis),
|
||||
preis(Geschenk1,Preis1),
|
||||
Preis > Preis1.
|
||||
|
||||
test(mindestens_wie,Geschenk,Geschenk1) :-
|
||||
preis(Geschenk,Preis),
|
||||
preis(Geschenk1,Preis1),
|
||||
Preis >= Preis1.
|
||||
|
||||
test(gleich_wie,Geschenk,Geschenk1) :-
|
||||
preis(Geschenk,Preis),
|
||||
preis(Geschenk1,Preis).
|
||||
|
||||
preis(laetzchen,10).
|
||||
preis(schlafmuetze,20).
|
||||
preis(filzpantoffel,30).
|
||||
|
||||
% eof handler arc -------------------------------------
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,282 @@
|
|||
% Thom Fruehwirth ECRC 1991-1993
|
||||
% 910528 started boolean,and,or constraints
|
||||
% 910904 added xor,neg constraints
|
||||
% 911120 added imp constraint
|
||||
% 931110 ported to new release
|
||||
% 931111 added card constraint
|
||||
% 961107 Christian Holzbaur, SICStus mods
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler bool.
|
||||
|
||||
constraints boolean/1, and/3, or/3, xor/3, neg/2, imp/2.
|
||||
constraints labeling/0.
|
||||
|
||||
|
||||
boolean(0) <=> true.
|
||||
boolean(1) <=> true.
|
||||
|
||||
labeling, boolean(A)#Pc <=>
|
||||
(A=0 ; A=1),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
|
||||
% and/3 specification
|
||||
%and(0,0,0).
|
||||
%and(0,1,0).
|
||||
%and(1,0,0).
|
||||
%and(1,1,1).
|
||||
|
||||
and(0,X,Y) <=> Y=0.
|
||||
and(X,0,Y) <=> Y=0.
|
||||
and(1,X,Y) <=> Y=X.
|
||||
and(X,1,Y) <=> Y=X.
|
||||
and(X,Y,1) <=> X=1,Y=1.
|
||||
and(X,X,Z) <=> X=Z.
|
||||
%and(X,Y,X) <=> imp(X,Y).
|
||||
%and(X,Y,Y) <=> imp(Y,X).
|
||||
and(X,Y,A) \ and(X,Y,B) <=> A=B.
|
||||
and(X,Y,A) \ and(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, and(A,B,C)#Pc <=>
|
||||
label_and(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_and(0,X,0).
|
||||
label_and(1,X,X).
|
||||
|
||||
|
||||
% or/3 specification
|
||||
%or(0,0,0).
|
||||
%or(0,1,1).
|
||||
%or(1,0,1).
|
||||
%or(1,1,1).
|
||||
|
||||
or(0,X,Y) <=> Y=X.
|
||||
or(X,0,Y) <=> Y=X.
|
||||
or(X,Y,0) <=> X=0,Y=0.
|
||||
or(1,X,Y) <=> Y=1.
|
||||
or(X,1,Y) <=> Y=1.
|
||||
or(X,X,Z) <=> X=Z.
|
||||
%or(X,Y,X) <=> imp(Y,X).
|
||||
%or(X,Y,Y) <=> imp(X,Y).
|
||||
or(X,Y,A) \ or(X,Y,B) <=> A=B.
|
||||
or(X,Y,A) \ or(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, or(A,B,C)#Pc <=>
|
||||
label_or(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_or(0,X,X).
|
||||
label_or(1,X,1).
|
||||
|
||||
|
||||
% xor/3 specification
|
||||
%xor(0,0,0).
|
||||
%xor(0,1,1).
|
||||
%xor(1,0,1).
|
||||
%xor(1,1,0).
|
||||
|
||||
xor(0,X,Y) <=> X=Y.
|
||||
xor(X,0,Y) <=> X=Y.
|
||||
xor(X,Y,0) <=> X=Y.
|
||||
xor(1,X,Y) <=> neg(X,Y).
|
||||
xor(X,1,Y) <=> neg(X,Y).
|
||||
xor(X,Y,1) <=> neg(X,Y).
|
||||
xor(X,X,Y) <=> Y=0.
|
||||
xor(X,Y,X) <=> Y=0.
|
||||
xor(Y,X,X) <=> Y=0.
|
||||
xor(X,Y,A) \ xor(X,Y,B) <=> A=B.
|
||||
xor(X,Y,A) \ xor(Y,X,B) <=> A=B.
|
||||
|
||||
labeling, xor(A,B,C)#Pc <=>
|
||||
label_xor(A,B,C),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_xor(0,X,X).
|
||||
label_xor(1,X,Y):- neg(X,Y).
|
||||
|
||||
|
||||
% neg/2 specification
|
||||
%neg(0,1).
|
||||
%neg(1,0).
|
||||
|
||||
neg(0,X) <=> X=1.
|
||||
neg(X,0) <=> X=1.
|
||||
neg(1,X) <=> X=0.
|
||||
neg(X,1) <=> X=0.
|
||||
neg(X,X) <=> fail.
|
||||
neg(X,Y) \ neg(Y,Z) <=> X=Z.
|
||||
neg(X,Y) \ neg(Z,Y) <=> X=Z.
|
||||
neg(Y,X) \ neg(Y,Z) <=> X=Z.
|
||||
% Interaction with other boolean constraints
|
||||
neg(X,Y) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(Y,X) \ and(X,Y,Z) <=> Z=0.
|
||||
neg(X,Z) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Z,X) , and(X,Y,Z) <=> X=1,Y=0,Z=0.
|
||||
neg(Y,Z) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(Z,Y) , and(X,Y,Z) <=> X=0,Y=1,Z=0.
|
||||
neg(X,Y) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ or(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Z,X) , or(X,Y,Z) <=> X=0,Y=1,Z=1.
|
||||
neg(Y,Z) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(Z,Y) , or(X,Y,Z) <=> X=1,Y=0,Z=1.
|
||||
neg(X,Y) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(Y,X) \ xor(X,Y,Z) <=> Z=1.
|
||||
neg(X,Z) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Z,X) \ xor(X,Y,Z) <=> Y=1.
|
||||
neg(Y,Z) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(Z,Y) \ xor(X,Y,Z) <=> X=1.
|
||||
neg(X,Y) , imp(X,Y) <=> X=0,Y=1.
|
||||
neg(Y,X) , imp(X,Y) <=> X=0,Y=1.
|
||||
|
||||
labeling, neg(A,B)#Pc <=>
|
||||
label_neg(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_neg(0,1).
|
||||
label_neg(1,0).
|
||||
|
||||
|
||||
% imp/2 specification (implication)
|
||||
%imp(0,0).
|
||||
%imp(0,1).
|
||||
%imp(1,1).
|
||||
|
||||
imp(0,X) <=> true.
|
||||
imp(X,0) <=> X=0.
|
||||
imp(1,X) <=> X=1.
|
||||
imp(X,1) <=> true.
|
||||
imp(X,X) <=> true.
|
||||
imp(X,Y),imp(Y,X) <=> X=Y.
|
||||
|
||||
labeling, imp(A,B)#Pc <=>
|
||||
label_imp(A,B),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_imp(0,X).
|
||||
label_imp(1,1).
|
||||
|
||||
|
||||
|
||||
% Boolean cardinality operator
|
||||
% card(A,B,L,N) constrains list L of length N to have between A and B 1s
|
||||
|
||||
constraints card/4.
|
||||
|
||||
card(A,B,L):-
|
||||
length(L,N),
|
||||
A=<B,0=<B,A=<N,%0=<N
|
||||
card(A,B,L,N).
|
||||
|
||||
% card/4 specification
|
||||
%card(A,B,[],0):- A=<0,0=<B.
|
||||
%card(A,B,[0|L],N):-
|
||||
% N1 is N-1,
|
||||
% card(A,B,L,N1).
|
||||
%card(A,B,[1|L],N):-
|
||||
% A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
% card(A1,B1,L,N1).
|
||||
|
||||
triv_sat @ card(A,B,L,N) <=> A=<0,N=<B | true. % trivial satisfaction
|
||||
pos_sat @ card(N,B,L,N) <=> set_to_ones(L). % positive satisfaction
|
||||
neg_sat @ card(A,0,L,N) <=> set_to_zeros(L). % negative satisfaction
|
||||
pos_red @ card(A,B,L,N) <=> delete(X,L,L1),X==1 | % positive reduction
|
||||
A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
card(A1,B1,L1,N1).
|
||||
neg_red @ card(A,B,L,N) <=> delete(X,L,L1),X==0 | % negative reduction
|
||||
N1 is N-1,
|
||||
card(A,B,L1,N1).
|
||||
% special cases with two variables
|
||||
card2nand @ card(0,1,[X,Y],2) <=> and(X,Y,0).
|
||||
card2neg @ card(1,1,[X,Y],2) <=> neg(X,Y).
|
||||
card2or @ card(1,2,[X,Y],2) <=> or(X,Y,1).
|
||||
|
||||
delete( X, [X|L], L).
|
||||
delete( Y, [X|Xs], [X|Xt]) :-
|
||||
delete( Y, Xs, Xt).
|
||||
|
||||
labeling, card(A,B,L,N)#Pc <=>
|
||||
label_card(A,B,L,N),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
label_card(A,B,[],0):- A=<0,0=<B.
|
||||
label_card(A,B,[0|L],N):-
|
||||
N1 is N-1,
|
||||
card(A,B,L).
|
||||
label_card(A,B,[1|L],N):-
|
||||
A1 is A-1, B1 is B-1, N1 is N-1,
|
||||
card(A1,B1,L).
|
||||
|
||||
set_to_ones([]).
|
||||
set_to_ones([1|L]):-
|
||||
set_to_ones(L).
|
||||
|
||||
set_to_zeros([]).
|
||||
set_to_zeros([0|L]):-
|
||||
set_to_zeros(L).
|
||||
|
||||
|
||||
|
||||
% Auxiliary predicates
|
||||
|
||||
operator(100,fy,(~~)).
|
||||
operator(100,xfy,(#)).
|
||||
|
||||
solve_bool(A,C) :- var(A), !, A=C.
|
||||
solve_bool(A,C) :- atomic(A), !, A=C.
|
||||
solve_bool(A * B, C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
and(A1,B1,C).
|
||||
solve_bool(A + B, C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
or(A1,B1,C).
|
||||
solve_bool(A # B, C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
xor(A1,B1,C).
|
||||
solve_bool(~~A,C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
neg(A1,C).
|
||||
solve_bool((A -> B), C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
imp(A1,B1),C=1.
|
||||
solve_bool(A = B, C) ?- !,
|
||||
solve_bool(A,A1),
|
||||
solve_bool(B,B1),
|
||||
A1=B1,C=1.
|
||||
|
||||
% Labeling
|
||||
label_bool([]).
|
||||
label_bool([X|L]) :-
|
||||
(X=0;X=1),
|
||||
label_bool(L).
|
||||
|
||||
/* % no write macros in SICStus
|
||||
|
||||
bool_portray(and(A,B,C),Out)?- !, Out = (A*B = C).
|
||||
bool_portray(or(A,B,C),Out)?- !, Out = (A+B = C).
|
||||
bool_portray(xor(A,B,C),Out)?- !, Out = (A#B = C).
|
||||
bool_portray(neg(A,B),Out)?- !, Out = (A= ~~B).
|
||||
bool_portray(imp(A,B),Out)?- !, Out = (A -> B).
|
||||
bool_portray(card(A,B,L,N),Out)?- !, Out = card(A,B,L).
|
||||
|
||||
:- define_macro(type(compound),bool_portray/2,[write]).
|
||||
*/
|
||||
|
||||
/* end of handler bool */
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,141 @@
|
|||
% Feature Tree Constraints (CFT) ---------------------------------------------
|
||||
% following Records for Logic Programming (Smolka,Treinen) JLP 1994:18:229-258
|
||||
% 950512 Thom Fruehwirth ECRC, based on osf.pl, see also kl-one.pl, type.pl
|
||||
% 980211, 980311 Thom Fruehwirth LMU for Sicstus CHR
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler cft.
|
||||
|
||||
operator(100,xfx,'::'). % Variable::Sort/Expression sort constraint
|
||||
operator(100,xfx,'@@'). % Variable@@LabelList arity/label constraint
|
||||
operator(450,xfy,'##'). % Variable##Feature##Value feature constraint
|
||||
% in X@@A assumes that A is a sorted list of ground features
|
||||
% in X##F##Y assumes that feature F is a ground term and Y stays a variable or is atomic
|
||||
|
||||
constraints (::)/2, (@@)/2, (##)/2.
|
||||
|
||||
% CFT Term Dissolution
|
||||
X::T <=> nonvar(T), \+ atomic(T) | dissolve(X,T).
|
||||
|
||||
dissolve(X,T):-
|
||||
T=..[S|Ls], X::S, dissolve1(X,Ls,A), sort(A,As), X@@As.
|
||||
dissolve1(X,[],[]).
|
||||
dissolve1(X,[L1::T1|Ls],[L1|Ls1]):-
|
||||
X##L1##TV,
|
||||
(nonvar(T1) -> dissolve(TV,T1) ; TV=T1),
|
||||
dissolve1(X,Ls,Ls1).
|
||||
|
||||
%!!! sort arity list, load member/2
|
||||
|
||||
% CFT Axiom scheme
|
||||
% see section 3, p.235, p.236
|
||||
% see proof of proposition 6.5, p.245
|
||||
|
||||
% (S) sort are pairwise disjoint
|
||||
X::S1 \ X::S2 <=> S1=S2.
|
||||
|
||||
% (F) features are functional
|
||||
X##L##Y \ X##L##Z <=> Y=Z.
|
||||
|
||||
% (A2) arities are unique
|
||||
% sorting removes duplicate features
|
||||
X@@A1 \ X@@A2 <=> A1=A2.
|
||||
|
||||
% (A1) If X has arity A, exactly the features in A are defined on X
|
||||
X@@A, X##F##Y ==> member(F,A).
|
||||
|
||||
member(X,[Y|L]):- X=Y ; member(X,L).
|
||||
|
||||
% (D) determinant
|
||||
% not implemented yet
|
||||
|
||||
|
||||
% EXAMPLES ---------------------------------------------------------------
|
||||
|
||||
% page 236, determinant
|
||||
eg0([U,V,W]-[X,Y,Z]):-
|
||||
X::a(f::V,g::Y),
|
||||
Y::b(f::X,g::Z,h::u),
|
||||
Z::a(f::W,g::Y,h::Z).
|
||||
|
||||
% cyclic structure, adapted from page 1, DEC-PRL RR 32
|
||||
eg1(P):-
|
||||
P::person(name::id(first::_,
|
||||
last::S),
|
||||
age::30,
|
||||
spouse::person(name::id(last::S),
|
||||
spouse::P)).
|
||||
|
||||
% cyclic list, adapted from p. 3, DEC-PRL RR 32
|
||||
eg2(X):-
|
||||
X::cons(head::1,tail::X).
|
||||
eg2a(X):- % same result as eg2(X)
|
||||
X::cons(head::1,tail::X), X::cons(head::1,tail::cons(head::1,tail::X)).
|
||||
|
||||
% adapted from p.17, DEC-PRL RR 32
|
||||
eg3(X):-
|
||||
X::s1(l1::s),X::s2(l2::s).
|
||||
|
||||
/*
|
||||
|
||||
| ?- eg0(X); eg1(X) ; eg2(X) ; eg2a(X) ; eg3(X).
|
||||
|
||||
X = [_A,_B,_C]-[_D,_E,_F],
|
||||
_D::a,
|
||||
_D##f##_B,
|
||||
_D##g##_E,
|
||||
_D@@[f,g],
|
||||
_E::b,
|
||||
_E##f##_D,
|
||||
_E##g##_F,
|
||||
_E##h##_G,
|
||||
_G::u,
|
||||
_G@@[],
|
||||
_E@@[f,g,h],
|
||||
_F::a,
|
||||
_F##f##_C,
|
||||
_F##g##_E,
|
||||
_F##h##_F,
|
||||
_F@@[f,g,h] ? ;
|
||||
|
||||
X::person,
|
||||
X##name##_A,
|
||||
_A::id,
|
||||
_A##first##_B,
|
||||
_A##last##_C,
|
||||
_A@@[first,last],
|
||||
X##age##_D,
|
||||
_D::30,
|
||||
_D@@[],
|
||||
X##spouse##_E,
|
||||
_E::person,
|
||||
_E##name##_F,
|
||||
_F::id,
|
||||
_F##last##_C,
|
||||
_F@@[last],
|
||||
_E##spouse##X,
|
||||
_E@@[name,spouse],
|
||||
X@@[age,name,spouse] ? ;
|
||||
|
||||
X::cons,
|
||||
X##head##_A,
|
||||
_A::1,
|
||||
_A@@[],
|
||||
X##tail##X,
|
||||
X@@[head,tail] ? ;
|
||||
|
||||
X::cons,
|
||||
X##head##_A,
|
||||
_A::1,
|
||||
_A@@[],
|
||||
X##tail##X,
|
||||
X@@[head,tail] ? ;
|
||||
|
||||
*/
|
||||
|
||||
% end of handler cft ----------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,472 @@
|
|||
% FINITE and INFINITE DOMAINS
|
||||
% 910527 ECRC thom fruehwirth
|
||||
% 910913 modified
|
||||
% 920409 element/3 added
|
||||
% 920616 more CHIP predicates added
|
||||
% 930726 started porting to CHR release
|
||||
% 931014 mult/3 added for CHIC user meeting
|
||||
% 931201 ported to CHR release
|
||||
% 931208 removed special case of integer domain
|
||||
% 940304 element/3 constraint loop fixed
|
||||
% 961017 Christian Holzbaur SICStus mods
|
||||
% 980714 Thom Fruehwirth, some updates reagrding alread_in*
|
||||
|
||||
% just quick port from Eclipse CHR library version
|
||||
% does not take advantage of Sicstus CHR library features!
|
||||
|
||||
% Simplifies domains together with inequalities and some more CHIP predicates:
|
||||
% element/3, atmost/3, alldistinct/1, circuit/1 and mult/3
|
||||
% It also includes paired (!) domains (see element constraint)
|
||||
|
||||
:- use_module( library(chr)).
|
||||
:- use_module( library('chr/getval')).
|
||||
:- use_module( library(lists), [member/2,last/2]).
|
||||
|
||||
:- use_module( library(ordsets),
|
||||
[
|
||||
list_to_ord_set/2,
|
||||
ord_intersection/3
|
||||
]).
|
||||
|
||||
handler domain.
|
||||
|
||||
option(already_in_store, on).
|
||||
option(already_in_heads, off). % see pragma already_in_heads
|
||||
option(check_guard_bindings, off).
|
||||
|
||||
% for domain constraints
|
||||
operator(700,xfx,'::').
|
||||
operator(600,xfx,'..').
|
||||
operator(600,xfx,':'). % clash with module operator?
|
||||
|
||||
% for inequality constraints
|
||||
operator(700,xfx,lt).
|
||||
operator(700,xfx,le).
|
||||
operator(700,xfx,gt).
|
||||
operator(700,xfx,ge).
|
||||
operator(700,xfx,ne).
|
||||
|
||||
% X::Dom - X must be element of the finite or infinite domain Dom
|
||||
|
||||
% Domains can be either numbers (including arithemtic expressions)
|
||||
% or arbitrary ground terms (!), the domain is set with setval(domain,Kind),
|
||||
% where Kind is either number or term. Default for Kind is term.
|
||||
|
||||
:- setval(domain,term). % set default
|
||||
|
||||
|
||||
% INEQUALITIES ===============================================================
|
||||
% inequalities over numbers (including arithmetic expressions) or terms
|
||||
|
||||
constraints lt/2,le/2,ne/2.
|
||||
|
||||
A gt B :- B lt A. % constraints gt/2,ge/2
|
||||
A ge B :- B le A.
|
||||
% some basic simplifications
|
||||
A lt A <=> fail.
|
||||
A le A <=> true.
|
||||
A ne A <=> fail.
|
||||
A lt B,B lt A <=> fail.
|
||||
A le B,B le A <=> A=B.
|
||||
A ne B \ B ne A <=> true.
|
||||
% for number domain, allow arithmetic expressions in the arguments
|
||||
A lt B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 lt B.
|
||||
B lt A <=> domain(number),ground(A),\+ number(A) | A1 is A, B lt A1.
|
||||
A le B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 le B.
|
||||
B le A <=> domain(number),ground(A),\+ number(A) | A1 is A, B le A1.
|
||||
A ne B <=> domain(number),ground(A),\+ number(A) | A1 is A, A1 ne B.
|
||||
B ne A <=> domain(number),ground(A),\+ number(A) | A1 is A, B ne A1.
|
||||
% use built-ins to solve the predicates if arguments are known
|
||||
A lt B <=> ground(A),ground(B) | (domain(number) -> A < B ; A @< B).
|
||||
A le B <=> ground(A),ground(B) | (domain(number) -> A =< B ; A @=< B).
|
||||
A ne B <=> ground(A),ground(B) | (domain(number) -> A =\= B ; A \== B).
|
||||
|
||||
|
||||
|
||||
% FINITE and INFINITE DOMAINS ================================================
|
||||
|
||||
constraints (::)/2.
|
||||
|
||||
% enforce groundness of domain expression
|
||||
X::Dom <=> nonground(Dom) |
|
||||
raise_exception( instantiation_error(X::Dom,2)).
|
||||
|
||||
constraints labeling/0.
|
||||
|
||||
labeling, (X::[Y|L]) # Ph <=>
|
||||
member(X,[Y|L]), labeling
|
||||
pragma passive(Ph).
|
||||
|
||||
% binary search by splitting domain in halves
|
||||
labeling, (X::Min:Max) # Ph <=> domain(number),Min+0.5<Max | % ensure termination
|
||||
(integer(Min),integer(Max) -> % assume we have integer domain
|
||||
Mid is (Min+Max)//2, Next is Mid+1
|
||||
;
|
||||
Mid is (Min+Max)/2, Next=Mid % splitted domains overlap at Mid for floats
|
||||
),
|
||||
(
|
||||
X::Min:Mid
|
||||
;
|
||||
X::Next:Max
|
||||
% ;
|
||||
% Min+1>Max, % for floats only, to get X also bound
|
||||
% X=Min % or X=Max etc.
|
||||
),
|
||||
labeling
|
||||
pragma passive(Ph).
|
||||
|
||||
nonground(X) :- ground(X), !, fail.
|
||||
nonground(_).
|
||||
|
||||
domain(Kind) :- getval(domain,Kind).
|
||||
|
||||
% CHIP list shorthand for domain variables
|
||||
% list must be known (end in the empty list)
|
||||
|
||||
[X|L]::Dom <=> makedom([X|L],Dom).
|
||||
|
||||
makedom([],D) :- true.
|
||||
makedom([X|L],D) :-
|
||||
nonvar(L),
|
||||
X::D,
|
||||
makedom(L,D).
|
||||
|
||||
|
||||
% Consecutive integer domain ---------------------------------------------
|
||||
% X::Min..Max - X is an integer between the numbers Min and Max (included)
|
||||
% constraint is mapped to enumeration domain constraint
|
||||
X::Min..Max <=>
|
||||
Min0 is Min,
|
||||
(Min0=:=round(float(Min0)) -> Min1 is integer(Min0) ; Min1 is integer(Min0+1)),
|
||||
Max1 is integer(Max),
|
||||
interval(Min1,Max1,L),
|
||||
X::L.
|
||||
|
||||
interval(M,N,[M|Ns]):-
|
||||
M<N,
|
||||
!,
|
||||
M1 is M+1,
|
||||
interval(M1,N,Ns).
|
||||
interval(N,N,[N]).
|
||||
|
||||
|
||||
% Enumeration domain -----------------------------------------------------
|
||||
|
||||
% X::Dom - X must be a ground term in the ascending sorted ground list Dom
|
||||
X::[A|L] <=> list_to_ord_set([A|L],SL), SL\==[A|L] | X::SL.
|
||||
% for number domain, allow arithmetic expressions in domain
|
||||
X::[A|L] <=> domain(number), member(X,[A|L]), \+ number(X) |
|
||||
eval_list([A|L],L1),list_to_ord_set(L1,L2), X::L2.
|
||||
|
||||
eval_list([],[]).
|
||||
eval_list([X|L1],[Y|L2]):-
|
||||
Y is X,
|
||||
eval_list(L1,L2).
|
||||
|
||||
% special cases
|
||||
X::[] <=> fail.
|
||||
X::[Y] <=> X=Y.
|
||||
X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true).
|
||||
|
||||
% intersection of domains for the same variable
|
||||
% without pragma already_in_heads, needs already_in_store
|
||||
X::[A1|L1] \ X::[A2|L2] <=>
|
||||
ord_intersection([A1|L1],[A2|L2],L),
|
||||
L \== [A2|L2]
|
||||
|
|
||||
X::L.
|
||||
|
||||
% interaction with inequalities
|
||||
X::[A|L] \ X ne Y <=> integer(Y), remove(Y,[A|L],L1) | X::L1.
|
||||
X::[A|L] \ Y ne X <=> integer(Y), remove(Y,[A|L],L1) | X::L1.
|
||||
|
||||
X::[A|L], Y le X ==> ground(Y), remove_lower(Y,[A|L],L1) | X::L1.
|
||||
X::[A|L], X le Y ==> ground(Y), remove_higher(Y,[A|L],L1) | X::L1.
|
||||
X::[A|L], Y lt X ==> ground(Y), remove_lower(Y,[A|L],L1),remove(Y,L1,L2) | X::L2.
|
||||
X::[A|L], X lt Y ==> ground(Y), remove_higher(Y,[A|L],L1),remove(Y,L1,L2) | X::L2.
|
||||
|
||||
% interaction with interval domain
|
||||
X::[A|L], X::Min:Max ==> remove_lower(Min,[A|L],L1),remove_higher(Max,L1,L2) | X::L2.
|
||||
|
||||
% propagation of bounds
|
||||
X le Y, Y::[A|L] ==> var(X) | last([A|L],Max), X le Max.
|
||||
X le Y, X::[Min|_] ==> var(Y) | Min le Y.
|
||||
X lt Y, Y::[A|L] ==> var(X) | last([A|L],Max), X lt Max.
|
||||
X lt Y, X::[Min|_] ==> var(Y) | Min lt Y.
|
||||
|
||||
% Interval domain ---------------------------------------------------------
|
||||
% X::Min:Max - X must be a ground term between Min and Max (included)
|
||||
% for number domain, allow for arithmetic expressions ind omain
|
||||
% for integer domains, X::Min..Max should be used
|
||||
X::Min:Max <=> domain(number), \+ (number(Min),number(Max)) |
|
||||
Min1 is Min, Max1 is Max, X::Min1:Max1.
|
||||
% special cases
|
||||
X::Min:Min <=> X=Min.
|
||||
X::Min:Max <=> (domain(number) -> Min>Max ; Min@>Max) | fail.
|
||||
X::Min:Max <=> ground(X) |
|
||||
(domain(number) -> Min=<X,X=<Max ; Min@=<X,X@=<Max).
|
||||
% intersection of domains for the same variable
|
||||
% without pragma already_in_heads, needs already_in_store
|
||||
X::Min1:Max1 \ X::Min2:Max2 <=> maximum(Min1,Min2,Min),
|
||||
minimum(Max1,Max2,Max),
|
||||
(Min \== Min2 ; Max \== Max2 ) |
|
||||
X::Min:Max.
|
||||
|
||||
minimum(A,B,C):- (domain(number) -> A<B ; A@<B) -> A=C ; B=C.
|
||||
maximum(A,B,C):- (domain(number) -> A<B ; A@<B) -> B=C ; A=C.
|
||||
|
||||
% interaction with inequalities
|
||||
X::Min:Max \ X ne Y <=> ground(Y),
|
||||
(domain(number) -> (Y<Min;Y>Max) ; (Y@<Min;Y@>Max)) | true.
|
||||
X::Min:Max \ Y ne X <=> ground(Y),
|
||||
(domain(number) -> (Y<Min;Y>Max) ; (Y@<Min;Y@>Max)) | true.
|
||||
X::Min1:Max \ Min2 le X <=> ground(Min2) , maximum(Min1,Min2,Min) | X::Min:Max.
|
||||
X::Min:Max1 \ X le Max2 <=> ground(Max2) , minimum(Max1,Max2,Max) | X::Min:Max.
|
||||
X::Min1:Max \ Min2 lt X <=> ground(Min2) , maximum(Min1,Min2,Min) |
|
||||
X::Min:Max, X ne Min.
|
||||
X::Min:Max1 \ X lt Max2 <=> ground(Max2) , minimum(Max1,Max2,Max) |
|
||||
X::Min:Max, X ne Max.
|
||||
% propagation of bounds
|
||||
X le Y, Y::Min:Max ==> var(X) | X le Max.
|
||||
X le Y, X::Min:Max ==> var(Y) | Min le Y.
|
||||
X lt Y, Y::Min:Max ==> var(X) | X lt Max.
|
||||
X lt Y, X::Min:Max ==> var(Y) | Min lt Y.
|
||||
|
||||
|
||||
|
||||
% MULT/3 EXAMPLE EXTENSION ==================================================
|
||||
% mult(X,Y,C) - integer X multiplied by integer Y gives the integer constant C.
|
||||
|
||||
constraints mult/3.
|
||||
|
||||
mult(X,Y,C) <=> ground(X) | (X=:=0 -> C=:=0 ; 0=:=C mod X, Y is C//X).
|
||||
mult(Y,X,C) <=> ground(X) | (X=:=0 -> C=:=0 ; 0=:=C mod X, Y is C//X).
|
||||
mult(X,Y,C), X::MinX:MaxX ==>
|
||||
%(Dom=MinX:MaxX -> true ; Dom=[MinX|L],last(L,MaxX)),
|
||||
MinY is (C-1)//MaxX+1,
|
||||
MaxY is C//MinX,
|
||||
Y::MinY:MaxY.
|
||||
mult(Y,X,C), X::MinX:MaxX ==>
|
||||
%(Dom=MinX:MaxX -> true ; Dom=[MinX|L],last(L,MaxX)),
|
||||
MinY is (C-1)//MaxX+1,
|
||||
MaxY is C//MinX,
|
||||
Y::MinY:MaxY.
|
||||
|
||||
/*
|
||||
:- mult(X,Y,156),[X,Y]::2:156,X le Y.
|
||||
|
||||
X = X_g307
|
||||
Y = Y_g331
|
||||
|
||||
Constraints:
|
||||
(1) mult(X_g307, Y_g331, 156)
|
||||
(7) Y_g331 :: 2 : 78
|
||||
(8) X_g307 :: 2 : 78
|
||||
(10) X_g307 le Y_g331
|
||||
|
||||
yes.
|
||||
:- mult(X,Y,156),[X,Y]::2:156,X le Y,labeling.
|
||||
|
||||
X = 12
|
||||
Y = 13 More? (;)
|
||||
|
||||
X = 6
|
||||
Y = 26 More? (;)
|
||||
|
||||
X = 4
|
||||
Y = 39 More? (;)
|
||||
|
||||
X = 2
|
||||
Y = 78 More? (;)
|
||||
|
||||
X = 3
|
||||
Y = 52 More? (;)
|
||||
|
||||
no (more) solution.
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
||||
% CHIP ELEMENT/3 ============================================================
|
||||
% translated to "pair domains", a very powerful extension of usual domains
|
||||
% this version does not work with arithmetic expressions!
|
||||
|
||||
element(I,VL,V):- length(VL,N),interval(1,N,IL),gen_pair(IL,VL,BL), I-V::BL.
|
||||
|
||||
gen_pair([],[],[]).
|
||||
gen_pair([A|L1],[B|L2],[A-B|L3]):-
|
||||
gen_pair(L1,L2,L3).
|
||||
|
||||
% special cases
|
||||
I-I::L <=> setof(X,member(X-X,L),L1), I::L1.
|
||||
I-V::L <=> ground(I) | setof(X,member(I-X,L),L1), V::L1.
|
||||
I-V::L <=> ground(V) | setof(X,member(X-V,L),L1), I::L1.
|
||||
% intersections
|
||||
X::[A|L1], X-Y::L2 <=> intersect(I::[A|L1],I-V::L2,I-V::L3),
|
||||
length(L2,N2),length(L3,N3),N2>N3 | X-Y::L3.
|
||||
Y::[A|L1], X-Y::L2 <=> intersect(V::[A|L1],I-V::L2,I-V::L3),
|
||||
length(L2,N2),length(L3,N3),N2>N3 | X-Y::L3.
|
||||
X-Y::L1, Y-X::L2 <=> intersect(I-V::L1,V-I::L2,I-V::L3) | X-Y::L3.
|
||||
X-Y::L1, X-Y::L2 <=> intersect(I-V::L1,I-V::L2,I-V::L3) | X-Y::L3 pragma already_in_heads.
|
||||
|
||||
intersect(A::L1,B::L2,C::L3):- setof(C,A^B^(member(A,L1),member(B,L2)),L3).
|
||||
|
||||
% inequalties with two common variables
|
||||
Y lt X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R@< S),L1) | X-Y::L1.
|
||||
X lt Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S@< R),L1) | X-Y::L1.
|
||||
Y le X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R@=<S),L1) | X-Y::L1.
|
||||
X le Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S@=<R),L1) | X-Y::L1.
|
||||
Y ne X, X-Y::L <=> A=R-S,setof(A,(member(A,L),R\==S),L1) | X-Y::L1.
|
||||
X ne Y, X-Y::L <=> A=R-S,setof(A,(member(A,L),S\==R),L1) | X-Y::L1.
|
||||
% propagation between paired domains (path-consistency)
|
||||
% X-Y::L1, Y-Z::L2 ==> intersect(A-B::L1,B-C::L2,A-C::L), X-Z::L.
|
||||
% X-Y::L1, Z-Y::L2 ==> intersect(A-B::L1,C-B::L2,A-C::L), X-Z::L.
|
||||
% X-Y::L1, X-Z::L2 ==> intersect(I-V::L1,I-W::L2,V-W::L), Y-Z::L.
|
||||
% propagation to usual unary domains
|
||||
X-Y::L ==> A=R-S,setof(R,A^member(A,L),L1), X::L1,
|
||||
setof(S,A^member(A,L),L2), Y::L2.
|
||||
|
||||
|
||||
|
||||
% ATMOST/3 ===================================================================
|
||||
|
||||
atmost(N,List,V):-length(List,K),atmost(N,List,V,K).
|
||||
|
||||
constraints atmost/4.
|
||||
|
||||
atmost(N,List,V,K) <=> K=<N | true.
|
||||
atmost(0,List,V,K) <=> (ground(V);ground(List)) | outof(V,List).
|
||||
atmost(N,List,V,K) <=> K>N,ground(V),delete_ground(X,List,L1) |
|
||||
(X==V -> N1 is N-1 ; N1=N),K1 is K-1, atmost(N1,L1,V,K1).
|
||||
|
||||
delete_ground(X,List,L1):- delete(X,List,L1),ground(X),!.
|
||||
|
||||
delete( X, [X|Xs], Xs).
|
||||
delete( Y, [X|Xs], [X|Xt]) :-
|
||||
delete( Y, Xs, Xt).
|
||||
|
||||
|
||||
% ALLDISTINCT/1 ===============================================================
|
||||
% uses ne/2 constraint
|
||||
|
||||
constraints alldistinct/1.
|
||||
|
||||
alldistinct([]) <=> true.
|
||||
alldistinct([X]) <=> true.
|
||||
alldistinct([X,Y]) <=> X ne Y.
|
||||
alldistinct([A|L]) <=> delete_ground(X,[A|L],L1) | outof(X,L1),alldistinct(L1).
|
||||
|
||||
alldistinct([]).
|
||||
alldistinct([X|L]):-
|
||||
outof(X,L),
|
||||
alldistinct(L).
|
||||
|
||||
outof(X,[]).
|
||||
outof(X,[Y|L]):-
|
||||
X ne Y,
|
||||
outof(X,L).
|
||||
|
||||
constraints alldistinct1/2.
|
||||
|
||||
alldistinct1(R,[]) <=> true.
|
||||
alldistinct1(R,[X]), X::[A|L] <=> ground(R) |
|
||||
remove_list(R,[A|L],T), X::T.
|
||||
alldistinct1(R,[X]) <=> (ground(R);ground(X)) | outof(X,R).
|
||||
alldistinct1(R,[A|L]) <=> ground(R),delete_ground(X,[A|L],L1) |
|
||||
(member(X,R) -> fail ; alldistinct1([X|R],L1)).
|
||||
|
||||
|
||||
|
||||
% CIRCUIT/1 =================================================================
|
||||
|
||||
% constraints circuit1/1, circuit/1.
|
||||
% uses list domains and ne/2
|
||||
|
||||
|
||||
% lazy version
|
||||
|
||||
circuit1(L):-length(L,N),N>1,circuit1(N,L).
|
||||
|
||||
circuit1(2,[2,1]).
|
||||
circuit1(N,L):- N>2,
|
||||
interval(1,N,D),
|
||||
T=..[f|L],
|
||||
domains1(1,D,L),
|
||||
alldistinct1([],L),
|
||||
no_subtours(N,1,T,[]).
|
||||
|
||||
domains1(N,D,[]).
|
||||
domains1(N,D,[X|L]):-
|
||||
remove(N,D,DX),
|
||||
X::DX,
|
||||
N1 is N+1,
|
||||
domains1(N1,D,L).
|
||||
|
||||
no_subtours(0,N,L,R):- !.
|
||||
no_subtours(K,N,L,R):-
|
||||
outof(N,R),
|
||||
(var(N) -> freeze(N,no_subtours1(K,N,L,R)) ; no_subtours1(K,N,L,R)).
|
||||
% no_subtours(K,N,T,R) \ no_subtours(K1,N,T,_) <=> K<K1 | true.
|
||||
|
||||
no_subtours1(K,N,L,R):-
|
||||
K>0,K1 is K-1,arg(N,L,A),no_subtours(K1,A,L,[N|R]).
|
||||
|
||||
|
||||
% eager version
|
||||
|
||||
circuit(L):- length(L,N),N>1,circuit(N,L).
|
||||
|
||||
circuit(2,[2,1]).
|
||||
%circuit(3,[2,3,1]).
|
||||
%circuit(3,[3,1,2]).
|
||||
circuit(N,L):- N>2,
|
||||
interval(1,N,D),
|
||||
T=..[f|L],
|
||||
N1 is N-1,
|
||||
domains(1,D,L,T,N1),
|
||||
alldistinct(L).
|
||||
|
||||
domains(N,D,[],T,K).
|
||||
domains(N,D,[X|L],T,K):-
|
||||
remove(N,D,DX),
|
||||
X::DX,
|
||||
N1 is N+1,
|
||||
no_subtours(K,N,T,[]), % unfolded
|
||||
%no_subtours1(K,X,T,[N]),
|
||||
domains(N1,D,L,T,K).
|
||||
|
||||
|
||||
|
||||
|
||||
% remove*/3 auxiliary predicates =============================================
|
||||
|
||||
remove(A,B,C):-
|
||||
delete(A,B,C) -> true ; B=C.
|
||||
|
||||
remove_list(_,[],T):- !, T=[].
|
||||
remove_list([],S,T):- S=T.
|
||||
remove_list([X|R],[Y|S],T):- remove(X,[Y|S],S1),remove_list(R,S1,T).
|
||||
|
||||
remove_lower(_,[],L1):- !, L1=[].
|
||||
remove_lower(Min,[X|L],L1):-
|
||||
X@<Min,
|
||||
!,
|
||||
remove_lower(Min,L,L1).
|
||||
remove_lower(Min,[X|L],[X|L1]):-
|
||||
remove_lower(Min,L,L1).
|
||||
|
||||
remove_higher(_,[],L1):- !, L1=[].
|
||||
remove_higher(Max,[X|L],L1):-
|
||||
X@>Max,
|
||||
!,
|
||||
remove_higher(Max,L,L1).
|
||||
remove_higher(Max,[X|L],[X|L1]):-
|
||||
remove_higher(Max,L,L1).
|
||||
|
||||
|
||||
|
||||
% end of handler domain.chr =================================================
|
||||
% ===========================================================================
|
||||
|
||||
|
|
@ -0,0 +1,235 @@
|
|||
% Simple examples for boolean handler
|
||||
/*
|
||||
[eclipse 6]: and(X,Y,Z),(X=1;X=0;X=Y).
|
||||
|
||||
Z = Var_m333
|
||||
X = 1
|
||||
Y = Var_m333
|
||||
|
||||
Constraints:
|
||||
(3) boolean(Var_m333)
|
||||
More? (;)
|
||||
|
||||
Z = 0
|
||||
X = 0
|
||||
Y = Var_m333
|
||||
|
||||
Constraints:
|
||||
(3) boolean(Var_m333)
|
||||
More? (;)
|
||||
|
||||
Z = _m309
|
||||
X = _m309
|
||||
Y = _m309
|
||||
|
||||
Constraints:
|
||||
(3) boolean(_m309)
|
||||
|
||||
yes.
|
||||
*/
|
||||
|
||||
|
||||
% alternative formulations
|
||||
|
||||
nand1(X1,Y1,Z):- and(X,Y,Z),neg(X1,X),neg(Y1,Y).
|
||||
nand2(X1,Y1,Z):- or(X1,Y1,Z1),neg(Z1,Z).
|
||||
test_nand(X,Y,Z1,Z2):- nand1(X,Y,Z1),nand2(X,Y,Z2),neg(Z1,Z2).
|
||||
|
||||
or1(X,Y,Z):- nand1(X,Y,Z1),neg(Z1,Z).
|
||||
or2(X,Y,Z):- nand2(X,Y,Z1),neg(Z1,Z).
|
||||
or3(A,B,C):- xor(A,B,D),and(A,B,E),xor(D,E,C).
|
||||
test_or(A,B,C,D):- (or1(A,B,C);or2(A,B,C);or3(A,B,C)),or(A,B,D),neg(C,D).
|
||||
|
||||
xor1(A,B,C):- or(A,B,C1), and(A,B,C2), neg(C2,C3), and(C1,C3,C).
|
||||
test_xor(A,B,C,D):- xor1(A,B,C),xor(A,B,D),neg(C,D).
|
||||
|
||||
and1(A,B,C):- neg(A,AN),neg(B,BN),or(AN,BN,CN),neg(CN,C).
|
||||
test_and(A,B,C,D):- and1(A,B,C),and(A,B,D),neg(C,D).
|
||||
|
||||
test(X,Y,Z):- and(X,Y,Z),or(X,Y,Z),neg(X,Z).
|
||||
|
||||
|
||||
% full-adder circuit boolean algebra example sept 1991, nov 1993
|
||||
|
||||
add(I1,I2,I3,O1,O2):-
|
||||
xor(I1,I2,X1),
|
||||
and(I1,I2,A1),
|
||||
xor(I3,X1,O1),
|
||||
and(I3,X1,A2),
|
||||
or(A1,A2,O2).
|
||||
/*
|
||||
add(L1,L2,L3):- add(L1,L2,L3,0).
|
||||
|
||||
add([],[],[C],C).
|
||||
add([X|L1],[Y|L2],[Z|L3],C):-
|
||||
add(X,Y,C,Z,C1),
|
||||
add(L1,L2,L3,C1).
|
||||
*/
|
||||
|
||||
add(L1,L2,[C|L3]):- add(L1,L2,L3,C).
|
||||
|
||||
add([],[],[],0).
|
||||
add([X|L1],[Y|L2],[Z|L3],C):-
|
||||
add(L1,L2,L3,C1),
|
||||
add(X,Y,C1,Z,C).
|
||||
|
||||
/*
|
||||
[eclipse 56]: add(L,L,R).
|
||||
|
||||
L = []
|
||||
R = [0] More? (;)
|
||||
|
||||
L = [_g71]
|
||||
R = [_g71, 0] More? (;)
|
||||
|
||||
L = [_g71, _g79]
|
||||
R = [_g71, _g79, 0] More? (;)
|
||||
|
||||
L = [_g71, _g79, _g87]
|
||||
R = [_g71, _g79, _g87, 0] More? (;)
|
||||
|
||||
L = [_g71, _g79, _g87, _g95]
|
||||
R = [_g71, _g79, _g87, _g95, 0] More? (;)
|
||||
|
||||
|
||||
[eclipse 59]: add([X,X,X],[Y,Y,Y],R), (X=1;X=0;X=Y;neg(X,Y)).
|
||||
|
||||
R = [_m5677, Var_m4777, Var_m2407, Var_m419]
|
||||
X = 1
|
||||
Y = Var_m395
|
||||
|
||||
Constraints:
|
||||
(39) boolean(_m5251)
|
||||
(33) boolean(Var_m1499)
|
||||
(19) and(Var_m395, Var_m1499, 0)
|
||||
(31) xor(Var_m395, Var_m1499, Var_m4777)
|
||||
(34) and(Var_m395, Var_m1499, _m5251)
|
||||
(16) xor(Var_m395, Var_m1499, Var_m2407)
|
||||
(43) neg(Var_m395, Var_m419)
|
||||
(38) boolean(Var_m395)
|
||||
(37) or(Var_m395, _m5251, _m5677)
|
||||
More? (;)
|
||||
|
||||
R = [0, Var_m395, Var_m395, Var_m395]
|
||||
X = 0
|
||||
Y = Var_m395
|
||||
|
||||
Constraints:
|
||||
(33) boolean(Var_m395)
|
||||
More? (;)
|
||||
|
||||
R = [_m371, _m371, _m371, 0]
|
||||
X = _m371
|
||||
Y = _m371
|
||||
|
||||
Constraints:
|
||||
(3) boolean(_m371)
|
||||
More? (;)
|
||||
|
||||
R = [_m5251, Var_m4777, Var_m2407, Var_m419]
|
||||
X = _m371
|
||||
Y = Var_m395
|
||||
|
||||
Constraints:
|
||||
(1) xor(_m371, Var_m395, Var_m419)
|
||||
(2) boolean(_m371)
|
||||
(3) boolean(Var_m395)
|
||||
(4) and(_m371, Var_m395, _m877)
|
||||
(10) xor(_m371, Var_m395, Var_m1499)
|
||||
(13) and(_m371, Var_m395, _m1973)
|
||||
(16) xor(_m877, Var_m1499, Var_m2407)
|
||||
(17) boolean(_m877)
|
||||
(18) boolean(Var_m1499)
|
||||
(19) and(_m877, Var_m1499, _m2881)
|
||||
(22) or(_m1973, _m2881, _m3307)
|
||||
(23) boolean(_m1973)
|
||||
(24) boolean(_m2881)
|
||||
(25) xor(_m371, Var_m395, Var_m3773)
|
||||
(31) xor(_m3307, Var_m3773, Var_m4777)
|
||||
(32) boolean(_m3307)
|
||||
(33) boolean(Var_m3773)
|
||||
(39) boolean(_m5251)
|
||||
(34) and(_m3307, Var_m3773, _m5251)
|
||||
(28) and(_m371, Var_m395, 0)
|
||||
|
||||
yes.
|
||||
|
||||
|
||||
[eclipse 60]: add([X,X,X],[Y,Y,Y],R), (X=1;X=0;X=Y;neg(X,Y)), labeling.
|
||||
|
||||
R = [0, 0, 0, 1]
|
||||
X = 1
|
||||
Y = 0 More? (;)
|
||||
|
||||
R = [1, 1, 1, 0]
|
||||
X = 1
|
||||
Y = 1 More? (;)
|
||||
|
||||
R = [0, 1, 1, 1]
|
||||
X = 1
|
||||
Y = 0 More? (;)
|
||||
|
||||
R = [0, 0, 0, 0]
|
||||
X = 0
|
||||
Y = 0 More? (;)
|
||||
|
||||
R = [0, 1, 1, 1]
|
||||
X = 0
|
||||
Y = 1 More? (;)
|
||||
|
||||
R = [0, 0, 0, 0]
|
||||
X = 0
|
||||
Y = 0 More? (;)
|
||||
|
||||
R = [1, 1, 1, 0]
|
||||
X = 1
|
||||
Y = 1 More? (;)
|
||||
|
||||
R = [0, 0, 0, 0]
|
||||
X = 0
|
||||
Y = 0 More? (;)
|
||||
|
||||
R = [0, 1, 1, 1]
|
||||
X = 0
|
||||
Y = 1 More? (;)
|
||||
|
||||
R = [0, 1, 1, 1]
|
||||
X = 1
|
||||
Y = 0
|
||||
yes.
|
||||
|
||||
[eclipse 66]: add(L,R,[X|L]).
|
||||
|
||||
R = []
|
||||
X = 0
|
||||
L = [] More? (;)
|
||||
|
||||
R = [0]
|
||||
X = 0
|
||||
L = [_m295]
|
||||
|
||||
Constraints:
|
||||
(2) boolean(_m295)
|
||||
More? (;)
|
||||
|
||||
R = [0, 0]
|
||||
X = 0
|
||||
L = [_m1785, _m303]
|
||||
|
||||
Constraints:
|
||||
(11) boolean(_m303)
|
||||
(20) boolean(_m1785)
|
||||
More? (;)
|
||||
|
||||
R = [0, 0, 0]
|
||||
X = 0
|
||||
L = [_m3275, _m1793, _m311]
|
||||
|
||||
Constraints:
|
||||
(29) boolean(_m311)
|
||||
(38) boolean(_m1793)
|
||||
(47) boolean(_m3275)
|
||||
More? (;)
|
||||
yes.
|
||||
|
||||
*/
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,115 @@
|
|||
% The Deussen Problem -------------------------------------------------------
|
||||
|
||||
/*From mark@ecrc.de Tue Jul 14 11:05:16 1992
|
||||
|
||||
I thought a propositional satisfiability example would be good.
|
||||
I therefore propose the Deussen problem Ulm027r1
|
||||
(chosen pretty well at random).
|
||||
|
||||
Mark Wallace
|
||||
*/
|
||||
|
||||
% the ulm027r1 problem has 16 solutions
|
||||
|
||||
% no labeling
|
||||
deussen0(Vars) :-
|
||||
ulm027r1(L,Vars),
|
||||
solve_bools(L).
|
||||
|
||||
% built-in labeling
|
||||
deussen1(Vars) :-
|
||||
ulm027r1(L,Vars),
|
||||
solve_bools(L),
|
||||
labeling.
|
||||
|
||||
% user-defined labeling
|
||||
deussen2(Vars) :-
|
||||
ulm027r1(L,Vars),
|
||||
solve_bools(L),
|
||||
label_bool(Vars).
|
||||
|
||||
solve_bools([]).
|
||||
solve_bools([X|L]) :-
|
||||
solve_bool(X,1), % boolean expression X must be 1 (true)
|
||||
solve_bools(L).
|
||||
|
||||
% Deussen Problem Ulm027/1
|
||||
|
||||
ulm027r1(
|
||||
[
|
||||
U12 + U3 + U2,
|
||||
U12 + ~~U3 + ~~U2,
|
||||
~~U12 + ~~U3 + U2,
|
||||
~~U12 + U3 + ~~U2,
|
||||
U13 + U4 + U12,
|
||||
U13 + ~~U4 + ~~U12,
|
||||
~~U13 + ~~U4 + U12,
|
||||
~~U13 + U4 + ~~U12,
|
||||
U14 + U5 + U13,
|
||||
U14 + ~~U5 + ~~U13,
|
||||
~~U14 + ~~U5 + U13,
|
||||
~~U14 + U5 + ~~U13,
|
||||
~~U14,
|
||||
U15 + U6 + U4,
|
||||
U15 + ~~U6 + ~~U4,
|
||||
~~U15 + ~~U6 + U4,
|
||||
~~U15 + U6 + ~~U4,
|
||||
U16 + U2 + U15,
|
||||
U16 + ~~U2 + ~~U15,
|
||||
~~U16 + ~~U2 + U15,
|
||||
~~U16 + U2 + ~~U15,
|
||||
U17 + U2 + U16,
|
||||
U17 + ~~U2 + ~~U16,
|
||||
~~U17 + ~~U2 + U16,
|
||||
~~U17 + U2 + ~~U16,
|
||||
U18 + U6 + U17,
|
||||
U18 + ~~U6 + ~~U17,
|
||||
~~U18 + ~~U6 + U17,
|
||||
~~U18 + U6 + ~~U17,
|
||||
~~U18,
|
||||
U19 + U10 + U3,
|
||||
U19 + ~~U10 + ~~U3,
|
||||
~~U19 + ~~U10 + U3,
|
||||
~~U19 + U10 + ~~U3,
|
||||
U20 + U11 + U19,
|
||||
U20 + ~~U11 + ~~U19,
|
||||
~~U20 + ~~U11 + U19,
|
||||
~~U20 + U11 + ~~U19,
|
||||
U21 + U6 + U20,
|
||||
U21 + ~~U6 + ~~U20,
|
||||
~~U21 + ~~U6 + U20,
|
||||
~~U21 + U6 + ~~U20,
|
||||
U22 + U7 + U21,
|
||||
U22 + ~~U7 + ~~U21,
|
||||
~~U22 + ~~U7 + U21,
|
||||
~~U22 + U7 + ~~U21,
|
||||
~~U22,
|
||||
U23 + U5 + U7,
|
||||
U23 + ~~U5 + ~~U7,
|
||||
~~U23 + ~~U5 + U7,
|
||||
~~U23 + U5 + ~~U7,
|
||||
U24 + U6 + U23,
|
||||
U24 + ~~U6 + ~~U23,
|
||||
~~U24 + ~~U6 + U23,
|
||||
~~U24 + U6 + ~~U23,
|
||||
U25 + U10 + U24,
|
||||
U25 + ~~U10 + ~~U24,
|
||||
~~U25 + ~~U10 + U24,
|
||||
~~U25 + U10 + ~~U24,
|
||||
U26 + U11 + U25,
|
||||
U26 + ~~U11 + ~~U25,
|
||||
~~U26 + ~~U11 + U25,
|
||||
~~U26 + U11 + ~~U25,
|
||||
~~U26
|
||||
],
|
||||
[
|
||||
%U1,
|
||||
U2,U3,U4,U5,U6,U7, %U8,U9,
|
||||
U10,U11,U12,U13,U14,U15,U16,U17,U18,U19,
|
||||
U20,U21,U22,U23,U24,U25,U26
|
||||
]).
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,444 @@
|
|||
% Boolean tests from Daniel Diaz
|
||||
% 931127 adapted to Eclipse and CHRs by Thom Fruehwirth, ECRC
|
||||
|
||||
%From diaz@margaux.inria.fr Tue Nov 23 18:59:17 1993
|
||||
%
|
||||
%I send you 3 programs schur.pl, pigeon.pl and queens.pl and a file
|
||||
%b_bips.pl containing the necessary built-ins and libraries.
|
||||
|
||||
|
||||
|
||||
|
||||
%---schur.pl---
|
||||
|
||||
/*-------------------------------------------------------------------------*/
|
||||
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
|
||||
/* */
|
||||
/* Name : bschur.pl */
|
||||
/* Title : Schur's lemma */
|
||||
/* Original Source: Giovanna Dore - Italy */
|
||||
/* Adapted by : Daniel Diaz - INRIA France */
|
||||
/* Date : January 1993 */
|
||||
/* */
|
||||
/* Color the integers 1,2...,N with 3 colors so that there is no monochrome*/
|
||||
/* triplets (x,y,z) where x+y=z. Solution iff N<=13. */
|
||||
/* The solution is a list [ [Int11,Int12,Int13],..., [IntN1,IntN2,IntN3] ] */
|
||||
/* where Intij is 1 if the integer i is colored with the color j. */
|
||||
/* */
|
||||
/* Solution: */
|
||||
/* N=4 [[0,0,1],[0,1,0],[0,0,1],[1,0,0]] */
|
||||
/* [[0,0,1],[0,1,0],[0,1,0],[0,0,1]] */
|
||||
/* ... */
|
||||
/* N=13 [[0,0,1],[0,1,0],[0,1,0],[0,0,1],[1,0,0],[1,0,0],[0,0,1],[1,0,0], */
|
||||
/* [1,0,0],[0,0,1],[0,1,0],[0,1,0],[0,0,1]] (first solution) */
|
||||
/*-------------------------------------------------------------------------*/
|
||||
|
||||
bschur:- write('N ?'), read(N),
|
||||
cputime( Starttime),
|
||||
(schur(N,A),
|
||||
% write(A), nl,
|
||||
fail
|
||||
;
|
||||
write('No more solutions'), nl),
|
||||
cputime( Cputime),
|
||||
Y is Cputime-Starttime,
|
||||
write('time : '), write(Y), nl.
|
||||
|
||||
cputime( Ts) :-
|
||||
statistics( runtime, [Tm,_]),
|
||||
Ts is Tm/1000.
|
||||
|
||||
|
||||
schur(N,A):-
|
||||
create_array(N,3,A),
|
||||
for_each_line(A,only1),
|
||||
pair_constraints(A,A),
|
||||
!,
|
||||
% labeling.
|
||||
array_labeling(A).
|
||||
|
||||
|
||||
|
||||
|
||||
pair_constraints([],_):-
|
||||
!.
|
||||
|
||||
pair_constraints([_],_):-
|
||||
!.
|
||||
|
||||
pair_constraints([_,[K1,K2,K3]|A2],[[I1,I2,I3]|A1]):-
|
||||
and0(I1,K1),
|
||||
and0(I2,K2),
|
||||
and0(I3,K3),
|
||||
triplet_constraints(A2,A1,[I1,I2,I3]),
|
||||
pair_constraints(A2,A1).
|
||||
|
||||
|
||||
|
||||
|
||||
triplet_constraints([],_,_).
|
||||
|
||||
triplet_constraints([[K1,K2,K3]|A2],[[J1,J2,J3]|A1],[I1,I2,I3]):-
|
||||
and0(I1,J1,K1),
|
||||
and0(I2,J2,K2),
|
||||
and0(I3,J3,K3),
|
||||
triplet_constraints(A2,A1,[I1,I2,I3]).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
%--- pigeon.pl ---
|
||||
|
||||
/*-------------------------------------------------------------------------*/
|
||||
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
|
||||
/* */
|
||||
/* Name : bpigeon.pl */
|
||||
/* Title : pigeon-hole problem */
|
||||
/* Originated from: */
|
||||
/* Adapted by : Daniel Diaz - INRIA France */
|
||||
/* Date : January 1993 */
|
||||
/* */
|
||||
/* Put N pigeons in M pigeon-holes. Solution iff N<=M. */
|
||||
/* The solution is a list [ [Pig11,...,Pig1m], ... ,[Pign1,...,Pignm] ] */
|
||||
/* where Pigij = 1 if the pigeon i is in the pigeon-hole j */
|
||||
/* */
|
||||
/* Solution: */
|
||||
/* N=2 M=3 [[0,0,1],[0,1,0]] */
|
||||
/* [[0,0,1],[1,0,0]] */
|
||||
/* [[0,1,0],[0,0,1]] */
|
||||
/* [[0,1,0],[1,0,0]] */
|
||||
/* [[1,0,0],[0,0,1]] */
|
||||
/* [[1,0,0],[0,1,0]] */
|
||||
/*-------------------------------------------------------------------------*/
|
||||
|
||||
|
||||
bpigeon:- write('N ?'), read(N), write('M ?'), read(M),
|
||||
cputime( Starttime),
|
||||
(bpigeon(N,M,A),
|
||||
% write(A), nl,
|
||||
fail
|
||||
;
|
||||
write('No more solutions'), nl),
|
||||
cputime( Cputime),
|
||||
Y is Cputime-Starttime,
|
||||
write('time : '), write(Y), nl.
|
||||
|
||||
|
||||
|
||||
|
||||
bpigeon(N,M,A):-
|
||||
create_array(N,M,A),
|
||||
for_each_line(A,only1),
|
||||
for_each_column(A,atmost1),
|
||||
!,
|
||||
array_labeling(A).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
%--- queens.pl ---
|
||||
|
||||
/*-------------------------------------------------------------------------*/
|
||||
/* Benchmark (Boolean) INRIA Rocquencourt - ChLoE Project */
|
||||
/* */
|
||||
/* Name : bqueens.pl */
|
||||
/* Title : N-queens problem */
|
||||
/* Original Source: Daniel Diaz - INRIA France */
|
||||
/* Adapted by : */
|
||||
/* Date : January 1993 */
|
||||
/* */
|
||||
/* Put N queens on an NxN chessboard so that there is no couple of queens */
|
||||
/* threatening each other. */
|
||||
/* The solution is a list [ [Que11,...,Que1N], ... ,[QueN1,...,QueNN] ] */
|
||||
/* where Queij is 1 if the the is a queen on the ith line an jth row. */
|
||||
/* */
|
||||
/* Solution: */
|
||||
/* N=4 [[0,0,1,0], [[0,1,0,0], */
|
||||
/* [1,0,0,0], [0,0,0,1], */
|
||||
/* [0,0,0,1], and [1,0,0,0], */
|
||||
/* [0,1,0,0]] [0,0,1,0]] */
|
||||
/* */
|
||||
/* N=8 [[0,0,0,0,0,0,0,1], (first solution) */
|
||||
/* [0,0,0,1,0,0,0,0], */
|
||||
/* [1,0,0,0,0,0,0,0], */
|
||||
/* [0,0,1,0,0,0,0,0], */
|
||||
/* [0,0,0,0,0,1,0,0], */
|
||||
/* [0,1,0,0,0,0,0,0], */
|
||||
/* [0,0,0,0,0,0,1,0], */
|
||||
/* [0,0,0,0,1,0,0,0]] */
|
||||
/*-------------------------------------------------------------------------*/
|
||||
|
||||
|
||||
bqueens:- write('N ?'), read(N),
|
||||
cputime( Starttime),
|
||||
(bqueens(N,A),
|
||||
% write(A), nl,
|
||||
fail
|
||||
;
|
||||
write('No more solutions'), nl),
|
||||
cputime( Cputime),
|
||||
Y is Cputime-Starttime,
|
||||
write('time : '), write(Y), nl.
|
||||
|
||||
|
||||
|
||||
|
||||
bqueens(N,A):-
|
||||
create_array(N,N,A),
|
||||
for_each_line(A,only1),
|
||||
for_each_column(A,only1),
|
||||
for_each_diagonal(A,N,N,atmost1),
|
||||
!,
|
||||
array_labeling(A).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
%--- b_bips.pl ---
|
||||
|
||||
|
||||
|
||||
%I also use the following shorthands:
|
||||
|
||||
and0(X,Y):-
|
||||
and(X,Y,0).
|
||||
% delay([X,Y],and(X,Y,0)).
|
||||
|
||||
|
||||
|
||||
or1(X,Y):-
|
||||
or(X,Y,1).
|
||||
|
||||
|
||||
and0(X,Y,Z):-
|
||||
and(X,Y,XY),
|
||||
and(XY,Z,0).
|
||||
% delay([X,Y,Z],(
|
||||
% and(X,Y,XY),
|
||||
% and(XY,Z,0))).
|
||||
|
||||
|
||||
|
||||
|
||||
or1(X,Y,Z):-
|
||||
or(X,Y,XY),
|
||||
or(XY,Z,1).
|
||||
|
||||
|
||||
/*-------------------------------------------------------------------------*/
|
||||
/* Prolog to Wam Compiler INRIA Rocquencourt - ChLoE Project */
|
||||
/* Version 1.0 - C Run-time Daniel Diaz - 1991 */
|
||||
/* Extended to FD Constraints (July 1992) */
|
||||
/* */
|
||||
/* Built-In: B predicates (booleans) */
|
||||
/* */
|
||||
/* b_bips.pl */
|
||||
/*-------------------------------------------------------------------------*/
|
||||
|
||||
/* Symbolic constraints */
|
||||
|
||||
%:- public only_one/1, at_least_one/1, at_most_one/1.
|
||||
|
||||
%only_one(L):- card(1,1,L).
|
||||
%at_most_one(L):- card(0,1,L).
|
||||
|
||||
|
||||
only_one(L):-
|
||||
at_least_one(L),
|
||||
at_most_one(L).
|
||||
|
||||
|
||||
|
||||
|
||||
at_least_one(L):-
|
||||
at_least_one1(L,1).
|
||||
|
||||
|
||||
at_least_one1([X],X).
|
||||
|
||||
at_least_one1([X|L],R):-
|
||||
at_least_one1(L,R1),
|
||||
or(X,R1,R).
|
||||
|
||||
|
||||
|
||||
|
||||
at_most_one([]).
|
||||
|
||||
at_most_one([X|L]):-
|
||||
not_two(L,X),
|
||||
at_most_one(L).
|
||||
|
||||
|
||||
|
||||
|
||||
not_two([],_).
|
||||
|
||||
not_two([X1|L],X):-
|
||||
and0(X1,X),
|
||||
not_two(L,X).
|
||||
|
||||
|
||||
|
||||
/* Array procedures */
|
||||
|
||||
%:- public create_array/3, for_each_line/2, for_each_column/2, for_each_diagonal/4, array_labeling/1.
|
||||
|
||||
|
||||
/*---------------------------------------------------------*/
|
||||
/* */
|
||||
/* An array NL x NC elements is represented as follows : */
|
||||
/* A = [L_1, ..., L_NL] with L_i = [X_i_1, ..., X_i_NC] */
|
||||
/* Hence : */
|
||||
/* A = [ [X_1_1,..., X_1_NC], ..., [X_NL_1,..., X_NL_NC] ] */
|
||||
/*---------------------------------------------------------*/
|
||||
|
||||
% create_array(NL,NC,A)
|
||||
% NL: nb of lines NC:nb of columns A:array
|
||||
% creates an array (with unbound variables)
|
||||
|
||||
create_array(NL,NC,A):-
|
||||
create_array1(0,NL,NC,A),
|
||||
!.
|
||||
|
||||
|
||||
create_array1(NL,NL,_,[]).
|
||||
|
||||
create_array1(I,NL,NC,[L|A]):-
|
||||
create_one_line(0,NC,L),
|
||||
I1 is I+1,
|
||||
create_array1(I1,NL,NC,A).
|
||||
|
||||
|
||||
|
||||
|
||||
create_one_line(NC,NC,[]).
|
||||
|
||||
create_one_line(J,NC,[_|L]):-
|
||||
J1 is J+1,
|
||||
create_one_line(J1,NC,L).
|
||||
|
||||
|
||||
|
||||
|
||||
% for_each_line(A,P)
|
||||
% A:array P: program atom
|
||||
% calls: array_prog(P,L) for each line L (L is a list)
|
||||
|
||||
for_each_line([],_).
|
||||
|
||||
for_each_line([L|A],P):-
|
||||
array_prog(P,L),
|
||||
for_each_line(A,P).
|
||||
|
||||
|
||||
|
||||
|
||||
% for_each_column(A,P)
|
||||
% A:array P: program atom
|
||||
% calls: array_prog(P,L) for each column L (L is a list)
|
||||
|
||||
for_each_column([[]|_],_):-
|
||||
!.
|
||||
|
||||
for_each_column(A,P):-
|
||||
create_column(A,C,A1),
|
||||
array_prog(P,C),
|
||||
for_each_column(A1,P).
|
||||
|
||||
|
||||
|
||||
|
||||
create_column([],[],[]).
|
||||
|
||||
create_column([[X|L]|A],[X|C],[L|A1]):-
|
||||
create_column(A,C,A1).
|
||||
|
||||
|
||||
|
||||
|
||||
% for_each_diagonal(A,NL,NC,P)
|
||||
% A:array NL: nb of lines
|
||||
% NC:nb of columns P: program atom
|
||||
% calls: array_prog(P,L) for each diagonal D (D is a list)
|
||||
|
||||
for_each_diagonal(A,NL,NC,P):-
|
||||
NbDiag is 2*(NL+NC-1), % numbered from 0 to NbDiag-1
|
||||
create_lst_diagonal(0,NbDiag,LD),
|
||||
fill_lst_diagonal(A,0,NL,NC,LD,LD1),
|
||||
!,
|
||||
for_each_line(LD1,P).
|
||||
|
||||
|
||||
|
||||
|
||||
create_lst_diagonal(NbDiag,NbDiag,[]).
|
||||
|
||||
create_lst_diagonal(I,NbDiag,[[]|LD]):-
|
||||
I1 is I+1,
|
||||
create_lst_diagonal(I1,NbDiag,LD).
|
||||
|
||||
|
||||
|
||||
|
||||
fill_lst_diagonal([],_,_,_,LD,LD).
|
||||
|
||||
fill_lst_diagonal([L|A],I,NL,NC,LD,LD2):-
|
||||
I1 is I+1,
|
||||
fill_lst_diagonal(A,I1,NL,NC,LD,LD1),
|
||||
one_list(L,I,NL,0,NC,LD1,LD2).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
one_list([],_,_,_,_,LD,LD).
|
||||
|
||||
one_list([X|L],I,NL,J,NC,LD,LD3):-
|
||||
J1 is J+1,
|
||||
one_list(L,I,NL,J1,NC,LD,LD1),
|
||||
NoDiag1 is I+J,
|
||||
NoDiag2 is I+NC-J+NL+NC-2,
|
||||
add_in_lst_diagonal(0,NoDiag1,X,LD1,LD2),
|
||||
add_in_lst_diagonal(0,NoDiag2,X,LD2,LD3).
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
add_in_lst_diagonal(NoDiag,NoDiag,X,[D|LD],[[X|D]|LD]).
|
||||
|
||||
add_in_lst_diagonal(K,NoDiag,X,[D|LD],[D|LD1]):-
|
||||
K1 is K+1,
|
||||
add_in_lst_diagonal(K1,NoDiag,X,LD,LD1).
|
||||
|
||||
|
||||
|
||||
array_prog(only1,L):- !,
|
||||
only_one(L).
|
||||
|
||||
array_prog(atmost1,L):- !,
|
||||
at_most_one(L).
|
||||
|
||||
|
||||
|
||||
|
||||
array_labeling([]).
|
||||
|
||||
array_labeling([L|A]):-
|
||||
label_bool(L),
|
||||
array_labeling(A).
|
||||
|
||||
|
||||
%--- end ---
|
|
@ -0,0 +1,63 @@
|
|||
% fourier.chr EXAMPLES ------------------------------------------------------
|
||||
% adapted for CHRs by Thom Fruehwirth 1993
|
||||
|
||||
eg([X,Z,Y,SA,SB,SD,SC,SE,SF,SG,SH,SK,End]):-
|
||||
{
|
||||
Y=:=SA,
|
||||
SB =:= SA + 7,
|
||||
SD =:= SA + 7,
|
||||
SC =:= SB + 3,
|
||||
SC>=SB+3,
|
||||
SE =:= SD + 8,
|
||||
SG>=SC+1,
|
||||
SG =:= SD + 8,
|
||||
SF =:= SD + 8,
|
||||
SF>=SC+1,
|
||||
SH >= SF + 1,
|
||||
SJ =:= SH + 3,
|
||||
SK>=SG+1,
|
||||
SK>=SE+2,
|
||||
SK =:= SJ + 2,
|
||||
End =:= SK + 1,
|
||||
3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
|
||||
2*(X+Y+Z)=:=3*(X-Y-Z),
|
||||
5*(X+Y)-7*X-Z >= (2+1+X)*6,
|
||||
2*(X-Y+Z)=:=Y+X-7,
|
||||
SH-SC+X+Z=:=0
|
||||
}.
|
||||
|
||||
%L = [-5, -1, 0, 0, 7, 7, 10, 15, 15, 15, 16, 21, 22]
|
||||
|
||||
|
||||
/*
|
||||
|
||||
%I1=3,I2=2,I3=3,I4=0,I5=4,I6=2,I7=5,I8=0,I9=3,I10=5,I11=(-2),I12=3,I13=4,I14=3,
|
||||
|
||||
I8+I7+I6+I5+I4+I3+I2+6=:=22, I9+I8+I7+I6+I5+I4+I3+I2+6=:=25,
|
||||
I1=:=3, I2>=2, I3>=3, I4+I3+I2+1>=4, I5+I4+1>=5,
|
||||
I6+I5+1>=7, I6>=2, I7>=5, I10+I9+1>=2, I11+I10+1>=4,
|
||||
I12+I11+2=<3, I12+1=<4, I12+I11+1>=2, I12>=3, I13>=4,
|
||||
I14>=3, I14+I13+I12+I11+4=<22, I14+I13+I12+I11+3=<25,
|
||||
I14+I13+I12+I11+I10+I9+7>=23, I14+I13+I12+I11+I10+6>=26. % should be 19
|
||||
|
||||
|
||||
X>2,X>=3.
|
||||
|
||||
X>=2,X>2.
|
||||
|
||||
X>2,X>=2.
|
||||
|
||||
X+Y>=2,Y-X>=1,3>=Y.
|
||||
|
||||
X+2*Y=<3,-X-Y=<1.
|
||||
|
||||
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,145 @@
|
|||
% From Christian Holzbaur Tue, 14 Jul 1992 14:49:16 +0200
|
||||
% adapted by Thom Fruehwirth for CHRs
|
||||
|
||||
/*
|
||||
With the mortgage definition
|
||||
*/
|
||||
mg1(P,T,I,B,MP):-
|
||||
T=:=1,
|
||||
B + MP =:= P * (1 + I).
|
||||
mg1(P,T,I,B,MP):-
|
||||
T >= 2,
|
||||
T1 =:= T-1,
|
||||
mg1(P * (1 + I) - MP, T1, I, B, MP).
|
||||
|
||||
|
||||
mg2(P,T,I,B,MP):-
|
||||
T > 0,
|
||||
T =< 1,
|
||||
B + MP = P * (1 + I).
|
||||
mg2(P,T,I,B,MP):-
|
||||
T > 1,
|
||||
mg2(P * (1 + I) - MP, T - 1, I, B, MP).
|
||||
/*
|
||||
and the queries
|
||||
|
||||
:- mg(P,120,0.01,B,MP).
|
||||
|
||||
:- mg(P, 5, Int, B, MP).
|
||||
*/
|
||||
|
||||
|
||||
example( [X0,X1,X2,X3,X4]) :-
|
||||
+87*X0 +52*X1 +27*X2 -54*X3 +56*X4 =< -93,
|
||||
+33*X0 -10*X1 +61*X2 -28*X3 -29*X4 =< 63,
|
||||
-68*X0 +8*X1 +35*X2 +68*X3 +35*X4 =< -85,
|
||||
+90*X0 +60*X1 -76*X2 -53*X3 +24*X4 =< -68,
|
||||
-95*X0 -10*X1 +64*X2 +76*X3 -24*X4 =< 33,
|
||||
+43*X0 -22*X1 +67*X2 -68*X3 -92*X4 =< -97,
|
||||
+39*X0 +7*X1 +62*X2 +54*X3 -26*X4 =< -27,
|
||||
+48*X0 -13*X1 +7*X2 -61*X3 -59*X4 =< -2,
|
||||
+49*X0 -23*X1 -31*X2 -76*X3 +27*X4 =< 3,
|
||||
-50*X0 +58*X1 -1*X2 +57*X3 +20*X4 =< 6,
|
||||
-13*X0 -63*X1 +81*X2 -3*X3 +70*X4 =< 64,
|
||||
+20*X0 +67*X1 -23*X2 -41*X3 -66*X4 =< 52,
|
||||
-81*X0 -44*X1 +19*X2 -22*X3 -73*X4 =< -17,
|
||||
-43*X0 -9*X1 +14*X2 +27*X3 +40*X4 =< 39,
|
||||
+16*X0 +83*X1 +89*X2 +25*X3 +55*X4 =< 36,
|
||||
+2*X0 +40*X1 +65*X2 +59*X3 -32*X4 =< 13,
|
||||
-65*X0 -11*X1 +10*X2 -13*X3 +91*X4 =< 49,
|
||||
+93*X0 -73*X1 +91*X2 -1*X3 +23*X4 =< -87.
|
||||
|
||||
|
||||
|
||||
top2 :- example( [X0,X1,X2,X3,X4]).
|
||||
|
||||
% X3=<-5/4-35/68*X2-2/17*X1+X0-35/68*X4,
|
||||
% X3>=68/53-76/53*X2+60/53*X1+90/53*X0+24/53*X4,
|
||||
% X3=<-1/2-31/27*X2-7/54*X1-13/18*X0+13/27*X4,
|
||||
% X3>=17/22+19/22*X2-2*X1-81/22*X0-73/22*X4,
|
||||
% X3=<33/76-16/19*X2+5/38*X1+5/4*X0+6/19*X4,
|
||||
% X3>=87+91*X2-73*X1+93*X0+23*X4,
|
||||
% X3>=-3/76-31/76*X2-23/76*X1+49/76*X0+27/76*X4,
|
||||
% X3=<13/9-14/27*X2+1/3*X1+43/27*X0-40/27*X4,
|
||||
% X3=<2/19+1/57*X2-58/57*X1+50/57*X0-20/57*X4
|
||||
|
||||
top3 :- example( [X0,_,_,_,X4]).
|
||||
|
||||
% X0>=477804/40409+6973307/969816*X4,
|
||||
% X0>=7357764/4517605-5006476/13552815*X4,
|
||||
% X0>=58416/36205-4659804/12418315*X4,
|
||||
% X0>=3139326/1972045-745308/1972045*X4,
|
||||
% X0>=67158/43105-16394/43105*X4,
|
||||
% X0>=1327097/6210451-2619277/6210451*X4,
|
||||
% X0=<-688135/1217232-2174029/811488*X4
|
||||
|
||||
% Detection of Implied Equalities
|
||||
|
||||
top4 :- A=<B,
|
||||
B=<C,
|
||||
C=<D,
|
||||
A>=D.
|
||||
|
||||
% B =:= A,
|
||||
% C =:= A,
|
||||
% D =:= A
|
||||
|
||||
top5 :-
|
||||
X11 + X12 + X13 + X14 + X15 =:= 1000,
|
||||
X21 + X22 + X23 + X24 + X25 =:= 1000,
|
||||
|
||||
4*X11 + 5*X21 - Y21 - Z21 =< 0,
|
||||
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
|
||||
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
|
||||
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
|
||||
+ Z21 - Z22 - Z23 + Z25 =:= 0,
|
||||
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
|
||||
|
||||
7*X11 + 9*X21 >= 0,
|
||||
7*X12 + 9*X22 =< 3000,
|
||||
7*X13 + 9*X23 =< 200,
|
||||
7*X14 + 9*X24 =< 10000,
|
||||
7*X15 + 9*X25 =< 7000,
|
||||
|
||||
Z21 =< 5000,
|
||||
Z22 =< 250,
|
||||
Z23 =< 600,
|
||||
Z24 =< 7000,
|
||||
Z25 =< 4000,
|
||||
|
||||
X11 >= 0, X12 >= 0, X13 >= 0, X14 >= 0, X15 >= 0,
|
||||
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
|
||||
|
||||
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
|
||||
|
||||
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
|
||||
% should be optimization here:
|
||||
M =:= 99999,
|
||||
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
|
||||
3 * Y23 + 8*Y24 + 5*Y25.
|
||||
|
||||
% M =:= 99999,
|
||||
% Min =:= 23450,
|
||||
% X11 =:= 0,
|
||||
% X12 =:= 0,
|
||||
% X13 =:= 0,
|
||||
% X14 =:= 1000,
|
||||
% X15 =:= 0,
|
||||
% X21 =:= 0,
|
||||
% X22 =:= 50,
|
||||
% X23 =:= 1850/3-X25,
|
||||
% X24 =:= 1000/3,
|
||||
% Y21 =:= 4000,
|
||||
% Y22 =:= 0,
|
||||
% Y23 =:= 7450/3,
|
||||
% Y24 =:= 0,
|
||||
% Y25 =:= 0,
|
||||
% Z21 =:= 5000,
|
||||
% Z22 =:= 250,
|
||||
% Z23 =:= 600,
|
||||
% Z24 =:= 9250/3-5*X25,
|
||||
% Z25 =:= 0,
|
||||
% X25 >= 5350/9,
|
||||
% X25 =< 1850/3
|
||||
|
||||
%=============================================================================
|
|
@ -0,0 +1,374 @@
|
|||
% From lim@scorpio Thu Jun 17 14:09:28 1993
|
||||
% adapted for CHRs by thom fruehwirth 930617
|
||||
% replaced $= by =:= and then removed '$'
|
||||
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% Rational Constraint Solver Source Module
|
||||
%
|
||||
% sccsid("@(#)data 1.00 92/06/29").
|
||||
% sccscr("@(#) Copyright 1992 ECRC GmbH ").
|
||||
%
|
||||
% IDENTIFICATION: examples
|
||||
%
|
||||
% AUTHOR: Pierre Lim
|
||||
%
|
||||
%
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
% X + Y =:= 4
|
||||
% X - Y =:= 0
|
||||
% Answer:
|
||||
%
|
||||
% X =:= 2, Y =:= 2
|
||||
%
|
||||
|
||||
X + Y =:= 4,
|
||||
X - Y =:= 0.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%-8x + 5y + -1z =:= 18,
|
||||
%x + -11z + -5y =:= 6,
|
||||
%-1x + 5y + 5z =:= 0.
|
||||
% Answer:
|
||||
%
|
||||
% x =:= -12/7, y =:= 23/35, z =:= -1
|
||||
|
||||
-8 * X + 5 * Y - Z =:= 18,
|
||||
X - 11 * Z - 5 * Y =:= 6,
|
||||
-X + 5 * Y + 5 * Z =:= 0.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%-11z + -5y + x =:= -6,
|
||||
%5z + -1x + 5y =:= 0.
|
||||
%
|
||||
% Answer:
|
||||
%
|
||||
% z =:= 1, x =:= 5 * Y + 5, y =:= (unconstrained)
|
||||
%
|
||||
% Notes:
|
||||
% CLP(R) compiler
|
||||
%
|
||||
% Y =:= 0.2*X - 1
|
||||
% Z =:= 1
|
||||
%
|
||||
% CHIP compiler
|
||||
% Z =:= (1)
|
||||
% X =:= (5) + (5) * _r80
|
||||
% Y =:= _r80
|
||||
%
|
||||
% My rational constraint solver produces
|
||||
% Z =:= 1
|
||||
% X =:= 5 * _m277 + 5
|
||||
% Y =:= 1 * _m277
|
||||
%
|
||||
%
|
||||
|
||||
-11*Z - 5*Y + X =:= -6,
|
||||
5*Z - X + 5*Y =:= 0.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
% X + -5*Y + -11 * Z =:= -6,
|
||||
% -X + 5* Z + 5* Y =:= 0,
|
||||
% X + 2* Z + -3* Y =:= 7,
|
||||
% 8*X + Z + -5*Y + P =:= 18.
|
||||
%
|
||||
% Answer: z =:= 1.0, x =:= 5.0, y =:= 0.0, p =:= -23
|
||||
%
|
||||
|
||||
X - 5*Y - 11 * Z =:= -6,
|
||||
-X + 5* Z + 5* Y =:= 0,
|
||||
X + 2* Z - 3* Y =:= 7,
|
||||
8*X + Z - 5*Y + P =:= 18.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%-8x + -1z + 5y =:= -18,
|
||||
%x + -5y + -11z =:= -6,
|
||||
%-x + 5z + y =:= 0,
|
||||
%x + 2z + -3y =:= 7.
|
||||
%
|
||||
% Answer inconsistent
|
||||
%
|
||||
|
||||
-8*X + -1*Z + 5*Y =:= -18,
|
||||
X + -5*Y + -11*Z =:= -6,
|
||||
-X + 5*Z + Y =:= 0,
|
||||
X + 2*Z + -3*Y =:= 7.
|
||||
|
||||
%
|
||||
% 0 =< X, X =< 10.
|
||||
%
|
||||
|
||||
0 =< X, X =< 10, X =:= 11. % inconsistent
|
||||
0 =< X, X =< 10, X =:= 1. % X =:= 1
|
||||
X =:= (1/2)/(1/2). % X =:= 1
|
||||
|
||||
|
||||
%
|
||||
% Inequality example 1
|
||||
/*
|
||||
X1 + X2 >= 2,
|
||||
-X1 + X2 >= 1,
|
||||
X2 =< 3,
|
||||
X1 >= 0,
|
||||
X2 >= 0.
|
||||
*/
|
||||
%
|
||||
%
|
||||
% CHIP compiler
|
||||
%
|
||||
% X1 =:= (1/2) + (-1/2) * _rp105 + (1/2) * _rp78
|
||||
% X2 =:= (3/2) + (1/2) * _rp105 + (1/2) * _rp78
|
||||
%
|
||||
%
|
||||
|
||||
X1 + X2 >= 2,
|
||||
-X1 + X2 >= 1,
|
||||
X2 =< 3,
|
||||
X1 >= 0,
|
||||
X2 >= 0.
|
||||
% print_store.
|
||||
|
||||
%
|
||||
%
|
||||
% Answer: X =:= 5
|
||||
%
|
||||
|
||||
X >= 5,
|
||||
X =< 5.
|
||||
|
||||
%
|
||||
% x1 + x2 =< 4,
|
||||
% 2x1 + 3x2 >= 18,
|
||||
% x1 >= 0,
|
||||
% x2 >= 0.
|
||||
%
|
||||
% Answer: inconsistent
|
||||
|
||||
X1 + X2 =< 4,
|
||||
2 * X1 + 3 * X2 >= 18,
|
||||
X1 >= 0,
|
||||
X2 >= 0.
|
||||
|
||||
%
|
||||
%
|
||||
/*
|
||||
X1 =< 50,
|
||||
X2 =< 200,
|
||||
X1 + 0.2 * X2 =< 72,
|
||||
150 * X1 + 25 * X2 =< 10000,
|
||||
Z =:= 250 * X1 + 45 * X2.
|
||||
*/
|
||||
%
|
||||
%
|
||||
% Answer: CLP(R) compiler
|
||||
%
|
||||
% X1 =:= 0.004*Z - 0.18*X2
|
||||
% Z =< 3.33333*X2 + 16666.7
|
||||
% Z + 5*X2 =< 18000
|
||||
% X2 =< 200
|
||||
% Z =< 45*X2 + 12500
|
||||
%
|
||||
% Answer: CHIP compiler
|
||||
%
|
||||
% Z =:= (17000) + (-9/5) * _rp161 + (20) * _rp101
|
||||
% X1 =:= (50) + (-1) * _rp101
|
||||
% X2 =:= (100) + (-1/25) * _rp161 + (6) * _rp101
|
||||
%
|
||||
% First 3 constraints
|
||||
% X1 =:= (50) + (-1) * _rp67
|
||||
% X2 =:= (110) + (-5) * _rp105 + (5) * _rp67
|
||||
%
|
||||
|
||||
X1 =< 50,
|
||||
X2 =< 200,
|
||||
X1 + 2/10 * X2 =< 72,
|
||||
150 * X1 + 25 * X2 =< 10000,
|
||||
Z =:= 250 * X1 + 45 * X2.
|
||||
%,output.
|
||||
|
||||
/*
|
||||
Eclipse input:
|
||||
|
||||
X1 =< 50,
|
||||
X2 =< 200,
|
||||
X1 + 2/10 * X2 =< 72,
|
||||
150 * X1 + 25 * X2 =< 10000,
|
||||
Z =:= 250 * X1 + 45 * X2.
|
||||
|
||||
*/
|
||||
|
||||
%
|
||||
%
|
||||
% X4 =< 1 + 3 * X3,
|
||||
% X4 =< 4/13+18/13*X3,
|
||||
% X4 >= -1/8+9/8*X3,
|
||||
% X4 >= -2+6*X3,
|
||||
% X4 >= -1/11+9/11*X3
|
||||
/*
|
||||
X4 - 3 * X3 =< 1,
|
||||
X4 - 1.38462 * X3 =< 0.307692,
|
||||
X4 - 1.125 * X3 >= -0.125,
|
||||
X4 - 6 * X3 >= -2,
|
||||
X4 - 0.818182 * X3 >= -0.0909091.
|
||||
|
||||
X4 - 3 * X3 =< 1,
|
||||
X4 - 18/13 * X3 =< 4/13,
|
||||
X4 - 9/8 * X3 >= -1/8,
|
||||
X4 - 6 * X3 >= -2,
|
||||
X4 - 9/11 * X3 >= -1/11.
|
||||
*/
|
||||
%
|
||||
% CHIP Compiler
|
||||
% X4 =:= (-2/7) + (-13/7) * _rp145 + (6/7) * _rp118
|
||||
% X3 =:= (-3/7) + (-13/21) * _rp145 + (13/21) * _rp118
|
||||
%
|
||||
% CLP(R) Compiler
|
||||
%
|
||||
% 0.818182*X3 =< X4 + 0.0909091
|
||||
% 6*X3 =< X4 + 2
|
||||
% 1.125*X3 =< X4 + 0.125
|
||||
% X4 =< 1.38462*X3 + 0.307692
|
||||
% X4 =< 3*X3 + 1
|
||||
%
|
||||
%
|
||||
|
||||
X4 =< 1+3*X3,
|
||||
X4 =< 4/13+18/13*X3,
|
||||
X4 >= -1/8+9/8*X3,
|
||||
X4 >= -2+6*X3,
|
||||
X4 >= -1/11+9/11*X3.
|
||||
|
||||
%
|
||||
%
|
||||
%
|
||||
% CHIP Compiler
|
||||
%
|
||||
% X3 =:= (1/9) * _rp256 + (5/6) * _rp229 + (-4/9) * _rp202 + (-1/2) * _rp159
|
||||
% X4 =:= (2/3) * _rp229 + (-1/3) * _rp202
|
||||
% X1 =:= (1/9) * _rp256 + (1/3) * _rp229 + (-1/9) * _rp202 + (-1/3) * _rp159
|
||||
% X2 =:= (1) + (-1) * _rp256 + (-13/6) * _rp229 + (1/3) * _rp202 +
|
||||
% (3/2) * _rp159
|
||||
%
|
||||
%
|
||||
%example([X1,X2,X3,X4]) :-
|
||||
12*X1 + X2 - 3*X3 + X4 =< 1,
|
||||
-36*X1 - 2*X2 + 18*X3 - 11*X4 =< -2,
|
||||
-18*X1 - X2 + 9*X3 - 7*X4 =< -1,
|
||||
45*X1 + 4*X2 - 18*X3 + 13*X4 =< 4,
|
||||
X1 >= 0,
|
||||
X2 >= 0.
|
||||
|
||||
%
|
||||
%
|
||||
% Small Scheduling Problem
|
||||
% CHIP Compiler
|
||||
%
|
||||
% SA =:= (-7) + (1) * _r218 + (-1) * _rp211
|
||||
% SB =:= _r218
|
||||
% SD =:= (1) * _r218 + (1) * _rp238 + (-1) * _rp211
|
||||
% SC =:= (3) + (1) * _r218 + (1) * _rp264
|
||||
% SF =:= (8) + (1) * _r218 + (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
|
||||
% SH =:= (9) + (1) * _r218 + (1) * _rp471 + (1) * _rp407 + (1) * _rp238 +
|
||||
% (-1) * _rp211
|
||||
% SG =:= (8) + (1) * _r218 + (1) * _rp374 + (1) * _rp238 + (-1) * _rp211
|
||||
% SE =:= (8) + (1) * _r218 + (1) * _rp314 + (1) * _rp238 + (-1) * _rp211
|
||||
% SJ =:= (12) + (1) * _r218 + (1) * _rp506 + (1) * _rp471 + (1) * _rp407 +
|
||||
% (1) * _rp238 + (-1) * _rp211
|
||||
% Send =:= (15) + (1) * _r218 + (1) * _rp674 + (1) * _rp607 + (1) * _rp506 +
|
||||
% (1) * _rp471 + (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
|
||||
% SK =:= (14) + (1) * _r218 + (1) * _rp607 + (1) * _rp506 + (1) * _rp471 +
|
||||
% (1) * _rp407 + (1) * _rp238 + (-1) * _rp211
|
||||
%
|
||||
%
|
||||
|
||||
SB >= SA + 7,
|
||||
SD >= SA + 7,
|
||||
SC >= SB + 3,
|
||||
SE >= SC + 1,
|
||||
SE >= SD + 8,
|
||||
SG >= SC + 1,
|
||||
SG >= SD + 8,
|
||||
SF >= SD + 8,
|
||||
SF >= SC + 1,
|
||||
SH >= SF + 1,
|
||||
SJ >= SH + 3,
|
||||
SK >= SG + 1,
|
||||
SK >= SE + 2,
|
||||
SK >= SJ + 2,
|
||||
Send >= SK + 1.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
%
|
||||
% Example from paper by De Backer and Beringer
|
||||
% ``A CLP language handling disjunctions of linear constraints''
|
||||
%
|
||||
% ConstrainedMin[ x, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
|
||||
% {0, {x -> 0, y -> 5}}
|
||||
% ConstrainedMax[ x, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
|
||||
% 16 16
|
||||
% {--, {x -> --, y -> 6}}
|
||||
% 3 3
|
||||
% ConstrainedMin[y, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
|
||||
% 14
|
||||
% {5, {x -> --, y -> 5}}
|
||||
% 3
|
||||
% ConstrainedMax[ y, {3x -2y =< 4, 3x+2y =< 28, 5 =< y},{x,y}]
|
||||
% {14, {x -> 0, y -> 14}}
|
||||
|
||||
|
||||
3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y. %, rmax(X).
|
||||
%3*X - 2*Y >= -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmin(X).
|
||||
%3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmax(Y).
|
||||
%3*X - 2*Y =< -4, 3*X + 2*Y =< 28, 5 =< Y.%, rmin(Y).
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
X11 + X12 + X13 + X14 + X15 =:= 1000,
|
||||
X21 + X22 + X23 + X24 + X25 =:= 1000,
|
||||
|
||||
4*X11 + 5*X21 - Y21 - Z21 =< 0,
|
||||
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
|
||||
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
|
||||
Y21 + Z21 =:= 0.
|
||||
|
||||
X1>=0,%positive(X1),
|
||||
X2>=0,%positive(X2),
|
||||
Y1>=0,%positive(Y1),
|
||||
Y2>=0,%positive(Y2),
|
||||
Y1 =:= X1 - X2,
|
||||
Y2 =:= X2 - X1.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
|
||||
U1-Z+W =:= 0,
|
||||
U2 +Z-V =:= 0,
|
||||
U3 -W + V =:= 0,
|
||||
U1 >=0,
|
||||
U2 >= 0,
|
||||
U3 >= 0,
|
||||
Z >= 0,
|
||||
V >= 0,
|
||||
W >= 0.
|
||||
|
||||
U1-Z+2*W =:= 0,
|
||||
U2 +2*Z-V =:= 0,
|
||||
U3-W+2*V =:= 0,
|
||||
U1 >= 0,
|
||||
U2 >= 0,
|
||||
U3 >= 0,
|
||||
Z >= 0,
|
||||
V >= 0,
|
||||
W >= 0.
|
||||
|
||||
X + 2*Z >=0,
|
||||
-Z +Y >= 1,
|
||||
-Y >= 2.
|
||||
|
||||
|
|
@ -0,0 +1,448 @@
|
|||
% From lim@scorpio Thu Jun 17 14:09:36 1993
|
||||
% adapted for CHRs by thom fruehwirth 930617
|
||||
% fourier very slow, maybe loops with beale/1, opt1/1 loops, opt2/1 works
|
||||
|
||||
rmin(E):- M=:=E. % thom: no optimisation
|
||||
rmax(E):- (-M)=:=E. % thom: no optimisation
|
||||
|
||||
%
|
||||
beale([X1,X2,X3,X4,X5,X6,X7]) :-
|
||||
X1 + 1/4 * X4 - 8 * X5 - X6 + 9 * X7 =:= 0,
|
||||
X2 + 1/2 * X4 - 12 * X5 - 1/2 * X6 + 3 * X7 =:= 0,
|
||||
X3 + X6 =:= 1,
|
||||
X1 >= 0,
|
||||
X2 >= 0,
|
||||
X3 >= 0,
|
||||
X4 >= 0,
|
||||
X5 >= 0,
|
||||
X6 >= 0,
|
||||
X7 >= 0,
|
||||
rmin( - 3/4 * X4 + 20 * X5 - 1/2 * X6 + 6* X7).
|
||||
|
||||
% topb(L,n)
|
||||
topb(L,N) :-
|
||||
topb1([],L,0,N).
|
||||
|
||||
topb1(Li,Li,I,I) :- !.
|
||||
topb1(Li,Lo,I,N) :-
|
||||
insertb(P,Li,Lt),
|
||||
J is I+1,
|
||||
putcons(Lt,1,J),
|
||||
topb1(Lt,Lo,J,N).
|
||||
|
||||
insertb(P,[],[P]).
|
||||
insertb(P,[A|B],[P,A|B]).
|
||||
insertb(P,[A|B],[A|C]) :-
|
||||
insertb(P,B,C).
|
||||
|
||||
putcons(_,M,N) :-
|
||||
M > N,
|
||||
!.
|
||||
putcons([P|R],M,N) :-
|
||||
M0 is M - 1,
|
||||
% bwriteln(P > M0/N),
|
||||
% bwriteln(P < M/N),
|
||||
P > M0/N,
|
||||
P < M/N,
|
||||
M1 is M + 1,
|
||||
putcons(R,M1,N).
|
||||
|
||||
bwriteln(X) :-
|
||||
writeln(X).
|
||||
bwriteln(X) :-
|
||||
writeln(delete(X)).
|
||||
|
||||
% may loop
|
||||
fib(0,1).
|
||||
fib(1,1).
|
||||
fib(N,Z) :-
|
||||
Z =:= X1 + X2,
|
||||
N1 =:= N-1,
|
||||
N2 =:= N-2,
|
||||
fib(N1,X1),
|
||||
fib(N2,X2).
|
||||
|
||||
|
||||
laplace([_, _]) :- !.
|
||||
laplace([H1, H2, H3|T]):-
|
||||
laplace_vec(H1, H2, H3),
|
||||
laplace([H2, H3|T]).
|
||||
|
||||
laplace_vec([_, _], [_, _], [_, _]) :- !.
|
||||
laplace_vec([_TL, T, TR|T1], [ML, M, MR|T2], [_BL, B, BR|T3]):-
|
||||
B + T + ML + MR - 4 * M =:= 0,
|
||||
laplace_vec([T, TR|T1], [M, MR|T2], [B, BR|T3]).
|
||||
|
||||
%
|
||||
laplace5(M) :-
|
||||
M = [
|
||||
[0,0,0,0,0],
|
||||
[100,R,S,T,100],
|
||||
[100,U,V,W,100],
|
||||
[100,X,Y,Z,100],
|
||||
[100,100,100,100,100]
|
||||
],
|
||||
laplace(M).
|
||||
|
||||
% [chipc]: laplace7(X).
|
||||
%
|
||||
% X = [[0, 0, 0, 0, 0, 0, 0], [100, (5260/99), (63625/1716), (42545/1287), (63625/1716), (5260/99), 100], [100, (388405/5148), (2050/33), (149485/2574), (2050/33), (388405/5148), 100], [100, (1125/13), (2025/26), (75), (2025/26), (1125/13), 100], [100, (477845/5148), (2900/33), (221765/2574), (2900/33), (477845/5148), 100], [100, (9590/99), (162425/1716), (120805/1287), (162425/1716), (9590/99), 100], [100, 100, 100, 100, 100, 100, 100]]
|
||||
|
||||
%
|
||||
laplace7(M) :-
|
||||
M = [
|
||||
[0,0,0,0,0,0,0],
|
||||
[100,R11,R12,R13,R14,R15,100],
|
||||
[100,R21,R22,R23,R24,R25,100],
|
||||
[100,R31,R32,R33,R34,R35,100],
|
||||
[100,R41,R42,R43,R44,R45,100],
|
||||
[100,R51,R52,R53,R54,R55,100],
|
||||
[100,100,100,100,100,100,100]
|
||||
],
|
||||
laplace(M).
|
||||
|
||||
% [chipc]: chipOpt(X,Y,Z).
|
||||
%
|
||||
% X = (8/5)
|
||||
% Y = (6/5)
|
||||
% Z = (14/5)
|
||||
|
||||
%
|
||||
chipOpt(X1,X2,X3) :-
|
||||
X1 + 2 * X2 =< 4,
|
||||
3 * X1 + X2 =< 6,
|
||||
X3 =:= X1 + X2,
|
||||
rmax(X3).
|
||||
|
||||
% chipfact(n,1,N)
|
||||
chipfact(X,Y,M) :-
|
||||
X =:= 0,
|
||||
!,
|
||||
Y =:= M.
|
||||
chipfact(X,Y,M) :-
|
||||
X1 =:= X - 1,
|
||||
M1 =:= X * Y,
|
||||
chipfact(X1,M1,M).
|
||||
|
||||
% order of magnitude slower than chipfact/3
|
||||
fact(0,1).
|
||||
fact(1,1).
|
||||
fact(N,R) :- 1 < N, N =< R, M =:= N-1, fact(M,T), R =:= N * T.
|
||||
|
||||
%
|
||||
mg(P,T,I,B,MP):-
|
||||
T > 0,
|
||||
T =< 1,
|
||||
B + MP =:= P * (1 + I/100).
|
||||
mg(P,T,I,B,MP):-
|
||||
T > 1,
|
||||
I1 =:= I / 100,
|
||||
T1 =:= T -1,
|
||||
P2 =:= P * (1 + I1) - MP,
|
||||
mg(P2, T1, I, B, MP).
|
||||
|
||||
mg1(X,Y,Z) :-
|
||||
2 =:= T,
|
||||
1 =:= I,
|
||||
T > 1,
|
||||
I1 =:= I / 100,
|
||||
T1 =:= T -1,
|
||||
P2 =:= P * (1 + I1) - MP,
|
||||
T1 > 0,
|
||||
T1 =< 1,
|
||||
B + MP =:= P2 * (1 + I/100).
|
||||
|
||||
% [chipc]: top0(X,Y,Z).
|
||||
%
|
||||
% X = _r94
|
||||
% Y = (-9462212541120451001/1000000000000000000) * _r94 + (10462212541120451001/1000000000000000000) * _r90
|
||||
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
|
||||
%
|
||||
% ---------------------------------------------------------
|
||||
% [chipc]: top1(X,Y,Z).
|
||||
%
|
||||
% X = _r94
|
||||
% Y = (-101/100) * _r94 + (201/100) * _r90
|
||||
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
|
||||
% ---------------------------------------------------------
|
||||
% [chipc]: top(X,Y,Z).
|
||||
%
|
||||
% X = _r94
|
||||
% Y = (-2101900399479668244827490915525641902001/100000000000000000000000000000000000000) * _r94 + (2201900399479668244827490915525641902001/100000000000000000000000000000000000000) * _r90
|
||||
% Z = (101/100) * _r94 + (-1) * _r90 More? (;)
|
||||
%
|
||||
|
||||
%
|
||||
top0(P, B, MP) :- mg(P,10,1,B,MP).
|
||||
top1(P, B, MP) :- mg(P,2,1,B,MP).
|
||||
top(P, B, MP) :- mg(P,20,1,B,MP).
|
||||
|
||||
|
||||
% Detection of Implied Equalities -------------------------------------------
|
||||
|
||||
%
|
||||
top4([A,B,C,D]) :-
|
||||
A=<B,
|
||||
B=<C,
|
||||
C=<D,
|
||||
A>=D.
|
||||
|
||||
% B = A,
|
||||
% C = A,
|
||||
% D = A
|
||||
/*
|
||||
L = [A_m108, B_m128, C_m336, D_m660]
|
||||
|
||||
Constraints:
|
||||
eq0([B_m128 * 1, D_m660 * -1], 0)
|
||||
eq0([C_m336 * 1, D_m660 * -1], 0)
|
||||
eq0([A_m108 * -1, D_m660 * 1], 0)
|
||||
*/
|
||||
|
||||
%
|
||||
% X = [(1/3), (0), (13/3)]
|
||||
%
|
||||
%
|
||||
opt1([X1,X2,X3]) :-
|
||||
X1 + X2 + 2 * X3 =< 9,
|
||||
X1 + X2 - X3 =< 2,
|
||||
-X1 + X2 + X3 =< 4,
|
||||
X1 >= 0,
|
||||
X2 >= 0,
|
||||
X3 >= 0,
|
||||
rmin(X1 + X2 - 4 * X3).
|
||||
|
||||
%
|
||||
% X = [(0), (0)]
|
||||
%
|
||||
%
|
||||
opt2([X1,X2]) :-
|
||||
X1 + 2 * X2 =< 4,
|
||||
X2 =< 1,
|
||||
X1 >= 0,
|
||||
X2 >= 0,
|
||||
rmin(X1 + X2).
|
||||
|
||||
available_res(10).
|
||||
available_res(14).
|
||||
available_res(27).
|
||||
available_res(60).
|
||||
available_res(100).
|
||||
available_cell(10).
|
||||
available_cell(20).
|
||||
|
||||
ohm(V,I,R) :-
|
||||
% bwriteln(V =:= I * R),
|
||||
V =:= I * R.
|
||||
|
||||
sum([],Z) :-
|
||||
% bwriteln(Z =:= 0),
|
||||
Z =:= 0.
|
||||
sum([H|T],N) :-
|
||||
% bwriteln(N =:= H + M),
|
||||
N =:= H + M,
|
||||
sum(T,M).
|
||||
|
||||
kirchoff(L) :-
|
||||
sum(L,0).
|
||||
|
||||
% X = [(200/37), (540/37)] More? (;)
|
||||
%
|
||||
% X = [(140/37), (600/37)] More? (;)
|
||||
%
|
||||
% X = [(540/127), (2000/127)] More? (;)
|
||||
|
||||
%
|
||||
ohm_example([V1,V2]) :-
|
||||
29/2 < V2, V2 < 65/4,
|
||||
available_res(R1),
|
||||
available_res(R2),
|
||||
available_cell(V),
|
||||
ohm(V1,I1,R1), ohm(V2,I2,R2),
|
||||
kirchoff([I1,-I2]), kirchoff([-V,V1,V2]).
|
||||
|
||||
% X = [10, 27, 20] More? (;)
|
||||
%
|
||||
% X = [14, 60, 20] More? (;)
|
||||
%
|
||||
% X = [27, 100, 20] More? (;)
|
||||
%
|
||||
ohm_example1([R1,R2,V]) :-
|
||||
29/2 < V2, V2 < 65/4,
|
||||
available_res(R1),
|
||||
available_res(R2),
|
||||
available_cell(V),
|
||||
ohm(V1,I1,R1), ohm(V2,I2,R2),
|
||||
kirchoff([I1,-I2]), kirchoff([-V,V1,V2]).
|
||||
|
||||
%
|
||||
% X = [(14), (60), (20)]
|
||||
%
|
||||
%
|
||||
ohm1([A,B,C]) :-
|
||||
A =:= 14,
|
||||
B =:= 60,
|
||||
C =:= 20,
|
||||
29/2 < V2, V2 < 65/4,
|
||||
V1/A - V2/B =:= 0,
|
||||
V1 + V2 =:= C.
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
%
|
||||
example( [X0,X1,X2,X3,X4]) :-
|
||||
87*X0 +52*X1 +27*X2 -54*X3 +56*X4 =< -93,
|
||||
33*X0 -10*X1 +61*X2 -28*X3 -29*X4 =< 63,
|
||||
-68*X0 +8*X1 +35*X2 +68*X3 +35*X4 =< -85,
|
||||
90*X0 +60*X1 -76*X2 -53*X3 +24*X4 =< -68,
|
||||
-95*X0 -10*X1 +64*X2 +76*X3 -24*X4 =< 33,
|
||||
43*X0 -22*X1 +67*X2 -68*X3 -92*X4 =< -97,
|
||||
39*X0 +7*X1 +62*X2 +54*X3 -26*X4 =< -27,
|
||||
48*X0 -13*X1 +7*X2 -61*X3 -59*X4 =< -2,
|
||||
49*X0 -23*X1 -31*X2 -76*X3 +27*X4 =< 3,
|
||||
-50*X0 +58*X1 -1*X2 +57*X3 +20*X4 =< 6,
|
||||
-13*X0 -63*X1 +81*X2 -3*X3 +70*X4 =< 64,
|
||||
20*X0 +67*X1 -23*X2 -41*X3 -66*X4 =< 52,
|
||||
-81*X0 -44*X1 +19*X2 -22*X3 -73*X4 =< -17,
|
||||
-43*X0 -9*X1 +14*X2 +27*X3 +40*X4 =< 39,
|
||||
16*X0 +83*X1 +89*X2 +25*X3 +55*X4 =< 36,
|
||||
+2*X0 +40*X1 +65*X2 +59*X3 -32*X4 =< 13,
|
||||
-65*X0 -11*X1 +10*X2 -13*X3 +91*X4 =< 49,
|
||||
93*X0 -73*X1 +91*X2 -1*X3 +23*X4 =< -87.
|
||||
|
||||
|
||||
|
||||
top2 :- example( [X0,X1,X2,X3,X4]).
|
||||
|
||||
% X3<=-5/4-35/68*X2-2/17*X1+X0-35/68*X4,
|
||||
% X3<=68/53-76/53*X2+60/53*X1+90/53*X0+24/53*X4,
|
||||
% X3<=-1/2-31/27*X2-7/54*X1-13/18*X0+13/27*X4,
|
||||
% X3<=17/22+19/22*X2-2*X1-81/22*X0-73/22*X4,
|
||||
% X3<=33/76-16/19*X2+5/38*X1+5/4*X0+6/19*X4,
|
||||
% X3>=87+91*X2-73*X1+93*X0+23*X4,
|
||||
% X3>=-3/76-31/76*X2-23/76*X1+49/76*X0+27/76*X4,
|
||||
% X3<=13/9-14/27*X2+1/3*X1+43/27*X0-40/27*X4,
|
||||
% X3<=2/19+1/57*X2-58/57*X1+50/57*X0-20/57*X4
|
||||
|
||||
top3 :- example( [X0,_,_,_,X4]).
|
||||
|
||||
% X0>=477804/40409+6973307/969816*X4,
|
||||
% X0>=7357764/4517605-5006476/13552815*X4,
|
||||
% X0>=58416/36205-4659804/12418315*X4,
|
||||
% X0>=3139326/1972045-745308/1972045*X4,
|
||||
% X0>=67158/43105-16394/43105*X4,
|
||||
% X0>=1327097/6210451-2619277/6210451*X4,
|
||||
% X0<=-688135/1217232-2174029/811488*X4
|
||||
|
||||
% [chipc]: top5(X).
|
||||
%
|
||||
% X = [(0), (0), (0), (1000), (0), (0), (50), (200/9) + (-1/9) * _rp522 , (1000/3), (5350/9) + (1/9) * _rp522 , (4000), (0), (7450/3), (0), (0), (5000), (250), (600), (1000/9) + (-5/9) * _rp522 , (0)]
|
||||
% yes.
|
||||
|
||||
top5([X11,X12,X13,X14,X15,X21,X22,X23,X24,X25,Y21,Y22,Y23,Y24,Y25,Z21,Z22,Z23,Z24,Z25]) :-
|
||||
X11 + X12 + X13 + X14 + X15 =:= 1000,
|
||||
X21 + X22 + X23 + X24 + X25 =:= 1000,
|
||||
|
||||
4*X11 + 5*X21 - Y21 - Z21 =< 0,
|
||||
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
|
||||
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
|
||||
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
|
||||
+ Z21 - Z22 - Z23 + Z25 =:= 0,
|
||||
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
|
||||
|
||||
7*X11 + 9*X21 >= 0,
|
||||
7*X12 + 9*X22 =< 3000,
|
||||
7*X13 + 9*X23 =< 200,
|
||||
7*X14 + 9*X24 =< 10000,
|
||||
7*X15 + 9*X25 =< 7000,
|
||||
|
||||
Z21 =< 5000,
|
||||
Z22 =< 250,
|
||||
Z23 =< 600,
|
||||
Z24 =< 7000,
|
||||
Z25 =< 4000,
|
||||
|
||||
X11 >= 0,
|
||||
X12 >= 0,
|
||||
X13 >= 0,
|
||||
X14 >= 0,
|
||||
X15 >= 0,
|
||||
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
|
||||
|
||||
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
|
||||
|
||||
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
|
||||
|
||||
M =:= 99999,
|
||||
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
|
||||
3 * Y23 + 8*Y24 + 5*Y25,
|
||||
rmax(Min).
|
||||
|
||||
%
|
||||
top5a(List) :-
|
||||
List = [X11,X12,X13,X14,X15,X21,X22,X23,X24,X25,Y21,Y22,Y23,Y24,Y25,Z21,Z22,Z23,Z24,Z25],
|
||||
X11 + X12 + X13 + X14 + X15 =:= 1000,
|
||||
X21 + X22 + X23 + X24 + X25 =:= 1000,
|
||||
|
||||
4*X11 + 5*X21 - Y21 - Z21 =< 0,
|
||||
-4*X12 - 5*X22 + Y22 + Z22 =:= 0,
|
||||
-4*X13 - 5*X23 + Y24 - Y25 + Z24 - Z25 =:= 0,
|
||||
-4*X14 - 5*X24 + Y21 - Y22 - Y23 + Y25
|
||||
+ Z21 - Z22 - Z23 + Z25 =:= 0,
|
||||
-4*X15 - 5*X25 + Y23 - Y24 + Z23 - Z24 =:= 0,
|
||||
|
||||
7*X11 + 9*X21 >= 0,
|
||||
7*X12 + 9*X22 =< 3000,
|
||||
7*X13 + 9*X23 =< 200,
|
||||
7*X14 + 9*X24 =< 10000,
|
||||
7*X15 + 9*X25 =< 7000,
|
||||
|
||||
Z21 =< 5000,
|
||||
Z22 =< 250,
|
||||
Z23 =< 600,
|
||||
Z24 =< 7000,
|
||||
Z25 =< 4000,
|
||||
|
||||
X11 >= 0,
|
||||
X12 >= 0,
|
||||
X13 >= 0,
|
||||
X14 >= 0,
|
||||
X15 >= 0,
|
||||
X21 >= 0, X22 >= 0, X23 >= 0, X24 >= 0, X25 >= 0,
|
||||
|
||||
Y21 >= 0, Y22 >= 0, Y23 >= 0, Y24 >= 0, Y25 >= 0,
|
||||
|
||||
Z21 >= 0, Z22 >= 0, Z23 >= 0, Z24 >= 0, Z25 >= 0,
|
||||
|
||||
M =:= 99999,
|
||||
Min = 23450,
|
||||
- Min =:= 99999 * X11 + 99999 * X21 + 4 * Y21 + 7 * Y22 +
|
||||
3 * Y23 + 8*Y24 + 5*Y25.
|
||||
|
||||
% M = 99999,
|
||||
% Min = 23450,
|
||||
% X11 = 0,
|
||||
% X12 = 0,
|
||||
% X13 = 0,
|
||||
% X14 = 1000,
|
||||
% X15 = 0,
|
||||
% X21 = 0,
|
||||
% X22 = 50,
|
||||
% X23 = 1850/3-X25,
|
||||
% X24 = 1000/3,
|
||||
% Y21 = 4000,
|
||||
% Y22 = 0,
|
||||
% Y23 = 7450/3,
|
||||
% Y24 = 0,
|
||||
% Y25 = 0,
|
||||
% Z21 = 5000,
|
||||
% Z22 = 250,
|
||||
% Z23 = 600,
|
||||
% Z24 = 9250/3-5*X25,
|
||||
% Z25 = 0,
|
||||
% X25>=5350/9,
|
||||
% X25<=1850/3
|
||||
|
||||
|
||||
|
||||
|
||||
% ===========================================================================
|
|
@ -0,0 +1,80 @@
|
|||
%From lim@scorpio Tue Mar 8 10:11:36 1994
|
||||
% adapted by Thom Fruehwirth for CHRs 930308
|
||||
|
||||
% *************************************
|
||||
% CLP(R) Version 1.1 - Example Programs
|
||||
% *************************************
|
||||
%
|
||||
% Algebraic combinations of options transactions
|
||||
|
||||
% heaviside function
|
||||
h(X, Y, Z) :- Y < X, Z =:= 0.
|
||||
h(X, Y, Z) :- Y >= X, Z =:= 1.
|
||||
|
||||
% ramp function
|
||||
r(X, Y, Z) :- Y < X , Z =:= 0.
|
||||
r(X, Y, Z) :- Y >= X, Z =:= Y - X.
|
||||
|
||||
% option valuation
|
||||
value(Type,Buy_or_Sell,S,C,P,I,X,B,Value) :-
|
||||
check_param(S,C,P,I,X,B),
|
||||
get_sign(Buy_or_Sell,Sign),
|
||||
lookup_option(Type,S,C,P,I,X,B,
|
||||
B1,B2,H1,H2,R1,R2),
|
||||
h(B1,S,T1),h(B2,S,T2),r(B1,S,T3),r(B2,S,T4),
|
||||
Value =:= Sign*(H1*T1 + H2*T2 + R1*T3 + R2*T4).
|
||||
|
||||
% safety check
|
||||
check_param(S,C,P,I,X,B) :-
|
||||
S >= 0, C >= 0, P >= 0,
|
||||
I >= 0, X >= 0, B >= 0 .
|
||||
|
||||
% Buy or sell are just opposite
|
||||
get_sign(buy,S) :- S =:= -1.
|
||||
get_sign(sell,S) :- S =:= 1.
|
||||
|
||||
% lookup option vector
|
||||
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2) :-
|
||||
table(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
|
||||
|
||||
% Table of values for B1,B2,H1,H2,R1,R2
|
||||
% generic format - lookup_table(Type,Pos_neg,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
|
||||
% where K to R21 are obtained from the table
|
||||
% M is a multiplier which is -1 or 1 depending on whether one
|
||||
% is buying or selling the option
|
||||
table( stock, S, C, P, I, X, B, 0, 0, S*(1+I), 0, -1, 0).
|
||||
table( call, S, C, P, I, X, B, 0, X, C*(1+I), 0, 0, -1).
|
||||
table( put, S, C, P, I, X, B, 0, X, P*(1+I)-X, 0, 1, -1).
|
||||
table( bond, S, C, P, I, X, B, 0, 0, B*(1+I), 0, 0, 0).
|
||||
|
||||
|
||||
solve1(Wealth, Stockprice) :-
|
||||
Wealth =:= Wealth1 + Wealth2,
|
||||
X =:= 99,
|
||||
P =:= 10, C =:= 10,
|
||||
I =:= 0,
|
||||
value(put, buy, Stockprice, _, P, I, X, _, Wealth1),
|
||||
value(call, buy, Stockprice, C, _, I, X, _, Wealth2).
|
||||
% dump([Stockprice, Wealth]).
|
||||
|
||||
solve2(Wealth, Stockprice) :-
|
||||
I =:= 0.1, P1 =:= 10, X1 =:= 20,
|
||||
value(put, sell, Stockprice, _, P1, I, X1, _, Wealth1),
|
||||
P2 =:= 18, X2 =:= 40,
|
||||
value(put, buy, Stockprice, _, P2, I, X2, _, Wealth2),
|
||||
C3 =:= 15, X3 =:= 60,
|
||||
value(call, buy, Stockprice, C3, _, I, X3, _, Wealth3),
|
||||
C4 =:= 10, X4 =:= 80,
|
||||
value(call, sell, Stockprice, C4, _, I, X4, _, Wealth4),
|
||||
Wealth =:= Wealth1 + Wealth2 + Wealth3 + Wealth4.
|
||||
% dump([Stockprice, Wealth]).
|
||||
|
||||
go1 :- solve1(Wealth, Stockprice), fail.
|
||||
go1.
|
||||
|
||||
go2 :- solve2(Wealth, Stockprice), fail.
|
||||
go2.
|
||||
|
||||
?- printf("\n>>> Sample goals: go1/0, go2/0\n", []).
|
||||
|
||||
%=============================================================================
|
|
@ -0,0 +1,150 @@
|
|||
/*
|
||||
Article: 5653 of comp.lang.prolog
|
||||
Newsgroups: comp.lang.prolog
|
||||
Path: ecrc!Germany.EU.net!mcsun!ub4b!news.cs.kuleuven.ac.be!bimbart
|
||||
From: bimbart@cs.kuleuven.ac.be (Bart Demoen)
|
||||
Subject: boolean constraint solvers
|
||||
Message-ID: <1992Oct19.093131.11399@cs.kuleuven.ac.be>
|
||||
Sender: news@cs.kuleuven.ac.be
|
||||
Nntp-Posting-Host: hera.cs.kuleuven.ac.be
|
||||
Organization: Dept. Computerwetenschappen K.U.Leuven
|
||||
Date: Mon, 19 Oct 1992 09:31:31 GMT
|
||||
Lines: 120
|
||||
|
||||
?- calc_constr(N,C,L) . % with N instantiated to a positive integer
|
||||
|
||||
generates in the variable C a datastructure that can be interpreted as a
|
||||
boolean expression (and in fact is so by SICStus Prolog's bool:sat) and in L
|
||||
the list of variables involved in this boolean expression; so
|
||||
|
||||
?- calc_constr(N,C,L) , bool:sat(C) , bool:labeling(L) .
|
||||
% with N instantiated to a positive integer
|
||||
|
||||
shows the instantiations of L for which the boolean expression is true
|
||||
e.g.
|
||||
|
||||
| ?- calc_constr(3,C,L) , bool:sat(C) , bool:labeling(L) .
|
||||
% C = omitted
|
||||
L = [1,0,1,0,1,0,1,0,1] ? ;
|
||||
|
||||
no
|
||||
|
||||
it is related to a puzzle which I can describe if people are interested
|
||||
|
||||
SICStus Prolog can solve this puzzle up to N = 9 on my machine; it then
|
||||
fails because of lack of memory (my machine has relatively little: for N=9
|
||||
SICStus needs 14 Mb - and about 50 secs runtime + 20 secs for gc on Sparc 1)
|
||||
|
||||
I am interested in hearing about boolean constraint solvers that can deal with
|
||||
the expression generated by the program below, for large N and in reasonable
|
||||
time and space; say N in the range 10 to 20: the number of solutions for
|
||||
different N varies wildly; there is exactly one solution for N = 10,12,13,15,20
|
||||
but for N=18 or 19 there are several thousand, so perhaps it is best to
|
||||
restrict attention to N with only one solution - unless that is unfair to your
|
||||
solver
|
||||
|
||||
in case you have to adapt the expression for your own boolean solver, in
|
||||
the expression generated, ~ means negation, + means disjunction,
|
||||
* means conjunction and somewhere in the program, 1 means true
|
||||
|
||||
|
||||
Thanks
|
||||
|
||||
Bart Demoen
|
||||
*/
|
||||
|
||||
|
||||
% test(N,L) :- calc_constr(N,C,L) , bool:sat(C) , bool:labeling(L) .
|
||||
test(N,L) :- calc_constr(N,C,L) , solve_bool(C,1).
|
||||
testbl(N,L) :- calc_constr(N,C,L) , solve_bool(C,1), labeling.
|
||||
testul(N,L) :- calc_constr(N,C,L) , solve_bool(C,1), label_bool(L).
|
||||
|
||||
calc_constr(N,C,L) :-
|
||||
M is N * N ,
|
||||
functor(B,b,M) ,
|
||||
B =.. [_|L] ,
|
||||
cc(N,N,N,B,C,1) .
|
||||
|
||||
cc(0,M,N,B,C,T) :- ! ,
|
||||
NewM is M - 1 ,
|
||||
cc(N,NewM,N,B,C,T) .
|
||||
cc(_,0,_,B,C,C) :- ! .
|
||||
cc(I,J,N,B,C,T) :-
|
||||
neighbours(I,J,N,B,C,S) ,
|
||||
NewI is I - 1 ,
|
||||
cc(NewI,J,N,B,S,T) .
|
||||
|
||||
|
||||
neighbours(I,J,N,B,C,S) :-
|
||||
add(I,J,N,B,L,R1) ,
|
||||
add(I-1,J,N,B,R1,R2) ,
|
||||
add(I+1,J,N,B,R2,R3) ,
|
||||
add(I,J-1,N,B,R3,R4) ,
|
||||
add(I,J+1,N,B,R4,[]) , % L is the list of neighbours of (I,J)
|
||||
% including (I,J)
|
||||
odd(L,C,S) .
|
||||
|
||||
add(I,J,N,B,S,S) :- I =:= 0 , ! .
|
||||
add(I,J,N,B,S,S) :- J =:= 0 , ! .
|
||||
add(I,J,N,B,S,S) :- I > N , ! .
|
||||
add(I,J,N,B,S,S) :- J > N , ! .
|
||||
add(I,J,N,B,[X|S],S) :- A is (I-1) * N + J , arg(A,B,X) .
|
||||
|
||||
|
||||
% odd/2 generates the constraint that an odd number of elements of its first
|
||||
% argument must be 1, the rest must be 0
|
||||
|
||||
odd(L,C*S,S):- exors(L,C).
|
||||
|
||||
exors([X],X).
|
||||
exors([X|L],X#R):- L=[_|_],
|
||||
exors(L,R).
|
||||
|
||||
|
||||
/*
|
||||
% did this by enumeration, because there are only 4 possibilities
|
||||
|
||||
odd([A], A * S,S) :- ! .
|
||||
|
||||
odd([A,B,C], ((A * ~~(B) * ~~(C)) +
|
||||
(A * B * C) +
|
||||
( ~~(A) * B * ~~(C)) +
|
||||
( ~~(A) * ~~(B) * C)) * S,S)
|
||||
:- ! .
|
||||
|
||||
odd([A,B,C,D], ((A * ~~(B) * ~~(C) * ~~(D)) +
|
||||
(A * B * C * ~~(D)) +
|
||||
(A * B * ~~(C) * D) +
|
||||
(A * ~~(B) * C * D) +
|
||||
( ~~(A) * B * ~~(C) * ~~(D)) +
|
||||
( ~~(A) * B * C * D) +
|
||||
( ~~(A) * ~~(B) * C * ~~(D)) +
|
||||
( ~~(A) * ~~(B) * ~~(C) * D)) * S,S )
|
||||
:- ! .
|
||||
|
||||
odd([A,B,C,D,E],((A * ~~(B) * ~~(C) * ~~(D) * ~~(E)) +
|
||||
(A * B * C * ~~(D) * ~~(E)) +
|
||||
(A * B * ~~(C) * D * ~~(E)) +
|
||||
(A * ~~(B) * C * D * ~~(E)) +
|
||||
(A * B * ~~(C) * ~~(D) * E) +
|
||||
(A * ~~(B) * C * ~~(D) * E) +
|
||||
(A * ~~(B) * ~~(C) * D * E) +
|
||||
(A * B * C * D * E) +
|
||||
( ~~(A) * B * ~~(C) * ~~(D) * ~~(E)) +
|
||||
( ~~(A) * B * ~~(C) * D * E) +
|
||||
( ~~(A) * B * C * ~~(D) * E) +
|
||||
( ~~(A) * B * C * D * ~~(E)) +
|
||||
( ~~(A) * ~~(B) * C * ~~(D) * ~~(E)) +
|
||||
( ~~(A) * ~~(B) * C * D * E) +
|
||||
( ~~(A) * ~~(B) * ~~(C) * D * ~~(E)) +
|
||||
( ~~(A) * ~~(B) * ~~(C) * ~~(D) * E)) * S,S ) :- ! .
|
||||
|
||||
*/
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,101 @@
|
|||
% 4-queens problem
|
||||
|
||||
queens4([[S11, S12, S13, S14],
|
||||
[S21, S22, S23, S24],
|
||||
[S31, S32, S33, S34],
|
||||
[S41, S42, S43, S44]
|
||||
]) :-
|
||||
%% rows
|
||||
card(1,1,[S11, S12, S13, S14]),
|
||||
card(1,1,[S21, S22, S23, S24]),
|
||||
card(1,1,[S31, S32, S33, S34]),
|
||||
card(1,1,[S41, S42, S43, S44]),
|
||||
%% columns
|
||||
card(1,1,[S11, S21, S31, S41]),
|
||||
card(1,1,[S12, S22, S32, S42]),
|
||||
card(1,1,[S13, S23, S33, S43]),
|
||||
card(1,1,[S14, S24, S34, S44]),
|
||||
%% diag left-right
|
||||
card(0,1,[S14]),
|
||||
card(0,1,[S13, S24]),
|
||||
card(0,1,[S12, S23, S34]),
|
||||
card(0,1,[S11, S22, S33, S44]),
|
||||
card(0,1,[S21, S32, S43]),
|
||||
card(0,1,[S31, S42]),
|
||||
card(0,1,[S41]),
|
||||
%% diag right-left
|
||||
card(0,1,[S11]),
|
||||
card(0,1,[S12, S21]),
|
||||
card(0,1,[S13, S22, S31]),
|
||||
card(0,1,[S14, S23, S32, S41]),
|
||||
card(0,1,[S24, S33, S42]),
|
||||
card(0,1,[S34, S43]),
|
||||
card(0,1,[S44]).
|
||||
|
||||
/*
|
||||
Article 4689 of comp.lang.prolog:
|
||||
From: leonardo@dcs.qmw.ac.uk (Mike Hopkins)
|
||||
Subject: Re: Solving 4 queens using boolean constraint
|
||||
Message-ID: <1992Apr6.140627.10533@dcs.qmw.ac.uk>
|
||||
Date: 6 Apr 92 14:06:27 GMT
|
||||
References: <1992Apr6.105730.13467@corax.udac.uu.se>
|
||||
|
||||
The problem insists that each row and column contains exactly one
|
||||
queens: therefore the program should be:
|
||||
|
||||
fourQueens(q(r(S11, S12, S13, S14),
|
||||
r(S21, S22, S23, S24),
|
||||
r(S31, S32, S33, S34),
|
||||
r(S41, S42, S43, S44))) :-
|
||||
%% rows
|
||||
bool:sat(card([1],[S11, S12, S13, S14])),
|
||||
bool:sat(card([1],[S21, S22, S23, S24])),
|
||||
bool:sat(card([1],[S31, S32, S33, S34])),
|
||||
bool:sat(card([1],[S41, S42, S43, S44])),
|
||||
%% columns
|
||||
bool:sat(card([1],[S11, S21, S31, S41])),
|
||||
bool:sat(card([1],[S12, S22, S32, S42])),
|
||||
bool:sat(card([1],[S13, S23, S33, S43])),
|
||||
bool:sat(card([1],[S14, S24, S34, S44])),
|
||||
%% diag left-right
|
||||
bool:sat(card([0-1],[S14])),
|
||||
bool:sat(card([0-1],[S13, S24])),
|
||||
bool:sat(card([0-1],[S12, S23, S34])),
|
||||
bool:sat(card([0-1],[S11, S22, S33, S44])),
|
||||
bool:sat(card([0-1],[S21, S32, S43])),
|
||||
bool:sat(card([0-1],[S31, S42])),
|
||||
bool:sat(card([0-1],[S41])),
|
||||
%% diag right-left
|
||||
bool:sat(card([0-1],[S11])),
|
||||
bool:sat(card([0-1],[S12, S21])),
|
||||
bool:sat(card([0-1],[S13, S22, S31])),
|
||||
bool:sat(card([0-1],[S14, S23, S32, S41])),
|
||||
bool:sat(card([0-1],[S24, S33, S42])),
|
||||
bool:sat(card([0-1],[S34, S43])),
|
||||
bool:sat(card([0-1],[S44])).
|
||||
|
||||
This then gives the following result:
|
||||
|
||||
| ?- fourQueens(A).
|
||||
|
||||
A = q(r(0,_C,_B,0),r(_B,0,0,_A),r(_A,0,0,_B),r(0,_B,_A,0)),
|
||||
bool:sat(_C=\=_B),
|
||||
bool:sat(_A=\=_B) ? ;
|
||||
|
||||
no
|
||||
| ?-
|
||||
|
||||
This therefore represents the desired two solutions!
|
||||
|
||||
===================================================
|
||||
Mike Hopkins
|
||||
Dept. of Computer Science, Queen Mary and Westfield College,
|
||||
Mile End Road, London E1 4NS, UK
|
||||
|
||||
Tel: 071-975-5241
|
||||
|
||||
ARPA: leonardo%cs.qmw.ac.uk@nsfnet-relay.ac.uk
|
||||
BITNET: leonardo%uk.ac.qmw.cs@UKACRL.BITNET
|
||||
===================================================
|
||||
|
||||
*/
|
|
@ -0,0 +1,16 @@
|
|||
% n-queens with finite domains
|
||||
|
||||
:- setval(domain,number).
|
||||
|
||||
queen(N,L):-
|
||||
length(L,N),
|
||||
L::1..N,
|
||||
queen(L).
|
||||
|
||||
queen([]).
|
||||
queen([X|Xs]):- safe(X,Xs,1),queen(Xs).
|
||||
|
||||
safe(X,[],N).
|
||||
safe(X,[H|T],N):- no_attack(X,H,N), M is N+1, safe(X,T,M).
|
||||
|
||||
no_attack(X,Y,N):- X ne Y, X ne Y-N, X ne Y+N, Y ne X-N, Y ne X+N.
|
|
@ -0,0 +1,52 @@
|
|||
% Examples for *math* handlers
|
||||
% From Peter Stuckey Wed Jun 16 17:51:08 1993
|
||||
% Results are in old format
|
||||
|
||||
:- U1-Z+W=:=0,
|
||||
U2+Z-V=:=0,
|
||||
U3-W+V=:=0,
|
||||
U1>=0,U2>=0,U3>=0,Z>=0,V>=0,W>=0.
|
||||
/*
|
||||
U1 = 0
|
||||
U2 = 0
|
||||
U3 = 0
|
||||
Z = Z_m270
|
||||
V = V_m460
|
||||
W = W_m290
|
||||
|
||||
Constraints:
|
||||
eq0([Z_m270 * 1, V_m460 * -1], 0, =:=)
|
||||
eq0([W_m290 * -1, V_m460 * 1], 0, =:=)
|
||||
eq0([V_m460 * 1], 0, >=)
|
||||
*/
|
||||
|
||||
:- U1-Z+2*W=:=0,
|
||||
U2+ 2*Z-V=:=0,
|
||||
U3-W+ 2*V=:=0,
|
||||
U1>=0,U2>=0,U3>=0,Z>=0,V>=0,W>=0.
|
||||
/*
|
||||
U1 = 0
|
||||
U2 = 0
|
||||
U3 = 0
|
||||
Z = 0
|
||||
V = 0
|
||||
W = 0
|
||||
*/
|
||||
|
||||
:- X+2*Z>=0,
|
||||
-Z+Y>=1,
|
||||
-Y>=2.
|
||||
/*
|
||||
X = X_m156
|
||||
Z = Z_m176
|
||||
Y = Y_m714
|
||||
|
||||
Constraints:
|
||||
eq0([X_m156 * 1, Z_m176 * 2], 0, >=)
|
||||
eq0([Z_m176 * -1, Y_m714 * 1], -1, >=)
|
||||
eq0([X_m156 * 1, Y_m714 * 2], -2, >=)
|
||||
eq0([Y_m714 * -1], -2, >=)
|
||||
eq0([Z_m176 * -1], -3, >=)
|
||||
eq0([X_m156 * 1], -6, >=)
|
||||
*/
|
||||
|
|
@ -0,0 +1,619 @@
|
|||
% examples-thom1.math --------------------------------------------------------
|
||||
% thom fruehwirth 1991-93
|
||||
% examples for *math* constraint handlers compiled from various sources
|
||||
% results shown are from old obsolete versions
|
||||
|
||||
:- op(1200,fx,'example').
|
||||
:- dynamic (example)/1.
|
||||
|
||||
% Equation Examples
|
||||
|
||||
example X1+X2=<4, 2*X1+3*X2>=18, X1>=0,X2>=0.
|
||||
%NO
|
||||
|
||||
example Y1>=0,Y2>=0,X1>=0,X2>=0,Y1=:=X1-X2,Y2=:=X2-X1.
|
||||
%YES Y1 = 0 , Y2 = 0,
|
||||
% X2 =:= slack(_2),
|
||||
% X1 =:= slack(_2),
|
||||
% slack(_1) =:= slack(_2)
|
||||
|
||||
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
|
||||
2*(X+Y+Z)=:=3*(X-Y-Z),
|
||||
5*(X+Y)-7*X-Z=:=(2+1+X)*6.
|
||||
%YES Y = 0.657143 , Z = -1 , X = -1.71429
|
||||
|
||||
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
|
||||
2*(X+Y+Z)=:=3*(X-Y-Z).
|
||||
%YES Z = -1,
|
||||
% X =:= 5 * -1 + 5 * Y
|
||||
|
||||
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
|
||||
2*(X+Y+Z)=:=3*(X-Y-Z),
|
||||
5*(X+Y)-7*X-Z=:=(2+1+X)*6 ,
|
||||
2*(X-Y+Z)=:=Y+X-7.
|
||||
%Failure, test = 0.0799999
|
||||
%NO
|
||||
|
||||
example 3*X+2*Y-4*(3+Z)=:=2*(X-3)+(Y+Z)*7,
|
||||
2*(X+Y+Z)=:=3*(X-Y-Z),
|
||||
5*(X+Y)-7*X-Z >= (2+1+X)*6 ,
|
||||
2*(X-Y+Z)=:=Y+X-7.
|
||||
%Success, test = 0.0666666
|
||||
%YES Z = -1 , Y = 0 , X = -5
|
||||
|
||||
example X>=Y,Y>=X.
|
||||
%Success, test = 0.0216667
|
||||
%YES ,
|
||||
% X =:= slack(0) + Y
|
||||
|
||||
example X>=Y+1,Y>=X+1.
|
||||
%Failure, test = 0.0133333
|
||||
%NO
|
||||
|
||||
example X>=Y+1,Y>=X-1.
|
||||
|
||||
example X>=Y+1,Y>=X-2.
|
||||
%Success, test = 0.0199999
|
||||
%YES ,
|
||||
% X =:= slack(0) + Y + 1
|
||||
|
||||
example X*Y=:=6,X+Y=:=5,X-Y=:=1.
|
||||
%Success, test = 0.0200001
|
||||
%YES X = 3.0 , Y = 2.0
|
||||
|
||||
example X*Y=:=6,X+Y=:=5,X>=Y.
|
||||
%Success, test = 0.04
|
||||
%YES ,
|
||||
% 6 =:= X * Y,
|
||||
% X =:= 0.5 * slack(_1) + 2.5,
|
||||
% Y =:= -0.5 * slack(_1) + 2.5
|
||||
|
||||
example X>=Y+Z,Z>=X+1,Y>=Z.
|
||||
%Success, test = 0.0883333
|
||||
%YES ,
|
||||
% Z =:= -(slack(_1)) - slack(_3) - slack(_2) - 1,
|
||||
% X =:= -(slack(_1)) - 2 * slack(_3) - slack(_2) - 2,
|
||||
% Y =:= -(slack(_3)) - slack(_2) - 1
|
||||
|
||||
|
||||
|
||||
% men_and_horses
|
||||
|
||||
mh(Men,Horses,Heads,Legs):-
|
||||
Men >= 0, Horses >= 0,
|
||||
Heads =:= Men + Horses,
|
||||
Legs =:= 2*Men + 4*Horses.
|
||||
|
||||
|
||||
% fibonacci
|
||||
% loops for first argument var !
|
||||
% works if multi-headed rules are evaluated eagerly as soon as a var is bound
|
||||
|
||||
fib(N, X):-
|
||||
N =:= 0, X =:= 1.
|
||||
fib(N, X):-
|
||||
N =:= 1, X =:= 1.
|
||||
fib(N, X):-
|
||||
N >= 2, X >= N,
|
||||
X =:= X1 + X2,
|
||||
%N1 =:= N - 1,
|
||||
%N2 =:= N - 2,
|
||||
fib(N-1, X1),
|
||||
fib(N-2, X2).
|
||||
|
||||
|
||||
% prove of paralellogram in arbitrary polygon with 4 corners
|
||||
|
||||
:- op(31,xfx,#).
|
||||
|
||||
mid(AX#AY,BX#BY,CX#CY):-
|
||||
AX+CX =:= 2*BX,
|
||||
AY+CY =:= 2*BY.
|
||||
|
||||
para(AX#AY,BX#BY,CX#CY,DX#DY):- % nonlinear part
|
||||
(AX-BX)*(CY-DY) =:= (AY-BY)*(CX-DX).
|
||||
|
||||
pp(P0,P1,P2,P3,[P4,P5,P6,P7]):-
|
||||
mid(P0,P4,P1),
|
||||
mid(P1,P5,P2),
|
||||
mid(P2,P6,P3),
|
||||
mid(P3,P7,P0),
|
||||
para(P4,P5,P7,P6),
|
||||
para(P4,P7,P5,P6).
|
||||
|
||||
% for solution, 4 points must be given
|
||||
|
||||
example pp(1#5,2#3,3#1,5#2,L).
|
||||
%Success, test = 0.025
|
||||
%YES L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]
|
||||
|
||||
example pp(A,B,C,D,[1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]).
|
||||
/*
|
||||
YES A = _2 # _4 , B = _1 # _3 , C = _5 # _7 , D = _6 # _8,
|
||||
_1 =:= _6 - 3.0,
|
||||
_2 =:= -(_6) + 6.0,
|
||||
_3 =:= _8 + 1.0,
|
||||
_4 =:= -(_8) + 7.0,
|
||||
_5 =:= -(_6) + 8.0,
|
||||
_7 =:= -(_8) + 3.0
|
||||
*/
|
||||
|
||||
example L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5],pp(A,B,1#1,D,L).
|
||||
%Success, test = 0.0333328
|
||||
%YES A = -1 # 5.0 , B = 4.0 # 3.0 , D = 7.0 # 2.0 , L = [1.5 # 4.0, 2.5 # 2.0, 4.0 # 1.5, 3.0 # 3.5]
|
||||
|
||||
|
||||
|
||||
% CLP(R) Version 1.0 - Example Programs
|
||||
% Standard mortgage relationship between:
|
||||
% P: Principal
|
||||
% T: Life of loan in months
|
||||
% I: Fixed (but compounded) monthly interest rate
|
||||
% B: Outstanding balance at the end
|
||||
% M: Monthly payment
|
||||
% doesn't run in CHIP because of nonlinear constraints ?
|
||||
|
||||
mg(P, T, I, B, MP) :-
|
||||
T =:= 1,
|
||||
B =:= P + P*I - MP.
|
||||
mg(P, T, I, B, MP) :-
|
||||
T > 1,
|
||||
T1 =:= T - 1,
|
||||
P1 =:= P + P*I - MP,
|
||||
mg(P1, T1, I, B, MP).
|
||||
|
||||
mg1(P, T, I, B, MP) :-
|
||||
T =:= 1,
|
||||
B =:= P + P*I - MP.
|
||||
mg1(P, T, I, B, MP) :-
|
||||
T > 1,
|
||||
mg1(P + P*I - MP, T-1, I, B, MP).
|
||||
|
||||
% code in CLP9R) language and system ACM TPLS paper 1992
|
||||
mg2(P, T, I, B, MP) :-
|
||||
T>0,T=<1,
|
||||
Int =:= T*(P*I/1200),
|
||||
B =:= P + Int - (T*MP).
|
||||
mg2(P, T, I, B, MP) :-
|
||||
T > 1,
|
||||
Int =:= P*I/1200,
|
||||
mg2(P+Int-MP, T-1, I, B, MP).
|
||||
|
||||
mg1(M):- mg(999999, 6, 0.01, 0, M). % 6 was 360
|
||||
|
||||
mg2(P,B,M):- mg(P, 6, 0.01, B, M). % 6 was 720
|
||||
|
||||
example mg(999999, 6, 0.01, 0, M).
|
||||
%YES M = 172548.2
|
||||
|
||||
example mg(P, 6, 0.01, B, M).
|
||||
/*
|
||||
YES ,
|
||||
_1 =:= -0.990099 * B + 1.9901 * _5,
|
||||
M =:= -(B) + 1.01 * _5,
|
||||
P =:= -4.85343 * B + 5.85343 * _5,
|
||||
_2 =:= -2.94098 * B + 3.94098 * _5,
|
||||
_3 =:= -3.90197 * B + 4.90196 * _5,
|
||||
_4 =:= -1.97039 * B + 2.97039 * _5
|
||||
*/
|
||||
|
||||
example B=0, P=999999,
|
||||
_1 =:= -0.990099 * B + 1.9901 * _5,
|
||||
M =:= -(B) + 1.01 * _5,
|
||||
P =:= -4.85343 * B + 5.85343 * _5,
|
||||
_2 =:= -2.94098 * B + 3.94098 * _5,
|
||||
_3 =:= -3.90197 * B + 4.90196 * _5,
|
||||
_4 =:= -1.97039 * B + 2.97039 * _5.
|
||||
%Success, test = 0.0199997
|
||||
%YES _1 = 339988.4 , M = 172548.2 , P = 999999 , _2 = 673276.4 , _3 = 837450.1 , _4 = 507461.0 , B = 0 , _5 = 170839.8
|
||||
|
||||
example B=0, P=999999,
|
||||
M =:= -(B) + 1.01 * _5,
|
||||
P =:= -4.85343 * B + 5.85343 * _5.
|
||||
%Success, test = 0.0116669
|
||||
%YES M = 172548.2 , P = 999999 , B = 0 , _5 = 170839.8
|
||||
|
||||
example mg(P, 6,I,B,M).
|
||||
/*
|
||||
YES ,
|
||||
_1 =:= P * I,
|
||||
M =:= _11 - B + _9,
|
||||
P =:= -(_3) + _4 + 2 * M - _1,
|
||||
_10 =:= _6 * I,
|
||||
_11 =:= _9 * I,
|
||||
_2 =:= 2 * _8 - 2 * _6 - _5 + 3 * _7 - _3,
|
||||
_3 =:= _2 * I,
|
||||
_4 =:= 2 * _10 - 2 * _9 - _8 + 3 * _6 - _5,
|
||||
_5 =:= _4 * I,
|
||||
_6 =:= _11 - B - _10 + 2 * _9,
|
||||
_7 =:= 2 * _11 - 2 * B - _10 + 3 * _9 - _8,
|
||||
_8 =:= _7 * I
|
||||
*/
|
||||
|
||||
% CLP(R) Version 1.0 - Example Programs
|
||||
% (Slow implementation of) The classic cryptarithmetic puzzle:
|
||||
%
|
||||
% S E N D
|
||||
% + M O R E
|
||||
% ---------
|
||||
% M O N E Y
|
||||
% works, but very slow
|
||||
|
||||
|
||||
example sendmory([9, 5, 6, 7, 1, 0, 8, 2]).
|
||||
%Success, test = 0.00999908
|
||||
%YES (was no before because floats don't unify bit/1)
|
||||
|
||||
sendmory([S, E, N, D, M, O, R, Y]) :-
|
||||
constraints([S, E, N, D, M, O, R, Y]),
|
||||
gen_diff_digits([S, E, N, D, M, O, R, Y]).
|
||||
|
||||
constraints([S, E, N, D, M, O, R, Y]) :-
|
||||
% S >= 0, E >= 0, N >= 0, D >= 0, M >= 0, O >= 0, R >= 0, Y >= 0,
|
||||
% S =< 9, E =< 9, N =< 9, D =< 9, M =< 9, O =< 9, R =< 9, Y =< 9,
|
||||
% S >= 1,
|
||||
M >= 1,
|
||||
% C1 >= 0, C2 >= 0, C3 >= 0, C4 >= 0,
|
||||
% C1 =< 1, C2 =< 1, C3 =< 1, C4 =< 1,
|
||||
M = C1,
|
||||
S + M + C2 =:= O + 10 * C1,
|
||||
E + O + C3 =:= N + 10 * C2,
|
||||
N + R + C4 =:= E + 10 * C3,
|
||||
D + E =:= Y + 10 * C4,
|
||||
bit(C1), bit(C2), bit(C3), bit(C4).
|
||||
|
||||
bit(0).
|
||||
bit(1).
|
||||
|
||||
gen_diff_digits(L) :-
|
||||
gen_diff_digits(L, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]).
|
||||
gen_diff_digits([], _).
|
||||
gen_diff_digits([H | T], L) :-
|
||||
delete(H, L, L2), gen_diff_digits(T, L2).
|
||||
|
||||
|
||||
|
||||
% CLP(R) Version 1.0 - Example Programs
|
||||
% Algebraic combinations of options transactions
|
||||
% very slow if Stockprice not given, because of
|
||||
% backtracking caused by h/3, r/3
|
||||
|
||||
% heaviside function
|
||||
h(X, Y, Z) :- Y < X, Z =:= 0.
|
||||
h(X, Y, Z) :- Y >= X, Z =:= 1.
|
||||
|
||||
% ramp function
|
||||
r(X, Y, Z) :- Y < X , Z =:= 0.
|
||||
r(X, Y, Z) :- Y >= X, Z =:= Y - X.
|
||||
|
||||
% option valuation
|
||||
% changed order of subgoals
|
||||
value(Type,Buy_or_Sell,S,C,P,I,X,B,Value) :-
|
||||
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2),
|
||||
check_param(S,C,P,I,X,B),
|
||||
get_sign(Buy_or_Sell,Sign),
|
||||
h(B1,S,T1),h(B2,S,T2),r(B1,S,T3),r(B2,S,T4),
|
||||
Value =:= Sign*(H1*T1 + H2*T2 + R1*T3 + R2*T4).
|
||||
|
||||
% safety check
|
||||
check_param(S,C,P,I,X,B) :-
|
||||
S >= 0, C >= 0, P >= 0,
|
||||
I >= 0, X >= 0, B >= 0 .
|
||||
|
||||
% Buy or sell are just opposite
|
||||
get_sign(buy,(-1)).
|
||||
get_sign(sell,1).
|
||||
|
||||
% lookup option vector
|
||||
lookup_option(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2) :-
|
||||
table(Type,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
|
||||
% table(Type,S,C,P,I,X,B,B11,B21,H11,H21,R11,R21),
|
||||
% B1 =:= B11, B2 =:= B21, H1 =:= H11, H2 =:= H21, R1 =:= R11, R2 =:= R21.
|
||||
|
||||
% Table of values for B1,B2,H1,H2,R1,R2
|
||||
% generic format - lookup_table(Type,Pos_neg,S,C,P,I,X,B,B1,B2,H1,H2,R1,R2).
|
||||
% where K to R2 are obtained from the table
|
||||
% M is a multiplier which is -1 or 1 depending on whether one
|
||||
% is buying or selling the option
|
||||
table( stock, S, C, P, I, X, B, 0, 0, S*(1+I), 0, -1, 0).
|
||||
table( call, S, C, P, I, X, B, 0, X, C*(1+I), 0, 0, -1).
|
||||
table( put, S, C, P, I, X, B, 0, X, P*(1+I)-X, 0, 1, -1).
|
||||
table( bond, S, C, P, I, X, B, 0, 0, B*(1+I), 0, 0, 0).
|
||||
|
||||
|
||||
stocks1(Wealth, Stockprice) :-
|
||||
Wealth =:= Wealth1 + Wealth2,
|
||||
X = 99,
|
||||
P = 10, C = 10,
|
||||
I = 0,
|
||||
value(put, buy, Stockprice, _, P, I, X, _, Wealth1),
|
||||
value(call, buy, Stockprice, C, _, I, X, _, Wealth2).
|
||||
|
||||
stocks2(Wealth, Stockprice) :-
|
||||
I = 0.1, P1 = 10, X1 = 20,
|
||||
value(put, sell, Stockprice, _, P1, I, X1, _, Wealth1),
|
||||
P2 = 18, X2 = 40,
|
||||
value(put, buy, Stockprice, _, P2, I, X2, _, Wealth2),
|
||||
C3 = 15, X3 = 60,
|
||||
value(call, buy, Stockprice, C3, _, I, X3, _, Wealth3),
|
||||
C4 = 10, X4 = 80,
|
||||
value(call, sell, Stockprice, C4, _, I, X4, _, Wealth4),
|
||||
Wealth =:= Wealth1 + Wealth2 + Wealth3 + Wealth4.
|
||||
|
||||
example stocks1(W,10).
|
||||
/*
|
||||
Success, test = 0.075
|
||||
YES W = 69,
|
||||
_1 =:= slack(_2),
|
||||
_3 =:= slack(_4),
|
||||
_5 =:= slack(_6),
|
||||
_7 =:= slack(_8)
|
||||
*/
|
||||
|
||||
example stocks2(W,10).
|
||||
/*
|
||||
YES W = 5.7,
|
||||
_1 =:= slack(_2),
|
||||
_11 =:= slack(_12),
|
||||
_13 =:= slack(_14),
|
||||
_15 =:= slack(_16),
|
||||
_3 =:= slack(_4),
|
||||
_5 =:= slack(_6),
|
||||
_7 =:= slack(_8),
|
||||
_9 =:= slack(_10)
|
||||
*/
|
||||
|
||||
|
||||
|
||||
% Hoon Hong EXAMPLES
|
||||
|
||||
% electric circuit (from clp(r))
|
||||
|
||||
resistor(V,I,R):-
|
||||
V =:= I*R, R>0.
|
||||
|
||||
par_circuit(V,I,R1,R2):-
|
||||
I=:=I1+I2,
|
||||
resistor(V,I1,R1),
|
||||
resistor(V,I2,R2).
|
||||
|
||||
example par_circuit(A,B,2,2).
|
||||
%Success, test = 0.0566666
|
||||
%YES ,
|
||||
% _1 =:= 0.5 * A,
|
||||
% B =:= A,
|
||||
% _2 =:= 0.5 * A
|
||||
|
||||
example par_circuit(2,A,2,B).
|
||||
%Success, test = 0.0300003
|
||||
%YES ,
|
||||
% nonzero(B - 0),
|
||||
% 2 =:= _1 * B,
|
||||
% A =:= _1 + 1,
|
||||
% B =:= slack(_2)
|
||||
|
||||
|
||||
% complex number arithmetic ((from clp(r))
|
||||
|
||||
zmul(R1#I1,R2#I2,R3#I3):-
|
||||
R3 =:= R1*R2-I1*I2,
|
||||
I3 =:= R1*I2+R2*I1.
|
||||
|
||||
example zmul(1#2,3#4,C).
|
||||
%Success, test = 0.00333405
|
||||
%YES C = -5 # 10
|
||||
|
||||
example zmul(A,B,(-5)#10).
|
||||
/*
|
||||
Success, test = 0.0483337
|
||||
YES A = _1 # _4 , B = _3 # _2,
|
||||
_5 =:= _1 * _3,
|
||||
_5 =:= _6 - 5,
|
||||
_6 =:= _4 * _2,
|
||||
_7 =:= _1 * _2,
|
||||
_7 =:= -(_8) + 10,
|
||||
_8 =:= _3 * _4
|
||||
*/
|
||||
|
||||
example zmul(1#2,B,(-5)#10).
|
||||
%Success, test = 0.0183334
|
||||
%YES B = 3.0 # 4.0
|
||||
|
||||
|
||||
% pythagorean numbers
|
||||
% loops, see fib for explaination
|
||||
% changed order of subgoals
|
||||
|
||||
nat(X):- X=:=1.
|
||||
nat(X):- X>1,nat(Y),X=:=Y+1.
|
||||
|
||||
% loops immediately
|
||||
pyth(X,Y,Z):-
|
||||
X*X+Y*Y=:=Z*Z,nat(X),nat(Y),nat(Z).
|
||||
|
||||
/*
|
||||
%From lim@scorpio Fri Jan 31 17:09:44 1992
|
||||
|
||||
minimize x1 - 2x2
|
||||
subject to
|
||||
x1 + x2 >= 2,
|
||||
-x1 + x2 >= 1,
|
||||
x2 <= 3.
|
||||
chr: X+Y>=2,Y-X>=1,Y=<3,X-2*Y=:=M,minimize(M),X=< -1.
|
||||
|
||||
Y = 3
|
||||
M = -7
|
||||
X = -1
|
||||
|
||||
% does not work
|
||||
chr: X+Y>=2,Y-X>=1,Y=<3,X-2*Y=:=M,minimize(M).
|
||||
|
||||
X = X_m176
|
||||
Y = Y_m196
|
||||
M = M_m2048
|
||||
|
||||
yes if
|
||||
eq0([slack(X_g7001_m242) * 1, slack(X_g7001_m470) * 1, slack(X_g7602_m1106) * 2], -3)
|
||||
eq0([X_m176 * 1, Y_m196 * -2, M_m2048 * -1], 0)
|
||||
eq0([Y_m196 * 1, M_m2048 * 1, slack(X_g7001_m470) * 1], 1)
|
||||
eq0([M_m2048 * -1, slack(X_g7001_m470) * -1, slack(X_g7602_m1106) * 1], -4)
|
||||
minimize(M_m2048)
|
||||
|
||||
|
||||
Delayed goals:
|
||||
X_g7001_m242 >= 0
|
||||
X_g7001_m470 >= 0
|
||||
X_g7602_m1106 >= 0
|
||||
|
||||
minimize -3x1 + 4x2
|
||||
subject to
|
||||
x1 + x2 <= 4,
|
||||
2x1 + 3x2 >= 18.
|
||||
|
||||
chr: X+Y =<4,2*X+3*Y>=18,M=:=4*Y-3*X,minimize(M).
|
||||
|
||||
Y = 10
|
||||
X = -6
|
||||
M = 58
|
||||
chr: X+Y =<4,2*X+3*Y>=18,M=:=4*Y-3*X,M<58.
|
||||
|
||||
no (more) solution.
|
||||
|
||||
minimize -x1 + 2x2 -3x3
|
||||
subject to
|
||||
x1 + x2 + x3 = 6,
|
||||
-x1 + x2 + 2x3 = 4,
|
||||
2x2 + 3x3 = 10,
|
||||
x3 <= 2.
|
||||
|
||||
chr: X+Y+Z=:=6,Y+2*Z-X=:=4,2*Y+3*Z=:=10,Z=<2,M=:=2*Y-3*Z-X,minimize(M).
|
||||
|
||||
Y = 2
|
||||
Z = 2
|
||||
X = 2
|
||||
M = -4
|
||||
yes.
|
||||
chr: X+Y+Z=:=6,Y+2*Z-X=:=4,2*Y+3*Z=:=10,Z=<2,M=:=2*Y-3*Z-X,M< -4.
|
||||
|
||||
no (more) solution.
|
||||
|
||||
*/
|
||||
|
||||
|
||||
% from CACM May 91 34(5) p. 59
|
||||
% given solution is wrong because last inequation is wrong - replace 26 by 19
|
||||
%I1=3,I2=2,I3=3,I4=0,I5=4,I6=2,I7=5,I8=0,I9=3,I10=5,I11=(-2),I12=3,I13=4,I14=3,
|
||||
example I8+I7+I6+I5+I4+I3+I2+6=:=22, I9+I8+I7+I6+I5+I4+I3+I2+6=:=25,
|
||||
I1=:=3, I2>=2, I3>=3, I4+I3+I2+1>=4, I5+I4+1>=5,
|
||||
I6+I5+1>=7, I6>=2, I7>=5, I10+I9+1>=2, I11+I10+1>=4,
|
||||
I12+I11+2=<3, I12+1=<4, I12+I11+1>=2, I12>=3, I13>=4,
|
||||
I14>=3, I14+I13+I12+I11+4=<22, I14+I13+I12+I11+3=<25,
|
||||
I14+I13+I12+I11+I10+I9+7>=23, I14+I13+I12+I11+I10+6>=26.
|
||||
/*
|
||||
YES I1 = 3 , I9 = 3 , I12 = 3 , I11 = -2,
|
||||
I7 =:= slack(_1) + 5,
|
||||
I10 =:= slack(_14) + slack(_13) - 9,
|
||||
I13 =:= -(slack(_10)) - slack(_9) + 14,
|
||||
I14 =:= slack(_9) + 3,
|
||||
I2 =:= -(slack(_7)) + slack(_6) - slack(_5) + slack(_4) - slack(_3),
|
||||
I3 =:= slack(_3) + 3,
|
||||
I4 =:= slack(_7) - slack(_6) + slack(_5),
|
||||
I5 =:= -(slack(_7)) + slack(_6) + 4,
|
||||
I6 =:= slack(_7) + 2,
|
||||
I8 =:= -(slack(_1)) - slack(_6) - slack(_4) + 2,
|
||||
slack(_10) =:= slack(_13) - 4,
|
||||
slack(_11) =:= slack(_14) + slack(_13) - 7,
|
||||
slack(_12) =:= slack(_14) + slack(_13) - 14,
|
||||
slack(_14) =:= slack(_15) + 7,
|
||||
slack(_2) =:= -(slack(_7)) + slack(_6) - slack(_5) + slack(_4) - slack(_3) - 2,
|
||||
slack(_8) =:= -(slack(_10)) - slack(_9) + 10
|
||||
*/
|
||||
|
||||
/*
|
||||
|
||||
% Examples that take longer --------------------------------------------------
|
||||
|
||||
example sendmory(L). % too slow maybe
|
||||
%YES L = [9, 5, 6, 7, 1, 0, 8, 2]
|
||||
|
||||
example stocks1(69,S). % takes long!
|
||||
/*
|
||||
YES S = 10,
|
||||
_1 =:= slack(_2),
|
||||
_3 =:= slack(_4),
|
||||
_5 =:= slack(_6),
|
||||
_7 =:= slack(_8)
|
||||
;
|
||||
YES S = 188,
|
||||
_A =:= slack(_B),
|
||||
_C =:= slack(_D),
|
||||
_E =:= slack(_F),
|
||||
_G =:= slack(_H)
|
||||
*/
|
||||
|
||||
|
||||
%------------------------------------------------------------------------------
|
||||
|
||||
chr: X+Y>=2,Y-X>=1,3>=Y.
|
||||
|
||||
X = X_m208
|
||||
Y = Y_m228
|
||||
|
||||
yes if
|
||||
eq0([X_m208 * 1, Y_m228 * -1, slack(X_g7001_m4754) * 1], 1)
|
||||
eq0([Y_m228 * 1, slack(X_g7001_m13874) * 1], -3)
|
||||
eq0([slack(X_g7001_m802) * 1, slack(X_g7001_m4754) * 1, slack(X_g7001_m13874) * 2], -3)
|
||||
|
||||
|
||||
Delayed goals:
|
||||
X_g7001_m802 >= 0
|
||||
X_g7001_m4754 >= 0
|
||||
X_g7001_m13874 >= 0
|
||||
yes.
|
||||
chr: X+2*Y=<3,-X-Y=<1.
|
||||
|
||||
X = X_m206
|
||||
Y = Y_m226
|
||||
|
||||
yes if
|
||||
eq0([X_m206 * -1, Y_m226 * -1, slack(X_g7602_m5512) * 1], -1)
|
||||
eq0([Y_m226 * 1, slack(X_g7602_m808) * 1, slack(X_g7602_m5512) * 1], -4)
|
||||
|
||||
|
||||
Delayed goals:
|
||||
X_g7602_m808 >= 0
|
||||
X_g7602_m5512 >= 0
|
||||
yes.
|
||||
chr: X+Y-Z=:=0,-Y+3*Z=:=0.
|
||||
|
||||
X = X_m222
|
||||
Y = Y_m242
|
||||
Z = Z_m262
|
||||
|
||||
yes if
|
||||
eq0([X_m222 * 1, Y_m242 * 1, Z_m262 * -1], 0)
|
||||
eq0([Y_m242 * -1, Z_m262 * 3], 0)
|
||||
|
||||
yes.
|
||||
chr: 2*X-3*Y+4*Z=:=5,X+2*Y-Z=:=6,-3*X+Y+3*Z=:=1.
|
||||
|
||||
X = 2.5714285714285712
|
||||
Y = 2.714285714285714
|
||||
Z = 2
|
||||
*/
|
||||
|
||||
% end of file examples-thom1.math ============================================
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
% 980202, 980311 Thom Fruehwirth, LMU
|
||||
% computes greatest common divisor of positive numbers written each as gcd(N)
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler gcd.
|
||||
|
||||
constraints gcd/1.
|
||||
|
||||
gcd(0) <=> true.
|
||||
gcd(N) \ gcd(M) <=> N=<M | L is M-N, gcd(L).
|
||||
%gcd(N) \ gcd(M) <=> N=<M | L is M mod N, gcd(L). % faster variant
|
||||
|
||||
/*
|
||||
% Sample queries
|
||||
|
||||
gcd(2),gcd(3).
|
||||
|
||||
gcd(1.5),gcd(2.5).
|
||||
|
||||
gcd(37*11*11*7*3),gcd(11*7*5*3),gcd(37*11*5).
|
||||
*/
|
|
@ -0,0 +1,242 @@
|
|||
% Thom Fruehwirth, LMU, 980129ff, 980312, 980611, 980711
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler interval.
|
||||
|
||||
option(debug_compile,off).
|
||||
option(already_in_store, off).
|
||||
option(check_guard_bindings, off).
|
||||
option(already_in_heads, off).
|
||||
|
||||
% for domain constraints
|
||||
operator( 700,xfx,'::').
|
||||
%operator( 600,xfx,':'). % operator already defined in Sicstus Prolog
|
||||
|
||||
% for inequality constraints
|
||||
%operator( 700,xfx,lt). % not implemented
|
||||
operator( 700,xfx,le).
|
||||
operator( 700,xfx,ne).
|
||||
operator( 700,xfx,eq).
|
||||
|
||||
constraints (::)/2, le/2, eq/2, ne/2, add/3, mult/3.
|
||||
% X::Min:Max - X is between the numbers Min and Max, inclusively
|
||||
% X must always be a unbound variable (!), and Min and Max evaluable
|
||||
% (i.e. ground) arithmetic expressions (or numbers)
|
||||
constraints int/1.
|
||||
% int(X) says that X is an integer (default is a real)
|
||||
constraints bool/1.
|
||||
% bool(X) says that X is a boolean (default is a real)
|
||||
|
||||
constraints browse/1.
|
||||
% watch how domain of X evolves
|
||||
browse(X), X::A:B ==> write((X::A:B)),nl.
|
||||
|
||||
% define the smallest intervals you want to get:
|
||||
% the smaller, the more precise, the longer the computation
|
||||
small(A:B):- A+2.0e-05>=B.
|
||||
|
||||
% Intersection -------------------------------
|
||||
|
||||
redundant @ X::A:B \ X::C:D <=> %var(X),
|
||||
(C=<A, B=<D ; A<B,small(A:B), C<D,small(C:D))
|
||||
|
|
||||
true.
|
||||
|
||||
intersect @ X::A:B , X::C:D <=> %var(X) |
|
||||
X::max(A,C):min(B,D).
|
||||
|
||||
% Special Cases -------------------------------
|
||||
|
||||
failure @ X::A:B <=> A>B | fail.
|
||||
|
||||
compute @ X::A:B <=> \+ (number(A),number(B)) | C is A, D is B, X::C:D.
|
||||
|
||||
integer @ int(X), X::A:B ==> \+ (integer(A),integer(B)) |
|
||||
C is integer(ceiling(float(A))), D is integer(floor(float(B))), X::C:D.
|
||||
|
||||
bool @ bool(X), X::A:B ==> B<1 | X::0:0.
|
||||
bool @ bool(X), X::A:B ==> A>0 | X::1:1.
|
||||
bool @ bool(X) ==> X::0:1.
|
||||
|
||||
% Inequality -------------------------------
|
||||
|
||||
(le) @ X le Y, X::A:B, Y::C:D ==> Y::A:D, X::A:D.
|
||||
(eq) @ X eq Y, X::A:B, Y::C:D ==> Y::A:B, X::C:D.
|
||||
(ne) @ X ne Y, X::A:A, Y::A:A <=> fail.
|
||||
|
||||
(ne_int) @ int(X) \ X ne Y, X::A:B <=> A=Y | X::A+1:B.
|
||||
(ne_int) @ int(X) \ X ne Y, X::A:B <=> B=Y | X::A:B-1.
|
||||
(ne_int) @ int(X) \ Y ne X, X::A:B <=> A=Y | X::A+1:B.
|
||||
(ne_int) @ int(X) \ Y ne X, X::A:B <=> B=Y | X::A:B-1.
|
||||
|
||||
% Addition X+Y=Z -------------------------------
|
||||
|
||||
add @ add(X,Y,Z), X::A:B, Y::C:D, Z::E:F ==>
|
||||
X::E-D:F-C, Y::E-B:F-A, Z::A+C:B+D.
|
||||
|
||||
% Multiplication X*Y=Z -------------------------------
|
||||
|
||||
mitnull(A:B) :- A=<0, 0=<B.
|
||||
|
||||
mult_z @ mult(X,Y,Z), X::A:B, Y::C:D ==>
|
||||
M1 is A*C, M2 is A*D, M3 is B*C, M4 is B*D,
|
||||
Z::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
|
||||
|
||||
mult_y @ mult(X,Y,Z), X::A:B, Z::E:F ==>
|
||||
\+ mitnull(A:B) |
|
||||
M1 is E/A, M2 is E/B, M3 is F/A, M4 is F/B,
|
||||
Y::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
|
||||
mult_x @ mult(Y,X,Z), X::A:B, Z::E:F ==>
|
||||
\+ mitnull(A:B) |
|
||||
M1 is E/A, M2 is E/B, M3 is F/A, M4 is F/B,
|
||||
Y::min(min(M1,M2),min(M3,M4)):max(max(M1,M2),max(M3,M4)).
|
||||
|
||||
mult_xyz @ mult(X,Y,Z), X::A:B, Y::C:D, Z::E:F ==>
|
||||
mitnull(A:B), mitnull(C:D), \+ mitnull(E:F) |
|
||||
(A*C<E -> D>0, X::E/D:B ; true),
|
||||
(B*D<E -> C<0, X::A:E/C ; true),
|
||||
(F<A*D -> C<0, X::F/C:B ; true),
|
||||
(F<B*C -> D>0, X::A:F/D ; true).
|
||||
|
||||
% Labeling --------------------------------------------------------
|
||||
|
||||
constraints split0/1.
|
||||
constraints split/1.
|
||||
% repeated split/1:
|
||||
constraints label/1.
|
||||
|
||||
label @ split0(X), X::A:B <=> \+ small(A:B), A<0,0<B |
|
||||
(X::A:0 ; X::0:B).
|
||||
|
||||
label @ split(X), X::A:B <=> \+ small(A:B) |
|
||||
Half is (A+B)/2,
|
||||
(X::A:Half ; X::Half:B).
|
||||
|
||||
label @ label(X), X::A:B <=> \+ small(A:B) |
|
||||
Half is (A+B)/2,
|
||||
(X::A:Half ; X::Half:B),
|
||||
label(X).
|
||||
|
||||
|
||||
|
||||
% EXAMPLES ================================================================
|
||||
|
||||
/*
|
||||
|
||||
?- X::3:5,X::2:4.
|
||||
|
||||
X::3:4 ?
|
||||
|
||||
?- X::3:5, Y::2:4, X=Y.
|
||||
|
||||
Y = X,
|
||||
X::3:4 ?
|
||||
|
||||
?- X::3:3.
|
||||
|
||||
X::3:3 ?
|
||||
|
||||
?- X le Y, X::3:5,X::2:4.
|
||||
|
||||
X le Y,
|
||||
X::3:4 ?
|
||||
|
||||
?- X le Y, X::3:5, Y::3:5.
|
||||
|
||||
X le Y,
|
||||
X::3:5,
|
||||
Y::3:5 ?
|
||||
|
||||
?- X le Y, X::3:5, Y::2:4.
|
||||
|
||||
X le Y,
|
||||
Y::3:4,
|
||||
X::3:4 ?
|
||||
|
||||
?- add(X,Y,Z), X::2:5, Y::3:4, Z::1:7.
|
||||
|
||||
Y::3:4,
|
||||
Z::5:7,
|
||||
X::2:4,
|
||||
add(X,Y,Z)?
|
||||
|
||||
?- mult(X,Y,Z), X:: -2:3, Y:: -3:4, Z::7:12.
|
||||
|
||||
Z::7:12,
|
||||
X::1.75:3,
|
||||
Y::2.3333333333333335:4.0,
|
||||
mult(X,Y,Z) ? ;
|
||||
|
||||
?- mult(X,Y,Z), X:: -2:3, Y:: -3:4, Z:: -12: -9.
|
||||
|
||||
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B.
|
||||
|
||||
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, split(A).
|
||||
|
||||
?- int(A), A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, split(A).
|
||||
|
||||
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B,
|
||||
split(A),split(A),split(A),split(A).
|
||||
|
||||
?- A::(-3):3, B::(-3):3, C::4:4, mult(A,B,C), A eq B, label(A).
|
||||
|
||||
?- int(A),int(B),int(C), mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3,
|
||||
A le C, B le C, C le A, C le B, A le B, B le A.
|
||||
|
||||
?- int(A),int(B),int(C), mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3,
|
||||
A eq B, B eq C.
|
||||
|
||||
?- mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3, A eq B, B eq C.
|
||||
|
||||
A eq B,
|
||||
B eq C,
|
||||
C::0.0:4.304672099999998e-9,
|
||||
B::0.0:4.304672099999998e-9,
|
||||
A::0.0:4.304672099999998e-9,
|
||||
mult(A,B,C) ? ;
|
||||
|
||||
?- mult(A,B,C), A::0:0.3, B::0:0.3, C::0:0.3, A le C.
|
||||
|
||||
B::0:0.3,
|
||||
A le C,
|
||||
C::0.0:1.9682999999999995e-5,
|
||||
A::0:1.9682999999999995e-5,
|
||||
mult(A,B,C) ? ;
|
||||
|
||||
?- mult(A,B,C), A::(-0.3):0.3, B::(-0.3):0.3, C::(-0.3):0.3, A eq C.
|
||||
|
||||
B:: -0.3:0.3,
|
||||
A eq C,
|
||||
C:: -5.9048999999999996e-6:5.9048999999999996e-6,
|
||||
A:: -5.9048999999999996e-6:5.9048999999999996e-6,
|
||||
mult(A,B,C) ? ;
|
||||
|
||||
?- mult(A,B,C), A::(-3):3, B::(-3):3, C::(-3):3, A eq C.
|
||||
% solutions A=C=0 or B=1, impossible to enumerate
|
||||
|
||||
A:: -3:3,
|
||||
B:: -3:3,
|
||||
C:: -3:3,
|
||||
A eq C,
|
||||
mult(A,B,C) ? ;
|
||||
|
||||
?- mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
|
||||
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
|
||||
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
|
||||
split0(A),split0(C).
|
||||
|
||||
?- int(A),
|
||||
mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
|
||||
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
|
||||
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
|
||||
label(A).
|
||||
|
||||
?- mult(A,B,AB), A eq B, add(AB,C,F), F::5:5,
|
||||
mult(C,D,CD), C eq D, add(CD,A,G), G::3:3,
|
||||
A:: -10:10, B:: -10:10, C:: -10:10, D:: -10:10,
|
||||
label(A).
|
||||
|
||||
*/
|
||||
|
||||
% end of handler interval ===================================================
|
|
@ -0,0 +1,274 @@
|
|||
% Terminological Reasoning (similar to KL-ONE or feature trees)
|
||||
% Ph. Hanschke, DFKI Kaiserslautern, and Th. Fruehwirth
|
||||
% 920120-920217-920413-920608ff-931210, LMU 980312
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler klone.
|
||||
|
||||
|
||||
% SYNTAX
|
||||
|
||||
% Basic operators
|
||||
operator(1200,xfx,isa). % concept definition
|
||||
operator(950,xfx,'::'). % A-Box membership and role-filler assertion
|
||||
operator(940,xfy,or). % disjunction
|
||||
operator(930,xfy,and). % conjunction
|
||||
operator(700,xfx,is). % used in restricitions
|
||||
operator(690,fy, nota). % complement
|
||||
operator(650,fx, some). % exists-in restriction
|
||||
operator(650,fx, every). % value restriction
|
||||
% Operators for extensions
|
||||
operator(100,fx, feature). % functional role / attribute
|
||||
operator(100,fx, distinct). % concept distinct from any other concept
|
||||
operator(100,fx, at_most_one). % local functional role
|
||||
operator(100,yfx,of). % role chain (note associativity)
|
||||
|
||||
:- dynamic (feature)/1, (distinct)/1, (isa)/2. % to allow scattered clauses
|
||||
|
||||
|
||||
% TYPES
|
||||
|
||||
role_assertion((I,J)::R):- individual(I),individual(J), role(R).
|
||||
membership_assertion(I::T):- individual(I), concept_term(T).
|
||||
|
||||
concept_definition((C isa T)):- concept(C), concept_term(T).
|
||||
|
||||
concept_term(S):- concept(S).
|
||||
concept_term(S or T):- concept_term(S), concept_term(T).
|
||||
concept_term(S and T):- concept_term(S), concept_term(T).
|
||||
concept_term(nota S):- concept_term(S).
|
||||
concept_term(some R is S):- role(R), concept_term(S).
|
||||
concept_term(every R is S):- role(R), concept_term(S).
|
||||
concept_term(at_most_one R):- role(R). % extension
|
||||
|
||||
individual(I):- var(I) ; atomic(I).
|
||||
|
||||
role(R):- atom(R).
|
||||
role(R1 of R2):- role(R1), role(R2). % extension
|
||||
|
||||
concept(C):- atom(C).
|
||||
|
||||
|
||||
|
||||
|
||||
% CONSISTENCY CHECK
|
||||
% A-box as constraint goals, T-box asserted (concept definitions by isa-rules)
|
||||
|
||||
constraints (::)/2, labeling/0.
|
||||
|
||||
% disjunction (is delayed as choice)
|
||||
labeling, (I::S or T) # Ph <=>
|
||||
(I::S ; I::T),
|
||||
labeling
|
||||
pragma passive(Ph).
|
||||
|
||||
% primitive clash
|
||||
I::nota Q, I::Q <=> fail.
|
||||
|
||||
% duplicates
|
||||
I::C \ I::C <=> true.
|
||||
|
||||
% top
|
||||
I::top <=> true.
|
||||
|
||||
% complement nota/1
|
||||
|
||||
% nota-top
|
||||
I::nota top <=> fail.
|
||||
|
||||
% nota-or
|
||||
I::nota (S or T) <=> I::(nota S and nota T).
|
||||
|
||||
% nota-and
|
||||
I::nota (S and T) <=> I::(nota S or nota T).
|
||||
|
||||
% nota-nota
|
||||
I::nota nota S <=> I::S.
|
||||
|
||||
% nota-every
|
||||
I::nota every R is S <=> I::some R is nota S.
|
||||
|
||||
% nota-some
|
||||
I::nota some R is S <=> I::every R is nota S.
|
||||
|
||||
% conjunction
|
||||
I::S and T <=> I::S, I::T.
|
||||
|
||||
% exists-in restriction
|
||||
I::some R is S <=> role(R) | (I,J)::R, J::S. % generate witness
|
||||
|
||||
% value restriction
|
||||
I::every R is S, (I,J)::R ==> J::S.
|
||||
|
||||
% Extensions ------------------------------------------------------------------
|
||||
|
||||
% value restriction merge and consistency test
|
||||
I::every R is S1, I::every R is S2 <=> I::every R is S1 and S2, J::S1 and S2.
|
||||
|
||||
% distinct/disjoint concept
|
||||
I::C1 \ I::C2 <=> concept(C1),concept(C2),distinct C1 | C1=C2.
|
||||
|
||||
% features/attributes/functional role
|
||||
(I,J1)::F \ (I,J2)::F <=> feature F | J1=J2.
|
||||
|
||||
% role chains
|
||||
(I,J)::C1 of C2 <=> (I,K)::C2, (K,J)::C1. % also covers "some" case
|
||||
I::every R1 of R is S, (I,J)::R ==> J::every R1 is S.
|
||||
I::at_most_one R1 of R, (I,J)::R ==> J::at_most_one R1.
|
||||
|
||||
% simple number restriction / local functional role using role chains
|
||||
constraints at_most_one/3.
|
||||
I::at_most_one R, (I,J)::R ==> at_most_one(I,J,R).
|
||||
at_most_one(I,J,R) \ at_most_one(I,J1,R) <=> J1=J.
|
||||
|
||||
I::nota at_most_one R <=> (I,J1)::R, (I,J2)::R, (J1,J2)::different.
|
||||
|
||||
% concrete domain predicates
|
||||
(X,X)::different <=> fail.
|
||||
(X,Y)::identical <=> X=Y.
|
||||
|
||||
X::greater(Y) <=> ground(X) | X>Y.
|
||||
(X,Y)::greater <=> ground(X), ground(Y) | X>Y.
|
||||
X::smaller(Y) <=> ground(X) | X<Y.
|
||||
(X,Y)::smaller <=> ground(X), ground(Y) | X<Y.
|
||||
|
||||
% binary concrete domain predicates using role chains
|
||||
I::some (R1 and R2) is S <=> (I,J1)::R1, (I,J2)::R2, (J1,J2)::S.
|
||||
constraints (every)/3.
|
||||
I::every (R1 and R2) is S <=> every((I,I),(R1,R2),S).
|
||||
every((I1,I2),(identical,identical),S) <=> (I1,I2)::S.
|
||||
every((I1,I2),(identical,R),S), (I2,J2)::R ==>
|
||||
(I1,J2)::S.
|
||||
every((I1,I2),(identical,R2 of R),S), (I2,J2)::R ==>
|
||||
every((I1,J2),(identical,R2),S).
|
||||
every((I1,I2),(R,R2),S), (I1,J1)::R ==>
|
||||
every((J1,I2),(identical,R2),S).
|
||||
every((I1,I2),(R1 of R,R2),S), (I1,J1)::R ==>
|
||||
every((J1,I2),(R1,R2),S).
|
||||
|
||||
|
||||
% unfolding using concept definition
|
||||
% if you use recursion in concepts, replace rules below by propagation rules
|
||||
I::C <=> (C isa T) | I::T.
|
||||
I::nota C <=> (C isa T) | I::nota T.
|
||||
|
||||
|
||||
|
||||
|
||||
% EXAMPLES ===================================================================
|
||||
|
||||
|
||||
% Family ---------------------------------------------------------------------
|
||||
|
||||
female isa nota male.
|
||||
woman isa human and female.
|
||||
man isa human and male.
|
||||
parent isa human and some child is human.
|
||||
father isa parent and man.
|
||||
mother isa parent and woman.
|
||||
grandfather isa father and some child is parent.
|
||||
grandmother isa mother and some child is parent.
|
||||
fatherofsons isa father and every child is male.
|
||||
|
||||
feature age.
|
||||
person isa (man or woman) and every age is number.
|
||||
|
||||
distinct number.
|
||||
X::number <=> nonvar(X) | number(X).
|
||||
|
||||
feature partner.
|
||||
married_person isa person and every partner is married_person. % recursion !
|
||||
|
||||
|
||||
% Configuration ---------------------------------------------------------------
|
||||
|
||||
distinct interface.
|
||||
distinct configuration.
|
||||
|
||||
simple_device isa device and
|
||||
some connector is interface.
|
||||
|
||||
feature component_1.
|
||||
feature component_2.
|
||||
|
||||
simple_config isa configuration and
|
||||
some component_1 is simple_device and
|
||||
some component_2 is simple_device.
|
||||
|
||||
very_simple_device isa simple_device and
|
||||
at_most_one connector.
|
||||
|
||||
feature price.
|
||||
feature voltage.
|
||||
feature frequency.
|
||||
|
||||
electrical_device isa very_simple_device and
|
||||
some voltage is greater(0) and some price is greater(1).
|
||||
|
||||
low_cost_device isa electrical_device and
|
||||
every price is smaller(200).
|
||||
|
||||
high_voltage_device isa electrical_device and
|
||||
every voltage is greater(15).
|
||||
|
||||
electrical_config isa simple_configuration and
|
||||
every component_1 is electrical_device and
|
||||
every component_2 is electrical_device and
|
||||
every (voltage of component_1 and voltage of component_2)
|
||||
is greater.
|
||||
|
||||
bus_device isa simple_device and bus and
|
||||
some frequency is greater(0).
|
||||
cpu_device isa simple_device and cpu and
|
||||
some frequency is greater(0).
|
||||
|
||||
bus_config isa configuration and
|
||||
some main_device is bus_device and
|
||||
every component is cpu_device and
|
||||
every (frequency of main_device and frequency of sub_device)
|
||||
is greater.
|
||||
|
||||
|
||||
catalog(dev1) :- dev1::electrical_device,
|
||||
(dev1,10)::voltage, (dev1,100)::price.
|
||||
catalog(dev2) :- dev2::electrical_device,
|
||||
(dev2,20)::voltage, (dev2,1000)::price.
|
||||
|
||||
possible_config(C) :-
|
||||
catalog(D1), (C,D1)::component_1,
|
||||
catalog(D2), (C,D2)::component_2.
|
||||
|
||||
/*
|
||||
% Example Queries
|
||||
|
||||
:- possible_config(C).
|
||||
|
||||
:- possible_config(C), C::electrical_config.
|
||||
|
||||
:- possible_config(C), C::electrical_config,
|
||||
(C,D1)::component_1, D1::low_cost_device,
|
||||
(C,D2)::component_2, D2::high_voltage_device.
|
||||
*/
|
||||
|
||||
|
||||
% Prolog terms ---------------------------------------------------------
|
||||
% see also handler term.chr
|
||||
|
||||
feature functor.
|
||||
feature arity.
|
||||
feature arg(N).
|
||||
|
||||
term isa top and some arity is number and some arity is greater(-1)
|
||||
and some functor is top.
|
||||
|
||||
(X,_)::arg(N) ==> N>=1.
|
||||
%(X,A)::arity ==> A>=0.
|
||||
(X,A)::arity,(X,_)::arg(N) ==> A>=N,A>=1.
|
||||
|
||||
% (X,0)::arity <-> (X,X)::functor
|
||||
(X,0)::arity ==> (X,X)::functor.
|
||||
(X,X)::functor ==> (X,0)::arity.
|
||||
|
||||
|
||||
% end of kl-one.pl ========================================================
|
|
@ -0,0 +1,48 @@
|
|||
% simple constraint solver for inequalities between variables
|
||||
% thom fruehwirth ECRC 950519, LMU 980207, 980311
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler leq.
|
||||
|
||||
constraints leq/2.
|
||||
% X leq Y means variable X is less-or-equal to variable Y
|
||||
|
||||
:- op(500, xfx, leq).
|
||||
|
||||
reflexivity @ X leq X <=> true.
|
||||
antisymmetry @ X leq Y , Y leq X <=> X=Y.
|
||||
idempotence @ X leq Y \ X leq Y <=> true.
|
||||
transitivity @ X leq Y , Y leq Z ==> X leq Z.
|
||||
|
||||
/*
|
||||
% more efficient, less propagating version using pragma passive
|
||||
reflexivity @ X leq X <=> true.
|
||||
antisymmetry @ X leq Y , Y leq X # Id <=> X=Y pragma passive(Id).
|
||||
idempotence @ X leq Y # Id \ X leq Y <=> true pragma passive(Id).
|
||||
transitivity @ X leq Y # Id , Y leq Z ==> X leq Z pragma passive(Id).
|
||||
*/
|
||||
|
||||
% this generates a circular leq-relation chain with N variables
|
||||
|
||||
time(N):-
|
||||
cputime(X),
|
||||
length(L,N),
|
||||
genleq(L,Last),
|
||||
L=[First|_],
|
||||
Last leq First,
|
||||
cputime( Now),
|
||||
Time is Now-X,
|
||||
write(N-Time), nl.
|
||||
|
||||
genleq([Last],Last).
|
||||
genleq([X,Y|Xs],Last):-
|
||||
X leq Y,
|
||||
genleq([Y|Xs],Last).
|
||||
|
||||
cputime( Ts) :-
|
||||
statistics( runtime, [Tm,_]),
|
||||
Ts is Tm/1000.
|
||||
|
||||
|
||||
% eof handler leq -----------------------------------------------
|
|
@ -0,0 +1,362 @@
|
|||
% 931129 ECRC, 980312 LMU thom fruehwirth
|
||||
% 961106 Christian Holzbaur, SICStus mods
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler list.
|
||||
|
||||
constraints eqlist/2, lenlist/2.
|
||||
operator(700,xfx,eqlist).
|
||||
operator(700,xfx,lenlist).
|
||||
|
||||
% Rs eqlist L: Rs is a list of lists, whose concatentation is the single list L
|
||||
|
||||
[] eqlist L <=> L=[].
|
||||
[R] eqlist L <=> R=L.
|
||||
[R|Rs] eqlist [] <=> R=[], Rs eqlist [].
|
||||
[[X|R]|Rs] eqlist L <=> L=[X|L1], [R|Rs] eqlist L1.
|
||||
Rs eqlist L <=> delete(R,Rs,Rs1),R==[] | Rs1 eqlist L.
|
||||
Rs eqlist L <=> delete(R,Rs,Rs1),R==L | Rs1 eqlist [].
|
||||
|
||||
constraints labeling/0.
|
||||
|
||||
labeling, ([R|Rs] eqlist L)#Ph <=> true |
|
||||
(var(L) -> length(L,_) ; true),
|
||||
(
|
||||
R=[], Rs eqlist L
|
||||
;
|
||||
L=[X|L1], R=[X|R1], [R1|Rs] eqlist L1
|
||||
),
|
||||
labeling
|
||||
pragma passive(Ph).
|
||||
|
||||
|
||||
% L lenlist N: The length of the list L is N
|
||||
% N can be an arithmetic expression
|
||||
|
||||
[] lenlist N <=> true | (var(N) -> N=0 ; N=:=0).
|
||||
[_|L] lenlist N <=> positive(N), plus(M,1,N), L lenlist M.
|
||||
L lenlist N <=> ground(N) | length(L,N).
|
||||
|
||||
|
||||
% auxiliary predicates ---------------------------------------------------
|
||||
|
||||
delete( X, [X|L], L).
|
||||
delete( Y, [X|Xs], [X|Xt]) :-
|
||||
delete( Y, Xs, Xt).
|
||||
|
||||
length([],0).
|
||||
length([_|L],N1):- length(L,N), N1 is N+1.
|
||||
|
||||
:- block plus(-,-,?), plus(-,?,-), plus(?,-,-).
|
||||
%
|
||||
plus( A, B, C) :- var(C), !, C is A+B.
|
||||
plus( A, B, C) :- var(B), !, B is C-A.
|
||||
plus( A, B, C) :- var(A), !, A is C-B.
|
||||
plus( A, B, C) :- C is A+B.
|
||||
|
||||
:- block positive(-).
|
||||
%
|
||||
positive( X) :- X>0.
|
||||
|
||||
|
||||
% EXAMPLES ================================================================
|
||||
|
||||
% Inspired by LISTLOG, Z. Farkas, TAPSOFT 87, Pisa, Italy
|
||||
% these predicates have better (more fair) enumeration properties
|
||||
|
||||
chr_member(X,L):- [_,[X],_] eqlist L.
|
||||
|
||||
chr_append(L1,L2,L3):- [L1,L2] eqlist L3.
|
||||
|
||||
chr_last(L,X):- [_,[X]] eqlist L.
|
||||
|
||||
/*
|
||||
[6]: chr_member(1,L),chr_member(2,L),labeling.
|
||||
|
||||
L = [1, 2] More? (;)
|
||||
|
||||
L = [2, 1] More? (;)
|
||||
|
||||
L = [1, 2, _g1240] More? (;)
|
||||
|
||||
L = [1, _g1062, 2] More? (;)
|
||||
|
||||
L = [2, 1, _g1240] More? (;)
|
||||
|
||||
L = [2, _g1062, 1] More? (;)
|
||||
|
||||
[7]: member(1,L),member(2,L). % compare with usual member/2
|
||||
|
||||
L = [1, 2|_g282] More? (;)
|
||||
|
||||
L = [1, _g280, 2|_g288] More? (;)
|
||||
|
||||
L = [1, _g280, _g286, 2|_g294] More? (;)
|
||||
*/
|
||||
|
||||
palindrome([]).
|
||||
palindrome([X]).
|
||||
palindrome(L):-
|
||||
X lenlist 1,
|
||||
[X,L1,X] eqlist L,
|
||||
palindrome(L1).
|
||||
|
||||
|
||||
reverse([],[]).
|
||||
reverse(R,L):-
|
||||
R lenlist N,
|
||||
L lenlist N,
|
||||
X lenlist 1,
|
||||
[X,R1] eqlist R,
|
||||
[L1,X] eqlist L,
|
||||
reverse(R1,L1).
|
||||
|
||||
/*
|
||||
[19]: reverse(X,[a,b]).
|
||||
|
||||
X = [b, a] % does not loop like usual reverse/2
|
||||
[10]: reverse([a,b|L],R).
|
||||
|
||||
L = []
|
||||
R = [b, a] More? (;)
|
||||
|
||||
L = [_m1718]
|
||||
R = [_m1718, b, a] More? (;)
|
||||
|
||||
L = [_m1718, _m2218]
|
||||
R = [_m2218, _m1718, b, a] More? (;)
|
||||
|
||||
|
||||
[11]: reverse(R,[a,b|L]).
|
||||
|
||||
R = [b, a]
|
||||
L = [] More? (;)
|
||||
|
||||
R = [_m754, b, a]
|
||||
L = [_m754] More? (;)
|
||||
|
||||
R = [_m754, _m1274, b, a]
|
||||
L = [_m1274, _m754] More? (;)
|
||||
|
||||
|
||||
*/
|
||||
|
||||
|
||||
% Done myself (thom)
|
||||
|
||||
permute([],[]).
|
||||
permute(R,L):-
|
||||
R lenlist N,
|
||||
L lenlist N,
|
||||
X lenlist 1,
|
||||
[X,R1] eqlist R,
|
||||
[A,X,B] eqlist L,
|
||||
[A,B] eqlist L1,
|
||||
permute(R1,L1).
|
||||
|
||||
/*
|
||||
[10]: permute(A,B).
|
||||
|
||||
A = []
|
||||
B = [] More? (;)
|
||||
|
||||
A = [_m970]
|
||||
B = [_m970] More? (;)
|
||||
|
||||
A = [_m970, _m1994]
|
||||
B = [_m2392, _m2416]
|
||||
|
||||
Constraints:
|
||||
[_m946, [_m970], _m994] eqlist [_m2392, _m2416]
|
||||
[_m946, _m994] eqlist [_m1994]
|
||||
More? (;)
|
||||
|
||||
A = [_m970, _m1994, _m3194]
|
||||
B = [_m3948, _m3972, _m3996]
|
||||
|
||||
Constraints:
|
||||
[_m1970, [_m1994], _m2018] eqlist [_m3592, _m3616]
|
||||
[_m946, _m994] eqlist [_m3592, _m3616]
|
||||
[_m946, [_m970], _m994] eqlist [_m3948, _m3972, _m3996]
|
||||
[_m1970, _m2018] eqlist [_m3194]
|
||||
More? (;)
|
||||
|
||||
|
||||
[11]: permute(A,B),labeling.
|
||||
|
||||
A = []
|
||||
B = [] More? (;)
|
||||
|
||||
A = [_m976]
|
||||
B = [_m976] More? (;)
|
||||
|
||||
A = [_m976, _m2000]
|
||||
B = [_m976, _m2000] More? (;)
|
||||
|
||||
A = [_m976, _m2000]
|
||||
B = [_m2000, _m976] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m976, _m2000, _m3200] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m2000, _m976, _m3200] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m2000, _m3200, _m976] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m976, _m3200, _m2000] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m3200, _m976, _m2000] More? (;)
|
||||
|
||||
A = [_m976, _m2000, _m3200]
|
||||
B = [_m3200, _m2000, _m976] More? (;)
|
||||
|
||||
*/
|
||||
|
||||
|
||||
% From Cohen, Koiran, Perrin "Meta-Level Interpretation of CLP(Lists)"
|
||||
% in "CLP: Selected Research", eds Benhamou, Colmerauer, MIT Press 1993.
|
||||
|
||||
% tree(Preorder,Postorder,Tree).
|
||||
tree([A],[A],A):- freeze(A,atomic(A)).
|
||||
tree(Pre,Post,t(A,L,R)):-
|
||||
% Pre lenlist N,
|
||||
% Post lenlist N,
|
||||
[[A],X,Y] eqlist Pre,
|
||||
[Z,W,[A]] eqlist Post,
|
||||
tree(X,Z,L),
|
||||
tree(Y,W,R).
|
||||
|
||||
/*
|
||||
[50]: tree([a, b, b, a, a], [b, a, a, b, a], T).
|
||||
|
||||
T = t(a, b, t(b, a, a))
|
||||
*/
|
||||
|
||||
% Inspired by talk by A. Colmerauer, WCLP Marseille, March 1993
|
||||
|
||||
transpose([],L):- [L,[[]]] eqlist [[]|L]. % list of []'s
|
||||
transpose([X|R],L):- first_column(L,X,L1), transpose(R,L1).
|
||||
|
||||
first_column([],[],[]).
|
||||
first_column([[X|L]|R],[X|S],[L|T]):- first_column(R,S,T).
|
||||
|
||||
/*
|
||||
[36]: transpose([[], [], [], []], L_g85).
|
||||
|
||||
L = []
|
||||
|
||||
[37]: transpose(L_g69, [[], [], [], []]).
|
||||
|
||||
L = []
|
||||
|
||||
*/
|
||||
|
||||
/*
|
||||
[18]: [X,Y,Z,Z,Y,X] eqlist [a,b,b,c,c,c,c,c,c,b,b,a], labeling.
|
||||
|
||||
Z = [c, c, c]
|
||||
Y = [b, b]
|
||||
X = [a]
|
||||
|
||||
[21]: [[a],X,[b],Y] eqlist L,
|
||||
[Y,[b],X,[a]] eqlist L .
|
||||
|
||||
Y = Y_m654
|
||||
X = X_m630
|
||||
L = [a|_m678]
|
||||
|
||||
Constraints:
|
||||
(3) [X_m630, [b], Y_m654] eqlist _m678
|
||||
(4) [Y_m654, [b], X_m630, [a]] eqlist [a|_m678]
|
||||
|
||||
|
||||
[4]: [[a],X,[b],Y] eqlist L,
|
||||
[Y,[b],X,[a]] eqlist L, labeling.
|
||||
|
||||
Y = [a]
|
||||
X = []
|
||||
L = [a, b, a] More? (;)
|
||||
|
||||
Y = [a]
|
||||
X = [b]
|
||||
L = [a, b, b, a] More? (;)
|
||||
|
||||
Y = [a, b, a]
|
||||
X = []
|
||||
L = [a, b, a, b, a] More? (;)
|
||||
|
||||
Y = [a, a]
|
||||
X = [a]
|
||||
L = [a, a, b, a, a] More? (;)
|
||||
|
||||
Y = [a]
|
||||
X = [b, b]
|
||||
L = [a, b, b, b, a] More? (;)
|
||||
|
||||
Y = [a]
|
||||
X = [b, b, b]
|
||||
L = [a, b, b, b, b, a] More? (;)
|
||||
|
||||
*/
|
||||
|
||||
|
||||
/*
|
||||
|
||||
% Unsolvable equation
|
||||
{2]: [[2],X] eqlist L,
|
||||
[X,[1]] eqlist L,
|
||||
labeling.
|
||||
% if there is no more solution for longer lists L, labeling does not terminate
|
||||
|
||||
% Unsolvable equation from dissertation of J.-P. Pecuchet, 1981
|
||||
[5]: [[2],X,Y,[1]] eqlist L,
|
||||
[X,[1],[2],X] eqlist L,
|
||||
labeling.
|
||||
% if there is no more solution for longer lists L, labeling does not terminate
|
||||
|
||||
% Solvable equation from paper by K. Schulz, 1988
|
||||
[11]: [[1],X,[2],Z,X] eqlist L,
|
||||
[Z,[3],Z,Y,Y,Y] eqlist L,
|
||||
labeling.
|
||||
|
||||
X = [3, 1, 2, 1, 3, 1]
|
||||
Z = [1]
|
||||
Y = [2, 1, 3, 1]
|
||||
L = [1, 3, 1, 2, 1, 3, 1, 2, 1, 3, 1, 2, 1, 3, 1] More? (;)
|
||||
|
||||
X = [A, 3, 1, A, 2, 1, A, A, 3, 1, A]
|
||||
Z = [1, A]
|
||||
Y = [2, 1, A, A, 3, 1, A]
|
||||
L = [1, A, 3, 1, A, 2, 1, A, A, 3, 1, A, 2, 1, A, A, 3, 1, A, 2, 1, A, A, 3, 1, A] More? (;)
|
||||
|
||||
L = [1,_A,_B,3,1,_A,_B,2,1,_A|...],
|
||||
X = [_A,_B,3,1,_A,_B,2,1,_A,_B|...],
|
||||
Y = [2,1,_A,_B,_A,_B,3,1,_A,_B],
|
||||
Z = [1,_A,_B],
|
||||
|
||||
etc.
|
||||
|
||||
% Solvable equation from talk by A. Colmerauer, WCLP Marseille, March 1993
|
||||
[13]: X=[1,2,3,2,1],
|
||||
[X,[1]] eqlist L1, [[U],Y,[U,U]] eqlist L1,
|
||||
[Y,[2]] eqlist L2, [[V],Z,[V,V]] eqlist L2,
|
||||
labeling.
|
||||
|
||||
X = [1, 2, 3, 2, 1]
|
||||
U = 1
|
||||
L1 = [1, 2, 3, 2, 1, 1]
|
||||
Y = [2, 3, 2]
|
||||
Z = [3]
|
||||
V = 2
|
||||
L2 = [2, 3, 2, 2]
|
||||
|
||||
*/
|
||||
|
||||
|
||||
% end of handler list
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
% Slim Abdennadher, Thom Fruehwirth, LMU, July 1998
|
||||
% Finite (enumeration, list) domain solver over integers
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
:- use_module( library(lists),
|
||||
[member/2,memberchk/2,select/3,
|
||||
last/2,is_list/1,min_list/2, max_list/2,
|
||||
remove_duplicates/2]).
|
||||
|
||||
handler listdom.
|
||||
|
||||
option(debug_compile,on).
|
||||
option(already_in_heads, on).
|
||||
option(check_guard_bindings, off).
|
||||
|
||||
% for domain constraints
|
||||
operator( 700,xfx,'::').
|
||||
operator( 600,xfx,'..').
|
||||
|
||||
% for inequality constraints
|
||||
operator( 700,xfx,lt).
|
||||
operator( 700,xfx,le).
|
||||
operator( 700,xfx,ne).
|
||||
|
||||
constraints (::)/2, le/2, lt/2, ne/2, add/3, mult/3.
|
||||
% X::Dom - X must be element of the finite list domain Dom
|
||||
|
||||
% special cases
|
||||
X::[] <=> fail.
|
||||
%X::[Y] <=> X=Y.
|
||||
%X::[A|L] <=> ground(X) | (member(X,[A|L]) -> true).
|
||||
|
||||
% intersection of domains for the same variable
|
||||
X::L1, X::L2 <=> is_list(L1), is_list(L2) |
|
||||
intersection(L1,L2,L) , X::L.
|
||||
|
||||
X::L, X::Min..Max <=> is_list(L) |
|
||||
remove_lower(Min,L,L1), remove_higher(Max,L1,L2),
|
||||
X::L2.
|
||||
|
||||
|
||||
% interaction with inequalities
|
||||
|
||||
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
|
||||
min_list(L1,MinX), min_list(L2,MinY), MinX > MinY |
|
||||
max_list(L2,MaxY), Y::MinX..MaxY.
|
||||
X le Y, X::L1, Y::L2 ==> is_list(L1),is_list(L2),
|
||||
max_list(L1,MaxX), max_list(L2,MaxY), MaxX > MaxY |
|
||||
min_list(L1,MinX), X::MinX..MaxY.
|
||||
|
||||
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
|
||||
max_list(L1,MaxX), max_list(L2,MaxY),
|
||||
MaxY1 is MaxY - 1, MaxY1 < MaxX |
|
||||
min_list(L1,MinX), X::MinX..MaxY1.
|
||||
X lt Y, X::L1, Y::L2 ==> is_list(L1), is_list(L2),
|
||||
min_list(L1,MinX), min_list(L2,MinY),
|
||||
MinX1 is MinX + 1, MinX1 > MinY |
|
||||
max_list(L2,MaxY), Y :: MinX1..MaxY.
|
||||
|
||||
X ne Y \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
|
||||
Y ne X \ Y::D <=> ground(X), is_list(D), member(X,D) | select(X,D,D1), Y::D1.
|
||||
Y::D \ X ne Y <=> ground(X), is_list(D), \+ member(X,D) | true.
|
||||
Y::D \ Y ne X <=> ground(X), is_list(D), \+ member(X,D) | true.
|
||||
|
||||
|
||||
% interaction with addition
|
||||
% no backpropagation yet!
|
||||
|
||||
add(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
|
||||
all_addition(L1,L2,L3), Z::L3.
|
||||
|
||||
% interaction with multiplication
|
||||
% no backpropagation yet!
|
||||
|
||||
mult(X,Y,Z), X::L1, Y::L2 ==> is_list(L1), is_list(L2) |
|
||||
all_multiplication(L1,L2,L3), Z::L3.
|
||||
|
||||
|
||||
% auxiliary predicates =============================================
|
||||
|
||||
remove_lower(_,[],L1):- !, L1=[].
|
||||
remove_lower(Min,[X|L],L1):-
|
||||
X@<Min,
|
||||
!,
|
||||
remove_lower(Min,L,L1).
|
||||
remove_lower(Min,[X|L],[X|L1]):-
|
||||
remove_lower(Min,L,L1).
|
||||
|
||||
remove_higher(_,[],L1):- !, L1=[].
|
||||
remove_higher(Max,[X|L],L1):-
|
||||
X@>Max,
|
||||
!,
|
||||
remove_higher(Max,L,L1).
|
||||
remove_higher(Max,[X|L],[X|L1]):-
|
||||
remove_higher(Max,L,L1).
|
||||
|
||||
intersection([], _, []).
|
||||
intersection([Head|L1tail], L2, L3) :-
|
||||
memberchk(Head, L2),
|
||||
!,
|
||||
L3 = [Head|L3tail],
|
||||
intersection(L1tail, L2, L3tail).
|
||||
intersection([_|L1tail], L2, L3) :-
|
||||
intersection(L1tail, L2, L3).
|
||||
|
||||
all_addition(L1,L2,L3) :-
|
||||
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X + Y), L3).
|
||||
|
||||
all_multiplication(L1,L2,L3) :-
|
||||
setof(Z, X^Y^(member(X,L1), member(Y,L2), Z is X * Y), L3).
|
||||
|
||||
|
||||
% EXAMPLE ==========================================================
|
||||
|
||||
/*
|
||||
?- X::[1,2,3,4,5,6,7], Y::[2,4,6,7,8,0], Y lt X, X::4..9, X ne Y,
|
||||
add(X,Y,Z), mult(X,Y,Z).
|
||||
*/
|
||||
|
||||
% end of handler listdom.pl =================================================
|
||||
% ===========================================================================
|
||||
|
|
@ -0,0 +1,136 @@
|
|||
% math-elim.pl================================================================
|
||||
% constraint handling rules for linear polynomial (in)equalitions
|
||||
% thom fruehwirth 910610,911213,920124,930518,931223,940308,950410-11,980312
|
||||
% 961107 Christian Holzbaur, SICStus mods.
|
||||
|
||||
% CHOOSE one of the following elim-* named CHRs for variable elimination
|
||||
% and comment out the others!
|
||||
|
||||
:- use_module( library(chr)).
|
||||
:- ensure_loaded( 'math-utilities').
|
||||
|
||||
handler elim.
|
||||
|
||||
% auxiliary constraint to delay a goal G until it is ground
|
||||
constraints check/1.
|
||||
check(G) <=> ground(G) | G.
|
||||
|
||||
% handle inequalities (introduces slack variables)
|
||||
|
||||
constraints {}/1.
|
||||
|
||||
{ C,Cs } <=> { C }, { Cs }.
|
||||
|
||||
{A =< B} <=> ground(A),ground(B) | A=<B.
|
||||
{A >= B} <=> ground(A),ground(B) | A>=B.
|
||||
{A < B} <=> ground(A),ground(B) | A<B.
|
||||
{A > B} <=> ground(A),ground(B) | A>B.
|
||||
{A =\= B} <=> ground(A),ground(B) | A=\=B.
|
||||
|
||||
% transform inequations into equations by introducing slack variables
|
||||
{A =< B} <=> {A+slack(X) =:= B}, check(X>=0).
|
||||
{A >= B} <=> {B+slack(X) =:= A}, check(X>=0).
|
||||
{A < B} <=> {A+slack(X) =:= B}, check(X>0).
|
||||
{A > B} <=> {B+slack(X) =:= A}, check(X>0).
|
||||
{A =\= B} <=> {A+ X =:= B}, check(X=\=0).
|
||||
|
||||
% some quick cases and the general case
|
||||
{A =:= B} <=> ground(A),ground(B) | X is A-B, zero(X). % handle imprecision
|
||||
{A =:= B} <=> var(A), ground(B) | A is B.
|
||||
{B =:= A} <=> var(A), ground(B) | A is B.
|
||||
{A =:= B} <=> unconstrained(A),var(B) | A=B.
|
||||
{B =:= A} <=> unconstrained(A),var(B) | A=B.
|
||||
{A =:= B} <=> normalize(A,B,P,C), equals(P,C).
|
||||
|
||||
operator(100,xfx,equals).
|
||||
|
||||
constraints (equals)/2.
|
||||
% Poly equals Const, where Poly is list of monomials Variable*Coefficient
|
||||
|
||||
% simplify single equation --------------------------------------------------
|
||||
empty @ [] equals C1 <=> zero(C1).
|
||||
unify @ [X*C2] equals C1 <=> nonground(X) | is_div(C1,C2,X). % nonzero(X)
|
||||
simplify @ P0 equals C1 <=> delete(X*C2,P0,P), ground(X) |
|
||||
is_mul(X,C2,XC2),
|
||||
C is XC2+C1,
|
||||
P equals C.
|
||||
/*
|
||||
% use only if you unify variables of equations with each other
|
||||
% if rule is not used: may loop if variables of the equations are unified
|
||||
unified @ P0 equals C1 <=>
|
||||
append(P1,[X*C2|P2],P0),var(X),delete(Y*C3,P2,P3),X==Y
|
||||
|
|
||||
C23 is C1+C2,
|
||||
append(P1,[X*C23|P3],P4),
|
||||
sort1(P4,P5), % needed ?
|
||||
P5 equals C1.
|
||||
*/
|
||||
|
||||
% CHOOSE one of the following elim-* CHRs for variable elimination
|
||||
% and comment out the others
|
||||
|
||||
% eliminate a variable ------------------------------------------------------
|
||||
% lazy rule to replace a variable or slack (as used in math-lazy.chr)
|
||||
elim_lazy @ [X*C2X|PX] equals C1X \ [X*C2|P] equals C1 <=> var(X) |
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
P4 equals C3.
|
||||
/*
|
||||
% not so lazy rule to replace a variable or slack
|
||||
% should make all variable bindings explicit
|
||||
% maybe even less efficient then eager rule?
|
||||
elim_medium @ [X*C2X|PX] equals C1X \ P0 equals C1 <=>
|
||||
(P0=[Y*C2|P] ; P0=[VC,Y*C2|P1],P=[VC|P1]),
|
||||
X==Y
|
||||
|
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
P4 equals C3.
|
||||
|
||||
% eager rule to replace a variable or slack (as used in math-eager.chr)
|
||||
elim_eager @ [X*C2X|PX] equals C1X \ P0 equals C1 <=> %var(X) |
|
||||
delete(Y*C2,P0,P),X==Y
|
||||
|
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
P3 equals C3.
|
||||
*/
|
||||
/*
|
||||
% handle slack variables, not complete ---------------------------------------
|
||||
all_slacks @ P equals C <=> all_slacks(P,PS),sign(C,CS),(CS=0;CS=PS) |
|
||||
CS=0,all_zeroes(P).
|
||||
*/
|
||||
% handle slack variables, complete? ------------------------------------------
|
||||
zero_slacks @ P equals C <=> zero(C),all_slacks(P,_PS) | all_zeroes(P).
|
||||
|
||||
first_slack @ [S1*C1|P] equals C <=> nonvar(S1),sign(C,SC),sign(C1,SC1),SC=SC1 |
|
||||
(delete(S2*C2,P,P1),sign(C2,SC2),SC2 is -SC ->
|
||||
[S2*C2,S1*C1|P1] equals C).
|
||||
|
||||
elim_slack @ [X*C2X|PX] equals C1X \ P0 equals C1 <=> % P0 all_slacks, no?
|
||||
nonvar(X), % slack variable
|
||||
sign(C1X,SC1X),sign(C2X,SC2X),SC2X\==SC1X, % different sign
|
||||
delete(Y*C2,P0,P),X==Y
|
||||
|
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
P3 equals C3. % put P0 first slack first, yes?
|
||||
|
||||
|
||||
% handle nonlinear equations -------------------------------------------------
|
||||
operator(450,xfx,eqnonlin).
|
||||
constraints (eqnonlin)/2.
|
||||
linearize @ X eqnonlin A <=> ground(A) | A1 is A, {X=:=A1}.
|
||||
linearize @ X eqnonlin A*B <=> ground(A) | A1 is A, {X=:=A1*B}.
|
||||
linearize @ X eqnonlin B*A <=> ground(A) | A1 is A, {X=:=A1*B}.
|
||||
|
||||
% pretty-print math-portray for equals/2 is defined in math-utilities.pl -----
|
||||
|
||||
/* end of file math-elim.pl -----------------------------------------------*/
|
||||
|
|
@ -0,0 +1,209 @@
|
|||
% fougau.pl =================================================================
|
||||
% constraint handling rules for linear arithmetic
|
||||
% fouriers algorithm for inequalities and gaussian elemination for equalities
|
||||
% thom fruehwirth 950405-06, 980312
|
||||
% 961107 Christian Holzbaur, SICStus mods
|
||||
|
||||
% CHOOSE one of the propagation rules below and comment out the others!
|
||||
% completeness and termination depends on propagation rule used
|
||||
|
||||
:- use_module( library(chr)).
|
||||
:- use_module( library(lists), [append/3]).
|
||||
:- ensure_loaded('math-utilities').
|
||||
|
||||
handler fougau.
|
||||
|
||||
% auxiliary constraint to delay a goal G until it is ground
|
||||
constraints check/1.
|
||||
check(G) <=> ground(G) | G.
|
||||
|
||||
constraints {}/1.
|
||||
|
||||
{ C,Cs } <=> { C }, { Cs }.
|
||||
|
||||
{A =< B} <=> ground(A),ground(B) | A=<B.
|
||||
{A >= B} <=> ground(A),ground(B) | A>=B.
|
||||
{A < B} <=> ground(A),ground(B) | A<B.
|
||||
{A > B} <=> ground(A),ground(B) | A>B.
|
||||
{A =\= B} <=> ground(A),ground(B) | A=\=B.
|
||||
|
||||
{A =< B} <=> normalize(B,A,P,C), eq(P,C,'>'('=')).
|
||||
{A >= B} <=> normalize(A,B,P,C), eq(P,C,'>'('=')).
|
||||
{A < B} <=> normalize(B,A,P,C), eq(P,C,'>'('>')).
|
||||
{A > B} <=> normalize(A,B,P,C), eq(P,C,'>'('>')).
|
||||
%{A < B} <=> normalize(B,A+1,P,C), eq(P,C,(>=)). % adopt to integer
|
||||
%{A > B} <=> normalize(A,B+1,P,C), eq(P,C,(>=)). % adopt to integer
|
||||
{A =\= B} <=> normalize(A+X,B,P,C), eq(P,C,(=:=)), check(X=\=0).
|
||||
|
||||
{A =:= B} <=> ground(A),ground(B) | X is A-B, zero(X). % handle imprecision of reals
|
||||
{A =:= B} <=> var(A), ground(B) | A is B.
|
||||
{B =:= A} <=> var(A), ground(B) | A is B.
|
||||
{A =:= B} <=> unconstrained(A),var(B) | A=B.
|
||||
{B =:= A} <=> unconstrained(A),var(B) | A=B.
|
||||
{A =:= B} <=> normalize(A,B,P,C), eq(P,C,(=:=)).
|
||||
|
||||
constraints eq/3.
|
||||
% eq(P,C,R)
|
||||
% P is a polynomial (list of monomials variable*coefficient),
|
||||
% C is a numeric constant and R is the relation between P and C
|
||||
|
||||
% simplify single equation
|
||||
zero @ eq([],C1,(=:=)) <=> zero(C1).
|
||||
zero @ eq([],C1,'>'('=')) <=> C1>=0.
|
||||
zero @ eq([],C1,'>'('>')) <=> C1>0.
|
||||
unify @ eq([X*C2],C1,(=:=)) <=> nonground(X),nonzero(C2) | is_div(C1,C2,X).
|
||||
%, integer(X) % if integers only
|
||||
simplify @ eq(P0,C1,R) <=> delete(X*C2,P0,P),ground(X) | % R any relation
|
||||
%, integer(X), % if integers only
|
||||
is_mul(X,C2,XC2),
|
||||
C is XC2+C1,
|
||||
eq(P,C,R).
|
||||
/*
|
||||
% must use if you unify variables of equations with each other
|
||||
unified @ eq(P0,C1,R1) <=>
|
||||
append(P1,[X*C2|P2],P0),var(X),delete(Y*C3,P2,P3),X==Y
|
||||
|
|
||||
C23 is C2+C3,
|
||||
append(P1,[X*C23|P3],P4),
|
||||
sort1(P4,P5),
|
||||
eq(P5,C1,R1).
|
||||
*/
|
||||
|
||||
%(1) remove redundant inequation
|
||||
% -1 (change in number of constraints)
|
||||
red_poly @ eq([X*C1X|P1],C1,'>'(R1)) \ eq([X*C2X|P2],C2,'>'(R2)) <=>
|
||||
C is C2X/C1X, % explicit because of call_explicit bug
|
||||
C>0, % same sign
|
||||
C1C is C1*C,
|
||||
C1C=<C2, % remove right one
|
||||
stronger(C1X,C1C,R1,C2X,C2,R2), % remove right one if C1C=:= C2
|
||||
same_poly(P1,P2,C)
|
||||
|
|
||||
true.
|
||||
|
||||
%(2) equate opposite inequations
|
||||
% -1
|
||||
opp_poly @ eq([X*C1X|P1],C1,'>'(R1)), eq([X*C2X|P2],C2,'>'(R2)) <=>
|
||||
C is C2X/C1X,
|
||||
C<0, % different sign
|
||||
C1C is C1*C,
|
||||
C1C>=C2, % applicable?
|
||||
same_poly(P1,P2,C)
|
||||
|
|
||||
Z is C1C-C2, zero(Z), % must have identical constants
|
||||
(R1)=('='), (R2)=('='), % fail if one of R's is ('>')
|
||||
eq([X*C1X|P1],C1,(=:=)).
|
||||
|
||||
%(3) usual equation replacement (like math-gauss.chr)
|
||||
% 0
|
||||
/*
|
||||
elimin_eager @ eq([X*C2X|PX],C1X,(=:=)) \ eq(P0,C1,R) <=> % R any relation
|
||||
extract(X*C2,P0,P)
|
||||
|
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
eq(P4,C3,R).
|
||||
*/
|
||||
elimin_lazy @ eq([X*C2X|PX],C1X,(=:=)) \ eq([X*C2|P],C1,R) <=>
|
||||
is_div(C2,C2X,CX),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
eq(P4,C3,R).
|
||||
|
||||
% choose one of the propagation rules below and comment out the others!
|
||||
% completeness and termination depends on propagation rule used
|
||||
|
||||
%(4) propagate, transitive closure of inequations, various versions
|
||||
% +1
|
||||
/*
|
||||
% complete, but too costly, propagate_lazy is as good, can loop
|
||||
propagate_eager @ eq([X*C2X|PX],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==>
|
||||
extract(X*C2,P0,P),
|
||||
is_div(C2,C2X,CX),
|
||||
CX>0 % different sign?
|
||||
|
|
||||
combine_ineqs(R1,R2,R3),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
eq(P4,C3,'>'(R3)).
|
||||
|
||||
% complete, may loop
|
||||
propagate_lazy @ eq([X*C2X|PX],C1X,'>'(R1)), eq([X*C2|P],C1,'>'(R2)) ==>
|
||||
is_div(C2,C2X,CX),
|
||||
CX>0 % different sign?
|
||||
|
|
||||
combine_ineqs(R1,R2,R3),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
eq(P4,C3,'>'(R3)).
|
||||
*/
|
||||
/*
|
||||
% incomplete, number of variables does not increase, may loop
|
||||
propagate_pair @ eq([X*C2X|PX],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==>
|
||||
not(PX=[_,_,_|_]), % single variable or pair of variables only
|
||||
extract(X*C2,P0,P),
|
||||
is_div(C2,C2X,CX),
|
||||
CX>0 % different sign?
|
||||
|
|
||||
combine_ineqs(R1,R2,R3),
|
||||
mult_const(eq0(C1X,PX),CX,P2),
|
||||
add_eq0(eq0(C1,P),P2,eq0(C3,P3)),
|
||||
sort1(P3,P4),
|
||||
eq(P4,C3,'>'(R3)).
|
||||
*/
|
||||
% incomplete, is interval reasoning, number of variables decreases, loop free
|
||||
propagate_single @ eq([X*C2X],C1X,'>'(R1)), eq(P0,C1,'>'(R2)) ==> % single variable only
|
||||
(P0=[V*C2|P],V==X ; P0=[VC,V*C2|PP],V==X,P=[VC|PP]), % only first or second variable
|
||||
is_div(C2,C2X,CX),
|
||||
CX>0 % different sign?
|
||||
|
|
||||
combine_ineqs(R1,R2,R3),
|
||||
is_mul(C1X,CX,C1XCX),
|
||||
C3 is C1+C1XCX,
|
||||
eq(P,C3,'>'(R3)).
|
||||
/*
|
||||
% incomplete, ignore inequations until they are sufficiently simplified
|
||||
%propagate_never @ eq([X*C2X|PX],C1X,'>'(R1)), eq([X*C2|P],C1,'>'(R2)) ==>
|
||||
% fail | true.
|
||||
*/
|
||||
|
||||
% handle nonlinear equations ------------------------------------------------
|
||||
operator(450,xfx,eqnonlin).
|
||||
constraints (eqnonlin)/2.
|
||||
non_linear @ X eqnonlin A <=> ground(A) | A1 is A, {X=:=A1}.
|
||||
non_linear @ X eqnonlin A*B <=> ground(A) | A1 is A, {X=:=A1*B}.
|
||||
non_linear @ X eqnonlin B*A <=> ground(A) | A1 is A, {X=:=A1*B}.
|
||||
|
||||
|
||||
% labeling, useful really only for integers ---------------------------------
|
||||
%label_with eq([XC],C1,'>'('=')) if true.
|
||||
%eq([XC],C1,'>'('=')) :- eq([XC],C1,(=:=)) ; eq([XC],C1,'>'('>')).
|
||||
|
||||
|
||||
% auxiliary predicates --------------------------------------------------------
|
||||
|
||||
% combine two inequalities
|
||||
combine_ineqs(('='),('='),('=')):- !.
|
||||
combine_ineqs(_,_,('>')).
|
||||
|
||||
same_poly([],[],C).
|
||||
same_poly([X*C1|P1],[X*C2|P2],C) ?-
|
||||
%X==Y,
|
||||
C4 is C*C1-C2, zero(C4),
|
||||
same_poly(P1,P2,C).
|
||||
|
||||
stronger(C1X,C1C,R1,C2X,C2,R2):-
|
||||
C1C=:=C2 ->
|
||||
\+ (R1=('='),R2=('>')),
|
||||
C1A is abs(C1X)+1/abs(C1X), C2A is abs(C2X)+1/abs(C2X),
|
||||
C1A=<C2A
|
||||
;
|
||||
true.
|
||||
|
||||
|
||||
/* end of file math-fougau.chr ----------------------------------------------*/
|
|
@ -0,0 +1,64 @@
|
|||
% Slim Abdennadher, Thom fruehwirth, LMU, July 1998
|
||||
% Straightforward Fourier Solver for linear inequations
|
||||
% may loop because of producing more and mor eredundant equations
|
||||
% compare to gauss.pl and fougau.pl
|
||||
|
||||
:- use_module(library(chr)).
|
||||
:- ['math-utilities.pl']. % load auxiliary file
|
||||
:- use_module( library(lists), [member/2, memberchk/2,select/3]).
|
||||
|
||||
handler gauss.
|
||||
|
||||
option(check_guard_bindings, on). % for delete(X...)
|
||||
option(already_in_store, off).
|
||||
option(already_in_heads, off).
|
||||
|
||||
operator(100,xfx,leq).
|
||||
|
||||
constraints (leq)/2.
|
||||
|
||||
redundant @
|
||||
[X*Coeff1|P1] leq C1 \ P leq C2 <=>
|
||||
delete(X*Coeff2,P,P2),
|
||||
is_div(Coeff2,Coeff1,C),
|
||||
C < 0,
|
||||
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
|
||||
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
|
||||
P3=[], 0 >= C3
|
||||
|
|
||||
true.
|
||||
|
||||
propagate(X) @
|
||||
[X*Coeff1|P1] leq C1, P leq C2 ==>
|
||||
delete(X*Coeff2,P,P2),
|
||||
is_div(Coeff2,Coeff1,C),
|
||||
C > 0
|
||||
|
|
||||
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
|
||||
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
|
||||
P3 leq C3.
|
||||
|
||||
zero @ [] leq C1 <=> 0 =< C1.
|
||||
|
||||
|
||||
constraints {}/1.
|
||||
% curly brackets as wrapper to avoid name clash with built-in =:= etc.
|
||||
|
||||
split @ { C, Cs } <=> { C }, { Cs }.
|
||||
|
||||
normalize @ {A >= B} <=> {B =< A}.
|
||||
normalize @ {A =:= B} <=> {A >= B}, {B =< A}.
|
||||
normalize @ {A =< B} <=>
|
||||
normalize(A,B,Poly,Const),
|
||||
Poly leq Const.
|
||||
|
||||
|
||||
/*
|
||||
|
||||
3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
|
||||
2 * (X + Y + Z) =:= 3 * (X - Y - Z) ,
|
||||
5 * (X + Y) - 7 * X - Z =:= (2 + 1 + X) * 6.
|
||||
*/
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
% solving linear polynomial equations by variable elimination a la Gauss
|
||||
% thom fruehwirth 910610,911213,920124,930602,931223, 980311
|
||||
% 961107 christian holzbaur for SICStus CHR
|
||||
% complete for equalities, leaves equalities implicit, slow
|
||||
% may loop if variables of the equations are unified
|
||||
|
||||
:- use_module(library(chr)).
|
||||
:- ensure_loaded('math-utilities'). % load auxiliary file
|
||||
|
||||
handler gauss.
|
||||
|
||||
option(check_guard_bindings, on). % for delete(X...) in rule eliminate
|
||||
|
||||
operator(100,xfx,equals).
|
||||
|
||||
constraints (equals)/2.
|
||||
% Poly equals Const, where Poly is list of monomials Variable*Coefficient
|
||||
|
||||
eliminate(X) @
|
||||
[X*Coeff1|P1] equals C1 \ P equals C2 <=> delete(X*Coeff2,P,P2) |
|
||||
is_div(Coeff2,Coeff1,C),
|
||||
mult_const(eq0(C1,P1),C,eq0(C1C,P1C)),
|
||||
add_eq0(eq0(C2,P2),eq0(C1C,P1C),eq0(C3,P3)),
|
||||
P3 equals C3.
|
||||
|
||||
|
||||
constraints {}/1.
|
||||
% curly brackets as wrapper to avoid name clash with built-in =:=
|
||||
|
||||
split @ { C, Cs } <=> { C }, { Cs }.
|
||||
|
||||
normalize @ {A =:= B} <=>
|
||||
normalize(A,B,Poly,Const),
|
||||
Poly equals Const.
|
||||
|
||||
|
||||
/*
|
||||
% uses math_portray pretty print defined in math-utilities.pl
|
||||
|
||||
?- {3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
|
||||
2 * (X + Y + Z) =:= 3 * (X - Y - Z) ,
|
||||
5 * (X + Y) - 7 * X - Z =:= (2 + 1 + X) * 6}.
|
||||
|
||||
-(6*Z)=:=6,
|
||||
-(35*Y)=:= -23,
|
||||
X=:= -1.7142857142857144 ?
|
||||
|
||||
?- {3 * X + 2 * Y - 4 * (3 + Z) =:= 2 * (X - 3) + (Y + Z) * 7 ,
|
||||
2 * (X + Y + Z) =:= 3 * (X - Y - Z)}.
|
||||
|
||||
-(6*Z)=:=6,
|
||||
-(5*Y)+X=:= -5 ?
|
||||
*/
|
||||
|
||||
/* end of file gauss.chr ------------------------------------------------*/
|
|
@ -0,0 +1,300 @@
|
|||
% math-utilities.pl ===========================================================
|
||||
% auxiliary predicates for math*.pl constraint solvers
|
||||
% thom fruehwirth 1991-92, revised 930518,931223,940304
|
||||
% 961030 christian holzbaur, SICStus adaption
|
||||
|
||||
:- use_module( library('chr/getval')).
|
||||
:- use_module( library('chr/matching')).
|
||||
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
|
||||
|
||||
|
||||
% SETTINGS --------------------------------------------------------------------
|
||||
|
||||
% for use in is/2: precision, slack variables, simulated infimum, etc.
|
||||
|
||||
% Code works with flag prefer_rationals on or off
|
||||
% and with float_precision single or double
|
||||
|
||||
% adapt precision for zero/1 test
|
||||
:- ( current_module(eclipse) ->
|
||||
get_flag(float_precision,G)
|
||||
;
|
||||
G = double
|
||||
),
|
||||
(G==single -> setval(precision,1.0e-06),setval(mprecision,-1.0e-06)
|
||||
;
|
||||
G==double -> setval(precision,1.0e-12),setval(mprecision,-1.0e-12)
|
||||
).
|
||||
|
||||
slack(X,X). % :- X>=0.
|
||||
|
||||
inf( 3.40282e38).
|
||||
minf( -3.40282e38).
|
||||
sup( 1.0e-45).
|
||||
msup( -1.0e-45).
|
||||
|
||||
:- multifile portray/1.
|
||||
|
||||
portray( X) :- math_portray( X, Xp), print( Xp).
|
||||
|
||||
|
||||
% PRETTY PRINT ---------------------------------------------------------------
|
||||
|
||||
% for math-gauss.pl and math-elim.pl
|
||||
math_portray(equals(P,C),P1=:=0):- zero(C),!,
|
||||
make_poly(P,P1).
|
||||
math_portray(equals(P,C),P1=:=C1):-!,
|
||||
MC is (-C),
|
||||
avoid_float(MC,C1),
|
||||
make_poly(P,P1).
|
||||
% for math-fougau.pl
|
||||
math_portray(eq(P,C,(=:=)),P1=:=C1):-!,
|
||||
MC is (-C),
|
||||
avoid_float(MC,C1),
|
||||
make_poly(P,P1).
|
||||
math_portray(eq(P,C,'>'('=')),P1>=C1):-!,
|
||||
MC is (-C),
|
||||
avoid_float(MC,C1),
|
||||
make_poly(P,P1).
|
||||
math_portray(eq(P,C,'>'('>')),P1>C1):-!,
|
||||
MC is (-C),
|
||||
avoid_float(MC,C1),
|
||||
make_poly(P,P1).
|
||||
% for all three math*pl solvers
|
||||
math_portray(eqnonlin(X,(E)),X=:=E):-!.
|
||||
|
||||
|
||||
make_poly([],0).
|
||||
make_poly([X*C],-CX):- C<0,!,
|
||||
C1 is (-C),
|
||||
avoid_float(C1,C2),
|
||||
make_mono(C2,X,CX).
|
||||
make_poly([X*C],CX):-!,
|
||||
avoid_float(C,C1),
|
||||
make_mono(C1,X,CX).
|
||||
make_poly([X*C|P],P1-CX):- C<0,!,
|
||||
C1 is (-C),
|
||||
avoid_float(C1,C2),
|
||||
make_mono(C2,X,CX),
|
||||
make_poly(P,P1).
|
||||
make_poly([X*C|P],P1+CX):-
|
||||
avoid_float(C,C1),
|
||||
make_mono(C1,X,CX),
|
||||
make_poly(P,P1).
|
||||
|
||||
make_mono(C,X,CX):- nonvar(X),X=slack(Y),!,make_mono(C,Y,CX).
|
||||
make_mono(C,X,CX1):- nonvar(X),number(X),!,CX is C*X,avoid_float(CX,CX1).
|
||||
make_mono(1,X,X):-!.
|
||||
% make_mono(1_1,X,X):-!.
|
||||
make_mono(C,X,C*X).
|
||||
|
||||
|
||||
% AUXILIARY PREDICATES -------------------------------------------------------
|
||||
|
||||
nonground( X) :- ground( X), !, fail.
|
||||
nonground( _).
|
||||
|
||||
%
|
||||
% sort X*K,slack(_)*K with globalized Xs
|
||||
%
|
||||
sort1(A,B):-
|
||||
msort(A,C),
|
||||
((C=[X*_|_],nonvar(X),X=slack(_))->A=B;B=C). % slacks unordered why?
|
||||
|
||||
msort( L, S) :-
|
||||
length( L, Len),
|
||||
msort( Len, L, [], S).
|
||||
|
||||
msort( 0, L, L, []) :- !.
|
||||
msort( 1, [X|L], L, [X]) :- !.
|
||||
msort( N, L0, L2, S) :-
|
||||
P is N>>1,
|
||||
Q is N-P,
|
||||
msort( P, L0, L1, Sp),
|
||||
msort( Q, L1, L2, Sq),
|
||||
merge( Sp, Sq, S).
|
||||
|
||||
merge( [], B, B) :- !.
|
||||
merge( A, [], A) :- !.
|
||||
merge( [A|As], [B|Bs], Res) :-
|
||||
cmp( R, A, B),
|
||||
merge( R, A, As, B, Bs, Res).
|
||||
|
||||
merge( =, A, As, _, Bs, [A|Rest]) :- merge( As, Bs, Rest).
|
||||
merge( <, A, As, B, Bs, [A|Rest]) :- merge( As, [B|Bs], Rest).
|
||||
merge( >, A, As, B, Bs, [B|Rest]) :- merge( [A|As], Bs, Rest).
|
||||
|
||||
cmp( R, X, Y) :- var(X), var(Y), !, var_compare( R, X, Y).
|
||||
cmp( R, X, _) :- var(X), !, R = (<).
|
||||
cmp( R, _, Y) :- var(Y), !, R = (>).
|
||||
cmp( R, X, Y) :-
|
||||
functor( X, Fx, Ax),
|
||||
functor( Y, Fy, Ay),
|
||||
compare( Rr, Ax/Fx, Ay/Fy),
|
||||
( Rr = (=),
|
||||
Ax > 0 ->
|
||||
cmp_args( 1,Ax, X, Y, R)
|
||||
;
|
||||
R = Rr
|
||||
).
|
||||
|
||||
cmp_args( N,M, _, _, R) :- N>M, !, R = (=).
|
||||
cmp_args( N,M, X, Y, R) :-
|
||||
arg( N, X, Ax),
|
||||
arg( N, Y, Ay),
|
||||
cmp( Rr, Ax, Ay),
|
||||
( Rr = (=) ->
|
||||
N1 is N+1,
|
||||
cmp_args( N1,M, X, Y, R)
|
||||
;
|
||||
R = Rr
|
||||
).
|
||||
|
||||
|
||||
rev([],L,L).
|
||||
rev([X|L1],L2,L3):- rev(L1,[X|L2],L3).
|
||||
|
||||
extract(X*C2,P0,P) ?- delete(Y*C2,P0,P),X==Y,!.
|
||||
|
||||
delete( X, [X|L], L).
|
||||
delete( Y, [X|Xs], [X|Xt]) :-
|
||||
delete( Y, Xs, Xt).
|
||||
|
||||
zero( slack(S)) ?- !, zero( S).
|
||||
zero(C):-
|
||||
float(C) ->
|
||||
getval(precision,P),
|
||||
getval(mprecision,MP),
|
||||
MP < C, % cope with imprecision
|
||||
C < P
|
||||
;
|
||||
C=:=0.
|
||||
|
||||
nonzero(C):- zero(C), !, fail.
|
||||
nonzero(_).
|
||||
|
||||
unwrap( slack(S), X) ?- !, X=S.
|
||||
unwrap( X, X).
|
||||
|
||||
is_div( C1, C2, C3) :-
|
||||
unwrap( C1, C11),
|
||||
unwrap( C2, C21),
|
||||
unwrap( C3, C31),
|
||||
is_divu( C11, C21, C31).
|
||||
|
||||
is_divu(C1,C2,C3):- zero(C1),!,C3=0.
|
||||
is_divu(C1,C2,C3):- X is -(C1/C2), % minus here to get sign needed in handlers
|
||||
avoid_float(X,C3).
|
||||
|
||||
is_mul( C1, C2, C3) :-
|
||||
unwrap( C1, C11),
|
||||
unwrap( C2, C21),
|
||||
unwrap( C3, C31),
|
||||
is_mulu( C11, C21, C31).
|
||||
|
||||
is_mulu(C1,C2,C3):- zero(C1),!,C3=0.
|
||||
is_mulu(C1,C2,C3):- zero(C2),!,C3=0.
|
||||
is_mulu(C1,C2,C3):- X is C1*C2,
|
||||
avoid_float(X,C3).
|
||||
|
||||
avoid_float(X,C3):-
|
||||
float(X) -> Y is round(X),Z is X-Y,(zero(Z)-> C3 is integer(Y);C3=X) ; C3=X.
|
||||
|
||||
|
||||
simplifyable(X*C,P,P1):- delete(X*C,P,P1),ground(X),!.
|
||||
|
||||
|
||||
% HANDLING SLACK VARIABLES ----------------------------------------------------
|
||||
|
||||
all_slacks([]).
|
||||
all_slacks([slack(Sl)*C|P]) ?- % check_slack(Sl),
|
||||
all_slacks(P).
|
||||
|
||||
all_slacks([],_).
|
||||
all_slacks([slack(Sl)*C|P],S) ?- % check_slack(Sl),
|
||||
sign(C,S),
|
||||
all_slacks(P,S).
|
||||
|
||||
check_slack( S) :- find_constraint( S, basic(_)#_), !.
|
||||
check_slack( _) :- raise_exception( slack).
|
||||
|
||||
sign(C,0):- zero(C),!.
|
||||
sign(C,S):- C>0 -> S=1 ; S=(-1).
|
||||
|
||||
all_zeroes([]).
|
||||
all_zeroes([slack(0)*C|P]) :-
|
||||
all_zeroes(P).
|
||||
|
||||
|
||||
% COMPUTING WITH POLYNOMIALS -------------------------------------------------
|
||||
|
||||
% gets rounded constant C from is_div/3
|
||||
mult_const(eq0(C1,P1),C,eq0(0 ,[])):- C=:=0,!.
|
||||
mult_const(eq0(C1,P1),C,eq0(C1,P1)):- C=:=1,!.
|
||||
mult_const(eq0(C1,P1),C2,eq0(C,P)):-
|
||||
(zero(C1) -> C=0 ; C is C1*C2),
|
||||
mult_const1(P1,C2,P).
|
||||
mult_const1([],C,[]).
|
||||
mult_const1([Xi*Ci|Poly],C,PolyR):-
|
||||
(zero(Ci) -> PolyR=NPoly ; NCi is Ci*C,PolyR=[Xi*NCi|NPoly]),
|
||||
mult_const1(Poly,C,NPoly).
|
||||
|
||||
% gets input from const_mult/3
|
||||
add_eq0(eq0(C1,P1),eq0(C2,P2),eq0(C,P0)):-
|
||||
Ci is C1+C2,
|
||||
(zero(Ci) -> C=0 ; C=Ci),
|
||||
add_eq1(P1,P2,P0).
|
||||
% sort(P,P0).
|
||||
add_eq1([],Poly,Poly):-!.
|
||||
add_eq1(Poly,[],Poly):-!.
|
||||
add_eq1([Xi1*Ci1|Poly1],Poly21,Poly):-
|
||||
delete(Xi2*Ci2,Poly21,Poly2),Xi2==Xi1,
|
||||
!,
|
||||
Ci is Ci1+Ci2,
|
||||
(zero(Ci) -> Poly=Poly3 ; Poly=[Xi1*Ci|Poly3]),
|
||||
add_eq1(Poly1,Poly2,Poly3).
|
||||
add_eq1([Xi1*Ci1|Poly1],Poly2,[Xi1*Ci1|Poly3]):-
|
||||
add_eq1(Poly1,Poly2,Poly3).
|
||||
|
||||
|
||||
|
||||
normalize(A,B,P2,C1):-
|
||||
normalize1(A-B,P),
|
||||
P=eq0(C1,P1),rev(P1,[],P1R),globalize(P1R),
|
||||
sort1(P1,P2).
|
||||
|
||||
normalize1(V,P) ?- var(V),!,
|
||||
P=eq0(0,[V*1]).
|
||||
normalize1(C,P) ?- ground(C),!,
|
||||
C1 is C,P=eq0(C1,[]).
|
||||
normalize1(slack(V),P) ?- !,
|
||||
P=eq0(0,[slack(V)*1]).
|
||||
normalize1((+E),P) ?-!,
|
||||
normalize1(E,P).
|
||||
normalize1((-E),P) ?-!,
|
||||
normalize1(E,P1),
|
||||
mult_const(P1,(-1),P).
|
||||
normalize1(A*B,C) ?- ground(A),!,
|
||||
normalize1(B,BN),
|
||||
mult_const(BN,A,C).
|
||||
normalize1(B*A,C) ?- ground(A),!,
|
||||
normalize1(B,BN),
|
||||
mult_const(BN,A,C).
|
||||
normalize1(B/A,C) ?- ground(A),!,
|
||||
normalize1(B,BN),
|
||||
A1 is 1/A,
|
||||
mult_const(BN,A1,C).
|
||||
normalize1(A-B,C) ?- !,
|
||||
normalize1(A,AN),
|
||||
normalize1((-B),BN),
|
||||
add_eq0(AN,BN,C).
|
||||
normalize1(A+B,C) ?- !,
|
||||
normalize1(A,AN),
|
||||
normalize1(B,BN),
|
||||
add_eq0(AN,BN,C).
|
||||
normalize1(E,C) ?-
|
||||
C=eq0(0,[CX*1]),
|
||||
eqnonlin(CX,E). % add a nonlinear equation constraint
|
||||
|
||||
|
||||
% end of file math-utilities.pl -----------------------------------------------
|
|
@ -0,0 +1,127 @@
|
|||
% INEQUALITIES with MINIMIUM and MAXIMUM on terms
|
||||
% 920303, 950411 ECRC Thom Rruehwirth
|
||||
% 961105 Christian Holzbaur, SICStus mods
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler minmax.
|
||||
|
||||
option(check_guard_bindings, on). % for ~=/2 with deep guards
|
||||
|
||||
operator(700, xfx, lss). % less than
|
||||
operator(700, xfx, grt). % greater than
|
||||
operator(700, xfx, neq). % not equal to
|
||||
operator(700, xfx, geq). % greater or equal to
|
||||
operator(700, xfx, leq). % less or equal to
|
||||
operator(700, xfx, ~=). % not identical
|
||||
|
||||
constraints (~=)/2.
|
||||
|
||||
X ~= X <=> fail.
|
||||
X ~= Y <=> ground(X),ground(Y) | X\==Y.
|
||||
|
||||
constraints (leq)/2, (lss)/2, (neq)/2, minimum/3, maximum/3.
|
||||
|
||||
X geq Y :- Y leq X.
|
||||
X grt Y :- Y lss X.
|
||||
|
||||
|
||||
/* leq */
|
||||
|
||||
built_in @ X leq Y <=> ground(X),ground(Y) | X @=< Y.
|
||||
reflexivity @ X leq X <=> true.
|
||||
|
||||
antisymmetry @ X leq Y, Y leq X <=> X = Y.
|
||||
|
||||
transitivity @ X leq Y, Y leq Z ==> X \== Y, Y \== Z, X \== Z | X leq Z.
|
||||
|
||||
subsumption @ X leq N \ X leq M <=> N@<M | true.
|
||||
subsumption @ M leq X \ N leq X <=> N@<M | true.
|
||||
|
||||
|
||||
/* lss */
|
||||
|
||||
built_in @ X lss Y <=> ground(X),ground(Y) | X @< Y.
|
||||
irreflexivity@ X lss X <=> fail.
|
||||
|
||||
transitivity @ X lss Y, Y lss Z ==> X \== Y, Y \== Z | X lss Z.
|
||||
transitivity @ X leq Y, Y lss Z ==> X \== Y, Y \== Z | X lss Z.
|
||||
transitivity @ X lss Y, Y leq Z ==> X \== Y, Y \== Z | X lss Z.
|
||||
|
||||
subsumption @ X lss Y \ X leq Y <=> true.
|
||||
|
||||
subsumption @ X lss N \ X lss M <=> N@<M | true.
|
||||
subsumption @ M lss X \ N lss X <=> N@<M | true.
|
||||
|
||||
subsumption @ X leq N \ X lss M <=> N@<M | true.
|
||||
subsumption @ M leq X \ N lss X <=> N@<M | true.
|
||||
subsumption @ X lss N \ X leq M <=> N@<M | true.
|
||||
subsumption @ M lss X \ N leq X <=> N@<M | true.
|
||||
|
||||
|
||||
/* neq */
|
||||
|
||||
built_in @ X neq Y <=> X ~= Y | true.
|
||||
irreflexivity@ X neq X <=> fail.
|
||||
|
||||
subsumption @ X neq Y \ Y neq X <=> true.
|
||||
subsumption @ X lss Y \ X neq Y <=> true.
|
||||
subsumption @ X lss Y \ Y neq X <=> true.
|
||||
|
||||
simplification @ X neq Y, X leq Y <=> X lss Y.
|
||||
simplification @ Y neq X, X leq Y <=> X lss Y.
|
||||
|
||||
|
||||
|
||||
/* MINIMUM */
|
||||
|
||||
constraints labeling/0.
|
||||
|
||||
labeling, minimum(X, Y, Z)#Pc <=>
|
||||
(X leq Y, Z = X ; Y lss X, Z = Y),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
built_in @ minimum(X, Y, Z) <=> ground(X),ground(Y) | (X@=<Y -> Z=X ; Z=Y).
|
||||
built_in @ minimum(X, Y, Z) <=> Z~=X | Z = Y, Y lss X.
|
||||
built_in @ minimum(Y, X, Z) <=> Z~=X | Z = Y, Y lss X.
|
||||
|
||||
min_eq @ minimum(X, X, Y) <=> X = Y.
|
||||
|
||||
min_leq @ Y leq X \ minimum(X, Y, Z) <=> Y=Z.
|
||||
min_leq @ X leq Y \ minimum(X, Y, Z) <=> X=Z.
|
||||
min_lss @ Z lss X \ minimum(X, Y, Z) <=> Y=Z.
|
||||
min_lss @ Z lss Y \ minimum(X, Y, Z) <=> X=Z.
|
||||
|
||||
functional @ minimum(X, Y, Z) \ minimum(X, Y, Z1) <=> Z1=Z.
|
||||
functional @ minimum(X, Y, Z) \ minimum(Y, X, Z1) <=> Z1=Z.
|
||||
|
||||
propagation @ minimum(X, Y, Z) ==> X\==Y | Z leq X, Z leq Y.
|
||||
|
||||
|
||||
/* MAXIMUM */
|
||||
|
||||
labeling, maximum(X, Y, Z)#Pc <=>
|
||||
(X leq Y, Z = Y ; Y lss X, Z = X),
|
||||
labeling
|
||||
pragma passive(Pc).
|
||||
|
||||
built_in @ maximum(X, Y, Z) <=> ground(X),ground(Y) | (Y@=<X -> Z=X ; Z=Y).
|
||||
built_in @ maximum(X, Y, Z) <=> Z~=X | Z = Y, X lss Y.
|
||||
built_in @ maximum(Y, X, Z) <=> Z~=X | Z = Y, X lss Y.
|
||||
|
||||
max_eq @ maximum(X, X, Y) <=> X = Y.
|
||||
|
||||
max_leq @ Y leq X \ maximum(X, Y, Z) <=> X=Z.
|
||||
max_leq @ X leq Y \ maximum(X, Y, Z) <=> Y=Z.
|
||||
max_lss @ X lss Z \ maximum(X, Y, Z) <=> Y=Z.
|
||||
max_lss @ Y lss Z \ maximum(X, Y, Z) <=> X=Z.
|
||||
|
||||
functional @ maximum(X, Y, Z) \ maximum(X, Y, Z1) <=> Z1=Z.
|
||||
functional @ maximum(X, Y, Z) \ maximum(Y, X, Z1) <=> Z1=Z.
|
||||
|
||||
propagation @ maximum(X, Y, Z) ==> X\==Y | X leq Z, Y leq Z.
|
||||
|
||||
|
||||
|
||||
% end of handler minmax
|
|
@ -0,0 +1,36 @@
|
|||
:- use_module(library(chr)).
|
||||
|
||||
handler modelgenerator.
|
||||
|
||||
constraints attends/3, requires/2, less/2, leq/2.
|
||||
|
||||
operator(700,xfx,less).
|
||||
operator(700,xfx,leq).
|
||||
|
||||
|
||||
X less Y <=> nonvar(X), nonvar(Y) | X < Y.
|
||||
|
||||
X less Y \ X less Z <=> Y =< Z | true.
|
||||
|
||||
X less Y, X leq Y <=> false.
|
||||
|
||||
X leq X <=> true.
|
||||
|
||||
|
||||
attends(S, Y, TY), requires(Y, X) ==> attends(S, X, TX), TX less TY.
|
||||
|
||||
attends(john,C,T) ==> true | (T leq 1996 ; T less 1994).
|
||||
|
||||
|
||||
example :-
|
||||
attends(john,constraintprogrammierung,1996),
|
||||
requires(constraintprogrammierung,logik).
|
||||
|
||||
/*
|
||||
?- example.
|
||||
|
||||
requires(constraintprogrammierung,logik),
|
||||
_A less 1994,
|
||||
attends(john,constraintprogrammierung,1996),
|
||||
attends(john,logik,_A) ?
|
||||
*/
|
|
@ -0,0 +1,340 @@
|
|||
%
|
||||
% Monkey and Bananas:
|
||||
%
|
||||
% Forward chaining rules via CHR.
|
||||
% rules inspired from ftp://ftp.cs.unibo.it:/pub/gaspari/fw_rules/
|
||||
% Quite fast because no dynamic predicates are used to
|
||||
% represent the facts.
|
||||
% The amount of code generated is substantial however.
|
||||
% Not optimized
|
||||
%
|
||||
% 970213 Christian Holzbaur
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
handler monkey.
|
||||
|
||||
constraints phys_object/7, monkey/3, goal/5, found/0.
|
||||
% explaination of constraints is missing here
|
||||
|
||||
:- op(900,fy,not).
|
||||
% There is no such fact ('not exists' in SQL)
|
||||
not Fact :- find_constraint( Fact, _), !, fail.
|
||||
not _.
|
||||
|
||||
|
||||
testcase(1) :-
|
||||
phys_object(bananas,9-9,light,ceiling,_,_,ok),
|
||||
phys_object(couch,7-7,heavy,floor,_,low,_),
|
||||
phys_object(ladder,4-3,light,floor,_,high,_),
|
||||
phys_object(blanket,7-7,light,_,_,_,_),
|
||||
phys_object(garbage_can,3-5,light,floor,_,low,_),
|
||||
monkey(7-7,couch,blanket),
|
||||
goal(active,holds,bananas,_,_).
|
||||
|
||||
|
||||
rule(1) @
|
||||
goal(active,on,floor,A,B),
|
||||
monkey(D,E,F) <=>
|
||||
|
||||
E\==floor
|
||||
|
|
||||
write('Jump onto the floor'),
|
||||
nl,
|
||||
monkey(D,floor,F),
|
||||
goal(satisfied,on,floor,A,B).
|
||||
|
||||
|
||||
rule(2) @
|
||||
monkey(A,floor,B) \
|
||||
goal(active,on,floor,D,E) <=>
|
||||
|
||||
write('Monkey is already on floor'),
|
||||
nl,
|
||||
goal(satisfied,on,floor,D,E).
|
||||
|
||||
|
||||
rule(3) @
|
||||
phys_object(A,B,C,floor,D,E,F) \
|
||||
goal(active,on,A,H,I),
|
||||
monkey(B,K,nothing) <=>
|
||||
|
||||
K\==A
|
||||
|
|
||||
write('Climb onto '),
|
||||
write(A),
|
||||
nl,
|
||||
monkey(B,A,nothing),
|
||||
goal(satisfied,on,A,H,I).
|
||||
|
||||
|
||||
rule(4) @
|
||||
goal(active,on,A,B,C),
|
||||
phys_object(A,E,F,G,H,I,J),
|
||||
monkey(E,L,M) ==>
|
||||
|
||||
M\==nothing
|
||||
|
|
||||
write('Put '),
|
||||
nl,
|
||||
goal(active,holds,nothing,O,P).
|
||||
|
||||
|
||||
rule(5) @
|
||||
goal(active,on,A,B,C),
|
||||
phys_object(A,E,F,floor,G,H,I),
|
||||
monkey(K,L,M) ==>
|
||||
|
||||
K\==E
|
||||
|
|
||||
goal(active,at,nothing,O,E).
|
||||
|
||||
|
||||
rule(6) @
|
||||
phys_object(A,B,C,floor,D,E,F),
|
||||
monkey(B,A,H) \
|
||||
goal(active,on,A,J,K) <=>
|
||||
|
||||
write('Monkey is already on '),
|
||||
write(A),
|
||||
nl,
|
||||
goal(satisfied,on,A,J,K).
|
||||
|
||||
|
||||
rule(7) @
|
||||
goal(active,holds,nothing,A,B),
|
||||
monkey(D,E,F),
|
||||
phys_object(F,H,I,J,K,L,M) <=>
|
||||
|
||||
F\==nothing
|
||||
|
|
||||
write('Drop '),
|
||||
write(F),
|
||||
nl,
|
||||
goal(satisfied,holds,nothing,A,B),
|
||||
monkey(D,E,nothing),
|
||||
phys_object(F,H,I,floor,K,L,M).
|
||||
|
||||
|
||||
rule(8) @
|
||||
goal(active,holds,nothing,A,B),
|
||||
monkey(D,E,nothing) ==>
|
||||
|
||||
write('Monkey is holding nothing'),
|
||||
nl,
|
||||
goal(satisfied,holds,nothing,A,B).
|
||||
|
||||
|
||||
rule(9) @
|
||||
phys_object(ladder,A,B,floor,C,D,E) \
|
||||
goal(active,holds,G,H,I),
|
||||
phys_object(G,A,light,ceiling,K,L,M),
|
||||
monkey(O,ladder,nothing) <=>
|
||||
|
||||
not phys_object(Q,R,S,G,T,U,V)
|
||||
|
|
||||
write('Grab '),
|
||||
write(G),
|
||||
nl,
|
||||
monkey(O,ladder,G),
|
||||
phys_object(G,A,light,nothing,K,L,M),
|
||||
goal(satisfied,holds,G,H,I).
|
||||
|
||||
|
||||
rule(10) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,ceiling,F,G,H),
|
||||
phys_object(ladder,E,J,floor,K,L,M),
|
||||
monkey(O,P,Q) ==>
|
||||
|
||||
P\==ladder
|
||||
|
|
||||
goal(active,on,ladder,S,T).
|
||||
|
||||
|
||||
rule(11) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,ceiling,F,G,H),
|
||||
phys_object(ladder,J,K,L,M,N,O) ==>
|
||||
|
||||
J\==E,
|
||||
not goal(active,at,ladder,Q,E)
|
||||
|
|
||||
goal(active,at,ladder,R,E).
|
||||
|
||||
|
||||
rule(12) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,F,G,H,I),
|
||||
monkey(E,floor,nothing) <=>
|
||||
|
||||
F\==ceiling,
|
||||
not phys_object(L,M,N,A,O,P,Q)
|
||||
|
|
||||
write('Grab '),
|
||||
write(A),
|
||||
nl,
|
||||
phys_object(A,E,light,nothing,G,H,I),
|
||||
monkey(E,floor,A),
|
||||
goal(satisfied,holds,A,B,C).
|
||||
|
||||
|
||||
rule(13) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,F,G,H,I),
|
||||
monkey(E,F,K) ==>
|
||||
|
||||
F\==ceiling,
|
||||
F\==floor
|
||||
|
|
||||
goal(active,on,floor,M,N).
|
||||
|
||||
|
||||
rule(14) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,F,G,H,I),
|
||||
monkey(K,L,M) ==>
|
||||
|
||||
F\==ceiling,
|
||||
K\==E,
|
||||
not goal(active,at,nothing,O,P)
|
||||
|
|
||||
goal(active,at,nothing,Q,E).
|
||||
|
||||
|
||||
rule(15) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,F,G,H,I),
|
||||
monkey(E,K,L) ==>
|
||||
|
||||
L\==nothing,
|
||||
L\==A,
|
||||
not goal(active,holds,nothing,N,O)
|
||||
|
|
||||
goal(active,holds,nothing,P,Q).
|
||||
|
||||
|
||||
rule(16) @
|
||||
goal(active,at,A,B,C),
|
||||
monkey(E,floor,A),
|
||||
phys_object(A,G,H,I,J,K,L) <=>
|
||||
|
||||
E\==C
|
||||
|
|
||||
write('Move '),
|
||||
write(A),
|
||||
write(' to '),
|
||||
write(C),
|
||||
nl,
|
||||
phys_object(A,C,H,I,J,K,L),
|
||||
monkey(C,floor,A),
|
||||
goal(satisfied,at,A,B,C).
|
||||
|
||||
|
||||
rule(17) @
|
||||
goal(active,at,A,B,C),
|
||||
monkey(E,F,A),
|
||||
phys_object(A,H,I,J,K,L,M) ==>
|
||||
|
||||
F\==floor,
|
||||
H\==C,
|
||||
not goal(active,on,floor,O,P)
|
||||
|
|
||||
goal(active,on,floor,Q,R).
|
||||
|
||||
|
||||
rule(18) @
|
||||
goal(active,at,A,B,C),
|
||||
phys_object(A,E,light,F,G,H,I),
|
||||
monkey(K,L,M) ==>
|
||||
|
||||
E\==C,
|
||||
M\==A,
|
||||
not goal(active,holds,A,O,P)
|
||||
|
|
||||
goal(active,holds,A,Q,R).
|
||||
|
||||
|
||||
rule(19) @
|
||||
phys_object(A,B,light,C,D,E,F) \
|
||||
goal(active,at,A,H,B) <=>
|
||||
|
||||
write('The object '),
|
||||
write(A),
|
||||
write(' is already at '),
|
||||
write(B),
|
||||
nl,
|
||||
goal(satisfied,at,A,H,B).
|
||||
|
||||
|
||||
rule(20) @
|
||||
goal(active,at,nothing,A,B),
|
||||
monkey(B,floor,nothing) <=>
|
||||
|
||||
write('Walk to '),
|
||||
write(B),
|
||||
nl,
|
||||
monkey(B,floor,nothing),
|
||||
goal(satisfied,at,nothing,A,B).
|
||||
|
||||
|
||||
rule(21) @
|
||||
goal(active,at,nothing,A,B),
|
||||
monkey(D,floor,E),
|
||||
phys_object(E,G,H,I,J,K,L) <=>
|
||||
|
||||
D\==B
|
||||
|
|
||||
write('Walk to '),
|
||||
write(B),
|
||||
write(' carrying '),
|
||||
write(E),
|
||||
nl,
|
||||
monkey(B,floor,E),
|
||||
phys_object(E,B,H,I,J,K,L),
|
||||
goal(satisfied,at,nothing,A,B).
|
||||
|
||||
|
||||
rule(22) @
|
||||
goal(active,at,nothing,A,B),
|
||||
monkey(D,E,F) ==>
|
||||
|
||||
E\==floor,
|
||||
D\==B
|
||||
|
|
||||
goal(active,on,floor,H,I).
|
||||
|
||||
|
||||
rule(23) @
|
||||
monkey(A,B,C) \
|
||||
goal(active,at,nothing,E,A) <=>
|
||||
|
||||
write('Monkey is already at '),
|
||||
write(A),
|
||||
nl,
|
||||
goal(satisfied,at,nothing,E,A).
|
||||
|
||||
|
||||
rule(24) @
|
||||
goal(satisfied,A,B,C,D) ==>
|
||||
|
||||
not goal(active,F,G,H,I),
|
||||
not found
|
||||
|
|
||||
write('CONGRATULATIONS the goals are satisfied'),
|
||||
nl,
|
||||
found.
|
||||
|
||||
|
||||
rule(25) @
|
||||
goal(active,holds,A,B,C),
|
||||
phys_object(A,E,light,nothing,F,G,H),
|
||||
monkey(E,J,A) ==>
|
||||
|
||||
write('Object '),
|
||||
write(A),
|
||||
write(' is already being held'),
|
||||
nl,
|
||||
goal(satisfied,holds,A,B,C).
|
||||
|
||||
end_of_file.
|
|
@ -0,0 +1,124 @@
|
|||
% Order Sorted Feature Constraints -------------------------------------------
|
||||
% following DEC-PRL Research Report 32, May 1993, by H. Ait-Kaci, A. Podelski
|
||||
% and S.C. Goldstein on "Order-Sorted Feature Theory Unification"
|
||||
% see also cft.pl, kl-one.pl, type.pl
|
||||
% 940603 ECRC, 980211, 980312 Thom Fruehwirth LMU for Sicstus CHR
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler osf.
|
||||
|
||||
option(already_in_store, on).
|
||||
|
||||
operator(150,xfx,'=>'). % label has value constraint
|
||||
operator(100,xfx,'::'). % sort constraint
|
||||
operator(100,xfx,'..'). % feature constraint
|
||||
operator(450,xfx,'##'). % equality constraint
|
||||
operator(450,fx,'theory'). % OSF theory clause
|
||||
|
||||
constraints (::)/2, (##)/2.
|
||||
|
||||
|
||||
% OSF Term Dissolution
|
||||
X::T <=> nonvar(T), \+ atomic(T) | dissolve(X,T).
|
||||
|
||||
dissolve(X,T):- T=..[S|Ls], X::S, dissolve1(X,Ls).
|
||||
dissolve1(X,[]).
|
||||
dissolve1(X,[L1=>T1|Ls]):- X..L1##Y, dissolve0(Y,T1), dissolve1(X,Ls).
|
||||
dissolve0(Y,T):- var(T), !, Y=T.
|
||||
dissolve0(Y,X::T):- !, Y=X, dissolve(Y,T).
|
||||
dissolve0(Y,T):- Y::T.
|
||||
|
||||
|
||||
% OSF Clause Normalization Rules
|
||||
% see Figure 1, p. 6 of DEC-PRL RR 32
|
||||
|
||||
% (1) sort intersection
|
||||
X::S1, X::S2 <=> atomic(S1),atomic(S2) | sort_intersection(S1,S2,S3), X::S3.
|
||||
|
||||
% (2) inconsistent sort
|
||||
% reflected down to built-in constraints true and fail
|
||||
X::bot <=> fail.
|
||||
X::top <=> true.
|
||||
|
||||
% (3) variable elimination
|
||||
% reflected down to built-in constraint for equality
|
||||
X##Y <=> var(X) | X=Y.
|
||||
|
||||
% (4) feature decomposition
|
||||
X..L##Y \ X..L##Z <=> Y=Z.
|
||||
|
||||
|
||||
% OSF Theory Unification
|
||||
% preliminary version, theory represented by Prolog facts
|
||||
X::S#Id, X.._##_ ==> atomic(S),theory X::T,functor(T,S,_) | X::T.
|
||||
|
||||
|
||||
% EXAMPLES ---------------------------------------------------------------
|
||||
|
||||
% cyclic structure, page 1, DEC-PRL RR 32
|
||||
eg1(P):-
|
||||
P::person(name=>id(first=>string,
|
||||
last=>S::string),
|
||||
age=>30,
|
||||
spouse=>person(name=>id(last=>S),
|
||||
spouse=>P)).
|
||||
|
||||
% cyclic structure, p. 3, DEC-PRL RR 32
|
||||
eg2(X):-
|
||||
X::cons(head=>1,tail=>X).
|
||||
eg2a(X):- % same as eg2(X)
|
||||
X::cons(head=>1,tail=>X), X::cons(head=>1,tail=>cons(head=>1,tail=>X)).
|
||||
|
||||
% p.17, DEC-PRL RR 32
|
||||
eg3(X):-
|
||||
X::s1(l1=>s),X::s2(l2=>s).
|
||||
|
||||
sort_intersection(s1,s2,s3).
|
||||
sort_intersection(s2,s1,s3).
|
||||
|
||||
% non-empty theory
|
||||
theory YS1::s1(l1=>Y1::s).
|
||||
theory YS2::s2(l2=>Y2::s).
|
||||
theory YS3::s3(l1=>Y3::s(l=>Y4::s),l2=>Y3).
|
||||
theory YS::s(l=>Y5::s).
|
||||
|
||||
/*
|
||||
| ?- eg1(X) ; eg2(X) ; eg2a(X) ; eg3(X).
|
||||
|
||||
X::person,
|
||||
X..name##_A,
|
||||
_A::id,
|
||||
_A..first##_B,
|
||||
_B::string,
|
||||
_A..last##_C,
|
||||
_C::string,
|
||||
X..age##_D,
|
||||
_D::30,
|
||||
X..spouse##_E,
|
||||
_E::person,
|
||||
_E..name##_F,
|
||||
_F::id,
|
||||
_F..last##_C,
|
||||
_E..spouse##X ? ;
|
||||
|
||||
X::cons,
|
||||
X..head##_A,
|
||||
_A::1,
|
||||
X..tail##X ? ;
|
||||
|
||||
X::cons,
|
||||
X..head##_A,
|
||||
_A::1,
|
||||
X..tail##X ? ;
|
||||
|
||||
X..l1##_A,
|
||||
_A::s,
|
||||
X::s3,
|
||||
_A..l##_B,
|
||||
_B::s,
|
||||
X..l2##_A ?
|
||||
|
||||
*/
|
||||
|
||||
% end of handler osf ----------------------------------------------------------
|
|
@ -0,0 +1,100 @@
|
|||
% rational tree handler with diseqquality and OZ type constraint, intersection
|
||||
% thom fruehwirth ECRC 1993,1995
|
||||
%
|
||||
%
|
||||
% 950519 added OZ type constraint, equalit ~ from tree.chr
|
||||
% 980211 Thom Fruehwirth LMU for Sicstus CHR
|
||||
|
||||
:- use_module( library(chr)).
|
||||
|
||||
handler oztype.
|
||||
|
||||
option(debug_compile,on).
|
||||
option(already_in_store, on).
|
||||
option(already_in_heads, off).
|
||||
option(check_guard_bindings, off).
|
||||
|
||||
constraints (~)/2, (':<')/2, ('&&')/2.
|
||||
|
||||
operator(100,xfx,(~)). % equality
|
||||
operator(100,xfx,(':<')). % type constraint of Oz
|
||||
operator(110,xfx,('&&')). % type intersection, precedence choosen so that
|
||||
|
||||
% need global order on variables
|
||||
:- use_module( library('chr/ordering'), [globalize/1,var_compare/3]).
|
||||
% var is smaller than any non-var term
|
||||
lt(X,Y):- (var(X),var(Y) -> globalize(X),globalize(Y),var_compare(<,X,Y) ; X@<Y).
|
||||
le(X,Y):- (var(X) -> true ; X@=<Y).
|
||||
|
||||
|
||||
% equality ~ -----------------------------------------------------------------
|
||||
% can be optimised using list of variables that are equated instead of
|
||||
% seperate constraints, i.e. [X1,...Xn] ~ Term, to avoid dereferencing
|
||||
|
||||
ident @ T ~ T <=> true.
|
||||
decompose @ T1 ~ T2 <=> nonvar(T1),nonvar(T2) |
|
||||
same_functor(T1,T2),
|
||||
T1=..[F|L1],T2=..[F|L2],
|
||||
equate(L1,L2).
|
||||
orient @ T ~ X <=> lt(X,T) | X ~ T.
|
||||
simplify @ X ~ T1 \ X ~ T2 <=> le(T1,T2) | T1 ~ T2.
|
||||
|
||||
same_functor(T1,T2):- functor(T1,F,N),functor(T2,F,N).
|
||||
|
||||
equate([],[]).
|
||||
equate([X|L1],[Y|L2]):- X ~ Y, equate(L1,L2).
|
||||
|
||||
|
||||
% type constraint :< ---------------------------------------------------------
|
||||
% similar to equality ~
|
||||
% plus standard axioms for order relation plus intersection &&
|
||||
% types are not cyclic
|
||||
|
||||
type_identity @ XT :< XT <=> true.
|
||||
type_decompose @ T1 :< T2 <=> nonvar(T1),nonvar(T2) |
|
||||
same_functor(T1,T2),
|
||||
T1=..[_|L1],T2=..[_|L2],
|
||||
contain(L1,L2).
|
||||
type_simplify1 @ X ~ T1 \ X :< T2 <=> var(X) | T1 :< T2.
|
||||
type_simplify2 @ X ~ T1 \ T2 :< X <=> var(X) | T2 :< T1.
|
||||
type_transitiv @ T1 :< Y, Y :< T2 ==> var(Y) | T1 :< T2.
|
||||
type_intersect @ X :< T1, X :< T2 <=> nonvar(T1),nonvar(T2) |
|
||||
same_functor(T1,T2),
|
||||
T1=..[F|L1],T2=..[F|L2],
|
||||
type_intersect(L1,L2,L3),
|
||||
T3=..[F|L3],
|
||||
X :< T3.
|
||||
|
||||
contain([],[]).
|
||||
contain([X|L1],[Y|L2]):-
|
||||
X :< Y,
|
||||
contain(L1,L2).
|
||||
|
||||
type_intersect([],[],[]).
|
||||
type_intersect([X|L1],[Y|L2],[Z|L3]):-
|
||||
Z~X&&Y, % was Z :< X, Z :< Y before
|
||||
type_intersect(L1,L2,L3).
|
||||
|
||||
% X~Y&&Z parses as (X~Y)&&Z, so it does not match X~T
|
||||
type_functional @ Z1~X&&Y \ Z2~X&&Y <=> Z1=Z2.
|
||||
type_functional @ Z1~Y&&X \ Z2~X&&Y <=> Z1=Z2.
|
||||
type_propagate @ Z~X&&Y ==> Z :< X, Z :< Y.
|
||||
|
||||
/*
|
||||
:- f(a,b):<f(X,X). % succeeds - X is a "top" ('a hole')
|
||||
a:<X,b:<X.
|
||||
:- Y~f(U),Z~f(X),X:<Y,X:<Z. % succeeds
|
||||
Y~f(U),Z~f(X),UX~X&&U,X:<f(UX),UX:<X,UX:<U,UX:<f(UX)
|
||||
:- Y~f(U),U~a,Z~f(X),X:<Y,X:<Z. % fails
|
||||
:- X:<Y,X~f(X),X:<f(Y).
|
||||
X~f(X), f(X):<Y % simplifies nicely
|
||||
:- X:<Y,Y~f(U),U~a,Z~f(X),X:<Z. % fails
|
||||
:- X~Y,U:<X,Z:<a,U:<Z,Y:<b. % fails
|
||||
:- X:<Y,X:<Z,Y~a,Z~b. % fails
|
||||
:- X:<Y,X:<Z,Y~f(Y,U),Z~f(Z,V),U~a,V~b. % fails, loops without type_functional
|
||||
:- X:<f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % succeeds
|
||||
:- X~ f(X,Y), X~f(X1,U), X1~f(X11,U1), U1~g(U), a:<U, b:<U. % fails
|
||||
*/
|
||||
|
||||
|
||||
% end of handler oztype =======================================================
|
|
@ -0,0 +1,52 @@
|
|||
% PATH CONSISTENCY, simple
|
||||
% thom fruehwirth ECRC 941201, simplified version of time-pc.chr
|
||||
% 980311 Thom Fruehwirth, LMU, adapted to Sicstus CHR
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
handler path.
|
||||
|
||||
option(already_in_heads,on).
|
||||
|
||||
constraints con/3.
|
||||
% con(X,Y,C) means that constraint C holds between variables X and Y
|
||||
|
||||
intersect_xy_xy @ con(X, Y, C1), con(X, Y, C2) <=>
|
||||
inter(C1, C2, C3),
|
||||
con(X,Y,C3).
|
||||
intersect_xy_yx @ con(X, Y, C1), con(Y, X, CR) <=>
|
||||
invert(CR, C2),
|
||||
inter(C1, C2, C3),
|
||||
con(X,Y,C3).
|
||||
|
||||
propagate_xy_yz @ con(X, Y, C1), con(Y, Z, C2) ==>
|
||||
trans(C1, C2, C3)
|
||||
|
|
||||
con(X, Z, C3).
|
||||
propagate_xy_xz @ con(X, Y, CR), con(X, Z, C2) ==>
|
||||
invert(CR,C1),
|
||||
trans(C1, C2, C3)
|
||||
|
|
||||
con(Y, Z, C3).
|
||||
propagate_xy_zy @ con(X, Y, C1), con(Z, Y, CR) ==>
|
||||
invert(CR,C2),
|
||||
trans(C1, C2, C3)
|
||||
|
|
||||
con(X, Z, C3).
|
||||
|
||||
|
||||
% Example ---------------------------------
|
||||
% constraints are < and >
|
||||
|
||||
invert(<,>).
|
||||
invert(>,<).
|
||||
|
||||
% fail if empty constraint would be produced
|
||||
inter(C,C,C).
|
||||
|
||||
% fail if most general constraint would be produced
|
||||
trans(C,C,C).
|
||||
|
||||
% ?- con(A,B,>),con(A,C,>),con(B,D,>),con(C,D,>).
|
||||
|
||||
/*--------------- eof path.pl ----------------------------------------------*/
|
|
@ -0,0 +1,38 @@
|
|||
% Thom Fruehwirth, LMU, 980129, 980311
|
||||
|
||||
:- use_module(library(chr)).
|
||||
|
||||
handler pathc.
|
||||
|
||||
option(already_in_heads,on).
|
||||
|
||||
constraints c/3.
|
||||
% c(X,Y,N): the distance between variables X and Y is the positive number N
|
||||
|
||||
c(I,J,A),c(I,J,B) <=> C is min(A,B), c(I,J,C).
|
||||
c(I,J,A),c(J,K,B) ==> C is A+B, c(I,K,C).
|
||||
|
||||
% Only complete if both c(I,J,D) and c(J,I,D) are present for each constraint
|
||||
|
||||
/*
|
||||
% Queries
|
||||
|
||||
c(A,B,D).
|
||||
|
||||
c(A,B,2),c(A,B,4).
|
||||
|
||||
c(A,B,2),c(B,C,3).
|
||||
|
||||
c(A,B,2),c(B,A,1).
|
||||
|
||||
c(A,B,2),c(B,A,0).
|
||||
|
||||
c(A,B,2),c(A,C,3),c(C,B,2).
|
||||
|
||||
c(A,B,2),c(A,C,3),c(C,B,4).
|
||||
|
||||
c(A,B,2),c(B,C,3),c(C,A,4).
|
||||
|
||||
c(A,B,2),c(B,C,3),c(C,A,4),c(B,A,2),c(C,B,3),c(A,C,4).
|
||||
|
||||
*/
|
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue