developed the iterator framework for prolog

parent 9e73d105
......@@ -105,7 +105,6 @@
(if (pair? tail)
(vector? (car (reverse tail)))
#f)))
(let lp ((h head) (t tail) (p path) (v pot) (d depth))
(if (or (null? p) (<= d stop-depth))
(begin
......
(define-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog persist)
#:use-module (logic guile-log scmspace)
#:use-module (logic guile-log tools)
#:use-module (logic guile-log prolog symbols)
#:use-module (logic guile-log hash-dynamic)
#:use-module (logic guile-log prolog base)
......@@ -51,8 +52,10 @@
load_persists
save_persists
accessify_predicate
sumof prodof
maxof minof lastof functor
sumof prodof countof maxof minof foldof
sumofn prodofn countofn maxofn minofn foldofn
lastof functor
uniq
;;swi stuff
meta_predicate public
......@@ -91,6 +94,7 @@
group_pairs_by_key
gcd
expand_term
expand_goal
callable
......@@ -250,7 +254,6 @@
;SWI Stuff
set set_x #;gcd
$member $append pp_dyn
dyntrace untr
))
......@@ -382,3 +385,4 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(@@ (logic guile-log guile-prolog copy-term) cp))
(set! (@@ (logic guile-log prompts) cp)
(@@ (logic guile-log guile-prolog copy-term) cp))
......@@ -40,8 +40,11 @@
#:use-module (ice-9 pretty-print)
#:replace (catch throw)
#:export ( unify_with_occurs_check copy_term
findall findall-fkn bagof setof sumof prodof
maxof minof lastof functor arg
findall findall-fkn bagof setof
sumof countof prodof maxof minof foldof
sumofn countofn prodofn maxofn minofn foldofn
lastof functor arg
var atomic compound nonvar
directive
procedure_name
......@@ -49,6 +52,8 @@
-var -atom
halt
uniq
^ :- #{,}# #{,,}# -> #{\\+}# op2= == =@= | -i>
#{\\=}# #{\\==}# #{\\=@=}# @< @> @>= @=< is
op2+ op2- op1- op1+ #{\\}# op2* op2/ // rem mod div
......@@ -242,6 +247,10 @@
(meta-mk-prolog-term mk-prolog-term-1 stx (x) (tp))
(meta-mk-prolog-term mk-prolog-term-2 stx (x y) (tp-x tp-y))
(meta-mk-prolog-term mk-prolog-term-3 stx (x y z) (tp-x tp-y tp-z))
(meta-mk-prolog-term mk-prolog-term-4 stx (x y z w)
(tp-x tp-y tp-z tp-w))
(meta-mk-prolog-term mk-prolog-term-5 stx (x y z w u)
(tp-x tp-y tp-z tp-w tp-u))
; ------------------------
(define-syntax-rule (meta-mk-scheme-op mk-scheme stx nm-code
......@@ -698,7 +707,7 @@ floor(x) (floor x)
(else
(type_error list y))))))))
(<define-guile-log-rule> (mac=.. a b) (sup=.. a b))
(mk-prolog-biop 'xfx "=.." tr=.. =.. mac=.. a a)
......@@ -812,7 +821,7 @@ floor(x) (floor x)
(<define> (findall-fkn template g l)
(<code> (gp-var-set *call-expression* g S))
(<var> (r)
(<fold> cons '() (<lambda> () (goal-eval g)) template r)
(<fold> cons '() (<lambda> (q) (goal-eval g)) template r)
(<if>
(<=> ,l ,(reverse (<lookup> r)))
<cc>
......@@ -824,6 +833,9 @@ floor(x) (floor x)
(<define-guile-log-rule> (findall-mac t g l)
(findall-fkn t g l))
(<define> (uniq X goal)
(<uniq> (</.> (goal-eval goal)) X))
(mk-prolog-term-3 tr-findall findall findall-mac a a a)
(<define> (bagof-fkn template g l)
(<recur> lp ((gg g) (q '()) (i 0))
......@@ -855,6 +867,58 @@ floor(x) (floor x)
(mk-prolog-term-3 tr-bagof bagof bagof-mac a a a)
(<define> (gen F X XX X0)
(<recur> lp ((Y X0))
(<var> (YY)
(<call> ((YY XX)) (</.> (<and> (= X Y) (F))))
(<or> <cc> (lp YY)))))
(<define> (foldof-fkn0 x xx x0 update)
(<recur> lp ((gg update) (q '()) (i 0))
(<let> ((gg (<lookup> gg)))
(cond
((<var?> gg)
(instantiation_error))
(else <cc>))
(<or>
(<var> (X A)
(<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons X q) (+ i 1))))
(<let*> ((t (<get-fixed> (cons x xx) '()))
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
(<var> (template)
(<fix-fold>
(lambda (x s) x)
x0
(<lambda> () (gen gg x xx x0))
x
fixed
x)))))))
(<define> (foldof-fkn x xx x0 update)
(foldof-fkn0 x xx x0
(</.> (goal-eval update))))
(<define> (foldofn-fkn m x xx x0 update)
(<var> (n nn)
(foldof-fkn0 (cons n x) (cons nn xx) (cons 0 x0)
(</.> (<let> ((n (<lookup> n))
(m (<lookup> m)))
(when (< n m))
(<=> nn (+ n 1))
(goal-eval update))))))
(<define-guile-log-rule> (foldof-mac x xx x0 update)
(foldof-fkn x xx x0 update))
(<define-guile-log-rule> (foldofn-mac n x xx x0 update)
(foldofn-fkn n x xx x0 update))
(mk-prolog-term-4 tr-foldof foldof foldof-mac a a a a)
(mk-prolog-term-5 tr-foldofn foldofn foldofn-mac a a a a a)
(define-syntax-rule (mkof sumof-fkn kons knil)
(<define> (sumof-fkn template g l)
(<recur> lp ((gg g) (q '()) (i 0))
......@@ -871,38 +935,98 @@ floor(x) (floor x)
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
(<var> (r)
(<fix-fold> kons knil (<lambda> () (goal-eval gg))
template fixed r)
(<=> ,l ,r))))))))
(mkof sumof-fkn + 0)
(<var> (t)
(<let> ((f (vector (list is t template))))
(<fix-fold> kons knil
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed l)))))))))
(define-syntax-rule (mkofn sumof-fkn kons knil)
(<define> (sumof-fkn n template g l)
(<recur> lp ((gg g) (q '()) (i 0))
(<let> ((gg (<lookup> gg)))
(cond
((<var?> gg)
(instantiation_error))
(else <cc>))
(<or>
(<var> (X A)
(<=> gg ,(vector (list "^" X A)))
(<cut> (lp A (cons X q) (+ i 1))))
(<let*> ((t (<get-fixed> template '()))
(q (<get-fixed> q '()))
(fixed (<get-fixed> gg (append t q))))
(<code> (gp-var-set *call-expression* gg S))
(<var> (t r)
(<let> ((f (vector (list is t template)))
(n (<lookup> n)))
(<fix-fold> (lambda (x s)
(cons (+ (car s) 1) (kons x (cdr s))))
(cons 0 knil)
(<lambda> ()
(goal-eval gg)
(goal-eval f))
t fixed r
(<lambda> (s) (when (< (car s) n))))
(<=> (_ . ,l) ,r)))))))))
(define (sum1 x s) (+ s 1))
(mkof countof-fkn sum1 0)
(mkofn countofn-fkn sum1 0)
(<define-guile-log-rule> (countof-mac t g l)
(countof-fkn t g l))
(<define-guile-log-rule> (countofn-mac n t g l)
(countofn-fkn n t g l))
(mk-prolog-term-3 tr-countof countof countof-mac a a a)
(mk-prolog-term-4 tr-countof countofn countofn-mac a a a a)
(mkof sumof-fkn + 0)
(mkofn sumofn-fkn + 0)
(<define-guile-log-rule> (sumof-mac t g l)
(sumof-fkn t g l))
(<define-guile-log-rule> (sumofn-mac n t g l)
(sumofn-fkn n t g l))
(mk-prolog-term-3 tr-sumof sumof sumof-mac a a a)
(mk-prolog-term-3 tr-sumof sumof sumof-mac a a a)
(mk-prolog-term-4 tr-sumofn sumofn sumofn-mac a a a a)
(mkof prodof-fkn * 1)
(mkof prodof-fkn * 1)
(mkofn prodofn-fkn * 1)
(<define-guile-log-rule> (prodof-mac t g l)
(prodof-fkn t g l))
(<define-guile-log-rule> (prodofn-mac n t g l)
(prodofn-fkn n t g l))
(mk-prolog-term-3 tr-prodof prodof prodof-mac a a a)
(mk-prolog-term-3 tr-prodof prodof prodof-mac a a a)
(mk-prolog-term-4 tr-prodofn prodofn prodofn-mac a a a a)
(mkof maxof-fkn max (- (inf)))
(mkof maxof-fkn max (- (inf)))
(mkofn maxofn-fkn max (- (inf)))
(<define-guile-log-rule> (maxof-mac t g l)
(maxof-fkn t g l))
(<define-guile-log-rule> (maxofn-mac n t g l)
(maxofn-fkn n t g l))
(mk-prolog-term-3 tr-maxof maxof maxof-mac a a a)
(mk-prolog-term-3 tr-maxof maxof maxof-mac a a a)
(mk-prolog-term-4 tr-maxofn maxofn maxofn-mac a a a a)
(mkof minof-fkn max (inf))
(mkof minof-fkn max (inf))
(mkofn minofn-fkn max (inf))
(<define-guile-log-rule> (minof-mac t g l)
(minof-fkn t g l))
(<define-guile-log-rule> (minofn-mac n t g l)
(minofn-fkn n t g l))
(mk-prolog-term-3 tr-minof minof minof-mac a a a)
(mk-prolog-term-3 tr-minof minof minof-mac a a a)
(mk-prolog-term-4 tr-minofn minofn minofn-mac a a a a)
(define (laster x y) x)
......@@ -1275,9 +1399,4 @@ floor(x) (floor x)
(define op1- op2-)
(define gop1+ gop2+)
(define gop1- gop2-)
......@@ -14,7 +14,7 @@
#:use-module (logic guile-log prolog dynamic)
#:use-module (logic guile-log prolog goal-transformers)
#:use-module (logic guile-log prolog goal-functors)
#:replace (sort plus delete string)
#:replace (sort plus delete string reverse)
#:export (memberchk keysort $skip_list is_list
term_variables
setup_call_cleanup
......@@ -175,7 +175,7 @@
(define (get-module-name)
(define (last x)
(let ((ret (car (reverse x))))
(let ((ret (car (scm-reverse x))))
(if (symbol? x)
(symbol->string x)
x)))
......@@ -418,10 +418,15 @@
((#(("op2-" ,k v)) . u)
(lp k u (cons v dg) g))
((#(("op2-" kk v)) . u)
(lp kk u (list v) (cons (vector (list op2- k (reverse dg))) g)))
(lp kk u (list v) (cons (vector (list op2- k (scm-reverse dg))) g)))
(()
(<=> groups
,(reverse (cons (vector (list op2- k (reverse dg))) g)))))))
,(scm-reverse (cons (vector (list op2- k (scm-reverse dg))) g)))))))
(()
(<=> groups ()))))
(<=> groups ())))
)
(define scm-reverse (@@ (guile) reverse))
(<define> (reverse x y)
(<let> ((x (<scm> x))
(y (<scm> y)))
(<=> ,(scm-reverse x) y)))
......@@ -1209,7 +1209,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
// printf("gc0: %d %d\n",gp->n, gp->nrem);
if(gp->n > 100 && gp->nrem*20 > gp->n)
{
printf("gc: %d %d\n",gp->n, gp->nrem);
//printf("gc: %d %d\n",gp->n, gp->nrem);
if(gp->n > 100000) doit = 1;
SCM *pt1,*pt2, *pt3, *pt1_insert, *pt2_insert,*pt3_insert,
*last_redo = gp->gp_cstack,
......
......@@ -61,14 +61,14 @@
(<define> (<umember> X L)
(<match> (#:name '<umember>) (L)
((Y . _) (<cut> (if (m= S X Y) <cc> <fail>)))
((Y . _) (if (m= S X Y) <cc> <fail>))
((_ . U) (<cut> (<umember> X U)))
(_ (<cut> <fail>))))
(<define> (new-machine) <cc>)
(<define> (<fold> kons knil Lam X L)
(<define> (<fold> kons knil Lam X L . E)
(<let> ((p P))
(<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
(lguard
......@@ -77,6 +77,7 @@
(<and>
(new-machine)
(<funcall> Lam)
(if (pair? E) ((car E) (cdr l)) <cc>)
(<code>
(let* ((a (<cp> X))
(b (ref-attribute-constructors S)))
......@@ -90,13 +91,14 @@
(<with-fail> p (<=> ,(cdr l) L)))))))))))
(<define> (<fold-step> kons knil Lam X L)
(<define> (<fold-step> kons knil Lam X L . E)
(<let-with-lr-guard> wind lguard rguard ((l (cons '() knil)))
(lguard
(</.>
(<and>
(new-machine)
(<funcall> Lam)
(if (pair? E) ((car E) (cdr l)) <cc>)
(<code>
(let* ((a (<cp> X))
(b (ref-attribute-constructors S)))
......@@ -106,38 +108,51 @@
(do-attribute-constructors (car l))
(<=> ,(cdr l) L)
(rguard (</.> <cc>)))))))
(<define> (<uniq> Lam Y)
(<let-with-lr-guard> wind lguard rguard ((l '()))
(lguard
(</.>
(Lam)
(<not> (<umember> Y l))
(<code> (set! l (cons (<cp> Y) l)))
(do-attribute-constructors)
(rguard (</.> <cc>))))))
(<let> ((y (<cp> Y)))
(<not> (<umember> y l))
(<code> (set! l (cons y l)))
(do-attribute-constructors)
(rguard (</.> <cc>)))))))
;; This is a slow n² algorithm using the functional database
;; Indexing Framework, it can be designed to be essentially n¹
;; It has it merrits though in getting bagof for infinit sets.
;; But then a full prolog bagof algorithm is impossible without a major
;; rework of the underlying engine.
(<define> (<fix-fold> kons knil Lam X Y L)
(<define> (<fix-fold> kons knil Lam X Y L . E)
(<var> (Z)
(<call> ((Z Y))
(<uniq> Lam Y))
(<fold> kons knil
(</.> (Lam) (if (m= S Y Z) <cc> <fail>))
X L)
(<uniq> (<lambda> () (Lam)) Y))
(<and!>
(<apply> <fold> kons knil
(<lambda> ()
(Lam)
(if (m= S Y Z) <cc> <fail>))
X L E))
(<=> Y Z)))
(<define> (<fix-fold-step> kons knil Lam X Y L)
(<define> (<fix-fold-step> kons knil Lam X Y L . E)
(<var> (Z)
(<call> ((Z Y))
(<uniq> Lam Y))
(<fold-step> kons knil (</.> (Lam) (if (m= S Y Z) <cc> <fail>)) X L)))
(<apply> <fold-step> kons knil
(<lambda> (kons)
(Lam kons)
(if (m= S Y Z)
<cc>
<fail>))
X L E)))
(<define> (<f-vector> f . x)
(<recur> loop ((x x) (l '()))
......
......@@ -3,6 +3,7 @@
#:autoload (system base compile) (compile compile-file)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog set)
#:use-module (logic guile-log guile-prolog attribute)
......
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