syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

term-intersect

This commit is contained in:
Tony Garnock-Jones 2018-08-13 21:32:51 +01:00
parent 86412b273d
commit f5efa77d91
1 changed files with 73 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
syndicate/term.rkt
View File

@ -5,7 +5,8 @@
term->skeleton-proj
term->key
term->capture-proj
instantiate-term->value)
instantiate-term->value
term-intersect)
(require racket/match)
(require syndicate/support/struct)
@ -66,6 +67,13 @@
(lambda (key-rev) (list (reverse key-rev)))
(lambda (key-rev atom) (list))))
(define (struct-fields t)
(cdr (vector->list (struct->vector t))))
(define (struct-map f t)
(apply (struct-type-make-constructor (struct->struct-type t))
(map f (struct-fields t))))
(define (instantiate-term->value t actuals)
(define (pop-actual!)
(define v (car actuals))
@ -80,7 +88,7 @@
[(discard)
(void)]
[(? non-object-struct?)
(for-each pop-captures! (cdr (vector->list (struct->vector t))))]
(for-each pop-captures! (struct-fields t))]
[(? list?)
(for-each pop-captures! t)]
[(? vector?)
@ -95,8 +103,7 @@
[(discard)
(discard)]
[(? non-object-struct?)
(apply (struct-type-make-constructor (struct->struct-type t))
(map walk (cdr (vector->list (struct->vector t)))))]
(struct-map walk t)]
[(? list?)
(map walk t)]
[(? vector?)
@ -104,3 +111,65 @@
[other other]))
(walk t))
;; Omits captures.
(define (term-intersect t1 t2 ks kf)
(define (walk-lists xs1 xs2 ks)
(let inner ((xs1 xs1) (xs2 xs2) (acc '()))
(match* (xs1 xs2)
[('() '())
(ks (reverse acc))]
[((cons x1 xs1) (cons x2 xs2))
(walk x1 x2 (lambda (v) (inner xs1 xs2 (cons v acc))))]
[(_ _)
(kf)])))
(define (walk t1 t2 ks)
(match* (t1 t2)
[((capture d1) d2) (walk d1 d2 ks)]
[(d1 (capture d2)) (walk d1 d2 ks)]
[((discard) other) (ks other)]
[(other (discard)) (ks other)]
[((? non-object-struct?) (? non-object-struct?))
(define ty (struct->struct-type t1))
(if (eq? ty (struct->struct-type t2))
(walk-lists (struct-fields t1)
(struct-fields t2)
(lambda (vs) (ks (apply (struct-type-make-constructor ty) vs))))
(kf))]
[('() '()) (ks '())]
[((cons d1 t1) (cons d2 t2))
(walk d1 d2 (lambda (a) (walk t1 t2 (lambda (d) (ks (cons a d))))))]
[((? vector?) (? vector?))
(walk-lists (vector->list t1)
(vector->list t2)
(lambda (vs) (ks (list->vector vs))))]
[(_ _)
(if (equal? t1 t2)
(ks t1)
(kf))]))
(walk t1 t2 ks))
(module+ test
(require rackunit)
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c))
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'c 'b) values void) (void))
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a (discard) 'c) values void) (list 'a 'b 'c))
(check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c))
(check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b (discard)) values void)
(list 'a 'b 'c))
(check-equal? (term-intersect (vector 'a (discard) 'c) (vector 'a 'b (discard)) values void)
(vector 'a 'b 'c))
(struct X (A B C) #:transparent)
(check-equal? (term-intersect (X 'a (discard) 'c) (X 'a 'b (discard)) values void) (X 'a 'b 'c))
(check-equal? (term-intersect (X (capture 'a) (discard) 'c) (X 'a 'b (discard)) values void)
(X 'a 'b 'c))
(check-equal? (term-intersect (capture (X (capture 'a) (discard) 'c))
(X 'a (capture 'b) (discard))
values
void)
(X 'a 'b 'c))
(check-equal? (term-intersect 'a 'b values void) (void))
(check-equal? (term-intersect 'a 'a values void) 'a)
(check-equal? (term-intersect (cons 1 2) (cons 1 2) values void) (cons 1 2))
(check-equal? (term-intersect "hi" "hi" values void) "hi")
)