1/* BEGIN LICENSE BLOCK 2 * Version: CMPL 1.1 3 * 4 * The contents of this file are subject to the Cisco-style Mozilla Public 5 * License Version 1.1 (the "License"); you may not use this file except 6 * in compliance with the License. You may obtain a copy of the License 7 * at www.eclipse-clp.org/license. 8 * 9 * Software distributed under the License is distributed on an "AS IS" 10 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 11 * the License for the specific language governing rights and limitations 12 * under the License. 13 * 14 * The Original Code is The ECLiPSe Constraint Logic Programming System. 15 * The Initial Developer of the Original Code is Cisco Systems, Inc. 16 * Portions created by the Initial Developer are 17 * Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 18 * 19 * Contributor(s): 20 * 21 * END LICENSE BLOCK */ 22 23/* 24 * External predicate examples from the SEPIA user manual 25 */ 26 27 28#include "external.h" 29 30 31int 32p_succ_ints(value val1, type tag1, 33 value val2, type tag2) 34{ 35 36 Check_Integer(tag1); 37 Check_Integer(tag2); 38 39 Succeed_If(val1.nint + 1 == val2.nint); 40} 41 42 43int 44p_print_array(value va, type ta, 45 value vm, type tm) 46{ 47 int size = 1; /* number of array elements */ 48 pword *p; 49 uword *dim; 50 dident wdid; 51 int arity; 52 53 Error_If_Ref(ta); 54 if (IsAtom(ta)) /* a global variable */ 55 wdid = va.did; 56 else /* an array */ 57 { 58 Get_Functor_Did(va, ta, wdid); 59 Get_Visible_Array_Header(wdid, vm, tm, p); 60 if (!IsStructure(p->tag)) /* error if not prolog */ 61 { 62 Error(TYPE_ERROR); 63 } 64 dim = (uword *) p->val.ptr; 65 dim++; /* skip the did */ 66 for (arity = DidArity(wdid); arity; arity--) 67 size *= *dim++; /* compute the size */ 68 } 69 Get_Visible_Array_Address(wdid, vm, tm, p); 70 for (; size; size--, p++) 71 { 72 Write(p->val, p->tag, Current_Output); 73 Fprintf(Current_Output, " "); 74 } 75 Succeed; 76} 77 78 79int 80p_sincos(value val_arg, type tag_arg, 81 value val_sin, type tag_sin, 82 value val_cos, type tag_cos) 83{ 84 extern void sincos(); /* from the math library */ 85 double s, c; 86 Prepare_Requests; 87 88 Error_If_Ref(tag_arg); 89 Check_Output_Float(tag_sin); 90 Check_Output_Float(tag_cos); 91 92 if (IsDouble(tag_arg)) 93 sincos(Dbl(val_arg), &s, &c); 94 else if (IsInteger(tag_arg)) 95 sincos((double) val_arg.nint, &s, &c); 96 else 97 { 98 Error(TYPE_ERROR); 99 } 100 Request_Unify_Float(val_sin, tag_sin, s); 101 Request_Unify_Float(val_cos, tag_cos, c); 102 Return_Unify; 103} 104 105 106int 107p_transform(value val1, type tag1, 108 value val2, type tag2) 109{ 110 pword *p = Gbl_Tg; 111 dident did1; /* the DID of the structure */ 112 int arity; /* its arity */ 113 int i; 114 115 /* the first argument must be a structure */ 116 Check_Structure(tag1); 117 /* the second argument must be a structure or a variable */ 118 Check_Output_Structure(tag2); 119 /* val1 points to the functor */ 120 did1 = val1.ptr->val.did; 121 arity = DidArity(did1); 122 /* reserve space for the functor and (arity + 1) args */ 123 Gbl_Tg += arity + 2; 124 /* insert the functor - the same name and higher arity */ 125 p[0].tag.kernel = TDICT; 126 p[0].val.did = Did(DidName(did1), arity + 1); 127 /* copy the arguments */ 128 for (i = 1; i <= arity; i++) 129 { 130 p[i].tag.all = val1.ptr[i].tag.all; 131 p[i].val.all = val1.ptr[i].val.all; 132 /* on some machines use p[i] = val1.ptr[i] */ 133 } 134 /* now create the free variable in the last argument; 135 * it is a self-reference 136 */ 137 p[arity + 1].tag.kernel = TREF; 138 p[arity + 1].val.ptr = p + (arity + 1); 139 /* and unify with the second argument */ 140 Return_Unify_Structure(val2, tag2, p); 141} 142 143 144int 145p_get_env(value v0, type t0, 146 value v1, type t1) 147{ 148 extern char *getenv(); 149 char *name; 150 value v; 151 152 Get_Name(v0,t0,name) 153 name = getenv(name); 154 if(name == (char *) 0) 155 { 156 Fail; 157 } 158 Cstring_To_Prolog(name, v); 159 Return_Unify_String(v1, t1, v.ptr) 160} 161 162 163int 164p_member(value velt, type telt, 165 value vlist, type tlist) 166{ 167 pword *p; 168 169 /* we require a list or nil */ 170 Check_List(tlist); 171 /* if the list is empty, we fail */ 172 if(IsNil(tlist)) 173 { 174 Fail; 175 } 176 /* the tail of the list */ 177 p = vlist.ptr + 1; 178 /* must be dereferenced! */ 179 Dereference(p); 180 /* 181 * on backtracking we will get the tail of the list 182 * instead of the list itself 183 */ 184 Remember(2, p->val, p->tag); 185 /* 186 * and we behave as the unification 187 * of the element and the head 188 */ 189 Return_Unify_Pw(velt, telt, 190 vlist.ptr->val, vlist.ptr->tag); 191} 192 193 194int 195p_p2(value v1, type t1, value v2, type t2) 196{ 197 char *result; 198 value new_v2; 199 type new_t2; 200 201 /* first check the arguments */ 202 Check_Integer(t2); 203 Check_Output_Atom(t1); 204 /* take note of new resatisfaction */ 205 new_v2.nint = v2.nint + 1; 206 new_t2.kernel = TINT; 207 Remember(2, new_v2, new_t2); 208 /* get the string that corresponds to the value of v2 */ 209 switch(v2.nint) 210 { 211 case 1: 212 result = "a"; 213 break; 214 case 2: 215 result = "b"; 216 break; 217 case 3: 218 result = "c"; 219 break; 220 default: 221 Fail; 222 } 223 Return_Unify_Atom(v1, t1, Did(result, 0)); 224} 225 226 227int 228p_diff_vars(value v1, type t1, value v2, type t2) 229{ 230 if (IsRef(t1) && IsRef(t2) && v1.ptr != v2.ptr) 231 { 232 Mark_Suspending_Variable(v1.ptr); 233 Mark_Suspending_Variable(v2.ptr); 234 Succeed; 235 } 236 else 237 Fail; 238} 239 240 241int 242p_atomd(value v1, type t1) 243{ 244 if (IsRef(t1)) 245 { 246 Mark_Suspending_Variable(v1.ptr); 247 Delay; 248 } 249 else 250 Succeed_If(IsAtom(t1)); 251} 252 253