new paralell rich pzip and pand now works

parent 16846cd4
......@@ -11,48 +11,59 @@
(() <fail>)
((x) (goal-eval x))
((fail x y)
(<pand> (</.> (goal-eval fail))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y))))
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y)))
(fail- (</.> (goal-eval fail)))))
((fail x y u)
(<pand> (</.> (goal-eval fail))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100) (goal-eval u))))
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u)))
(fail- (</.> (goal-eval fail)))))
((fail x y u v)
(<pand> (</.> (goal-eval fail))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100) (goal-eval u))
(p4 l4 s4 (gp-make-engine (+ next-level 1) 100) (goal-eval v))))
(let ((fail- #f))
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u))
(p4 l4 s4 (gp-make-engine (+ n 1) 100) (goal-eval v)))
(fail- (</.> (goal-eval fail)))))
((fail . l)
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(let ((fail- #f)
(l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand> (</.> (goal-eval fail))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100)
(<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (car l-u)))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100)
(<apply> paralell fail (cdr l-u))))))))
(p3 l3 s3 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (cdr l-u))))
(fail- (</.> (goal-eval fail)))))))
(define (fail x) x)
(define (fail- x) x)
(define pzip
(<case-lambda>
(() <fail>)
((x) (goal-eval x))
((x y)
(<pzip> fail
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))))
((x y u)
(<pzip> fail
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u))))
((x y u v)
(<pzip> fail
(<pzip> fail-
(p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u))
......@@ -62,7 +73,7 @@
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pzip> fail
(<pzip> fail-
(p2 l2 s2 q2 (<apply> pzip (car l-u)))
(p3 l3 s3 q3 (<apply> pzip (cdr l-u))))))))
......@@ -14,7 +14,8 @@
#:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if>
functorize adaptable_vars
<with-guile-log> <if-some>
<cc> <fail> <let> <let*> <var> <modvar> <hvar> </.> <when>
<cc> <fail> <let> <let*> <var> <nvar>
<modvar> <hvar> </.> <when>
<define> <define*> <cut> <pp> <pp-dyn> <dyn> <unify>
<recur> <letrec>
<lambda> <case-lambda> <with-fail> <with-cut> <with-s>
......@@ -484,6 +485,16 @@
(fl-let (cut s p cc)
(parse<> (cut s p cc) (<and> code ...))))))))
(define gp-make-nvar (@@ (logic guile-log code-load) gp-make-nvar))
(define-guile-log <nvar>
(syntax-rules ()
((_ (cut s p cc) n (v ...) code ...)
(let ((nn n))
(let ((v (gp-make-nvar n)) ...)
(fl-let (cut s p cc)
(parse<> (cut s p cc) (<and> code ...))))))))
(define-guile-log <modvar>
(syntax-rules ()
((_ (cut s p cc) (v ...) code ...)
......@@ -1160,7 +1171,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(lambda () #f)
undo
s)
(cc p s)))))
(cc s p)))))
#;(log-code-macro '<dynwind>)
;; This is code that allow to store a state
......
......@@ -29,8 +29,8 @@
(define level 0)
(define next-level 0)
(<define-guile-log-rule> (<pand> check (v l se engine code ...) ...)
(<var> (v ...)
(<define-guile-log-rule> (<pand> n check (v l se engine code ...) ...)
(<nvar> (+ next-level 1) (v ...)
(let ((i level) (n next-level) (l level) ...)
(<dynwind>
(lambda x #f)
......@@ -45,9 +45,7 @@
(let* ((s frame)
(ccc (lambda (ss pp)
(gp-combine-engines data)
(cc (gp-combine-state
s (list se ...))
p))))
(cc s p))))
(<with-s> s
(<pit> s p ccc
(<with-fail> p
......@@ -62,7 +60,9 @@
(<code>
(set! level (+ 1 n))
(set! next-level (+ 1 n)))
code ...
(<dynwind>
(lambda x (set! l next-level))
(lambda x (set! next-level l)))
......@@ -82,14 +82,17 @@
(set! next-level (max l ...))
(set! level i))
(<code> (gp-combine-engines data))
(<code>
(set! check
(<lambda> (fail-)
(let ((s.bindings (gp-combine-state s (list se ...))))
(check-bindings check (cdr s.bindings))
(<with-s> (car s.bindings)
(<with-fail> p <cc>))))))))
(check-bindings fail- (cdr s.bindings))
(<with-s> (car s.bindings))))))
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> check (v ll se p code ...) ...)
(<var> (p ...)
(<nvar> (+ next-level 1) (p ...)
(<letrec> ((l '())
(pwork
(lambda (q)
......@@ -98,6 +101,7 @@
(set! l (cdr l))
(pp))
(q))))
(pand-check #f)
(ccwork
(lambda (s pp cc)
(pwork (lambda () (cc s pp)))))
......@@ -105,10 +109,14 @@
(lambda ()
(set! l (list (<lookup> p) ...))
(pwork #f))))
(<pand> (check pend)
(v ll se (gp-make-engine (+ next-level 1) 100)
code ... (<set> p P)) ...)
((</.>
(<pand> n pand-check
(v ll se (gp-make-engine (+ n 1) 100)
code ... (<set> p P)) ...)))
(ccwork)
(pand-check (check (</.> (<ret> (pend)))))
(<with-fail> pend <cc>))))
......
......@@ -1508,6 +1508,8 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
SCM s_stack = SCM_CAR(gp_engine_path);
//printf("pop\n");
//format1("shall pop store_path: ~a~%",gp_store_path);
if(SCM_CONSP(gp_store_path))
gp_store_path = SCM_CDR(gp_store_path);
else
......@@ -1559,6 +1561,7 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
struct gp_stack *gp = get_gp();
//printf("push\n");
int logical = gp->_logical_;
SCM rguards = gp->rguards;
......@@ -1646,6 +1649,8 @@ SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM paths),
SCM e = SCM_CDR(SCM_CAR(SCM_CAR(paths)));
SCM pathout = gp_paths;
//printf("set\n");
if(SCM_CONSP(paths))
{
gp_engine_path = SCM_CAR(paths);
......@@ -1683,6 +1688,7 @@ SCM_DEFINE(gp_combine_pop, "gp-combine-pop", 0, 0, 0, (),
#define FUNC_NAME s_gp_combine_pop
{
//printf("combine pop\n");
SCM ret = SCM_CAR(gp_store_path);
gp_store_path = SCM_CDR(gp_store_path);
return ret;
......@@ -1696,12 +1702,18 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r),
{
gp_store_path = scm_cons(r, gp_store_path);
//printf("combine push\n");
//format1("pushed store_path: ~a~%",gp_store_path);
if(SCM_CONSP(gp_paths))
SCM_SETCDR(gp_paths, gp_store_path);
else
scm_misc_error("gp-combine-push","gp_paths not a cons ~a~%",
scm_list_1(gp_paths));
//format1("pushed store_path: ~a~%",gp_store_path);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -1712,13 +1724,14 @@ SCM all_variable_bindings = SCM_BOOL_F;
SCM folder(SCM key, SCM val, SCM seed, SCM data)
{
//printf("folder\n");fflush(stdout);
//format2("key, val : ~a, ~a ~%",key,val);
int level = scm_to_int(SCM_CDR(data));
if(GP_ID(key) > level)
return seed;
SCM val2 = scm_hash_ref(key, variable_bindings, SCM_BOOL_F);
SCM val2 = scm_hashq_ref(variable_bindings, key, SCM_BOOL_F);
if(scm_is_true(val2))
{
......@@ -1726,24 +1739,30 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
}
else
{
SCM val3 = scm_hash_ref(key, all_variable_bindings, SCM_BOOL_F);
//printf("new\n");
scm_hashq_set_x(variable_bindings, key, SCM_BOOL_T);
SCM val3 = scm_hashq_ref(all_variable_bindings, key, SCM_BOOL_F);
if(scm_is_true(val3))
{
SCM val4 = scm_hash_ref(key, variable_bindings_found, SCM_BOOL_F);
//printf("registred\n");
SCM val4 = scm_hashq_ref(variable_bindings_found, key, SCM_BOOL_F);
if(scm_is_true(val4))
{
//printf("fat\n");
return scm_cons(scm_cons(key,val),seed);
}
else
{
scm_hash_set_x(key, SCM_BOOL_T, variable_bindings_found);
//printf("thin\n");
scm_hashq_set_x(variable_bindings_found, key, SCM_BOOL_T);
return scm_cons(scm_cons(key,val),
scm_cons(scm_cons(key, val3), seed));
}
}
else
{
scm_hash_set_x(key, val, all_variable_bindings);
//printf("not registred\n");
scm_hashq_set_x(all_variable_bindings, key, val);
return seed;
}
}
......@@ -1752,6 +1771,8 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
SCM level1(SCM data, SCM ll, SCM ret);
SCM level0(SCM data, SCM l, SCM ret)
{
//printf("level0\n");fflush(stdout);
for(;SCM_CONSP(l);l = SCM_CDR(l))
{
ret = level1(data,SCM_CAR(l),ret);
......@@ -1763,6 +1784,9 @@ SCM level0(SCM data, SCM l, SCM ret)
SCM level1(SCM data, SCM ll, SCM ret)
{
SCM l0 = SCM_CAR(data);
//printf("level1\n");fflush(stdout);
for(;SCM_CONSP(ll);ll=SCM_CDR(ll))
{
if(scm_is_eq(ll, l0))
......@@ -1770,14 +1794,24 @@ SCM level1(SCM data, SCM ll, SCM ret)
{
SCM x = SCM_CAR(ll);
if(scm_vlist_p(x))
if(scm_is_true(scm_vlist_p(x)))
{
//printf("vlist\n");fflush(stdout);
//format1("vlist : ~a~%", x);
ret = vhash_fold_all_exp(data, folder, ret, x);
}
if(SCM_I_IS_VECTOR(x))
{
//printf("vector\n");fflush(stdout);
ret = level0(data, scm_c_vector_ref(ret, 0), ret);
}
if(SCM_CONSP(x))
{
//printf("cons\n");fflush(stdout);
ret = folder(SCM_CAR(x), SCM_CDR(x), ret, data);
}
}
}
return ret;
}
......@@ -1788,6 +1822,8 @@ SCM get_all_conflicting_bindings(SCM l, SCM data)
variable_bindings_found = scm_c_make_hash_table(100);
all_variable_bindings = scm_c_make_hash_table(100);
//printf("conflict\n");fflush(stdout);
SCM ret = SCM_EOL;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
......@@ -1805,6 +1841,8 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
SCM data = gp_gp_cdr(s,s);
SCM l0 = SCM_CAR(data);
//printf("combine state\n");fflush(stdout);
struct gp_stack * gp = get_gp();
SCM ll = SCM_EOL;
......
......@@ -987,11 +987,15 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
}
else
{
path = gp_engine_path;
path = gp_engine_path,
spath = gp_store_path;
}
}
else
{
path = gp_engine_path;
spath = gp_store_path;
}
if(SCM_CONSP(path))
{
......
......@@ -262,8 +262,8 @@ scm_t_bits gp_smob_t;
#define GP_UNREF(x) ((SCM) (x))
#define N_BITS 26
#define H_BITS 36
#define N_BITS 27
#define H_BITS 37
#define GP_ATTR_IT(x) ((x) = ((x) | GPI_ATTR))
......@@ -517,7 +517,7 @@ inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k,
if(!bang && gp->_logical_) return logical_add2(GP_UNREF(id),v,l);
if(!bang && GP_ID(*id) != gp->id && gp->_thread_safe_)
if(!bang && GP_ID(*id) < gp->id && gp->_thread_safe_)
{
gp_debug0("logical add\n");
return logical_add2(GP_UNREF(id),v,l);
......@@ -543,7 +543,7 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g
if(gp->_logical_) return logical_add2_l(GP_UNREF(id),v,l);
if(GP_ID(*id) != gp->id && gp->_thread_safe_)
if(GP_ID(*id) < gp->id && gp->_thread_safe_)
{
gp_debug0("logical add\n");
return logical_add2_l(GP_UNREF(id),v,l);
......@@ -3588,6 +3588,14 @@ SCM_DEFINE(gp_soft_init, "gp-module-init", 0, 0, 0, (),
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_nvariable, "gp-make-nvar", 1, 0, 0, (SCM id),
"makes a gp n variable")
#define FUNC_NAME gp_make_nvariable
{
return gp_make_variable_id(scm_to_int(id));
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (),
"makes a gp fluid variable")
#define FUNC_NAME s_gp_make_fluid
......
......@@ -119,6 +119,8 @@ SCM_API SCM gp_gp_store_state(SCM s);
SCM_API SCM gp_gp_restore_state(SCM cont, SCM K);
SCM_API SCM gp_make_fluid();
SCM_API SCM gp_make_nvariable(SCM id);
SCM_API SCM gp_fluid_set_bang(SCM f, SCM v, SCM s);
SCM_API SCM gp_dynwind(SCM in, SCM out, SCM s);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment