From f5efa77d91f48f85a1551b694254f1d71857f584 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 13 Aug 2018 21:32:51 +0100
Subject: [PATCH] term-intersect

---
 syndicate/term.rkt | 77 +++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 73 insertions(+), 4 deletions(-)

diff --git a/syndicate/term.rkt b/syndicate/term.rkt
index 97092e6..42d404b 100644
--- a/syndicate/term.rkt
+++ b/syndicate/term.rkt
@@ -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")
+  )