equal? works on sets

parent db1170ec
(define-module (ice-9 set complement)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (ice-9 set set)
#:use-module (srfi srfi-1)
......@@ -91,6 +92,7 @@ using that predicate
(define advanced-set-printer #t)
#;
(define-record-type <set>
(make-set- map map-complement set set-complement? meta)
cset?
......@@ -100,7 +102,26 @@ using that predicate
(set-complement? set-complement?)
(meta set-meta))
(set-record-type-printer! <set>
(define-class <set> ()
(map #:getter set-map
#:init-keyword #:map)
(map-complement #:getter set-map-complement
#:init-keyword #:map-complement)
(set #:getter set-set
#:init-keyword #:set)
(set-complement? #:getter set-complement?
#:init-keyword #:complement?)
(meta #:getter set-meta
#:init-keyword #:meta))
(define (make-set- map map-complement set set-complement? meta)
(make <set> #:map map #:map-complement map-complement #:set set
#:complement? set-complement? #:meta meta))
(define (cset? x)
(eq? (class-of x) <set>))
(define (set-printer vl port)
(lambda (vl port)
(let ((c (set-set vl))
(a (set-map vl))
......@@ -117,6 +138,18 @@ using that predicate
(format port "(~a∖~a ∪ ~aᶜ)" a b c)
(format port "(~a∖~a ∪ ~a)" a b c)))))))
(define *equal?* (make-fluid (lambda (x y) (eq? x y))))
(define-method (equal? (x <set>) (y <set>))
((fluid-ref *equal?*) x y))
(define-method (write (x <set>) port)
(set-printer x port))
#;
(set-record-type-printer! <set> set-printer)
(set-object-property! <set> 'prolog-printer
(lambda (lp vl advanced?)
(if advanced-set-printer (set! advanced? #t))
......
......@@ -29,6 +29,10 @@
(define vsetx-empty)
(fluid-set! (@@ (ice-9 set complement) *equal?*)
(lambda (x y)
(vsetx-equal? #f x y)))
(<define> (ele0 x)
(<<match>> (#:mode -) ((<lookup> x))
(#(("op2-" k v))
......@@ -57,15 +61,23 @@
(<define> (ele x)
(<<match>> (#:mode -) ((<lookup> x))
(#(#:brace v)
(<and>
(<values> (a c) (ele1 v))
(cond
((eq? a vsetx-empty)
(<cc> c))
(else
(<cc> (make-set- a vsetx-empty (vosetx-difference S c a) #f #f))))))
(x (<cc> x))))
(#(#:brace v)
(<and>
(<values> (a c) (ele1 v))
(<cc> (make-set- a vsetx-empty (vosetx-difference S c a) #f #f))))
((a . b)
(<and>
(<values> (aa) (ele a))
(<values> (bb) (ele a))
(<cc> (cons aa bb))))
(#(l)
(<and>
(<values> (a) (ele l))
(<cc> (vector a))))
(x (<cc> x))))
(<define> (make-2 f x y)
......
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