Skip to content
This repository
Browse code

added a unifiable? predicate to mk-structs, so unify can deal with in…

…heritance
  • Loading branch information...
commit 29a4c92c887c2f22f9c575e6984eed588679560f 1 parent 4778362
Claire Alvis authored April 01, 2013
2  README.md
Source Rendered
... ...
@@ -1,4 +1,4 @@
1  
-Copyright (C) 2011 Daniel P. Friedman, Oleg Kiselyov,
  1
+Copyright (C) 2011-2013 Daniel P. Friedman, Oleg Kiselyov,
2 2
 Claire E. Alvis, Jeremiah J. Willcock, Kyle M. Carter, William E. Byrd
3 3
 
4 4
 Permission is hereby granted, free of charge, to any person obtaining a copy
2  ak.rkt
@@ -40,6 +40,8 @@
40 40
    (define (constructor tie)
41 41
      (lambda (a t-ls)
42 42
        (make-tie a (car t-ls))))
  43
+   (define (unifiable? tie x) 
  44
+     (tie? x))
43 45
    (define (mk-struct->sexp tie)
44 46
      `(tie ,(tie-a tie) ,(tie-t tie)))])
45 47
 
7  ck.rkt
@@ -12,7 +12,7 @@
12 12
  conde conda condu ifa ifu project fresh succeed fail
13 13
  lambdaf@ inc enforce-constraints reify empty-a take
14 14
  format-source define-cvar-type reify-cvar var ext-s
15  
- gen:mk-struct recur constructor mk-struct? 
  15
+ gen:mk-struct recur constructor mk-struct? unifiable?
16 16
  lex<= sort-by-lex<= reify-with-colon occurs-check
17 17
  (for-syntax build-srcloc))
18 18
 
@@ -257,6 +257,9 @@
257 257
   ;; arguments like the arguments to k
258 258
   (constructor mk-struct)
259 259
 
  260
+  ;; determines whether mk-struct can unify with x
  261
+  (unifiable? mk-struct x)
  262
+
260 263
   ;; for reification 
261 264
   (mk-struct->sexp mk-struct)
262 265
 
@@ -265,6 +268,7 @@
265 268
     (define (recur p k)
266 269
       (k (car p) (cdr p)))
267 270
     (define (constructor p) cons)
  271
+    (define (unifiable? p x) (pair? x))
268 272
     (define (mk-struct->sexp v) v)]
269 273
    [vector?
270 274
     (define (recur v k)
@@ -272,6 +276,7 @@
272 276
         (k (car v) (cdr v))))
273 277
     (define (constructor v)
274 278
       (compose list->vector cons))
  279
+    (define (unifiable? v x) (vector? x))
275 280
     (define (mk-struct->sexp v) v)]))
276 281
 
277 282
 ;; == SUBSTITUTIONS ============================================================
8  tests/vector.rkt
@@ -17,4 +17,10 @@
17 17
                 (fresh (x y)
18 18
                   (== (vector x 2) (vector 1 y))
19 19
                   (== q `(,x ,y))))
20  
-              `((1 2))))
  20
+              `((1 2)))
  21
+  
  22
+  (test-check "3"
  23
+              (run* (q)
  24
+                 (== (vector 1 2) (list 1 2)))
  25
+              `())
  26
+  )
47  tree-unify.rkt
@@ -5,6 +5,12 @@
5 5
 
6 6
 ;; ---UNIFICATION--------------------------------------------------
7 7
 
  8
+(define (unifiable-structs? u v)
  9
+  (and (mk-struct? u)
  10
+       (mk-struct? v)
  11
+       (unifiable? u v)
  12
+       (unifiable? v u)))
  13
+
8 14
 (define (unify e s)
9 15
   (cond
10 16
    ((null? e) s)
@@ -19,8 +25,7 @@
19 25
          ((var? v)
20 26
           (and (not (occurs-check v u s))
21 27
                (unify e (ext-s v u s))))
22  
-         ((and (mk-struct? u)
23  
-               (mk-struct? v))
  28
+         ((unifiable-structs? u v)
24 29
           (recur u 
25 30
            (lambda (ua ud)
26 31
              (recur v
@@ -31,24 +36,22 @@
31 36
 
32 37
 ;; ---GOAL---------------------------------------------------------
33 38
 
34  
-(define == (lambda (u v) (goal-construct (==-c u v))))
35  
-
36  
-(define ==-c
37  
-  (lambda (u v)
38  
-    (lambdam@ (a : s c)
39  
-              (cond
40  
-                ((unify `((,u . ,v)) s)
41  
-                 => (lambda (s^)
42  
-                      ((update-prefix s s^) a)))
43  
-                (else #f)))))
44  
-
45  
-(define update-prefix
46  
-  (lambda (s s^)
47  
-    (let loop ((s^ s^))
48  
-      (cond
49  
-        ((eq? s s^) identitym)
50  
-        (else
51  
-         (composem
52  
-          (update-s (caar s^) (cdar s^))
53  
-          (loop (cdr s^))))))))
  39
+(define (== u v) (goal-construct (==-c u v)))
  40
+
  41
+(define (==-c u v)
  42
+  (lambdam@ (a : s c)
  43
+    (cond
  44
+     ((unify `((,u . ,v)) s)
  45
+      => (lambda (s^)
  46
+           ((update-prefix s s^) a)))
  47
+     (else #f))))
  48
+
  49
+(define (update-prefix s s^)
  50
+  (let loop ((s^ s^))
  51
+    (cond
  52
+     ((eq? s s^) identitym)
  53
+     (else
  54
+      (composem
  55
+       (update-s (caar s^) (cdar s^))
  56
+       (loop (cdr s^)))))))
54 57
 

0 notes on commit 29a4c92

Please sign in to comment.
Something went wrong with that request. Please try again.