added a 'default-reify' function that works for neq, symbolo, numbero…

…, and absento. also cleanup

absento.rkt

@@ -31,13 +31,9 @@
     (findf (lambda (oc) (and (eq? (oc-rator oc) 'symbol-c) 
                              (eq? (car (oc-rands oc)) v))) c)))
 
-(define (reify-symbol-cs v r c)
-  (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'symbol-c)) c)])
-    (let ([ocs (map (lambda (oc) (walk (car (oc-rands oc)) r)) c)])
-      (let ([ocs (filter-not any/var? ocs)])
-        (cond
-         [(null? ocs) '()]
-         [else `((sym . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define reify-symbol-cs
+  (default-reify 'sym '(symbol-c)
+    (lambda (rands) (remove-duplicates (map car rands)))))
 
 ;; numbero
 
@@ -65,13 +61,15 @@
     (findf (lambda (oc) (and (eq? (oc-rator oc) 'number-c) 
                              (eq? (car (oc-rands oc)) v))) c)))
 
-(define (reify-number-cs v r c)
-  (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'number-c)) c)])
-    (let ([ocs (map (lambda (oc) (walk (car (oc-rands oc)) r)) c)])
-      (let ([ocs (filter-not any/var? ocs)])
-        (cond
-         [(null? ocs) '()]
-         [else `((num . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define remove-duplicates
+  (lambda (l)
+    (for/fold ([s '()])
+              ([x l])
+      (if (member x s) s (cons x s)))))
+
+(define reify-number-cs
+  (default-reify 'num '(number-c) 
+    (lambda (rands) (remove-duplicates (map car rands)))))
 
 ;; absento
 
@@ -127,16 +125,11 @@
   (lambda (u t s c)
     (cond
      ((unify `((,u . ,t)) s c) =>
-      (lambda (s0) (eq? s0 s)))
+      (lambda (s^) (eq? s ^s)))
      (else #f))))
 
-(define (reify-absent-cs v r c)
-  (let ([c (filter (lambda (oc) (eq? (oc-rator oc) 'absent-c)) c)])
-    (let ([ocs (map (lambda (oc) (walk* (oc-rands oc) r)) c)])
-      (let ([ocs (filter-not any/var? ocs)])
-        (cond
-         [(null? ocs) '()]
-         [else `((absento . ,(sort (remove-duplicates ocs) lex<=)))])))))
+(define reify-absent-cs
+  (default-reify 'absento '(absent-c) remove-duplicates))
 
 (define (absento-split u v)
   (lambdam@ (a : s c)
@@ -189,12 +182,6 @@
       ((== #f x) succeed)
       ((== #t x) succeed))))
 
-(define remove-duplicates
-  (lambda (l)
-    (for/fold ([s '()])
-              ([x l])
-      (if (member x s) s (cons x s)))))
-
 ;; ckanren stuffs
 
 (extend-enforce-fns 'absento rerun-type-cs)

ck.rkt

@@ -15,7 +15,7 @@
  gen:mk-struct recur constructor mk-struct? unifiable?
  lex<= sort-by-lex<= reify-with-colon occurs-check
  run-constraints build-attr-oc attr-oc? attr-oc-uw?
- get-attributes filter/rator filter-not/rator
+ get-attributes filter/rator filter-not/rator default-reify
  (for-syntax build-srcloc))
 
 ;; == VARIABLES =================================================================
@@ -570,11 +570,17 @@
         [else `(,v . ,(sort-store c^))])))))
 
 ;; runs all the reification functions
-(define run-reify-fns
-  (lambda (v r c)
-    (for/fold ([c^ `()])
-              ([fn (map cdr (reify-fns))])
-       (append (fn v r c) c^))))
+(define (run-reify-fns v r c)
+  (for/fold ([c^ `()])
+            ([fn (map cdr (reify-fns))])
+    (append (fn v r c) c^)))
+
+(define ((default-reify sym cs fn) v r c)
+  (let ((c (filter (lambda (oc) (memq (oc-rator oc) cs)) c)))
+    (let ((rands (filter-not any/var? (walk* (map oc-rands c) r))))
+      (cond
+       ((null? rands) `())
+       (else `((,sym . ,(sort (fn rands) lex<=))))))))
 
 (define (sort-store c) (sort c lex<= #:key car))
 

neq.rkt

@@ -31,28 +31,16 @@
 
 (define reify-prefix-dot (make-parameter #t))
 
-(define reify-constraintsneq
-  (lambda (v r c)
-    (let ((c (filter (lambda (oc) (eq? (oc-rator oc) '=/=neq-c)) c)))
-      (let ((p* (walk* (map oc-prefix c) r)))
-        (let ((p* (sort-p* (filter-not any/var? p*))))
-          (cond
-            ((null? p*) '())
-            ((reify-prefix-dot) `((=/= . ,p*)))
-            (else `((=/= . ,(map remove-dots p*))))))))))
-
 (define (remove-dots p*)
-  (map (lambda (p) (list (car p) (cdr p))) p*))
-
-(define (sort-p* p*)
-  (sort-by-lex<=
-   (map (lambda (p)
-          (sort-by-lex<=
-           (map (lambda (a)
-                 (let ([u (car a)] [v (cdr a)])
-                   (sort-diseq u v)))
-               p)))
-        p*)))
+  (cond
+   [(reify-prefix-dot) p*]
+   [else (map (lambda (p) (list (car p) (cdr p))) p*)]))
+
+(define (sort-ps p*)
+  (map (lambda (p)
+         (sort-by-lex<=
+          (map (lambda (a) (sort-diseq (car a) (cdr a))) p)))
+       p*))
 
 (define (sort-diseq u v)
   (cond
@@ -63,6 +51,14 @@
   ((lex<= u v) (cons u v))
   (else (cons v u))))
 
+(define reify-constraintsneq 
+  (default-reify 
+    '=/= 
+    '(=/=neq-c)
+    (lambda (rands)
+      (let ([p* (map car rands)])
+        (map remove-dots (sort-ps p*))))))
+
 (define =/=neq-c
   (lambda (p)
     (lambdam@ (a : s c)