now everything works

parent 3f7ca6e8
......@@ -6,6 +6,7 @@
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system repl repl)
#:use-module (syntax parse)
#:re-export (gp-cons! gp-lookup gp-var! gp->scm gp-unify! gp-unify-raw! gp-m-unify!)
#:export (umatch))
......
......@@ -199,6 +199,26 @@ and-interleave
...)
(parse<> meta (<and> code ...)))))))))
(define-syntax letg
(lambda (x)
(syntax-case x ()
((_ ((s v) ...) code ...)
(with-syntax (((g ...) (generate-temporaries #'(s ...)))
((ss ...) (generate-temporaries #'(s ...))))
#'(letg-aux (g ...) (ss ...) (v ...)
(let-syntax ((s (make-variable-transformer
(lambda (x)
(syntax-case x (set!)
((set! _ w)
#'(g w))
((_ a (... ...))
#'(ss a (... ...)))
(var
(identifier? #'var)
#'ss)))))
...)
code ...)))))))
(define-syntax letg-aux
(syntax-rules ()
......@@ -228,3 +248,80 @@ and-interleave
(var
(identifier? #'var)
#'ss)))))))))))
(define-syntax-rule (cont-set! g p)
(let ((cont #f))
(set! g (lambda () (cont)))
(set! cont (let ((s (gp-store-state)))
(lambda ()
(gp-restore-wind s)
(p))))))
(define-syntax-rule (cont2-set! g p)
(let ((cont #f))
(set! g (lambda (s p cc) (cont)))
(set! cont (let ((s (gp-store-state)))
(lambda ()
(gp-restore-wind s)
(p))))))
(define-syntax-class vars
(pattern (aa:id a:id ...)
#:with (s ...) #'(aa a ...)
#:with id (datum->syntax #'aa (gensym "id")))
(pattern b:id
#:with (s ...) #'(b)
#:with id (datum->syntax #'b (gensym "id"))))
(define-guile-log <zip>
(lambda (x)
(syntax-parse x
((_ (cut s p cc) (v:vars code ...) (vs:vars codes ...) ...)
(with-syntax ((((vvs ...) ...) (map generate-temporaries
#'((vs.s ...) ...)))
((vv ...) (generate-temporaries #'(v.s ...)))
((gs ...) (generate-temporaries #'(vs.id ...)))
((ggs ...) (generate-temporaries #'(vs.id ...))))
#'(let ((g (</.> code ...)) (gs (</.> codes ...)) ...)
(use-logical)
(letg ((gg #f) (ggs gs) ...(vv #f) ... (vvs #f) ... ...)
(let ((fr (gp-newframe s)))
(g s p
(lambda (ss pp)
(cont-set! gg pp)
(set! vv (pk (gp->scm v.s ss))) ...
(gp-unwind fr)
(zip-aux (s p fr) ((vvs ...) ...) ((vs.s ...) ...)
(ggs ...)
(begin
(leave-logical)
(<with-guile-log> (s gg cc)
(<and> (<=> v.s vv ) ...
(<=> vs.s vvs) ...
...))))))))))))))
(define-syntax zip-aux
(syntax-rules ()
((_ (s p fr) ((vv ...) . vvs) ((v ...) . vs) (g . gs) code)
(g s p
(lambda (ss pp)
(cont2-set! g pp)
(set! vv (gp->scm v ss)) ...
(gp-unwind fr)
(zip-aux (s p fr) vvs vs gs code))))
((_ _ () () () code)
code)))
......@@ -11,13 +11,15 @@
let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq*)
<letg> <set!> define-guarded *gp-var-tr* *kanren-assq* <scm> <zip>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
(define-syntax S (lambda (x) #'#f))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define *cc* (gp-make-fluid))
(gp-fluid-set! *cc* #f)
(define *cc* (gp-make-fluid #f))
(define (<stall> s p cc)
(set! *cc* (cons s (cons p cc)))
......@@ -125,7 +127,7 @@
(lambda (s p)
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))) s)
r)
......@@ -134,7 +136,7 @@
(cons (tr (gp->scm v s) s) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p))) s)
r)
......@@ -156,7 +158,7 @@
(lambda (s p)
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p)))
s)
......@@ -166,7 +168,7 @@
(cons (tr (list (gp->scm v s) ...) s) ret))
(if (= n 0)
(let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm)
(gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '())
(p)))
s)
......@@ -288,7 +290,8 @@
(define-syntax <%fkn%>
(syntax-rules ()
((_ (cut s pr cc) f a ...)
(f s pr cc a ... ))))
(fluid-let-syntax ((S (lambda (x) #'s)))
(f s pr cc a ... )))))
(define-guile-log <with-fail>
(syntax-rules ()
......@@ -388,10 +391,11 @@
(define-guile-log <when>
(syntax-rules ()
((_ wc p code ...)
(if p
(parse<> wc (<and> code ...))
(parse<> wc <fail>)))))
((_ (cut s p cc) pred code ...)
(fluid-let-syntax ((S (lambda (x) #'s)))
(if pred
(parse<> (cut s p cc) (<and> code ...))
(parse<> (cut s p cc) <fail>))))))
(define (pp x)
(pretty-print x)
......@@ -423,15 +427,17 @@
(define-guile-log <tail-code>
(syntax-rules ()
((_ (_ s p cc) (ss pp ccc) code ...)
(fluid-let-syntax ((S (lambda (x) #'s)))
(let ((ss s)
(pp p)
(ccc cc))
code ...))))
code ...)))))
(define-guile-log <code>
(syntax-rules ()
((_ wc code ...)
(begin code ... (parse<> wc <cc>)))))
((_ (cut s p cc) code ...)
(fluid-let-syntax ((S (lambda (x) #'s)))
(begin code ... (parse<> (cut s p cc) <cc>))))))
(log-code-macro '<code>)
(define-guile-log <return>
......@@ -806,3 +812,5 @@
(gp-clear))
(log-code-macro '<fail>)
(define-module (logic guile-log racklog)
#:use-module (logic guile-log)
#:export (%true %fail
%=:= %< %> %<= %>= %=/=
%which %rel %more
%assert! %assert-after! %empty-rel
%let %is %constat %compound
%= use-occur-check? %and %or
%== %/== %var %nonvar
%freeze %melt %melt-new %copy !
%if-then-else %not))
(define use-occur-check? (make-fluid #f))
(define %true (</.> <cc> ))
(define %fail (</.> <fail>))
(define-syntax mk-op
(syntax-rules ()
((_ name op 1)
(define (name x)
(</.> (<when> (op (gp-lookup x))))))
((_ name op 2)
(define (name x y)
(</.> (<when> (op (gp-lookup x) (gp-lookup y))))))))
(define (neq x q) (not (= x y)))
(mk-op %=:= = 2)
(mk-op %< < 2)
(mk-op %> > 2)
(mk-op %<= <= 2)
(mk-op %>= >= 2)
(mk-op %=/= neq 2)
(define-syntax e
(syntax-rules ()
((_ x) x)))
(define-syntax %let
(lambda (x)
(syntax-case x ()
((_ (v ...) code ...)
(with-syntax (((vv ...) (generate-temporaries #'(v ...))))
#'(let ((vv (gp-var!)) ...)
(let-syntax ((v (syntax-rules ()
((_ x ...)
((e vv) x ...))
(_
(e vv))))
,,,)
code ...)))))))
(define-syntax state (lambda (x) #'#f))
(define-syntax E
(syntax-rules ()
((_ code)
(fluid-let-syntax ((e (syntax-rules ()
((_ x) (gp-loopup state x)))))
code))))
(define-syntax S
(syntax-rules ()
((_ code)
(fluid-let-syntax ((e (syntax-rules ()
((_ x) x))))
code))))
(define-syntax %which
(syntax-rules ()
((_ () code ...)
(<ask> (code) ...))
((_ (a ...) (code) ...)
(<run> 1 (a ...) (code) ...))
((_ n (a b ...) (code) ...)
(<run> n (a b ...) (code) ...))))
(define (%more) (<take> 1))
(define-syntax %rel
(syntax-rules ()
((_ (v ...) ((m ...) code ...) ...)
(lambda x
(%let (v ...)
(</.>
(<match> (x)
(,`(,m ...)
(<and> (code) ...))
...)))))))
(define-syntax %assert!
(syntax-rules ()
((_ name (a ...) clause ...)
(set! name
(let ((f name))
(%rel (a ...)
(w (apply f w))
clause ...))))))
(define-syntax %asssert-after!
(syntax-rules ()
((_ name (a ...) clause ...)
(set! name
(let ((f name))
(%rel (a ...)
clause ...
(w (apply f w))))))))
(define %empty-rel (lambda x %fail))
(define (%constant x)
(</.> (if (not (or (gp-var? x) (gp-pair? x))) <cc>)))
(define (%compound x)
(</.> (if (or (gp-var? x) (gp-pair? x)) <cc>)))
(define (%= x y)
(</.> (if (fluid-ref use-occures-check?)
(<unify> gp-unify! x y)
(<unify> gp-unify-raw! x y))))
(define (%and . l)
(</.>
(<recur> loop ((l l))
(if (pair? l)
(<and> ((car l)) (loop (cdr l)))
<cc>))))
(define (%or . l)
(</.>
(<recure> loop ((l l))
(if (pair? l)
(<or> ((car l)) (loop (cdr l)))
<fail>))))
(define (%== x y)
(</.> (<unify> gp-m-unify! x y)))
(define (%/== x y)
(</.> (<not> (<unify> gp-m-unify! x y))))
(define (%var x)
(</.>
(<recur> loop ((x x))
(<match> (#:mode -) (x)
((x . l)
(<or> (loop x) (loop l)))
((? gp-var?) <cc>)
(_ <fail>)))))
(define (%nonvar x)
(</.>
(<recur> loop ((x x))
(<match> (#:mode -) (x)
((x . l)
(<and> (loop x) (loop l)))
((? gp-var?) <fail>)
(_ <cc>)))))
(define-syntax %is
(syntax-rules ()
((_ x y)
(lambda (s p cc)
(fluid-let-syntax ((state (lambda (x) #'s)))
(<unify> gp-unify! (S x) (E y) s))))))
(define (freeze x)
(let loop ((x x))
(umatch (#:mode -) (x)
((? gp-var? x)
(vector 'freeze x))
((x . l)
(cons (loop x) (loop l)))
(x x))))
(define (%freeze s f)
(%= (freeze s) f))
(define (melt x)
(let loop ((x x))
(umatch (#:mode -) (x)
((x . l) (cons (loop x) (loop l)))
(#('freeze x) (gp-lookup x))
(x (gp-lookup x)))))
(define (melt-new x)
(define hash (make-hash-table))
(let loop ((x x))
(umatch (#:mode -) (x)
((x . l) (cons (loop x) (loop l)))
(#('freeze x)
(let* ((x (gp-lookup x)))
(if (gp-var? x)
(let ((v (hasq-ref hash x)))
(if v
v
(let ((u (gp-var!)))
(hasq-set! hash v u)
u)))
x)))
(x (gp-lookup x)))))
(define (copy x)
(define hash (make-hash-table))
(define (update x)
(let* ((x (gp-lookup x)))
(if (gp-var? x)
(let ((v (hasq-ref hash x)))
(if v
v
(let ((u (gp-var!)))
(hasq-set! hash v u)
u))))))
(let loop ((x x))
(umatch (#:mode -) (x)
((x . l)
(cons (loop x) (loop l)))
(#('freeze x)
(update x))
(x
(update x)))))
(define (%melt f s)
(%= (melt f) s))
(define (%melt-new f s)
(%= (melt-new f) s))
(define (%copy s c)
(%= (copy s) c))
(define-syntax !
(syntax-rules ()
((_) <cut>)
(_ <cut>)))
(define (%if-then-else a b c)
(</.> (<if> (a) (b) (c))))
(define (%not a)
(</.> (<not> (a))))
;; Not supporting free variables-yet
(define (%bag-of x g res)
(</.> (<collect> x (g) res)))
(define (%set-of x g res)
(</.> (<collect-set> x (g) res)))
(define (free-execute g)
(lambda (s p cc v)
(with-guarded-state gset! ((been '()) (first #t) (next #f) (fail p))
(g s fail
(lambda (ss pp inner-next)
(if first
(let ((val (v)))
(if (member v been)
(pp))
(let ((n
(set! fail p)
(set! first #f)
(set! v (freeeze val))
(set! next
(let ((s (gp-store-state)))
(lambda x
(gp-restore-state-wind s)
(set! been (cons cur been))
(set! first #t)
(set! v val)
(set! fail inner-next)
(pp))))))
(cc ss pp next))))))
(define (%bag-of x g out)
(lambda (s p cc)
(with-guarded-vars set-next! ((next (</.> (<fail> p))))
((bag-of set-next! x g out)
s p (lambda (ss pp)
(cc ss (lambda () (next))))))))
(define-syntax %free-vars
(syntax-rules ()
((_ (v) g)
(lambda (s p cc next)
(plet ((vv v))
(let-syntax ((v (syntax-rules ()
((_ a ...)
((vv) ...))
(_
(vv)))))
((free-execute g) s p cc vv next)))))))
%append
%member
;; Here is the zip function, zipping two functions together
(define (zip f (x g) (y h))
(define (make-cont p)
(let ((s (gp-store-state)))
(lambda ()
(gp-restore-state-wind s)
(p))))
(lambda (s p cc)
(glet ((g-cont #f) (h-cont h))
(with-logical
(let ((fr (gp-newframe fr)))
(g ss p
(lambda (ssg ppg)
(let ((cont #f))
(set! g-cont (lambda () (cont)))
(set! cont (make-cont ppg)))
(let ((xx (gp->scm x ssg)))
(gp-unwind fr)
(h-cont ss p
(lambda (ssh pph)
(let ((cont #f))
(set! h-cont (lambda (x y z) (cont)))
(set! cont (make-cont pph)))
(let ((yy (gp->scm y ssh)))
(gp-unwind fr)
(leave-logical
(<with-guile-log> (s g-cont cc)
(<and> (<=> x xx)
(<=> y yy)))))))))))))))
;; kanren zip
;; kanren bag-of including free variables
;; this can lead to an increase in computational complexity
;; any other kinds of tricks to accomplish anything cool?
;; a zip with wone function is especially call in that one can make
;; a problem is that applications are statedful , but we can store the
;; state and program as usuall
;; When we have multiple stacks we can do some trickety in order to stay
;; functional this means that we can implement copying functions and still
;; i'm 1, and i'm setting 2, let's hash it as an interpretation in stead
;; this way we can mix different stacks and actually keep them separate
;; without a need to store them, this means fast zipping so yeah multiple
;; stacks are pretty cool
;; One efficient hack is to make use of functional trees in order to reduce
;; lookup cost, to do this efficiently it would be nice to be able to store
;; the data in a functional lookup structure. it would be nice if all variables
;; had a hash value located on them. hmm, could be cool to use some kind of
;; 16 extra bit's on the smob! hmm it could also be a hash-key! cool!
;; We could find the base adress of the memory pool and use that as a reference
;; and be able to deduce if we are on different pools. then the extra smob bits
;; can be used as a hash structure.
;; hmm this is a really cool zipper, and is potentially very fast this also
;; can lead to efficient algorithms for multithreading applications.
\ No newline at end of file
......@@ -57,6 +57,47 @@ inline SCM logical_lookup(SCM x, SCM s)
return x;
}
inline SCM logical_lookup2(SCM x, SCM s)
{
SCM l;
if(SCM_CONSP(s))
s = SCM_CDR(s);
else
return x;
l = s;
if(!GP(x))
return x;
retry:
if(SCM_CONSP(l))
{
SCM car = SCM_CAR(l);
if(SCM_CONSP(car))
{
if(scm_is_eq(SCM_CAR(car),x))
{
SCM y = SCM_CDR(car);
if(!GP(y))
return x;
x = y;
l = s;
goto retry;
}
else
{
l = SCM_CDR(l);
goto retry;
}
}
else
scm_misc_error("logical_lookup","malformed assoc",SCM_EOL);
}
return x;
}
SCM logical_add(SCM x, SCM v, SCM s)
{
if(SCM_CONSP(s))
......
......@@ -41,8 +41,8 @@ scm_simple_format(SCM_BOOL_T, \
#define DB(X) X
#define DS(X) X
#define DB(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
#define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
......@@ -554,6 +554,8 @@ static int gp_recurent(SCM *id1,SCM *id2, SCM s)
id2 = gp_lookup(id2,s);
if(!GP_STAR(id2)) goto non_gp;
gp_debug0("recurent> looked up data\n");
if(id1 == id2 )
{
......@@ -614,12 +616,18 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
"creates a scheme representation of a gp object")
#define FUNC_NAME s_smob2scm
{
gp_debus0("gp->scm>\n");
if(GP(scm))
{
SCM *id;
id = UN_GP(scm);
id = gp_lookup(id, s);
if(!GP_STAR(id))
{
scm = GP_UNREF(id);
goto do_scm;
}
if(GP_CONS(id))
{
......@@ -630,6 +638,7 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
}
else
{
do_scm:
if(SCM_CONSP(scm))
{
SCM car = smob2scm(SCM_CAR(scm), s);
......@@ -1105,7 +1114,11 @@ static inline SCM ggp_set(SCM var, SCM val, SCM s)
if(GP(var))
{
id = GP_GETREF(var);
if(_logical_)
id = GP_GETREF(logical_lookup2(GP_UNREF(id),s));
else
id = gp_lookup(id,s);
if(GP_STAR(id))
if(GP(val))
{
......@@ -1154,6 +1167,18 @@ SCM_DEFINE(gp_set, "gp-set!", 3, 0, 0, (SCM var, SCM val, SCM s),
}
#undef FUNC_NAME
SCM_DEFINE(gp_set_stack, "gp-stack-set!", 3, 0, 0, (SCM var, SCM val),
"set gp var var to val using stack")
#define FUNC_NAME s_gp_set_stack
{
int old = _logical_;
_logical_ = 0;
ggp_set(var,val,SCM_EOL);
_logical_ = old;
return SCM_UNDEFINED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_print, "gp-print", 1, 0, 0, (SCM pr),
"print a val")
#define FUNC_NAME s_gp_print
......@@ -1336,6 +1361,7 @@ SCM_DEFINE(gp_gp_lookup, "gp-lookup", 2, 0, 0, (SCM x, SCM s),
//printf("lookup> gp\n");
gp_debug0("gp-lookup\n");
id = gp_lookup(GP_GETREF(x),s);
if(!GP_STAR(id)) return GP_UNREF(id);
if(GP_UNBOUND(id) || GP_CONS(id))
return GP_UNREF(id);
else
......@@ -1489,12 +1515,13 @@ SCM_DEFINE(gp_fluid_set_bang, "gp-fluid-set!", 2, 0, 0, (SCM f, SCM v),
scm_misc_error ("gp fluid error", "variable is not a fluid, ~a",
scm_list_1 (f));
id = gp_lookup(GP_GETREF(f),scm_cons(SCM_BOOL_F,SCM_EOL));
id = gp_lookup(GP_GETREF(f),SCM_EOL);
if(GP(v))