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

This commit was generated by cvs2svn to compensate for changes in r4,

Browse Source 
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:
vsc 2001-04-09 19:54:03 +00:00
parent 9a8ee05f1f
commit e5f4633c39
457 changed files with 189536 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10045
C/absmi.c Normal file
View File

File diff suppressed because it is too large Load Diff

555
C/adtdefs.c Normal file
View File

@ -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

935
C/alloc.c Normal file
View File

@ -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 */
}

2516
C/amasm.c Normal file
View File

File diff suppressed because it is too large Load Diff

823
C/analyst.c Normal file
View File

@ -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 */

227
C/arith0.c Normal file
View File

@ -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);
}

2046
C/arith1.c Normal file
View File

File diff suppressed because it is too large Load Diff

1753
C/arith2.c Normal file
View File

File diff suppressed because it is too large Load Diff

1525
C/arithi2.c Normal file
View File

File diff suppressed because it is too large Load Diff

1562
C/arrays.c Normal file
View File

File diff suppressed because it is too large Load Diff

552
C/attvar.c Normal file
View File

@ -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 */

352
C/bb.c Normal file
View File

@ -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);
}

216
C/bignum.c Normal file
View File

@ -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);
}

744
C/c_interface.c Normal file
View File

@ -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
}

2191
C/cdmgr.c Normal file
View File

File diff suppressed because it is too large Load Diff

1142
C/cmppreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

2624
C/compiler.c Normal file
View File

File diff suppressed because it is too large Load Diff

652
C/computils.c Normal file
View File

@ -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 */

1176
C/corout.c Normal file
View File

File diff suppressed because it is too large Load Diff

4207
C/dbase.c Normal file
View File

File diff suppressed because it is too large Load Diff

60
C/depth_bound.c Normal file
View File

@ -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

1814
C/errors.c Normal file
View File

File diff suppressed because it is too large Load Diff

145
C/eval.c Normal file
View File

@ -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);
}

233
C/evalis.c Normal file
View File

@ -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)));
}
}

301
C/evaltwo.c Normal file
View File

@ -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)));
}
}

1267
C/exec.c Normal file
View File

File diff suppressed because it is too large Load Diff

949
C/grow.c Normal file
View File

@ -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();
}

2388
C/heapgc.c Normal file
View File

File diff suppressed because it is too large Load Diff

1420
C/index.c Normal file
View File

File diff suppressed because it is too large Load Diff

1143
C/init.c Normal file
View File

File diff suppressed because it is too large Load Diff

4175
C/iopreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

81
C/load_aix.c Normal file
View File

@ -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 */

259
C/load_aout.c Normal file
View File

@ -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

309
C/load_coff.c Normal file
View File

@ -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 *) &sectionHeader[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 *) &sectionHeader[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

159
C/load_dl.c Normal file
View File

@ -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

103
C/load_dld.c Normal file
View File

@ -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

104
C/load_dll.c Normal file
View File

@ -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

143
C/load_foreign.c Normal file
View File

@ -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;
}

57
C/load_none.c Normal file
View File

@ -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

145
C/load_shl.c Normal file
View File

@ -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

276
C/mavar.c Normal file
View File

@ -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
}

96
C/modules.c Normal file
View File

@ -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);
}

52
C/other.c Normal file
View File

@ -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));
}

580
C/parser.c Normal file
View File

@ -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);
}

2907
C/save.c Normal file
View File

File diff suppressed because it is too large Load Diff

1348
C/scanner.c Normal file
View File

File diff suppressed because it is too large Load Diff

421
C/sort.c Normal file
View File

@ -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);
}

2247
C/stdpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

2021
C/sysbits.c Normal file
View File

File diff suppressed because it is too large Load Diff

236
C/tracer.c Normal file
View File

@ -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

1744
C/unify.c Normal file
View File

File diff suppressed because it is too large Load Diff

352
C/unifyi.c Normal file
View File

@ -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 = &REGS;
#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 = &REGS;
#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
}

734
C/userpreds.c Normal file
View File

@ -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)
{
}

1561
C/utilpreds.c Normal file
View File

File diff suppressed because it is too large Load Diff

654
C/write.c Normal file
View File

@ -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);
}

1130
C/ypsocks.c Normal file
View File

File diff suppressed because it is too large Load Diff

307
C/ypstdio.c Normal file
View File

@ -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 */

208
CHR/CHR.LICENSE Normal file
View File

@ -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.
========================================================================
=======================================================================

893
CHR/chr.pl Normal file
View File

@ -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.

907
CHR/chr.yap Normal file
View 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.

1495
CHR/chr/chrcmp.pl Normal file
View File

File diff suppressed because it is too large Load Diff

29
CHR/chr/compenv.pl Normal file
View File

@ -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)).

26
CHR/chr/concat.pl Normal file
View File

@ -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).

411
CHR/chr/examples/allentable.pl Normal file
View File

@ -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).

86
CHR/chr/examples/arc.pl Normal file
View File

@ -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 -------------------------------------

282
CHR/chr/examples/bool.pl Normal file
View File

@ -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 */

141
CHR/chr/examples/cft.pl Normal file
View File

@ -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 ----------------------------------------------------------

472
CHR/chr/examples/domain.pl Normal file
View File

@ -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 =================================================
% ===========================================================================

235
CHR/chr/examples/examples-adder.bool Normal file
View File

@ -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.
*/

1439
CHR/chr/examples/examples-benchmark.math Normal file
View File

File diff suppressed because it is too large Load Diff

115
CHR/chr/examples/examples-deussen.bool Normal file
View File

@ -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
]).

444
CHR/chr/examples/examples-diaz.bool Normal file
View File

@ -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 ---

63
CHR/chr/examples/examples-fourier.math Normal file
View File

@ -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.
*/

145
CHR/chr/examples/examples-holzbaur.math Normal file
View File

@ -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
%=============================================================================

374
CHR/chr/examples/examples-lim1.math Normal file
View File

@ -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.

448
CHR/chr/examples/examples-lim2.math Normal file
View File

@ -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
% ===========================================================================

80
CHR/chr/examples/examples-lim3.math Normal file
View File

@ -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", []).
%=============================================================================

150
CHR/chr/examples/examples-puzzle.bool Normal file
View File

@ -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 ) :- ! .
*/

101
CHR/chr/examples/examples-queens.bool Normal file
View File

@ -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
===================================================
*/

16
CHR/chr/examples/examples-queens.domain Normal file
View File

@ -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.

52
CHR/chr/examples/examples-stuckey.math Normal file
View File

@ -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, >=)
*/

619
CHR/chr/examples/examples-thom.math Normal file
View File

@ -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 ============================================

22
CHR/chr/examples/gcd.pl Normal file
View File

@ -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).
*/

242
CHR/chr/examples/interval.pl Normal file
View File

@ -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 ===================================================

274
CHR/chr/examples/kl-one.pl Normal file
View File

@ -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 ========================================================

48
CHR/chr/examples/leq.pl Normal file
View File

@ -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 -----------------------------------------------

362
CHR/chr/examples/list.pl Normal file
View File

@ -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

123
CHR/chr/examples/listdom.pl Normal file
View File

@ -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 =================================================
% ===========================================================================

136
CHR/chr/examples/math-elim.pl Normal file
View File

@ -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 -----------------------------------------------*/

209
CHR/chr/examples/math-fougau.pl Normal file
View File

@ -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 ----------------------------------------------*/

64
CHR/chr/examples/math-fourier.pl Normal file
View File

@ -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.
*/

55
CHR/chr/examples/math-gauss.pl Normal file
View File

@ -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 ------------------------------------------------*/

300
CHR/chr/examples/math-utilities.pl Normal file
View File

@ -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 -----------------------------------------------

127
CHR/chr/examples/minmax.pl Normal file
View File

@ -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

36
CHR/chr/examples/modelgenerator.pl Normal file
View File

@ -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) ?
*/

340
CHR/chr/examples/monkey.pl Normal file
View File

@ -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.

124
CHR/chr/examples/osf.pl Normal file
View 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 ----------------------------------------------------------

100
CHR/chr/examples/oztype.pl Normal file
View File

@ -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 =======================================================

52
CHR/chr/examples/path.pl Normal file
View File

@ -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 ----------------------------------------------*/

38
CHR/chr/examples/pathc.pl Normal file
View File

@ -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