prolog interface for set manipulation

parent 276e1b8c
......@@ -20,7 +20,6 @@ PSSOURCES = \
logic/guile-log/ck.scm \
logic/guile-log/code-load.scm \
logic/guile-log/vlist.scm \
logic/guile-log/vset.scm \
logic/guile-log/indexer.scm \
logic/guile-log/umatch.scm \
logic/guile-log/attributed.scm \
......
......@@ -5,7 +5,7 @@
#:use-module (srfi srfi-9 gnu)
#:export (make-complementable-set
make-complementable-set-mac
<set> set? Ω
<set> cset? Ω
;;;Example complementable oredered set builed out of srfi-1 listsets
*set-equality-predicate*
......@@ -89,7 +89,7 @@ Assoc based maps
(define-record-type <set>
(make-set- set complement meta)
set?
cset?
(set set-set)
(complement set-complement)
(meta set-meta))
......@@ -113,7 +113,7 @@ Assoc based maps
(begin code ...))))
(define-tool make-complementable-set make-complementable-set-mac
( union intersection difference tripple equiv? set-size)
( union intersection difference tripple equiv? set-size set?)
(define Ω (make-set- #t))
......
......@@ -2,7 +2,8 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (<set> set? make-set-from-assoc make-set-from-assoc-mac set-size))
#:export (<set> set? set-hash
make-set-from-assoc make-set-from-assoc-mac set-size))
#|
This takes an assoc like library and transforms it to an ordered/undordered
......@@ -152,17 +153,16 @@ Output: set operations and iteratables
(define (set->* repr s)
(match (make-one s)
(($ <set> ll mm n h)
(let lp ((m null) (l '()) (ll (l-serie ll)))
(let lp ((l '()) (ll (l-serie ll)))
(if (pair? ll)
(let ((kv (car ll)))
(if kv
(let ((kv (assoc kv mm)))
(if (and kv (not (assoc kv m)))
(lp (acons kv m) ;; hash
(cons (repr kv) l) ;; li
(if kv
(lp (cons (repr kv) l) ;; li
(cdr ll)) ;; itarator
(lp m l (cdr ll))))
(lp m l (cdr ll))))
(lp l (cdr ll))))
(lp l (cdr ll))))
(reverse l))))))
(define (reprl x) (value? x) x (kv-key x))
......@@ -556,7 +556,7 @@ Output: set operations and iteratables
(s+ x (apply s+ y l)))))
(define (fold f seed set)
(let lp ((l (l-serie (set-list set)))
(let lp ((l (l-serie (set-list set)))
(m (set-assoc set)))
(let lp ((l l) (seed seed))
(if (pair? l)
......
......@@ -435,7 +435,7 @@ output_and_more(V,N,More) :-
(when[(eq? (fluid-ref -mute?-) #t)] -> more ;
(
(V==[] -> (write(\"yes\"),nl) ; (once(vtosym(V,VV)),
write_out(VV,N),nl)),
setenv,write_out(VV,N),nl)),
(More=#t -> more ; throw(finish))
)
).
......@@ -511,7 +511,8 @@ solve(V,N,X) :- set_once,X,
(with-atomic-rec
(rec-00 vtosym_ vtosym-guard doit-at-rec)))
(<define> (setenv)
(<code> (fluid-set! (@@ (logic guile-log vset) sfluid) S)))
......
(define-module (logic guile-log guile-prolog set)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (gp-lookup gp->scm))
......@@ -13,13 +14,54 @@
mk-scheme-biop
mk-scheme-unop
mk-prolog-biop
->
s a))
#:export
(
set_to_list))
(<define> (ele1 x)
(<<match>> (#:mode -) (x)
(#((,op2- k v))
(<cc> (mk-kvx (<lookup> k) (<lookup> v))))
(#((,prolog-and x y))
(<and>
(<values> (x) (ele1 x))
(<values> (y) (ele1 y))
(<cc> (vosetx-union S x y))))
(x
(<cc> (mk-kx x)))))
(<define> (ele x)
(<<match>> (#:mode -) (x)
(#(#:brace v)
(ele1 v))
(x (<cc> x))))
(<define> (make-2 f x y)
(<values> (x) (ele x))
(<values> (y) (ele y))
(<ret> (f S x y)))
(<define> (make-1 f x)
(<values> (x) (ele x))
(<ret> (f S x)))
(define (make2 s f x y)
(make-2 s (lambda () #f) (lambda x #t) f x y))
(define (make1 s f x)
(make-1 s (lambda () #f) (lambda x #t) f x))
(define-syntax-rule (mk2 nm1 nm2)
(define-syntax-rule (nm1 x y) (nm2 S (gp-lookup x S) (gp-lookup y S))))
(define-syntax-rule (nm1 x y)
(make2 S nm2 (gp-lookup x S) (gp-lookup y S))))
(mk2 set_union_ vosetx-union )
(mk2 set_addition_ vosetx-addition )
......@@ -32,16 +74,21 @@
(mk-scheme-biop 'yfx "∩" tr- set_intersection_ s s)
(define-syntax-rule (mk1 nm1 nm2)
(define-syntax-rule (nm1 x) (nm2 S (gp-lookup x S))))
(define-syntax-rule (nm1 x) (make1 S nm2 (gp-lookup x S))))
(mk1 set_complement vosetx-complement)
(mk-scheme-unop 'xf "ᶜ" tr- set_complement s)
(<define> (memb x y) (when (vsetx-in S (<lookup> x) (<lookup> y))))
(<define> (equiv x y) (when (vosetx-equal? S (<lookup> x) (<lookup> y))))
(<define> (subset x y) (when (vosetx-subset< S (<lookup> x) (<lookup> y))))
(<define> (subseteq x y) (when (vosetx-subset<= S (<lookup> x) (<lookup> y))))
(<define> (memb x y) (when (make2 S vsetx-in
(<lookup> x) (<lookup> y))))
(<define> (equiv x y) (when (make2 S vosetx-equal?
(<lookup> x) (<lookup> y))))
(<define> (subset x y) (when (make2 S vosetx-subset<
(<lookup> x) (<lookup> y))))
(<define> (subseteq x y) (when (make2 S vosetx-subset<=
(<lookup> x) (<lookup> y))))
(<define> (supset x y) (subset y x))
(<define> (supseteq x y) (subseteq y x))
......@@ -51,4 +98,4 @@
(mk-prolog-biop 'xfx "⊃" tr- supset s s)
(mk-prolog-biop 'xfx "≡" tr- equiv s s)
(<define> (set_to_list x) (vsetx->list S (<lookup> x)))
(<define> (set_to_list x y) (<=> y ,(make1 S vsetx->list x)))
......@@ -1549,7 +1549,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
SCM * stack[110];
int sp;
sp = 0;
//gp_format2("(gp-unify! ~a ~a)~%",GP_UNREF(id1),GP_UNREF(id2));
gp_format2("(gp-unify! ~a ~a)~%",GP_UNREF(id1),GP_UNREF(id2));
#define U_NEXT \
{ \
if(SCM_UNLIKELY(sp==0)) \
......@@ -1796,6 +1796,8 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
SCM scm2 = GP_SCM(id2);
scm_check:
//printf("scn_check\n");
if(SCM_I_IS_VECTOR(scm1) && SCM_I_IS_VECTOR(scm2))
{
int n = SCM_I_VECTOR_LENGTH(scm1);
......@@ -3128,7 +3130,7 @@ SCM_DEFINE(gp_m_unify, "gp-m-unify!", 3, 0, 0, (SCM x, SCM y, SCM s),
{
SCM ret, l[3], ggp, ci;
struct gp_stack *gp;
gp_debus0("gp-unify-m!>\n");
//printf("gp-unify-m!>\n");
UNPACK_ALL(ci,l[0],ggp,gp,s,"failed to unpack in gp_m_unify");
if(vlist_p(l[0]))
{
......
(define-module (logic guile-log vset)
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log) #:select (<==> <lambda>))
#:use-module ((logic guile-log) #:select (<and> <==> <=> <pp> <lambda>))
#:use-module (logic guile-log umatch)
#:use-module (ice-9 set vhashx)
#:use-module (ice-9 set set)
......@@ -125,22 +125,22 @@
(define-syntax-rule (mk-set . l)
(call-with-values (lambda () (make-set-from-assoc-mac . l))
(call-with-values (lambda () (make-set-from-assoc . l))
(lambda* (#:key n-
= u n - + < <=
o= ou on o- o+ o< o<=
in fold map for-each empty set->list set->assoc set->kvlist)
(call-with-values (lambda ()
(make-complementable-set-mac
empty u n - n- = set-size))
(make-complementable-set
empty u n - n- = set-size set?))
(lambda* (#:key world u n c + - = < <= #:allow-other-keys )
(define c< < )
(define c<= <=)
(define c= = )
(call-with-values (lambda ()
(make-complementable-set-mac
empty ou on o- n- o= set-size))
(make-complementable-set
empty ou on o- n- o= set-size set?))
(lambda* (#:key ou on oc o+ o- = < <= #:allow-other-keys )
(define o< < )
(define o<= <=)
......@@ -307,12 +307,19 @@
(define sfluid (make-fluid #f))
(define (xhash x size)
(let ((s (fluid-ref sfluid)))
(let* ((s (fluid-ref sfluid))
(x (gp-lookup x s)))
(let lp ((x x))
(umatch (#:mode -) (x)
((x . l)
(logxor (lp x) (lp l)))
(x (hash (gp-lookup x s) size))))))
(x
(cond
((set? x)
(modulo (set-hash x) size))
(else
(hash x size))))))))
(define (xequal? x y)
(let ((s (fluid-ref sfluid)))
((<lambda> () (<==> x y))
......@@ -453,28 +460,28 @@
(wrap vsetx-equal? vsetx-equal?-)
(wrap vsetx-union vsetx-union-)
(wrap vsetx-intersection setx-intersection-)
(wrap vsetx-differenc setx-difference)
(wrap vsetx-addition setx-addition-)
(wrap vsetx-complement setx-complement-)
(wrap vsetx-subset< setx-subset<-)
(wrap vsetx-subset<= setx-subset<=-)
(wrap vosetx-equal? osetx-equal?-)
(wrap vosetx-union osetx-union-)
(wrap vosetx-intersection osetx-intersection-)
(wrap vosetx-difference osetx-difference-)
(wrap vosetx-addition osetx-addition-)
(wrap vosetx-complement osetx-complement-)
(wrap vosetx-subset< osetx-subset<-)
(wrap vosetx-subset<= osetx-subset<=-)
(wrap vset-in vset-in-)
(wrap vsetx-fold setx-fold-)
(wrap vsetx-map setx-map-)
(wrap vsetx-for-each setx-for-each-)
(wrap vsetx-empty setx-empty-)
(wrap vsetx-world setx-world-)
(wrap vsetx->list setx->list-)
(wrap vsetx->assoc setx->assoc-)
(wrap vsetx->kvlist- setx->kvlist-)
(wrap vsetx-intersection vsetx-intersection-)
(wrap vsetx-differenc vsetx-difference)
(wrap vsetx-addition vsetx-addition-)
(wrap vsetx-complement vsetx-complement-)
(wrap vsetx-subset< vsetx-subset<-)
(wrap vsetx-subset<= vsetx-subset<=-)
(wrap vosetx-equal? vosetx-equal?-)
(wrap vosetx-union vosetx-union-)
(wrap vosetx-intersection vosetx-intersection-)
(wrap vosetx-difference vosetx-difference-)
(wrap vosetx-addition vosetx-addition-)
(wrap vosetx-complement vosetx-complement-)
(wrap vosetx-subset< vosetx-subset<-)
(wrap vosetx-subset<= vosetx-subset<=-)
(wrap vsetx-in vsetx-in-)
(wrap vsetx-fold vsetx-fold-)
(wrap vsetx-map vsetx-map-)
(wrap vsetx-for-each vsetx-for-each-)
(wrap vsetx-empty vsetx-empty-)
(wrap vsetx-world vsetx-world-)
(wrap vsetx->list vsetx->list-)
(wrap vsetx->assoc vsetx->assoc-)
(wrap vsetx->kvlist vsetx->kvlist-)
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