now everything works

parent 3f7ca6e8
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (system repl repl) #: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!) #:re-export (gp-cons! gp-lookup gp-var! gp->scm gp-unify! gp-unify-raw! gp-m-unify!)
#:export (umatch)) #:export (umatch))
......
...@@ -199,6 +199,26 @@ and-interleave ...@@ -199,6 +199,26 @@ and-interleave
...) ...)
(parse<> meta (<and> code ...))))))))) (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 (define-syntax letg-aux
(syntax-rules () (syntax-rules ()
...@@ -228,3 +248,80 @@ and-interleave ...@@ -228,3 +248,80 @@ and-interleave
(var (var
(identifier? #'var) (identifier? #'var)
#'ss))))))))))) #'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 @@ ...@@ -11,13 +11,15 @@
let<> <or-i> <or-union> <stall> <continue> <take> let<> <or-i> <or-union> <stall> <continue> <take>
<state-ref> <state-set!> <lv*> <clear> <state-ref> <state-set!> <lv*> <clear>
<and-i> and-interleave interleave tr <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?) (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) (define (<stall> s p cc)
(set! *cc* (cons s (cons p cc))) (set! *cc* (cons s (cons p cc)))
...@@ -125,7 +127,7 @@ ...@@ -125,7 +127,7 @@
(lambda (s p) (lambda (s p)
(if (= n 0) (if (= n 0)
(let ((r (reverse ret))) (let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm) (gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '()) (n-ret-set! mm '())
(p))) s) (p))) s)
r) r)
...@@ -134,9 +136,9 @@ ...@@ -134,9 +136,9 @@
(cons (tr (gp->scm v s) s) ret)) (cons (tr (gp->scm v s) s) ret))
(if (= n 0) (if (= n 0)
(let ((r (reverse ret))) (let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm) (gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '()) (n-ret-set! mm '())
(p))) s) (p))) s)
r) r)
(p))))))))) (p)))))))))
...@@ -156,20 +158,20 @@ ...@@ -156,20 +158,20 @@
(lambda (s p) (lambda (s p)
(if (= n 0) (if (= n 0)
(let ((r (reverse ret))) (let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm) (gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '()) (n-ret-set! mm '())
(p))) (p)))
s) s)
r) r)
(begin (begin
(n-ret-set! (- n 1) (n-ret-set! (- n 1)
(cons (tr (list (gp->scm v s) ...) s) ret)) (cons (tr (list (gp->scm v s) ...) s) ret))
(if (= n 0) (if (= n 0)
(let ((r (reverse ret))) (let ((r (reverse ret)))
(gp-set! *cc* (cons #f (lambda (mm) (gp-stack-set! *cc* (cons #f (lambda (mm)
(n-ret-set! mm '()) (n-ret-set! mm '())
(p))) (p)))
s) s)
r) r)
(p))))))))))) (p)))))))))))
...@@ -287,8 +289,9 @@ ...@@ -287,8 +289,9 @@
(define-syntax <%fkn%> (define-syntax <%fkn%>
(syntax-rules () (syntax-rules ()
((_ (cut s pr cc) f a ...) ((_ (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> (define-guile-log <with-fail>
(syntax-rules () (syntax-rules ()
...@@ -388,10 +391,11 @@ ...@@ -388,10 +391,11 @@
(define-guile-log <when> (define-guile-log <when>
(syntax-rules () (syntax-rules ()
((_ wc p code ...) ((_ (cut s p cc) pred code ...)
(if p (fluid-let-syntax ((S (lambda (x) #'s)))
(parse<> wc (<and> code ...)) (if pred
(parse<> wc <fail>))))) (parse<> (cut s p cc) (<and> code ...))
(parse<> (cut s p cc) <fail>))))))
(define (pp x) (define (pp x)
(pretty-print x) (pretty-print x)
...@@ -423,15 +427,17 @@ ...@@ -423,15 +427,17 @@
(define-guile-log <tail-code> (define-guile-log <tail-code>
(syntax-rules () (syntax-rules ()
((_ (_ s p cc) (ss pp ccc) code ...) ((_ (_ s p cc) (ss pp ccc) code ...)
(let ((ss s) (fluid-let-syntax ((S (lambda (x) #'s)))
(pp p) (let ((ss s)
(ccc cc)) (pp p)
code ...)))) (ccc cc))
code ...)))))
(define-guile-log <code> (define-guile-log <code>
(syntax-rules () (syntax-rules ()
((_ wc code ...) ((_ (cut s p cc) code ...)
(begin code ... (parse<> wc <cc>))))) (fluid-let-syntax ((S (lambda (x) #'s)))
(begin code ... (parse<> (cut s p cc) <cc>))))))
(log-code-macro '<code>) (log-code-macro '<code>)
(define-guile-log <return> (define-guile-log <return>
...@@ -806,3 +812,5 @@ ...@@ -806,3 +812,5 @@
(gp-clear)) (gp-clear))
(log-code-macro '<fail>) (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) ...@@ -57,6 +57,47 @@ inline SCM logical_lookup(SCM x, SCM s)
return x; 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) SCM logical_add(SCM x, SCM v, SCM s)
{ {
if(SCM_CONSP(s)) if(SCM_CONSP(s))
......
...@@ -41,8 +41,8 @@ scm_simple_format(SCM_BOOL_T, \ ...@@ -41,8 +41,8 @@ scm_simple_format(SCM_BOOL_T, \
#define DB(X) X #define DB(X)
#define DS(X) X #define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout)) #define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; 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)) #define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
...@@ -553,7 +553,9 @@ static int gp_recurent(SCM *id1,SCM *id2, SCM s) ...@@ -553,7 +553,9 @@ static int gp_recurent(SCM *id1,SCM *id2, SCM s)
if(!GP(GP_UNREF(id2))) goto non_gp