guile-prolog features added, see especially code for delimeted continuations

parent 1d2c7dfb
(define-module (logic guile-log canonacalize)
#:use-module (logic guile-log umatch)
#:export (canon-it un-canon-it))
(define vals (map (lambda (x)
(gensym (format #f "CANON-~a-" x)))
(iota 100)))
(define valn (gensym "CANON-N-"))
(define (canon-it x s)
(define vs vals)
(define tr (make-hash-table))
(define n 0)
(let lp ((x (gp->scm x s)))
(cond
((pair? x)
(cons (lp (car x)) (lp (cdr x))))
((vector? x)
(list->vector
(lp (vector->list x))))
((gp-var? x s)
(let ((r (hash-ref tr x)))
(if r
r
(if (pair? vs)
(let ((tag (car vs)))
(set! vs (cdr vs))
(hash-set! tr x tag)
tag)
(let ((tag (cons valn n)))
(set! n (+ n 1))
(hash-set! tr x tag)
tag)))))
(else
x))))
(define (un-canon-it x)
(define vs vals)
(define n 0)
(define tr (make-hash-table))
(let lp ((x x))
(cond
((pair? x)
(if (pair? vs)
(cons (lp (car x)) (lp (cdr x)))
(let ((ca (car x))
(cd (cdr x)))
(if (eq? ca valn)
(if (= cd n)
(let ((untag (gp-make-var)))
(hash-set! tr x untag)
(set! n (+ n 1))
untag)
(hash-ref tr x))
(cons (lp ca) (lp cd))))))
((vector? x)
(list->vector (lp (vector->list x))))
(else
(if (symbol? x)
(let ((r (hash-ref tr x)))
(if r
r
(if (eq? x (car vs))
(let ((untag (gp-make-var)))
(set! vs (cdr vs))
(hash-set! tr x untag)
untag)
x)))
x)))))
\ No newline at end of file
(define-module (logic guile-log guile-prolog continuations)
#:use-module (logic guile-log)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log iso-prolog)
#:export (abort_to_prompt with_prompt generator next yield translate
re_prompt call_k
run run2 run3 run4))
(define prompt-tag (list 'prolog-prompt))
(<define> (abort_to_prompt tag data feed)
(<abort> prompt-tag (<lambda> (x) (<=> x feed) <cc>) tag data))
(<define> (with_prompt tag code handler-data handler)
(<prompt> prompt-tag '()
(<lambda> () (goal-eval code))
(<lambda> (t next k tt data)
(<if> (<=> tt tag)
(<and>
(<=> handler-data ,(list tt next k data))
(goal-eval handler))
(next)))))
(define re_prompt
(<case-lambda>
((tag k hdata handle data)
(<re-prompt> (<lookup> k)
(<lambda> (t next k tt data)
(<if> (<=> tt tag)
(<and>
(<=> hdata ,(list tt next k data))
(goal-eval handle))
(next)))
(list data)))
((k hdata handle data)
(<re-prompt> (<lookup> k)
(<lambda> (t next k tt data)
(<=> hdata ,(list tt next k data))
(goal-eval handle))
(list data)))))
(define call_k
(<<case-lambda>>
(([K X] X D (((<lookup> K)) D)))))
(compile-string "yield(X) :- abort_to_prompt(generator,X,_).")
(compile-string "eat(X) :- abort_to_prompt(generator,_,X).")
(compile-string "generator(Goal,F) :-
with_prompt(generator, Goal,[generator,_,K,X],
F=[K,X]).")
(<define> (pref)
(<pp> (gp-handlers-ref)))
(compile-string
"
next([K,X],X,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],_).
feed([K,_],Y,F) :- re_prompt(K,[generator,_,K2,_ ],F=[K2,_ ],Y).
translate([K,X],X,Y,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],Y).
")
;; Example 1 (run)
(compile-string
"
sum(S) :- write(sum(S)),nl,eat(X),write(y(X)),nl,SS is S + X,sum(SS).
run :- generator(iter(0),F),generator(sum(0),S),pr(F,S).
pr(F,S) :- next(F,X,FF) -> write(n(X)),nl, feed(S,X,SS),pr(FF,SS).
iter(N) :- write(iter(N)),nl,N < 10 -> (yield(N),N2 is N + 1, iter(N2)).
")
;; Example 2 (run2)
(compile-string
"
iter2(N) :- write(iter2(N)),nl,N < 10 -> (yield(N) ; N2 is N + 1, iter2(N2)).
run2 :- generator(iter2(0),F),pr2(F,S).
pr2(F,S) :- next(F,X,FF),fail.
")
;; Example 3 (run3)
(compile-string
"
iter3(S,N) :- N < 10 -> (write(iter3(S,N)),nl,N2 is N + 1, iter3(S,N2)) ; true.
run3 :- generator((eat(X),iter3(X,X)),F),pr3(F).
pr3(F) :- call_k(F,_,0),write('--------'),nl,call_k(F,_,5).
")
;; Example 4 (run4)
(compile-string
"
iter4(S,N) :- N < 10 -> (write(iter4(S,N)),nl;N2 is N + 1, iter4(S,N2)).
run4 :- generator((eat(X),iter4(X,X)),F),pr4(F).
pr4(F) :- (call_k(F,_,0);call_k(F,_,5)),fail.
")
\ No newline at end of file
(define-module (logic guile-log guile-prolog continuations)
#:use-module (logic guile-log)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log iso-prolog)
#:export (abort_to_prompt with_prompt generator next yield translate
re_prompt call_k
run run2 run3 run4))
(define prompt-tag (list 'prolog-prompt))
(<define> (abort_to_prompt tag data feed)
(<abort> prompt-tag (<lambda> (x) (<=> x feed) <cc>) tag data))
(<define> (with_prompt tag code handler-data handler)
(<prompt> prompt-tag '()
(<lambda> () (goal-eval code))
(<lambda> (t next k tt data)
(<if> (<=> tt tag)
(<and>
(<=> handler-data ,(list tt next k data))
(goal-eval handler))
(next)))))
(define re_prompt
(<case-lambda>
((tag k hdata handle data)
(<re-prompt> (<lookup> k)
(<lambda> (t next k tt data)
(<if> (<=> tt tag)
(<and>
(<=> hdata ,(list tt next k data))
(goal-eval handle))
(next)))
(list data)))
((k hdata handle data)
(<re-prompt> (<lookup> k)
(<lambda> (t next k tt data)
(<=> hdata ,(list tt next k data))
(goal-eval handle))
(list data)))))
(define call_k
(<<case-lambda>>
(([K X] X D (((<lookup> K)) D)))))
(compile-string "yield(X) :- abort_to_prompt(generator,X,_).")
(compile-string "eat(X) :- abort_to_prompt(generator,_,X).")
(compile-string "generator(Goal,F) :-
with_prompt(generator, Goal,[generator,_,K,X],
F=[K,X]).")
(<define> (pref)
(<pp> (gp-handlers-ref)))
(compile-string
"
next([K,X],X,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],_).
feed([K,_],Y,F) :- re_prompt(K,[generator,_,K2,_ ],F=[K2,_ ],Y).
translate([K,X],X,Y,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],Y).
")
;; Example 1 (run)
(compile-string
"
sum(S) :- write(sum(S)),nl,eat(X),write(y(X)),nl,SS is S + X,sum(SS).
run :- generator(iter(0),F),generator(sum(0),S),pr(F,S).
pr(F,S) :- next(F,X,FF) -> write(n(X)),nl, feed(S,X,SS),pr(FF,SS).
iter(N) :- write(iter(N)),nl,N < 10 -> (yield(N),N2 is N + 1, iter(N2)).
")
;; Example 2 (run2)
(compile-string
"
iter2(N) :- write(iter2(N)),nl,N < 10 -> (yield(N) ; N2 is N + 1, iter2(N2)).
run2 :- generator(iter2(0),F),pr2(F,S).
pr2(F,S) :- next(F,X,FF),fail.
")
;; Example 3 (run3)
(compile-string
"
iter3(S,N) :- N < 10 -> (write(iter3(S,N)),nl,N2 is N + 1, iter3(S,N2)) ; true.
run3 :- generator((eat(X),iter3(X,X)),F),pr3(F).
pr3(F) :- call_k(F,_,0),write('--------'),nl,call_k(F,_,5).
")
;; Example 4 (run4)
(compile-string
"
iter4(S,N) :- N < 10 -> (write(iter4(S,N)),nl;N2 is N + 1, iter4(S,N2)).
run4 :- generator((eat(X),iter4(X,X)),F),pr4(F).
pr4(F) :- (call_k(F,_,0);call_k(F,_,5)),fail.
")
\ No newline at end of file
(define-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log canonacalize)
#:use-module (logic guile-log hash)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog util)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log)
#:export (vhashp vhash_ref vhash_cons
with_dynamic_vhashes with_vhashes vhash
run))
(mk-sym vhash)
;; TODO: debug and stabilize the C-vlist code
;; TODO: These hashes get's bloated if we do a lot of hash-cons in which case
;; onw might wand hash_set_x!! in stead of vhash-cons
;; We need to support vectors or f(X) like objects
;; TODO: vhash must be intelligent with respect to truncate
;; TODO: EQ, hashes EQV hashes?
;; TODO: hash fold
;; TODO: region guarding.
#|
vhashes works like an association list where seting new values is done by
consing a new pair to the top of the list and therefore shading the old pair
it is possible to set it and remove th eold value but that is an expensive
operation, it is not uncommon to have this restriction. Another nice feature
we have with the vhash is that it can backtrack very effectively and is a well
optimized datastructure for doing this. But it is backtracking with
intelligence! If a value is stored in e.g. an interleaving operation it will
handle that and make act to chain a frech new datastructure else it will reuse
it's old datastructure.
|#
(<define> (vhashp x) (when (<vhash?> (<lookup> x))))
(<define> (vhash_ref h k ret)
(<let> ((h (<lookup> h))
(k (canon-it k S)))
(cond
((<var?> h)
(instantiation_error))
((not (<vhash?> h))
(type_error hash h))
(else
(<let> ((val (vhash-assoc (<scm> k) (fluid-ref h))))
(when val
(<=> ,(un-canon-it val) (k . ret))))))))
(<define> (vhash_cons h k v)
(<let*> ((h (<lookup> h))
(k.v (canon-it (cons k v) S))
(k (car k.v))
(v (cdr k.v)))
(cond
((<var?> h)
(instantiation_error))
((not (<vhash?> h))
(type_error hash h))
(else
(<code> (fluid-set! h (vhash-cons k v (fluid-ref h))))))))
(define-syntax-rule (mkvh with_vhashes <with-vhashes>)
(<define> (with_vhashes . x)
(<let> ((xx (map (lambda (x)
(let ((x (<lookup> x)))
(cond
((gp-var? x S)
(<make-vhash>))
((<vhash?> x)
x)
(else
(type_error S (lambda x #t) (lambda x #t) hash x)))))
(<scm> x))))
(<=> xx x)
(<apply> <with-vhashes> xx))))
(mkvh with_vhashes <with-vhashes>)
(mkvh with_dynamic_vhashes <guard-vhashes>)
(<define> (peek h)
(<code> (analyze (fluid-ref (<lookup> h)))))
(define (analyze x)
(if (vlist? x)
(let ((a (struct-ref x 0))
(b (struct-ref x 1)))
(format #t "<vhash> offset = ~a, " b)
(let ((block (vector-ref a 0))
(off (vector-ref a 2))
(size (vector-ref a 3))
(free (vector-ref a 4)))
(format #t " size ~a, free ~a~%" size free)
(let lp ((i b))
(if (>= i 0)
(let* ((next (number->string
(logand #xffffffff
(vector-ref block (+ (* size 3) i)))
16))
(back (ash
(vector-ref block (+ (* size 3) i))
-32))
(hash (vector-ref block (+ (* size 2) back)))
(v (object-address (vector-ref block i))))
(format #t "~a: next ~a, back ~a hashv ~a key ~a~%"
i next back
hash (number->string v 16))
(lp (- i 1)))))))
(format #t "<assoc>~%")))
(compile-string
"
iter(N,X) :- N < 10 , (X = N ; (N2 is N + 1, iter(N2,X))).
run :- pp_dyn(H,H),with_vhashes(H), vhash_cons(H,13,13),peek(H),
((iter(0,A),write(A),nl,vhash_cons(H,A,[A,Y,Y]),fail) ;
(peek(H),vhash_ref(H,14,X),write(solution(X)),nl)).
")
\ No newline at end of file
(define-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log memoize)
#:use-module (logic guile-log hash)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log prolog utils)
#:use-module (logic guile-log)
#:export (hashp hash_ref hash_cons guard_hash
dynamic_hashp dynamic_hash_ref dynamic_hash_set
with_dynamic_hash gurad_dynamic_hash
hash))
(mk-sym hash)
;; TODO: debug and stabilize the C-vlist code
;; TODO: These hashes get's bloated if we do a lot of hash-cons in which case
;; onw might wand hash_set_x!! in stead of vhash-cons
;; TODO we need to make a better matcher between K,V in case of variables
;; We need to support vectors or f(X) like objects
;; TODO: vhash must be intelligent with respect to truncate
;; TODO: EQ, hashes EQV hashes?
;; TODO: hash fold
;; TODO: region guarding.
#|
A fundamental issue with a hash-table with vhashes is that of making it
robust and fast at the same time. The problem has to do with the ability
to store an old value of the hash for use later we need an actions to
backtrack hashes a cool way of doing this is with the help of a var-list
We need to patch the unwind function and make use of a list of parameters
|#
(<define> (dynamic-hashp x) (when (dynamic-vhash? (<lookup> x))))
(<define> (hashp x) (when (vhash? (<lookup> x))))
(<define> (hash_ref h k ret)
(<let> ((h (<lookup> h))
(k (memo-it k)))
(cond
((<var?> h)
(instantiation_error))
((not (vash? h))
(type_error hash h))
(else
(<let> ((val (vhash-assoc h (<scm> k))))
(when val
(<=> ,(unmemo-it ret) (k . val))))))))
(<define> (hash_cons h k v hret)
(<let*> ((h (<lookup> h))
(k.v (memo-it (cons k v)))
(k (car k.v))
(v (cdr k.v)))
(cond
((<var?> h)
(instantiation_error))
((not (vhash? h))
(type_error hash h))
(else
(<=> hret ,(vhash-cons h k v))))))
(<define> (dynamic_hash_ref h k ret)
(<let> ((h (<lookup> h))
(k (<lookup> k)))
(cond
((<var?> h)
(instantiation_error))
((not (dynamic-vhash? h))
(type_error hash h))
(<let> ((h (fluid-ref? h)))
(<let> ((val (vhash-assoc h (memo-it k))))
(when val
(<=> ret (k . val))))))))
(<define> (dynamic_hash_set h k v)
(<let> ((h (<lookup> h)))
(cond
((<var?> h)
(instantiation_error))
((not (dynamic-vhash? h))
(type_error hash h))
(else
(<let>* ((hh (fluid-ref h))
(k.v (memo-it (cons k v)))
(k (car k.v))
(v (cdr k.v)))
(<code> (fluid-set! h (vhash-cons hh k v))))))))
(define with_hash <with-hash>)
(define guard_hash <guard-hash>)
(define dynamic_with_hash <with-mutating-hash>)
(define dynamic_guard_hash <guard-mutating-hash>)
\ No newline at end of file
(define-module (logic guile-log guile-prolog interleave)
#:use-module (logic guile-log)
#:export (or_i and_i or_union))
(define-syntax-rule (mk-i or_i f)
(<define> (or_i . x)
(<let> ((x (map (lambda (x) (<lambda> () (goal-evel x))) x)))
(<apply> (@@ (logic guile-log interleave) f) x))))
(mk-i or_i f-interleave)
(mk-i and_i and-interleave)
(mk-i or_union f-interleave-union)
\ No newline at end of file
(define-module (logic guile-log guile-prolog interleave)
#:use-module (logic guile-log)
#:export (or_i and_i or_union))
(define-syntax-rule (mk-i or_i f)
(<define> (or_i . x)
(<let> ((x (map (lambda (x) (<lambda> () (goal-evel x))) x)))
(<apply> (@@ (logic guile-log interleave) f) x))))
(mk-i or_i f-interleave)
(mk-i and_i and-interleave)
(mk-i or_union f-interleave-union)
\ No newline at end of file
#|
interact with scheme expressions e.g.
scheme([+,X,Y],Out)
|#
(<define> (scheme L Out)
(<=> Out ,(eval (<scm> L) (current-module))))
#|
interact with scheme expressions e.g.
scheme([+,X,Y],Out)
|#
(<define> (scheme L Out)
(<=> Out ,(eval (<scm> L) (current-module))))
#|
state handling e.g. be able to store a state entering a repl, as well
as storing a state.
|#
store(a)
restore(a)
new_interpreter
goto_interpreter
current_interpretter
(define-module (logic guile-log guile-prolog zip)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog goal-transformers)
#:export (zip usr_zip update lane update)
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
(set-procedure-property! a 'name 'a)))
(mk-sym lane)
(<define> (zip_ xs codes)
(<match> (#:mode - #:name zip_) (xs codes)
(() ()
<cc>)
((x) (c)
(goal-eval c))
((x1 x2) (c1 c2)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))))
((x1 x2 x3) (c1 c2 c3)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))))
((x1 x2 x3 x4) (c1 c2 c3 c4)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))
(x4 (goal-eval c4))))
((x1 x2 x3 x4 . xl) (c1 c2 c3 c4 . cl)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))
(x4 (goal-eval c4))
(xl (zip_ xl cl))))))
(<define> (zip . l)
(<match> (#:mode - #:name zip) (l)
((#((,lane x code)) ...)
(zip_ x code))
(_
(type_error zip l))))
(<define> (usr_zip_ fs xs cs guard)
(<match> (#:mode - #:name zip_) (fs xs codes)
(() () ()
(goal-eval guard))
((f) (x) (c)
(<//> ((df ((y x)) (goal-eval c)))
(<=> x y) (<=> f df)
(goal-eval guard)))
((f1 f2) (x1 x2) (c1 c2)
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2)))
(<=> (x1 x2) (y1 y2))
(<=> (f1 f2) (df1 df2))
(goal-eval guard)))
((f1 f2 f3) (x1 x2 x3) (c1 c2 c3)
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2))
(df3 ((y3 x3)) (goal-eval c3)))
(<=> (x1 x2 x3) (y1 y2 y3))
(<=> (f1 f2 f3) (df1 df2 df3))
(goal-eval guard)))
((f1 f2 f3 f4) (x1 x2 x3 x4) (c1 c2 c3 c4)
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2))
(df3 ((y3 x3)) (goal-eval c3))
(df4 ((y4 x4)) (goal-eval c4)))
(<=> (x1 x2 x3 x4) (y1 y2 y3 y4))
(<=> (f1 f2 f3 f4) (df1 df2 df3 df4))
(goal-eval guard)))
((f1 f2 f3 f4 . fl) (x1 x2 x3 x4 . xl) (c1 c2 c3 c4 . cl)
(<//> ((df1 ((y1 x1)) (goal-eval c1))
(df2 ((y2 x2)) (goal-eval c2))
(df3 ((y3 x3)) (goal-eval c3))
(df4 ((y4 x4)) (goal-eval c4)))
(<=> (x1 x2 x3 x4) (y1 y2 y3 y4))
(<=> (f1 f2 f3 f4) (df1 df2 df3 df4))
(usr_zip fl xl cl guard)))))
(<define> (usr_zip . l)
(<match> (#:mode - #:name zip) (l)
((#((,lane f x cs)) ... guard)
(usr_zip_ f x cs guard))
(_
(type_error zip l))))
(define update
(<case-lambda>
((x)
(<update> ((<lookup> x))))
((x . l)
(<update-val> ((<lookup> x)))
(<apply> update l))))
\ No newline at end of file
(<define> (zip_ xs codes)
(<match> (#:mode - #:name zip_) (xs codes)
(() ()
<cc>)
((x) (c)
(goal-eval c))
((x1 x2) (c1 c2)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))))
((x1 x2 x3) (c1 c2 c3)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))))
((x1 x2 x3 x4) (c1 c2 c3 c4)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))
(x4 (goal-eval c4))))
((x1 x2 x3 x4 . xl) (c1 c2 c3 c4 . cl)
(<zip> (x1 (goal-eval c1))
(x2 (goal-eval c2))
(x3 (goal-eval c3))
(x4 (goal-eval c4))
(xl (zip_ xl cl))))))
(zip,lane(x1,code1),lane(x2,code2)
\ No newline at end of file
(define-module (logic guile-log hash)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log canonacalize)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log)
#:export (<make-hash>
<make-mutating-hash>
<hash-ref> <hash-set!> <hash-add>
<with-mutating-hashes>
<with-hashes>
<guard-mutating-hashes>
<guard-hashes>))
#:export (<make-vhash>
<vhash?>
<vhash-ref> <vhash-cons>
<with-vhashes>
<guard-vhashes>))
#|
Hash algorithms
(define (<make-vhash>) (make-fluid vlist-null))