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