set theory works better

parent 447a85c3
......@@ -4,7 +4,8 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (<set> set? set-hash set-n
make-set-from-assoc make-set-from-assoc-mac set-size))
make-set-from-assoc make-set-from-assoc-mac set-size
set-hash))
#|
This takes an assoc like library and transforms it to an ordered/undordered
......@@ -132,13 +133,12 @@ Output: set operations and iteratables
(define-tool make-set-from-assoc make-set-from-assoc-mac
(null assoc acons delete hash mk-kv kv? kv-key kv-val sizefkn
value? order? equal? ar->l l->ar)
value? order? equal? ar->l l->ar)
(define (make-set '() null 0 0 (list set->kvlist)))
(define size 10000000000000)
(define size (@@ (ice-9 set vhashx) *size*))
(define (l-serie app)
(define mt null)
(let lp ((app app))
......@@ -163,6 +163,7 @@ Output: set operations and iteratables
(if (set? x)
x
(let ((kv (mk-kv x)))
(hash kv size)
(make-set (l->ar (list kv)) (acons kv null) 1 (hash kv size)
(list set->kvlist)))))
......@@ -240,6 +241,44 @@ Output: set operations and iteratables
#f)
#f))))
(define (4 x1 x2 y1 y2)
(match (list (make-one x1)
(make-one x2)
(make-one y1)
(make-one y2))
((($ <set> lx1 mx1 nx1 hx1)
($ <set> lx2 mx2 nx2 hx2)
($ <set> ly1 my1 ny1 hy1)
($ <set> ly2 my2 ny2 hy2))
(if (= (logxor hx1 hx2) (logxor hy1 hy2))
(if (= (+ nx1 nx2) (+ ny1 ny2))
(let ()
(define (try lx1 mx1)
(let lp ((lx1 (l-serie lx1)))
(if (pair? lx1)
(let ((kv (car lx1)))
(if kv
(let ((kvx (assoc kv mx1)))
(if kvx
(let ((kvy1 (assoc kv my1)))
(if kvy1
(if (equal? kvx kvy1)
(lp (cdr lx1))
#f)
(let ((kvy2 (assoc kv my2)))
(if kvy2
(if (equal? kvx kvy2)
(lp (cdr lx1))
#f)
#f))))
(lp (cdr lx1))))
(lp (cdr lx1))))
#t)))
(and (try lx1 mx1)
(try lx2 mx2)))
#f)
#f))))
(define (o x y)
(match (list (make-one x) (make-one y))
((($ <set> lx mx nx hx) ($ <set> ly my ny hy))
......@@ -302,6 +341,84 @@ Output: set operations and iteratables
#f)
#f)))))
(define (o4 x1 x2 y1 y2)
(match (list (make-one x1) (make-one x2) (make-one y1) (make-one y2))
((($ <set> lx1 mx1 nx1 hx1)
($ <set> lx2 mx2 nx2 hx2)
($ <set> ly1 my1 ny1 hy1)
($ <set> ly2 my2 ny2 hy2))
(let ()
(define (do-the-iteration)
(define (assocx kv)
(let ((kvx (assoc kv mx1)))
(if kvx
kvx
(assoc kv mx2))))
(define (assocy kv)
(let ((kvx (assoc kv my1)))
(if kvx
kvx
(assoc kv my2))))
(let lp ((lx (l-serie (make-append lx1 lx2)))
(ly (l-serie (make-append ly1 ly2))))
(if (pair? lx)
(let ((kvx (car lx)))
(if kvx
(begin
(let ((kvxx (assocx kvx)))
(if kvxx
(if (order? kvxx)
(set! kvx kvxx)
(let ((kvy (assocy kvxx)))
(if kvy
(if (order? kvy)
(set! kvx kvxx)
(lp (cdr lx) ly))
#f)))
(lp (cdr lx) ly)))
(let lp2 ((ly ly))
(if (pair? ly)
(let ((kvy (car ly)))
(begin
(let ((kvyy (assocy kvy)))
(if kvyy
(if (order? kvyy)
(set! kvy kvyy)
(let ((kvxx
(assocx kvyy)))
(if kvxx
(if (equal? kvxx
kvx)
(lp (cdr lx) (cdr ly))
(if (order? kvxx)
#f
(lp2 (cdr ly))))
#f)))
(lp2 (cdr ly))))
(if (equal? kvx kvy)
(lp (cdr lx) (cdr ly))
#f)))
#f)))
(lp (cdr lx) ly)))
(let lp2 ((ly ly))
(if (pair? ly)
(let ((ky (assocy (car ly))))
(if ky
#f
(lp2 (cdr ly))))
#t)))))
(if (= (logxor hx1 hx2) (logxor hy1 hy2))
(if (= (+ nx1 nx2) (+ ny1 ny2))
(do-the-iteration)
#f)
#f)))))
(define (next-mute lp ll l m n h)
(lp (cdr ll) l m n h))
......@@ -313,8 +430,9 @@ Output: set operations and iteratables
(lp (cdr ll) (cons kv l) m n h))
(define (next-add-kv lp ll l m n h kv kv*)
(lp (cdr ll) (cons kv* l) (acons kv* m)
(+ n 1) (logxor h (hash kv* size))))
(lp (cdr ll) (cons kv* l) (acons kv* m)
(+ n 1) (begin (hash kv* size)
(logxor h (hash kv* size)))))
(define (next-add-l lp ll l m n h kv*)
(lp (cdr ll) (cons kv* l) m n h))
......@@ -619,8 +737,10 @@ Output: set operations and iteratables
r)))
(values #:member member
#:= #:u u #:n n #:- s- #:+ s+ #:< #:<=
#:o= o #:ou ou #:on on #:o- o- #:o+ o+ #:o< o #:o<= o
#:= #:=4 4
#:u u #:n n #:- s- #:+ s+ #:< #:<=
#:o= o #:o=4 o4
#:ou ou #:on on #:o- o- #:o+ o+ #:o< o #:o<= o
#:n- tripple
#:in in #:fold fold #:map map #:for-each for-each #:empty
#:set->list set->list #:set->assoc set->assoc
......
......@@ -30,6 +30,8 @@
#:export (vhashx-null vhashx? vhashx-length vhashx-cons vhashx-assoc))
(define *size* 100000000000000000)
;;; Author: Ludovic Courtès <ludo@gnu.org>
;;;
;;; Commentary:
......
......@@ -256,7 +256,8 @@
(if (eq? ch #\.)
(lp #f ch (cons #\. r) #t)
(lp #f ch (cons #\. r) #f))
(list->string (reverse (cons #\. r))))))))
(list->string ((@ (guile) reverse)
(cons #\. r))))))))
(#\,
(read-char)
......
......@@ -18,20 +18,30 @@
mk-prolog-biop
->
s a))
#:export
(
(
set_to_list set_to_kvlist to_set
list_to_set
mapset
complex_set_p
advanced-set-printer))
(define vsetx-empty)
(<define> (ele0 x)
(<<match>> (#:mode -) ((<lookup> x))
(#(("op2-" k v))
(<cc> (vosetx-union S (mk-kvx (<scm> k) (<lookup> v)))
vsetx-empty))
(<and>
(<values> (kk) (ele k))
(<values> (vv) (ele v))
(<cc> (vosetx-union S (mk-kvx (<scm> kk) (<lookup> vv)))
vsetx-empty)))
(x
(<cc> vsetx-empty
(vosetx-union S (mk-kx (<scm> x)))))))
(<and>
(<values> (xx) (ele x))
(<cc> vsetx-empty
(vosetx-union S (mk-kx (<scm> xx))))))))
(<define> (ele1 x)
(<<match>> (#:mode -) ((<lookup> x))
......@@ -50,7 +60,11 @@
(#(#:brace v)
(<and>
(<values> (a c) (ele1 v))
(<cc> (make-set- a vsetx-empty c #f #f))))
(cond
((eq? a vsetx-empty)
(<cc> c))
(else
(<cc> (make-set- a vsetx-empty (vosetx-difference S c a) #f #f))))))
(x (<cc> x))))
......@@ -64,12 +78,21 @@
(<values> (x) (ele x))
(<ret> (f S x)))
(set! (@@ (logic guile-log prolog goal-functors) scm-brace-eval)
(lambda (s x)
(ele s
(lambda () #f)
(lambda (s p x) x)
x)))
(define (fail) #f)
(define (cc s p x) x)
(eval-when (compile eval load)
(begin
(set! (@@ (logic guile-log prolog goal-functors) scm-brace-eval)
(lambda (s x)
(ele s
(lambda () #f)
(lambda (s p x) x)
x)))
(set! (@@ (logic guile-log prolog goal) brace-stx-scm)
(lambda (stx x)
#`(ele S fail cc
`#,((@@ (logic guile-log prolog var) arg) stx x))))))
(define (make2 s f x y)
(make-2 s (lambda () #f) (lambda x #t) f x y))
......@@ -79,7 +102,9 @@
(define-syntax-rule (mk2 nm1 nm2)
(define-syntax-rule (nm1 x y)
(make2 S nm2 (gp-lookup x S) (gp-lookup y S))))
(make2 S nm2
(gp-lookup x S)
(gp-lookup y S))))
(define complex_set_p (make-fluid #t))
(<wrap> add-fluid-dynamics complex_set_p)
......@@ -96,10 +121,11 @@
(mk2 set_difference_ (wrap vsetx-difference vosetx-difference ))
(mk2 set_intersection_ (wrap vsetx-intersection vosetx-intersection ))
(mk-scheme-biop 'yfx "∪" tr- set_union_ s s)
(mk-scheme-biop 'yfx "⊕" tr- set_addition_ s s)
(mk-scheme-biop 'yfx "∖" tr- set_difference_ s s)
(mk-scheme-biop 'yfx "∩" tr- set_intersection_ s s)
(eval-when (compile load eval)
(mk-scheme-biop 'yfx "∪" tr- set_union_ s s)
(mk-scheme-biop 'yfx "⊕" tr- set_addition_ s s)
(mk-scheme-biop 'yfx "∖" tr- set_difference_ s s)
(mk-scheme-biop 'yfx "∩" tr- set_intersection_ s s))
(define-syntax-rule (mk1 nm1 nm2)
(define-syntax-rule (nm1 x) (make1 S nm2 (gp-lookup x S))))
......@@ -111,7 +137,7 @@
(<define> (memb x y) (when (make2 S vsetx-in
(<lookup> x) (<lookup> y))))
(<define> (equiv x y) (when (make2 S (wrap vsetx-equal? vosetx-equal?)
(<define> (equiv x y) (when (make2 S vsetx-equal?
(<lookup> x) (<lookup> y))))
(<define> (subset x y) (when (make2 S (wrap vsetx-subset< vosetx-subset<)
(<lookup> x) (<lookup> y))))
......@@ -122,12 +148,15 @@
(define (mq x)
(define (u x)
(if (equal? x '(nonvalue))
#f
x))
(if (pair? x)
(if (equal? (cdr x) '(nonvalue))
(cons (car x) #f)
x)
(cons (car x) (u (cdr x)))
(if x
(cons (get-k x) (get-v x))
(cons (get-k x) (u (get-v x)))
x)))
......@@ -162,7 +191,7 @@
(mk-prolog-biop 'xfx "⊇" tr- supseteq s s)
(mk-prolog-biop 'xfx "⊃" tr- supset s s)
(mk-prolog-biop 'xfx "≡" tr- equiv s s)
(mk-prolog-biop 'xfx "∈" tr- member a a)
(mk-prolog-biop 'xfx "∈" tr- member a s)
(mk-prolog-biop 'xfx "≡" tr- equiv s s)
......@@ -178,3 +207,28 @@
(<define> (to_set x y) (<=> y ,(make1 S ->vsetx (<lookup> x))))
(<define> (rev l ll) (<=> ll ,(reverse (<scm> l))))
(compile-prolog-string
"
f(X,Y) :- Y is X + X.
list_to_set(L,S) :-
rev(L,LL),
list_to_set(LL,∅,S).
list_to_set([],S,S).
list_to_set([X|L],S,SS) :-
(
(\\+var(X), X = K-V) ->
S2 is {K-V} ∪ S;
S2 is {X} ∪ S
),
list_to_set(L,S2,SS).
mapset(S,Map,SS) :-
findall(V, (_-V ∈ (Map ∩ S), V \\= #f),L),
list_to_set(L,SS).
")
......@@ -206,7 +206,7 @@
quoted ignore_ops numbervars write_option
;; replacings
append length open close member
append length open close member
;; Error functions
error type_error instantiation_error domain_error
......
......@@ -136,6 +136,10 @@
((x) (goal stx x))))
(define (brace-stx-scm . l)
(warn "X is {...}, is not supported as compilation target")
#f)
;;We do not, use eval-scm to eval objects in scm contexts
(define (scm stx x)
(define (sarg stx x) #``#,(arg stx x))
......@@ -153,6 +157,9 @@
((#:group x)
(scm stx x))
((#:lam-term #f l _ _ _)
(brace-stx-scm stx x))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
......
......@@ -205,7 +205,7 @@
))
(xfy 400 :)
,@(map (lambda (x) `(yfx 500 ,x)) '(+ - "/\\" "\\/" xor))
,@(map (lambda (x) `(yfx 400 ,x)) '( * / // rdiv << >> mod rem))
,@(map (lambda (x) `(yfx 400 ,x)) '( * / // rdiv << >> mod rem))
(xfx 200 **)
(xfy 200 ^)
(xf 200 )
......@@ -237,9 +237,9 @@
=:= =< == "=\\=" > >= @< @=< @> @>= "\\=" "\\==" as is
))
(xfy 600 :)
,@(map (lambda (x) `(yfx 500 ,x)) '(+ - "/\\" "\\/" xor))
,@(map (lambda (x) `(yfx 500 ,x)) '(+ - "/\\" "\\/" xor))
(fx 500 ?)
,@(map (lambda (x) `(yfx 400 ,x)) '(* / // div rdiv << >> mod rem))
,@(map (lambda (x) `(yfx 400 ,x)) '(* / // div rdiv << >> mod rem))
(xfx 200 **)
(xfy 200 ^)
,@(map (lambda (x) `(fy 200 ,x)) '(- + "\\"))
......@@ -703,9 +703,7 @@
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(xx (c1)
(<or> (.. (atom c0))
(<p-cc> #f)))
(.. (c1) (atom c0))
(.. (c2) (l c1))
(xx (cl) (<or>
(<and>
......@@ -731,6 +729,30 @@
`(#:lam-term ,c1 ,(<scm> c3) ,cl ,n ,m))))))
mk-id)))
(define set-tok
(let* ((l (f-tag "{"))
(r (f-tag "}"))
(l! (f-tag! "{"))
(r! (f-tag! "}"))
(e (letrec ((body (lambda (n)
(f*
(f-or
ws+
(f-seq l! (Ds (body (+ n 1))) r!)
(f-not! (f-or l r)))))))
(mk-token (body 0)))))
(p-freeze 'set-tok
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(.. (c2) (l c0))
(.. (c3) (expr c2))
(.. (c4) (r c3))
(<p-cc>
`(#:lam-term #f ,(<scm> c3) #f ,n ,m))))
mk-id)))
(define true/false
(let ((tag (mk-token (f-seq (f-or (f-tag! "#t") (f-tag! "#f"))
(f-not* rest-var)))))
......@@ -868,6 +890,7 @@
char list-tok true/false
termvar-tok #;term-binop-tok #;termop-tok
termstring-tok term-tok term-unop scm-tok lam-tok
set-tok
number qstring dstring atom variable symsym
#;op-tok))
......
......@@ -118,6 +118,8 @@
mxequal?))
(define <<set>> (@ (ice-9 set complement) <set>))
(define-inlinable (id x) x)
(define-record-type <kv>
(mk-kv k v)
......@@ -133,13 +135,13 @@
(define-syntax-rule (mk-set . l)
(call-with-values (lambda () (make-set-from-assoc . l))
(lambda* (#:key member
n- = u n - + < <=
o= ou on o- o+ o< o<=
n- = =4 u n - + < <=
o= o=4 ou on o- o+ o< o<=
in fold map for-each empty set->list set->assoc set->kvlist
make-one)
(call-with-values (lambda ()
(make-complementable-set
member empty u n - n- = set-size set? make-one))
member empty u n - n- = =4 set-size set? make-one))
(lambda* (#:key world u n c + - = < <= ->set memb #:allow-other-keys )
(define c< < )
(define c<= <=)
......@@ -148,7 +150,8 @@
(call-with-values (lambda ()
(make-complementable-set
member
empty ou on o- n- o= set-size set? make-one))
empty ou on o- n- o= o=4
set-size set? make-one))
(lambda* (#:key ou on oc o+ o- = < <= #:allow-other-keys )
(define o< < )
(define o<= <=)
......@@ -324,26 +327,32 @@
(define sfluid (make-fluid #f))
(define (xhash x size)
(let* ((s (fluid-ref sfluid)))
(let lp ((x x))
(let ((x (gp-lookup x s)))
(umatch (#:mode -) (x)
(#(x)
(lp x))
((x . l)
(logxor (lp x) (lp l)))
(_
(cond
((set? x)
(modulo (set-hash x) size))
(else
(hash x size)))))))))
(let lp ((x x))
(umatch (#:mode -) (x)
(#(x)
(lp x))
((x . l)
(logxor (lp x) (lp l)))
(_
(cond
((set? x)
(modulo (set-hash x) size))
((cset? x)
(match x
(($ <<set>> a b c p)
(if p
(modulo (set-hash c) size)
(modulo (logxor (set-hash a) (set-hash c))
size)))))
(else
(hash x size)))))))
(define (xequal?- x y)
(if (and (set? x) (set? y))
(vsetx-equal? x y)
(if (and (or (set? x) (cset? x)) (or (set? x) (cset? y)))
(let ((s (fluid-ref sfluid)))
(vsetx-equal? s x y))
(equal? x y)))
(define (xequal? x y z w) (xequal?- x y))
......@@ -353,7 +362,7 @@
(let ((x (gp-lookup s x))
(y (gp-lookup s y)))
(if (and (set? x) (set? y))
(vosetx-equal? x y)
(vosetx-equal? #f x y)
((<lambda> () (<==> x y))
s (lambda () #f) (lambda (p cc) #t))))))
(define (oxequal? x y z w) (oxequal?- x y))
......@@ -421,7 +430,7 @@
(eq? (get-e? kx1) (get-e? kx2))))
(define-inlinable (x-hash kx s) ((get-h kx) (get-k kx) s))
(define-inlinable (x-hash kx s) (get-k kx) ((get-h kx) (get-k kx) s))
;; A new thread should spur a new hastable here
......@@ -470,7 +479,7 @@
(vsetx-equal?-
vsetx-union-
vsetx-intersection-
vsetx-difference
vsetx-difference-
vsetx-addition-
vsetx-complement-
vsetx-subset<-
......@@ -511,7 +520,7 @@
(wrap vsetx-equal? vsetx-equal?-)
(wrap vsetx-union vsetx-union-)
(wrap vsetx-intersection vsetx-intersection-)
(wrap vsetx-differenc vsetx-difference)
(wrap vsetx-difference vsetx-difference-)
(wrap vsetx-addition vsetx-addition-)
(wrap vsetx-complement vsetx-complement-)
(wrap vsetx-subset< vsetx-subset<-)
......
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