delay.scm + struct destructoining without unification

parent 09a98ce8
......@@ -33,19 +33,24 @@ Version 0.5,
* corouttines / experimental.
* tracing
* Better compilation error handling
* Support for namespaced operators in prolog (TODO)
* Support for X[a] and X{A} (TODO)
* Operators are now namespaced correctly.
* fast math and guile featured operators for numerics added.
Version 0.6, TODO
* Functional Streams DONE
* SWI Prolog namespacing
* SWI Prolog modules
* SWI Prolog namespacing DONE
* SWI Prolog modules DONE
* SWI Prolog ensure_loded
* SWI Prolog call semantics
* More general postpone, for local searches.
* Indexed predicates per default.
* Fast C-version of predicate matching.
* Support for namespaced operators in prolog
* Support for X[a] and X{A}
* Extended attributes, more features added.
* if directives
* swi compability
* functions as vectors (SWI)
* GC of the (almost) unreachable tail of a stream (all)
* Multi threading capabilities (all)
* Sandboxing (prolog)
......
......@@ -254,16 +254,21 @@
(match-one abs s v (and . p) g+s sk fk i)
(insert-abs abs s fk)))
;; stis, added $ support!
((match-two abs s v ($ n) g-s sk fk i)
(if (n v)
(insert-abs abs s sk)
(insert-abs abs s fk)))
((match-two (abs ((car cdr pair? null? equal? id . u_) pp))
s v ($ n) g-s (sk ...) fk i)
(let ((vv (id v s)))
(if (n vv)
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s
(sk ... i))
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
((match-two abs s v ($ nn p ...) g+s sk fk i)
(if (nn v)
(match-$ abs (and) 0 (p ...) s v sk fk i)
(insert-abs abs s fk)))
((match-two (abs ((car cdr pair? null? equal? id . u_) pp))
s v ($ nn p ...) g+s sk fk i)
(let ((vv (id v s)))
(if (nn vv)
(match-$ (abs ((car cdr pair? null? equal? id . u_) pp))
(and) 0 (p ...) s vv sk fk i)
(insert-abs (abs ((car cdr pair? null? equal? id . u_) pp)) s fk))))
;; stis, added the possibility to use set! and get to records everything is
;; done through boxing here
......@@ -610,7 +615,7 @@
(+ (syntax->datum (syntax m)) 1))))
(syntax (match-$ abs (a ... (= 0 m p1)) m+1 (p2 ...) . v))))
((_ abs newpat m () s v kt ke i)
(syntax (match-one abss s v newpat () kt ke i))))))
(syntax (match-one abs s v newpat () kt ke i))))))
(define-syntax match-gen-ellipses
......
......@@ -41,12 +41,14 @@
sat_count/2
]).
:- use_module(user).
:- use_module(library(error)).
:- use_module(library(vhash)).
%:- use_module(library(assoc)).
:- use_module(library(lists)).
:- use_module(library(apply)).
:- use_module(user).
:- use_module(library(error)).
:- use_module(library(vhash)).
%:- use_module(library(assoc)).
:- use_module(library(lists)).
:- use_module(library(apply)).
/*
'~'(X).
......@@ -918,7 +920,6 @@ make_clpb_var('$clpb_next_node') :- nb_setval('$clpb_next_node', 0).
user:exception(undefined_global_variable, Name, retry) :-
make_clpb_var(Name), !.
clpb_next_id(Var, ID) :-
b_getval(Var, ID),
Next is ID + 1,
......@@ -981,4 +982,4 @@ clpb_hash(_,_,#t). % OK
sandbox:safe_global_variable('$clpb_next_var').
sandbox:safe_global_variable('$clpb_next_node').
*/
*/
(define-module (logic guile-log guile-prolog delay)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:use-module (srfi srfi-9)
#:export (delay force))
(define-record-type <delay>
(make-delay exp)
delay?
(exp delay-exp))
(set-record-type-printer! <delay>
(lambda (vl port)
(format port
"<delayed>")))
(<define> (delay e . l)
(<recur> lp ((l l) (hit? #f))
(<<match>> (#:mode -) (l)
(((? <var?> x) . l)
(<=> x ,(make-delay e))
(lp l #t))
(((and x ($ <delay> ee)) . l)
(if (<==> ee e)
<cc>
(<set> x ,(make-delay (vector (list comma ee e)))))
(lp l #t))
((_ . l)
(lp l hit?))
(()
(when hit?)))))
(<define> (delayed_p x f)
(<<match>> (#:mode -) (x)
(($ <delay>) (<=> f ,(<lookup> x)))
(_ <fail>)))
(compile-prolog-string
"
force(Var,Val) :- delayed_p(Var,F) -> (set(Var,Val),F) ; Var=Val.
")
#|
(<define> (nullify L) (<set> L '()))
(compile-prolog-string
"
adjust_window(0,L) :- nullify(L).
adjust_window(N,[_|L]) :- NN is N - 1, adjust_window(NN,L).
start_window(S) :- S=[].
moving_window(M,X,[N,L],SS) :-
SS = NN is N + 1, LL = [X|L], SS = [NN,LL], (adjust_window(M,LL) ; true).
mwop(Op, 1, [[W,X]] , Seed) :- !,
Op(WW, Seed, X), force(W,WW).
mwop(Op, M, [[W,X]|L], Seed) :-
Op(Seed2,Seed,X),
mwop(Op, L, Seed2).
maxz(Z,X,Y) :- delay(maxz ,Z,X,Y) ; (ZZ is max(X,Y), force(Z,ZZ)).
minz(Z,X,Y) :- delay(minz ,Z,X,Y) ; (ZZ is min(X,Y), force(Z,ZZ)).
plusz(Z,X,Y) :- delay(plusz,Z,X,Y) ; (ZZ is X + Y , force(Z,ZZ)).
moving_op(M,Op,Seed,U,X,S,SS) :-
moving_window(M,[U,X],S,SS) :-
(length(S,N), N is M) -> mwop(Op,M,SS,Seed) ; true).
take(Start,Next, N, S) :-
start(SS), take_(N,Next,SS,S).
take_(0,_,S,S).
take_(N,Next,S,SS) ;-
NN is N - 1, Next(S,SSS), take_(NN,Next,SSS, SS).
")
(<define> (varfail p) (<with-fail> p <fail>))
(<define> (randomz N P X)
(<let> ((n (<lookup> N)))
(<recur> lp ()
(<or>
(<peek-fail> pp
(<=> X ,(random n))
(<=> P pp))
(lp)))))
;; Example
(compile-prolog-string
"
find(R,[X|L],Y) :- X=[R|U] -> Y=X ; find(R,L,Y).
trim([],[]).
trim([[_,_,_,m] | L],U) :- !,trim(L,U).
trim([X|L],[X|U]) :- !,trim(L,U).
add_l(R,L,LL) :-
length(L,N),
(N > 30 -> trim(L,LLL) ; LLL = L),
LL = [R|LLL].
gl([_,_,Z,II,LL],[R,_,I,L]) :- II = I + 1, randomz(10,R,Retry),
( find(R,L,[R,X,J,P,_]), \+var(P)
-> (K is II - J, force(X,K),P=m); true)
add_l([R,Z,II,_,Retry],L,LL).
next(Z,Car,Cdr) :- Z=G(X,Y), G(X,Y), Car=Y, Cdr=G(Y,_).
start_l(Z) :- Z=gl([X,0,[]],_)
plus(Z,X,Y) :- delay(plus,Z,X,Y); W is X + Y, force(Z,W).
start_id(Z) :- Z = 1.
next_all1([Z1,Z2,Id],[ZZ1,ZZ2,IId]) :-
next(Z1,[R1,P1,C1|_],ZZ1),
next(Z2,[R2,P2,C2|_],ZZ2),
plus(C,C1,C2),
plus(IId,Id,C),
writez(_,IId,C,R1,R2).
start_all1([X1,Z2,Id]) :- start_l(X1), start_l(X2) start_id(Id).
writez(_,Id,X,R1,R2) :- delay(writez,_,Id,X,R1,R2) ; write([R1,R2,X]),nl.
fail_if(P,E) : call(E) -> varfail(P) ; true.
next_all2([Z1,Z2,Id,S1,S2],[ZZ1,ZZ2,IId,SS1,SS2]) :-
next(Z1,[R1,P1,C1|_],ZZ1),
next(Z2,[R2,P2,C2|_],ZZ2),
moving_op(2,maxz,0,U1,C1,S1,SS1),
moving_op(2,maxz,0,U2,C1,S2,SS2),
fail_if(P2,(U1 < U2)),
plus(C,U1,U2),
plus(IId,Id,C),
writez(_,IId,C,R1,R2).
start_all2([X1,Z2,Id,S1,S2]) :- start_l(X1), start_l(X2) start_id(Id), start_mw(S2), start_mw(S2).
")
|#
......@@ -393,7 +393,6 @@ conversation2(X,All) :-
tree,
consult(T,V,N,All).
-trace.
consult(X,V,N,All) :-
do[(fluid-set! -nsol- (<lookup> All))],
catch((solve(V,N,X) ; (nl,write(no),nl,fail)),finish,
......@@ -472,7 +471,6 @@ more :-
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
-trace.
solve(V,N,X) :- set_once,X,
if_once(output_and_more(V,N,#f),output_and_more(V,N,#t)).
.
......
......@@ -3,7 +3,9 @@
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log prolog pre)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (*current-stack* gp-var-set))
#:use-module ((logic guile-log umatch) #:select (*current-stack* gp-var-set
gp-newframe
gp-unwind))
#:use-module (system base language)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
......@@ -517,6 +519,13 @@
#f))
#f)))
(define-syntax-rule (wrap-* l)
(let* ((fr1 (gp-newframe (fluid-ref *current-stack*)))
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
l)
(gp-unwind fr1)))
(define (use-module-mac stx l n m)
(letrec ((lp (lambda (l)
(define (atom c)
......@@ -561,41 +570,48 @@
(let ((pth (-> l))
(h (append '(language prolog modules)
(f l #f))))
(wrap-*
(with-syntax ((f2 (datum->syntax stx pth))
(ff (datum->syntax stx h)))
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-stack* (fluid-ref *current-stack*))
(*current-language* (lookup-language 'scheme)))
(set-module! nm (resolve-module pth))
(pre-compile-prolog-file h))
(process-use_module (list (list pth)))
(use-pub-ops (resolve-module pth) (fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module pth)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module pth)
(fluid-ref *current-stack*))
#`(eval-when (expand load eval)
(with-fluids ((*ops* (fluid-ref *ops*))
(*term-expansions*
(fluid-ref *term-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*current-stack* (fluid-ref *current-stack*))
(*current-language* (lookup-language 'scheme)))
(pre-compile-prolog-file 'ff)
(set-module! '#,(datum->syntax stx nm) (resolve-module 'f2)))
(with-fluids ((*ops* (fluid-ref *ops*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*)))
(process-use_module (list (list pth)))
(use-pub-ops (resolve-module pth) (fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module pth)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module pth)
(fluid-ref *current-stack*))
#`(eval-when (expand load eval)
(wrap-*
(begin
(with-fluids ((*ops* (fluid-ref *ops*))
(*term-expansions*
(fluid-ref *term-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*current-language*
(lookup-language 'scheme)))
(pre-compile-prolog-file 'ff)
(set-module! '#,(datum->syntax stx nm)
(resolve-module 'f2)))
(with-fluids ((*ops* (fluid-ref *ops*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*)))
(process-use_module '((f2))))
(use-pub-ops (resolve-module 'f2) (fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module 'f2)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module 'f2)
(fluid-ref *current-stack*))))))
(process-use_module '((f2))))
(use-pub-ops (resolve-module 'f2)
(fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module 'f2)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module 'f2)
(fluid-ref *current-stack*)))))))))
((name imports)
(let* ((g (-> name))
......@@ -607,26 +623,27 @@
(((_ _ "as" _) m n)
`((,(atom m) . ,(atom n))))
(x (atom x))))
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-stack* (fluid-ref *current-stack*))
(*current-language* (lookup-language 'scheme)))
(pre-compile-prolog-file h)
(set-module! nm (resolve-module g)))
(process-use_module (list (list g '(#:duplicates (last)))))
(use-pub-ops (resolve-module g) (fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module g)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module g)
(fluid-ref *current-stack*))
(wrap-*
(begin
(with-fluids ((*ops* (fluid-ref *ops*))
(*current-language* (lookup-language 'scheme)))
(pre-compile-prolog-file h)
(set-module! nm (resolve-module g)))
(process-use_module (list (list g '(#:duplicates (last)))))
(use-pub-ops (resolve-module g) (fluid-ref *current-stack*))
(use-pub-goal-expansions (resolve-module g)
(fluid-ref *current-stack*))
(use-pub-term-expansions (resolve-module g)
(fluid-ref *current-stack*))))
#`(eval-when (expand load eval)
(with-fluids ((*current-language* (lookup-language 'scheme))
(*current-stack* (fluid-ref *current-stack*))
(*term-expansions*
(fluid-ref *term-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*ops* (fluid-ref *ops*)))
(wrap-* (begin (with-fluids ((*current-language* (lookup-language 'scheme))
(*term-expansions*
(fluid-ref *term-expansions*))
(*goal-expansions*
(fluid-ref *goal-expansions*))
(*ops*
(fluid-ref *ops*)))
(pre-compile-prolog-file '#,ff)
(set-module! '#,(datum->syntax stx nm) (resolve-module 'f)))
......@@ -646,7 +663,7 @@
(use-pub-goal-expansions (resolve-module 'f2)
(fluid-ref *current-stack*))
(use-pub-ops (resolve-module 'f2)
(fluid-ref *current-stack*))))))))))
(fluid-ref *current-stack*))))))))))))
(lp l)))
......@@ -706,8 +723,7 @@
(define *once* #f)
(<define> (use_module . l)
(<apply> use_module_ l)
(<code> (gp-var-set *once* S S)))
(<apply> use_module_ l))
(define (modspec x)
(let* ((fx (cadr x))
......@@ -816,6 +832,10 @@
((x)
(<match> (#:mode -) (x)
((a)
(<cut>
(use_module_ a)))
((a . l)
(<cut>
(<and>
......
......@@ -169,19 +169,20 @@
((_ m (v ...) code ...)
(let ((fr (gp-newframe (fluid-ref *current-stack*))))
(with-fluids ((*current-stack* fr))
(let* ((fr1 (gp-newframe (fluid-ref *current-stack*)))
(fr2 (gp-newframe fr1)))
(with-fluids ((*current-stack* fr2))
(if *kanren-assq*
(gp-logical++))
(let-with-lr-guard fr wind lg rg ((n m) (ret '()))
(lg fr
(let-with-lr-guard fr2 wind lg rg ((n m) (ret '()))
(lg fr2
(<eval> (v ...)
(<and> code ...)
(lambda x
(let ((r ret))
(set! n 0)
(set! ret '())
(gp-unwind fr)
(gp-unwind fr1)
(reverse r)))
(lambda (s p)
(if (= n 0)
......
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